(* Author: Tobias Nipkow, based on work by Daniel Somogyi *)

section \<open>Optimal BSTs: The `Quadratic' Algorithm\label{sec:quadratic}\<close>

theory Optimal_BST2
imports
  Optimal_BST
  Quadrilateral_Inequality
begin

text \<open>Knuth presented an optimization of the previously known cubic dynamic programming algorithm
to a quadratic one. A simplified proof of this optimization was found by Yao~\<^cite>\<open>"Yao80"\<close>.
Mehlhorn follows Yao closely. The core of the optimization argument is given abstractly
in theory @{theory Optimal_BST.Quadrilateral_Inequality}. In addition we first need to establish some more
properties of @{const argmin}.\<close>

text\<open>An index-based specification of @{const argmin}
expressing that the last minimal list-element is picked:\<close>

lemma argmin_takes_last: "xs \<noteq> [] \<Longrightarrow>
  argmin f xs = xs ! Max {i. i < length xs \<and> (\<forall>x \<in> set xs. f(xs!i) \<le> f x)}"
  (is "_ \<Longrightarrow> _ = _ ! Max (?M xs)")
proof(induction xs)
  case (Cons x xs)
  show ?case
  proof cases
    assume "xs = []" thus ?thesis by(simp cong: conj_cong)
  next
    assume 0: "xs \<noteq> []"
    show ?thesis
    proof cases
      assume 1: "\<forall>u \<in> set xs. f x < f u"
      hence 2: "?M (x#xs) = {0}"
        by (fastforce simp: not_less[symmetric] less_Suc_eq_0_disj)
      have "f x < f (argmin f xs)" using 0 1 argmin_Min[of xs f] by auto
      with 1 Cons.prems show ?case by(subst 2) (auto simp: Let_def)
    next
      assume 1: "\<not>(\<forall>u \<in> set xs. f x < f u)"
      have 2: "\<not> f x < f (argmin f xs)" using 1 argmin_Min[of xs f] 0 by auto
      have "argmin f xs : {u \<in> set xs. \<forall>x\<in>set xs. f u \<le> f x}"
        using 0 argmin_Min[of xs f] by (simp add: argmin_in)
      hence "{u \<in> set xs. \<forall>x\<in>set xs. f u \<le> f x} \<noteq> {}" by blast
      hence ne: "?M xs \<noteq> {}" by(auto simp: in_set_conv_nth)
      have "Max (?M (x#xs)) = Max (?M xs) + 1"
      proof (cases "\<exists>u \<in> set xs. f u < f x")
        case True
        hence "?M (x#xs) = (+) 1 ` ?M xs"
          by (auto simp: nth_Cons' image_def less_Suc_eq_0_disj)
        thus ?thesis
          using mono_Max_commute[of "(+) 1" "?M xs"] ne by (auto simp: mono_def)
      next
        case False
        hence *: "?M (x#xs) = insert 0 ((+) 1 ` ?M xs)"
          using 1 by (auto simp: nth_Cons' image_def less_Suc_eq_0_disj)
        hence "Max (?M (x#xs)) = Max ((+) 1 ` ?M xs)" using Max_insert ne by simp
        thus ?thesis using mono_Max_commute[of "(+) 1" "?M xs"] ne by (auto simp: mono_def)
      qed
      with Cons 2 0 show ?case by auto
    qed
  qed
qed simp

lemma Min_ex: "\<lbrakk> finite F; F \<noteq> {} \<rbrakk> \<Longrightarrow> \<exists>m \<in> F. \<forall>n \<in> F. m \<le> (n::_::linorder)"
using eq_Min_iff[of F "Min F"] by (fastforce)

text \<open>A consequence of @{thm [source] argmin_takes_last}:\<close>

lemma argmin_Max_Args_min_on: assumes [arith]: "i \<le> j"
shows "argmin f [i..j] = Max (Args_min_on f {i..j})"
proof -
  let ?min = "\<lambda>k. \<forall>n \<in> {i..j}. f([i..j]!k) \<le> f n"
  let ?M = "{k. k < nat(j-i+1) \<and> ?min k}"
  let ?Max = "Max ?M"
  have "?M \<noteq> {}" using Min_ex[of "f ` {i..j}"]
    apply(auto simp add: nth_upto)
    apply(rule_tac x="nat (m-i)" in exI)
    by simp
  hence "?Max < nat(j-i+1)" by(simp add: nth_upto)
  hence 1: "i + int ?Max \<le> j" by linarith
  have "argmin f [i..j] = [i..j] ! ?Max"
    using argmin_takes_last[of "[i..j]" f] by simp
  also have "\<dots> = i + int ?Max" using 1 by(simp add: nth_upto)
  also have "\<dots> = i + Max(int ` {k. k < nat(j-i+1) \<and> ?min k})"
    using \<open>?M \<noteq> {}\<close> by (simp add: monoI mono_Max_commute)
  also have "\<dots> = Max ((\<lambda>x. i + x) ` (int ` {k. k < nat(j-i+1) \<and> ?min k}))"
    using \<open>?M \<noteq> {}\<close> by (simp add: monoI mono_Max_commute)
  also have "(\<lambda>x. i + x) ` (int ` {k. k < nat(j-i+1) \<and> ?min k}) =
   {k. is_arg_min_on f {i..j} k}"
    apply(auto simp: is_arg_min_on_def Ball_def nth_upto image_def cong: conj_cong)
    apply(rule_tac x = "x-i" in exI)
    apply auto
    apply(rule_tac x = "nat(x-i)" in exI)
    by auto
   finally show ?thesis by(simp add: Args_min_simps)
qed

text \<open>As a consequence of @{thm [source] argmin_Max_Args_min_on} the following lemma
allows us to justify the restriction of the index range of @{const argmin}
used below in the optimized (quadratic) algorithm.\<close>

lemma argmin_red_ivl:
assumes "i \<le> i'" "argmin f [i..j] \<in> {i'..j'}" "j' \<le> j"
shows "argmin f [i'..j'] = argmin f [i..j]"
proof -
  have ij[arith]: "i \<le> j" using assms by simp
  have ij'[arith]: "i' \<le> j'" using assms by simp
  from Min_ex[of "f ` {i..j}"] have m: "\<exists>m \<in> {i..j}. \<forall>n \<in> {i..j}. f m \<le> f n" by auto
  note * = argmin_Max_Args_min_on[OF ij, of f]
  note ** = argmin_Max_Args_min_on[OF ij', of f]
  let ?M = "Args_min_on f {i..j}"
  let ?M' = "Args_min_on f {i'..j'}"
  have M: "finite ?M" "?M \<noteq> {}"
    using m by (fastforce simp: Args_min_simps simp del: atLeastAtMost_iff)+
  have "Max ?M \<in> ?M" by (simp add: M)
  have "Max ?M \<in> ?M'" using Max_in[OF M] assms * by(auto simp: Args_min_simps)
  have "?M' \<subseteq> ?M" using \<open>Max ?M \<in> ?M\<close> \<open>Max ?M \<in> ?M'\<close> assms(1,3)
    by(force simp add: Args_min_simps Ball_def)
  have "finite ?M'" using M(1) \<open>?M' \<subseteq> ?M\<close> infinite_super by blast
  hence "Max ?M \<le> Max ?M'" by (simp add: \<open>Max ?M \<in> ?M'\<close>)
  have "Max ?M' \<le> Max ?M" using Max.subset_imp[OF \<open>?M' \<subseteq> ?M\<close> _ M(1)] \<open>Max ?M \<in> ?M'\<close> by auto
  thus ?thesis using * ** \<open>Max ?M \<le> Max ?M'\<close> by force
qed

fun root:: "'a tree \<Rightarrow> 'a" where
"root \<langle>_,r,_\<rangle> = r"

text \<open>Now we can formulate and verify the improved algorithm. This requires two
assumptions on the weight function \<open>w\<close>.\<close>

locale Optimal_BST2 = Optimal_BST +
assumes monotone_w: "\<lbrakk>i \<le> i'; i' \<le> j; j \<le> j'\<rbrakk> \<Longrightarrow> w i' j \<le> w i j'"
assumes QI_w: "\<lbrakk>i \<le> i'; i' \<le> j; j \<le> j'\<rbrakk>\<Longrightarrow> w i j + w i' j'\<le> w i' j + w i j'"
begin

text\<open>When finding an optimal tree for @{term "[i..j]"} the optimization consists in reducing
the search for the root from @{term "[i..j]"} to
@{term "[root (opt_bst2 i (j-1)) .. root (opt_bst2 (i+1) j)]"}:\<close>

function opt_bst2 :: "int \<Rightarrow> int \<Rightarrow> int tree" where
"opt_bst2 i j =
  (if i > j then Leaf else
   if i = j then Node Leaf i Leaf else
   let left = root (opt_bst2 i (j-1)) in
   let right= root (opt_bst2 (i+1) j) in
     argmin (wpl i j) [\<langle>opt_bst2 i (k-1), k, opt_bst2 (k+1) j\<rangle>. k \<leftarrow> [left..right]])"
by auto

text \<open>The termination of @{const opt_bst2} is not completely obvious.
We first need to establish some functional properties of the terminating computations.
We start by showing that the root of the returned tree is always between \<open>left\<close> and \<open>right\<close>.
This is essentially equivalent to proving that \<open>left \<le> right\<close>
because otherwise @{const argmin} is applied to \<open>[]\<close>, which is undefined.\<close>

lemma left_le_right:
 "opt_bst2_dom(i,j) \<Longrightarrow>
  (i=j \<longrightarrow> root(opt_bst2 i j) = i) \<and>
  (i<j \<longrightarrow> root(opt_bst2 i j) \<in> {root(opt_bst2 i (j-1)) .. root(opt_bst2 (i+1) j)})"
proof (induction rule: opt_bst2.pinduct)
  case (1 i j)
  let ?left = "root (opt_bst2 i (j-1))"
  let ?right = "root (opt_bst2 (i+1) j)"
  let ?f ="(\<lambda>k. \<langle>opt_bst2 i (k - 1), k, opt_bst2 (k + 1) j\<rangle>)"
  show ?case
  proof cases
    assume "i > j" thus ?thesis by auto
  next
    assume [arith]: "\<not> i > j"
    show ?thesis
    proof cases
      assume "i = j" thus ?thesis using opt_bst2.psimps[OF "1.hyps"] by simp
    next
      assume [arith]: "i \<noteq> j"
      have left_le_right: "?left \<le> ?right"
      proof cases
        assume [arith]: "i = j-1"
        have l: "root (opt_bst2 i (j - 1)) = i" using "1.IH"(1) by auto
        have r: "root (opt_bst2 (i+1) j) = j" using "1.IH"(2) by auto
        show ?thesis using l r by auto
      next
        assume "\<not> i = j-1"
        hence[arith]: "i < j-1" by arith
        have "?left \<le> root (opt_bst2 (i + 1) (j - 1))" using "1.IH"(1) by auto
        also have "... \<le> root (opt_bst2 (i+1) j)" using "1.IH"(2) by auto
        finally have "?left \<le> ?right" .
        thus ?thesis by auto
      qed

      let ?lambda = "\<lambda>t. root t \<in> {?left .. ?right}"
      show ?thesis
        using argmin_forall[of \<open>map ?f [?left..?right]\<close> \<open>?lambda\<close> \<open>wpl i j\<close>] left_le_right
        by (fastforce simp add: opt_bst2.psimps[OF "1.hyps"])
    qed
  qed
qed

text \<open>Now we can bound the result of @{const opt_bst2} easily:\<close>

lemma root_opt_bst2_bound:
  "opt_bst2_dom (i,j) \<Longrightarrow> i \<le> j \<Longrightarrow> root (opt_bst2 i j) \<in> {i..j}"
proof(induction i j rule:opt_bst2.pinduct)
  case (1 i j)
  show ?case using  "1.prems" "1.IH"(1,2) left_le_right[OF "1.hyps"] by force
qed

text \<open>Now termination follows easily:\<close>

lemma opt_bst2_dom: "\<forall>args. opt_bst2_dom args"
by (relation "measure (\<lambda>(i,j). nat (j-i+1))") (auto dest: root_opt_bst2_bound)

termination by(rule opt_bst2_dom)

declare opt_bst2.simps[simp del]

abbreviation "min_wpl3 i j k \<equiv> min_wpl i (k-1) + min_wpl (k+1) j + w i j"

text\<open>The correctness proof \<^cite>\<open>"Yao80"\<close> is based on a general theory of `quatrilateral inequalities'
developed in locale QI that we now instantiate:\<close>

interpretation QI
  where
    c = "\<lambda>i j. min_wpl (i+1) j"
    and c_k = "\<lambda>i j. min_wpl3 (i+1) j"
    and w = "\<lambda>i j. w (i+1) j"
proof (standard, goal_cases)
  case (1 i i' j j')
  thus ?case using QI_w by simp
next
  case (2 i i' j j')
  thus ?case using monotone_w by simp
next
  case (3 i j)
  thus ?case by simp
next
  case (4 i j k)
  show ?case by simp
qed

lemma K_argmin: "i < j \<Longrightarrow> K i j = argmin (min_wpl3 (i+1) j) [i+1..j]"
by(simp add: K_def argmin_Max_Args_min_on Args_min_on_def)

theorem opt_bst2_opt_bst: "opt_bst2 i j = opt_bst i j"
proof (induction i j rule: opt_bst2.induct)
  case (1 i j)
  show ?case
  proof cases
    assume "i \<ge> j" thus ?thesis by(cases "i=j") (auto simp: opt_bst2.simps)
  next
    assume [arith]: "\<not> i \<ge> j"
    let ?c = "\<lambda>k. min_wpl i (k-1) + min_wpl (k+1) j + w i j"
    let ?opt = "\<lambda>k. \<langle>opt_bst i (k-1), k, opt_bst (k+1) j\<rangle>"
    have 1: "i \<le> K (i-1) (j-1)"
      using argmin_in[of "[i..j-1]"] by(auto simp add: K_argmin)
    have 2: "argmin ?c [i..j] \<in> {K (i-1) (j-1)..K i j}"
      using lemma_3[of "i-1" "j-1"] by(simp add: K_argmin)
    have 3: "K i j \<le> j" using argmin_in[of "[i+1..j]"] by(auto simp: K_argmin)
    have *: "argmin ?c [K (i-1) (j-1)..K i j] = argmin ?c [i..j]"
      by(rule argmin_red_ivl[OF 1 2 3])
    have "opt_bst2 i j =
     argmin (wpl i j) (map ?opt [root(opt_bst2 i (j-1))..root(opt_bst2 (i+1) j)])"
      using [[simp_depth_limit=3]]
      by(simp add: "1.IH"(3,4)[OF _ _ refl refl] opt_bst2.simps[of i j] cong: list.map_cong_simp)
    also have "\<dots> = argmin (wpl i j) (map ?opt [root(opt_bst i (j-1))..root(opt_bst (i+1) j)])"
      by (simp add: "1.IH"(1,2))
    also have "root(opt_bst i (j-1)) = K (i-1) (j-1)"
      by(simp add: argmin_map wpl_opt_bst comp_def K_argmin)
    also have "root(opt_bst (i+1) j) = K i j"
      by(simp add: argmin_map wpl_opt_bst comp_def K_argmin)
    also have "argmin (wpl i j) (map ?opt [K (i - 1) (j - 1)..K i j])
       = ?opt (argmin (wpl i j o ?opt) [K (i-1) (j-1)..K i j])"
      using lemma_3[of "i-1" "j-1"] by(simp add: argmin_map)
    also have "\<dots> = ?opt (argmin ?c [K (i-1) (j-1)..K i j])"
      by(simp add: comp_def wpl_opt_bst)
    also have "\<dots> = ?opt(argmin ?c [i..j])"
      by (simp add: "*")
    also have "\<dots> = ?opt(argmin (wpl i j o ?opt) [i..j])"
      by(simp add: comp_def wpl_opt_bst)
    also have "\<dots> = argmin (wpl i j) (map ?opt [i..j])"
      by(simp add: argmin_map)
    also have "\<dots> = opt_bst i j"
      by simp
    finally show ?thesis .
  qed
qed

corollary opt_bst2_is_optimal: "wpl i j (opt_bst2 i j) = min_wpl i j"
by (simp add: opt_bst2_opt_bst wpl_opt_bst)

function opt_bst_wpl2 :: "int \<Rightarrow> int \<Rightarrow> int tree \<times> nat" where
"opt_bst_wpl2 i j =
  (if i > j then (Leaf,0) else
   if i = j then (Node Leaf i Leaf, w i i) else
   let l = root(fst(opt_bst_wpl2 i (j-1)));
      r = root(fst(opt_bst_wpl2 (i+1) j)) in
     argmin snd
       [let (tl,wl) = opt_bst_wpl2 i (k-1); (tr,wr) = opt_bst_wpl2 (k+1) j
        in (\<langle>tl, k, tr\<rangle>, wl + wr + w i j) . k \<leftarrow> [l..r]])"
by auto

lemma left_le_right2:
 "opt_bst_wpl2_dom(i,j) \<Longrightarrow>
  (i=j \<longrightarrow> root(fst(opt_bst_wpl2 i j)) = i) \<and>
  (i<j \<longrightarrow> root(fst(opt_bst_wpl2 i j)) \<in>
    {root(fst(opt_bst_wpl2 i (j-1))) .. root(fst(opt_bst_wpl2 (i+1) j))})"
proof (induction rule: opt_bst_wpl2.pinduct)
  case (1 i j)
  let ?l = "root (fst(opt_bst_wpl2 i (j-1)))"
  let ?r = "root (fst(opt_bst_wpl2 (i+1) j))"
  let ?f ="\<lambda>k. let (tl,wl) = opt_bst_wpl2 i (k-1); (tr,wr) = opt_bst_wpl2 (k+1) j
               in (\<langle>tl, k, tr\<rangle>, wl + wr + w i j)"
  show ?case
  proof cases
    assume "i > j" thus ?thesis by auto
  next
    assume [arith]: "\<not> i > j"
    show ?thesis
    proof cases
      assume "i = j" thus ?thesis using opt_bst_wpl2.psimps[OF "1.hyps"] by simp
    next
      assume [arith]: "i \<noteq> j"
      have left_le_right: "?l \<le> ?r"
      proof cases
        assume [arith]: "i = j-1"
        have l: "root (fst(opt_bst_wpl2 i (j-1))) = i" using "1.IH"(1) by auto
        have r: "root (fst(opt_bst_wpl2 (i+1) j)) = j" using \<open>i = j-1\<close> "1.IH"(2)
          by auto
        show ?thesis using l r by auto
      next
        assume "\<not> i = j-1"
        hence[arith]: "i < j-1" by arith
        have "?l \<le> root (fst(opt_bst_wpl2 (i+1) (j-1)))" using "1.IH"(1) by auto
        also have "... \<le> root (fst(opt_bst_wpl2 (i+1) j))" using "1.IH"(2) by auto
        finally have "?l \<le> ?r" .
        thus ?thesis by auto
      qed

      let ?P = "\<lambda>t. root (fst t) \<in> {?l .. ?r}"
      show ?thesis
        using argmin_forall[of \<open>map ?f [?l..?r]\<close> ?P snd] left_le_right
        by (fastforce simp add: opt_bst_wpl2.psimps[OF "1.hyps"] split: prod.splits)
    qed
  qed
qed

text \<open>Now we can bound the result of @{const opt_bst_wpl2}:\<close>

lemma root_opt_bst_wpl2_bound:
  "opt_bst_wpl2_dom (i,j) \<Longrightarrow> i \<le> j \<Longrightarrow> root (fst(opt_bst_wpl2 i j)) \<in> {i..j}"
proof(induction i j rule:opt_bst_wpl2.pinduct)
  case (1 i j)
  show ?case using  "1.prems" "1.IH"(1)  "1.IH"(2)[OF _ _ refl] left_le_right2[OF "1.hyps"]
    by fastforce
qed

text \<open>Now termination follows easily:\<close>

lemma opt_bst_wpl2_dom: "\<forall>args. opt_bst_wpl2_dom args"
by (relation "measure (\<lambda>(i,j). nat (j-i+1))") (auto dest: root_opt_bst_wpl2_bound)

termination by(rule opt_bst_wpl2_dom)

declare opt_bst_wpl2.simps[simp del]

lemma opt_bst_wpl2_eq_pair:
  "opt_bst_wpl2 i j = (opt_bst2 i j, wpl i j (opt_bst2 i j))"
proof(induction i j rule: opt_bst_wpl2.induct)
  case (1 i j)
  note [simp] = opt_bst2.simps[of i j] opt_bst_wpl2.simps[of i j] (*opt_bst2_opt_bst*)
  show ?case
  proof cases
    assume "i > j" thus ?thesis using "1.prems" by (simp)
  next
    assume [arith]: "\<not> i > j"
    show ?case
    proof cases
      assume [arith]: "i = j"
      show ?thesis by(simp) (simp add: \<open>i = j\<close>)
    next
      assume [arith]: "i \<noteq> j"
      let ?l = "root (opt_bst2 i (j-1))" let ?r = "root (opt_bst2 (i+1) j)"
      have *: "?l \<le> ?r"
        using left_le_right[of i j] by (fastforce simp: opt_bst2_opt_bst opt_bst2_dom)
      let ?f = "\<lambda>k. case opt_bst_wpl2 i (k-1) of
             (l,wl) \<Rightarrow> case opt_bst_wpl2 (k+1) j of
                         (r,wr) \<Rightarrow> (\<langle>l,k,r\<rangle>, wl + wr + w i j)"
      let ?g = "\<lambda>k. (\<langle>opt_bst2 i (k-1), k, opt_bst2 (k+1) j\<rangle>,
                    wpl i (k-1) (opt_bst2 i (k-1)) + wpl (k+1) j (opt_bst2 (k+1) j) + w i j)"
      have fg: "?f k = ?g k" if k: "k \<in> {?l..?r}" for k
      proof -
        have 1: "opt_bst_wpl2 i (k-1) = (opt_bst2 i (k-1), wpl i (k-1) (opt_bst2 i (k-1)))"
          using k "1.IH"(3) by(simp add: "1.IH"(1,2))
        have 2: "opt_bst_wpl2 (k+1) j = (opt_bst2 (k+1) j, wpl (k+1) j (opt_bst2 (k+1) j))"
          using 1 k "1.IH"(4) by(simp add: "1.IH"(1,2))
        show ?thesis using 1 2 by(simp)
      qed
      have "opt_bst_wpl2 i j =
        argmin snd (map ?f [root(fst(opt_bst_wpl2 i (j-1)))..root(fst(opt_bst_wpl2 (i+1) j))])"
        by(simp)
      also have "\<dots> = argmin snd (map ?f [?l..?r])"
        by(simp add: "1.IH"(1,2))
      also have "\<dots> = argmin snd (map ?g [?l..?r])"
        using fg by (simp cong: list.map_cong_simp)
      also have "\<dots> = (opt_bst2 i j, wpl i j (opt_bst2 i j))" using *
        by(simp add: argmin_pairs comp_def)
      finally show ?thesis .
    qed
  qed
qed

corollary opt_bst_wpl2_eq_pair': "opt_bst_wpl2 i j = (opt_bst i j, min_wpl i j)"
by (simp add: opt_bst_wpl2_eq_pair opt_bst2_opt_bst wpl_opt_bst)

end (* locale Optimal_BST2 *)

end


(*  Title:      HOL/HOLCF/IOA/NTP/Multiset.thy
    Author:     Tobias Nipkow & Konrad Slind
*)

section {* Axiomatic multisets *}

theory Multiset
imports Lemmas
begin

typedecl
  'a multiset

consts

  emptym :: "'a multiset"                        ("{|}")
  addm   :: "['a multiset, 'a] => 'a multiset"
  delm   :: "['a multiset, 'a] => 'a multiset"
  countm :: "['a multiset, 'a => bool] => nat"
  count  :: "['a multiset, 'a] => nat"

axiomatization where

delm_empty_def:
  "delm {|} x = {|}" and

delm_nonempty_def:
  "delm (addm M x) y == (if x=y then M else addm (delm M y) x)" and

countm_empty_def:
   "countm {|} P == 0" and

countm_nonempty_def:
   "countm (addm M x) P == countm M P + (if P x then Suc 0 else 0)" and

count_def:
   "count M x == countm M (%y. y = x)" and

"induction":
   "\<And>P M. [| P({|}); !!M x. P(M) ==> P(addm M x) |] ==> P(M)"

lemma count_empty:
   "count {|} x = 0"
  by (simp add: Multiset.count_def Multiset.countm_empty_def)

lemma count_addm_simp:
     "count (addm M x) y = (if y=x then Suc(count M y) else count M y)"
  by (simp add: Multiset.count_def Multiset.countm_nonempty_def)

lemma count_leq_addm: "count M y <= count (addm M x) y"
  by (simp add: count_addm_simp)

lemma count_delm_simp:
     "count (delm M x) y = (if y=x then count M y - 1 else count M y)"
apply (unfold Multiset.count_def)
apply (rule_tac M = "M" in Multiset.induction)
apply (simp (no_asm_simp) add: Multiset.delm_empty_def Multiset.countm_empty_def)
apply (simp add: Multiset.delm_nonempty_def Multiset.countm_nonempty_def)
apply safe
apply simp
done

lemma countm_props: "!!M. (!x. P(x) --> Q(x)) ==> (countm M P <= countm M Q)"
apply (rule_tac M = "M" in Multiset.induction)
 apply (simp (no_asm) add: Multiset.countm_empty_def)
apply (simp (no_asm) add: Multiset.countm_nonempty_def)
apply auto
done

lemma countm_spurious_delm: "!!P. ~P(obj) ==> countm M P = countm (delm M obj) P"
  apply (rule_tac M = "M" in Multiset.induction)
  apply (simp (no_asm) add: Multiset.delm_empty_def Multiset.countm_empty_def)
  apply (simp (no_asm_simp) add: Multiset.countm_nonempty_def Multiset.delm_nonempty_def)
  done

lemma pos_count_imp_pos_countm [rule_format (no_asm)]: "!!P. P(x) ==> 0<count M x --> countm M P > 0"
  apply (rule_tac M = "M" in Multiset.induction)
  apply (simp (no_asm) add: Multiset.delm_empty_def Multiset.count_def Multiset.countm_empty_def)
  apply (simp add: Multiset.count_def Multiset.delm_nonempty_def Multiset.countm_nonempty_def)
  done

lemma countm_done_delm:
   "!!P. P(x) ==> 0<count M x --> countm (delm M x) P = countm M P - 1"
  apply (rule_tac M = "M" in Multiset.induction)
  apply (simp (no_asm) add: Multiset.delm_empty_def Multiset.countm_empty_def)
  apply (simp (no_asm_simp) add: count_addm_simp Multiset.delm_nonempty_def Multiset.countm_nonempty_def pos_count_imp_pos_countm)
  apply auto
  done

declare count_addm_simp [simp] count_delm_simp [simp]
  Multiset.countm_empty_def [simp] Multiset.delm_empty_def [simp] count_empty [simp]

end


subsection \<open>Exact Division of Multivariate Polynomials\<close>

theory MPoly_Divide
  imports
    Hermite_Lindemann.More_Multivariate_Polynomial_HLW
    Polynomials.MPoly_Type_Class
    Poly_Connection
begin

lemma poly_lead_coeff_dvd_lead_coeff:
  assumes "p dvd (q :: 'a :: idom poly)"
  shows   "Polynomial.lead_coeff p dvd Polynomial.lead_coeff q"
  using assms by (elim dvdE) (auto simp: Polynomial.lead_coeff_mult)

text \<open>
  Since there is no particularly sensible algorithm for division with a remainder on
  multivariate polynomials, we define the following division operator that performs an
  exact division if possible and returns 0 otherwise.
\<close>

instantiation mpoly :: ("comm_semiring_1") divide
begin

definition divide_mpoly :: "'a mpoly \<Rightarrow> 'a mpoly \<Rightarrow> 'a mpoly" where
  "divide_mpoly x y = (if y \<noteq> 0 \<and> y dvd x then THE z. x = y * z else 0)"

instance ..

end

instance mpoly :: (idom) idom_divide
  by standard (auto simp: divide_mpoly_def)

lemma (in transfer_mpoly_to_mpoly_poly) transfer_div [transfer_rule]:
  assumes [transfer_rule]: "R p' p" "R q' q"
  assumes "q dvd p"
  shows   "R (p' div q') (p div q)"
  using assms
  by (smt (z3) div_by_0 dvd_imp_mult_div_cancel_left mpoly_to_mpoly_poly_0 mpoly_to_mpoly_poly_eq_iff
        mpoly_to_mpoly_poly_mult nonzero_mult_div_cancel_left transfer_mpoly_to_mpoly_poly.R_def)

instantiation mpoly :: ("{normalization_semidom, idom}") normalization_semidom
begin

definition unit_factor_mpoly :: "'a mpoly \<Rightarrow> 'a mpoly" where
  "unit_factor_mpoly p = Const (unit_factor (lead_coeff p))"

definition normalize_mpoly :: "'a mpoly \<Rightarrow> 'a mpoly" where
  "normalize_mpoly p = Rings.divide p (unit_factor p)"

lemma unit_factor_mpoly_Const [simp]:
  "unit_factor (Const c) = Const (unit_factor c)"
  unfolding unit_factor_mpoly_def by simp

lemma normalize_mpoly_Const [simp]:
  "normalize (Const c) = Const (normalize c)"
proof (cases "c = 0")
  case False
  have "normalize (Const c) = Const c div Const (unit_factor c)"
    by (simp add: normalize_mpoly_def)
  also have "\<dots> = Const (unit_factor c * normalize c) div Const (unit_factor c)"
    by simp
  also have "\<dots> = Const (unit_factor c) * Const (normalize c) div Const (unit_factor c)"
    by (subst mpoly_Const_mult) auto
  also have "\<dots> = Const (normalize c)"
    using \<open>c \<noteq> 0\<close>
    by (subst nonzero_mult_div_cancel_left) auto
  finally show ?thesis .
qed (auto simp: normalize_mpoly_def)

instance proof
  show "unit_factor (0 :: 'a mpoly) = 0"
    by (simp add: unit_factor_mpoly_def)
next
  show "unit_factor x = x" if "x dvd 1" for x :: "'a mpoly"
    using that by (auto elim!: mpoly_is_unitE simp: is_unit_unit_factor)
next
  fix x :: "'a mpoly"
  assume "x \<noteq> 0"
  thus "unit_factor x dvd 1"
    by (auto simp: unit_factor_mpoly_def)
next
  fix x y :: "'a mpoly"
  assume "x dvd 1"
  hence "x \<noteq> 0"
    by auto
  show "unit_factor (x * y) = x * unit_factor y"
  proof (cases "y = 0")
    case False
    have "Const (unit_factor (lead_coeff x * lead_coeff y)) =
            x * Const (unit_factor (lead_coeff y))" using \<open>x dvd 1\<close>
      by (subst unit_factor_mult_unit_left)
         (auto elim!: mpoly_is_unitE simp: mpoly_Const_mult)
    thus ?thesis using \<open>x \<noteq> 0\<close> False
      by (simp add: unit_factor_mpoly_def lead_coeff_mult)
  qed (auto simp: unit_factor_mpoly_def)
next
  fix p :: "'a mpoly"
  let ?c = "Const (unit_factor (lead_coeff p))"
  show "unit_factor p * normalize p = p"
  proof (cases "p = 0")
    case False
    hence "?c dvd 1"
      by (intro is_unit_ConstI) auto
    also have "1 dvd p"
      by simp
    finally have "?c * (p div ?c) = p"
      by (rule dvd_imp_mult_div_cancel_left)
    thus ?thesis
      by (auto simp: unit_factor_mpoly_def normalize_mpoly_def)
  qed (auto simp: normalize_mpoly_def)
next
  show "normalize (0 :: 'a mpoly) = 0"
    by (simp add: normalize_mpoly_def)
qed

end

text \<open>
  The following is an exact division operator that can fail, i.e.\ if the divisor does not
  divide the dividend, it returns \<^const>\<open>None\<close>.
\<close>

definition divide_option :: "'a :: idom_divide \<Rightarrow> 'a \<Rightarrow> 'a option"  (infixl "div?" 70) where
  "divide_option p q = (if q dvd p then Some (p div q) else None)"

text \<open>
  We now show that exact division on the ring $R[X_1,\ldots, X_n]$ can be reduced to
  exact division on the ring $R[X_1,\ldots,X_n][X]$, i.e.\ we can go from \<^typ>\<open>'a mpoly\<close> to
  a \<^typ>\<open>'a mpoly poly\<close> where the coefficients have one variable less than the original
  multivariate polynomial. We basically simply use the isomorphism between these two rings.
\<close>

lemma divide_option_mpoly:
  fixes p q :: "'a :: idom_divide mpoly"
  shows "p div? q = (let V = vars p \<union> vars q in
           (if V = {} then
              let a = MPoly_Type.coeff p 0; b = MPoly_Type.coeff q 0; c = a div b
              in  if b * c = a then Some (Const c) else None
            else
              let x = Max V;
                  p' = mpoly_to_mpoly_poly x p; q' = mpoly_to_mpoly_poly x q
              in  case p' div? q' of
                    None \<Rightarrow> None
                  | Some r \<Rightarrow> Some (poly r (Var x))))" (is "_ = ?rhs")
proof -
  define x where "x = Max (vars p \<union> vars q)"
  define p' where "p' = mpoly_to_mpoly_poly x p"
  define q' where "q' = mpoly_to_mpoly_poly x q"
  interpret transfer_mpoly_to_mpoly_poly x .
  have [transfer_rule]: "R p' p" "R q' q"
    by (auto simp: p'_def q'_def R_def)

  show ?thesis
  proof (cases "vars p \<union> vars q = {}")
    case True
    define a where "a = MPoly_Type.coeff p 0"
    define b where "b = MPoly_Type.coeff q 0"
    have [simp]: "p = Const a" "q = Const b"
      using True by (auto elim!: vars_emptyE simp: a_def b_def mpoly_coeff_Const)
    show ?thesis
      apply (cases "b = 0")
       apply (auto simp: Let_def mpoly_coeff_Const mpoly_Const_mult divide_option_def elim!: dvdE)
      by (metis dvd_triv_left)
  next
    case False
    have "?rhs =
            (case p' div? q' of None \<Rightarrow> None
              | Some r \<Rightarrow> Some (poly r (Var x)))"
      using False
      unfolding Let_def
      apply (simp only: )
      apply (subst if_False)
      apply (simp flip: x_def p'_def q'_def cong: option.case_cong)
      done
    also have "\<dots> = (if q' dvd p' then Some (poly (p' div q') (Var x)) else None)"
      using False by (auto simp: divide_option_def)
    also have "\<dots> = p div? q"
      unfolding divide_option_def
    proof (intro if_cong refl arg_cong[where f = Some])
      show "(q' dvd p') = (q dvd p)"
        by transfer_prover
    next
      assume [transfer_rule]: "q dvd p"
      have "R (p' div q') (p div q)"
        by transfer_prover
      thus "poly (p' div q') (Var x) = p div q"
        by (simp add: R_def poly_mpoly_to_mpoly_poly)
    qed
    finally show ?thesis ..
  qed
qed

text \<open>
  Next, we show that exact division on the ring $R[X_1,\ldots,X_n][Y]$ can be reduced to
  exact division on the ring $R[X_1,\ldots,X_n]$. This is essentially just polynomial division.
\<close>
lemma divide_option_mpoly_poly:
  fixes p q :: "'a :: idom_divide mpoly poly"
  shows "p div? q =
            (if p = 0 then Some 0
            else if q = 0 then None
            else let dp = Polynomial.degree p; dq = Polynomial.degree q
                 in  if dp < dq then None
                     else case Polynomial.lead_coeff p div? Polynomial.lead_coeff q of
                            None \<Rightarrow> None
                          | Some c \<Rightarrow> (
                              case (p - Polynomial.monom c (dp - dq) * q) div? q of
                                None \<Rightarrow> None
                              | Some r \<Rightarrow> Some (Polynomial.monom c (dp - dq) + r)))"
  (is "_ = ?rhs")
proof (cases "p = 0"; cases "q = 0")
  assume [simp]: "p \<noteq> 0" "q \<noteq> 0"
  define dp where "dp = Polynomial.degree p"
  define dq where "dq = Polynomial.degree q"
  define cp where "cp = Polynomial.lead_coeff p"
  define cq where "cq = Polynomial.lead_coeff q"
  define mon where "mon = Polynomial.monom (cp div cq) (dp - dq)"
  show ?thesis
  proof (cases "dp < dq")
    case True
    hence "\<not>q dvd p"
      unfolding dp_def dq_def
      by (meson \<open>p \<noteq> 0\<close> divides_degree leD)
    thus ?thesis
      using True by (simp add: divide_option_def dp_def dq_def)
  next
    case deg: False
    show ?thesis
    proof (cases "cq dvd cp")
      case False
      hence "\<not>q dvd p"
        unfolding cq_def cp_def using poly_lead_coeff_dvd_lead_coeff by blast
      thus ?thesis
        using deg False by (simp add: dp_def dq_def Let_def divide_option_def cp_def cq_def)
    next
      case dvd1: True
      show ?thesis
      proof (cases "q dvd (p - mon * q)")
        case False
        hence "\<not>q dvd p"
          by (meson dvd_diff dvd_triv_right)
        thus ?thesis
          using deg dvd1 False
          by (simp add: dp_def dq_def Let_def divide_option_def cp_def cq_def mon_def)
      next
        case dvd2: True
        hence "q dvd p"
          by (metis diff_eq_eq dvd_add dvd_triv_right)
        have "?rhs = Some (mon + (p - mon * q) div q)"
          using deg dvd1 dvd2
          by (simp add: dp_def dq_def Let_def divide_option_def cp_def cq_def mon_def)
        also have "mon + (p - mon * q) div q = p div q"
          using dvd2 by (elim dvdE) (auto simp: algebra_simps)
        also have "Some \<dots> = p div? q"
          using \<open>q dvd p\<close> by (simp add: divide_option_def)
        finally show ?thesis ..
      qed
    qed
  qed
qed (auto simp: divide_option_def)

text \<open>
  These two equations now serve as two mutually recursive code equations that allow us to
  reduce exact division of multivariate polynomials to exact division of their coefficients.
  Termination of these code equations is not shown explicitly, but is obvious since one variable
  is eliminated in every step.
\<close>

definition divide_option_mpoly :: "'a :: idom_divide mpoly \<Rightarrow> _"
  where "divide_option_mpoly = divide_option"

definition divide_option_mpoly_poly :: "'a :: idom_divide mpoly poly \<Rightarrow> _"
  where "divide_option_mpoly_poly = divide_option"

lemmas divide_option_mpoly_code [code] =
  divide_option_mpoly [folded divide_option_mpoly_def divide_option_mpoly_poly_def]

lemmas divide_option_mpoly_poly_code [code] =
  divide_option_mpoly_poly [folded divide_option_mpoly_def divide_option_mpoly_poly_def]

lemma divide_mpoly_code [code]:
  fixes p q :: "'a :: idom_divide mpoly"
  shows "p div q = (case divide_option_mpoly p q of None \<Rightarrow> 0 | Some r \<Rightarrow> r)"
  by (auto simp: divide_option_mpoly_def divide_option_def divide_mpoly_def)

end


(*  Title:      HOL/Cardinals/Bounded_Set.thy
    Author:     Dmitriy Traytel, TU Muenchen
    Copyright   2015

Bounded powerset type.
*)

section \<open>Sets Strictly Bounded by an Infinite Cardinal\<close>

theory Bounded_Set
imports Cardinals
begin

typedef ('a, 'k) bset ("_ set[_]" [22, 21] 21) =
  "{A :: 'a set. |A| <o natLeq +c |UNIV :: 'k set|}"
  morphisms set_bset Abs_bset
  by (rule exI[of _ "{}"]) (auto simp: card_of_empty4 csum_def)

setup_lifting type_definition_bset

lift_definition map_bset ::
  "('a \<Rightarrow> 'b) \<Rightarrow> 'a set['k] \<Rightarrow> 'b set['k]" is image
  using card_of_image ordLeq_ordLess_trans by blast

lift_definition rel_bset ::
  "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a set['k] \<Rightarrow> 'b set['k] \<Rightarrow> bool" is rel_set
  .

lift_definition bempty :: "'a set['k]" is "{}"
  by (auto simp: card_of_empty4 csum_def)

lift_definition binsert :: "'a \<Rightarrow> 'a set['k] \<Rightarrow> 'a set['k]" is "insert"
  using infinite_card_of_insert ordIso_ordLess_trans Field_card_of Field_natLeq UNIV_Plus_UNIV
   csum_def finite_Plus_UNIV_iff finite_insert finite_ordLess_infinite2 infinite_UNIV_nat by metis

definition bsingleton where
  "bsingleton x = binsert x bempty"

lemma set_bset_to_set_bset: "|A| <o natLeq +c |UNIV :: 'k set| \<Longrightarrow>
  set_bset (the_inv set_bset A :: 'a set['k]) = A"
  apply (rule f_the_inv_into_f[unfolded inj_on_def])
  apply (simp add: set_bset_inject range_eqI Abs_bset_inverse[symmetric])
  apply (rule range_eqI Abs_bset_inverse[symmetric] CollectI)+
  .

lemma rel_bset_aux_infinite:
  fixes a :: "'a set['k]" and b :: "'b set['k]"
  shows "(\<forall>t \<in> set_bset a. \<exists>u \<in> set_bset b. R t u) \<and> (\<forall>u \<in> set_bset b. \<exists>t \<in> set_bset a. R t u) \<longleftrightarrow>
   ((BNF_Def.Grp {a. set_bset a \<subseteq> {(a, b). R a b}} (map_bset fst))\<inverse>\<inverse> OO
    BNF_Def.Grp {a. set_bset a \<subseteq> {(a, b). R a b}} (map_bset snd)) a b" (is "?L \<longleftrightarrow> ?R")
proof
  assume ?L
  define R' :: "('a \<times> 'b) set['k]"
    where "R' = the_inv set_bset (Collect (case_prod R) \<inter> (set_bset a \<times> set_bset b))"
      (is "_ = the_inv set_bset ?L'")
  have "|?L'| <o natLeq +c |UNIV :: 'k set|"
    unfolding csum_def Field_natLeq
    by (intro ordLeq_ordLess_trans[OF card_of_mono1[OF Int_lower2]]
      card_of_Times_ordLess_infinite)
      (simp, (transfer, simp add: csum_def Field_natLeq)+)
  hence *: "set_bset R' = ?L'" unfolding R'_def by (intro set_bset_to_set_bset)
  show ?R unfolding Grp_def relcompp.simps conversep.simps
  proof (intro CollectI case_prodI exI[of _ a] exI[of _ b] exI[of _ R'] conjI refl)
    from * show "a = map_bset fst R'" using conjunct1[OF \<open>?L\<close>]
      by (transfer, auto simp add: image_def Int_def split: prod.splits)
    from * show "b = map_bset snd R'" using conjunct2[OF \<open>?L\<close>]
      by (transfer, auto simp add: image_def Int_def split: prod.splits)
  qed (auto simp add: *)
next
  assume ?R thus ?L unfolding Grp_def relcompp.simps conversep.simps
    by transfer force
qed

bnf "'a set['k]"
  map: map_bset
  sets: set_bset
  bd: "natLeq +c card_suc |UNIV :: 'k set|"
  wits: bempty
  rel: rel_bset
proof -
  show "map_bset id = id" by (rule ext, transfer) simp
next
  fix f g
  show "map_bset (f o g) = map_bset f o map_bset g" by (rule ext, transfer) auto
next
  fix X f g
  assume "\<And>z. z \<in> set_bset X \<Longrightarrow> f z = g z"
  then show "map_bset f X = map_bset g X" by transfer force
next
  fix f
  show "set_bset \<circ> map_bset f = (`) f \<circ> set_bset" by (rule ext, transfer) auto
next
  fix X :: "'a set['k]"
  have "|set_bset X| <o natLeq +c |UNIV :: 'k set|" by transfer blast
  then show "|set_bset X| <o natLeq +c card_suc |UNIV :: 'k set|"
    by (rule ordLess_ordLeq_trans[OF _ csum_mono2[OF ordLess_imp_ordLeq[OF card_suc_greater[OF card_of_card_order_on]]]])
next
  fix R S
  show "rel_bset R OO rel_bset S \<le> rel_bset (R OO S)"
    by (rule predicate2I, transfer) (auto simp: rel_set_OO[symmetric])
next
  fix R :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
  show "rel_bset R = ((\<lambda>x y. \<exists>z. set_bset z \<subseteq> {(x, y). R x y} \<and>
    map_bset fst z = x \<and> map_bset snd z = y) :: 'a set['k] \<Rightarrow> 'b set['k] \<Rightarrow> bool)"
    by (simp add: rel_bset_def map_fun_def o_def rel_set_def
      rel_bset_aux_infinite[unfolded OO_Grp_alt])
