section "Binomial Heaps"

theory BinomialHeap
  imports Main "HOL-Library.Multiset" "Eval_Base.Eval_Base"
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'"
  apply2(induct q)
  apply(simp)
  apply(simp add: union_ac)
done

lemma qtmset_rev[simp]: "queue_to_multiset (rev q) = queue_to_multiset q"
  apply2(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
proof2(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)"
apply2(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'"
apply2(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)"
apply2(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'])"
proof2 (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
  proof2 (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"
proof2 (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"
proof2 (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
  apply2 (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
  apply2 (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))"
proof2 (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)"
  apply2 (induct bq) by 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"
proof2 (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)"
proof2 (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)
  apply2(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> [])"
  apply2(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)"
  apply2(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')"
proof2 (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))"
  apply2(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))"
proof2 (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'"
apply2(induct q q' rule: meld.induct)
  by(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)"
proof2 (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"
  apply2 (induct bq) by (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))"
  apply2 (induct xs rule: getMinTree.induct) by simp_all

lemma getMinTree_min_tree:
  "t \<in> set bq  \<Longrightarrow> prio (getMinTree bq) \<le> prio t"
  apply2(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)))"
  proof2 (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"
proof2(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"
proof2 (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"
      apply2 (induct bq rule: getMinTree.induct) by auto
    from ne False have "prio t \<noteq> prio (getMinTree bq)"
      apply2 (induct bq rule: getMinTree.induct) by 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
  proof2 (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))"
  proof2 (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'"
  apply2(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)"
proof2 (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 apply2 (induct list) by 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


(*<*)
theory GoedelProof_P1
imports IHOML
begin
nitpick_params[user_axioms=true, show_all, expect=genuine, format = 3,  atoms e = a b c d]
sledgehammer_params[verbose=true]
(*>*)

section \<open>G\"odel's Argument, Formally\<close>

text\<open>
 "G\"odel's particular version of the argument is a direct descendent of that of Leibniz, which in turn derives
  from one of Descartes. These arguments all have a two-part structure: prove God's existence is necessary,
  if possible; and prove God's existence is possible." @{cite "Fitting"}, p. 138. \<close>

subsection \<open>Part I - God's Existence is Possible\<close>

text\<open>  We separate G\"odel's Argument as presented in Fitting's textbook (ch. 11) in two parts. For the first one, while Leibniz provides
  some kind of proof for the compatibility of all perfections, G\"odel goes on to prove an analogous result:
 \emph{(T1) Every positive property is possibly instantiated}, which together with \emph{(T2) God is a positive property}
  directly implies the conclusion. In order to prove \emph{T1}, G\"odel assumes \emph{A2: Any property entailed by a positive property is positive}. \<close>
text\<open>  We are currently contemplating a follow-up analysis of the philosophical implications of these axioms,
 which encompasses some criticism of the notion of \emph{property entailment} used by G\"odel throughout the argument. \<close>

subsubsection \<open>General Definitions\<close>

abbreviation existencePredicate::"\<up>\<langle>\<zero>\<rangle>" ("E!")
  where "E! x  \<equiv> \<lambda>w. (\<^bold>\<exists>\<^sup>Ey. y\<^bold>\<approx>x) w" \<comment> \<open>existence predicate in object language\<close>

lemma "E! x w \<longleftrightarrow> existsAt x w"
  by simp \<comment> \<open>safety check: @{text "E!"} correctly matches its meta-logical counterpart\<close>

consts positiveProperty::"\<up>\<langle>\<up>\<langle>\<zero>\<rangle>\<rangle>" ("\<P>") \<comment> \<open>positiveness/perfection\<close>

text\<open>  Definitions of God (later shown to be equivalent under axiom \emph{A1b}):  \<close>
abbreviation God::"\<up>\<langle>\<zero>\<rangle>" ("G") where "G \<equiv> (\<lambda>x. \<^bold>\<forall>Y. \<P> Y \<^bold>\<rightarrow> Y x)"
abbreviation God_star::"\<up>\<langle>\<zero>\<rangle>" ("G*") where "G* \<equiv> (\<lambda>x. \<^bold>\<forall>Y. \<P> Y \<^bold>\<leftrightarrow> Y x)"

text\<open>  Definitions needed to formalise \emph{A3}:  \<close>
abbreviation appliesToPositiveProps::"\<up>\<langle>\<up>\<langle>\<up>\<langle>\<zero>\<rangle>\<rangle>\<rangle>" ("pos") where
  "pos Z \<equiv>  \<^bold>\<forall>X. Z X \<^bold>\<rightarrow> \<P> X"
abbreviation intersectionOf::"\<up>\<langle>\<up>\<langle>\<zero>\<rangle>,\<up>\<langle>\<up>\<langle>\<zero>\<rangle>\<rangle>\<rangle>" ("intersec") where
  "intersec X Z \<equiv>  \<^bold>\<box>(\<^bold>\<forall>x.(X x \<^bold>\<leftrightarrow> (\<^bold>\<forall>Y. (Z Y) \<^bold>\<rightarrow> (Y x))))" \<comment> \<open>quantifier is possibilist\<close>
abbreviation Entailment::"\<up>\<langle>\<up>\<langle>\<zero>\<rangle>,\<up>\<langle>\<zero>\<rangle>\<rangle>" (infix "\<Rrightarrow>" 60) where
  "X \<Rrightarrow> Y \<equiv>  \<^bold>\<box>(\<^bold>\<forall>\<^sup>Ez. X z \<^bold>\<rightarrow> Y z)"
text\<open> \bigbreak \<close>

subsubsection \<open>Axioms\<close>

axiomatization where
  A1a:"\<lfloor>\<^bold>\<forall>X. \<P> (\<^bold>\<rightharpoondown>X) \<^bold>\<rightarrow> \<^bold>\<not>(\<P> X) \<rfloor>" and      \<comment> \<open>axiom 11.3A\<close>
  A1b:"\<lfloor>\<^bold>\<forall>X. \<^bold>\<not>(\<P> X) \<^bold>\<rightarrow> \<P> (\<^bold>\<rightharpoondown>X)\<rfloor>" and       \<comment> \<open>axiom 11.3B\<close>
  A2: "\<lfloor>\<^bold>\<forall>X Y. (\<P> X \<^bold>\<and> (X \<Rrightarrow> Y)) \<^bold>\<rightarrow> \<P> Y\<rfloor>" and   \<comment> \<open>axiom 11.5\<close>
  A3: "\<lfloor>\<^bold>\<forall>Z X. (pos Z \<^bold>\<and> intersec X Z) \<^bold>\<rightarrow> \<P> X\<rfloor>" \<comment> \<open>axiom 11.10\<close>

lemma True nitpick[satisfy] oops       \<comment> \<open>model found: axioms are consistent\<close>

lemma "\<lfloor>D\<rfloor>"  using A1a A1b A2 by blast \<comment> \<open>axioms already imply \emph{D} axiom\<close>
lemma "\<lfloor>D\<rfloor>" using A1a A3 by metis

subsubsection \<open>Theorems\<close>

lemma "\<lfloor>\<^bold>\<exists>X. \<P> X\<rfloor>" using A1b by auto
lemma "\<lfloor>\<^bold>\<exists>X. \<P> X \<^bold>\<and>  \<^bold>\<diamond>\<^bold>\<exists>\<^sup>E X\<rfloor>" using A1a A1b A2 by metis

text\<open>  Being self-identical is a positive property:  \<close>
lemma "\<lfloor>(\<^bold>\<exists>X. \<P> X \<^bold>\<and>  \<^bold>\<diamond>\<^bold>\<exists>\<^sup>E X) \<^bold>\<rightarrow> \<P> (\<lambda>x w. x = x)\<rfloor>" using A2 by fastforce

text\<open>  Proposition 11.6  \<close>
lemma "\<lfloor>(\<^bold>\<exists>X. \<P> X) \<^bold>\<rightarrow> \<P> (\<lambda>x w. x = x)\<rfloor>" using A2 by fastforce

lemma "\<lfloor>\<P> (\<lambda>x w. x = x)\<rfloor>" using A1b A2  by blast
lemma "\<lfloor>\<P> (\<lambda>x w. x = x)\<rfloor>" using A3 by metis

text\<open>  Being non-self-identical is a negative property: \<close>
lemma "\<lfloor>(\<^bold>\<exists>X. \<P> X  \<^bold>\<and> \<^bold>\<diamond>\<^bold>\<exists>\<^sup>E X) \<^bold>\<rightarrow>  \<P> (\<^bold>\<rightharpoondown> (\<lambda>x w. \<not>x = x))\<rfloor>"
  using A2 by fastforce

lemma "\<lfloor>(\<^bold>\<exists>X. \<P> X) \<^bold>\<rightarrow>  \<P> (\<^bold>\<rightharpoondown> (\<lambda>x w. \<not>x = x))\<rfloor>" using A2 by fastforce
lemma "\<lfloor>(\<^bold>\<exists>X. \<P> X) \<^bold>\<rightarrow>  \<P> (\<^bold>\<rightharpoondown> (\<lambda>x w. \<not>x = x))\<rfloor>" using A3 by metis

text\<open>  Proposition 11.7  \<close>
lemma "\<lfloor>(\<^bold>\<exists>X. \<P> X) \<^bold>\<rightarrow> \<^bold>\<not>\<P> ((\<lambda>x w. \<not>x = x))\<rfloor>"  using A1a A2 by blast
lemma "\<lfloor>\<^bold>\<not>\<P> (\<lambda>x w. \<not>x = x)\<rfloor>"  using A1a A2 by blast

text\<open>  Proposition 11.8 (Informal Proposition 1) - Positive properties are possibly instantiated:  \<close>
theorem T1: "\<lfloor>\<^bold>\<forall>X. \<P> X \<^bold>\<rightarrow> \<^bold>\<diamond>\<^bold>\<exists>\<^sup>E X\<rfloor>" using A1a A2 by blast

text\<open>  Proposition 11.14 - Both defs (\emph{God/God*}) are equivalent. For improved performance we may prefer to use one or the other:  \<close>
lemma GodDefsAreEquivalent: "\<lfloor>\<^bold>\<forall>x. G x \<^bold>\<leftrightarrow> G* x\<rfloor>" using A1b by force

text\<open>  Proposition 11.15 - Possibilist existence of \emph{God} directly implies \emph{A1b}:  \<close>
lemma "\<lfloor>\<^bold>\<exists> G* \<^bold>\<rightarrow> (\<^bold>\<forall>X. \<^bold>\<not>(\<P> X) \<^bold>\<rightarrow> \<P> (\<^bold>\<rightharpoondown>X))\<rfloor>" by meson

text\<open>  Proposition 11.16 - \emph{A3} implies \emph{P(G)} (local consequence):   \<close>
lemma A3implT2_local: "\<lfloor>(\<^bold>\<forall>Z X. (pos Z \<^bold>\<and> intersec X Z) \<^bold>\<rightarrow> \<P> X) \<^bold>\<rightarrow> \<P> G\<rfloor>"
proof -
  {
  fix w
  have 1: "pos \<P> w" by simp
  have 2: "intersec G \<P> w" by simp
  {
    assume "(\<^bold>\<forall>Z X. (pos Z \<^bold>\<and> intersec X Z) \<^bold>\<rightarrow> \<P> X) w"
    hence "(\<^bold>\<forall>X. ((pos \<P>) \<^bold>\<and> (intersec X \<P>)) \<^bold>\<rightarrow> \<P> X) w"  by (rule allE)
    hence "(((pos \<P>) \<^bold>\<and> (intersec G \<P>)) \<^bold>\<rightarrow> \<P> G) w" by (rule allE)
    hence 3: "((pos \<P> \<^bold>\<and> intersec G \<P>) w) \<longrightarrow> \<P> G w" by simp
    hence 4: "((pos \<P>) \<^bold>\<and> (intersec G \<P>)) w" using 1 2 by simp
    from 3 4 have "\<P> G w" by (rule mp)
  }
  hence "(\<^bold>\<forall>Z X. (pos Z \<^bold>\<and> intersec X Z) \<^bold>\<rightarrow> \<P> X) w  \<longrightarrow> \<P> G w" by (rule impI)
  }
  thus ?thesis by (rule allI)
qed

text\<open>  \emph{A3} implies \<open>P(G)\<close> (as global consequence): \<close>
lemma A3implT2_global: "\<lfloor>\<^bold>\<forall>Z X. (pos Z \<^bold>\<and> intersec X Z) \<^bold>\<rightarrow> \<P> X\<rfloor> \<longrightarrow> \<lfloor>\<P> G\<rfloor>"
  using A3implT2_local by (rule localImpGlobalCons)

text\<open>  Being Godlike is a positive property. Note that this theorem can be axiomatized directly,
as noted by Dana Scott (see @{cite "Fitting"}, p. 152). We will do so for the second part. \<close>
theorem T2: "\<lfloor>\<P> G\<rfloor>" using A3implT2_global A3 by simp

text\<open>  Theorem 11.17 (Informal Proposition 3) - Possibly God exists: \<close>
theorem T3: "\<lfloor>\<^bold>\<diamond>\<^bold>\<exists>\<^sup>E G\<rfloor>"  using T1 T2 by simp

(*<*)
end
(*>*)


section "Arithmetic and Boolean Expressions"

theory AExp imports Main begin

subsection "Arithmetic Expressions"

type_synonym vname = string
type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

text_raw{*\snip{AExpaexpdef}{2}{1}{% *}
datatype aexp = N int | V vname | Plus aexp aexp
text_raw{*}%endsnip*}

text_raw{*\snip{AExpavaldef}{1}{2}{% *}
fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n) s = n" |
"aval (V x) s = s x" |
"aval (Plus a\<^sub>1 a\<^sub>2) s = aval a\<^sub>1 s + aval a\<^sub>2 s"
text_raw{*}%endsnip*}

value "aval (Plus (V ''x'') (N 5)) (\<lambda>x. if x = ''x'' then 7 else 0)"

text {* The same state more concisely: *}
value "aval (Plus (V ''x'') (N 5)) ((\<lambda>x. 0) (''x'':= 7))"

text {* A little syntax magic to write larger states compactly: *}

definition null_state ("<>") where
  "null_state \<equiv> \<lambda>x. 0"
syntax
  "_State" :: "updbinds => 'a" ("<_>")
translations
  "_State ms" == "_Update <> ms"
  "_State (_updbinds b bs)" <= "_Update (_State b) bs"

text {* \noindent
  We can now write a series of updates to the function @{text "\<lambda>x. 0"} compactly:
*}
lemma "<a := 1, b := 2> = (<> (a := 1)) (b := (2::int))"
  by (rule refl)

value "aval (Plus (V ''x'') (N 5)) <''x'' := 7>"

text {* In  the @{term[source] "<a := b>"} syntax, variables that are not mentioned are 0 by default:
*}
value "aval (Plus (V ''x'') (N 5)) <''y'' := 7>"

text{* Note that this @{text"<\<dots>>"} syntax works for any function space
@{text"\<tau>\<^sub>1 \<Rightarrow> \<tau>\<^sub>2"} where @{text "\<tau>\<^sub>2"} has a @{text 0}. *}

subsection "Constant Folding"

text{* Evaluate constant subsexpressions: *}

text_raw{*\snip{AExpasimpconstdef}{0}{2}{% *}
fun asimp_const :: "aexp \<Rightarrow> aexp" where
"asimp_const (N n) = N n" |
"asimp_const (V x) = V x" |
"asimp_const (Plus a\<^sub>1 a\<^sub>2) =
  (case (asimp_const a\<^sub>1, asimp_const a\<^sub>2) of
    (N n\<^sub>1, N n\<^sub>2) \<Rightarrow> N(n\<^sub>1+n\<^sub>2) |
    (b\<^sub>1,b\<^sub>2) \<Rightarrow> Plus b\<^sub>1 b\<^sub>2)"
text_raw{*}%endsnip*}

theorem aval_asimp_const:
  "aval (asimp_const a) s = aval a s"
  apply(induction a)
apply (auto split: aexp.split)
done

text{* Now we also eliminate all occurrences 0 in additions. The standard
method: optimized versions of the constructors: *}

text_raw{*\snip{AExpplusdef}{0}{2}{% *}
fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"plus (N i\<^sub>1) (N i\<^sub>2) = N(i\<^sub>1+i\<^sub>2)" |
"plus (N i) a = (if i=0 then a else Plus (N i) a)" |
"plus a (N i) = (if i=0 then a else Plus a (N i))" |
"plus a\<^sub>1 a\<^sub>2 = Plus a\<^sub>1 a\<^sub>2"
text_raw{*}%endsnip*}

lemma aval_plus[simp]:
  "aval (plus a1 a2) s = aval a1 s + aval a2 s"
apply(induction a1 a2 rule: plus.induct)
apply simp_all (* just for a change from auto *)
done

text_raw{*\snip{AExpasimpdef}{2}{0}{% *}
fun asimp :: "aexp \<Rightarrow> aexp" where
"asimp (N n) = N n" |
"asimp (V x) = V x" |
"asimp (Plus a\<^sub>1 a\<^sub>2) = plus (asimp a\<^sub>1) (asimp a\<^sub>2)"
text_raw{*}%endsnip*}

text{* Note that in @{const asimp_const} the optimized constructor was
inlined. Making it a separate function @{const plus} improves modularity of
the code and the proofs. *}

value "asimp (Plus (Plus (N 0) (N 0)) (Plus (V ''x'') (N 0)))"

theorem aval_asimp[simp]:
  "aval (asimp a) s = aval a s"
apply(induction a)
apply simp_all
done

(* Exercise 3.1 *)
fun optimal :: "aexp \<Rightarrow> bool" where
"optimal (N i) = True" |
"optimal (V v) = True" |
"optimal (Plus (N i) (N j)) = False" |
"optimal (Plus a1 a2) = ((optimal a1) \<or> (optimal a2))"

value "optimal (N 0)"
value "optimal (Plus (N 0) (N 1))"

lemma "optimal (asimp_const a)"
apply(induction a rule: optimal.induct)
apply(auto split: aexp.split)
done

(* Exercise 3.2 *)

(* Exercise 3.2 *)
fun sum_asimp :: "(int * aexp) \<Rightarrow> aexp \<Rightarrow> (int * aexp)" where
"sum_asimp (m, vs) (N n) = (n + m, vs)" |
"sum_asimp (m, vs) (V x) = (m, plus (V x) vs)" |
"sum_asimp (m, vs) (Plus a1 a2) = sum_asimp (sum_asimp (m, vs) a1) a2"

fun plus_pair :: "(int * aexp) \<Rightarrow> (int * aexp) \<Rightarrow> (int * aexp)" where
"plus_pair (n1, vs1) (n2, vs2) = (n1 + n2, Plus vs1 vs2)"

fun aval_pair :: "(int * aexp) \<Rightarrow> state \<Rightarrow> int" where
"aval_pair (n, a) s = n + aval a s"

lemma [simp]:"
aval_pair (sum_asimp (sum_asimp (0, N 0) a1) a2) s =
aval_pair (sum_asimp ((aval_pair (sum_asimp (0, N 0) a1) s), N 0) a2) s"
apply(induction a1)
apply(simp)
apply(simp)
apply(induction a2)
apply(simp)
apply(induction x)
apply(simp)
apply(simp)

oops

lemma [simp]:"aval (sum_asimp (sum_asimp (m, vs) a1) a2) s =
aval (sum_asimp (0, N 0) a1) s + aval (sum_asimp (0, N 0) a2) s"
  oops

lemma [simp]:"sum_asimp (m, N 0) a =
  (case (sum_asimp (0, N 0) a) of
    (n, y) \<Rightarrow> (n + m, y))"
apply(induction a)
apply(auto split: aexp.split)
  oops

lemma [simp]:"
aval (case sum_asimp (m, vs) a of (n, y) \<Rightarrow> plus (N n) y) s = n"
oops
lemma [simp]:"
sum_asimp (sum_asimp (0, N 0) a1) a2 = of (n, y) \<Rightarrow> plus (N n) y) s"

(* 1st target. the simplest one. cannot be proved *)
lemma [simp]:"
aval (case sum_asimp (m, N 0) a of (n, y) \<Rightarrow> plus (N n) y) s =
  m
+ aval (case sum_asimp (0, N 0) a of (n, y) \<Rightarrow> plus (N n) y) s"
apply(induction a)
apply(auto)
  oops

lemma [simp]:"
aval (case sum_asimp (m, vs) a of (n, y) \<Rightarrow> plus (N n) y) s =
  aval (plus (N m) vs) s
+ aval (case sum_asimp (0, N 0) a of (n, y) \<Rightarrow> plus (N n) y) s"
apply(induction a)
apply(auto)
apply(induction vs)
apply(auto split: aexp.split)
  oops

lemma [simp]:"aval (case sum_asimp (x, N 0) a of (n, y) \<Rightarrow> AExp.plus (N n) y) s =
         x + aval (case sum_asimp (0, N 0) a of (n, y) \<Rightarrow> AExp.plus (N n) y) s"
apply(induction a)
apply(auto split: aexp.split)
apply(auto)
oops

(* the most important lemma *)
lemma [simp]:"
aval (case sum_asimp (sum_asimp (0, N 0) a1) a2 of (n, y) \<Rightarrow> plus (N n) y) s =
  aval (case sum_asimp (0, N 0) a1 of (n, y) \<Rightarrow> plus (N n) y) s
+ aval (case sum_asimp (0, N 0) a2 of (n, y) \<Rightarrow> plus (N n) y) s"
  apply(induction a1)
  apply(simp)
apply(auto split: aexp.split)
apply(induction a2)
apply(auto split: aexp.split)
oops

fun full_asimp :: "aexp \<Rightarrow> aexp" where
"full_asimp a =
  (case sum_asimp (0, N 0) a of
    (n, vs) \<Rightarrow> plus (N n) vs)"

lemma [simp]:"aval (full_asimp a) s  = aval a s"
apply(induction a)
apply(auto split: aexp.split)

end


(*  Title:      HOL/MicroJava/BV/Semilat.thy
    Author:     Tobias Nipkow
    Copyright   2000 TUM

Semilattices.
*)

chapter \<open> Bytecode Verifier \label{cha:bv} \<close>

section \<open> Semilattices \<close>

theory Semilat
imports Main "HOL-Library.While_Combinator"
begin

type_synonym 'a ord    = "'a \<Rightarrow> 'a \<Rightarrow> bool"
type_synonym 'a binop  = "'a \<Rightarrow> 'a \<Rightarrow> 'a"
type_synonym 'a sl     = "'a set \<times> 'a ord \<times> 'a binop"

definition lesub :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool"
  where "lesub x r y \<longleftrightarrow> r x y"

definition lesssub :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool"
  where "lesssub x r y \<longleftrightarrow> lesub x r y \<and> x \<noteq> y"

definition plussub :: "'a \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b \<Rightarrow> 'c"
  where "plussub x f y = f x y"

notation (ASCII)
  "lesub"  ("(_ /<='__ _)" [50, 1000, 51] 50) and
  "lesssub"  ("(_ /<'__ _)" [50, 1000, 51] 50) and
  "plussub"  ("(_ /+'__ _)" [65, 1000, 66] 65)

notation
  "lesub"  ("(_ /\<sqsubseteq>\<^bsub>_\<^esub> _)" [50, 0, 51] 50) and
  "lesssub"  ("(_ /\<sqsubset>\<^bsub>_\<^esub> _)" [50, 0, 51] 50) and
  "plussub"  ("(_ /\<squnion>\<^bsub>_\<^esub> _)" [65, 0, 66] 65)

(* allow \<sub> instead of \<bsub>..\<esub> *)
abbreviation (input)
  lesub1 :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool" ("(_ /\<sqsubseteq>\<^sub>_ _)" [50, 1000, 51] 50)
  where "x \<sqsubseteq>\<^sub>r y == x \<sqsubseteq>\<^bsub>r\<^esub> y"

abbreviation (input)
  lesssub1 :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool" ("(_ /\<sqsubset>\<^sub>_ _)" [50, 1000, 51] 50)
  where "x \<sqsubset>\<^sub>r y == x \<sqsubset>\<^bsub>r\<^esub> y"

abbreviation (input)
  plussub1 :: "'a \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b \<Rightarrow> 'c" ("(_ /\<squnion>\<^sub>_ _)" [65, 1000, 66] 65)
  where "x \<squnion>\<^sub>f y == x \<squnion>\<^bsub>f\<^esub> y"

definition ord :: "('a \<times> 'a) set \<Rightarrow> 'a ord"
where
  "ord r = (\<lambda>x y. (x,y) \<in> r)"

definition order :: "'a ord \<Rightarrow> bool"
where
  "order r \<longleftrightarrow> (\<forall>x. x \<sqsubseteq>\<^sub>r x) \<and> (\<forall>x y. x \<sqsubseteq>\<^sub>r y \<and> y \<sqsubseteq>\<^sub>r x \<longrightarrow> x=y) \<and> (\<forall>x y z. x \<sqsubseteq>\<^sub>r y \<and> y \<sqsubseteq>\<^sub>r z \<longrightarrow> x \<sqsubseteq>\<^sub>r z)"

definition top :: "'a ord \<Rightarrow> 'a \<Rightarrow> bool"
where
  "top r T \<longleftrightarrow> (\<forall>x. x \<sqsubseteq>\<^sub>r T)"

definition acc :: "'a ord \<Rightarrow> bool"
where
  "acc r \<longleftrightarrow> wf {(y,x). x \<sqsubset>\<^sub>r y}"

definition closed :: "'a set \<Rightarrow> 'a binop \<Rightarrow> bool"
where
  "closed A f \<longleftrightarrow> (\<forall>x\<in>A. \<forall>y\<in>A. x \<squnion>\<^sub>f y \<in> A)"

definition semilat :: "'a sl \<Rightarrow> bool"
where
  "semilat = (\<lambda>(A,r,f). order r \<and> closed A f \<and>
                       (\<forall>x\<in>A. \<forall>y\<in>A. x \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y) \<and>
                       (\<forall>x\<in>A. \<forall>y\<in>A. y \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y) \<and>
                       (\<forall>x\<in>A. \<forall>y\<in>A. \<forall>z\<in>A. x \<sqsubseteq>\<^sub>r z \<and> y \<sqsubseteq>\<^sub>r z \<longrightarrow> x \<squnion>\<^sub>f y \<sqsubseteq>\<^sub>r z))"

definition is_ub :: "('a \<times> 'a) set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
where
  "is_ub r x y u \<longleftrightarrow> (x,u)\<in>r \<and> (y,u)\<in>r"

definition is_lub :: "('a \<times> 'a) set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
where
  "is_lub r x y u \<longleftrightarrow> is_ub r x y u \<and> (\<forall>z. is_ub r x y z \<longrightarrow> (u,z)\<in>r)"

definition some_lub :: "('a \<times> 'a) set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"
where
  "some_lub r x y = (SOME z. is_lub r x y z)"

locale Semilat =
  fixes A :: "'a set"
  fixes r :: "'a ord"
  fixes f :: "'a binop"
  assumes semilat: "semilat (A, r, f)"

lemma order_refl [simp, intro]: "order r \<Longrightarrow> x \<sqsubseteq>\<^sub>r x"
  (*<*) by (unfold order_def) (simp (no_asm_simp)) (*>*)

lemma order_antisym: "\<lbrakk> order r; x \<sqsubseteq>\<^sub>r y; y \<sqsubseteq>\<^sub>r x \<rbrakk> \<Longrightarrow> x = y"
  (*<*) by (unfold order_def) (simp (no_asm_simp)) (*>*)

lemma order_trans: "\<lbrakk> order r; x \<sqsubseteq>\<^sub>r y; y \<sqsubseteq>\<^sub>r z \<rbrakk> \<Longrightarrow> x \<sqsubseteq>\<^sub>r z"
  (*<*) by (unfold order_def) blast (*>*)

lemma order_less_irrefl [intro, simp]: "order r \<Longrightarrow> \<not> x \<sqsubset>\<^sub>r x"
  (*<*) by (unfold order_def lesssub_def) blast (*>*)

lemma order_less_trans: "\<lbrakk> order r; x \<sqsubset>\<^sub>r y; y \<sqsubset>\<^sub>r z \<rbrakk> \<Longrightarrow> x \<sqsubset>\<^sub>r z"
  (*<*) by (unfold order_def lesssub_def) blast (*>*)

lemma topD [simp, intro]: "top r T \<Longrightarrow> x \<sqsubseteq>\<^sub>r T"
  (*<*) by (simp add: top_def) (*>*)

lemma top_le_conv [simp]: "\<lbrakk> order r; top r T \<rbrakk> \<Longrightarrow> (T \<sqsubseteq>\<^sub>r x) = (x = T)"
  (*<*) by (blast intro: order_antisym) (*>*)

lemma semilat_Def:
"semilat(A,r,f) \<longleftrightarrow> order r \<and> closed A f \<and>
                 (\<forall>x\<in>A. \<forall>y\<in>A. x \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y) \<and>
                 (\<forall>x\<in>A. \<forall>y\<in>A. y \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y) \<and>
                 (\<forall>x\<in>A. \<forall>y\<in>A. \<forall>z\<in>A. x \<sqsubseteq>\<^sub>r z \<and> y \<sqsubseteq>\<^sub>r z \<longrightarrow> x \<squnion>\<^sub>f y \<sqsubseteq>\<^sub>r z)"
  (*<*) by (unfold semilat_def) clarsimp (*>*)

lemma (in Semilat) orderI [simp, intro]: "order r"
  (*<*) using semilat by (simp add: semilat_Def) (*>*)

lemma (in Semilat) closedI [simp, intro]: "closed A f"
  (*<*) using semilat by (simp add: semilat_Def) (*>*)

lemma closedD: "\<lbrakk> closed A f; x\<in>A; y\<in>A \<rbrakk> \<Longrightarrow> x \<squnion>\<^sub>f y \<in> A"
  (*<*) by (unfold closed_def) blast (*>*)

lemma closed_UNIV [simp]: "closed UNIV f"
  (*<*) by (simp add: closed_def) (*>*)

lemma (in Semilat) closed_f [simp, intro]: "\<lbrakk>x \<in> A; y \<in> A\<rbrakk>  \<Longrightarrow> x \<squnion>\<^sub>f y \<in> A"
  (*<*) by (simp add: closedD [OF closedI]) (*>*)

lemma (in Semilat) refl_r [intro, simp]: "x \<sqsubseteq>\<^sub>r x" by simp

lemma (in Semilat) antisym_r [intro?]: "\<lbrakk> x \<sqsubseteq>\<^sub>r y; y \<sqsubseteq>\<^sub>r x \<rbrakk> \<Longrightarrow> x = y"
  (*<*) by (rule order_antisym) auto (*>*)

lemma (in Semilat) trans_r [trans, intro?]: "\<lbrakk>x \<sqsubseteq>\<^sub>r y; y \<sqsubseteq>\<^sub>r z\<rbrakk> \<Longrightarrow> x \<sqsubseteq>\<^sub>r z"
  (*<*) by (auto intro: order_trans) (*>*)

lemma (in Semilat) ub1 [simp, intro?]: "\<lbrakk> x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> x \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y"
  (*<*) by (insert semilat) (unfold semilat_Def, simp) (*>*)

lemma (in Semilat) ub2 [simp, intro?]: "\<lbrakk> x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> y \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y"
  (*<*) by (insert semilat) (unfold semilat_Def, simp) (*>*)

lemma (in Semilat) lub [simp, intro?]:
  "\<lbrakk> x \<sqsubseteq>\<^sub>r z; y \<sqsubseteq>\<^sub>r z; x \<in> A; y \<in> A; z \<in> A \<rbrakk> \<Longrightarrow> x \<squnion>\<^sub>f y \<sqsubseteq>\<^sub>r z"
  (*<*) by (insert semilat) (unfold semilat_Def, simp) (*>*)

lemma (in Semilat) plus_le_conv [simp]:
  "\<lbrakk> x \<in> A; y \<in> A; z \<in> A \<rbrakk> \<Longrightarrow> (x \<squnion>\<^sub>f y \<sqsubseteq>\<^sub>r z) = (x \<sqsubseteq>\<^sub>r z \<and> y \<sqsubseteq>\<^sub>r z)"
  (*<*) by (blast intro: ub1 ub2 lub order_trans) (*>*)

lemma (in Semilat) le_iff_plus_unchanged:
  assumes "x \<in> A" and "y \<in> A"
  shows "x \<sqsubseteq>\<^sub>r y \<longleftrightarrow> x \<squnion>\<^sub>f y = y" (is "?P \<longleftrightarrow> ?Q")
(*<*)
proof
  assume ?P
  with assms show ?Q by (blast intro: antisym_r lub ub2)
next
  assume ?Q
  then have "y = x \<squnion>\<^bsub>f\<^esub> y" by simp
  moreover from assms have "x \<sqsubseteq>\<^bsub>r\<^esub> x \<squnion>\<^bsub>f\<^esub> y" by simp
  ultimately show ?P by simp
qed
(*>*)

lemma (in Semilat) le_iff_plus_unchanged2:
  assumes "x \<in> A" and "y \<in> A"
  shows "x \<sqsubseteq>\<^sub>r y \<longleftrightarrow> y \<squnion>\<^sub>f x = y" (is "?P \<longleftrightarrow> ?Q")
(*<*)
proof
  assume ?P
  with assms show ?Q by (blast intro: antisym_r lub ub1)
next
  assume ?Q
  then have "y = y \<squnion>\<^bsub>f\<^esub> x" by simp
  moreover from assms have "x \<sqsubseteq>\<^bsub>r\<^esub> y \<squnion>\<^bsub>f\<^esub> x" by simp
  ultimately show ?P by simp
qed
(*>*)

lemma (in Semilat) plus_assoc [simp]:
  assumes a: "a \<in> A" and b: "b \<in> A" and c: "c \<in> A"
  shows "a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c) = a \<squnion>\<^sub>f b \<squnion>\<^sub>f c"
(*<*)
proof -
  from a b have ab: "a \<squnion>\<^sub>f b \<in> A" ..
  from this c have abc: "(a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c \<in> A" ..
  from b c have bc: "b \<squnion>\<^sub>f c \<in> A" ..
  from a this have abc': "a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c) \<in> A" ..

  show ?thesis
  proof
    show "a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c) \<sqsubseteq>\<^sub>r (a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c"
    proof -
      from a b have "a \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f b" ..
      also from ab c have "\<dots> \<sqsubseteq>\<^sub>r \<dots> \<squnion>\<^sub>f c" ..
      finally have "a<": "a \<sqsubseteq>\<^sub>r (a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c" .
      from a b have "b \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f b" ..
      also from ab c have "\<dots> \<sqsubseteq>\<^sub>r \<dots> \<squnion>\<^sub>f c" ..
      finally have "b<": "b \<sqsubseteq>\<^sub>r (a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c" .
      from ab c have "c<": "c \<sqsubseteq>\<^sub>r (a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c" ..
      from "b<" "c<" b c abc have "b \<squnion>\<^sub>f c \<sqsubseteq>\<^sub>r (a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c" ..
      from "a<" this a bc abc show ?thesis ..
    qed
    show "(a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c)"
    proof -
      from b c have "b \<sqsubseteq>\<^sub>r b \<squnion>\<^sub>f c" ..
      also from a bc have "\<dots> \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f \<dots>" ..
      finally have "b<": "b \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c)" .
      from b c have "c \<sqsubseteq>\<^sub>r b \<squnion>\<^sub>f c" ..
      also from a bc have "\<dots> \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f \<dots>" ..
      finally have "c<": "c \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c)" .
      from a bc have "a<": "a \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c)" ..
      from "a<" "b<" a b abc' have "a \<squnion>\<^sub>f b \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c)" ..
      from this "c<" ab c abc' show ?thesis ..
    qed
  qed
qed
(*>*)

lemma (in Semilat) plus_com_lemma:
  "\<lbrakk>a \<in> A; b \<in> A\<rbrakk> \<Longrightarrow> a \<squnion>\<^sub>f b \<sqsubseteq>\<^sub>r b \<squnion>\<^sub>f a"
(*<*)
proof -
  assume a: "a \<in> A" and b: "b \<in> A"
  from b a have "a \<sqsubseteq>\<^sub>r b \<squnion>\<^sub>f a" ..
  moreover from b a have "b \<sqsubseteq>\<^sub>r b \<squnion>\<^sub>f a" ..
  moreover note a b
  moreover from b a have "b \<squnion>\<^sub>f a \<in> A" ..
  ultimately show ?thesis ..
qed
(*>*)

lemma (in Semilat) plus_commutative:
  "\<lbrakk>a \<in> A; b \<in> A\<rbrakk> \<Longrightarrow> a \<squnion>\<^sub>f b = b \<squnion>\<^sub>f a"
  (*<*) by(blast intro: order_antisym plus_com_lemma) (*>*)

lemma is_lubD:
  "is_lub r x y u \<Longrightarrow> is_ub r x y u \<and> (\<forall>z. is_ub r x y z \<longrightarrow> (u,z) \<in> r)"
  (*<*) by (simp add: is_lub_def) (*>*)

lemma is_ubI:
  "\<lbrakk> (x,u) \<in> r; (y,u) \<in> r \<rbrakk> \<Longrightarrow> is_ub r x y u"
  (*<*) by (simp add: is_ub_def) (*>*)

lemma is_ubD:
  "is_ub r x y u \<Longrightarrow> (x,u) \<in> r \<and> (y,u) \<in> r"
  (*<*) by (simp add: is_ub_def) (*>*)

lemma is_lub_bigger1 [iff]:
  "is_lub (r^* ) x y y = ((x,y)\<in>r^* )"
(*<*)
apply (unfold is_lub_def is_ub_def)
apply blast
done
(*>*)

lemma is_lub_bigger2 [iff]:
  "is_lub (r^* ) x y x = ((y,x)\<in>r^* )"
(*<*)
apply (unfold is_lub_def is_ub_def)
apply blast
done
(*>*)

lemma extend_lub:
  "\<lbrakk> single_valued r; is_lub (r^* ) x y u; (x',x) \<in> r \<rbrakk>
  \<Longrightarrow> \<exists>v. is_lub (r^* ) x' y v"
(*<*)
apply (unfold is_lub_def is_ub_def)
apply (case_tac "(y,x) \<in> r^*")
 apply (case_tac "(y,x') \<in> r^*")
  apply blast
 apply (blast elim: converse_rtranclE dest: single_valuedD)
apply (rule exI)
apply (rule conjI)
 apply (blast intro: converse_rtrancl_into_rtrancl dest: single_valuedD)
apply (blast intro: rtrancl_into_rtrancl converse_rtrancl_into_rtrancl
             elim: converse_rtranclE dest: single_valuedD)
done
(*>*)

lemma single_valued_has_lubs [rule_format]:
  "\<lbrakk> single_valued r; (x,u) \<in> r^* \<rbrakk> \<Longrightarrow> (\<forall>y. (y,u) \<in> r^* \<longrightarrow>
  (\<exists>z. is_lub (r^* ) x y z))"
(*<*)
apply (erule converse_rtrancl_induct)
 apply clarify
 apply (erule converse_rtrancl_induct)
  apply blast
 apply (blast intro: converse_rtrancl_into_rtrancl)
apply (blast intro: extend_lub)
done
(*>*)

lemma some_lub_conv:
  "\<lbrakk> acyclic r; is_lub (r^* ) x y u \<rbrakk> \<Longrightarrow> some_lub (r^* ) x y = u"
(*<*)
apply (simp only: some_lub_def is_lub_def)
apply (rule someI2)
 apply (simp only: is_lub_def)
apply (blast intro: antisymD dest!: acyclic_impl_antisym_rtrancl)
done
(*>*)

lemma is_lub_some_lub:
  "\<lbrakk> single_valued r; acyclic r; (x,u)\<in>r^*; (y,u)\<in>r^* \<rbrakk>
  \<Longrightarrow> is_lub (r^* ) x y (some_lub (r^* ) x y)"
  (*<*) by (fastforce dest: single_valued_has_lubs simp add: some_lub_conv) (*>*)

subsection\<open>An executable lub-finder\<close>

definition exec_lub :: "('a * 'a) set \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a binop"
where
  "exec_lub r f x y = while (\<lambda>z. (x,z) \<notin> r\<^sup>*) f y"

lemma exec_lub_refl: "exec_lub r f T T = T"
by (simp add: exec_lub_def while_unfold)

lemma acyclic_single_valued_finite:
 "\<lbrakk>acyclic r; single_valued r; (x,y) \<in> r\<^sup>*\<rbrakk>
  \<Longrightarrow> finite (r \<inter> {a. (x, a) \<in> r\<^sup>*} \<times> {b. (b, y) \<in> r\<^sup>*})"
(*<*)
apply(erule converse_rtrancl_induct)
 apply(rule_tac B = "{}" in finite_subset)
  apply(simp only:acyclic_def)
  apply(blast intro:rtrancl_into_trancl2 rtrancl_trancl_trancl)
 apply simp
apply(rename_tac x x')
apply(subgoal_tac "r \<inter> {a. (x,a) \<in> r\<^sup>*} \<times> {b. (b,y) \<in> r\<^sup>*} =
                   insert (x,x') (r \<inter> {a. (x', a) \<in> r\<^sup>*} \<times> {b. (b, y) \<in> r\<^sup>*})")
 apply simp
apply(blast intro:converse_rtrancl_into_rtrancl
            elim:converse_rtranclE dest:single_valuedD)
done
(*>*)

lemma exec_lub_conv:
  "\<lbrakk> acyclic r; \<forall>x y. (x,y) \<in> r \<longrightarrow> f x = y; is_lub (r\<^sup>*) x y u \<rbrakk> \<Longrightarrow>
  exec_lub r f x y = u"
(*<*)
apply(unfold exec_lub_def)
apply(rule_tac P = "\<lambda>z. (y,z) \<in> r\<^sup>* \<and> (z,u) \<in> r\<^sup>*" and
               r = "(r \<inter> {(a,b). (y,a) \<in> r\<^sup>* \<and> (b,u) \<in> r\<^sup>*})^-1" in while_rule)
    apply(blast dest: is_lubD is_ubD)
   apply(erule conjE)
   apply(erule_tac z = u in converse_rtranclE)
    apply(blast dest: is_lubD is_ubD)
   apply(blast dest:rtrancl_into_rtrancl)
  apply(rename_tac s)
  apply(subgoal_tac "is_ub (r\<^sup>*) x y s")
   prefer 2 apply(simp add:is_ub_def)
  apply(subgoal_tac "(u, s) \<in> r\<^sup>*")
   prefer 2 apply(blast dest:is_lubD)
  apply(erule converse_rtranclE)
   apply blast
  apply(simp only:acyclic_def)
  apply(blast intro:rtrancl_into_trancl2 rtrancl_trancl_trancl)
 apply(rule finite_acyclic_wf)
  apply simp
  apply(erule acyclic_single_valued_finite)
   apply(blast intro:single_valuedI)
  apply(simp add:is_lub_def is_ub_def)
 apply simp
 apply(erule acyclic_subset)
 apply blast
apply simp
apply(erule conjE)
apply(erule_tac z = u in converse_rtranclE)
 apply(blast dest: is_lubD is_ubD)
apply(blast dest:rtrancl_into_rtrancl)
done
(*>*)

lemma is_lub_exec_lub:
  "\<lbrakk> single_valued r; acyclic r; (x,u):r^*; (y,u):r^*; \<forall>x y. (x,y) \<in> r \<longrightarrow> f x = y \<rbrakk>
  \<Longrightarrow> is_lub (r^* ) x y (exec_lub r f x y)"
  (*<*) by (fastforce dest: single_valued_has_lubs simp add: exec_lub_conv) (*>*)

end


theory Lab2_Ex
imports Main
begin

(* Topic: Recursion, induction and counterexamples *)

(*
  replace :: Old \<Rightarrow> New \<Rightarrow> List \<Rightarrow> List'
  Replaces all occurences of Old in List with New.
*)
primrec replace :: "'a \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where "replace x y [] = []"
  | "replace x y (z#zs) = (if z = x then y else z)#(replace x y zs)"

value "replace 1 0 [1, 1, 2] :: int list"

(*
  del1 :: Item \<Rightarrow> List \<Rightarrow> List'
  Deletes first occurence of Item in List.
*)
primrec del1 :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where "del1 x [] = []"
  | "del1 x (y#ys) = (if y = x then ys else y#(del1 x ys))"

value "del1 1 [0, 0, 1, 1] :: int list"

(*
  delall :: Item \<Rightarrow> List \<Rightarrow> List'
  Deletes all occurences of Item in List.
*)
primrec delall :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where "delall x [] = []"
  | "delall x (y#ys) = (if y = x then (delall x ys) else y#(delall x ys))"

value "delall 0 [1, 1, 0, 0, 1] :: int list"

(* Вариант 3: 3 и 5
    3: theorem "del1 x (del1 y zs) = del1 y (del1 x zs)"
    5: theorem "del1 y (replace x y xs) = del1 x xs"
*)

(*
  prove
  e.g.:
    List = [0, 0, 1, 2]
    del1 0 (del1 1 List) = del1 1 (del1 0 List) = [2]
*)
theorem [simp]: "del1 x (del1 y zs) = del1 y (del1 x zs)"
  apply(induct_tac zs)
  apply auto
done

(*
  fail to prove
  e.g.:
    List = [0, 0, 1, 1]
    LHS: del1 1 (replace 0 1 List) = [1, 1, 1]
    RHS: del1 0 List = [0, 1, 1]
    [1, 1, 1] \<noteq> [0, 1, 1]
*)
theorem "del1 y (replace x y xs) = del1 x xs"
  apply(induct_tac xs)
  apply auto
  quickcheck 1
  quickcheck 2
  quickcheck 3
oops


theory ex5_02 imports Main begin

lemma "(\<exists>ys zs. xs = ys @ zs \<and> length ys = length zs) \<or> (\<exists> ys zs. xs = ys @ zs \<and> length ys = length zs + 1)"
proof(cases "even (length xs)")
  assume "even (length xs)"
  let ?n = "length xs"
  let ?n2 = "?n div 2"
  let ?ys = "take ?n2 xs"
  let ?zs = "drop ?n2 xs"
  have "xs = ?ys @ ?zs" by auto
  moreover have "length ?ys = length ?zs"
    proof -
      have "2 * (length xs div 2) = length xs"
        by (meson \<open>even (length xs)\<close> even_two_times_div_two)
      then show ?thesis
        by (metis (no_types) add_diff_cancel_right' append_eq_conv_conj length_append length_drop length_take mult_2)
    qed
  then show ?thesis using calculation by blast
next
  assume "odd (length xs)"
  let ?n = "length xs"
  let ?n2 = "?n - ?n div 2"
  let ?ys = "take ?n2 xs"
  let ?zs = "drop ?n2 xs"
  have "xs = ?ys @ ?zs" by auto
  moreover have "length ?ys = length ?zs + 1"
    proof -
      have "2 * (length xs div 2) + 1 = length xs"
        using \<open>odd (length xs)\<close> odd_two_times_div_two_succ by blast
      then show ?thesis
        by simp
    qed
  then show ?thesis using calculation by blast
qed

end


subsection\<open>AExp Lexorder\<close>

text\<open>This theory defines a lexicographical ordering on arithmetic expressions such that we can build
orderings for guards and, subsequently, transitions. We make use of the previously established
orderings on variable names and values.\<close>

theory AExp_Lexorder
imports AExp Value_Lexorder
begin

text_raw\<open>\snip{height}{1}{2}{%\<close>
fun height :: "'a aexp \<Rightarrow> nat"  where
  "height (L l2) = 1" |
  "height (V v2) = 1" |
  "height (Plus e1 e2) = 1 + max (height e1) (height e2)" |
  "height (Minus e1 e2) = 1 + max (height e1) (height e2)" |
  "height (Times e1 e2) = 1 + max (height e1) (height e2)"
text_raw\<open>}%endsnip\<close>

instantiation aexp :: (linorder) linorder begin
fun less_aexp_aux :: "'a aexp \<Rightarrow> 'a aexp \<Rightarrow> bool"  where
  "less_aexp_aux (L l1) (L l2) = (l1 < l2)" |
  "less_aexp_aux (L l1) _ = True" |

  "less_aexp_aux (V v1) (L l1) = False" |
  "less_aexp_aux (V v1) (V v2) = (v1 < v2)" |
  "less_aexp_aux (V v1) _ = True" |

  "less_aexp_aux (Plus e1 e2) (L l2) = False" |
  "less_aexp_aux (Plus e1 e2) (V v2) = False" |
  "less_aexp_aux (Plus e1 e2) (Plus e1' e2') = ((less_aexp_aux e1 e1') \<or> ((e1 = e1') \<and> (less_aexp_aux e2 e2')))"|
  "less_aexp_aux (Plus e1 e2) _ = True" |

  "less_aexp_aux (Minus e1 e2) (Minus e1' e2') =  ((less_aexp_aux e1 e1') \<or> ((e1 = e1') \<and> (less_aexp_aux e2 e2')))" |
  "less_aexp_aux (Minus e1 e2) (Times e1' e2') = True" |
  "less_aexp_aux (Minus e1 e2) _ = False" |

  "less_aexp_aux (Times e1 e2) (Times e1' e2') =  ((less_aexp_aux e1 e1') \<or> ((e1 = e1') \<and> (less_aexp_aux e2 e2')))" |
  "less_aexp_aux (Times e1 e2) _ = False"

definition less_aexp :: "'a aexp \<Rightarrow> 'a aexp \<Rightarrow> bool" where
  "less_aexp a1 a2 = (
    let
      h1 = height a1;
      h2 = height a2
    in
    if h1 = h2 then
      less_aexp_aux a1 a2
    else
      h1 < h2
  )"

definition less_eq_aexp :: "'a aexp \<Rightarrow> 'a aexp \<Rightarrow> bool"
  where "less_eq_aexp e1 e2 \<equiv> (e1 < e2) \<or> (e1 = e2)"

declare less_aexp_def [simp]

lemma less_aexp_aux_antisym: "less_aexp_aux x  y = (\<not>(less_aexp_aux y x) \<and> (x \<noteq> y))"
  by (induct x y rule: less_aexp_aux.induct, auto)

lemma less_aexp_antisym: "(x::'a aexp) < y = (\<not>(y < x) \<and> (x \<noteq> y))"
  apply (simp add: Let_def)
  apply standard
  using less_aexp_aux_antisym apply blast
  apply (simp add: not_less)
  apply clarify
  by (induct x, auto)

lemma less_aexp_aux_trans: "less_aexp_aux x y \<Longrightarrow> less_aexp_aux y z \<Longrightarrow> less_aexp_aux x z"
proof (induct x y arbitrary: z rule: less_aexp_aux.induct)
  case (1 l1 l2)
  then show ?case by (cases z, auto)
next
  case ("2_1" l1 v)
  then show ?case by (cases z, auto)
next
  case ("2_2" l1 v va)
  then show ?case by (cases z, auto)
next
  case ("2_3" l1 v va)
  then show ?case by (cases z, auto)
next
  case ("2_4" l1 v va)
  then show ?case by (cases z, auto)
next
  case (3 v1 l1)
  then show ?case by (cases z, auto)
next
  case (4 v1 v2)
  then show ?case by (cases z, auto)
next
  case ("5_1" v1 v va)
  then show ?case by (cases z, auto)
next
  case ("5_2" v1 v va)
  then show ?case by (cases z, auto)
next
  case ("5_3" v1 v va)
  then show ?case by (cases z, auto)
next
  case (6 e1 e2 l2)
  then show ?case by (cases z, auto)
next
  case (7 e1 e2 v2)
  then show ?case by (cases z, auto)
next
  case (8 e1 e2 e1' e2')
  then show ?case by (cases z, auto)
next
  case ("9_1" e1 e2 v va)
  then show ?case by (cases z, auto)
next
  case ("9_2" e1 e2 v va)
  then show ?case by (cases z, auto)
next
  case (10 e1 e2 e1' e2')
  then show ?case by (cases z, auto)
next
  case (11 e1 e2 e1' e2')
  then show ?case by (cases z, auto)
next
  case ("12_1" e1 e2 v)
  then show ?case by (cases z, auto)
next
  case ("12_2" e1 e2 v)
  then show ?case by (cases z, auto)
next
  case ("12_3" e1 e2 v va)
  then show ?case by (cases z, auto)
next
  case (13 e1 e2 e1' e2')
  then show ?case by (cases z, auto)
next
  case ("14_1" e1 e2 v)
  then show ?case by (cases z, auto)
next
  case ("14_2" e1 e2 v)
  then show ?case by (cases z, auto)
next
  case ("14_3" e1 e2 v va)
  then show ?case by (cases z, auto)
next
  case ("14_4" e1 e2 v va)
  then show ?case by (cases z, auto)
qed

lemma less_aexp_trans: "(x::'a aexp) < y \<Longrightarrow> y < z \<Longrightarrow> x < z"
  apply (simp add: Let_def)
  apply standard
   apply (metis AExp_Lexorder.less_aexp_aux_trans dual_order.asym)
  by presburger

instance proof
    fix x y z :: "'a aexp"
    show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
      by (metis less_aexp_antisym less_eq_aexp_def)
    show "(x \<le> x)"
      by (simp add: less_eq_aexp_def)
    show "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
      by (metis less_aexp_trans less_eq_aexp_def)
    show "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
      unfolding less_eq_aexp_def using less_aexp_antisym by blast
    show "x \<le> y \<or> y \<le> x"
      unfolding less_eq_aexp_def using less_aexp_antisym by blast
  qed
end

lemma smaller_height: "height a1 < height a2 \<Longrightarrow> a1 < a2"
  by simp

end


theory Chapter15_2_Typechecking
imports Chapter15_1_Language
begin

inductive typecheck :: "type env => expr => type => bool"
where tc_var [simp]: "lookup gam x = Some t ==> typecheck gam (Var x) t"
    | tc_zero [simp]: "typecheck gam Zero Nat"
    | tc_suc [simp]: "typecheck gam e Nat ==> typecheck gam (Suc e) Nat"
    | tc_isz [simp]: "typecheck gam et Nat ==> typecheck gam e0 t ==>
                typecheck (extend gam Nat) es t ==> typecheck gam (IsZ et e0 es) t"
    | tc_lam [simp]: "typecheck (extend gam t1) e t2 ==> typecheck gam (Lam t1 e) (Arrow t1 t2)"
    | tc_appl [simp]: "typecheck gam e1 (Arrow t2 t) ==> typecheck gam e2 t2 ==>
                typecheck gam (Appl e1 e2) t"
    | tc_triv [simp]: "typecheck gam Triv Unit"
    | tc_pair [simp]: "typecheck gam e1 t1 ==> typecheck gam e2 t2 ==>
                typecheck gam (Pair e1 e2) (Prod t1 t2)"
    | tc_projl [simp]: "typecheck gam e (Prod t1 t2) ==> typecheck gam (ProjL e) t1"
    | tc_projr [simp]: "typecheck gam e (Prod t1 t2) ==> typecheck gam (ProjR e) t2"
    | tc_abort [simp]: "typecheck gam e Void ==> typecheck gam (Abort t e) t"
    | tc_case [simp]: "typecheck gam et (Sum t1 t2) ==> typecheck (extend gam t1) el t ==>
                typecheck (extend gam t2) er t ==> typecheck gam (Case et el er) t"
    | tc_inl [simp]: "typecheck gam e t1 ==> typecheck gam (InL t1 t2 e) (Sum t1 t2)"
    | tc_inr [simp]: "typecheck gam e t2 ==> typecheck gam (InR t1 t2 e) (Sum t1 t2)"
    | tc_fix [simp]: "typecheck (extend gam t) e t ==> typecheck gam (Fix t e) t"

inductive_cases [elim!]: "typecheck gam (Var x) t"
inductive_cases [elim!]: "typecheck gam Zero t"
inductive_cases [elim!]: "typecheck gam (Suc e) t"
inductive_cases [elim!]: "typecheck gam (IsZ et e0 es) t"
inductive_cases [elim!]: "typecheck gam (Lam t1 e) t"
inductive_cases [elim!]: "typecheck gam (Appl e1 e2) t"
inductive_cases [elim!]: "typecheck gam Triv t"
inductive_cases [elim!]: "typecheck gam (Pair e1 e2) t"
inductive_cases [elim!]: "typecheck gam (ProjL e) t"
inductive_cases [elim!]: "typecheck gam (ProjR e) t"
inductive_cases [elim!]: "typecheck gam (Abort t1 e) t"
inductive_cases [elim!]: "typecheck gam (Case et el er) t"
inductive_cases [elim!]: "typecheck gam (InL t1 t2 e) t"
inductive_cases [elim!]: "typecheck gam (InR t1 t2 e) t"
inductive_cases [elim!]: "typecheck gam (Fix t1 e) t"

lemma [simp]: "typecheck (extend_at n gam t') e t ==> n in gam ==> typecheck gam e' t' ==>
                  typecheck gam (subst e' n e) t"
by (induction "extend_at n gam t'" e t arbitrary: n gam t' e' rule: typecheck.induct, fastforce+)

end


header {* Abstract syntax for Logic. *}

theory Syntax_SL
  imports  Main Real
begin

(*Constants*)
datatype val = Real real     ("Real _" 76)
             | String string ("String _" 76)
             | Bool bool     ("Bool _" 76)
| Err
(*Expressions of HCSP language.*)
datatype exp = Con val ("Con _" 75)
             | RVar string   ("RVar _" 75 )
             | SVar string   ("SVar _" 75)
             | BVar string   ("BVar _" 75)
             | Add exp exp   (infixr "[+]" 70)
             | Sub exp exp   (infixl  "[-]" 70)
             | Mul exp exp   (infixr "[*]" 71)
(*to complete all related to divide in  following functions.*)
           | Div exp exp   (infixr "[**]" 71)

(*Type declarations to be used in {*proc*}*)
datatype typeid = R | S | B
(*States*)
type_synonym state = "string * typeid => val"

(*Evaluation of expressions*)
primrec evalE :: "exp \<Rightarrow> state => val" where
"evalE (Con y) f = y" |
"evalE (RVar (x)) f = f (x, R)" |
"evalE (SVar (x)) f = f (x, S)" |
"evalE (BVar (x)) f = f (x, B)" |
"evalE (e1 [+] e2) f = (case (evalE e1 f) of Real (x) =>
                                         (case (evalE e2 f) of Real (y) => Real (x + y) |
                                                                          _    => Err)|
                                                              _ => Err)" |
"evalE (e1 [-] e2) f = (case (evalE e1 f) of  Real (x) =>
                                         (case (evalE e2 f) of  Real (y) =>  Real (x - y) |
                                                                          _    => Err)|
                                                              _ => Err)" |
"evalE (e1 [*] e2) f = (case (evalE e1 f) of  Real (x) =>
                                         (case (evalE e2 f) of Real (y) =>  Real (x * y) |
                                                                          _    => Err)|
                                                              _ => Err)"

section{*FOL operators*}
type_synonym fform = "state  \<Rightarrow> bool"
definition fTrue:: "fform" where " fTrue == % s. True"
definition fFalse:: "fform" where "fFalse == % s. False"
definition fEqual :: "exp \<Rightarrow> exp \<Rightarrow> fform"  ("_[=]_" 69) where
"e [=] f == % s. evalE e s = evalE f s"
definition fLess :: "exp \<Rightarrow> exp \<Rightarrow> fform"  ("_[<]_" 69) where
"e [<] f == % s. (case (evalE e s) of Real c \<Rightarrow> (case (evalE f s) of Real d \<Rightarrow> (c<d)
                                                                    |  _ \<Rightarrow> False)
                                       |  _ \<Rightarrow> False )"

definition fAnd :: "fform \<Rightarrow> fform \<Rightarrow> fform"  (infixl "[&]"  65) where
"P [&] Q == % s. P s \<and> Q s"
definition fOr :: "fform\<Rightarrow> fform \<Rightarrow> fform"  (infixl "[|]" 65) where
"P [|] Q == % s. P s \<or> Q s"
definition fNot :: "fform \<Rightarrow> fform"  ("[\<not>]_" 67) where
"[\<not>]P == % s. \<not> P s"
definition fImp :: "fform \<Rightarrow> fform \<Rightarrow> fform"  (infixl "[\<longrightarrow>]" 65) where
"P [\<longrightarrow>] Q == % s. P s \<longrightarrow> Q s"

definition fLessEqual :: "exp \<Rightarrow> exp \<Rightarrow> fform"  ("_[\<le>]_" 69) where
"e [\<le>] f == (e [=] f) [|] (e [<] f)"
definition fGreaterEqual :: "exp \<Rightarrow> exp \<Rightarrow> fform"  ("_[\<ge>]_" 69) where
"e [\<ge>] f == [\<not>](e [<] f)"
definition fGreater :: "exp \<Rightarrow> exp \<Rightarrow> fform"  ("_[>]_" 69) where
"e [>] f == [\<not>](e [\<le>] f)"

(*close() extends the formula with the boundary, used for continuous evolution.*)
consts close :: "fform \<Rightarrow> fform"

axiomatization where
Lessc[simp]: "close (e [<] f) = e [\<le>] f" and
Greatc[simp]: "close (e [>] f) = e [\<ge>] f" and
Equalc[simp]: "close (e [=] f) = e [=] f" and
GreatEqual[simp] : "close ( e [\<ge>] f) =  e [\<ge>] f" and
Andc[simp]: "close (P [&] Q) = close (P) [&] close (Q)" and
Orc[simp]: "close (P [|] Q) = close (P) [|] close (Q)"

lemma notLess : "close ([\<not>] e [<] f) = e [\<ge>] f"
apply (subgoal_tac "[\<not>] e [<] f == e [\<ge>] f", auto)
apply (simp add:fGreaterEqual_def fOr_def fNot_def fLess_def fEqual_def fGreater_def)
done

declare fTrue_def [simp]
declare fFalse_def [simp]

(*Types for defining HCSP*)
type_synonym cname = string
type_synonym time = real

(*Communication processes of HCSP*)
datatype comm
= Send "cname" "exp"         ("_!!_" [110,108] 100)
| Receive "cname" "exp"    ("_??_" [110,108] 100)

(*HCSP processes*)
datatype proc
= Cm comm
| "Skip"
| Ass "exp" "exp"          ("_ := _" [99, 95] 94)
| Seq "proc" "proc"                   ("_; _"        [91,90 ] 90)
| Cond "fform" "proc"                 ("IF _ _"   [95,94]93)
| CondG "fform" "proc" "proc"                 ("IFELSE _ _ _"   [95,94,94]93)
| Pref   "comm" "proc"                  ("_\<rightarrow>_"   [95,94]93)
| join "proc" "proc"                   (infixr "[[" 90)
| meet "proc" "proc"                  ("_<<_" [90,90] 90)
(*Repetition is annotated with invariant*)
| Rep    "proc" "fform"                              ("_*&&_"[91] 90)
| RepN  "proc" "nat"   ("_* NUM _"[91, 90] 90)
(*Continuous evolution is annotated with invariant.*)
| Cont  "(string * typeid) list" "exp list" "fform" "fform"               ("<_:_&&_&_>" [95,95,96]94)
| Interp   "proc" "proc" ("_[[>_"[95,94]94)

(*We assume parallel  composition only occurs in  the topmost level.*)
datatype procP = Par    "proc" "proc"                  (infixr "||" 89)

end


theory list_PairUnpair
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype ('a, 'b) Pair2 = Pair "'a" "'b"

datatype Nat = Z | S "Nat"

fun unpair :: "(('t, 't) Pair2) list => 't list" where
"unpair (Nil2) = Nil2"
| "unpair (Cons2 (Pair z y2) xys) =
     Cons2 z (Cons2 y2 (unpair xys))"

fun pairs :: "'t list => (('t, 't) Pair2) list" where
"pairs (Nil2) = Nil2"
| "pairs (Cons2 y (Nil2)) = Nil2"
| "pairs (Cons2 y (Cons2 y2 xs)) = Cons2 (Pair y y2) (pairs xs)"

fun length :: "'t list => Nat" where
"length (Nil2) = Z"
| "length (Cons2 y xs) = S (length xs)"

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

(*hipster unpair pairs length even *)

theorem x0 :
  "!! (xs :: 't list) .
     (even (length xs)) ==> ((unpair (pairs xs)) = xs)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end