(* 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>Specifying list insertion\<close>

theory Insert_Spec
  imports OpSet
begin

text\<open>In this section we consider only list insertion. We model an insertion
operation as a pair (\isa{ID, ref}), where \isa{ref} is either \isa{None}
(signifying an insertion at the head of the list) or \isa{Some r}
(an insertion immediately after a reference element with ID \isa{r}).
If the reference element does not exist, the operation does nothing.

We provide two different definitions of the interpretation function for list
insertion: \isa{insert-spec} and \isa{insert-alt}. The \isa{insert-alt} definition
matches the paper, while \isa{insert-spec} uses the Isabelle/HOL list datatype,
making it more suitable for formal reasoning. In a later subsection we prove
that the two definitions are in fact equivalent.\<close>

fun insert_spec :: "'oid list \<Rightarrow> ('oid \<times> 'oid option) \<Rightarrow> 'oid list" where
  "insert_spec xs     (oid, None)     = oid#xs" |
  "insert_spec []     (oid, _)        = []" |
  "insert_spec (x#xs) (oid, Some ref) =
     (if x = ref then x # oid # xs
                 else x # (insert_spec xs (oid, Some ref)))"

fun insert_alt :: "('oid \<times> 'oid option) set \<Rightarrow> ('oid \<times> 'oid) \<Rightarrow> ('oid \<times> 'oid option) set" where
  "insert_alt list_rel (oid, ref) = (
      if \<exists>n. (ref, n) \<in> list_rel
      then {(p, n) \<in> list_rel. p \<noteq> ref} \<union> {(ref, Some oid)} \<union>
           {(i, n). i = oid \<and> (ref, n) \<in> list_rel}
      else list_rel)"

text\<open>\isa{interp-ins} is the sequential interpretation of a set of insertion
operations. It starts with an empty list as initial state, and then applies
the operations from left to right.\<close>

definition interp_ins :: "('oid \<times> 'oid option) list \<Rightarrow> 'oid list" where
  "interp_ins ops \<equiv> foldl insert_spec [] ops"

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

text\<open>We now specialise the definitions from the abstract OpSet section for list
insertion. \isa{insert-opset} is an opset consisting only of insertion operations,
and \isa{insert-ops} is the specialisation of the \isa{spec-ops} predicate for
insertion operations. We prove several useful lemmas about \isa{insert-ops}.\<close>

locale insert_opset = opset opset set_option
  for opset :: "('oid::{linorder} \<times> 'oid option) set"

definition insert_ops :: "('oid::{linorder} \<times> 'oid option) list \<Rightarrow> bool" where
  "insert_ops list \<equiv> spec_ops list set_option"

lemma insert_ops_NilI [intro!]:
  shows "insert_ops []"
  by (auto simp add: insert_ops_def spec_ops_def)

lemma insert_ops_rem_last [dest]:
  assumes "insert_ops (xs @ [x])"
  shows "insert_ops xs"
  using assms insert_ops_def spec_ops_rem_last by blast

lemma insert_ops_rem_cons:
  assumes "insert_ops (x # xs)"
  shows "insert_ops xs"
  using assms insert_ops_def spec_ops_rem_cons by blast

lemma insert_ops_appendD:
  assumes "insert_ops (xs @ ys)"
  shows "insert_ops xs"
  using assms by (induction ys rule: List.rev_induct,
      auto, metis insert_ops_rem_last append_assoc)

lemma insert_ops_rem_prefix:
  assumes "insert_ops (pre @ suf)"
  shows "insert_ops suf"
  using assms proof(induction pre)
  case Nil
  then show "insert_ops ([] @ suf) \<Longrightarrow> insert_ops suf"
    by auto
next
  case (Cons a pre)
  have "sorted (map fst suf)"
    using assms by (simp add: insert_ops_def sorted_append spec_ops_def)
  moreover have "distinct (map fst suf)"
    using assms by (simp add: insert_ops_def spec_ops_def)
  ultimately show "insert_ops ((a # pre) @ suf) \<Longrightarrow> insert_ops suf"
    by (simp add: insert_ops_def spec_ops_def)
qed

lemma insert_ops_remove1:
  assumes "insert_ops xs"
  shows "insert_ops (remove1 x xs)"
  using assms insert_ops_def spec_ops_remove1 by blast

lemma last_op_greatest:
  assumes "insert_ops (op_list @ [(oid, oper)])"
    and "x \<in> set (map fst op_list)"
  shows "x < oid"
  using assms spec_ops_id_inc insert_ops_def by metis

lemma insert_ops_ref_older:
  assumes "insert_ops (pre @ [(oid, Some ref)] @ suf)"
  shows "ref < oid"
  using assms by (auto simp add: insert_ops_def spec_ops_def)

lemma insert_ops_memb_ref_older:
  assumes "insert_ops op_list"
    and "(oid, Some ref) \<in> set op_list"
  shows "ref < oid"
  using assms insert_ops_ref_older split_list_first by fastforce

subsection \<open>Properties of the \isa{insert-spec} function\<close>

lemma insert_spec_none [simp]:
  shows "set (insert_spec xs (oid, None)) = set xs \<union> {oid}"
  by (induction xs, auto simp add: insert_commute sup_commute)

lemma insert_spec_set [simp]:
  assumes "ref \<in> set xs"
  shows "set (insert_spec xs (oid, Some ref)) = set xs \<union> {oid}"
  using assms proof(induction xs)
  assume "ref \<in> set []"
  thus "set (insert_spec [] (oid, Some ref)) = set [] \<union> {oid}"
    by auto
next
  fix a xs
  assume "ref \<in> set xs \<Longrightarrow> set (insert_spec xs (oid, Some ref)) = set xs \<union> {oid}"
    and "ref \<in> set (a#xs)"
  thus "set (insert_spec (a#xs) (oid, Some ref)) = set (a#xs) \<union> {oid}"
    by(cases "a = ref", auto simp add: insert_commute sup_commute)
qed

lemma insert_spec_nonex [simp]:
  assumes "ref \<notin> set xs"
  shows "insert_spec xs (oid, Some ref) = xs"
  using assms proof(induction xs)
  show "insert_spec [] (oid, Some ref) = []"
    by simp
next
  fix a xs
  assume "ref \<notin> set xs \<Longrightarrow> insert_spec xs (oid, Some ref) = xs"
    and "ref \<notin> set (a#xs)"
  thus "insert_spec (a#xs) (oid, Some ref) = a#xs"
    by(cases "a = ref", auto simp add: insert_commute sup_commute)
qed

lemma list_greater_non_memb:
  fixes oid :: "'oid::{linorder}"
  assumes "\<And>x. x \<in> set xs \<Longrightarrow> x < oid"
    and "oid \<in> set xs"
  shows "False"
  using assms by blast

lemma inserted_item_ident:
  assumes "a \<in> set (insert_spec xs (e, i))"
    and "a \<notin> set xs"
  shows "a = e"
  using assms proof(induction xs)
  case Nil
  then show "a = e" by (cases i, auto)
next
  case (Cons x xs)
  then show "a = e"
  proof(cases i)
    case None
    then show "a = e" using assms by auto
  next
    case (Some ref)
    then show "a = e" using Cons by (case_tac "x = ref", auto)
  qed
qed

lemma insert_spec_distinct [intro]:
  fixes oid :: "'oid::{linorder}"
  assumes "distinct xs"
    and "\<And>x. x \<in> set xs \<Longrightarrow> x < oid"
    and "ref = Some r \<longrightarrow> r < oid"
  shows "distinct (insert_spec xs (oid, ref))"
  using assms(1) assms(2) proof(induction xs)
  show "distinct (insert_spec [] (oid, ref))"
    by(cases ref, auto)
next
  fix a xs
  assume IH: "distinct xs \<Longrightarrow> (\<And>x. x \<in> set xs \<Longrightarrow> x < oid) \<Longrightarrow> distinct (insert_spec xs (oid, ref))"
    and D: "distinct (a#xs)"
    and L: "\<And>x. x \<in> set (a#xs) \<Longrightarrow> x < oid"
  show "distinct (insert_spec (a#xs) (oid, ref))"
  proof(cases "ref")
    assume "ref = None"
    thus "distinct (insert_spec (a#xs) (oid, ref))"
      using D L by auto
  next
    fix id
    assume S: "ref = Some id"
    {
      assume EQ: "a = id"
      hence "id \<noteq> oid"
        using D L by auto
      moreover have "id \<notin> set xs"
        using D EQ by auto
      moreover have "oid \<notin> set xs"
        using L by auto
      ultimately have "id \<noteq> oid \<and> id \<notin> set xs \<and> oid \<notin> set xs \<and> distinct xs"
        using D by auto
    }
    note T = this
    {
      assume NEQ: "a \<noteq> id"
      have 0: "a \<notin> set (insert_spec xs (oid, Some id))"
        using D L by(metis distinct.simps(2) insert_spec.simps(1) insert_spec_none insert_spec_nonex
            insert_spec_set insert_iff list.set(2) not_less_iff_gr_or_eq)
      have 1: "distinct xs"
        using D by auto
      have "\<And>x. x \<in> set xs \<Longrightarrow> x < oid"
        using L by auto
      hence "distinct (insert_spec xs (oid, Some id))"
        using S IH[OF 1] by blast
      hence "a \<notin> set (insert_spec xs (oid, Some id)) \<and> distinct (insert_spec xs (oid, Some id))"
        using 0 by auto
    }
    from this S T show "distinct (insert_spec (a # xs) (oid, ref))"
      by clarsimp
  qed
qed

lemma insert_after_ref:
  assumes "distinct (xs @ ref # ys)"
  shows "insert_spec (xs @ ref # ys) (oid, Some ref) = xs @ ref # oid # ys"
  using assms by (induction xs, auto)

lemma insert_somewhere:
  assumes "ref = None \<or> (ref = Some r \<and> r \<in> set list)"
  shows "\<exists>xs ys. list = xs @ ys \<and> insert_spec list (oid, ref) = xs @ oid # ys"
  using assms proof(induction list)
  assume "ref = None \<or> ref = Some r \<and> r \<in> set []"
  thus "\<exists>xs ys. [] = xs @ ys \<and> insert_spec [] (oid, ref) = xs @ oid # ys"
  proof
    assume "ref = None"
    thus "\<exists>xs ys. [] = xs @ ys \<and> insert_spec [] (oid, ref) = xs @ oid # ys"
      by auto
  next
    assume "ref = Some r \<and> r \<in> set []"
    thus "\<exists>xs ys. [] = xs @ ys \<and> insert_spec [] (oid, ref) = xs @ oid # ys"
      by auto
  qed
next
  fix a list
  assume 1: "ref = None \<or> ref = Some r \<and> r \<in> set (a#list)"
    and IH: "ref = None \<or> ref = Some r \<and> r \<in> set list \<Longrightarrow>
         \<exists>xs ys. list = xs @ ys \<and> insert_spec list (oid, ref) = xs @ oid # ys"
  show "\<exists>xs ys. a # list = xs @ ys \<and> insert_spec (a # list) (oid, ref) = xs @ oid # ys"
  proof(rule disjE[OF 1])
    assume "ref = None"
    thus "\<exists>xs ys. a # list = xs @ ys \<and> insert_spec (a # list) (oid, ref) = xs @ oid # ys"
      by force
  next
    assume "ref = Some r \<and> r \<in> set (a # list)"
    hence 2: "r = a \<or> r \<in> set list" and 3: "ref = Some r"
      by auto
    show "\<exists>xs ys. a # list = xs @ ys \<and> insert_spec (a # list) (oid, ref) = xs @ oid # ys"
    proof(rule disjE[OF 2])
      assume "r = a"
      thus "\<exists>xs ys. a # list = xs @ ys \<and> insert_spec (a # list) (oid, ref) = xs @ oid # ys"
        using 3 by(metis append_Cons append_Nil insert_spec.simps(3))
    next
      assume "r \<in> set list"
      from this obtain xs ys
        where "list = xs @ ys \<and> insert_spec list (oid, ref) = xs @ oid # ys"
        using IH 3 by auto
      thus "\<exists>xs ys. a # list = xs @ ys \<and> insert_spec (a # list) (oid, ref) = xs @ oid # ys"
        using 3 by clarsimp (metis append_Cons append_Nil)
    qed
  qed
qed

lemma insert_first_part:
  assumes "ref = None \<or> (ref = Some r \<and> r \<in> set xs)"
  shows "insert_spec (xs @ ys) (oid, ref) = (insert_spec xs (oid, ref)) @ ys"
  using assms proof(induction ys rule: rev_induct)
  assume "ref = None \<or> ref = Some r \<and> r \<in> set xs"
  thus "insert_spec (xs @ []) (oid, ref) = insert_spec xs (oid, ref) @ []"
    by auto
next
  fix x xsa
  assume IH: "ref = None \<or> ref = Some r \<and> r \<in> set xs \<Longrightarrow> insert_spec (xs @ xsa) (oid, ref) = insert_spec xs (oid, ref) @ xsa"
    and "ref = None \<or> ref = Some r \<and> r \<in> set xs"
  thus "insert_spec (xs @ xsa @ [x]) (oid, ref) = insert_spec xs (oid, ref) @ xsa @ [x]"
  proof(induction xs)
    assume "ref = None \<or> ref = Some r \<and> r \<in> set []"
    thus "insert_spec ([] @ xsa @ [x]) (oid, ref) = insert_spec [] (oid, ref) @ xsa @ [x]"
      by auto
  next
    fix a xs
    assume 1: "ref = None \<or> ref = Some r \<and> r \<in> set (a # xs)"
      and 2: "((ref = None \<or> ref = Some r \<and> r \<in> set xs \<Longrightarrow> insert_spec (xs @ xsa) (oid, ref) = insert_spec xs (oid, ref) @ xsa) \<Longrightarrow>
             ref = None \<or> ref = Some r \<and> r \<in> set xs \<Longrightarrow> insert_spec (xs @ xsa @ [x]) (oid, ref) = insert_spec xs (oid, ref) @ xsa @ [x])"
      and 3: "(ref = None \<or> ref = Some r \<and> r \<in> set (a # xs) \<Longrightarrow> insert_spec ((a # xs) @ xsa) (oid, ref) = insert_spec (a # xs) (oid, ref) @ xsa)"
    show "insert_spec ((a # xs) @ xsa @ [x]) (oid, ref) = insert_spec (a # xs) (oid, ref) @ xsa @ [x]"
    proof(rule disjE[OF 1])
      assume "ref = None"
      thus "insert_spec ((a # xs) @ xsa @ [x]) (oid, ref) = insert_spec (a # xs) (oid, ref) @ xsa @ [x]"
        by auto
    next
      assume "ref = Some r \<and> r \<in> set (a # xs)"
      thus "insert_spec ((a # xs) @ xsa @ [x]) (oid, ref) = insert_spec (a # xs) (oid, ref) @ xsa @ [x]"
        using 2 3 by auto
    qed
  qed