next
  fix x
  assume "x \<in> set_bset bempty"
  then show False by transfer simp
qed (simp_all add: card_order_bd_fun Cinfinite_bd_fun regularCard_bd_fun)

lemma map_bset_bempty[simp]: "map_bset f bempty = bempty"
  by transfer auto

lemma map_bset_binsert[simp]: "map_bset f (binsert x X) = binsert (f x) (map_bset f X)"
  by transfer auto

lemma map_bset_bsingleton: "map_bset f (bsingleton x) = bsingleton (f x)"
  unfolding bsingleton_def by simp

lemma bempty_not_binsert: "bempty \<noteq> binsert x X" "binsert x X \<noteq> bempty"
  by (transfer, auto)+

lemma bempty_not_bsingleton[simp]: "bempty \<noteq> bsingleton x" "bsingleton x \<noteq> bempty"
  unfolding bsingleton_def by (simp_all add: bempty_not_binsert)

lemma bsingleton_inj[simp]: "bsingleton x = bsingleton y \<longleftrightarrow> x = y"
  unfolding bsingleton_def by transfer auto

lemma rel_bsingleton[simp]:
  "rel_bset R (bsingleton x1) (bsingleton x2) = R x1 x2"
  unfolding bsingleton_def
  by transfer (auto simp: rel_set_def)

