section "Binomial Heaps"

theory BinomialHeap
imports Main "HOL-Library.Multiset"
begin

locale BinomialHeapStruc_loc
begin

subsection \<open>Datatype Definition\<close>

text \<open>Binomial heaps are lists of binomial trees.\<close>
datatype ('e, 'a) BinomialTree =
  Node (val: 'e) (prio: "'a::linorder") (rank: nat) (children: "('e , 'a) BinomialTree list")
type_synonym ('e, 'a) BinomialQueue_inv = "('e, 'a::linorder) BinomialTree list"

text \<open>Combine two binomial trees (of rank $r$) to one (of rank $r+1$).\<close>
fun  link :: "('e, 'a::linorder) BinomialTree \<Rightarrow> ('e, 'a) BinomialTree \<Rightarrow>
  ('e, 'a) BinomialTree" where
  "link (Node e1 a1 r1 ts1) (Node e2 a2 r2 ts2) =
   (if  a1\<le>a2
     then (Node e1 a1 (Suc r1) ((Node e2 a2 r2 ts2)#ts1))
     else (Node e2 a2 (Suc r2) ((Node e1 a1 r1 ts1)#ts2)))"

subsubsection "Abstraction to Multiset"
text \<open>Return a multiset with all (element, priority) pairs from a queue.\<close>
fun tree_to_multiset
  :: "('e, 'a::linorder) BinomialTree \<Rightarrow> ('e \<times> 'a) multiset"
and queue_to_multiset
  :: "('e, 'a::linorder) BinomialQueue_inv \<Rightarrow> ('e \<times> 'a) multiset" where
  "tree_to_multiset (Node e a r ts) = {#(e,a)#} + queue_to_multiset ts" |
  "queue_to_multiset [] = {#}" |
  "queue_to_multiset (t#q) = tree_to_multiset t + queue_to_multiset q"

lemma qtmset_append_union[simp]: "queue_to_multiset (q @ q') =
  queue_to_multiset q + queue_to_multiset q'"
  apply(induct q)
  apply(simp)
  apply(simp add: union_ac)
done

lemma qtmset_rev[simp]: "queue_to_multiset (rev q) = queue_to_multiset q"
  apply(induct q)
  apply(simp)
  apply(simp add: union_ac)
done

subsubsection "Invariant"

text \<open>We first formulate the invariant for single binomial trees,
  and then extend the invariant to binomial heaps (lists of binomial trees).
  The invariant for trees claims that a tree labeled rank $0$ has no children,
  and a tree labeled rank $r+1$ is the result of a link operation of
  two rank $r$ trees.
\<close>
function tree_invar :: "('e, 'a::linorder) BinomialTree \<Rightarrow> bool" where
  "tree_invar (Node e a 0 ts) = (ts = [])" |
  "tree_invar (Node e a (Suc r) ts) =
  (\<exists> e1 a1 ts1 e2 a2 ts2.
    tree_invar (Node e1 a1 r ts1) \<and>
    tree_invar (Node e2 a2 r ts2) \<and>
    (Node e a (Suc r) ts) = link (Node e1 a1 r ts1) (Node e2 a2 r ts2))"
by pat_completeness auto
termination
  apply(relation "measure (\<lambda>t. rank t)")
  apply auto
done

text \<open>A queue satisfies the invariant, iff all trees inside the queue satisfy
  the invariant, and the queue contains only trees of distinct rank and
  is ordered by rank\<close>

text \<open>First part: All trees of the queue satisfy the tree invariant:\<close>
definition queue_invar :: "('e, 'a::linorder) BinomialQueue_inv \<Rightarrow> bool" where
  "queue_invar q \<equiv> (\<forall>t \<in> set q. tree_invar t)"

text \<open>Second part: Trees have distinct rank, and are ordered by
  ascending rank:\<close>
fun rank_invar :: "('e, 'a::linorder) BinomialQueue_inv \<Rightarrow> bool" where
  "rank_invar [] = True" |
  "rank_invar [t] = True" |
  "rank_invar (t # t' # bq) = (rank t < rank t' \<and> rank_invar (t' # bq))"

lemma queue_invar_simps[simp]:
  "queue_invar []"
  "queue_invar (t#q) \<longleftrightarrow> tree_invar t \<and> queue_invar q"
  "queue_invar (q@q') \<longleftrightarrow> queue_invar q \<and> queue_invar q'"
  unfolding queue_invar_def by auto

text \<open>Invariant for binomial queues:\<close>
definition "invar q == queue_invar q \<and> rank_invar q"

lemma mset_link[simp]: "(tree_to_multiset (link t1 t2))
  = (tree_to_multiset t1) + (tree_to_multiset t2)"
  by(cases t1, cases t2, auto simp add: union_ac)

lemma link_tree_invar:
  "\<lbrakk>tree_invar t1; tree_invar t2; rank t1 = rank t2\<rbrakk> \<Longrightarrow> tree_invar (link t1 t2)"
  by (cases t1, cases t2, simp, blast)

lemma invar_children:
  assumes "tree_invar ((Node e a r ts)::(('e, 'a::linorder) BinomialTree))"
  shows "queue_invar ts" using assms
  unfolding queue_invar_def
proof(induct r arbitrary: e a ts)
  case 0
  then show ?case by simp
next
  case (Suc r)
  from Suc(2) obtain e1 a1 ts1 e2 a2 ts2 where
    O: "tree_invar (Node e1 a1 r ts1)"  "tree_invar (Node e2 a2 r ts2)"
    "(Node e a (Suc r) ts) = link (Node e1 a1 r ts1) (Node e2 a2 r ts2)"
    by (simp only: tree_invar.simps) blast
  from Suc(1)[OF O(1)] O(2)
  have case1: "queue_invar ((Node e2 a2 r ts2) # ts1)"
    unfolding queue_invar_def by simp
  from Suc(1)[OF O(2)] O(1)
  have case2: "queue_invar ((Node e1 a1 r ts1) # ts2)"
    unfolding queue_invar_def by simp
  from O(3) have "ts = (if a1\<le>a2
    then (Node e2 a2 r ts2) # ts1
    else (Node e1 a1 r ts1) # ts2)" by auto
  with case1 case2 show ?case unfolding queue_invar_def by simp
qed

lemma invar_children': "tree_invar t \<Longrightarrow> queue_invar (children t)"
  by (cases t) (auto simp add: invar_children)

lemma rank_link: "rank t = rank t' \<Longrightarrow> rank (link t t') = rank t + 1"
apply (cases t)
apply (cases t')
apply(auto)
done

lemma rank_invar_not_empty_hd: "\<lbrakk>rank_invar (t # bq); bq \<noteq> []\<rbrakk> \<Longrightarrow>
  rank t < rank (hd bq)"
apply(induct bq arbitrary: t)
apply(auto)
done

lemma rank_invar_to_set: "rank_invar (t # bq) \<Longrightarrow>
  \<forall> t' \<in> set bq. rank t < rank t'"
apply(induct bq arbitrary: t)
apply(simp)
apply (metis nat_less_le rank_invar.simps(3) set_ConsD xt1(7))
done

lemma set_to_rank_invar: "\<lbrakk>\<forall> t' \<in> set bq. rank t < rank t'; rank_invar bq\<rbrakk>
  \<Longrightarrow>  rank_invar (t # bq)"
apply(induct bq arbitrary: t)
apply(simp)
by (metis list.sel(1) hd_in_set list.distinct(1) rank_invar.simps(3))

lemma rank_invar_hd_cons:
  "\<lbrakk>rank_invar bq; rank t < rank (hd bq)\<rbrakk> \<Longrightarrow> rank_invar (t # bq)"
apply(cases bq)
apply(auto)
done

lemma rank_invar_cons: "rank_invar (t # bq) \<Longrightarrow> rank_invar bq"
apply(cases bq)
apply(auto)
done

lemma invar_cons_up:
  "\<lbrakk>invar (t # bq); rank t' < rank t; tree_invar t'\<rbrakk> \<Longrightarrow> invar (t' # t # bq)"
  unfolding invar_def
  by (cases bq) simp_all

lemma invar_cons_down: "invar (t # bq) \<Longrightarrow> invar bq"
  unfolding invar_def
  by (cases bq) simp_all

lemma invar_app_single:
  "\<lbrakk>invar bq; \<forall>t \<in> set bq. rank t < rank t'; tree_invar t'\<rbrakk>
   \<Longrightarrow> invar (bq @ [t'])"
proof (induct bq)
  case Nil
  then show ?case by (simp add: invar_def)
next
  case (Cons a bq)
  from \<open>invar (a # bq)\<close> have "invar bq" by (rule invar_cons_down)
  with Cons have "invar (bq @ [t'])" by simp
  with Cons show ?case by (cases bq) (simp_all add: invar_def)
qed

subsubsection "Heap Ordering"
fun heap_ordered :: "('e, 'a::linorder) BinomialTree \<Rightarrow> bool" where
  "heap_ordered (Node e a r ts) = (\<forall>x \<in> set_mset(queue_to_multiset ts). a \<le> snd x)"

text \<open>The invariant for trees implies heap order.\<close>
lemma tree_invar_heap_ordered:
  assumes "tree_invar t"
  shows "heap_ordered t"
proof (cases t)
  case (Node e a nat list)
  with assms show ?thesis
  proof (induct nat arbitrary: t e a list)
    case 0
    then show ?case by simp
  next
    case (Suc nat t)
    then obtain t1 e1 a1 ts1 t2 e2 a2 ts2 where
      O: "tree_invar t1"  "tree_invar t2" "t = link t1 t2"
      and t1[simp]: "t1 = (Node e1 a1 nat ts1)"
      and t2[simp]: "t2 = (Node e2 a2 nat ts2)"
      by (simp only: tree_invar.simps) blast
    from O(3) have "t = (if  a1\<le>a2
      then (Node e1 a1 (Suc nat) (t2 # ts1))
      else (Node e2 a2 (Suc nat) (t1 # ts2)))" by simp
    with Suc(1)[OF O(1) t1] Suc(1)[OF O(2) t2]
    show ?case by (cases "a1 \<le> a2") auto
  qed
qed

subsubsection "Height and Length"
text \<open>
  Although complexity of HOL-functions cannot be expressed within
  HOL, we can express the height and length of a binomial heap.
  By showing that both, height and length, are logarithmic in the number
  of contained elements, we give strong evidence that our functions have
  logarithmic complexity in the number of elements.
\<close>

text \<open>Height of a tree and queue\<close>
fun height_tree :: "('e, ('a::linorder)) BinomialTree \<Rightarrow> nat" and
    height_queue :: "('e, ('a::linorder)) BinomialQueue_inv \<Rightarrow> nat"
  where
  "height_tree (Node e a r ts) = height_queue ts" |
  "height_queue [] = 0" |
  "height_queue (t # ts) = max (Suc (height_tree t)) (height_queue ts)"

lemma link_length: "size (tree_to_multiset (link t1 t2)) =
  size (tree_to_multiset t1) + size (tree_to_multiset t2)"
  apply(cases t1)
  apply(cases t2)
  apply simp
  done

lemma tree_rank_estimate:
  "tree_invar (Node e a r ts) \<Longrightarrow>
    size (tree_to_multiset (Node e a r ts)) = (2::nat)^r"
proof (induct r arbitrary: e a ts)
  case 0
  then show ?case by simp
next
  case (Suc r)
  from Suc(2) obtain e1 a1 ts1 e2 a2 ts2 where link:
    "(Node e a (Suc r) ts) = link (Node e1 a1 r ts1) (Node e2 a2 r ts2)"
    and inv1: "tree_invar (Node e1 a1 r ts1) "
    and inv2: "tree_invar (Node e2 a2 r ts2)" by simp blast
  from link_length[of "(Node e1 a1 r ts1)" "(Node e2 a2 r ts2)"]
    Suc(1)[OF inv1] Suc(1)[OF inv2] link
  show ?case by simp
qed

lemma tree_rank_height:
  "tree_invar (Node e a r ts) \<Longrightarrow> height_tree (Node e a r ts) = r"
proof (induct r arbitrary: e a ts)
  case 0
  then show ?case by simp
next
  case (Suc r)
  from Suc(2) obtain e1 a1 ts1 e2 a2 ts2 where link:
    "(Node e a (Suc r) ts) = link (Node e1 a1 r ts1) (Node e2 a2 r ts2)"
    and inv1: "tree_invar (Node e1 a1 r ts1) "
    and inv2: "tree_invar (Node e2 a2 r ts2)" by simp blast
  with link Suc(1)[OF inv1] Suc(1)[OF inv2] Suc(2) show ?case
    by (cases "a1 \<le> a2") simp_all
qed

text \<open>A binomial tree of height $h$ contains exactly $2^{h}$ elements\<close>
theorem tree_height_estimate:
  "tree_invar t \<Longrightarrow> size (tree_to_multiset t) = (2::nat)^(height_tree t)"
  apply (cases t, simp only:)
  apply (frule tree_rank_estimate)
  apply (frule tree_rank_height)
  apply (simp only: )
  done

(*lemma size_mset_tree_Node: "tree_invar (Node e a r ts) \<Longrightarrow>
  size (tree_to_multiset (Node e a r ts)) = (2::nat)^r"
  apply(induct r arbitrary: e a ts, simp)
proof -
  case goal1
  from goal1(2) obtain e1 a1 ts1 e2 a2 ts2 where link:
    "(Node e a (Suc r) ts) = link (Node e1 a1 r ts1) (Node e2 a2 r ts2)"
    and inv1: "tree_invar (Node e1 a1 r ts1) "
    and inv2: "tree_invar (Node e2 a2 r ts2)" by simp blast
  from link_length[of "(Node e1 a1 r ts1)" "(Node e2 a2 r ts2)"]
    goal1(1)[OF inv1] goal1(1)[OF inv2] link
  show ?case by simp
qed*)

lemma size_mset_tree: "tree_invar t \<Longrightarrow>
  size (tree_to_multiset t) = (2::nat)^(rank t)"
  by (cases t) (simp only: tree_rank_estimate BinomialTree.sel(3))

lemma invar_butlast: "invar (bq @ [t]) \<Longrightarrow> invar bq"
  unfolding invar_def
  apply (induct bq) apply simp apply (case_tac bq)
  by (simp_all)

lemma invar_last_max: "invar (bq @ [m]) \<Longrightarrow> \<forall> t \<in> set bq. rank t < rank m"
  unfolding invar_def
  apply (induct bq) apply simp apply (case_tac bq) apply simp by simp

lemma invar_length: "invar bq \<Longrightarrow> length bq \<le> Suc (rank (last bq))"
proof (induct bq rule: rev_induct)
  case Nil thus ?case by simp
next
  case (snoc x xs)
  show ?case proof (cases xs)
    case Nil thus ?thesis by simp
  next
    case [simp]: (Cons xxs xx)
    from snoc.hyps[OF invar_butlast[OF snoc.prems]] have
      IH: "length xs \<le> Suc (rank (last xs))" .
    also from invar_last_max[OF snoc.prems] last_in_set[of xs] have
      "Suc (rank (last xs)) \<le> rank (last (xs @ [x]))"
      by auto
    finally show ?thesis by simp
  qed
qed

lemma size_queue_sum_list:
  "size (queue_to_multiset bq) = sum_list (map (size \<circ> tree_to_multiset) bq)"
  by (induct bq) simp_all

text \<open>
  A binomial heap of length $l$ contains at least $2^l - 1$ elements.
\<close>
theorem queue_length_estimate_lower:
  "invar bq \<Longrightarrow> (size (queue_to_multiset bq)) \<ge> 2^(length bq) - 1"
proof (induct bq rule: rev_induct)
  case Nil thus ?case by simp
next
  case (snoc x xs)
  from snoc.hyps[OF invar_butlast[OF snoc.prems]]
  have IH: "2 ^ length xs \<le> Suc (size (queue_to_multiset xs))" by simp
  have size_q:
    "size (queue_to_multiset (xs @ [x])) =
    size (queue_to_multiset xs) + size (tree_to_multiset x)"
    by (simp add: size_queue_sum_list)
  also
  from snoc.prems have inv_x: "tree_invar x" by (simp add: invar_def)
  hence "size (tree_to_multiset x) = 2 ^ rank x" by (simp add: size_mset_tree)
  finally have
    eq: "size (queue_to_multiset (xs @ [x])) =
         size (queue_to_multiset xs) + (2::nat)^(rank x)" .
  from invar_length[OF snoc.prems] have "length xs \<le> rank x" by simp
  hence snd: "(2::nat) ^ length xs \<le> (2::nat) ^ rank x" by simp
  have
    "(2::nat) ^ length (xs @ [x]) = (2::nat) ^ (length xs) + (2::nat) ^ (length xs)"
    by simp
  with IH have
    "2 ^ length (xs @ [x]) \<le> Suc (size (queue_to_multiset xs)) + 2 ^ length xs"
    by simp
  with snd have "2 ^ length (xs @ [x]) \<le>
    Suc (size (queue_to_multiset xs)) + 2 ^ rank x"
    by arith
  with eq show ?case by simp
qed

subsection \<open>Operations\<close>

subsubsection "Empty"
lemma empty_correct[simp]:
  "invar Nil"
  "queue_to_multiset Nil = {#}"
  by (simp_all add: invar_def)

text \<open>The empty multiset is represented by exactly the empty queue\<close>
lemma empty_iff: "t=Nil \<longleftrightarrow> queue_to_multiset t = {#}"
  apply (cases t)
  apply auto
  apply (case_tac a)
  apply auto
  done

subsubsection "Insert"
text \<open>Inserts a binomial tree into a binomial queue, such that the queue
  does not contain two trees of same rank.\<close>
fun  ins :: "('e, 'a::linorder) BinomialTree \<Rightarrow> ('e, 'a) BinomialQueue_inv \<Rightarrow>
  ('e, 'a) BinomialQueue_inv" where
  "ins t [] = [t]" |
  "ins t' (t # bq) = (if (rank t') < (rank t)
    then t' # t # bq
    else (if (rank t) < (rank t')
            then t # (ins t' bq)
            else ins (link t' t) bq))"

text \<open>Inserts an element with priority into the queue.\<close>
definition insert :: "'e \<Rightarrow> 'a::linorder \<Rightarrow> ('e, 'a) BinomialQueue_inv \<Rightarrow>
  ('e, 'a) BinomialQueue_inv" where
  "insert e a bq = ins (Node e a 0 []) bq"

lemma insert_mset: "queue_invar q \<Longrightarrow>
  queue_to_multiset (insert e a q) = queue_to_multiset q + {# (e,a) #}"
by(simp add: ins_mset union_ac insert_def)

lemma ins_queue_invar: "\<lbrakk>tree_invar t; queue_invar q\<rbrakk> \<Longrightarrow> queue_invar (ins t q)"
proof (induct q arbitrary: t)
  case (Cons a q)
  note iv = Cons.hyps
  show ?case
  proof (cases "rank t = rank a")
    case [simp]: True
    from Cons.prems have
      inv_a: "tree_invar a" and inv_q: "queue_invar q"
      by (simp_all)
    note inv_link = link_tree_invar[OF \<open>tree_invar t\<close> inv_a True]
    from iv[OF inv_link inv_q] show ?thesis by simp
  next
    case False
    with Cons show ?thesis by auto
  qed
qed simp

lemma insert_queue_invar:
  assumes "queue_invar q"
  shows "queue_invar (insert e a q)"
proof -
  have inv: "tree_invar (Node e a 0 [])" by simp
  from ins_queue_invar[OF inv assms] show ?thesis by (simp add: insert_def)
qed

lemma  rank_ins: "(rank_invar (t # bq) \<Longrightarrow>
  (rank (hd (ins t' (t # bq))) \<ge> rank t) \<or>
  (rank (hd (ins t' (t # bq))) \<ge> rank t'))"
  apply(auto)
  apply(induct bq arbitrary: t t')
  apply(simp add: rank_link)
proof goal_cases
  case prems: (1 a bq t t')
  thus ?case
    apply(cases "rank (link t' t) = rank a")
    apply(auto simp add: rank_link)
  proof goal_cases
    case 1
    note * = this and \<open>\<And>t' t. \<lbrakk>rank_invar (t # bq); rank t' = rank t\<rbrakk>
      \<Longrightarrow> rank t \<le> rank (hd (ins (link t' t) bq))\<close>[of a "(link t' t)"]
    show ?case
    proof (cases "rank (hd (ins (link (link t' t) a) bq)) = rank a")
      case True
      with * show ?thesis by simp
    next
      case False
      with * have "rank a \<le> rank (hd (ins (link (link t' t) a) bq))"
        by (simp add: rank_link)
      with * show ?thesis by simp
    qed
  qed
qed

lemma rank_ins2: "rank_invar bq \<Longrightarrow>
  rank t \<le> rank (hd (ins t bq)) \<or>
  (rank (hd (ins t bq)) = rank (hd bq) \<and> bq \<noteq> [])"
  apply(induct bq arbitrary: t)
  apply(auto)
proof goal_cases
  case prems: (1 a bq t)
  hence r: "rank (link t a) = rank a + 1" by (simp add: rank_link)
  from prems r and prems(1)[of "(link t a)"] show ?case by (cases bq) auto
qed

lemma rank_invar_ins: "rank_invar bq \<Longrightarrow> rank_invar (ins t bq)"
  apply(induct bq arbitrary: t)
  apply(simp)
  apply(auto)
proof goal_cases
  case prems: (1 a bq t)
  hence inv: "rank_invar (ins t bq)" by (cases bq) simp_all
  from prems have hd: "bq \<noteq> [] \<Longrightarrow> rank a < rank (hd bq)"
    by (cases bq) auto
  from prems have "rank t \<le> rank (hd (ins t bq)) \<or>
    (rank (hd (ins t bq)) = rank (hd bq) \<and> bq \<noteq> [])"
    by (simp add: rank_ins2 rank_invar_cons)
  with prems have "rank a < rank (hd (ins t bq)) \<or>
    (rank (hd (ins t bq)) = rank (hd bq) \<and> bq \<noteq> [])" by auto
  with prems and inv and hd show ?case by (auto simp add: rank_invar_hd_cons)
next
  case prems: (2 a bq t)
  hence inv: "rank_invar bq" by (cases bq) simp_all
  with prems and prems(1)[of "(link t a)"] show ?case by simp
qed

lemma rank_invar_insert: "rank_invar bq \<Longrightarrow> rank_invar (insert e a bq)"
  by (simp add: rank_invar_ins insert_def)

lemma insert_correct:
  assumes I: "invar q"
  shows
  "invar (insert e a q)"
  "queue_to_multiset (insert e a q) = queue_to_multiset q + {# (e,a) #}"
  using insert_queue_invar[of q] rank_invar_insert[of q] insert_mset[of q] I
  unfolding invar_def by auto

subsubsection "Meld"
text \<open>Melds two queues.\<close>
fun meld :: "('e, 'a::linorder) BinomialQueue_inv \<Rightarrow> ('e, 'a) BinomialQueue_inv
  \<Rightarrow> ('e, 'a) BinomialQueue_inv"
  where
  "meld [] bq = bq" |
  "meld bq [] = bq" |
  "meld (t1#bq1) (t2#bq2) =
   (if (rank t1) < (rank t2)
       then t1 # (meld bq1 (t2 # bq2))
       else (
         if (rank t2 < rank t1)
            then t2 # (meld (t1 # bq1) bq2)
            else ins (link t1 t2) (meld bq1 bq2)
       )
    )"

lemma meld_queue_invar:
  "\<lbrakk>queue_invar q; queue_invar q'\<rbrakk> \<Longrightarrow> queue_invar (meld q q')"
proof (induct q q' rule: meld.induct)
  case 1
  then show ?case by simp
next
  case 2
  then show ?case by simp
next
  case (3 t1 bq1 t2 bq2)
  consider (lt) "rank t1 < rank t2" | (gt) "rank t1 > rank t2" | (eq) "rank t1 = rank t2"
    by atomize_elim auto
  then show ?case
  proof cases
    case lt
    from 3(4) have inv_bq1: "queue_invar bq1" by simp
    from 3(4) have inv_t1: "tree_invar t1" by simp
    from 3(1)[OF lt inv_bq1 3(5)] inv_t1 lt
    show ?thesis by simp
  next
    case gt
    from 3(5) have inv_bq2: "queue_invar bq2" by simp
    from 3(5) have inv_t2: "tree_invar t2" by simp
    from gt have "\<not> rank t1 < rank t2" by simp
    from 3(2)[OF this gt 3(4) inv_bq2] inv_t2 gt
    show ?thesis by simp
  next
    case eq
    from 3(4) have inv_bq1: "queue_invar bq1" by simp
    from 3(4) have inv_t1: "tree_invar t1" by simp
    from 3(5) have inv_bq2: "queue_invar bq2" by simp
    from 3(5) have inv_t2: "tree_invar t2" by simp
    note inv_link = link_tree_invar[OF inv_t1 inv_t2 eq]
    from eq have *: "\<not> rank t1 < rank t2" "\<not> rank t2 < rank t1" by simp_all
    note inv_meld = 3(3)[OF * inv_bq1 inv_bq2]
    from ins_queue_invar[OF inv_link inv_meld] *
    show ?thesis by simp
  qed
qed

lemma rank_ins_min: "rank_invar bq \<Longrightarrow>
  rank (hd (ins t bq)) \<ge> min (rank t) (rank (hd bq))"
  apply(induct bq arbitrary: t)
  apply(auto)
proof goal_cases
  case prems: (1 a bq t)
  hence inv: "rank_invar bq" by (cases bq) simp_all
  from prems have r: "rank (link t a) = rank a + 1" by (simp add: rank_link)
  with prems and inv and prems(1)[of "(link t a)"] show ?case by (cases bq) auto
qed

lemma rank_invar_meld_strong:
  "\<lbrakk>rank_invar bq1; rank_invar bq2\<rbrakk> \<Longrightarrow> rank_invar (meld bq1 bq2) \<and>
  rank (hd (meld bq1 bq2)) \<ge> min (rank (hd bq1)) (rank (hd bq2))"
proof (induct bq1 bq2 rule: meld.induct)
  case 1
  then show ?case by simp
next
  case 2
  then show ?case by simp
next
  case (3 t1 bq1 t2 bq2)
  from 3 have inv1: "rank_invar bq1" by (cases bq1) simp_all
  from 3 have inv2: "rank_invar bq2" by (cases bq2) simp_all

  from inv1 and inv2 and 3 show ?case
  proof (auto, goal_cases)
    let ?t = "t2"
    let ?bq = "bq2"
    let ?meld = "rank t2 < rank (hd (meld (t1 # bq1) bq2))"
    case prems: 1
    hence "?bq \<noteq> [] \<Longrightarrow> rank ?t < rank (hd ?bq)"
      by (simp add: rank_invar_not_empty_hd)
    with prems have ne: "?bq \<noteq> [] \<Longrightarrow> ?meld" by simp
    from prems have "?bq = [] \<Longrightarrow> ?meld" by simp
    with ne have "?meld" by (cases "?bq = []")
    with prems show ?case by (simp add: rank_invar_hd_cons)
  next \<comment> \<open>analog\<close>
    let ?t = "t1"
    let ?bq = "bq1"
    let ?meld = "rank t1 < rank (hd (meld bq1 (t2 # bq2)))"
    case prems: 2
    hence "?bq \<noteq> [] \<Longrightarrow> rank ?t < rank (hd ?bq)"
      by (simp add: rank_invar_not_empty_hd)
    with prems have ne: "?bq \<noteq> [] \<Longrightarrow> ?meld" by simp
    from prems have "?bq = [] \<Longrightarrow> ?meld" by simp
    with ne have "?meld" by (cases "?bq = []")
    with prems show ?case by (simp add: rank_invar_hd_cons)
  next
    case 3
    thus ?case by (simp add: rank_invar_ins)
  next
    case prems: 4 (* Ab hier wirds hässlich *)
    then have r: "rank (link t1 t2) = rank t2 + 1"
      by (simp add: rank_link)
    have m: "meld bq1 [] = bq1" by (cases bq1, auto)

    from inv1 and inv2 and prems
    have mm: "min (rank (hd bq1)) (rank (hd bq2)) \<le> rank (hd (meld bq1 bq2))"
      by simp
    from \<open>rank_invar (t1 # bq1)\<close> have "bq1 \<noteq> [] \<Longrightarrow> rank t1 < rank (hd bq1)"
      by (simp add: rank_invar_not_empty_hd)
    with prems have r1: "bq1 \<noteq> [] \<Longrightarrow> rank t2 < rank (hd bq1)" by simp
    from \<open>rank_invar (t2 # bq2)\<close>
    have r2: "bq2 \<noteq> [] \<Longrightarrow> rank t2 < rank (hd bq2)"
      by (simp add: rank_invar_not_empty_hd)

    from inv1 r r1 rank_ins_min[of bq1 "(link t1 t2)"]
    have abc1: "bq1 \<noteq> [] \<Longrightarrow> rank t2 \<le> rank (hd (ins (link t1 t2) bq1))"
      by simp
    from inv2 r r2 rank_ins_min[of bq2 "(link t1 t2)"]
    have abc2: "bq2 \<noteq> [] \<Longrightarrow> rank t2 \<le> rank (hd (ins (link t1 t2) bq2))"
      by simp
    from r1 r2 mm have
      "\<lbrakk>bq1 \<noteq> []; bq2 \<noteq> []\<rbrakk> \<Longrightarrow> rank t2 < rank (hd (meld bq1 bq2))" by simp
    with \<open>rank_invar (meld bq1 bq2)\<close>
      r rank_ins_min[of "meld bq1 bq2" "link t1 t2"]
    have "\<lbrakk>bq1 \<noteq> []; bq2 \<noteq> []\<rbrakk> \<Longrightarrow>
      rank t2 < rank (hd (ins (link t1 t2) (meld bq1 bq2)))" by simp
    thm rank_ins_min[of "meld bq1 bq2" "link t1 t2"]
    with inv1 and inv2 and r m r1 show ?case
      apply(cases "bq2 = []")
      apply(cases "bq1 = []")
      apply(simp)
      apply(auto simp add: abc1)
      apply(cases "bq1 = []")
      apply(simp)
      apply(auto simp add: abc2)
      done
  qed
qed

lemma rank_invar_meld:
  "\<lbrakk>rank_invar bq1; rank_invar bq2\<rbrakk> \<Longrightarrow> rank_invar (meld bq1 bq2)"
  by (simp only: rank_invar_meld_strong)

lemma meld_mset: "\<lbrakk>queue_invar q; queue_invar q'\<rbrakk> \<Longrightarrow>
  queue_to_multiset (meld q q') =
  queue_to_multiset q + queue_to_multiset q'"
by(induct q q' rule: meld.induct)
  (auto simp add: link_tree_invar meld_queue_invar ins_mset union_ac)

lemma meld_correct:
  assumes "invar q" "invar q'"
  shows
  "invar (meld q q')"
  "queue_to_multiset (meld q q') = queue_to_multiset q + queue_to_multiset q'"
  using assms
  unfolding invar_def
  by (simp_all add: meld_queue_invar rank_invar_meld meld_mset)

subsubsection "Find Minimal Element"
text \<open>Finds the tree containing the minimal element.\<close>
fun getMinTree :: "('e, 'a::linorder) BinomialQueue_inv \<Rightarrow>
  ('e, 'a) BinomialTree" where
  "getMinTree [t] = t" |
  "getMinTree (t#bq) = (if prio t \<le> prio (getMinTree bq)
     then t else (getMinTree bq))"

lemma mintree_exists: "(bq \<noteq> []) = (getMinTree bq \<in> set bq)"
proof (induct bq)
  case Nil
  then show ?case by simp
next
  case (Cons _ bq)
  then show ?case by (cases bq) simp_all
qed

lemma treehead_in_multiset:
  "t \<in> set bq \<Longrightarrow> (val t, prio t) \<in># queue_to_multiset bq"
  by (induct bq, simp, cases t, auto)

lemma heap_ordered_single:
"heap_ordered t = (\<forall>x \<in> set_mset (tree_to_multiset t). prio t \<le> snd x)"
  by (cases t) auto

lemma getMinTree_cons:
  "prio (getMinTree (y # x # xs)) \<le> prio (getMinTree (x # xs))"
  by (induct xs rule: getMinTree.induct) simp_all

lemma getMinTree_min_tree:
  "t \<in> set bq  \<Longrightarrow> prio (getMinTree bq) \<le> prio t"
  apply(induct bq arbitrary: t rule: getMinTree.induct)
  apply simp
  defer
  apply simp
proof goal_cases
  case prems: (1 t v va ta)
  thus ?case
    apply (cases "ta = t")
    apply auto[1]
    apply (metis getMinTree_cons prems(1) prems(3) set_ConsD xt1(6))
    done
qed

lemma getMinTree_min_prio:
  assumes "queue_invar bq"
    and "y \<in> set_mset (queue_to_multiset bq)"
  shows "prio (getMinTree bq) \<le> snd y"
proof -
  from assms have "bq \<noteq> []" by (cases bq) simp_all
  with assms have "\<exists> t \<in> set bq. (y \<in> set_mset ((tree_to_multiset t)))"
  proof (induct bq)
    case Nil
    then show ?case by simp
  next
    case (Cons a bq)
    thus ?case
      apply(cases "y \<in> set_mset (tree_to_multiset a)")
      apply simp
      apply(cases bq)
      apply simp_all
      done
  qed
  from this obtain t where O:
    "t \<in> set bq"
    "y \<in> set_mset (tree_to_multiset t)" by blast
  obtain e a r ts where [simp]: "t = (Node e a r ts)" by (cases t) blast
  from O assms(1) have inv: "tree_invar t" by (simp add: queue_invar_def)
  from tree_invar_heap_ordered[OF inv] heap_ordered.simps[of e a r ts] O
  have "prio t \<le> snd y" by auto
  with getMinTree_min_tree[OF O(1)] show ?thesis by simp
qed

text \<open>Finds the minimal Element in the queue.\<close>
definition findMin :: "('e, 'a::linorder) BinomialQueue_inv \<Rightarrow> ('e \<times> 'a)" where
  "findMin bq = (let min = getMinTree bq in (val min, prio min))"

lemma findMin_correct:
  assumes I: "invar q"
  assumes NE: "q \<noteq> Nil"
  shows
  "findMin q \<in># queue_to_multiset q"
  "\<forall>y\<in>set_mset (queue_to_multiset q). snd (findMin q) \<le> snd y"
proof -
  from NE have "getMinTree q \<in> set q" by (simp only: mintree_exists)
  thus "findMin q \<in># queue_to_multiset q"
    by (simp add: treehead_in_multiset Let_def findMin_def)
  show "\<forall>y\<in>set_mset (queue_to_multiset q). snd (findMin q) \<le> snd y"
    using I[unfolded invar_def]
    by (auto simp add: getMinTree_min_prio Let_def findMin_def)
qed

subsubsection "Delete Minimal Element"

text \<open>Removes the first tree, which has the priority $a$ within his root.\<close>
fun remove1Prio :: "'a \<Rightarrow> ('e, 'a::linorder) BinomialQueue_inv \<Rightarrow>
  ('e, 'a) BinomialQueue_inv" where
  "remove1Prio a [] = []" |
  "remove1Prio a (t#bq) =
  (if (prio t) = a then bq else t # (remove1Prio a bq))"

text \<open>Returns the queue without the minimal element.\<close>
definition deleteMin :: "('e, 'a::linorder) BinomialQueue_inv \<Rightarrow>
  ('e, 'a) BinomialQueue_inv" where
  "deleteMin bq \<equiv> (let min = getMinTree bq in
                    meld (rev (children min))
                         (remove1Prio (prio min) bq))"

lemma queue_invar_rev: "queue_invar q \<Longrightarrow> queue_invar (rev q)"
  by (simp add: queue_invar_def)

lemma queue_invar_remove1: "queue_invar q \<Longrightarrow> queue_invar (remove1 t q)"
  by (auto simp add: queue_invar_def)

lemma qtm_in_set_subset: "t \<in> set q \<Longrightarrow>
  tree_to_multiset t \<subseteq># queue_to_multiset q"
proof(induct q)
  case Nil
  then show ?case by simp
next
  case (Cons a q)
  show ?case
  proof (cases "t = a")
    case True
    then show ?thesis by simp
  next
    case False
    with Cons have t_in_q: "t \<in> set q" by simp
    have "queue_to_multiset q \<subseteq># queue_to_multiset (a # q)"
      by simp
    from subset_mset.order_trans[OF Cons(1)[OF t_in_q] this] show ?thesis .
  qed
qed

lemma remove1Prio_remove1[simp]:
  "remove1Prio (prio (getMinTree bq)) bq = remove1 (getMinTree bq) bq"
proof (induct bq)
  case Nil thus ?case by simp
next
  case (Cons t bq)
  note iv = Cons
  thus ?case
  proof (cases "t = getMinTree (t # bq)")
    case True
    with iv show ?thesis by simp
  next
    case False
    hence ne: "bq \<noteq> []" by auto
    with False have down: "getMinTree (t # bq) = getMinTree bq"
      by (induct bq rule: getMinTree.induct) auto
    from ne False have "prio t \<noteq> prio (getMinTree bq)"
      by (induct bq rule: getMinTree.induct) auto
    with down iv False ne show ?thesis by simp
  qed
qed

lemma deleteMin_queue_invar:
  assumes INV: "queue_invar q"
  assumes NE: "q \<noteq> Nil"
  shows "queue_invar (deleteMin q)"
proof (cases q)
  case Nil
  with assms show ?thesis by simp
next
  case Cons
  from NE and mintree_exists[of q] INV
  have inv_min: "tree_invar (getMinTree q)" by (simp add: queue_invar_def)
  note inv_children = invar_children'[OF inv_min]
  note inv_rev = queue_invar_rev[OF inv_children]
  note inv_rem = queue_invar_remove1[OF INV, of "getMinTree q"]
  from meld_queue_invar[OF inv_rev inv_rem] show ?thesis
    by (simp add: deleteMin_def Let_def)
qed

lemma children_rank_less:
  assumes "tree_invar t"
  shows "\<forall>t' \<in> set (children t). rank t' < rank t"
proof (cases t)
  case (Node e a nat list)
  with assms show ?thesis
  proof (induct nat arbitrary: t e a list)
    case 0
    then show ?case by simp
  next
    case (Suc nat)
    then obtain e1 a1 ts1 e2 a2 ts2 where
      O: "tree_invar (Node e1 a1 nat ts1)" "tree_invar (Node e2 a2 nat ts2)"
        "t = link (Node e1 a1 nat ts1) (Node e2 a2 nat ts2)"
      by (simp only: tree_invar.simps) blast
    hence ch_id: "children t =
      (if a1 \<le> a2 then (Node e2 a2 nat ts2)#ts1
       else (Node e1 a1 nat ts1)#ts2)" by simp
    from O Suc(1)[of "Node e1 a1 nat ts1" "e1" "a1" "ts1"]
    have  p1: "\<forall>t'\<in>set ((Node e2 a2 nat ts2) # ts1). rank t' < Suc nat" by auto
    from O Suc(1)[of "Node e2 a2 nat ts2" "e2" "a2" "ts2"]
    have p2: "\<forall>t'\<in>set ((Node e1 a1 nat ts1) # ts2). rank t' < Suc nat" by auto
    from Suc(3) p1 p2 ch_id show ?case by simp
  qed
qed

lemma strong_rev_children:
  assumes "tree_invar t"
  shows "invar (rev (children t))"
  unfolding invar_def
proof (cases t)
  case (Node e a nat list)
  with assms show "queue_invar (rev (children t)) \<and> rank_invar (rev (children t))"
  proof (induct "nat" arbitrary: t e a list)
    case 0
    then show ?case by simp
  next
    case (Suc nat)
    then obtain e1 a1 ts1 e2 a2 ts2 where
      O: "tree_invar (Node e1 a1 nat ts1)" "tree_invar (Node e2 a2 nat ts2)"
        "t = link (Node e1 a1 nat ts1) (Node e2 a2 nat ts2)"
      by (simp only: tree_invar.simps) blast
    hence ch_id: "children t =
      (if a1 \<le> a2 then (Node e2 a2 nat ts2)#ts1
       else (Node e1 a1 nat ts1)#ts2)" by simp
    from O Suc(1)[of "Node e1 a1 nat ts1" "e1" "a1" "ts1"]
    have rev_ts1: "invar (rev ts1)" by (simp add: invar_def)
    from O children_rank_less[of "Node e1 a1 nat ts1"]
    have  "\<forall>t\<in>set (rev ts1). rank t < rank (Node e2 a2 nat ts2)" by simp
    with O rev_ts1 invar_app_single[of "rev ts1" "Node e2 a2 nat ts2"]
    have p1: "invar (rev ((Node e2 a2 nat ts2) # ts1))" by simp
    from O Suc(1)[of "Node e2 a2 nat ts2" "e2" "a2" "ts2"]
    have rev_ts2: "invar (rev ts2)" by (simp add: invar_def)
    from O children_rank_less[of "Node e2 a2 nat ts2"]
    have "\<forall>t\<in>set (rev ts2). rank t < rank (Node e1 a1 nat ts1)" by simp
    with O rev_ts2 invar_app_single[of "rev ts2" "Node e1 a1 nat ts1"]
    have p2: "invar (rev ((Node e1 a1 nat ts1) # ts2))" by simp
    from p1 p2 ch_id show ?case by (simp add: invar_def)
  qed
qed

lemma first_less: "rank_invar (t # bq) \<Longrightarrow> \<forall>t' \<in> set bq. rank t < rank t'"
  apply(induct bq arbitrary: t)
  apply (simp)
  apply (metis order_le_less rank_invar.simps(3) set_ConsD xt1(7))
  done

lemma strong_remove1: "invar bq \<Longrightarrow> invar (remove1 t bq)"
proof (induct bq arbitrary: t)
  case Nil
  then show ?case by simp
next
  case (Cons a bq)
  show ?case
  proof (cases "t=a")
    case True
    from Cons(2) have "invar bq" by (rule invar_cons_down)
    with True show ?thesis by simp
  next
    case False
    from Cons(2) have "invar bq" by (rule invar_cons_down)
    with Cons(1)[of "t"] have si1: "invar (remove1 t bq)" .
    from False have "invar (remove1 t (a # bq)) = invar (a # (remove1 t bq))"
      by simp
    show ?thesis
    proof (cases "remove1 t bq")
      case Nil
      with si1 Cons(2) False show ?thesis by (simp add: invar_def)
    next
      case Cons': (Cons aa list)
      from Cons have "tree_invar a" by (simp add: invar_def)
      from Cons first_less[of "a" "bq"] have "\<forall>t \<in> set (remove1 t bq). rank a < rank t"
        by (metis notin_set_remove1 invar_def)
      with Cons' have "rank a < rank aa" by simp
      with si1 Cons(2) False Cons' invar_cons_up[of "aa" "list" "a"] show ?thesis
        by (simp add: invar_def)
    qed
  qed
qed

theorem deleteMin_invar:
  assumes "invar bq"
    and "bq \<noteq> []"
  shows "invar (deleteMin bq)"
proof -
  have eq: "invar (deleteMin bq) =
    invar (meld (rev (children (getMinTree bq))) (remove1 (getMinTree bq) bq))"
    by (simp add: deleteMin_def Let_def)
  from assms mintree_exists[of "bq"] have ti: "tree_invar (getMinTree bq)"
    by (simp add: invar_def Let_def queue_invar_def)
  with strong_rev_children[of "getMinTree bq"]
  have m1: "invar (rev (children (getMinTree bq)))" .
  from strong_remove1[of "bq" "getMinTree bq"] assms(1)
  have m2: "invar (remove1 (getMinTree bq) bq)" .
  from meld_correct(1)[of "rev (children (getMinTree bq))"
    "remove1 (getMinTree bq) bq"] m1 m2
  have "invar (meld (rev (children (getMinTree bq))) (remove1 (getMinTree bq) bq))" .
  with eq show ?thesis ..
qed

lemma children_mset: "queue_to_multiset (children t) =
  tree_to_multiset t - {# (val t, prio t) #}"
proof (cases t)
  case (Node e a nat list)
  thus ?thesis by (induct list) simp_all
qed

lemma deleteMin_mset:
  assumes "queue_invar q"
    and "q \<noteq> Nil"
  shows "queue_to_multiset (deleteMin q) = queue_to_multiset q - {# (findMin q) #}"
proof -
  from assms mintree_exists[of "q"] have min_in_q: "getMinTree q \<in> set q" by auto
  with assms(1) have inv_min: "tree_invar (getMinTree q)"
    by (simp add: queue_invar_def)
  from assms(2) have q_ne: "q \<noteq> []" .
  note inv_children = invar_children'[OF inv_min]
  note inv_rev = queue_invar_rev[OF inv_children]
  note inv_rem = queue_invar_remove1[OF assms(1), of "getMinTree q"]
  note m_meld = meld_mset[OF inv_rev inv_rem]
  note m_rem = remove1_mset[OF min_in_q]
  note m_rev = qtmset_rev[of "children (getMinTree q)"]
  note m_children = children_mset[of "getMinTree q"]
  note min_subset_q = qtm_in_set_subset[OF min_in_q]
  let ?Q = "queue_to_multiset q"
  let ?MT = "tree_to_multiset (getMinTree q)"
  from q_ne have head_subset_min:
    "{# (val (getMinTree q), prio (getMinTree q)) #} \<subseteq># ?MT"
    by(cases "getMinTree q") simp
  let ?Q = "queue_to_multiset q"
  let ?MT = "tree_to_multiset (getMinTree q)"
  from m_meld m_rem m_rev m_children
    multiset_diff_union_assoc[OF head_subset_min, of "?Q - ?MT"]
    mset_subset_eq_multiset_union_diff_commute[OF min_subset_q, of "?MT"]
  show ?thesis by (simp add: deleteMin_def union_ac Let_def findMin_def)
qed

lemma deleteMin_correct:
  assumes INV: "invar q"
  assumes NE: "q \<noteq> Nil"
  shows
  "invar (deleteMin q)"
  "queue_to_multiset (deleteMin q) = queue_to_multiset q - {# (findMin q) #}"
  using deleteMin_invar deleteMin_mset INV NE
  unfolding invar_def
  by auto

end

interpretation BinomialHeapStruc: BinomialHeapStruc_loc .

subsection "Hiding the Invariant"
subsubsection "Datatype"
typedef (overloaded) ('e, 'a) BinomialHeap =
  "{q :: ('e,'a::linorder) BinomialHeapStruc.BinomialQueue_inv. BinomialHeapStruc.invar q }"
  apply (rule_tac x="Nil" in exI)
  apply auto
  done

lemma Rep_BinomialHeap_invar[simp]:
  "BinomialHeapStruc.invar (Rep_BinomialHeap x)"
  using Rep_BinomialHeap
  by (auto)

lemma [simp, code abstype]: "Abs_BinomialHeap (Rep_BinomialHeap q) = q"
  by (rule Rep_BinomialHeap_inverse)

locale BinomialHeap_loc
begin
  subsubsection "Operations"

  definition [code]:
    "to_mset t == BinomialHeapStruc.queue_to_multiset (Rep_BinomialHeap t)"

  definition empty where "empty == Abs_BinomialHeap Nil"
  lemma [code abstract, simp]: "Rep_BinomialHeap empty = []"
    by (unfold empty_def) simp

  definition [code]: "isEmpty q == Rep_BinomialHeap q = Nil"
  lemma empty_rep: "q=empty \<longleftrightarrow> Rep_BinomialHeap q = Nil"
    apply (auto simp add: empty_def)
    apply (metis Rep_BinomialHeap_inverse)
    done

  lemma isEmpty_correct: "isEmpty q \<longleftrightarrow> q=empty"
    by (simp add: empty_rep isEmpty_def)

  definition
    insert
    :: "'e  \<Rightarrow> ('a::linorder) \<Rightarrow> ('e,'a) BinomialHeap \<Rightarrow> ('e,'a) BinomialHeap"
    where "insert e a q ==
            Abs_BinomialHeap (BinomialHeapStruc.insert e a (Rep_BinomialHeap q))"
  lemma [code abstract]:
    "Rep_BinomialHeap (insert e a q)
    = BinomialHeapStruc.insert e a (Rep_BinomialHeap q)"
    by (simp add: insert_def BinomialHeapStruc.insert_correct)

  definition [code]: "findMin q == BinomialHeapStruc.findMin (Rep_BinomialHeap q)"

  definition "deleteMin q ==
    if q=empty then empty
    else Abs_BinomialHeap (BinomialHeapStruc.deleteMin (Rep_BinomialHeap q))"

  text \<open>
    In this lemma, we do not use equality, but case-distinction for checking
    non-emptyness. That prevents the code generator from introducing
    an equality-class parameter for the entry type \<open>'a\<close>.
\<close>
  lemma [code abstract]: "Rep_BinomialHeap (deleteMin q) =
    (case (Rep_BinomialHeap q) of [] \<Rightarrow> [] |
     _ \<Rightarrow> BinomialHeapStruc.deleteMin (Rep_BinomialHeap q))"
  proof (cases "Rep_BinomialHeap q")
    case Nil
    show ?thesis
      apply (simp add: Nil)
      apply (auto simp add: deleteMin_def BinomialHeapStruc.deleteMin_correct
      BinomialHeapStruc.empty_iff empty_rep Nil)
      done
  next
    case (Cons a b)
    hence NE: "Rep_BinomialHeap q \<noteq> []" by auto
    show ?thesis
      apply (simp add: Cons)
      apply (fold Cons)
      using NE
      by (auto simp add: deleteMin_def BinomialHeapStruc.deleteMin_correct
        BinomialHeapStruc.empty_iff empty_rep)
  qed

  (*
  lemma [code abstract]: "Rep_BinomialHeap (deleteMin q) =
    (if (Rep_BinomialHeap q = []) then []
     else BinomialHeapStruc.deleteMin (Rep_BinomialHeap q))"
    by (auto simp add: deleteMin_def BinomialHeapStruc.deleteMin_correct
      BinomialHeapStruc.empty_iff empty_rep)
      *)

  definition "meld q1 q2 ==
    Abs_BinomialHeap (BinomialHeapStruc.meld (Rep_BinomialHeap q1)
                                             (Rep_BinomialHeap q2))"
  lemma [code abstract]:
    "Rep_BinomialHeap (meld q1 q2)
    = BinomialHeapStruc.meld (Rep_BinomialHeap q1) (Rep_BinomialHeap q2)"
    by (simp add: meld_def BinomialHeapStruc.meld_correct)

  subsubsection "Correctness"

  lemma empty_correct: "to_mset q = {#} \<longleftrightarrow> q=empty"
    by (simp add: to_mset_def BinomialHeapStruc.empty_iff empty_rep)

  lemma to_mset_of_empty[simp]: "to_mset empty = {#}"
    by (simp add: empty_correct)

  lemma insert_correct: "to_mset (insert e a q) = to_mset q + {#(e,a)#}"
    apply (unfold insert_def to_mset_def)
    apply (simp add: BinomialHeapStruc.insert_correct)
    done

  lemma findMin_correct:
    assumes "q\<noteq>empty"
    shows
    "findMin q \<in># to_mset q"
    "\<forall>y\<in>set_mset (to_mset q). snd (findMin q) \<le> snd y"
    using assms
    apply (unfold findMin_def to_mset_def)
    apply (simp_all add: empty_rep BinomialHeapStruc.findMin_correct)
    done

  lemma deleteMin_correct:
    assumes "q\<noteq>empty"
    shows "to_mset (deleteMin q) = to_mset q - {# findMin q #}"
    using assms
    apply (unfold findMin_def deleteMin_def to_mset_def)
    apply (simp_all add: empty_rep BinomialHeapStruc.deleteMin_correct)
    done

  lemma meld_correct:
    shows "to_mset (meld q q') = to_mset q + to_mset q'"
    apply (unfold to_mset_def meld_def)
    apply (simp_all add: BinomialHeapStruc.meld_correct)
    done

  text \<open>Correctness lemmas to be used with simplifier\<close>
  lemmas correct = empty_correct deleteMin_correct meld_correct

  end
  interpretation BinomialHeap: BinomialHeap_loc .

subsection "Documentation"

(*#DOC
  fun [no_spec] BinomialHeap.to_mset
    Abstraction to multiset.

  fun BinomialHeap.empty
    The empty heap. ($O(1)$)

  fun BinomialHeap.isEmpty
    Checks whether heap is empty. Mainly used to work around
    code-generation issues. ($O(1)$)

  fun BinomialHeap.insert
    Inserts element ($O(\log(n))$)

  fun BinomialHeap.findMin
    Returns a minimal element ($O(\log(n))$)

  fun BinomialHeap.deleteMin
    Deletes {\em the} element that is returned by {\em find\_min}

  fun [long_type] BinomialHeap.meld
    Melds two heaps ($O(\log(n+m))$)

*)

text \<open>
    \underline{@{term_type "BinomialHeap.to_mset"}}\\
        Abstraction to multiset.\\

    \underline{@{term_type "BinomialHeap.empty"}}\\
        The empty heap. ($O(1)$)\\
    {\bf Spec} \<open>BinomialHeap.empty_correct\<close>:
    @{thm [display] BinomialHeap.empty_correct[no_vars]}

    \underline{@{term_type "BinomialHeap.isEmpty"}}\\
        Checks whether heap is empty. Mainly used to work around
    code-generation issues. ($O(1)$)\\
    {\bf Spec} \<open>BinomialHeap.isEmpty_correct\<close>:
    @{thm [display] BinomialHeap.isEmpty_correct[no_vars]}

    \underline{@{term_type "BinomialHeap.insert"}}\\
        Inserts element ($O(\log(n))$)\\
    {\bf Spec} \<open>BinomialHeap.insert_correct\<close>:
    @{thm [display] BinomialHeap.insert_correct[no_vars]}

    \underline{@{term_type "BinomialHeap.findMin"}}\\
        Returns a minimal element ($O(\log(n))$)\\
    {\bf Spec} \<open>BinomialHeap.findMin_correct\<close>:
    @{thm [display] BinomialHeap.findMin_correct[no_vars]}

    \underline{@{term_type "BinomialHeap.deleteMin"}}\\
        Deletes {\em the} element that is returned by {\em find\_min}\\
    {\bf Spec} \<open>BinomialHeap.deleteMin_correct\<close>:
    @{thm [display] BinomialHeap.deleteMin_correct[no_vars]}

    \underline{@{term "BinomialHeap.meld"}}
    @{term_type [display] "BinomialHeap.meld"}
        Melds two heaps ($O(\log(n+m))$)\\
    {\bf Spec} \<open>BinomialHeap.meld_correct\<close>:
    @{thm [display] BinomialHeap.meld_correct[no_vars]}

\<close>

end


(*  Title:      HOL/Library/FSet.thy
    Author:     Ondrej Kuncar, TU Muenchen
    Author:     Cezary Kaliszyk and Christian Urban
    Author:     Andrei Popescu, TU Muenchen
*)

section {* Type of finite sets defined as a subtype of sets *}

theory FSet
imports Conditionally_Complete_Lattices
begin

subsection {* Definition of the type *}

typedef 'a fset = "{A :: 'a set. finite A}"  morphisms fset Abs_fset
by auto

setup_lifting type_definition_fset

subsection {* Basic operations and type class instantiations *}

(* FIXME transfer and right_total vs. bi_total *)
instantiation fset :: (finite) finite
begin
instance by default (transfer, simp)
end

instantiation fset :: (type) "{bounded_lattice_bot, distrib_lattice, minus}"
begin

interpretation lifting_syntax .

lift_definition bot_fset :: "'a fset" is "{}" parametric empty_transfer by simp

lift_definition less_eq_fset :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> bool" is subset_eq parametric subset_transfer
  .

definition less_fset :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> bool" where "xs < ys \<equiv> xs \<le> ys \<and> xs \<noteq> (ys::'a fset)"

lemma less_fset_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A"
  shows "((pcr_fset A) ===> (pcr_fset A) ===> op =) op \<subset> op <"
  unfolding less_fset_def[abs_def] psubset_eq[abs_def] by transfer_prover

lift_definition sup_fset :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> 'a fset" is union parametric union_transfer
  by simp

lift_definition inf_fset :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> 'a fset" is inter parametric inter_transfer
  by simp

lift_definition minus_fset :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> 'a fset" is minus parametric Diff_transfer
  by simp

instance
by default (transfer, auto)+

end

abbreviation fempty :: "'a fset" ("{||}") where "{||} \<equiv> bot"
abbreviation fsubset_eq :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> bool" (infix "|\<subseteq>|" 50) where "xs |\<subseteq>| ys \<equiv> xs \<le> ys"
abbreviation fsubset :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> bool" (infix "|\<subset>|" 50) where "xs |\<subset>| ys \<equiv> xs < ys"
abbreviation funion :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> 'a fset" (infixl "|\<union>|" 65) where "xs |\<union>| ys \<equiv> sup xs ys"
abbreviation finter :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> 'a fset" (infixl "|\<inter>|" 65) where "xs |\<inter>| ys \<equiv> inf xs ys"
abbreviation fminus :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> 'a fset" (infixl "|-|" 65) where "xs |-| ys \<equiv> minus xs ys"

instantiation fset :: (equal) equal
begin
definition "HOL.equal A B \<longleftrightarrow> A |\<subseteq>| B \<and> B |\<subseteq>| A"
instance by intro_classes (auto simp add: equal_fset_def)
end

instantiation fset :: (type) conditionally_complete_lattice
begin

interpretation lifting_syntax .

lemma right_total_Inf_fset_transfer:
  assumes [transfer_rule]: "bi_unique A" and [transfer_rule]: "right_total A"
  shows "(rel_set (rel_set A) ===> rel_set A)
    (\<lambda>S. if finite (Inter S \<inter> Collect (Domainp A)) then Inter S \<inter> Collect (Domainp A) else {})
      (\<lambda>S. if finite (Inf S) then Inf S else {})"
    by transfer_prover

lemma Inf_fset_transfer:
  assumes [transfer_rule]: "bi_unique A" and [transfer_rule]: "bi_total A"
  shows "(rel_set (rel_set A) ===> rel_set A) (\<lambda>A. if finite (Inf A) then Inf A else {})
    (\<lambda>A. if finite (Inf A) then Inf A else {})"
  by transfer_prover

lift_definition Inf_fset :: "'a fset set \<Rightarrow> 'a fset" is "\<lambda>A. if finite (Inf A) then Inf A else {}"
parametric right_total_Inf_fset_transfer Inf_fset_transfer by simp

lemma Sup_fset_transfer:
  assumes [transfer_rule]: "bi_unique A"
  shows "(rel_set (rel_set A) ===> rel_set A) (\<lambda>A. if finite (Sup A) then Sup A else {})
  (\<lambda>A. if finite (Sup A) then Sup A else {})" by transfer_prover

lift_definition Sup_fset :: "'a fset set \<Rightarrow> 'a fset" is "\<lambda>A. if finite (Sup A) then Sup A else {}"
parametric Sup_fset_transfer by simp

lemma finite_Sup: "\<exists>z. finite z \<and> (\<forall>a. a \<in> X \<longrightarrow> a \<le> z) \<Longrightarrow> finite (Sup X)"
by (auto intro: finite_subset)

lemma transfer_bdd_below[transfer_rule]: "(rel_set (pcr_fset op =) ===> op =) bdd_below bdd_below"
  by auto

instance
proof
  fix x z :: "'a fset"
  fix X :: "'a fset set"
  {
    assume "x \<in> X" "bdd_below X"
    then show "Inf X |\<subseteq>| x" by transfer auto
  next
    assume "X \<noteq> {}" "(\<And>x. x \<in> X \<Longrightarrow> z |\<subseteq>| x)"
    then show "z |\<subseteq>| Inf X" by transfer (clarsimp, blast)
  next
    assume "x \<in> X" "bdd_above X"
    then obtain z where "x \<in> X" "(\<And>x. x \<in> X \<Longrightarrow> x |\<subseteq>| z)"
      by (auto simp: bdd_above_def)
    then show "x |\<subseteq>| Sup X"
      by transfer (auto intro!: finite_Sup)
  next
    assume "X \<noteq> {}" "(\<And>x. x \<in> X \<Longrightarrow> x |\<subseteq>| z)"
    then show "Sup X |\<subseteq>| z" by transfer (clarsimp, blast)
  }
qed
end

instantiation fset :: (finite) complete_lattice
begin

lift_definition top_fset :: "'a fset" is UNIV parametric right_total_UNIV_transfer UNIV_transfer by simp

instance by default (transfer, auto)+
end

instantiation fset :: (finite) complete_boolean_algebra
begin

lift_definition uminus_fset :: "'a fset \<Rightarrow> 'a fset" is uminus
  parametric right_total_Compl_transfer Compl_transfer by simp

instance by (default, simp_all only: INF_def SUP_def) (transfer, simp add: Compl_partition Diff_eq)+

end

abbreviation fUNIV :: "'a::finite fset" where "fUNIV \<equiv> top"
abbreviation fuminus :: "'a::finite fset \<Rightarrow> 'a fset" ("|-| _" [81] 80) where "|-| x \<equiv> uminus x"

declare top_fset.rep_eq[simp]

subsection {* Other operations *}

lift_definition finsert :: "'a \<Rightarrow> 'a fset \<Rightarrow> 'a fset" is insert parametric Lifting_Set.insert_transfer
  by simp

syntax
  "_insert_fset"     :: "args => 'a fset"  ("{|(_)|}")

translations
  "{|x, xs|}" == "CONST finsert x {|xs|}"
  "{|x|}"     == "CONST finsert x {||}"

lift_definition fmember :: "'a \<Rightarrow> 'a fset \<Rightarrow> bool" (infix "|\<in>|" 50) is Set.member
  parametric member_transfer .

abbreviation notin_fset :: "'a \<Rightarrow> 'a fset \<Rightarrow> bool" (infix "|\<notin>|" 50) where "x |\<notin>| S \<equiv> \<not> (x |\<in>| S)"

context
begin

interpretation lifting_syntax .

lift_definition ffilter :: "('a \<Rightarrow> bool) \<Rightarrow> 'a fset \<Rightarrow> 'a fset" is Set.filter
  parametric Lifting_Set.filter_transfer unfolding Set.filter_def by simp

lift_definition fPow :: "'a fset \<Rightarrow> 'a fset fset" is Pow parametric Pow_transfer
by (simp add: finite_subset)

lift_definition fcard :: "'a fset \<Rightarrow> nat" is card parametric card_transfer .

lift_definition fimage :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a fset \<Rightarrow> 'b fset" (infixr "|`|" 90) is image
  parametric image_transfer by simp

lift_definition fthe_elem :: "'a fset \<Rightarrow> 'a" is the_elem .

lift_definition fbind :: "'a fset \<Rightarrow> ('a \<Rightarrow> 'b fset) \<Rightarrow> 'b fset" is Set.bind parametric bind_transfer
by (simp add: Set.bind_def)

lift_definition ffUnion :: "'a fset fset \<Rightarrow> 'a fset" is Union parametric Union_transfer by simp

lift_definition fBall :: "'a fset \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" is Ball parametric Ball_transfer .
lift_definition fBex :: "'a fset \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" is Bex parametric Bex_transfer .

lift_definition ffold :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'a fset \<Rightarrow> 'b" is Finite_Set.fold .

subsection {* Transferred lemmas from Set.thy *}

lemmas fset_eqI = set_eqI[Transfer.transferred]
lemmas fset_eq_iff[no_atp] = set_eq_iff[Transfer.transferred]
lemmas fBallI[intro!] = ballI[Transfer.transferred]
lemmas fbspec[dest?] = bspec[Transfer.transferred]
lemmas fBallE[elim] = ballE[Transfer.transferred]
lemmas fBexI[intro] = bexI[Transfer.transferred]
lemmas rev_fBexI[intro?] = rev_bexI[Transfer.transferred]
lemmas fBexCI = bexCI[Transfer.transferred]
lemmas fBexE[elim!] = bexE[Transfer.transferred]
lemmas fBall_triv[simp] = ball_triv[Transfer.transferred]
lemmas fBex_triv[simp] = bex_triv[Transfer.transferred]
lemmas fBex_triv_one_point1[simp] = bex_triv_one_point1[Transfer.transferred]
lemmas fBex_triv_one_point2[simp] = bex_triv_one_point2[Transfer.transferred]
lemmas fBex_one_point1[simp] = bex_one_point1[Transfer.transferred]
lemmas fBex_one_point2[simp] = bex_one_point2[Transfer.transferred]
lemmas fBall_one_point1[simp] = ball_one_point1[Transfer.transferred]
lemmas fBall_one_point2[simp] = ball_one_point2[Transfer.transferred]
lemmas fBall_conj_distrib = ball_conj_distrib[Transfer.transferred]
lemmas fBex_disj_distrib = bex_disj_distrib[Transfer.transferred]
lemmas fBall_cong = ball_cong[Transfer.transferred]
lemmas fBex_cong = bex_cong[Transfer.transferred]
lemmas fsubsetI[intro!] = subsetI[Transfer.transferred]
lemmas fsubsetD[elim, intro?] = subsetD[Transfer.transferred]
lemmas rev_fsubsetD[no_atp,intro?] = rev_subsetD[Transfer.transferred]
lemmas fsubsetCE[no_atp,elim] = subsetCE[Transfer.transferred]
lemmas fsubset_eq[no_atp] = subset_eq[Transfer.transferred]
lemmas contra_fsubsetD[no_atp] = contra_subsetD[Transfer.transferred]
lemmas fsubset_refl = subset_refl[Transfer.transferred]
lemmas fsubset_trans = subset_trans[Transfer.transferred]
lemmas fset_rev_mp = set_rev_mp[Transfer.transferred]
lemmas fset_mp = set_mp[Transfer.transferred]
lemmas fsubset_not_fsubset_eq[code] = subset_not_subset_eq[Transfer.transferred]
lemmas eq_fmem_trans = eq_mem_trans[Transfer.transferred]
lemmas fsubset_antisym[intro!] = subset_antisym[Transfer.transferred]
lemmas fequalityD1 = equalityD1[Transfer.transferred]
lemmas fequalityD2 = equalityD2[Transfer.transferred]
lemmas fequalityE = equalityE[Transfer.transferred]
lemmas fequalityCE[elim] = equalityCE[Transfer.transferred]
lemmas eqfset_imp_iff = eqset_imp_iff[Transfer.transferred]
lemmas eqfelem_imp_iff = eqelem_imp_iff[Transfer.transferred]
lemmas fempty_iff[simp] = empty_iff[Transfer.transferred]
lemmas fempty_fsubsetI[iff] = empty_subsetI[Transfer.transferred]
lemmas equalsffemptyI = equals0I[Transfer.transferred]
lemmas equalsffemptyD = equals0D[Transfer.transferred]
lemmas fBall_fempty[simp] = ball_empty[Transfer.transferred]
lemmas fBex_fempty[simp] = bex_empty[Transfer.transferred]
lemmas fPow_iff[iff] = Pow_iff[Transfer.transferred]
lemmas fPowI = PowI[Transfer.transferred]
lemmas fPowD = PowD[Transfer.transferred]
lemmas fPow_bottom = Pow_bottom[Transfer.transferred]
lemmas fPow_top = Pow_top[Transfer.transferred]
lemmas fPow_not_fempty = Pow_not_empty[Transfer.transferred]
lemmas finter_iff[simp] = Int_iff[Transfer.transferred]
lemmas finterI[intro!] = IntI[Transfer.transferred]
lemmas finterD1 = IntD1[Transfer.transferred]
lemmas finterD2 = IntD2[Transfer.transferred]
lemmas finterE[elim!] = IntE[Transfer.transferred]
lemmas funion_iff[simp] = Un_iff[Transfer.transferred]
lemmas funionI1[elim?] = UnI1[Transfer.transferred]
lemmas funionI2[elim?] = UnI2[Transfer.transferred]
lemmas funionCI[intro!] = UnCI[Transfer.transferred]
lemmas funionE[elim!] = UnE[Transfer.transferred]
lemmas fminus_iff[simp] = Diff_iff[Transfer.transferred]
lemmas fminusI[intro!] = DiffI[Transfer.transferred]
lemmas fminusD1 = DiffD1[Transfer.transferred]
lemmas fminusD2 = DiffD2[Transfer.transferred]
lemmas fminusE[elim!] = DiffE[Transfer.transferred]
lemmas finsert_iff[simp] = insert_iff[Transfer.transferred]
lemmas finsertI1 = insertI1[Transfer.transferred]
lemmas finsertI2 = insertI2[Transfer.transferred]
lemmas finsertE[elim!] = insertE[Transfer.transferred]
lemmas finsertCI[intro!] = insertCI[Transfer.transferred]
lemmas fsubset_finsert_iff = subset_insert_iff[Transfer.transferred]
lemmas finsert_ident = insert_ident[Transfer.transferred]
lemmas fsingletonI[intro!,no_atp] = singletonI[Transfer.transferred]
lemmas fsingletonD[dest!,no_atp] = singletonD[Transfer.transferred]
lemmas fsingleton_iff = singleton_iff[Transfer.transferred]
lemmas fsingleton_inject[dest!] = singleton_inject[Transfer.transferred]
lemmas fsingleton_finsert_inj_eq[iff,no_atp] = singleton_insert_inj_eq[Transfer.transferred]
lemmas fsingleton_finsert_inj_eq'[iff,no_atp] = singleton_insert_inj_eq'[Transfer.transferred]
lemmas fsubset_fsingletonD = subset_singletonD[Transfer.transferred]
lemmas fminus_single_finsert = diff_single_insert[Transfer.transferred]
lemmas fdoubleton_eq_iff = doubleton_eq_iff[Transfer.transferred]
lemmas funion_fsingleton_iff = Un_singleton_iff[Transfer.transferred]
lemmas fsingleton_funion_iff = singleton_Un_iff[Transfer.transferred]
lemmas fimage_eqI[simp, intro] = image_eqI[Transfer.transferred]
lemmas fimageI = imageI[Transfer.transferred]
lemmas rev_fimage_eqI = rev_image_eqI[Transfer.transferred]
lemmas fimageE[elim!] = imageE[Transfer.transferred]
lemmas Compr_fimage_eq = Compr_image_eq[Transfer.transferred]
lemmas fimage_funion = image_Un[Transfer.transferred]
lemmas fimage_iff = image_iff[Transfer.transferred]
lemmas fimage_fsubset_iff[no_atp] = image_subset_iff[Transfer.transferred]
lemmas fimage_fsubsetI = image_subsetI[Transfer.transferred]
lemmas fimage_ident[simp] = image_ident[Transfer.transferred]
lemmas split_if_fmem1 = split_if_mem1[Transfer.transferred]
lemmas split_if_fmem2 = split_if_mem2[Transfer.transferred]
lemmas pfsubsetI[intro!,no_atp] = psubsetI[Transfer.transferred]
lemmas pfsubsetE[elim!,no_atp] = psubsetE[Transfer.transferred]
lemmas pfsubset_finsert_iff = psubset_insert_iff[Transfer.transferred]
lemmas pfsubset_eq = psubset_eq[Transfer.transferred]
lemmas pfsubset_imp_fsubset = psubset_imp_subset[Transfer.transferred]
lemmas pfsubset_trans = psubset_trans[Transfer.transferred]
lemmas pfsubsetD = psubsetD[Transfer.transferred]
lemmas pfsubset_fsubset_trans = psubset_subset_trans[Transfer.transferred]
lemmas fsubset_pfsubset_trans = subset_psubset_trans[Transfer.transferred]
lemmas pfsubset_imp_ex_fmem = psubset_imp_ex_mem[Transfer.transferred]
lemmas fimage_fPow_mono = image_Pow_mono[Transfer.transferred]
lemmas fimage_fPow_surj = image_Pow_surj[Transfer.transferred]
lemmas fsubset_finsertI = subset_insertI[Transfer.transferred]
lemmas fsubset_finsertI2 = subset_insertI2[Transfer.transferred]
lemmas fsubset_finsert = subset_insert[Transfer.transferred]
lemmas funion_upper1 = Un_upper1[Transfer.transferred]
lemmas funion_upper2 = Un_upper2[Transfer.transferred]
lemmas funion_least = Un_least[Transfer.transferred]
lemmas finter_lower1 = Int_lower1[Transfer.transferred]
lemmas finter_lower2 = Int_lower2[Transfer.transferred]
lemmas finter_greatest = Int_greatest[Transfer.transferred]
lemmas fminus_fsubset = Diff_subset[Transfer.transferred]
lemmas fminus_fsubset_conv = Diff_subset_conv[Transfer.transferred]
lemmas fsubset_fempty[simp] = subset_empty[Transfer.transferred]
lemmas not_pfsubset_fempty[iff] = not_psubset_empty[Transfer.transferred]
lemmas finsert_is_funion = insert_is_Un[Transfer.transferred]
lemmas finsert_not_fempty[simp] = insert_not_empty[Transfer.transferred]
lemmas fempty_not_finsert = empty_not_insert[Transfer.transferred]
lemmas finsert_absorb = insert_absorb[Transfer.transferred]
lemmas finsert_absorb2[simp] = insert_absorb2[Transfer.transferred]
lemmas finsert_commute = insert_commute[Transfer.transferred]
lemmas finsert_fsubset[simp] = insert_subset[Transfer.transferred]
lemmas finsert_inter_finsert[simp] = insert_inter_insert[Transfer.transferred]
lemmas finsert_disjoint[simp,no_atp] = insert_disjoint[Transfer.transferred]
lemmas disjoint_finsert[simp,no_atp] = disjoint_insert[Transfer.transferred]
lemmas fimage_fempty[simp] = image_empty[Transfer.transferred]
lemmas fimage_finsert[simp] = image_insert[Transfer.transferred]
lemmas fimage_constant = image_constant[Transfer.transferred]
lemmas fimage_constant_conv = image_constant_conv[Transfer.transferred]
lemmas fimage_fimage = image_image[Transfer.transferred]
lemmas finsert_fimage[simp] = insert_image[Transfer.transferred]
lemmas fimage_is_fempty[iff] = image_is_empty[Transfer.transferred]
lemmas fempty_is_fimage[iff] = empty_is_image[Transfer.transferred]
lemmas fimage_cong = image_cong[Transfer.transferred]
lemmas fimage_finter_fsubset = image_Int_subset[Transfer.transferred]
lemmas fimage_fminus_fsubset = image_diff_subset[Transfer.transferred]
lemmas finter_absorb = Int_absorb[Transfer.transferred]
lemmas finter_left_absorb = Int_left_absorb[Transfer.transferred]
lemmas finter_commute = Int_commute[Transfer.transferred]
lemmas finter_left_commute = Int_left_commute[Transfer.transferred]
lemmas finter_assoc = Int_assoc[Transfer.transferred]
lemmas finter_ac = Int_ac[Transfer.transferred]
lemmas finter_absorb1 = Int_absorb1[Transfer.transferred]
lemmas finter_absorb2 = Int_absorb2[Transfer.transferred]
lemmas finter_fempty_left = Int_empty_left[Transfer.transferred]
lemmas finter_fempty_right = Int_empty_right[Transfer.transferred]
lemmas disjoint_iff_fnot_equal = disjoint_iff_not_equal[Transfer.transferred]
lemmas finter_funion_distrib = Int_Un_distrib[Transfer.transferred]
lemmas finter_funion_distrib2 = Int_Un_distrib2[Transfer.transferred]
lemmas finter_fsubset_iff[no_atp, simp] = Int_subset_iff[Transfer.transferred]
lemmas funion_absorb = Un_absorb[Transfer.transferred]
lemmas funion_left_absorb = Un_left_absorb[Transfer.transferred]
lemmas funion_commute = Un_commute[Transfer.transferred]
lemmas funion_left_commute = Un_left_commute[Transfer.transferred]
lemmas funion_assoc = Un_assoc[Transfer.transferred]
lemmas funion_ac = Un_ac[Transfer.transferred]
lemmas funion_absorb1 = Un_absorb1[Transfer.transferred]
lemmas funion_absorb2 = Un_absorb2[Transfer.transferred]
lemmas funion_fempty_left = Un_empty_left[Transfer.transferred]
lemmas funion_fempty_right = Un_empty_right[Transfer.transferred]
lemmas funion_finsert_left[simp] = Un_insert_left[Transfer.transferred]
lemmas funion_finsert_right[simp] = Un_insert_right[Transfer.transferred]
lemmas finter_finsert_left = Int_insert_left[Transfer.transferred]
lemmas finter_finsert_left_ifffempty[simp] = Int_insert_left_if0[Transfer.transferred]
lemmas finter_finsert_left_if1[simp] = Int_insert_left_if1[Transfer.transferred]
lemmas finter_finsert_right = Int_insert_right[Transfer.transferred]
lemmas finter_finsert_right_ifffempty[simp] = Int_insert_right_if0[Transfer.transferred]
lemmas finter_finsert_right_if1[simp] = Int_insert_right_if1[Transfer.transferred]
lemmas funion_finter_distrib = Un_Int_distrib[Transfer.transferred]
lemmas funion_finter_distrib2 = Un_Int_distrib2[Transfer.transferred]
lemmas funion_finter_crazy = Un_Int_crazy[Transfer.transferred]
lemmas fsubset_funion_eq = subset_Un_eq[Transfer.transferred]
lemmas funion_fempty[iff] = Un_empty[Transfer.transferred]
lemmas funion_fsubset_iff[no_atp, simp] = Un_subset_iff[Transfer.transferred]
lemmas funion_fminus_finter = Un_Diff_Int[Transfer.transferred]
lemmas fminus_finter2 = Diff_Int2[Transfer.transferred]
lemmas funion_finter_assoc_eq = Un_Int_assoc_eq[Transfer.transferred]
lemmas fBall_funion = ball_Un[Transfer.transferred]
lemmas fBex_funion = bex_Un[Transfer.transferred]
lemmas fminus_eq_fempty_iff[simp,no_atp] = Diff_eq_empty_iff[Transfer.transferred]
lemmas fminus_cancel[simp] = Diff_cancel[Transfer.transferred]
lemmas fminus_idemp[simp] = Diff_idemp[Transfer.transferred]
lemmas fminus_triv = Diff_triv[Transfer.transferred]
lemmas fempty_fminus[simp] = empty_Diff[Transfer.transferred]
lemmas fminus_fempty[simp] = Diff_empty[Transfer.transferred]
lemmas fminus_finsertffempty[simp,no_atp] = Diff_insert0[Transfer.transferred]
lemmas fminus_finsert = Diff_insert[Transfer.transferred]
lemmas fminus_finsert2 = Diff_insert2[Transfer.transferred]
lemmas finsert_fminus_if = insert_Diff_if[Transfer.transferred]
lemmas finsert_fminus1[simp] = insert_Diff1[Transfer.transferred]
lemmas finsert_fminus_single[simp] = insert_Diff_single[Transfer.transferred]
lemmas finsert_fminus = insert_Diff[Transfer.transferred]
lemmas fminus_finsert_absorb = Diff_insert_absorb[Transfer.transferred]
lemmas fminus_disjoint[simp] = Diff_disjoint[Transfer.transferred]
lemmas fminus_partition = Diff_partition[Transfer.transferred]
lemmas double_fminus = double_diff[Transfer.transferred]
lemmas funion_fminus_cancel[simp] = Un_Diff_cancel[Transfer.transferred]
lemmas funion_fminus_cancel2[simp] = Un_Diff_cancel2[Transfer.transferred]
lemmas fminus_funion = Diff_Un[Transfer.transferred]
lemmas fminus_finter = Diff_Int[Transfer.transferred]
lemmas funion_fminus = Un_Diff[Transfer.transferred]
lemmas finter_fminus = Int_Diff[Transfer.transferred]
lemmas fminus_finter_distrib = Diff_Int_distrib[Transfer.transferred]
lemmas fminus_finter_distrib2 = Diff_Int_distrib2[Transfer.transferred]
lemmas fUNIV_bool[no_atp] = UNIV_bool[Transfer.transferred]
lemmas fPow_fempty[simp] = Pow_empty[Transfer.transferred]
lemmas fPow_finsert = Pow_insert[Transfer.transferred]
lemmas funion_fPow_fsubset = Un_Pow_subset[Transfer.transferred]
lemmas fPow_finter_eq[simp] = Pow_Int_eq[Transfer.transferred]
lemmas fset_eq_fsubset = set_eq_subset[Transfer.transferred]
lemmas fsubset_iff[no_atp] = subset_iff[Transfer.transferred]
lemmas fsubset_iff_pfsubset_eq = subset_iff_psubset_eq[Transfer.transferred]
lemmas all_not_fin_conv[simp] = all_not_in_conv[Transfer.transferred]
lemmas ex_fin_conv = ex_in_conv[Transfer.transferred]
lemmas fimage_mono = image_mono[Transfer.transferred]
lemmas fPow_mono = Pow_mono[Transfer.transferred]
lemmas finsert_mono = insert_mono[Transfer.transferred]
lemmas funion_mono = Un_mono[Transfer.transferred]
lemmas finter_mono = Int_mono[Transfer.transferred]
lemmas fminus_mono = Diff_mono[Transfer.transferred]
lemmas fin_mono = in_mono[Transfer.transferred]
lemmas fthe_felem_eq[simp] = the_elem_eq[Transfer.transferred]
lemmas fLeast_mono = Least_mono[Transfer.transferred]
lemmas fbind_fbind = bind_bind[Transfer.transferred]
lemmas fempty_fbind[simp] = empty_bind[Transfer.transferred]
lemmas nonfempty_fbind_const = nonempty_bind_const[Transfer.transferred]
lemmas fbind_const = bind_const[Transfer.transferred]
lemmas ffmember_filter[simp] = member_filter[Transfer.transferred]
lemmas fequalityI = equalityI[Transfer.transferred]

subsection {* Additional lemmas*}

subsubsection {* @{text fsingleton} *}

lemmas fsingletonE = fsingletonD [elim_format]

subsubsection {* @{text femepty} *}

lemma fempty_ffilter[simp]: "ffilter (\<lambda>_. False) A = {||}"
by transfer auto

(* FIXME, transferred doesn't work here *)
lemma femptyE [elim!]: "a |\<in>| {||} \<Longrightarrow> P"
  by simp

subsubsection {* @{text fset} *}

lemmas fset_simps[simp] = bot_fset.rep_eq finsert.rep_eq

lemma finite_fset [simp]:
  shows "finite (fset S)"
  by transfer simp

lemmas fset_cong = fset_inject

lemma filter_fset [simp]:
  shows "fset (ffilter P xs) = Collect P \<inter> fset xs"
  by transfer auto

lemma notin_fset: "x |\<notin>| S \<longleftrightarrow> x \<notin> fset S" by (simp add: fmember.rep_eq)

lemmas inter_fset[simp] = inf_fset.rep_eq

lemmas union_fset[simp] = sup_fset.rep_eq

lemmas minus_fset[simp] = minus_fset.rep_eq

subsubsection {* @{text filter_fset} *}

lemma subset_ffilter:
  "ffilter P A |\<subseteq>| ffilter Q A = (\<forall> x. x |\<in>| A \<longrightarrow> P x \<longrightarrow> Q x)"
  by transfer auto

lemma eq_ffilter:
  "(ffilter P A = ffilter Q A) = (\<forall>x. x |\<in>| A \<longrightarrow> P x = Q x)"
  by transfer auto

lemma pfsubset_ffilter:
  "(\<And>x. x |\<in>| A \<Longrightarrow> P x \<Longrightarrow> Q x) \<Longrightarrow> (x |\<in>| A & \<not> P x & Q x) \<Longrightarrow>
    ffilter P A |\<subset>| ffilter Q A"
  unfolding less_fset_def by (auto simp add: subset_ffilter eq_ffilter)

subsubsection {* @{text finsert} *}

(* FIXME, transferred doesn't work here *)
lemma set_finsert:
  assumes "x |\<in>| A"
  obtains B where "A = finsert x B" and "x |\<notin>| B"
using assms by transfer (metis Set.set_insert finite_insert)

lemma mk_disjoint_finsert: "a |\<in>| A \<Longrightarrow> \<exists>B. A = finsert a B \<and> a |\<notin>| B"
  by (rule_tac x = "A |-| {|a|}" in exI, blast)

subsubsection {* @{text fimage} *}

lemma subset_fimage_iff: "(B |\<subseteq>| f|`|A) = (\<exists> AA. AA |\<subseteq>| A \<and> B = f|`|AA)"
by transfer (metis mem_Collect_eq rev_finite_subset subset_image_iff)

subsubsection {* bounded quantification *}

lemma bex_simps [simp, no_atp]:
  "\<And>A P Q. fBex A (\<lambda>x. P x \<and> Q) = (fBex A P \<and> Q)"
  "\<And>A P Q. fBex A (\<lambda>x. P \<and> Q x) = (P \<and> fBex A Q)"
  "\<And>P. fBex {||} P = False"
  "\<And>a B P. fBex (finsert a B) P = (P a \<or> fBex B P)"
  "\<And>A P f. fBex (f |`| A) P = fBex A (\<lambda>x. P (f x))"
  "\<And>A P. (\<not> fBex A P) = fBall A (\<lambda>x. \<not> P x)"
by auto

lemma ball_simps [simp, no_atp]:
  "\<And>A P Q. fBall A (\<lambda>x. P x \<or> Q) = (fBall A P \<or> Q)"
  "\<And>A P Q. fBall A (\<lambda>x. P \<or> Q x) = (P \<or> fBall A Q)"
  "\<And>A P Q. fBall A (\<lambda>x. P \<longrightarrow> Q x) = (P \<longrightarrow> fBall A Q)"
  "\<And>A P Q. fBall A (\<lambda>x. P x \<longrightarrow> Q) = (fBex A P \<longrightarrow> Q)"
  "\<And>P. fBall {||} P = True"
  "\<And>a B P. fBall (finsert a B) P = (P a \<and> fBall B P)"
  "\<And>A P f. fBall (f |`| A) P = fBall A (\<lambda>x. P (f x))"
  "\<And>A P. (\<not> fBall A P) = fBex A (\<lambda>x. \<not> P x)"
by auto

lemma atomize_fBall:
    "(\<And>x. x |\<in>| A ==> P x) == Trueprop (fBall A (\<lambda>x. P x))"
apply (simp only: atomize_all atomize_imp)
apply (rule equal_intr_rule)
by (transfer, simp)+

end

subsubsection {* @{text fcard} *}

(* FIXME: improve transferred to handle bounded meta quantification *)

lemma fcard_fempty:
  "fcard {||} = 0"
  by transfer (rule card_empty)

lemma fcard_finsert_disjoint:
  "x |\<notin>| A \<Longrightarrow> fcard (finsert x A) = Suc (fcard A)"
  by transfer (rule card_insert_disjoint)

lemma fcard_finsert_if:
  "fcard (finsert x A) = (if x |\<in>| A then fcard A else Suc (fcard A))"
  by transfer (rule card_insert_if)

lemma card_0_eq [simp, no_atp]:
  "fcard A = 0 \<longleftrightarrow> A = {||}"
  by transfer (rule card_0_eq)

lemma fcard_Suc_fminus1:
  "x |\<in>| A \<Longrightarrow> Suc (fcard (A |-| {|x|})) = fcard A"
  by transfer (rule card_Suc_Diff1)

lemma fcard_fminus_fsingleton:
  "x |\<in>| A \<Longrightarrow> fcard (A |-| {|x|}) = fcard A - 1"
  by transfer (rule card_Diff_singleton)

lemma fcard_fminus_fsingleton_if:
  "fcard (A |-| {|x|}) = (if x |\<in>| A then fcard A - 1 else fcard A)"
  by transfer (rule card_Diff_singleton_if)

lemma fcard_fminus_finsert[simp]:
  assumes "a |\<in>| A" and "a |\<notin>| B"
  shows "fcard (A |-| finsert a B) = fcard (A |-| B) - 1"
using assms by transfer (rule card_Diff_insert)

lemma fcard_finsert: "fcard (finsert x A) = Suc (fcard (A |-| {|x|}))"
by transfer (rule card_insert)

lemma fcard_finsert_le: "fcard A \<le> fcard (finsert x A)"
by transfer (rule card_insert_le)

lemma fcard_mono:
  "A |\<subseteq>| B \<Longrightarrow> fcard A \<le> fcard B"
by transfer (rule card_mono)

lemma fcard_seteq: "A |\<subseteq>| B \<Longrightarrow> fcard B \<le> fcard A \<Longrightarrow> A = B"
by transfer (rule card_seteq)

lemma pfsubset_fcard_mono: "A |\<subset>| B \<Longrightarrow> fcard A < fcard B"
by transfer (rule psubset_card_mono)

lemma fcard_funion_finter:
  "fcard A + fcard B = fcard (A |\<union>| B) + fcard (A |\<inter>| B)"
by transfer (rule card_Un_Int)

lemma fcard_funion_disjoint:
  "A |\<inter>| B = {||} \<Longrightarrow> fcard (A |\<union>| B) = fcard A + fcard B"
by transfer (rule card_Un_disjoint)

lemma fcard_funion_fsubset:
  "B |\<subseteq>| A \<Longrightarrow> fcard (A |-| B) = fcard A - fcard B"
by transfer (rule card_Diff_subset)

lemma diff_fcard_le_fcard_fminus:
  "fcard A - fcard B \<le> fcard(A |-| B)"
by transfer (rule diff_card_le_card_Diff)

lemma fcard_fminus1_less: "x |\<in>| A \<Longrightarrow> fcard (A |-| {|x|}) < fcard A"
by transfer (rule card_Diff1_less)

lemma fcard_fminus2_less:
  "x |\<in>| A \<Longrightarrow> y |\<in>| A \<Longrightarrow> fcard (A |-| {|x|} |-| {|y|}) < fcard A"
by transfer (rule card_Diff2_less)

lemma fcard_fminus1_le: "fcard (A |-| {|x|}) \<le> fcard A"
by transfer (rule card_Diff1_le)

lemma fcard_pfsubset: "A |\<subseteq>| B \<Longrightarrow> fcard A < fcard B \<Longrightarrow> A < B"
by transfer (rule card_psubset)

subsubsection {* @{text ffold} *}

(* FIXME: improve transferred to handle bounded meta quantification *)

context comp_fun_commute
begin
  lemmas ffold_empty[simp] = fold_empty[Transfer.transferred]

  lemma ffold_finsert [simp]:
    assumes "x |\<notin>| A"
    shows "ffold f z (finsert x A) = f x (ffold f z A)"
    using assms by (transfer fixing: f) (rule fold_insert)

  lemma ffold_fun_left_comm:
    "f x (ffold f z A) = ffold f (f x z) A"
    by (transfer fixing: f) (rule fold_fun_left_comm)

  lemma ffold_finsert2:
    "x |\<notin>| A \<Longrightarrow> ffold f z (finsert x A) = ffold f (f x z) A"
    by (transfer fixing: f) (rule fold_insert2)

  lemma ffold_rec:
    assumes "x |\<in>| A"
    shows "ffold f z A = f x (ffold f z (A |-| {|x|}))"
    using assms by (transfer fixing: f) (rule fold_rec)

  lemma ffold_finsert_fremove:
    "ffold f z (finsert x A) = f x (ffold f z (A |-| {|x|}))"
     by (transfer fixing: f) (rule fold_insert_remove)
end

lemma ffold_fimage:
  assumes "inj_on g (fset A)"
  shows "ffold f z (g |`| A) = ffold (f \<circ> g) z A"
using assms by transfer' (rule fold_image)

lemma ffold_cong:
  assumes "comp_fun_commute f" "comp_fun_commute g"
  "\<And>x. x |\<in>| A \<Longrightarrow> f x = g x"
    and "s = t" and "A = B"
  shows "ffold f s A = ffold g t B"
using assms by transfer (metis Finite_Set.fold_cong)

context comp_fun_idem
begin

  lemma ffold_finsert_idem:
    "ffold f z (finsert x A) = f x (ffold f z A)"
    by (transfer fixing: f) (rule fold_insert_idem)

  declare ffold_finsert [simp del] ffold_finsert_idem [simp]

  lemma ffold_finsert_idem2:
    "ffold f z (finsert x A) = ffold f (f x z) A"
    by (transfer fixing: f) (rule fold_insert_idem2)

end

subsection {* Choice in fsets *}

lemma fset_choice:
  assumes "\<forall>x. x |\<in>| A \<longrightarrow> (\<exists>y. P x y)"
  shows "\<exists>f. \<forall>x. x |\<in>| A \<longrightarrow> P x (f x)"
  using assms by transfer metis

subsection {* Induction and Cases rules for fsets *}

lemma fset_exhaust [case_names empty insert, cases type: fset]:
  assumes fempty_case: "S = {||} \<Longrightarrow> P"
  and     finsert_case: "\<And>x S'. S = finsert x S' \<Longrightarrow> P"
  shows "P"
  using assms by transfer blast

lemma fset_induct [case_names empty insert]:
  assumes fempty_case: "P {||}"
  and     finsert_case: "\<And>x S. P S \<Longrightarrow> P (finsert x S)"
  shows "P S"
proof -
  (* FIXME transfer and right_total vs. bi_total *)
  note Domainp_forall_transfer[transfer_rule]
  show ?thesis
  using assms by transfer (auto intro: finite_induct)
qed

lemma fset_induct_stronger [case_names empty insert, induct type: fset]:
  assumes empty_fset_case: "P {||}"
  and     insert_fset_case: "\<And>x S. \<lbrakk>x |\<notin>| S; P S\<rbrakk> \<Longrightarrow> P (finsert x S)"
  shows "P S"
proof -
  (* FIXME transfer and right_total vs. bi_total *)
  note Domainp_forall_transfer[transfer_rule]
  show ?thesis
  using assms by transfer (auto intro: finite_induct)
qed

lemma fset_card_induct:
  assumes empty_fset_case: "P {||}"
  and     card_fset_Suc_case: "\<And>S T. Suc (fcard S) = (fcard T) \<Longrightarrow> P S \<Longrightarrow> P T"
  shows "P S"
proof (induct S)
  case empty
  show "P {||}" by (rule empty_fset_case)
next
  case (insert x S)
  have h: "P S" by fact
  have "x |\<notin>| S" by fact
  then have "Suc (fcard S) = fcard (finsert x S)"
    by transfer auto
  then show "P (finsert x S)"
    using h card_fset_Suc_case by simp
qed

lemma fset_strong_cases:
  obtains "xs = {||}"
    | ys x where "x |\<notin>| ys" and "xs = finsert x ys"
by transfer blast

lemma fset_induct2:
  "P {||} {||} \<Longrightarrow>
  (\<And>x xs. x |\<notin>| xs \<Longrightarrow> P (finsert x xs) {||}) \<Longrightarrow>
  (\<And>y ys. y |\<notin>| ys \<Longrightarrow> P {||} (finsert y ys)) \<Longrightarrow>
  (\<And>x xs y ys. \<lbrakk>P xs ys; x |\<notin>| xs; y |\<notin>| ys\<rbrakk> \<Longrightarrow> P (finsert x xs) (finsert y ys)) \<Longrightarrow>
  P xsa ysa"
  apply (induct xsa arbitrary: ysa)
  apply (induct_tac x rule: fset_induct_stronger)
  apply simp_all
  apply (induct_tac xa rule: fset_induct_stronger)
  apply simp_all
  done

subsection {* Setup for Lifting/Transfer *}

subsubsection {* Relator and predicator properties *}

lift_definition rel_fset :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a fset \<Rightarrow> 'b fset \<Rightarrow> bool" is rel_set
parametric rel_set_transfer .

lemma rel_fset_alt_def: "rel_fset R = (\<lambda>A B. (\<forall>x.\<exists>y. x|\<in>|A \<longrightarrow> y|\<in>|B \<and> R x y)
  \<and> (\<forall>y. \<exists>x. y|\<in>|B \<longrightarrow> x|\<in>|A \<and> R x y))"
apply (rule ext)+
apply transfer'
apply (subst rel_set_def[unfolded fun_eq_iff])
by blast

lemma finite_rel_set:
  assumes fin: "finite X" "finite Z"
  assumes R_S: "rel_set (R OO S) X Z"
  shows "\<exists>Y. finite Y \<and> rel_set R X Y \<and> rel_set S Y Z"
proof -
  obtain f where f: "\<forall>x\<in>X. R x (f x) \<and> (\<exists>z\<in>Z. S (f x) z)"
  apply atomize_elim
  apply (subst bchoice_iff[symmetric])
  using R_S[unfolded rel_set_def OO_def] by blast

  obtain g where g: "\<forall>z\<in>Z. S (g z) z \<and> (\<exists>x\<in>X. R x (g z))"
  apply atomize_elim
  apply (subst bchoice_iff[symmetric])
  using R_S[unfolded rel_set_def OO_def] by blast

  let ?Y = "f ` X \<union> g ` Z"
  have "finite ?Y" by (simp add: fin)
  moreover have "rel_set R X ?Y"
    unfolding rel_set_def
    using f g by clarsimp blast
  moreover have "rel_set S ?Y Z"
    unfolding rel_set_def
    using f g by clarsimp blast
  ultimately show ?thesis by metis
qed

subsubsection {* Transfer rules for the Transfer package *}

text {* Unconditional transfer rules *}

context
begin

interpretation lifting_syntax .

lemmas fempty_transfer [transfer_rule] = empty_transfer[Transfer.transferred]

lemma finsert_transfer [transfer_rule]:
  "(A ===> rel_fset A ===> rel_fset A) finsert finsert"
  unfolding rel_fun_def rel_fset_alt_def by blast

lemma funion_transfer [transfer_rule]:
  "(rel_fset A ===> rel_fset A ===> rel_fset A) funion funion"
  unfolding rel_fun_def rel_fset_alt_def by blast

lemma ffUnion_transfer [transfer_rule]:
  "(rel_fset (rel_fset A) ===> rel_fset A) ffUnion ffUnion"
  unfolding rel_fun_def rel_fset_alt_def by transfer (simp, fast)

lemma fimage_transfer [transfer_rule]:
  "((A ===> B) ===> rel_fset A ===> rel_fset B) fimage fimage"
  unfolding rel_fun_def rel_fset_alt_def by simp blast

lemma fBall_transfer [transfer_rule]:
  "(rel_fset A ===> (A ===> op =) ===> op =) fBall fBall"
  unfolding rel_fset_alt_def rel_fun_def by blast

lemma fBex_transfer [transfer_rule]:
  "(rel_fset A ===> (A ===> op =) ===> op =) fBex fBex"
  unfolding rel_fset_alt_def rel_fun_def by blast

(* FIXME transfer doesn't work here *)
lemma fPow_transfer [transfer_rule]:
  "(rel_fset A ===> rel_fset (rel_fset A)) fPow fPow"
  unfolding rel_fun_def
  using Pow_transfer[unfolded rel_fun_def, rule_format, Transfer.transferred]
  by blast

lemma rel_fset_transfer [transfer_rule]:
  "((A ===> B ===> op =) ===> rel_fset A ===> rel_fset B ===> op =)
    rel_fset rel_fset"
  unfolding rel_fun_def
  using rel_set_transfer[unfolded rel_fun_def,rule_format, Transfer.transferred, where A = A and B = B]
  by simp

lemma bind_transfer [transfer_rule]:
  "(rel_fset A ===> (A ===> rel_fset B) ===> rel_fset B) fbind fbind"
  using assms unfolding rel_fun_def
  using bind_transfer[unfolded rel_fun_def, rule_format, Transfer.transferred] by blast

text {* Rules requiring bi-unique, bi-total or right-total relations *}

lemma fmember_transfer [transfer_rule]:
  assumes "bi_unique A"
  shows "(A ===> rel_fset A ===> op =) (op |\<in>|) (op |\<in>|)"
  using assms unfolding rel_fun_def rel_fset_alt_def bi_unique_def by metis

lemma finter_transfer [transfer_rule]:
  assumes "bi_unique A"
  shows "(rel_fset A ===> rel_fset A ===> rel_fset A) finter finter"
  using assms unfolding rel_fun_def
  using inter_transfer[unfolded rel_fun_def, rule_format, Transfer.transferred] by blast

lemma fminus_transfer [transfer_rule]:
  assumes "bi_unique A"
  shows "(rel_fset A ===> rel_fset A ===> rel_fset A) (op |-|) (op |-|)"
  using assms unfolding rel_fun_def
  using Diff_transfer[unfolded rel_fun_def, rule_format, Transfer.transferred] by blast

lemma fsubset_transfer [transfer_rule]:
  assumes "bi_unique A"
  shows "(rel_fset A ===> rel_fset A ===> op =) (op |\<subseteq>|) (op |\<subseteq>|)"
  using assms unfolding rel_fun_def
  using subset_transfer[unfolded rel_fun_def, rule_format, Transfer.transferred] by blast

lemma fSup_transfer [transfer_rule]:
  "bi_unique A \<Longrightarrow> (rel_set (rel_fset A) ===> rel_fset A) Sup Sup"
  using assms unfolding rel_fun_def
  apply clarify
  apply transfer'
  using Sup_fset_transfer[unfolded rel_fun_def] by blast

(* FIXME: add right_total_fInf_transfer *)

lemma fInf_transfer [transfer_rule]:
  assumes "bi_unique A" and "bi_total A"
  shows "(rel_set (rel_fset A) ===> rel_fset A) Inf Inf"
  using assms unfolding rel_fun_def
  apply clarify
  apply transfer'
  using Inf_fset_transfer[unfolded rel_fun_def] by blast

lemma ffilter_transfer [transfer_rule]:
  assumes "bi_unique A"
  shows "((A ===> op=) ===> rel_fset A ===> rel_fset A) ffilter ffilter"
  using assms unfolding rel_fun_def
  using Lifting_Set.filter_transfer[unfolded rel_fun_def, rule_format, Transfer.transferred] by blast

lemma card_transfer [transfer_rule]:
  "bi_unique A \<Longrightarrow> (rel_fset A ===> op =) fcard fcard"
  using assms unfolding rel_fun_def
  using card_transfer[unfolded rel_fun_def, rule_format, Transfer.transferred] by blast

end

lifting_update fset.lifting
lifting_forget fset.lifting

subsection {* BNF setup *}

context
includes fset.lifting
begin

lemma rel_fset_alt:
  "rel_fset R a b \<longleftrightarrow> (\<forall>t \<in> fset a. \<exists>u \<in> fset b. R t u) \<and> (\<forall>t \<in> fset b. \<exists>u \<in> fset a. R u t)"
by transfer (simp add: rel_set_def)

lemma fset_to_fset: "finite A \<Longrightarrow> fset (the_inv fset A) = A"
apply (rule f_the_inv_into_f[unfolded inj_on_def])
apply (simp add: fset_inject)
apply (rule range_eqI Abs_fset_inverse[symmetric] CollectI)+
.

lemma rel_fset_aux:
"(\<forall>t \<in> fset a. \<exists>u \<in> fset b. R t u) \<and> (\<forall>u \<in> fset b. \<exists>t \<in> fset a. R t u) \<longleftrightarrow>
 ((BNF_Def.Grp {a. fset a \<subseteq> {(a, b). R a b}} (fimage fst))\<inverse>\<inverse> OO
  BNF_Def.Grp {a. fset a \<subseteq> {(a, b). R a b}} (fimage snd)) a b" (is "?L = ?R")
proof
  assume ?L
  def R' \<equiv> "the_inv fset (Collect (split R) \<inter> (fset a \<times> fset b))" (is "the_inv fset ?L'")
  have "finite ?L'" by (intro finite_Int[OF disjI2] finite_cartesian_product) (transfer, simp)+
  hence *: "fset R' = ?L'" unfolding R'_def by (intro fset_to_fset)
  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 = fimage fst R'" using conjunct1[OF `?L`]
      by (transfer, auto simp add: image_def Int_def split: prod.splits)
    from * show "b = fimage snd R'" using conjunct2[OF `?L`]
      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
  apply (simp add: subset_eq Ball_def)
  apply (rule conjI)
  apply (transfer, clarsimp, metis snd_conv)
  by (transfer, clarsimp, metis fst_conv)
qed

bnf "'a fset"
  map: fimage
  sets: fset
  bd: natLeq
  wits: "{||}"
  rel: rel_fset
apply -
          apply transfer' apply simp
         apply transfer' apply force
        apply transfer apply force
       apply transfer' apply force
      apply (rule natLeq_card_order)
     apply (rule natLeq_cinfinite)
    apply transfer apply (metis ordLess_imp_ordLeq finite_iff_ordLess_natLeq)
   apply (fastforce simp: rel_fset_alt)
 apply (simp add: Grp_def relcompp.simps conversep.simps fun_eq_iff rel_fset_alt rel_fset_aux)
apply transfer apply simp
done

lemma rel_fset_fset: "rel_set \<chi> (fset A1) (fset A2) = rel_fset \<chi> A1 A2"
  by transfer (rule refl)

end

lemmas [simp] = fset.map_comp fset.map_id fset.set_map

subsection {* Size setup *}

context includes fset.lifting begin
lift_definition size_fset :: "('a \<Rightarrow> nat) \<Rightarrow> 'a fset \<Rightarrow> nat" is "\<lambda>f. setsum (Suc \<circ> f)" .
end

instantiation fset :: (type) size begin
definition size_fset where
  size_fset_overloaded_def: "size_fset = FSet.size_fset (\<lambda>_. 0)"
instance ..
end

lemmas size_fset_simps[simp] =
  size_fset_def[THEN meta_eq_to_obj_eq, THEN fun_cong, THEN fun_cong,
    unfolded map_fun_def comp_def id_apply]

lemmas size_fset_overloaded_simps[simp] =
  size_fset_simps[of "\<lambda>_. 0", unfolded add_0_left add_0_right,
    folded size_fset_overloaded_def]

lemma fset_size_o_map: "inj f \<Longrightarrow> size_fset g \<circ> fimage f = size_fset (g \<circ> f)"
  unfolding size_fset_def fimage_def
  by (auto simp: Abs_fset_inverse setsum.reindex_cong[OF subset_inj_on[OF _ top_greatest]])

setup {*
BNF_LFP_Size.register_size_global @{type_name fset} @{const_name size_fset}
  @{thms size_fset_simps size_fset_overloaded_simps} @{thms fset_size_o_map}
*}

subsection {* Advanced relator customization *}

(* Set vs. sum relators: *)

lemma rel_set_rel_sum[simp]:
"rel_set (rel_sum \<chi> \<phi>) A1 A2 \<longleftrightarrow>
 rel_set \<chi> (Inl -` A1) (Inl -` A2) \<and> rel_set \<phi> (Inr -` A1) (Inr -` A2)"
(is "?L \<longleftrightarrow> ?Rl \<and> ?Rr")
proof safe
  assume L: "?L"
  show ?Rl unfolding rel_set_def Bex_def vimage_eq proof safe
    fix l1 assume "Inl l1 \<in> A1"
    then obtain a2 where a2: "a2 \<in> A2" and "rel_sum \<chi> \<phi> (Inl l1) a2"
    using L unfolding rel_set_def by auto
    then obtain l2 where "a2 = Inl l2 \<and> \<chi> l1 l2" by (cases a2, auto)
    thus "\<exists> l2. Inl l2 \<in> A2 \<and> \<chi> l1 l2" using a2 by auto
  next
    fix l2 assume "Inl l2 \<in> A2"
    then obtain a1 where a1: "a1 \<in> A1" and "rel_sum \<chi> \<phi> a1 (Inl l2)"
    using L unfolding rel_set_def by auto
    then obtain l1 where "a1 = Inl l1 \<and> \<chi> l1 l2" by (cases a1, auto)
    thus "\<exists> l1. Inl l1 \<in> A1 \<and> \<chi> l1 l2" using a1 by auto
  qed
  show ?Rr unfolding rel_set_def Bex_def vimage_eq proof safe
    fix r1 assume "Inr r1 \<in> A1"
    then obtain a2 where a2: "a2 \<in> A2" and "rel_sum \<chi> \<phi> (Inr r1) a2"
    using L unfolding rel_set_def by auto
    then obtain r2 where "a2 = Inr r2 \<and> \<phi> r1 r2" by (cases a2, auto)
    thus "\<exists> r2. Inr r2 \<in> A2 \<and> \<phi> r1 r2" using a2 by auto
  next
    fix r2 assume "Inr r2 \<in> A2"
    then obtain a1 where a1: "a1 \<in> A1" and "rel_sum \<chi> \<phi> a1 (Inr r2)"
    using L unfolding rel_set_def by auto
    then obtain r1 where "a1 = Inr r1 \<and> \<phi> r1 r2" by (cases a1, auto)
    thus "\<exists> r1. Inr r1 \<in> A1 \<and> \<phi> r1 r2" using a1 by auto
  qed
next
  assume Rl: "?Rl" and Rr: "?Rr"
  show ?L unfolding rel_set_def Bex_def vimage_eq proof safe
    fix a1 assume a1: "a1 \<in> A1"
    show "\<exists> a2. a2 \<in> A2 \<and> rel_sum \<chi> \<phi> a1 a2"
    proof(cases a1)
      case (Inl l1) then obtain l2 where "Inl l2 \<in> A2 \<and> \<chi> l1 l2"
      using Rl a1 unfolding rel_set_def by blast
      thus ?thesis unfolding Inl by auto
    next
      case (Inr r1) then obtain r2 where "Inr r2 \<in> A2 \<and> \<phi> r1 r2"
      using Rr a1 unfolding rel_set_def by blast
      thus ?thesis unfolding Inr by auto
    qed
  next
    fix a2 assume a2: "a2 \<in> A2"
    show "\<exists> a1. a1 \<in> A1 \<and> rel_sum \<chi> \<phi> a1 a2"
    proof(cases a2)
      case (Inl l2) then obtain l1 where "Inl l1 \<in> A1 \<and> \<chi> l1 l2"
      using Rl a2 unfolding rel_set_def by blast
      thus ?thesis unfolding Inl by auto
    next
      case (Inr r2) then obtain r1 where "Inr r1 \<in> A1 \<and> \<phi> r1 r2"
      using Rr a2 unfolding rel_set_def by blast
      thus ?thesis unfolding Inr by auto
    qed
  qed
qed

end