qed

lemma insert_second_part:
  assumes "ref = Some r"
    and "r \<notin> set xs"
    and "r \<in> set ys"
  shows "insert_spec (xs @ ys) (oid, ref) = xs @ (insert_spec ys (oid, ref))"
  using assms proof(induction xs)
  assume "ref = Some r"
  thus "insert_spec ([] @ ys) (oid, ref) = [] @ insert_spec ys (oid, ref)"
    by auto
next
  fix a xs
  assume "ref = Some r" and "r \<notin> set (a # xs)" and "r \<in> set ys"
    and "ref = Some r \<Longrightarrow> r \<notin> set xs \<Longrightarrow> r \<in> set ys \<Longrightarrow> insert_spec (xs @ ys) (oid, ref) = xs @ insert_spec ys (oid, ref)"
  thus "insert_spec ((a # xs) @ ys) (oid, ref) = (a # xs) @ insert_spec ys (oid, ref)"
    by auto
qed

subsection \<open>Properties of the \isa{interp-ins} function\<close>

lemma interp_ins_empty [simp]:
  shows "interp_ins [] = []"
  by (simp add: interp_ins_def)

lemma interp_ins_tail_unfold:
  shows "interp_ins (xs @ [x]) = insert_spec (interp_ins xs) x"
  by (clarsimp simp add: interp_ins_def)

lemma interp_ins_subset [simp]:
  shows "set (interp_ins op_list) \<subseteq> set (map fst op_list)"
proof(induction op_list rule: List.rev_induct)
  case Nil
  then show "set (interp_ins []) \<subseteq> set (map fst [])"
    by (simp add: interp_ins_def)
next
  case (snoc x xs)
  hence IH: "set (interp_ins xs) \<subseteq> set (map fst xs)"
    using interp_ins_def by blast
  obtain oid ref where x_pair: "x = (oid, ref)"
    by fastforce
  hence spec: "interp_ins (xs @ [x]) = insert_spec (interp_ins xs) (oid, ref)"
    by (simp add: interp_ins_def)
  then show "set (interp_ins (xs @ [x])) \<subseteq> set (map fst (xs @ [x]))"
  proof(cases ref)
    case None
    then show "set (interp_ins (xs @ [x])) \<subseteq> set (map fst (xs @ [x]))"
      using IH spec x_pair by auto
  next
    case (Some a)
    then show "set (interp_ins (xs @ [x])) \<subseteq> set (map fst (xs @ [x]))"
      using IH spec x_pair by (cases "a \<in> set (interp_ins xs)", auto)
  qed
qed

lemma interp_ins_distinct:
  assumes "insert_ops op_list"
  shows "distinct (interp_ins op_list)"
  using assms proof(induction op_list rule: rev_induct)
  case Nil
  then show "distinct (interp_ins [])"
    by (simp add: interp_ins_def)
next
  case (snoc x xs)
  hence IH: "distinct (interp_ins xs)" by blast
  obtain oid ref where x_pair: "x = (oid, ref)" by force
  hence "\<forall>x \<in> set (map fst xs). x < oid"
    using last_op_greatest snoc.prems by blast
  hence "\<forall>x \<in> set (interp_ins xs). x < oid"
    using interp_ins_subset by fastforce
  hence "distinct (insert_spec (interp_ins xs) (oid, ref))"
    using IH insert_spec_distinct insert_spec_nonex by metis
  then show "distinct (interp_ins (xs @ [x]))"
    by (simp add: x_pair interp_ins_tail_unfold)
qed

subsection \<open>Equivalence of the two definitions of insertion\<close>

text\<open>At the beginning of this section we gave two different definitions of
interpretation functions for list insertion: \isa{insert-spec} and
\isa{insert-alt}. In this section we prove that the two are equivalent.

We first define how to derive the successor relation from an Isabelle list.
This relation contains (\isa{id}, \isa{None}) if \isa{id} is the last element
of the list, and (\isa{id1}, \isa{id2}) if \isa{id1} is immediately
followed by \isa{id2} in the list.\<close>

fun succ_rel :: "'oid list \<Rightarrow> ('oid \<times> 'oid option) set" where
  "succ_rel [] = {}" |
  "succ_rel [head] = {(head, None)}" |
  "succ_rel (head#x#xs) = {(head, Some x)} \<union> succ_rel (x#xs)"

text\<open>\isa{interp-alt} is the equivalent of \isa{interp-ins}, but using
\isa{insert-alt} instead of \isa{insert-spec}. To match the paper, it uses a
distinct head element to refer to the beginning of the list.\<close>

definition interp_alt :: "'oid \<Rightarrow> ('oid \<times> 'oid option) list \<Rightarrow> ('oid \<times> 'oid option) set" where
  "interp_alt head ops \<equiv> foldl insert_alt {(head, None)}
     (map (\<lambda>x. case x of
            (oid, None)     \<Rightarrow> (oid, head) |
            (oid, Some ref) \<Rightarrow> (oid, ref))
      ops)"

lemma succ_rel_set_fst:
  shows "fst ` (succ_rel xs) = set xs"
  by (induction xs rule: succ_rel.induct, auto)

lemma succ_rel_functional:
  assumes "(a, b1) \<in> succ_rel xs"
    and "(a, b2) \<in> succ_rel xs"
    and "distinct xs"
  shows "b1 = b2"
  using assms proof(induction xs rule: succ_rel.induct)
  case 1
  then show ?case by simp
next
  case (2 head)
  then show ?case by simp
next
  case (3 head x xs)
  then show ?case
  proof(cases "a = head")
    case True
    hence "a \<notin> set (x#xs)"
      using 3 by auto
    hence "a \<notin> fst ` (succ_rel (x#xs))"
      using succ_rel_set_fst by metis
    then show "b1 = b2"
      using 3 image_iff by fastforce
  next
    case False
    hence "{(a, b1), (a, b2)} \<subseteq> succ_rel (x#xs)"
      using 3 by auto
    moreover have "distinct (x#xs)"
      using 3 by auto
    ultimately show "b1 = b2"
      using "3.IH" by auto
  qed
qed

lemma succ_rel_rem_head:
  assumes "distinct (x # xs)"
  shows "{(p, n) \<in> succ_rel (x # xs). p \<noteq> x} = succ_rel xs"
proof -
  have head_notin: "x \<notin> fst ` succ_rel xs"
    using assms by (simp add: succ_rel_set_fst)
  moreover obtain y where "(x, y) \<in> succ_rel (x # xs)"
    by (cases xs, auto)
  moreover have "succ_rel (x # xs) = {(x, y)} \<union> succ_rel xs"
    using calculation head_notin image_iff by (cases xs, fastforce+)
  moreover from this have "\<And>n. (x, n) \<in> succ_rel (x # xs) \<Longrightarrow> n = y"
    by (metis Pair_inject fst_conv head_notin image_eqI insertE insert_is_Un)
  hence "{(p, n) \<in> succ_rel (x # xs). p \<noteq> x} = succ_rel (x # xs) - {(x, y)}"
    by blast
  moreover have "succ_rel (x # xs) - {(x, y)} = succ_rel xs"
    using image_iff calculation by fastforce
  ultimately show "{(p, n) \<in> succ_rel (x # xs). p \<noteq> x} = succ_rel xs"
    by simp
qed

lemma succ_rel_swap_head:
  assumes "distinct (ref # list)"
    and "(ref, n) \<in> succ_rel (ref # list)"
  shows "succ_rel (oid # list) = {(oid, n)} \<union> succ_rel list"
proof(cases list)
  case Nil
  then show ?thesis using assms by auto
next
  case (Cons a list)
  moreover from this have "n = Some a"
    by (metis Un_iff assms singletonI succ_rel.simps(3) succ_rel_functional)
  ultimately show ?thesis by simp
qed