lemma rel_bset_bsingleton[simp]:
  "rel_bset R (bsingleton x1) = (\<lambda>X. X \<noteq> bempty \<and> (\<forall>x2\<in>set_bset X. R x1 x2))"
  "rel_bset R X (bsingleton x2) = (X \<noteq> bempty \<and> (\<forall>x1\<in>set_bset X. R x1 x2))"
  unfolding bsingleton_def fun_eq_iff
  by (transfer, force simp add: rel_set_def)+

lemma rel_bset_bempty[simp]:
  "rel_bset R bempty X = (X = bempty)"
  "rel_bset R Y bempty = (Y = bempty)"
  by (transfer, simp add: rel_set_def)+

definition bset_of_option where
  "bset_of_option = case_option bempty bsingleton"

lift_definition bgraph :: "('a \<Rightarrow> 'b option) \<Rightarrow> ('a \<times> 'b) set['a set]" is
  "\<lambda>f. {(a, b). f a = Some b}"
proof -
  fix f :: "'a \<Rightarrow> 'b option"
  have "|{(a, b). f a = Some b}| \<le>o |UNIV :: 'a set|"
    by (rule surj_imp_ordLeq[of _ "\<lambda>x. (x, the (f x))"]) auto
  also have "|UNIV :: 'a set| <o |UNIV :: 'a set set|"
    by simp
  also have "|UNIV :: 'a set set| \<le>o natLeq +c |UNIV :: 'a set set|"
    by (rule ordLeq_csum2) simp
  finally show "|{(a, b). f a = Some b}| <o natLeq +c |UNIV :: 'a set set|" .
qed

lemma rel_bset_False[simp]: "rel_bset (\<lambda>x y. False) x y = (x = bempty \<and> y = bempty)"
  by transfer (auto simp: rel_set_def)

lemma rel_bset_of_option[simp]:
  "rel_bset R (bset_of_option x1) (bset_of_option x2) = rel_option R x1 x2"
  unfolding bset_of_option_def bsingleton_def[abs_def]
  by transfer (auto simp: rel_set_def split: option.splits)

lemma rel_bgraph[simp]:
  "rel_bset (rel_prod (=) R) (bgraph f1) (bgraph f2) = rel_fun (=) (rel_option R) f1 f2"
  apply transfer
  apply (auto simp: rel_fun_def rel_option_iff rel_set_def split: option.splits)
  using option.collapse apply fastforce+
  done

lemma set_bset_bsingleton[simp]:
  "set_bset (bsingleton x) = {x}"
  unfolding bsingleton_def by transfer auto

lemma binsert_absorb[simp]: "binsert a (binsert a x) = binsert a x"
  by transfer simp

lemma map_bset_eq_bempty_iff[simp]: "map_bset f X = bempty \<longleftrightarrow> X = bempty"
  by transfer auto

lemma map_bset_eq_bsingleton_iff[simp]:
  "map_bset f X = bsingleton x \<longleftrightarrow> (set_bset X \<noteq> {} \<and> (\<forall>y \<in> set_bset X. f y = x))"
  unfolding bsingleton_def by transfer auto