lemma succ_rel_insert_alt:
  assumes "a \<noteq> ref"
    and "distinct (oid # a # b # list)"
  shows "insert_alt (succ_rel (a # b # list)) (oid, ref) =
         {(a, Some b)} \<union> insert_alt (succ_rel (b # list)) (oid, ref)"
proof(cases "\<exists>n. (ref, n) \<in> succ_rel (a # b # list)")
  case True
  hence "insert_alt (succ_rel (a # b # list)) (oid, ref) =
           {(p, n) \<in> succ_rel (a # b # list). p \<noteq> ref} \<union> {(ref, Some oid)} \<union>
           {(i, n). i = oid \<and> (ref, n) \<in> succ_rel (a # b # list)}"
    by simp
  moreover have "{(p, n) \<in> succ_rel (a # b # list). p \<noteq> ref} =
                 {(a, Some b)} \<union> {(p, n) \<in> succ_rel (b # list). p \<noteq> ref}"
    using assms(1) by auto
  moreover have "insert_alt (succ_rel (b # list)) (oid, ref) =
           {(p, n) \<in> succ_rel (b # list). p \<noteq> ref} \<union> {(ref, Some oid)} \<union>
           {(i, n). i = oid \<and> (ref, n) \<in> succ_rel (b # list)}"
  proof -
    have "\<exists>n. (ref, n) \<in> succ_rel (b # list)"
      using assms(1) True by auto
    thus ?thesis by simp
  qed
  moreover have "{(i, n). i = oid \<and> (ref, n) \<in> succ_rel (a # b # list)} =
                 {(i, n). i = oid \<and> (ref, n) \<in> succ_rel (b # list)}"
    using assms(1) by auto
  ultimately show ?thesis by simp
next
  case False
  then show ?thesis by auto
qed

lemma succ_rel_insert_head:
  assumes "distinct (ref # list)"
  shows "succ_rel (insert_spec (ref # list) (oid, Some ref)) =
         insert_alt (succ_rel (ref # list)) (oid, ref)"
proof -
  obtain n where ref_in_rel: "(ref, n) \<in> succ_rel (ref # list)"
    by (cases list, auto)
  moreover from this have "{(p, n) \<in> succ_rel (ref # list). p \<noteq> ref} = succ_rel list"
    using assms succ_rel_rem_head by (metis (mono_tags, lifting))
  moreover have "{(i, n). i = oid \<and> (ref, n) \<in> succ_rel (ref # list)} = {(oid, n)}"
  proof -
    have "\<And>nx. (ref, nx) \<in> succ_rel (ref # list) \<Longrightarrow> nx = n"
      using assms by (simp add: succ_rel_functional ref_in_rel)
    hence "{(i, n) \<in> succ_rel (ref # list). i = ref} \<subseteq> {(ref, n)}"
      by blast
    moreover have "{(ref, n)} \<subseteq> {(i, n) \<in> succ_rel (ref # list). i = ref}"
      by (simp add: ref_in_rel)
    ultimately show ?thesis by blast
  qed
  moreover have "insert_alt (succ_rel (ref # list)) (oid, ref) =
                   {(p, n) \<in> succ_rel (ref # list). p \<noteq> ref} \<union> {(ref, Some oid)} \<union>
                   {(i, n). i = oid \<and> (ref, n) \<in> succ_rel (ref # list)}"
  proof -
    have "\<exists>n. (ref, n) \<in> succ_rel (ref # list)"
      using ref_in_rel by blast
    thus ?thesis by simp
  qed
  ultimately have "insert_alt (succ_rel (ref # list)) (oid, ref) =
                   succ_rel list \<union> {(ref, Some oid)} \<union> {(oid, n)}"
    by simp
  moreover have "succ_rel (oid # list) = {(oid, n)} \<union> succ_rel list"
    using assms ref_in_rel succ_rel_swap_head by metis
  hence "succ_rel (ref # oid # list) = {(ref, Some oid), (oid, n)} \<union> succ_rel list"
    by auto
  ultimately show "succ_rel (insert_spec (ref # list) (oid, Some ref)) =
                   insert_alt (succ_rel (ref # list)) (oid, ref)"
    by auto
qed

lemma succ_rel_insert_later:
  assumes "succ_rel (insert_spec (b # list) (oid, Some ref)) =
           insert_alt (succ_rel (b # list)) (oid, ref)"
    and "a \<noteq> ref"
    and "distinct (a # b # list)"
  shows "succ_rel (insert_spec (a # b # list) (oid, Some ref)) =
         insert_alt (succ_rel (a # b # list)) (oid, ref)"
proof -
  have "succ_rel (a # b # list) = {(a, Some b)} \<union> succ_rel (b # list)"
    by simp
  moreover have "insert_spec (a # b # list) (oid, Some ref) =
                 a # (insert_spec (b # list) (oid, Some ref))"
    using assms(2) by simp
  hence "succ_rel (insert_spec (a # b # list) (oid, Some ref)) =
         {(a, Some b)} \<union> succ_rel (insert_spec (b # list) (oid, Some ref))"
    by auto
  hence "succ_rel (insert_spec (a # b # list) (oid, Some ref)) =
         {(a, Some b)} \<union> insert_alt (succ_rel (b # list)) (oid, ref)"
    using assms(1) by auto
  moreover have "insert_alt (succ_rel (a # b # list)) (oid, ref) =
                 {(a, Some b)} \<union> insert_alt (succ_rel (b # list)) (oid, ref)"
    using succ_rel_insert_alt assms(2) by auto
  ultimately show ?thesis by blast
qed

lemma succ_rel_insert_Some:
  assumes "distinct list"
  shows "succ_rel (insert_spec list (oid, Some ref)) = insert_alt (succ_rel list) (oid, ref)"
  using assms proof(induction list)
  case Nil
  then show "succ_rel (insert_spec [] (oid, Some ref)) = insert_alt (succ_rel []) (oid, ref)"
    by simp
next
  case (Cons a list)
  hence "distinct (a # list)"
    by simp
  then show "succ_rel (insert_spec (a # list) (oid, Some ref)) =
             insert_alt (succ_rel (a # list)) (oid, ref)"
  proof(cases "a = ref")
    case True
    then show ?thesis
      using succ_rel_insert_head \<open>distinct (a # list)\<close> by metis
  next
    case False
    hence "a \<noteq> ref" by simp
    moreover have "succ_rel (insert_spec list (oid, Some ref)) =
                   insert_alt (succ_rel list) (oid, ref)"
      using Cons.IH Cons.prems by auto
    ultimately show "succ_rel (insert_spec (a # list) (oid, Some ref)) =
                     insert_alt (succ_rel (a # list)) (oid, ref)"
      by (cases list, force, metis Cons.prems succ_rel_insert_later)
  qed
qed

text\<open>The main result of this section, that \isa{insert-spec} and \isa{insert-alt}
are equivalent.\<close>

theorem insert_alt_equivalent:
  assumes "insert_ops ops"
    and "head \<notin> fst ` set ops"
    and "\<And>r. Some r \<in> snd ` set ops \<Longrightarrow> r \<noteq> head"
  shows "succ_rel (head # interp_ins ops) = interp_alt head ops"
  using assms proof(induction ops rule: List.rev_induct)
  case Nil
  then show "succ_rel (head # interp_ins []) = interp_alt head []"
    by (simp add: interp_ins_def interp_alt_def)
next
  case (snoc x xs)
  have IH: "succ_rel (head # interp_ins xs) = interp_alt head xs"
    using snoc by auto
  have distinct_list: "distinct (head # interp_ins xs)"
  proof -
    have "distinct (interp_ins xs)"
      using interp_ins_distinct snoc.prems(1) by blast
    moreover have "set (interp_ins xs) \<subseteq> fst ` set xs"
      using interp_ins_subset snoc.prems(1) by fastforce
    ultimately show "distinct (head # interp_ins xs)"
      using snoc.prems(2) by auto
  qed
  obtain oid r where x_pair: "x = (oid, r)" by force
  then show "succ_rel (head # interp_ins (xs @ [x])) = interp_alt head (xs @ [x])"
  proof(cases r)
    case None
    have "interp_alt head (xs @ [x]) = insert_alt (interp_alt head xs) (oid, head)"
      by (simp add: interp_alt_def None x_pair)
    moreover have "... = insert_alt (succ_rel (head # interp_ins xs)) (oid, head)"
      by (simp add: IH)
    moreover have "... = succ_rel (insert_spec (head # interp_ins xs) (oid, Some head))"
      using distinct_list succ_rel_insert_Some by metis
    moreover have "... = succ_rel (head # (insert_spec (interp_ins xs) (oid, None)))"
      by auto
    moreover have "... = succ_rel (head # (interp_ins (xs @ [x])))"
      by (simp add: interp_ins_tail_unfold None x_pair)
    ultimately show ?thesis by simp
  next
    case (Some ref)
    have "ref \<noteq> head"
      by (simp add: Some snoc.prems(3) x_pair)
    have "interp_alt head (xs @ [x]) = insert_alt (interp_alt head xs) (oid, ref)"
      by (simp add: interp_alt_def Some x_pair)
    moreover have "... = insert_alt (succ_rel (head # interp_ins xs)) (oid, ref)"
      by (simp add: IH)
    moreover have "... = succ_rel (insert_spec (head # interp_ins xs) (oid, Some ref))"
      using distinct_list succ_rel_insert_Some by metis
    moreover have "... = succ_rel (head # (insert_spec (interp_ins xs) (oid, Some ref)))"
      using \<open>ref \<noteq> head\<close> by auto
    moreover have "... = succ_rel (head # (interp_ins (xs @ [x])))"
      by (simp add: interp_ins_tail_unfold Some x_pair)
    ultimately show ?thesis by simp
  qed
qed

subsection \<open>The \isa{list-order} predicate\<close>

text\<open>\isa{list-order ops x y} holds iff, after interpreting the list of
insertion operations \isa{ops}, the list element with ID \isa{x} appears
before the list element with ID \isa{y} in the resulting list. We prove several
lemmas about this predicate; in particular, that executing additional insertion
operations does not change the relative ordering of existing list elements.\<close>

definition list_order :: "('oid::{linorder} \<times> 'oid option) list \<Rightarrow> 'oid \<Rightarrow> 'oid \<Rightarrow> bool" where
  "list_order ops x y \<equiv> \<exists>xs ys zs. interp_ins ops = xs @ [x] @ ys @ [y] @ zs"

lemma list_orderI:
  assumes "interp_ins ops = xs @ [x] @ ys @ [y] @ zs"
  shows "list_order ops x y"
  using assms by (auto simp add: list_order_def)

lemma list_orderE:
  assumes "list_order ops x y"
  shows "\<exists>xs ys zs. interp_ins ops = xs @ [x] @ ys @ [y] @ zs"
  using assms by (auto simp add: list_order_def)

lemma list_order_memb1:
  assumes "list_order ops x y"
  shows "x \<in> set (interp_ins ops)"
  using assms by (auto simp add: list_order_def)

lemma list_order_memb2:
  assumes "list_order ops x y"
  shows "y \<in> set (interp_ins ops)"
  using assms by (auto simp add: list_order_def)

lemma list_order_trans:
  assumes "insert_ops op_list"
    and "list_order op_list x y"
    and "list_order op_list y z"
  shows "list_order op_list x z"
proof -
  obtain xxs xys xzs where 1: "interp_ins op_list = (xxs@[x]@xys)@(y#xzs)"
    using assms by (auto simp add: list_order_def interp_ins_def)
  obtain yxs yys yzs where 2: "interp_ins op_list = yxs@y#(yys@[z]@yzs)"
    using assms by (auto simp add: list_order_def interp_ins_def)
  have 3: "distinct (interp_ins op_list)"
    using assms interp_ins_distinct by blast
  hence "xzs = yys@[z]@yzs"
    using distinct_list_split[OF 3, OF 2, OF 1] by auto
  hence "interp_ins op_list = xxs@[x]@xys@[y]@yys@[z]@yzs"
    using 1 2 3 by clarsimp
  thus "list_order op_list x z"
    using assms by (metis append.assoc list_orderI)
qed

lemma insert_preserves_order:
  assumes "insert_ops ops" and "insert_ops rest"
    and "rest = before @ after"
    and "ops  = before @ (oid, ref) # after"
  shows "\<exists>xs ys zs. interp_ins rest = xs @ zs \<and> interp_ins ops = xs @ ys @ zs"
  using assms proof(induction after arbitrary: rest ops rule: List.rev_induct)
  case Nil
  then have 1: "interp_ins ops = insert_spec (interp_ins before) (oid, ref)"
    by (simp add: interp_ins_tail_unfold)
  then show "\<exists>xs ys zs. interp_ins rest = xs @ zs \<and> interp_ins ops = xs @ ys @ zs"
  proof(cases ref)
    case None
    hence "interp_ins rest = [] @ (interp_ins before) \<and>
           interp_ins ops = [] @ [oid] @ (interp_ins before)"
      using 1 Nil.prems(3) by simp
    then show ?thesis by blast
  next
    case (Some a)
    then show ?thesis
    proof(cases "a \<in> set (interp_ins before)")
      case True
      then obtain xs ys where "interp_ins before = xs @ ys \<and>
          insert_spec (interp_ins before) (oid, ref) = xs @ oid # ys"
        using insert_somewhere Some by metis
      hence "interp_ins rest = xs @ ys \<and> interp_ins ops = xs @ [oid] @ ys"
        using 1 Nil.prems(3) by auto
      then show ?thesis by blast
    next
      case False
      hence "interp_ins ops = (interp_ins rest) @ [] @ []"
        using insert_spec_nonex 1 Nil.prems(3) Some by simp
      then show ?thesis by blast
    qed
  qed
next
  case (snoc oper op_list)
  then have "insert_ops ((before @ (oid, ref) # op_list) @ [oper])"
    and "insert_ops ((before @ op_list) @ [oper])"
    by auto
  then have ops1: "insert_ops (before @ op_list)"
    and ops2: "insert_ops (before @ (oid, ref) # op_list)"
    using insert_ops_appendD by blast+
  then obtain xs ys zs where IH1: "interp_ins (before @ op_list) = xs @ zs"
    and IH2: "interp_ins (before @ (oid, ref) # op_list) = xs @ ys @ zs"
    using snoc.IH by blast
  obtain i2 r2 where "oper = (i2, r2)" by force
  then show "\<exists>xs ys zs. interp_ins rest = xs @ zs \<and> interp_ins ops = xs @ ys @ zs"
  proof(cases r2)
    case None
    hence "interp_ins (before @ op_list @ [oper]) = (i2 # xs) @ zs"
      by (metis IH1 \<open>oper = (i2, r2)\<close> append.assoc append_Cons insert_spec.simps(1)
          interp_ins_tail_unfold)
    moreover have "interp_ins (before @ (oid, ref) # op_list @ [oper]) = (i2 # xs) @ ys @ zs"
      by (metis IH2 None \<open>oper = (i2, r2)\<close> append.assoc append_Cons insert_spec.simps(1)
          interp_ins_tail_unfold)
    ultimately show ?thesis
      using snoc.prems(3) snoc.prems(4) by blast
  next
    case (Some r)
    then have 1: "interp_ins (before @ (oid, ref) # op_list @ [(i2, r2)]) =
                  insert_spec (xs @ ys @ zs) (i2, Some r)"
      by (metis IH2 append.assoc append_Cons interp_ins_tail_unfold)
    have 2: "interp_ins (before @ op_list @ [(i2, r2)]) = insert_spec (xs @ zs) (i2, Some r)"
      by (metis IH1 append.assoc interp_ins_tail_unfold Some)
    consider (r_xs) "r \<in> set xs" | (r_ys) "r \<in> set ys" | (r_zs) "r \<in> set zs" |
      (r_nonex) "r \<notin> set (xs @ ys @ zs)"
      by auto
    then show "\<exists>xs ys zs. interp_ins rest = xs @ zs \<and> interp_ins ops = xs @ ys @ zs"
    proof(cases)
      case r_xs
      from this have "insert_spec (xs @ ys @ zs) (i2, Some r) =
                      (insert_spec xs (i2, Some r)) @ ys @ zs"
        by (meson insert_first_part)
      moreover have "insert_spec (xs @ zs) (i2, Some r) = (insert_spec xs (i2, Some r)) @ zs"
        by (meson r_xs insert_first_part)
      ultimately show ?thesis
        using 1 2 \<open>oper = (i2, r2)\<close> snoc.prems by auto
    next
      case r_ys
      hence "r \<notin> set xs" and "r \<notin> set zs"
        using IH2 ops2 interp_ins_distinct by force+
      moreover from this have "insert_spec (xs @ ys @ zs) (i2, Some r) =
                               xs @ (insert_spec ys (i2, Some r)) @ zs"
        using insert_first_part insert_second_part insert_spec_nonex
        by (metis Some UnE r_ys set_append)
      moreover have "insert_spec (xs @ zs) (i2, Some r) = xs @ zs"
        by (simp add: Some calculation(1) calculation(2))
      ultimately show ?thesis
        using 1 2 \<open>oper = (i2, r2)\<close> snoc.prems by auto
    next
      case r_zs
      hence "r \<notin> set xs" and "r \<notin> set ys"
        using IH2 ops2 interp_ins_distinct by force+
      moreover from this have "insert_spec (xs @ ys @ zs) (i2, Some r) =
                               xs @ ys @ (insert_spec zs (i2, Some r))"
        by (metis Some UnE insert_second_part insert_spec_nonex set_append)
      moreover have "insert_spec (xs @ zs) (i2, Some r) = xs @ (insert_spec zs (i2, Some r))"
        by (simp add: r_zs calculation(1) insert_second_part)
      ultimately show ?thesis
        using 1 2 \<open>oper = (i2, r2)\<close> snoc.prems by auto
    next
      case r_nonex
      then have "insert_spec (xs @ ys @ zs) (i2, Some r) = xs @ ys @ zs"
        by simp
      moreover have "insert_spec (xs @ zs) (i2, Some r) = xs @ zs"
        using r_nonex by simp
      ultimately show ?thesis
        using 1 2 \<open>oper = (i2, r2)\<close> snoc.prems by auto
    qed
  qed
qed

lemma distinct_fst:
  assumes "distinct (map fst A)"
  shows "distinct A"
  using assms by (induction A) auto

lemma subset_distinct_le:
  assumes "set A \<subseteq> set B" and "distinct A" and "distinct B"
  shows "length A \<le> length B"
  using assms proof(induction B arbitrary: A)
  case Nil
  then show "length A \<le> length []" by simp
next
  case (Cons a B)
  then show "length A \<le> length (a # B)"
  proof(cases "a \<in> set A")
    case True
    have "set (remove1 a A) \<subseteq> set B"
      using Cons.prems by auto
    hence "length (remove1 a A) \<le> length B"
      using Cons.IH Cons.prems by auto
    then show "length A \<le> length (a # B)"
      by (simp add: True length_remove1)
  next
    case False
    hence "set A \<subseteq> set B"
      using Cons.prems by auto
    hence "length A \<le> length B"
      using Cons.IH Cons.prems by auto
    then show "length A \<le> length (a # B)"
      by simp
  qed
qed

lemma set_subset_length_eq:
  assumes "set A \<subseteq> set B" and "length B \<le> length A"
    and "distinct A" and "distinct B"
  shows "set A = set B"
proof -
  have "length A \<le> length B"
    using assms by (simp add: subset_distinct_le)
  moreover from this have "card (set A) = card (set B)"
    using assms by (simp add: distinct_card le_antisym)
  ultimately show "set A = set B"
    using assms(1) by (simp add: card_subset_eq)
qed

lemma length_diff_Suc_exists:
  assumes "length xs - length ys = Suc m"
    and "set ys \<subseteq> set xs"
    and "distinct ys" and "distinct xs"
  shows "\<exists>e. e \<in> set xs \<and> e \<notin> set ys"
  using assms proof(induction xs arbitrary: ys)
  case Nil
  then show "\<exists>e. e \<in> set [] \<and> e \<notin> set ys"
    by simp
next
  case (Cons a xs)
  then show "\<exists>e. e \<in> set (a # xs) \<and> e \<notin> set ys"
  proof(cases "a \<in> set ys")
    case True
    have IH: "\<exists>e. e \<in> set xs \<and> e \<notin> set (remove1 a ys)"
    proof -
      have "length xs - length (remove1 a ys) = Suc m"
        by (metis Cons.prems(1) One_nat_def Suc_pred True diff_Suc_Suc length_Cons
            length_pos_if_in_set length_remove1)
      moreover have "set (remove1 a ys) \<subseteq> set xs"
        using Cons.prems by auto
      ultimately show ?thesis
        by (meson Cons.IH Cons.prems distinct.simps(2) distinct_remove1)
    qed
    moreover have "set ys - {a} \<subseteq> set xs"
      using Cons.prems(2) by auto
    ultimately show "\<exists>e. e \<in> set (a # xs) \<and> e \<notin> set ys"
      by (metis Cons.prems(4) distinct.simps(2) in_set_remove1 set_subset_Cons subsetCE)
  next
    case False
    then show "\<exists>e. e \<in> set (a # xs) \<and> e \<notin> set ys"
      by auto
  qed
qed

lemma app_length_lt_exists:
  assumes "xsa @ zsa = xs @ ys"
    and "length xsa \<le> length xs"
  shows "xsa @ (drop (length xsa) xs) = xs"
  using assms by (induction xsa arbitrary: xs zsa ys, simp,
      metis append_eq_append_conv_if append_take_drop_id)

lemma list_order_monotonic:
  assumes "insert_ops A" and "insert_ops B"
    and "set A \<subseteq> set B"
    and "list_order A x y"
  shows "list_order B x y"
  using assms proof(induction rule: measure_induct_rule[where f="\<lambda>x. (length x - length A)"])
  case (less xa)
  have "distinct (map fst A)" and "distinct (map fst xa)" and
    "sorted (map fst A)" and "sorted (map fst xa)"
    using less.prems by (auto simp add: insert_ops_def spec_ops_def)
  hence "distinct A" and "distinct xa"
    by (auto simp add: distinct_fst)
  then show "list_order xa x y"
  proof(cases "length xa - length A")
    case 0
    hence "set A = set xa"
      using set_subset_length_eq less.prems(3) \<open>distinct A\<close> \<open>distinct xa\<close> diff_is_0_eq by blast
    hence "A = xa"
      using \<open>distinct (map fst A)\<close> \<open>distinct (map fst xa)\<close>
        \<open>sorted (map fst A)\<close> \<open>sorted (map fst xa)\<close> map_sorted_distinct_set_unique
      by (metis distinct_map less.prems(3) subset_Un_eq)
    then show "list_order xa x y"
      using less.prems(4) by blast
  next
    case (Suc nat)
    then obtain e where "e \<in> set xa" and "e \<notin> set A"
      using length_diff_Suc_exists \<open>distinct A\<close> \<open>distinct xa\<close> less.prems(3) by blast
    hence IH: "list_order (remove1 e xa) x y"
    proof -
      have "length (remove1 e xa) - length A < Suc nat"
        using diff_Suc_1 diff_commute length_remove1 less_Suc_eq Suc \<open>e \<in> set xa\<close> by metis
      moreover have "insert_ops (remove1 e xa)"
        by (simp add: insert_ops_remove1 less.prems(2))
      moreover have "set A \<subseteq> set (remove1 e xa)"
        by (metis (no_types, lifting) \<open>e \<notin> set A\<close> in_set_remove1 less.prems(3) rev_subsetD subsetI)
      ultimately show ?thesis
        by (simp add: Suc less.IH less.prems(1) less.prems(4))
    qed
    then obtain xs ys zs where "interp_ins (remove1 e xa) = xs @ x # ys @ y # zs"
      using list_order_def by fastforce
    moreover obtain oid ref where e_pair: "e = (oid, ref)"
      by fastforce
    moreover obtain ps ss where xa_split: "xa = ps @ [e] @ ss" and "e \<notin> set ps"
      using split_list_first \<open>e \<in> set xa\<close> by fastforce
    hence "remove1 e (ps @ e # ss) = ps @ ss"
      by (simp add: remove1_append)
    moreover from this have "insert_ops (ps @ ss)" and "insert_ops (ps @ e # ss)"
      using xa_split less.prems(2) by (metis append_Cons append_Nil insert_ops_remove1, auto)
    then obtain xsa ysa zsa where "interp_ins (ps @ ss) = xsa @ zsa"
      and interp_xa: "interp_ins (ps @ (oid, ref) # ss) = xsa @ ysa @ zsa"
      using insert_preserves_order e_pair by metis
    moreover have xsa_zsa: "xsa @ zsa = xs @ x # ys @ y # zs"
      using interp_ins_def remove1_append calculation xa_split by auto
    then show "list_order xa x y"
    proof(cases "length xsa \<le> length xs")
      case True
      then obtain ts where "xsa@ts = xs"
        using app_length_lt_exists xsa_zsa by blast
      hence "interp_ins xa = (xsa @ ysa @ ts) @ [x] @ ys @ [y] @ zs"
        using calculation xa_split by auto
      then show "list_order xa x y"
        using list_order_def by blast
    next
      case False
      then show "list_order xa x y"
      proof(cases "length xsa \<le> length (xs @ x # ys)")
        case True
        have xsa_zsa1: "xsa @ zsa = (xs @ x # ys) @ (y # zs)"
          by (simp add: xsa_zsa)
        then obtain us where "xsa @ us = xs @ x # ys"
          using app_length_lt_exists True by blast
        moreover from this have "xs @ x # (drop (Suc (length xs)) xsa) = xsa"
          using append_eq_append_conv_if id_take_nth_drop linorder_not_less
            nth_append nth_append_length False by metis
        moreover have "us @ y # zs = zsa"
          by (metis True xsa_zsa1 append_eq_append_conv_if append_eq_conv_conj calculation(1))
        ultimately have "interp_ins xa = xs @ [x] @
              ((drop (Suc (length xs)) xsa) @ ysa @ us) @ [y] @ zs"
          by (simp add: e_pair interp_xa xa_split)
        then show "list_order xa x y"
          using list_order_def by blast
      next
        case False
        hence "length (xs @ x # ys) < length xsa"
          using not_less by blast
        hence "length (xs @ x # ys @ [y]) \<le> length xsa"
          by simp
        moreover have "(xs @ x # ys @ [y]) @ zs = xsa @ zsa"
          by (simp add: xsa_zsa)
        ultimately obtain vs where "(xs @ x # ys @ [y]) @ vs = xsa"
          using app_length_lt_exists by blast
        hence "xsa @ ysa @ zsa = xs @ [x] @ ys @ [y] @ vs @ ysa @ zsa"
          by simp
        hence "interp_ins xa = xs @ [x] @ ys @ [y] @ (vs @ ysa @ zsa)"
          using e_pair interp_xa xa_split by auto
        then show "list_order xa x y"
          using list_order_def by blast
      qed
    qed
  qed
qed

end


(*  Title:      HOL/Divides.thy
*)

section \<open>Misc lemmas on division, to be sorted out finally\<close>

theory Divides
imports Parity
begin

class unique_euclidean_semiring_numeral = unique_euclidean_semiring_with_nat + linordered_semidom +
  assumes div_less [no_atp]: "0 \<le> a \<Longrightarrow> a < b \<Longrightarrow> a div b = 0"
    and mod_less [no_atp]: " 0 \<le> a \<Longrightarrow> a < b \<Longrightarrow> a mod b = a"
    and div_positive [no_atp]: "0 < b \<Longrightarrow> b \<le> a \<Longrightarrow> a div b > 0"
    and mod_less_eq_dividend [no_atp]: "0 \<le> a \<Longrightarrow> a mod b \<le> a"
    and pos_mod_bound [no_atp]: "0 < b \<Longrightarrow> a mod b < b"
    and pos_mod_sign [no_atp]: "0 < b \<Longrightarrow> 0 \<le> a mod b"
    and mod_mult2_eq [no_atp]: "0 \<le> c \<Longrightarrow> a mod (b * c) = b * (a div b mod c) + a mod b"
    and div_mult2_eq [no_atp]: "0 \<le> c \<Longrightarrow> a div (b * c) = a div b div c"
  assumes discrete [no_atp]: "a < b \<longleftrightarrow> a + 1 \<le> b"

hide_fact (open) div_less mod_less mod_less_eq_dividend mod_mult2_eq div_mult2_eq

context unique_euclidean_semiring_numeral
begin

context
begin

lemma divmod_digit_1 [no_atp]:
  assumes "0 \<le> a" "0 < b" and "b \<le> a mod (2 * b)"
  shows "2 * (a div (2 * b)) + 1 = a div b" (is "?P")
    and "a mod (2 * b) - b = a mod b" (is "?Q")
proof -
  from assms mod_less_eq_dividend [of a "2 * b"] have "b \<le> a"
    by (auto intro: trans)
  with \<open>0 < b\<close> have "0 < a div b" by (auto intro: div_positive)
  then have [simp]: "1 \<le> a div b" by (simp add: discrete)
  with \<open>0 < b\<close> have mod_less: "a mod b < b" by (simp add: pos_mod_bound)
  define w where "w = a div b mod 2"
  then have w_exhaust: "w = 0 \<or> w = 1" by auto
  have mod_w: "a mod (2 * b) = a mod b + b * w"
    by (simp add: w_def mod_mult2_eq ac_simps)
  from assms w_exhaust have "w = 1"
    using mod_less by (auto simp add: mod_w)
  with mod_w have mod: "a mod (2 * b) = a mod b + b" by simp
  have "2 * (a div (2 * b)) = a div b - w"
    by (simp add: w_def div_mult2_eq minus_mod_eq_mult_div ac_simps)
  with \<open>w = 1\<close> have div: "2 * (a div (2 * b)) = a div b - 1" by simp
  then show ?P and ?Q
    by (simp_all add: div mod add_implies_diff [symmetric])
qed

lemma divmod_digit_0 [no_atp]:
  assumes "0 < b" and "a mod (2 * b) < b"
  shows "2 * (a div (2 * b)) = a div b" (is "?P")
    and "a mod (2 * b) = a mod b" (is "?Q")
proof -
  define w where "w = a div b mod 2"
  then have w_exhaust: "w = 0 \<or> w = 1" by auto
  have mod_w: "a mod (2 * b) = a mod b + b * w"
    by (simp add: w_def mod_mult2_eq ac_simps)
  moreover have "b \<le> a mod b + b"
  proof -
    from \<open>0 < b\<close> pos_mod_sign have "0 \<le> a mod b" by blast
    then have "0 + b \<le> a mod b + b" by (rule add_right_mono)
    then show ?thesis by simp
  qed
  moreover note assms w_exhaust
  ultimately have "w = 0" by auto
  with mod_w have mod: "a mod (2 * b) = a mod b" by simp
  have "2 * (a div (2 * b)) = a div b - w"
    by (simp add: w_def div_mult2_eq minus_mod_eq_mult_div ac_simps)
  with \<open>w = 0\<close> have div: "2 * (a div (2 * b)) = a div b" by simp
  then show ?P and ?Q
    by (simp_all add: div mod)
qed

lemma mod_double_modulus: \<comment>\<open>This is actually useful and should be transferred to a suitable type class\<close>
  assumes "m > 0" "x \<ge> 0"
  shows   "x mod (2 * m) = x mod m \<or> x mod (2 * m) = x mod m + m"
proof (cases "x mod (2 * m) < m")
  case True
  thus ?thesis using assms using divmod_digit_0(2)[of m x] by auto
next
  case False
  hence *: "x mod (2 * m) - m = x mod m"
    using assms by (intro divmod_digit_1) auto
  hence "x mod (2 * m) = x mod m + m"
    by (subst * [symmetric], subst le_add_diff_inverse2) (use False in auto)
  thus ?thesis by simp
qed

end

end

instance nat :: unique_euclidean_semiring_numeral
  by standard
    (auto simp add: div_greater_zero_iff div_mult2_eq mod_mult2_eq)

instance int :: unique_euclidean_semiring_numeral
  by standard (auto intro: zmod_le_nonneg_dividend simp add:
    pos_imp_zdiv_pos_iff zmod_zmult2_eq zdiv_zmult2_eq)

(* REVISIT: should this be generalized to all semiring_div types? *)
lemma zmod_eq_0D [dest!]: "\<exists>q. m = d * q" if "m mod d = 0" for m d :: int
  using that by auto

lemma div_geq [no_atp]: "m div n = Suc ((m - n) div n)" if "0 < n" and " \<not> m < n" for m n :: nat
  by (rule le_div_geq) (use that in \<open>simp_all add: not_less\<close>)

lemma mod_geq [no_atp]: "m mod n = (m - n) mod n" if "\<not> m < n" for m n :: nat
  by (rule le_mod_geq) (use that in \<open>simp add: not_less\<close>)

lemma mod_eq_0D [no_atp]: "\<exists>q. m = d * q" if "m mod d = 0" for m d :: nat
  using that by (auto simp add: mod_eq_0_iff_dvd)

lemma pos_mod_conj [no_atp]: "0 < b \<Longrightarrow> 0 \<le> a mod b \<and> a mod b < b" for a b :: int
  by simp

lemma neg_mod_conj [no_atp]: "b < 0 \<Longrightarrow> a mod b \<le> 0 \<and> b < a mod b" for a b :: int
  by simp

lemma zmod_eq_0_iff [no_atp]: "m mod d = 0 \<longleftrightarrow> (\<exists>q. m = d * q)" for m d :: int
  by (auto simp add: mod_eq_0_iff_dvd)

lemma div_positive_int [no_atp]:
  "k div l > 0" if "k \<ge> l" and "l > 0" for k l :: int
  using that by (simp add: nonneg1_imp_zdiv_pos_iff)

code_identifier
  code_module Divides \<rightharpoonup> (SML) Arith and (OCaml) Arith and (Haskell) Arith

end


theory Taylor_Models_Misc
imports "~~/src/HOL/Library/Float"
        "~~/src/HOL/Library/Function_Algebras"
        "~~/src/HOL/Decision_Procs/Approximation"
        "Poly_Ex"
begin

(* This theory contains anything that doesn't belong anywhere else. *)

lemma of_nat_real_float_equiv: "(of_nat n :: real) = (of_nat n :: float)"
  by (induction n, simp_all add: of_nat_def)

lemma fact_real_float_equiv: "(fact n :: float) = (fact n :: real)"
  by (induction n) simp_all

lemma Some_those_length:
assumes "Some xs = those ys"
shows "length xs = length ys"
using assms
apply(induction ys arbitrary: xs)
apply(simp)
proof(goal_cases)
  case (1 a ys xs)
  show ?case
    apply(cases a)
    using 1(2)
    apply(simp)
    proof-
      fix a' assume a_def: "a = Some a'"
      from 1(2)
      have "Some xs = map_option (op # a') (those ys)"
        by (simp add: a_def)
      thus "length xs = length (a # ys)"
        using 1(1) by (metis (no_types, lifting) length_Cons map_option_eq_Some)
    qed
qed

lemma Some_those_nth:
assumes "Some xs = those ys"
assumes "i < length xs"
shows "Some (xs!i) = ys!i"
proof-
  have "None \<in> set ys \<Longrightarrow> those ys = None"
    apply(induction ys)
    apply(simp)
    proof(goal_cases)
      case (1 a ys) thus ?case by (cases a, simp_all)
    qed
  hence "None \<notin> set ys"
    using assms(1) by auto
  then obtain y where y_def: "Some y = ys!i"
    by (metis Some_those_length assms not_None_eq nth_mem)
  hence "xs!i = y"
    using assms
    apply(induction i arbitrary: y xs ys)
    apply(simp_all)
    proof(goal_cases)
      case (1 y xs ys)
      thus ?case
      apply(cases ys)
      apply(simp_all)
      by (metis nth_Cons_0 option.distinct(1) option.map_disc_iff option.map_sel option.sel option.simps(5))
    next
      case (2 i y xs ys)
      thus ?case
      apply(cases ys)
      apply(simp_all)
      by (smt Suc_less_eq length_Cons map_option_eq_Some nth_Cons_Suc option.case_eq_if option.distinct(1))
    qed
  thus ?thesis
    by (simp add: y_def)
qed

lemma fun_pow: "f^n = (\<lambda>x. (f x)^n)"
by (induction n, simp_all)

(* Count the number of parameters of a floatarith expression *)
fun num_vars :: "floatarith \<Rightarrow> nat"
where "num_vars (Add a b) = max (num_vars a) (num_vars b)"
    | "num_vars (Minus a) = num_vars a"
    | "num_vars (Mult a b) = max (num_vars a) (num_vars b)"
    | "num_vars (Inverse a) = num_vars a"
    | "num_vars (Cos a) = num_vars a"
    | "num_vars (Arctan a) = num_vars a"
    | "num_vars (Min a b) = max (num_vars a) (num_vars b)"
    | "num_vars (Max a b) = max (num_vars a) (num_vars b)"
    | "num_vars (Abs a) = num_vars a"
    | "num_vars (Sqrt a) = num_vars a"
    | "num_vars (Exp a) = num_vars a"
    | "num_vars (Ln a) = num_vars a"
    | "num_vars (Var v) = Suc v"
    | "num_vars (Power a n) = num_vars a"
    | "num_vars (Num _) = 0"
    | "num_vars Pi = 0"

(* Translate floatarith expressions by a vector of floats.*)
fun fa_translate :: "float list \<Rightarrow> floatarith \<Rightarrow> floatarith"
where "fa_translate v (Add a b) = Add (fa_translate v a) (fa_translate v b)"
    | "fa_translate v (Minus a) = Minus (fa_translate v a)"
    | "fa_translate v (Mult a b) = Mult (fa_translate v a) (fa_translate v b)"
    | "fa_translate v (Inverse a) = Inverse (fa_translate v a)"
    | "fa_translate v (Cos a) = Cos (fa_translate v a)"
    | "fa_translate v (Arctan a) = Arctan (fa_translate v a)"
    | "fa_translate v (Min a b) = Min (fa_translate v a) (fa_translate v b)"
    | "fa_translate v (Max a b) = Max (fa_translate v a) (fa_translate v b)"
    | "fa_translate v (Abs a) = Abs (fa_translate v a)"
    | "fa_translate v (Sqrt a) = Sqrt (fa_translate v a)"
    | "fa_translate v (Exp a) = Exp (fa_translate v a)"
    | "fa_translate v (Ln a) = Ln (fa_translate v a)"
    | "fa_translate v (Var n) = Add (Var n) (Num (v!n))"
    | "fa_translate v (Power a n) = Power (fa_translate v a) n"
    | "fa_translate v (Num c) = Num c"
    | "fa_translate v Pi = Pi"

lemma fa_translate_correct:
assumes "num_vars f \<le> length I"
assumes "length v = length I"
shows "interpret_floatarith (fa_translate v f) I = interpret_floatarith f (list_op op+ I v)"
using assms
by (induction f, simp_all)

end


section\<open>The Axiom of Choice in $M[G]$\<close>
theory Choice_Axiom
  imports Powerset_Axiom Pairing_Axiom Union_Axiom Extensionality_Axiom
          Foundation_Axiom Powerset_Axiom Separation_Axiom
          Replacement_Axiom Interface Infinity_Axiom
begin

definition
  induced_surj :: "i\<Rightarrow>i\<Rightarrow>i\<Rightarrow>i" where
  "induced_surj(f,a,e) \<equiv> f-``(range(f)-a)\<times>{e} \<union> restrict(f,f-``a)"

lemma domain_induced_surj: "domain(induced_surj(f,a,e)) = domain(f)"
  unfolding induced_surj_def using domain_restrict domain_of_prod by auto

lemma range_restrict_vimage:
  assumes "function(f)"
  shows "range(restrict(f,f-``a)) \<subseteq> a"
proof
  from assms
  have "function(restrict(f,f-``a))"
    using function_restrictI by simp
  fix y
  assume "y \<in> range(restrict(f,f-``a))"
  then
  obtain x where "\<langle>x,y\<rangle> \<in> restrict(f,f-``a)"  "x \<in> f-``a" "x\<in>domain(f)"
    using domain_restrict domainI[of _ _ "restrict(f,f-``a)"] by auto
  moreover
  note \<open>function(restrict(f,f-``a))\<close>
  ultimately
  have "y = restrict(f,f-``a)`x"
    using function_apply_equality by blast
  also from \<open>x \<in> f-``a\<close>
  have "restrict(f,f-``a)`x = f`x"
    by simp
  finally
  have "y=f`x" .
  moreover from assms \<open>x\<in>domain(f)\<close>
  have "\<langle>x,f`x\<rangle> \<in> f"
    using function_apply_Pair by auto
  moreover
  note assms \<open>x \<in> f-``a\<close>
  ultimately
  show "y\<in>a"
    using function_image_vimage[of f a] by auto
qed

lemma induced_surj_type:
  assumes
    "function(f)" (* "relation(f)" (* a function can contain nonpairs *) *)
  shows
    "induced_surj(f,a,e): domain(f) \<rightarrow> {e} \<union> a"
    and
    "x \<in> f-``a \<Longrightarrow> induced_surj(f,a,e)`x = f`x"
proof -
  let ?f1="f-``(range(f)-a) \<times> {e}" and ?f2="restrict(f, f-``a)"
  have "domain(?f2) = domain(f) \<inter> f-``a"
    using domain_restrict by simp
  moreover from assms
  have 1: "domain(?f1) = f-``(range(f))-f-``a"
    using domain_of_prod function_vimage_Diff by simp
  ultimately
  have "domain(?f1) \<inter> domain(?f2) = 0"
    by auto
  moreover
  have "function(?f1)" "relation(?f1)" "range(?f1) \<subseteq> {e}"
    unfolding function_def relation_def range_def by auto
  moreover from this and assms
  have "?f1: domain(?f1) \<rightarrow> range(?f1)"
    using function_imp_Pi by simp
  moreover from assms
  have "?f2: domain(?f2) \<rightarrow> range(?f2)"
    using function_imp_Pi[of "restrict(f, f -`` a)"] function_restrictI by simp
  moreover from assms
  have "range(?f2) \<subseteq> a"
    using range_restrict_vimage by simp
  ultimately
  have "induced_surj(f,a,e): domain(?f1) \<union> domain(?f2) \<rightarrow> {e} \<union> a"
    unfolding induced_surj_def using fun_is_function fun_disjoint_Un fun_weaken_type by simp
  moreover
  have "domain(?f1) \<union> domain(?f2) = domain(f)"
    using domain_restrict domain_of_prod by auto
  ultimately
  show "induced_surj(f,a,e): domain(f) \<rightarrow> {e} \<union> a"
    by simp
  assume "x \<in> f-``a"
  then
  have "?f2`x = f`x"
    using restrict by simp
  moreover from \<open>x \<in> f-``a\<close> and 1
  have "x \<notin> domain(?f1)"
    by simp
  ultimately
  show "induced_surj(f,a,e)`x = f`x"
    unfolding induced_surj_def using fun_disjoint_apply2[of x ?f1 ?f2] by simp
qed

lemma induced_surj_is_surj :
  assumes
    "e\<in>a" "function(f)" "domain(f) = \<alpha>" "\<And>y. y \<in> a \<Longrightarrow> \<exists>x\<in>\<alpha>. f ` x = y"
  shows
    "induced_surj(f,a,e) \<in> surj(\<alpha>,a)"
  unfolding surj_def
proof (intro CollectI ballI)
  from assms
  show "induced_surj(f,a,e): \<alpha> \<rightarrow> a"
    using induced_surj_type[of f a e] cons_eq cons_absorb by simp
  fix y
  assume "y \<in> a"
  with assms
  have "\<exists>x\<in>\<alpha>. f ` x = y"
    by simp
  then
  obtain x where "x\<in>\<alpha>" "f ` x = y" by auto
  with \<open>y\<in>a\<close> assms
  have "x\<in>f-``a"
    using vimage_iff function_apply_Pair[of f x] by auto
  with \<open>f ` x = y\<close> assms
  have "induced_surj(f, a, e) ` x = y"
    using induced_surj_type by simp
  with \<open>x\<in>\<alpha>\<close> show
    "\<exists>x\<in>\<alpha>. induced_surj(f, a, e) ` x = y" by auto
qed

context G_generic
begin

definition
  upair_name :: "i \<Rightarrow> i \<Rightarrow> i" where
  "upair_name(\<tau>,\<rho>) \<equiv> {\<langle>\<tau>,one\<rangle>,\<langle>\<rho>,one\<rangle>}"

definition
  is_upair_name :: "[i,i,i] \<Rightarrow> o" where
  "is_upair_name(x,y,z) \<equiv> \<exists>xo\<in>M. \<exists>yo\<in>M. pair(##M,x,one,xo) \<and> pair(##M,y,one,yo) \<and>
                                       upair(##M,xo,yo,z)"

lemma upair_name_abs :
  assumes "x\<in>M" "y\<in>M" "z\<in>M"
  shows "is_upair_name(x,y,z) \<longleftrightarrow> z = upair_name(x,y)"
  unfolding is_upair_name_def upair_name_def using assms one_in_M pair_in_M_iff by simp

lemma upair_name_closed :
  "\<lbrakk> x\<in>M; y\<in>M \<rbrakk> \<Longrightarrow> upair_name(x,y)\<in>M"
  unfolding upair_name_def using upair_in_M_iff pair_in_M_iff one_in_M by simp

definition
  upair_name_fm :: "[i,i,i,i] \<Rightarrow> i" where
  "upair_name_fm(x,y,o,z) \<equiv> Exists(Exists(And(pair_fm(x#+2,o#+2,1),
                                          And(pair_fm(y#+2,o#+2,0),upair_fm(1,0,z#+2)))))"

lemma upair_name_fm_type[TC] :
    "\<lbrakk> s\<in>nat;x\<in>nat;y\<in>nat;o\<in>nat\<rbrakk> \<Longrightarrow> upair_name_fm(s,x,y,o)\<in>formula"
  unfolding upair_name_fm_def by simp

lemma sats_upair_name_fm :
  assumes "x\<in>nat" "y\<in>nat" "z\<in>nat" "o\<in>nat" "env\<in>list(M)""nth(o,env)=one"
  shows
    "sats(M,upair_name_fm(x,y,o,z),env) \<longleftrightarrow> is_upair_name(nth(x,env),nth(y,env),nth(z,env))"
  unfolding upair_name_fm_def is_upair_name_def using assms by simp

definition
  opair_name :: "i \<Rightarrow> i \<Rightarrow> i" where
  "opair_name(\<tau>,\<rho>) \<equiv> upair_name(upair_name(\<tau>,\<tau>),upair_name(\<tau>,\<rho>))"

definition
  is_opair_name :: "[i,i,i] \<Rightarrow> o" where
  "is_opair_name(x,y,z) \<equiv> \<exists>upxx\<in>M. \<exists>upxy\<in>M. is_upair_name(x,x,upxx) \<and> is_upair_name(x,y,upxy)
                                          \<and> is_upair_name(upxx,upxy,z)"

lemma opair_name_abs :
  assumes "x\<in>M" "y\<in>M" "z\<in>M"
  shows "is_opair_name(x,y,z) \<longleftrightarrow> z = opair_name(x,y)"
  unfolding is_opair_name_def opair_name_def using assms upair_name_abs upair_name_closed by simp

lemma opair_name_closed :
  "\<lbrakk> x\<in>M; y\<in>M \<rbrakk> \<Longrightarrow> opair_name(x,y)\<in>M"
  unfolding opair_name_def using upair_name_closed by simp

definition
  opair_name_fm :: "[i,i,i,i] \<Rightarrow> i" where
  "opair_name_fm(x,y,o,z) \<equiv> Exists(Exists(And(upair_name_fm(x#+2,x#+2,o#+2,1),
                    And(upair_name_fm(x#+2,y#+2,o#+2,0),upair_name_fm(1,0,o#+2,z#+2)))))"

lemma opair_name_fm_type[TC] :
    "\<lbrakk> s\<in>nat;x\<in>nat;y\<in>nat;o\<in>nat\<rbrakk> \<Longrightarrow> opair_name_fm(s,x,y,o)\<in>formula"
  unfolding opair_name_fm_def by simp

lemma sats_opair_name_fm :
  assumes "x\<in>nat" "y\<in>nat" "z\<in>nat" "o\<in>nat" "env\<in>list(M)""nth(o,env)=one"
  shows
    "sats(M,opair_name_fm(x,y,o,z),env) \<longleftrightarrow> is_opair_name(nth(x,env),nth(y,env),nth(z,env))"
  unfolding opair_name_fm_def is_opair_name_def using assms sats_upair_name_fm by simp

lemma val_upair_name : "val(G,upair_name(\<tau>,\<rho>)) = {val(G,\<tau>),val(G,\<rho>)}"
  unfolding upair_name_def using val_Upair  generic one_in_G one_in_P by simp

lemma val_opair_name : "val(G,opair_name(\<tau>,\<rho>)) = \<langle>val(G,\<tau>),val(G,\<rho>)\<rangle>"
  unfolding opair_name_def Pair_def using val_upair_name  by simp

lemma val_RepFun_one: "val(G,{\<langle>f(x),one\<rangle> . x\<in>a}) = {val(G,f(x)) . x\<in>a}"
proof -
  let ?A = "{f(x) . x \<in> a}"
  let ?Q = "\<lambda>\<langle>x,p\<rangle> . p = one"
  have "one \<in> P\<inter>G" using generic one_in_G one_in_P by simp
  have "{\<langle>f(x),one\<rangle> . x \<in> a} = {t \<in> ?A \<times> P . ?Q(t)}"
    using one_in_P by force
  then
  have "val(G,{\<langle>f(x),one\<rangle>  . x \<in> a}) = val(G,{t \<in> ?A \<times> P . ?Q(t)})"
    by simp
  also
  have "... = {val(G,t) .. t \<in> ?A , \<exists>p\<in>P\<inter>G . ?Q(\<langle>t,p\<rangle>)}"
    using val_of_name_alt by simp
  also
  have "... = {val(G,t) . t \<in> ?A }"
    using \<open>one\<in>P\<inter>G\<close> by force
  also
  have "... = {val(G,f(x)) . x \<in> a}"
    by auto
  finally show ?thesis by simp
qed

subsection\<open>$M[G]$ is a transitive model of ZF\<close>

interpretation mgzf: M_ZF_trans "M[G]"
  using Transset_MG generic pairing_in_MG Union_MG
    extensionality_in_MG power_in_MG foundation_in_MG
    strong_replacement_in_MG separation_in_MG infinity_in_MG
  by unfold_locales simp_all

(* y = opair_name(check(\<beta>),s`\<beta>) *)
definition
  is_opname_check :: "[i,i,i] \<Rightarrow> o" where
  "is_opname_check(s,x,y) \<equiv> \<exists>chx\<in>M. \<exists>sx\<in>M. is_check(x,chx) \<and> fun_apply(##M,s,x,sx) \<and>
                             is_opair_name(chx,sx,y)"

definition
  opname_check_fm :: "[i,i,i,i] \<Rightarrow> i" where
  "opname_check_fm(s,x,y,o) \<equiv> Exists(Exists(And(check_fm(2#+x,2#+o,1),
                              And(fun_apply_fm(2#+s,2#+x,0),opair_name_fm(1,0,2#+o,2#+y)))))"

lemma opname_check_fm_type[TC] :
  "\<lbrakk> s\<in>nat;x\<in>nat;y\<in>nat;o\<in>nat\<rbrakk> \<Longrightarrow> opname_check_fm(s,x,y,o)\<in>formula"
  unfolding opname_check_fm_def by simp

lemma sats_opname_check_fm:
  assumes "x\<in>nat" "y\<in>nat" "z\<in>nat" "o\<in>nat" "env\<in>list(M)" "nth(o,env)=one"
          "y<length(env)"
  shows
    "sats(M,opname_check_fm(x,y,z,o),env) \<longleftrightarrow> is_opname_check(nth(x,env),nth(y,env),nth(z,env))"
  unfolding opname_check_fm_def is_opname_check_def
  using assms sats_check_fm sats_opair_name_fm one_in_M by simp

lemma opname_check_abs :
  assumes "s\<in>M" "x\<in>M" "y\<in>M"
  shows "is_opname_check(s,x,y) \<longleftrightarrow> y = opair_name(check(x),s`x)"
  unfolding is_opname_check_def
  using assms check_abs check_in_M opair_name_abs apply_abs apply_closed by simp

lemma repl_opname_check :
  assumes
    "A\<in>M" "f\<in>M"
  shows
   "{opair_name(check(x),f`x). x\<in>A}\<in>M"
proof -
  have "arity(opname_check_fm(3,0,1,2))= 4"
    unfolding opname_check_fm_def opair_name_fm_def upair_name_fm_def
          check_fm_def rcheck_fm_def trans_closure_fm_def is_eclose_fm_def mem_eclose_fm_def
         is_Hcheck_fm_def Replace_fm_def PHcheck_fm_def finite_ordinal_fm_def is_iterates_fm_def
             is_wfrec_fm_def is_recfun_fm_def restriction_fm_def pre_image_fm_def eclose_n_fm_def
        is_nat_case_fm_def quasinat_fm_def Memrel_fm_def singleton_fm_def fm_defs iterates_MH_fm_def
    by (simp add:nat_simp_union)
  moreover
  have "x\<in>A \<Longrightarrow> opair_name(check(x), f ` x)\<in>M" for x
    using assms opair_name_closed apply_closed transitivity check_in_M
    by simp
  ultimately
  show ?thesis using assms opname_check_abs[of f] sats_opname_check_fm
        one_in_M
        Repl_in_M[of "opname_check_fm(3,0,1,2)" "[one,f]" "is_opname_check(f)"
                    "\<lambda>x. opair_name(check(x),f`x)"]
    by simp
qed

theorem choice_in_MG:
  assumes "choice_ax(##M)"
  shows "choice_ax(##M[G])"
proof -
  {
    fix a
    assume "a\<in>M[G]"
    then
    obtain \<tau> where "\<tau>\<in>M" "val(G,\<tau>) = a"
      using GenExt_def by auto
    with \<open>\<tau>\<in>M\<close>
    have "domain(\<tau>)\<in>M"
      using domain_closed by simp
    then
    obtain s \<alpha> where "s\<in>surj(\<alpha>,domain(\<tau>))" "Ord(\<alpha>)" "s\<in>M" "\<alpha>\<in>M"
      using assms choice_ax_abs by auto
    then
    have "\<alpha>\<in>M[G]"
      using M_subset_MG generic one_in_G subsetD by blast
    let ?A="domain(\<tau>)\<times>P"
    let ?g = "{opair_name(check(\<beta>),s`\<beta>). \<beta>\<in>\<alpha>}"
    have "?g \<in> M" using \<open>s\<in>M\<close> \<open>\<alpha>\<in>M\<close> repl_opname_check by simp
    let ?f_dot="{\<langle>opair_name(check(\<beta>),s`\<beta>),one\<rangle>. \<beta>\<in>\<alpha>}"
    have "?f_dot = ?g \<times> {one}" by blast
    from one_in_M have "{one} \<in> M" using singletonM by simp
    define f where
      "f \<equiv> val(G,?f_dot)"
    from \<open>{one}\<in>M\<close> \<open>?g\<in>M\<close> \<open>?f_dot = ?g\<times>{one}\<close>
    have "?f_dot\<in>M"
      using cartprod_closed by simp
    then
    have "f \<in> M[G]"
      unfolding f_def by (blast intro:GenExtI)
    have "f = {val(G,opair_name(check(\<beta>),s`\<beta>)) . \<beta>\<in>\<alpha>}"
      unfolding f_def using val_RepFun_one by simp
    also
    have "... = {\<langle>\<beta>,val(G,s`\<beta>)\<rangle> . \<beta>\<in>\<alpha>}"
      using val_opair_name valcheck generic one_in_G one_in_P by simp
    finally
    have "f = {\<langle>\<beta>,val(G,s`\<beta>)\<rangle> . \<beta>\<in>\<alpha>}" .
    then
    have 1: "domain(f) = \<alpha>" "function(f)"
      unfolding function_def by auto
    have 2: "y \<in> a \<Longrightarrow> \<exists>x\<in>\<alpha>. f ` x = y" for y
    proof -
      fix y
      assume
        "y \<in> a"
      with \<open>val(G,\<tau>) = a\<close>
      obtain \<sigma> where  "\<sigma>\<in>domain(\<tau>)" "val(G,\<sigma>) = y"
        using elem_of_val[of y _ \<tau>] by blast
      with \<open>s\<in>surj(\<alpha>,domain(\<tau>))\<close>
      obtain \<beta> where "\<beta>\<in>\<alpha>" "s`\<beta> = \<sigma>"
        unfolding surj_def by auto
      with \<open>val(G,\<sigma>) = y\<close>
      have "val(G,s`\<beta>) = y"
        by simp
      with \<open>f = {\<langle>\<beta>,val(G,s`\<beta>)\<rangle> . \<beta>\<in>\<alpha>}\<close> \<open>\<beta>\<in>\<alpha>\<close>
      have "\<langle>\<beta>,y\<rangle>\<in>f"
        by auto
      with \<open>function(f)\<close>
      have "f`\<beta> = y"
        using function_apply_equality by simp
      with \<open>\<beta>\<in>\<alpha>\<close> show
        "\<exists>\<beta>\<in>\<alpha>. f ` \<beta> = y"
        by auto
    qed
    then
    have "\<exists>\<alpha>\<in>(M[G]). \<exists>f'\<in>(M[G]). Ord(\<alpha>) \<and> f' \<in> surj(\<alpha>,a)"
    proof (cases "a=0")
      case True
      then
      have "0\<in>surj(0,a)"
        unfolding surj_def by simp
      then
      show ?thesis using zero_in_MG by auto
    next
      case False
      with \<open>a\<in>M[G]\<close>
      obtain e where "e\<in>a" "e\<in>M[G]"
        using transitivity_MG by blast
      with 1 and 2
      have "induced_surj(f,a,e) \<in> surj(\<alpha>,a)"
        using induced_surj_is_surj by simp
      moreover from \<open>f\<in>M[G]\<close> \<open>a\<in>M[G]\<close> \<open>e\<in>M[G]\<close>
      have "induced_surj(f,a,e) \<in> M[G]"
        unfolding induced_surj_def
        by (simp flip: setclass_iff)
      moreover note
        \<open>\<alpha>\<in>M[G]\<close> \<open>Ord(\<alpha>)\<close>
      ultimately show ?thesis by auto
    qed
  }
  then
  show ?thesis using mgzf.choice_ax_abs by simp
qed

end (* G_generic_extra_repl *)

end


section "Wellformed Signature and Theory"

theory Theory
  imports Term Sorts SortConstants
begin

(* Functional versions of wf_type/wf_term, for historic reasons still used in definitions and proofs *)
fun typ_ok_sig :: "signature \<Rightarrow> typ \<Rightarrow> bool" where
  "typ_ok_sig \<Sigma> (Ty c Ts) = (case type_arity \<Sigma> c of
    None \<Rightarrow> False
  | Some ar \<Rightarrow> length Ts = ar \<and> list_all (typ_ok_sig \<Sigma>) Ts)"
| "typ_ok_sig \<Sigma> (Tv _ S) = wf_sort (subclass (osig \<Sigma>)) S"

lemma typ_ok_sig_imp_wf_type: "typ_ok_sig \<Sigma> T \<Longrightarrow> wf_type \<Sigma> T"
  by (induction T) (auto split: option.splits intro: wf_type.intros simp add: list_all_iff)
lemma wf_type_imp_typ_ok_sig: "wf_type \<Sigma> T \<Longrightarrow> typ_ok_sig \<Sigma> T"
  by (induction \<Sigma> T rule: wf_type.induct) (simp_all split: option.splits add: list_all_iff)

corollary wf_type_iff_typ_ok_sig[iff]: "wf_type \<Sigma> T = typ_ok_sig \<Sigma> T"
  using wf_type_imp_typ_ok_sig typ_ok_sig_imp_wf_type by blast

fun term_ok' :: "signature \<Rightarrow> term \<Rightarrow> bool" where
  "term_ok' \<Sigma> (Fv _ T) = typ_ok_sig \<Sigma> T"
| "term_ok' \<Sigma> (Bv _) = True"
| "term_ok' \<Sigma> (Ct s T) = (case const_type \<Sigma> s of
    None \<Rightarrow> False
  | Some ty \<Rightarrow> typ_ok_sig \<Sigma> T \<and> tinstT T ty)"
| "term_ok' \<Sigma> (t $ u) \<longleftrightarrow> term_ok' \<Sigma> t \<and> term_ok' \<Sigma> u"
| "term_ok' \<Sigma> (Abs T t) \<longleftrightarrow> typ_ok_sig \<Sigma> T \<and> term_ok' \<Sigma> t"

lemma term_ok'_imp_wf_term: "term_ok' \<Sigma> t \<Longrightarrow> wf_term \<Sigma> t"
  by (induction t) (auto intro: wf_term.intros split: option.splits)
lemma wf_term_imp_term_ok': "wf_term \<Sigma> t \<Longrightarrow> term_ok' \<Sigma> t"
  by (induction \<Sigma> t rule: wf_term.induct) (auto split: option.splits)
corollary wf_term_iff_term_ok'[iff]: "wf_term \<Sigma> t = term_ok' \<Sigma> t"
  using term_ok'_imp_wf_term wf_term_imp_term_ok' by blast

lemma acyclic_empty[simp]: "acyclic {}" unfolding acyclic_def by simp

lemma "wf_sig (Map.empty, Map.empty, empty_osig)"
  by (simp add: coregular_tcsigs_def complete_tcsigs_def consistent_length_tcsigs_def
      all_normalized_and_ex_tcsigs_def)
lemma
  term_ok_imp_typ_ok_pre:
  "is_std_sig \<Sigma> \<Longrightarrow> wf_term \<Sigma> t \<Longrightarrow> list_all (typ_ok_sig \<Sigma>) Ts
  \<Longrightarrow> typ_of1 Ts t = Some ty \<Longrightarrow> typ_ok_sig \<Sigma> ty"
proof (induction Ts t arbitrary: ty rule: typ_of1.induct)
  case (2 Ts i)
  then show ?case by (auto simp add: bind_eq_Some_conv list_all_length split: option.splits if_splits)
next
  case (4 Ts T body)
  obtain bodyT where bodyT: "typ_of1 (T#Ts) body = Some bodyT"
    using "4.prems" by fastforce
  hence ty: "ty = T \<rightarrow> bodyT"
    using 4 by simp
  have "typ_ok_sig \<Sigma> bodyT"
    using 4 bodyT by simp
  thus ?case
    using ty 4 by (cases \<Sigma>) auto
next
  case (5 Ts f u T)
  from this obtain U where "typ_of1 Ts u = Some U"
    using typ_of1_split_App by blast
  moreover hence "typ_of1 Ts f = Some (U \<rightarrow> T)"
    using "5.prems"(4) by (meson typ_of1_arg_typ)
  ultimately have "typ_ok_sig \<Sigma> (U \<rightarrow> T)"
    using "5.IH"(2) "5.prems"(1) "5.prems"(2) "5.prems"(3) term_ok'.simps(4) by blast
  then show ?case
    by (auto simp add: bind_eq_Some_conv split: option.splits if_splits)
qed (auto simp add: bind_eq_Some_conv split: option.splits if_splits)

(* This might now be doable with just prod rules *)
lemma theory_full_exhaust: "(\<And>cto tao sorts axioms.
    \<Theta> = ((cto, tao, sorts), axioms) \<Longrightarrow> P)
  \<Longrightarrow> P"
  apply (cases \<Theta>) subgoal for \<Sigma> axioms apply (cases \<Sigma>) by auto done

definition [simp]: "typ_ok \<Theta> T \<equiv> wf_type (sig \<Theta>) T"
definition [simp]: "term_ok \<Theta> t \<equiv> wt_term (sig \<Theta>) t"

corollary typ_of_subst_bv_no_change: "typ_of t \<noteq> None \<Longrightarrow> subst_bv u t = t"
  using closed_subst_bv_no_change typ_of_imp_closed by auto
corollary term_ok_subst_bv_no_change: "term_ok \<Theta> t \<Longrightarrow> subst_bv u t = t"
  using typ_of_subst_bv_no_change wt_term_def by auto

lemmas eq_axs_def = eq_reflexive_ax_def eq_symmetric_ax_def eq_transitive_ax_def eq_intr_ax_def
  eq_elim_ax_def eq_combination_ax_def eq_abstract_rule_ax_def

bundle eq_axs_simp
begin
declare eq_axs_def[simp]
declare mk_all_list_def[simp] add_vars'_def[simp] bind_eq_Some_conv[simp] bind_fv_def[simp]
end

lemma typ_of_eq_ax: "typ_of (eq_reflexive_ax) = Some propT"
    "typ_of (eq_symmetric_ax) = Some propT"
    "typ_of (eq_transitive_ax) = Some propT"
    "typ_of (eq_intr_ax) = Some propT"
    "typ_of (eq_elim_ax) = Some propT"
    "typ_of (eq_combination_ax) = Some propT"
    "typ_of (eq_abstract_rule_ax) = Some propT"
  by (auto simp add: typ_of_def eq_axs_def mk_all_list_def add_vars'_def bind_eq_Some_conv bind_fv_def)

lemma term_ok_eq_ax:
  assumes "is_std_sig (sig \<Theta>)"
  shows "term_ok \<Theta> (eq_reflexive_ax)"
    "term_ok \<Theta> (eq_symmetric_ax)"
    "term_ok \<Theta> (eq_transitive_ax)"
    "term_ok \<Theta> (eq_intr_ax)"
    "term_ok \<Theta> (eq_elim_ax)"
    "term_ok \<Theta> (eq_combination_ax)"
    "term_ok \<Theta> (eq_abstract_rule_ax)"
  using assms
  by (all \<open>cases \<Theta> rule: theory_full_exhaust\<close>)
   (auto simp add: wt_term_def typ_of_def tinstT_def eq_axs_def bind_eq_Some_conv
      bind_fv_def sort_ex_def normalize_sort_def mk_all_list_def add_vars'_def wf_sort_def)

lemma wf_theory_imp_is_std_sig: "wf_theory \<Theta> \<Longrightarrow> is_std_sig (sig \<Theta>)"
  by (cases \<Theta> rule: theory_full_exhaust) simp
lemma wf_theory_imp_wf_sig: "wf_theory \<Theta> \<Longrightarrow> wf_sig (sig \<Theta>)"
  by (cases \<Theta> rule: theory_full_exhaust) simp

lemma
  term_ok_imp_typ_ok:
  "wf_theory thy \<Longrightarrow> term_ok thy t \<Longrightarrow> typ_of t = Some ty \<Longrightarrow> typ_ok thy ty"
  apply (cases thy)
  using term_ok_imp_typ_ok_pre term_ok_def
  by (metis list.pred_inject(1) wt_term_def wf_theory_imp_is_std_sig typ_of_def typ_ok_def wf_type_iff_typ_ok_sig)

lemma axioms_terms_ok: "wf_theory thy \<Longrightarrow> A\<in>axioms thy \<Longrightarrow> term_ok thy A"
  using wt_term_def by (cases thy rule: theory_full_exhaust) simp

lemma axioms_typ_of_propT: "wf_theory thy \<Longrightarrow> A\<in>axioms thy \<Longrightarrow> typ_of A = Some propT"
  using has_typ_iff_typ_of by (cases thy rule: theory_full_exhaust) simp

lemma propT_ok[simp]: "wf_theory \<Theta> \<Longrightarrow> typ_ok \<Theta> propT"
  using term_ok_imp_typ_ok wf_theory.elims(2)
  by (metis sig.simps term_ok_eq_ax(4) typ_of_eq_ax(4))

lemma term_ok_mk_eqD: "term_ok \<Theta> (mk_eq s t) \<Longrightarrow> term_ok \<Theta> s \<and> term_ok \<Theta> t"
  using term_ok'.simps(4) wt_term_def typ_of_def by (auto simp add: bind_eq_Some_conv)
lemma term_ok_app_eqD: "term_ok \<Theta> (s $ t) \<Longrightarrow> term_ok \<Theta> s \<and> term_ok \<Theta> t"
  using term_ok'.simps(4) wt_term_def typ_of_def by (auto simp add: bind_eq_Some_conv)

lemma wf_type_Type_imp_mgd:
  "wf_sig \<Sigma> \<Longrightarrow> wf_type \<Sigma> (Ty n Ts) \<Longrightarrow> tcsigs (osig \<Sigma>) n \<noteq> None"
  by (cases \<Sigma>) (auto split: option.splits)

lemma term_ok_eta_expand:
  assumes "wf_theory \<Theta>" "term_ok \<Theta> f" "typ_of f = Some (\<tau> \<rightarrow> \<tau>')" "typ_ok \<Theta> \<tau>"
  shows "term_ok \<Theta> (Abs \<tau> (f $ Bv 0))"
  using assms typ_of_eta_expand by (auto simp add: wt_term_def)

lemma term_ok'_incr_bv: "term_ok' \<Sigma> t \<Longrightarrow> term_ok' \<Sigma> (incr_bv inc lev t)"
  by (induction inc lev t rule: incr_bv.induct) auto

lemma term_ok'_subst_bv2: "term_ok' \<Sigma> s \<Longrightarrow> term_ok' \<Sigma> u \<Longrightarrow> term_ok' \<Sigma> (subst_bv2 s lev u)"
  by (induction s lev u rule: subst_bv2.induct) (auto simp add: term_ok'_incr_bv)

lemma term_ok'_subst_bv: "term_ok' \<Sigma> (Abs T t) \<Longrightarrow> term_ok' \<Sigma> (subst_bv (Fv x T) t)"
  by (simp add: substn_subst_0' term_ok'_subst_bv2)
lemma term_ok_subst_bv: "term_ok \<Theta> (Abs T t) \<Longrightarrow> term_ok \<Theta> (subst_bv (Fv x T) t)"
  apply (simp add: term_ok'_subst_bv wt_term_def)
  using subst_bv_def typ_of1_subst_bv_gen' typ_of_Abs_body_typ' typ_of_def by fastforce

lemma term_ok_subst_bv2_0: "term_ok \<Theta> (Abs T t) \<Longrightarrow> term_ok \<Theta> (subst_bv2 t 0 (Fv x T))"
  apply (clarsimp simp add: term_ok'_subst_bv2 wt_term_def)
  using substn_subst_0' typ_of1_subst_bv_gen' typ_of_Abs_body_typ' typ_of_def
    wt_term_def term_ok_subst_bv by auto

lemma has_sort_empty[simp]:
  assumes "wf_sig \<Sigma>" "wf_type \<Sigma> T"
  shows "has_sort (osig \<Sigma>) T full_sort"
proof(cases T)
  case (Ty n Ts)
  obtain cl tcs where cltcs: "osig \<Sigma> = (cl, tcs)"
    by fastforce
  obtain mgd where mgd: "tcsigs (osig \<Sigma>) n = Some mgd"
    using wf_type_Type_imp_mgd assms Ty by blast
  show ?thesis
    using mgd cltcs by (auto simp add: Ty intro!: has_sort_Ty)
next
  case (Tv v S)
  then show ?thesis
    by (cases "osig \<Sigma>") (auto simp add: sort_leq_def split: prod.splits)
qed

lemma typ_Fv_of_full_sort[simp]:
  "wf_theory \<Theta> \<Longrightarrow> term_ok \<Theta> (Fv v T) \<Longrightarrow> has_sort (osig (sig \<Theta>)) T full_sort"
  by (simp add: wt_term_def wf_theory_imp_wf_sig)

end


subsection\<open>Resolution\<close>
theory Resolution
imports CNF "HOL-Library.While_Combinator"
begin

text\<open>Resolution is different from the other proof systems:
  its derivations do not represent proofs in the way the other systems do.
  Rather, they represent invariant additions (under satisfiability) to set of clauses.\<close>
inductive Resolution :: "'a literal set set \<Rightarrow> 'a literal set \<Rightarrow> bool" ("_ \<turnstile> _" [30] 28) where
Ass: "C \<in> S \<Longrightarrow> S \<turnstile> C" |
R: "S \<turnstile> C \<Longrightarrow> S \<turnstile> D \<Longrightarrow> k\<^sup>+ \<in> C \<Longrightarrow> k\<inverse> \<in> D \<Longrightarrow> S \<turnstile> (C - {k\<^sup>+}) \<union> (D - {k\<inverse>})"
text\<open>The problematic part of this formulation is that we can't talk about a "Resolution Refutation" in an inductive manner.
  In the places where Gallier's proofs~\<^cite>\<open>"gallier2015logic"\<close> do that, we have to work around that.\<close>

lemma Resolution_weaken: "S \<turnstile> D \<Longrightarrow> T \<union> S \<turnstile> D"
  by(induction rule: Resolution.induct; auto intro: Resolution.intros)

lemma Resolution_unnecessary:
  assumes sd: "\<forall>C \<in> T. S \<turnstile> C"
  shows "T \<union> S \<turnstile> D \<longleftrightarrow> S \<turnstile> D" (is "?l \<longleftrightarrow> ?r")
proof
  assume ?l
  from \<open>?l\<close> sd show  ?r
  proof(induction "T \<union> S" D rule: Resolution.induct)
    case (Ass D)
    show ?case proof cases
      assume "D \<in> S" with Resolution.Ass show ?thesis .
    next
      assume "D \<notin> S"
      with Ass.hyps have "D \<in> T" by simp
      with Ass.prems show ?thesis by blast
    qed
  next
    case (R D H k) thus ?case by (simp add: Resolution.R)
  qed
next
  assume ?r with Resolution_weaken show ?l by blast
qed

lemma Resolution_taint_assumptions: "S \<union> T \<turnstile> C \<Longrightarrow> \<exists>R \<subseteq> D. ((\<union>) D ` S) \<union> T \<turnstile> R \<union> C"
(* No, we don't need to show this for an arbitrary clause D, but the proof doesn't get any more readable if you only allow a single atom. *)
proof(induction "S \<union> T" "C" rule: Resolution.induct)
 case (Ass C)
  show ?case proof(cases "C \<in> S")
    case True
    hence "D \<union> C \<in> (\<union>) D ` S \<union> T" by simp
    with Resolution.Ass have "((\<union>) D ` S) \<union> T \<turnstile> D \<union> C" .
    thus ?thesis by blast
  next
    case False
    with Ass have "C \<in> T" by simp
    hence "((\<union>) D ` S) \<union> T \<turnstile> C" by(simp add: Resolution.Ass)
    thus ?thesis by(intro exI[where x="{}"]) simp
  qed
next
  case (R C1 C2 k)
  let ?m = "((\<union>) D ` S) \<union> T"
  from R obtain R1 where IH1: "R1 \<subseteq> D" "?m \<turnstile> R1 \<union> C1" by blast
  from R obtain R2 where IH2: "R2 \<subseteq> D" "?m \<turnstile> R2 \<union> C2" by blast
  from R have "k\<^sup>+ \<in> R1 \<union> C1" "k\<inverse> \<in> R2 \<union> C2" by simp_all
  note Resolution.R[OF IH1(2) IH2(2) this]
  hence "?m \<turnstile> (R1 - {k\<^sup>+}) \<union> (R2 - {k\<inverse>}) \<union> (C1 - {k\<^sup>+} \<union> (C2 - {k\<inverse>}))"
    by (simp add: Un_Diff Un_left_commute sup.assoc)
  moreover have "(R1 - {k\<^sup>+}) \<union> (R2 - {k\<inverse>}) \<subseteq> D" (* hah\<triangleright> gotcha. This is the reason that I should be doing this on sets\<triangleright> not multisets. - neh, actually, there are others. how is the rule even supposed to look? *)
    using IH1(1) IH2(1) by blast
  ultimately show ?case by blast
qed

text\<open>Resolution is ``strange'':
Given a set of clauses that is presumed to be satisfiable,
it derives new clauses that can be added while preserving the satisfiability of the set of clauses.
However, not every clause that could be added while keeping satisfiability can actually be added by resolution.
Especially, the above lemma \<open>Resolution_taint_assumptions\<close> gives us the derivability of a clause
@{term "R \<union> C"}, where @{term "R \<subseteq> D"}. What we might actually want is the derivability of
@{term "D \<union> C"}. Any model that satisfies @{term "R \<union> C"} obviously satisfies @{term "D \<union> C"}
(since they are disjunctions), but Resolution only allows to derive the former.
\<close>
text\<open>Nevertheless, \<open>Resolution_taint_assumptions\<close>, can still be a quite useful lemma:
picking @{term D} to be a singleton set only leaves two possibilities for @{term R}.\<close>

lemma Resolution_useless_infinite:
assumes R: "S \<turnstile> R"
assumes "finite R"
shows "\<exists>S' \<subseteq> S. Ball S' finite \<and> finite S' \<and> (S' \<turnstile> R)"
using assms proof(induction rule: Resolution.induct)
  case (Ass C S) thus ?case using Resolution.Ass by(intro exI[where x="{C}"]) auto
next
  case (R S C D k)
  from R.prems have "finite C" "finite D" by simp_all
  with R.IH obtain SC SD where IH:
    "SC\<subseteq>S" "(\<forall>C\<in>SC. finite C)" "finite SC" "SC \<turnstile> C"
    "SD\<subseteq>S" "(\<forall>D\<in>SD. finite D)" "finite SD" "SD \<turnstile> D"
    by blast
  hence IHw: "SC \<union> SD \<turnstile> C" "SC \<union> SD \<turnstile> D" using Resolution_weaken
    by(simp_all add: sup_commute Resolution_weaken (* yes, using and simp set. whatever. *))
  with IH(1-3,5-7) show ?case
    by(blast intro!: exI[where x="SC \<union> SD"] Resolution.R[OF _ _ \<open>k\<^sup>+ \<in> C\<close> \<open>k\<inverse> \<in> D\<close>])
qed
(* situation would be different if we allowed to resolve an infinite amount of literals in one step instead of just one.
   And I think that's exactly the reason why one doesn't do that.
 *)

text\<open>Now we define and verify a toy resolution prover.
Function \<open>res\<close> computes the set of resolvents of a clause set:\<close>
context begin

definition res :: "'a clause set \<Rightarrow> 'a clause set" where
"res S =
 (\<Union>C1 \<in> S. \<Union>C2 \<in> S. \<Union>L1 \<in> C1. \<Union>L2 \<in> C2.
 (case (L1,L2) of (Pos i,Neg j) \<Rightarrow> if i=j then {(C1 - {Pos i}) \<union> (C2 - {Neg j})} else {}
  | _ \<Rightarrow> {}))"

private definition "ex1 \<equiv> {{Neg (0::int)}, {Pos 0, Pos 1, Neg 2}, {Pos 0, Pos 1, Pos 2}, {Pos 0, Neg 1}}"
value "res ex1"

(* now we want to iterate res. We've got two options. Either use the while combinator,
   which is not so beautiful to present but easy to understand, or use partial_function magic,
  which looks beautiful, but\<dots> magic. The ML kind. *)

definition Rwhile ::" 'a clause set \<Rightarrow> 'a clause set option" where
"Rwhile = while_option (\<lambda>S. \<box> \<notin> S \<and> \<not> res S \<subseteq> S) (\<lambda>S. res S \<union> S)"

value [code] "Rwhile ex1"
lemma "\<box> \<in> the (Rwhile ex1)" by eval

lemma Rwhile_sound: assumes "Rwhile S = Some S'"
  shows "\<forall>C \<in> S'. Resolution S C"
apply(rule while_option_rule[OF _ assms[unfolded Rwhile_def]])
apply (auto simp: Ass R res_def split: if_splits literal.splits)
done

definition "all_clauses S = {s. s \<subseteq> {Pos k|k. k \<in> atoms_of_cnf S} \<union> {Neg k|k. k \<in> atoms_of_cnf S}}"
lemma s_sub_all_clauses: "S \<subseteq> all_clauses S"
  unfolding all_clauses_def
  apply(rule)
  apply(simp)
  apply(rule)
  apply(simp add: atoms_of_cnf_alt lit_atoms_cases[abs_def])
  by (metis imageI literal.exhaust literal.simps(5) literal.simps(6))
lemma atoms_res: "atoms_of_cnf (res S) \<subseteq>  atoms_of_cnf S"
  unfolding res_def atoms_of_cnf_alt
  apply (clarsimp simp: lit_atoms_cases [abs_def] split: literal.splits if_splits)
  apply (clarsimp simp add: image_iff)
  apply force
  done

lemma exlitE: "(\<And>x. xe = Pos x \<Longrightarrow> P x) \<Longrightarrow> (\<And>x. xe = Neg x \<Longrightarrow> False) \<Longrightarrow> \<exists>x. xe = Pos x \<and> P x"
  by(cases xe) auto
lemma res_in_all_clauses: "res S \<subseteq> all_clauses S"
  apply (clarsimp simp: res_def all_clauses_def atoms_of_cnf_alt lit_atoms_cases
    split: literal.splits if_splits)
  apply (clarsimp simp add: image_iff)
  apply (metis atoms_of_lit.simps(1) atoms_of_lit.simps(2) lit_atoms_cases literal.exhaust)
  done

lemma Res_in_all_clauses: "res S \<union> S \<subseteq> all_clauses S"
  by (simp add: res_in_all_clauses s_sub_all_clauses)
lemma all_clauses_Res_inv: "all_clauses (res S \<union> S) = all_clauses S"
  unfolding all_clauses_def atoms_of_cnf_Un
  using atoms_res by fast
lemma all_clauses_finite: "finite S \<and> (\<forall>C \<in> S. finite C) \<Longrightarrow> finite (all_clauses S)"
  unfolding all_clauses_def atoms_of_cnf_def by simp
lemma finite_res: "\<forall>C \<in> S. finite C \<Longrightarrow> \<forall>C \<in> res S. finite C"
  unfolding res_def by(clarsimp split: literal.splits)

lemma "finite T \<Longrightarrow> S \<subseteq> T \<Longrightarrow> card S < Suc (card T)"
  by (simp add: card_mono le_imp_less_Suc)

lemma "finite S \<and> (\<forall>C \<in> S. finite C) \<Longrightarrow> \<exists>T. Rwhile S = Some T"
  apply(unfold Rwhile_def)
  apply(rule measure_while_option_Some[rotated, where f="\<lambda>T. Suc (card (all_clauses S)) - card T"
        and P="\<lambda>T. finite T \<and> (\<forall>C \<in> T. finite C) \<and> all_clauses T = all_clauses S"])
   apply(simp;fail)
  apply(intro conjI)
     subgoal by (meson all_clauses_finite finite_UnI finite_subset res_in_all_clauses)
    subgoal using finite_res by blast
   subgoal using all_clauses_Res_inv by blast
  subgoal
    apply(rule diff_less_mono2)
     subgoal by (metis Res_in_all_clauses all_clauses_finite card_seteq finite_subset not_le sup_commute sup_ge2)
    subgoal apply(intro card_mono le_imp_less_Suc)
      subgoal using all_clauses_finite by blast
      subgoal using s_sub_all_clauses by blast
    done
  done
done

partial_function(option) Res where
"Res S = (let R = res S \<union> S in if R = S then Some S else Res R)"
declare Res.simps[code]

value [code] "Res ex1"
lemma "\<box> \<in> the (Res ex1)" by code_simp

lemma res: "C \<in> res S \<Longrightarrow> S \<turnstile> C"
  unfolding res_def by(auto split: literal.splits if_splits) (metis Resolution.simps literal.exhaust)

lemma Res_sound: "Res S = Some S' \<Longrightarrow> (\<forall>C \<in> S'. S \<turnstile> C)"
proof (induction arbitrary: S S' rule: Res.fixp_induct)
  fix X S S'
  assume IH: "\<And>S S'. X S = Some S' \<Longrightarrow> (\<forall>C\<in>S'. S \<turnstile> C)"
  assume prem: "(let R = res S \<union> S in if R = S then Some S else X R) = Some S'"
  thus "(\<forall>C\<in>S'. S \<turnstile> C)"
  proof cases
    assume "res S \<union> S = S"
    with prem show ?thesis by (simp add: Resolution.Ass)
  next
    assume 1: "res S \<union> S \<noteq> S"
    with prem have "X (res S \<union> S) = Some S'" by simp
    with IH have "\<forall>C\<in>S'. res S \<union> S \<turnstile> C" by blast
    thus ?thesis using Resolution_unnecessary res by blast (* this needs the generalized Resolution_unnecessary lemma. And I don't get why the option-variant didn't. *)
  qed
qed (fast intro!: option_admissible)+

lemma Res_terminates: "finite S \<Longrightarrow> \<forall>C \<in> S. finite C \<Longrightarrow> \<exists>T. Res S = Some T"
proof(induction "card (all_clauses S) - card S" arbitrary: S rule: less_induct) (* can be done by induction on "card (all_clauses S - S)", but I found that to be more annoying. *)
  case less
  let ?r = "res S \<union> S"
  show ?case proof(cases "?r = S")
    case False
    have b: "finite (res S \<union> S)" by (meson less Res_in_all_clauses all_clauses_finite infinite_super)
    have c: "Ball (res S \<union> S) finite" using less.prems(2) finite_res by auto
    have "card S < card ?r" by (metis False b psubsetI psubset_card_mono sup_ge2)
    moreover have "card ?r \<le> (card (all_clauses S))"
      by (meson less Res_in_all_clauses all_clauses_finite card_mono le_imp_less_Suc)
    ultimately have a: "(card (all_clauses ?r)) - card ?r < (card (all_clauses S)) - card S"
      using all_clauses_Res_inv[of S] by simp
    from less(1)[OF a b c] show ?thesis by (subst Res.simps) (simp add: Let_def)
  qed (simp add: Res.simps)
qed

(* just to demonstrate, this would not work: *)
code_pred (*(modes: i \<Rightarrow> i \<Rightarrow> bool)*) Resolution . (* can't infer any modes. *)
print_theorems (* doesn't generate any theorems either. *)

end
end