lift_definition bCollect :: "('a \<Rightarrow> bool) \<Rightarrow> 'a set['a set]" is Collect
  apply (rule ordLeq_ordLess_trans[OF card_of_mono1[OF subset_UNIV]])
  apply (rule ordLess_ordLeq_trans[OF card_of_set_type])
  apply (rule ordLeq_csum2[OF card_of_Card_order])
  done

lift_definition bmember :: "'a \<Rightarrow> 'a set['k] \<Rightarrow> bool" is "(\<in>)" .

lemma bmember_bCollect[simp]: "bmember a (bCollect P) = P a"
  by transfer simp

lemma bset_eq_iff: "A = B \<longleftrightarrow> (\<forall>a. bmember a A = bmember a B)"
  by transfer auto

(* FIXME: Lifting does not work with dead variables,
   that is why we are hiding the below setup in a locale*)
locale bset_lifting
begin

declare bset.rel_eq[relator_eq]
declare bset.rel_mono[relator_mono]
declare bset.rel_compp[symmetric, relator_distr]
declare bset.rel_transfer[transfer_rule]

lemma bset_quot_map[quot_map]: "Quotient R Abs Rep T \<Longrightarrow>
  Quotient (rel_bset R) (map_bset Abs) (map_bset Rep) (rel_bset T)"
  unfolding Quotient_alt_def5 bset.rel_Grp[of UNIV, simplified, symmetric]
    bset.rel_conversep[symmetric] bset.rel_compp[symmetric]
    by (auto elim: bset.rel_mono_strong)

lemma set_relator_eq_onp [relator_eq_onp]:
  "rel_bset (eq_onp P) = eq_onp (\<lambda>A. Ball (set_bset A) P)"
  unfolding fun_eq_iff eq_onp_def by transfer (auto simp: rel_set_def)

end

end


(*  Title:      HOL/Nitpick_Examples/Induct_Nits.thy
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2009-2011

Examples featuring Nitpick applied to (co)inductive definitions.
*)

section {* Examples Featuring Nitpick Applied to (Co)inductive Definitions *}

theory Induct_Nits
imports Main
begin

nitpick_params [verbose, card = 1-8, unary_ints,
                sat_solver = MiniSat_JNI, max_threads = 1, timeout = 240]

inductive p1 :: "nat \<Rightarrow> bool" where
"p1 0" |
"p1 n \<Longrightarrow> p1 (n + 2)"

coinductive q1 :: "nat \<Rightarrow> bool" where
"q1 0" |
"q1 n \<Longrightarrow> q1 (n + 2)"

lemma "p1 = q1"
nitpick [expect = none]
nitpick [wf, expect = none]
nitpick [non_wf, expect = none]
nitpick [non_wf, dont_star_linear_preds, expect = none]
oops

lemma "p1 \<noteq> q1"
nitpick [expect = potential]
nitpick [wf, expect = potential]
nitpick [non_wf, expect = potential]
nitpick [non_wf, dont_star_linear_preds, expect = potential]
oops

lemma "p1 (n - 2) \<Longrightarrow> p1 n"
nitpick [expect = genuine]
nitpick [non_wf, expect = genuine]
nitpick [non_wf, dont_star_linear_preds, expect = genuine]
oops

lemma "q1 (n - 2) \<Longrightarrow> q1 n"
nitpick [expect = genuine]
nitpick [non_wf, expect = genuine]
nitpick [non_wf, dont_star_linear_preds, expect = genuine]
oops

inductive p2 :: "nat \<Rightarrow> bool" where
"p2 n \<Longrightarrow> p2 n"

coinductive q2 :: "nat \<Rightarrow> bool" where
"q2 n \<Longrightarrow> q2 n"

lemma "p2 = bot"
nitpick [expect = none]
nitpick [dont_star_linear_preds, expect = none]
sorry

lemma "q2 = bot"
nitpick [expect = genuine]
nitpick [dont_star_linear_preds, expect = genuine]
nitpick [wf, expect = quasi_genuine]
oops

lemma "p2 = top"
nitpick [expect = genuine]
nitpick [dont_star_linear_preds, expect = genuine]
oops

lemma "q2 = top"
nitpick [expect = none]
nitpick [dont_star_linear_preds, expect = none]
nitpick [wf, expect = quasi_genuine]
sorry

lemma "p2 = q2"
nitpick [expect = genuine]
nitpick [dont_star_linear_preds, expect = genuine]
oops

lemma "p2 n"
nitpick [expect = genuine]
nitpick [dont_star_linear_preds, expect = genuine]
nitpick [dont_specialize, expect = genuine]
oops

lemma "q2 n"
nitpick [expect = none]
nitpick [dont_star_linear_preds, expect = none]
sorry

lemma "\<not> p2 n"
nitpick [expect = none]
nitpick [dont_star_linear_preds, expect = none]
sorry

lemma "\<not> q2 n"
nitpick [expect = genuine]
nitpick [dont_star_linear_preds, expect = genuine]
nitpick [dont_specialize, expect = genuine]
oops

inductive p3 and p4 where
"p3 0" |
"p3 n \<Longrightarrow> p4 (Suc n)" |
"p4 n \<Longrightarrow> p3 (Suc n)"

coinductive q3 and q4 where
"q3 0" |
"q3 n \<Longrightarrow> q4 (Suc n)" |
"q4 n \<Longrightarrow> q3 (Suc n)"

lemma "p3 = q3"
nitpick [expect = none]
nitpick [non_wf, expect = none]
sorry

lemma "p4 = q4"
nitpick [expect = none]
nitpick [non_wf, expect = none]
sorry

lemma "p3 = top - p4"
nitpick [expect = none]
nitpick [non_wf, expect = none]
sorry

lemma "q3 = top - q4"
nitpick [expect = none]
nitpick [non_wf, expect = none]
sorry

lemma "inf p3 q4 \<noteq> bot"
nitpick [expect = potential]
nitpick [non_wf, expect = potential]
sorry

lemma "inf q3 p4 \<noteq> bot"
nitpick [expect = potential]
nitpick [non_wf, expect = potential]
sorry

lemma "sup p3 q4 \<noteq> top"
nitpick [expect = potential]
nitpick [non_wf, expect = potential]
sorry

lemma "sup q3 p4 \<noteq> top"
nitpick [expect = potential]
nitpick [non_wf, expect = potential]
sorry

end


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

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

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun filter :: "('a => bool) => 'a list => 'a list" where
"filter q (nil2) = nil2"
| "filter q (cons2 y xs) =
     (if q y then cons2 y (filter q xs) else filter q xs)"

(*fun did not finish the proof*)
function nubBy :: "('a => ('a => bool)) => 'a list => 'a list" where
"nubBy x (nil2) = nil2"
| "nubBy x (cons2 z xs) =
     cons2 z (nubBy x (filter (% (y2 :: 'a) => (~ ((x z) y2))) xs))"
by pat_completeness auto

(*fun did not finish the proof*)
function elem :: "'a => 'a list => bool" where
"elem x (nil2) = False"
| "elem x (cons2 z xs) = ((z = x) | (elem x xs))"
by pat_completeness auto

fun count :: "'a => 'a list => Nat" where
"count x (nil2) = Z"
| "count x (cons2 z ys) =
     (if (x = z) then plus (S Z) (count x ys) else count x ys)"

theorem property0 :
  "((elem x xs) ==>
      ((count x (nubBy (% (y :: 'a) => % (z :: 'a) => (y = z)) xs)) =
         (S Z)))"
  oops

end


theory ToyList
imports Main

begin

(*Syntax annotation: NOT standard*)
no_notation Nil ("[]") and Cons (infixr "#" 65) and append (infixr "@" 65)
hide_type list
hide_const rev

datatype 'a list = Nil ("[]")
  | Cons 'a "'a list"(infixr "#" 65)

(* This is the append function: *)
primrec app :: "'a list => 'a list => 'a list" (infixr "@" 65) where
"[] @ ys =ys"|
"(x # xs) @ ys = x # (xs @ ys)"

(* This is the reverse function: *)
primrec rev :: "'a list => 'a list" where "rev [] =[]"|
"rev(x#xs) =(rev xs)@(x#[])"

(*Theory Begins*)

lemma app_Nil2 [simp]: "xs @ [] = xs"
  apply(induct_tac xs)
   apply(auto)
   done

lemma app_assoc [simp]: "(xs @ ys) @ zs = xs @ (ys @ zs)"
  apply(induct_tac xs)
   apply(auto)
  done

lemma rev_app [simp]: "rev(xs @ ys) = (rev ys) @ (rev xs)"
  apply(induct_tac xs)
   apply(auto)
  done

theorem rev_rev [simp]: "rev(rev xs) = xs"
  apply(induct_tac xs)
   apply(auto)
  done

end