src/HOL/Data_Structures/Leftist_Heap.thy
author nipkow
Thu, 31 Aug 2017 08:39:42 +0200
changeset 66564 ff561d9cb661
parent 66524 5fe7ed50d096
child 67406 23307fd33906
permissions -rw-r--r--
added PQ with merge
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
     1
(* Author: Tobias Nipkow *)
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
     2
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
     3
section \<open>Leftist Heap\<close>
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
     4
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
     5
theory Leftist_Heap
66422
8194ed7cf2cb separate file for priority queue interface; extended Leftist_Heap.
nipkow
parents: 64977
diff changeset
     6
imports
66492
nipkow
parents: 66424
diff changeset
     7
  Base_FDS
66422
8194ed7cf2cb separate file for priority queue interface; extended Leftist_Heap.
nipkow
parents: 64977
diff changeset
     8
  Tree2
8194ed7cf2cb separate file for priority queue interface; extended Leftist_Heap.
nipkow
parents: 64977
diff changeset
     9
  Priority_Queue
8194ed7cf2cb separate file for priority queue interface; extended Leftist_Heap.
nipkow
parents: 64977
diff changeset
    10
  Complex_Main
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    11
begin
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    12
64969
a7ea55c1be52 proper priority queue spec
nipkow
parents: 62706
diff changeset
    13
fun mset_tree :: "('a,'b) tree \<Rightarrow> 'a multiset" where
a7ea55c1be52 proper priority queue spec
nipkow
parents: 62706
diff changeset
    14
"mset_tree Leaf = {#}" |
a7ea55c1be52 proper priority queue spec
nipkow
parents: 62706
diff changeset
    15
"mset_tree (Node _ l a r) = {#a#} + mset_tree l + mset_tree r"
a7ea55c1be52 proper priority queue spec
nipkow
parents: 62706
diff changeset
    16
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    17
type_synonym 'a lheap = "('a,nat)tree"
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    18
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    19
fun rank :: "'a lheap \<Rightarrow> nat" where
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    20
"rank Leaf = 0" |
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    21
"rank (Node _ _ _ r) = rank r + 1"
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    22
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    23
fun rk :: "'a lheap \<Rightarrow> nat" where
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    24
"rk Leaf = 0" |
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    25
"rk (Node n _ _ _) = n"
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    26
64969
a7ea55c1be52 proper priority queue spec
nipkow
parents: 62706
diff changeset
    27
text{* The invariants: *}
a7ea55c1be52 proper priority queue spec
nipkow
parents: 62706
diff changeset
    28
a7ea55c1be52 proper priority queue spec
nipkow
parents: 62706
diff changeset
    29
fun (in linorder) heap :: "('a,'b) tree \<Rightarrow> bool" where
a7ea55c1be52 proper priority queue spec
nipkow
parents: 62706
diff changeset
    30
"heap Leaf = True" |
a7ea55c1be52 proper priority queue spec
nipkow
parents: 62706
diff changeset
    31
"heap (Node _ l m r) =
a7ea55c1be52 proper priority queue spec
nipkow
parents: 62706
diff changeset
    32
  (heap l \<and> heap r \<and> (\<forall>x \<in> set_mset(mset_tree l + mset_tree r). m \<le> x))"
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    33
64973
nipkow
parents: 64971
diff changeset
    34
fun ltree :: "'a lheap \<Rightarrow> bool" where
nipkow
parents: 64971
diff changeset
    35
"ltree Leaf = True" |
nipkow
parents: 64971
diff changeset
    36
"ltree (Node n l a r) =
nipkow
parents: 64971
diff changeset
    37
 (n = rank r + 1 \<and> rank l \<ge> rank r \<and> ltree l & ltree r)"
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    38
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    39
definition node :: "'a lheap \<Rightarrow> 'a \<Rightarrow> 'a lheap \<Rightarrow> 'a lheap" where
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    40
"node l a r =
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    41
 (let rl = rk l; rr = rk r
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    42
  in if rl \<ge> rr then Node (rr+1) l a r else Node (rl+1) r a l)"
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    43
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    44
fun get_min :: "'a lheap \<Rightarrow> 'a" where
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    45
"get_min(Node n l a r) = a"
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    46
66502
nipkow
parents: 66492
diff changeset
    47
text \<open>For function \<open>merge\<close>:\<close>
nipkow
parents: 66492
diff changeset
    48
unbundle pattern_aliases
nipkow
parents: 66492
diff changeset
    49
declare size_prod_measure[measure_function]
66492
nipkow
parents: 66424
diff changeset
    50
66502
nipkow
parents: 66492
diff changeset
    51
fun merge :: "'a::ord lheap \<Rightarrow> 'a lheap \<Rightarrow> 'a lheap" where
64976
1a4cb9403a10 renaming
nipkow
parents: 64975
diff changeset
    52
"merge Leaf t2 = t2" |
1a4cb9403a10 renaming
nipkow
parents: 64975
diff changeset
    53
"merge t1 Leaf = t1" |
66492
nipkow
parents: 66424
diff changeset
    54
"merge (Node n1 l1 a1 r1 =: t1) (Node n2 l2 a2 r2 =: t2) =
nipkow
parents: 66424
diff changeset
    55
   (if a1 \<le> a2 then node l1 a1 (merge r1 t2)
nipkow
parents: 66424
diff changeset
    56
    else node l2 a2 (merge r2 t1))"
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    57
64976
1a4cb9403a10 renaming
nipkow
parents: 64975
diff changeset
    58
lemma merge_code: "merge t1 t2 = (case (t1,t2) of
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    59
  (Leaf, _) \<Rightarrow> t2 |
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    60
  (_, Leaf) \<Rightarrow> t1 |
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    61
  (Node n1 l1 a1 r1, Node n2 l2 a2 r2) \<Rightarrow>
64976
1a4cb9403a10 renaming
nipkow
parents: 64975
diff changeset
    62
    if a1 \<le> a2 then node l1 a1 (merge r1 t2) else node l2 a2 (merge r2 t1))"
1a4cb9403a10 renaming
nipkow
parents: 64975
diff changeset
    63
by(induction t1 t2 rule: merge.induct) (simp_all split: tree.split)
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    64
66524
nipkow
parents: 66502
diff changeset
    65
hide_const (open) insert
nipkow
parents: 66502
diff changeset
    66
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    67
definition insert :: "'a::ord \<Rightarrow> 'a lheap \<Rightarrow> 'a lheap" where
64976
1a4cb9403a10 renaming
nipkow
parents: 64975
diff changeset
    68
"insert x t = merge (Node 1 Leaf x Leaf) t"
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    69
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    70
fun del_min :: "'a::ord lheap \<Rightarrow> 'a lheap" where
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    71
"del_min Leaf = Leaf" |
64976
1a4cb9403a10 renaming
nipkow
parents: 64975
diff changeset
    72
"del_min (Node n l x r) = merge l r"
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    73
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    74
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    75
subsection "Lemmas"
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    76
66422
8194ed7cf2cb separate file for priority queue interface; extended Leftist_Heap.
nipkow
parents: 64977
diff changeset
    77
lemma mset_tree_empty: "mset_tree t = {#} \<longleftrightarrow> t = Leaf"
8194ed7cf2cb separate file for priority queue interface; extended Leftist_Heap.
nipkow
parents: 64977
diff changeset
    78
by(cases t) auto
8194ed7cf2cb separate file for priority queue interface; extended Leftist_Heap.
nipkow
parents: 64977
diff changeset
    79
64973
nipkow
parents: 64971
diff changeset
    80
lemma rk_eq_rank[simp]: "ltree t \<Longrightarrow> rk t = rank t"
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    81
by(cases t) auto
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    82
64973
nipkow
parents: 64971
diff changeset
    83
lemma ltree_node: "ltree (node l a r) \<longleftrightarrow> ltree l \<and> ltree r"
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    84
by(auto simp add: node_def)
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    85
64969
a7ea55c1be52 proper priority queue spec
nipkow
parents: 62706
diff changeset
    86
lemma heap_node: "heap (node l a r) \<longleftrightarrow>
a7ea55c1be52 proper priority queue spec
nipkow
parents: 62706
diff changeset
    87
  heap l \<and> heap r \<and> (\<forall>x \<in> set_mset(mset_tree l + mset_tree r). a \<le> x)"
a7ea55c1be52 proper priority queue spec
nipkow
parents: 62706
diff changeset
    88
by(auto simp add: node_def)
a7ea55c1be52 proper priority queue spec
nipkow
parents: 62706
diff changeset
    89
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    90
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    91
subsection "Functional Correctness"
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    92
64976
1a4cb9403a10 renaming
nipkow
parents: 64975
diff changeset
    93
lemma mset_merge: "mset_tree (merge h1 h2) = mset_tree h1 + mset_tree h2"
1a4cb9403a10 renaming
nipkow
parents: 64975
diff changeset
    94
by (induction h1 h2 rule: merge.induct) (auto simp add: node_def ac_simps)
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    95
64969
a7ea55c1be52 proper priority queue spec
nipkow
parents: 62706
diff changeset
    96
lemma mset_insert: "mset_tree (insert x t) = mset_tree t + {#x#}"
64976
1a4cb9403a10 renaming
nipkow
parents: 64975
diff changeset
    97
by (auto simp add: insert_def mset_merge)
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
    98
66422
8194ed7cf2cb separate file for priority queue interface; extended Leftist_Heap.
nipkow
parents: 64977
diff changeset
    99
lemma get_min: "\<lbrakk> heap h;  h \<noteq> Leaf \<rbrakk> \<Longrightarrow> get_min h = Min_mset (mset_tree h)"
66424
8756322dc5de added Min_mset and Max_mset
nipkow
parents: 66422
diff changeset
   100
by (induction h) (auto simp add: eq_Min_iff)
64969
a7ea55c1be52 proper priority queue spec
nipkow
parents: 62706
diff changeset
   101
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   102
lemma mset_del_min: "mset_tree (del_min h) = mset_tree h - {# get_min h #}"
64976
1a4cb9403a10 renaming
nipkow
parents: 64975
diff changeset
   103
by (cases h) (auto simp: mset_merge)
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   104
64976
1a4cb9403a10 renaming
nipkow
parents: 64975
diff changeset
   105
lemma ltree_merge: "\<lbrakk> ltree l; ltree r \<rbrakk> \<Longrightarrow> ltree (merge l r)"
1a4cb9403a10 renaming
nipkow
parents: 64975
diff changeset
   106
proof(induction l r rule: merge.induct)
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   107
  case (3 n1 l1 a1 r1 n2 l2 a2 r2)
64976
1a4cb9403a10 renaming
nipkow
parents: 64975
diff changeset
   108
  show ?case (is "ltree(merge ?t1 ?t2)")
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   109
  proof cases
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   110
    assume "a1 \<le> a2"
64976
1a4cb9403a10 renaming
nipkow
parents: 64975
diff changeset
   111
    hence "ltree (merge ?t1 ?t2) = ltree (node l1 a1 (merge r1 ?t2))" by simp
1a4cb9403a10 renaming
nipkow
parents: 64975
diff changeset
   112
    also have "\<dots> = (ltree l1 \<and> ltree(merge r1 ?t2))"
64973
nipkow
parents: 64971
diff changeset
   113
      by(simp add: ltree_node)
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   114
    also have "..." using "3.prems" "3.IH"(1)[OF `a1 \<le> a2`] by (simp)
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   115
    finally show ?thesis .
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   116
  next (* analogous but automatic *)
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   117
    assume "\<not> a1 \<le> a2"
64973
nipkow
parents: 64971
diff changeset
   118
    thus ?thesis using 3 by(simp)(auto simp: ltree_node)
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   119
  qed
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   120
qed simp_all
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   121
64976
1a4cb9403a10 renaming
nipkow
parents: 64975
diff changeset
   122
lemma heap_merge: "\<lbrakk> heap l; heap r \<rbrakk> \<Longrightarrow> heap (merge l r)"
1a4cb9403a10 renaming
nipkow
parents: 64975
diff changeset
   123
proof(induction l r rule: merge.induct)
1a4cb9403a10 renaming
nipkow
parents: 64975
diff changeset
   124
  case 3 thus ?case by(auto simp: heap_node mset_merge ball_Un)
64969
a7ea55c1be52 proper priority queue spec
nipkow
parents: 62706
diff changeset
   125
qed simp_all
a7ea55c1be52 proper priority queue spec
nipkow
parents: 62706
diff changeset
   126
64973
nipkow
parents: 64971
diff changeset
   127
lemma ltree_insert: "ltree t \<Longrightarrow> ltree(insert x t)"
64976
1a4cb9403a10 renaming
nipkow
parents: 64975
diff changeset
   128
by(simp add: insert_def ltree_merge del: merge.simps split: tree.split)
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   129
64969
a7ea55c1be52 proper priority queue spec
nipkow
parents: 62706
diff changeset
   130
lemma heap_insert: "heap t \<Longrightarrow> heap(insert x t)"
64976
1a4cb9403a10 renaming
nipkow
parents: 64975
diff changeset
   131
by(simp add: insert_def heap_merge del: merge.simps split: tree.split)
64969
a7ea55c1be52 proper priority queue spec
nipkow
parents: 62706
diff changeset
   132
64973
nipkow
parents: 64971
diff changeset
   133
lemma ltree_del_min: "ltree t \<Longrightarrow> ltree(del_min t)"
64976
1a4cb9403a10 renaming
nipkow
parents: 64975
diff changeset
   134
by(cases t)(auto simp add: ltree_merge simp del: merge.simps)
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   135
64969
a7ea55c1be52 proper priority queue spec
nipkow
parents: 62706
diff changeset
   136
lemma heap_del_min: "heap t \<Longrightarrow> heap(del_min t)"
64976
1a4cb9403a10 renaming
nipkow
parents: 64975
diff changeset
   137
by(cases t)(auto simp add: heap_merge simp del: merge.simps)
64969
a7ea55c1be52 proper priority queue spec
nipkow
parents: 62706
diff changeset
   138
66564
ff561d9cb661 added PQ with merge
nipkow
parents: 66524
diff changeset
   139
text \<open>Last step of functional correctness proof: combine all the above lemmas
ff561d9cb661 added PQ with merge
nipkow
parents: 66524
diff changeset
   140
to show that leftist heaps satisfy the specification of priority queues with merge.\<close>
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   141
66564
ff561d9cb661 added PQ with merge
nipkow
parents: 66524
diff changeset
   142
interpretation lheap: Priority_Queue_Merge
64975
96b66d5c0fc1 added is_empty
nipkow
parents: 64973
diff changeset
   143
where empty = Leaf and is_empty = "\<lambda>h. h = Leaf"
96b66d5c0fc1 added is_empty
nipkow
parents: 64973
diff changeset
   144
and insert = insert and del_min = del_min
66564
ff561d9cb661 added PQ with merge
nipkow
parents: 66524
diff changeset
   145
and get_min = get_min and merge = merge
ff561d9cb661 added PQ with merge
nipkow
parents: 66524
diff changeset
   146
and invar = "\<lambda>h. heap h \<and> ltree h" and mset = mset_tree
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   147
proof(standard, goal_cases)
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   148
  case 1 show ?case by simp
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   149
next
64975
96b66d5c0fc1 added is_empty
nipkow
parents: 64973
diff changeset
   150
  case (2 q) show ?case by (cases q) auto
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   151
next
64975
96b66d5c0fc1 added is_empty
nipkow
parents: 64973
diff changeset
   152
  case 3 show ?case by(rule mset_insert)
96b66d5c0fc1 added is_empty
nipkow
parents: 64973
diff changeset
   153
next
96b66d5c0fc1 added is_empty
nipkow
parents: 64973
diff changeset
   154
  case 4 show ?case by(rule mset_del_min)
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   155
next
66422
8194ed7cf2cb separate file for priority queue interface; extended Leftist_Heap.
nipkow
parents: 64977
diff changeset
   156
  case 5 thus ?case by(simp add: get_min mset_tree_empty)
8194ed7cf2cb separate file for priority queue interface; extended Leftist_Heap.
nipkow
parents: 64977
diff changeset
   157
next
8194ed7cf2cb separate file for priority queue interface; extended Leftist_Heap.
nipkow
parents: 64977
diff changeset
   158
  case 6 thus ?case by(simp)
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   159
next
66422
8194ed7cf2cb separate file for priority queue interface; extended Leftist_Heap.
nipkow
parents: 64977
diff changeset
   160
  case 7 thus ?case by(simp add: heap_insert ltree_insert)
64969
a7ea55c1be52 proper priority queue spec
nipkow
parents: 62706
diff changeset
   161
next
66422
8194ed7cf2cb separate file for priority queue interface; extended Leftist_Heap.
nipkow
parents: 64977
diff changeset
   162
  case 8 thus ?case by(simp add: heap_del_min ltree_del_min)
66564
ff561d9cb661 added PQ with merge
nipkow
parents: 66524
diff changeset
   163
next
ff561d9cb661 added PQ with merge
nipkow
parents: 66524
diff changeset
   164
  case 9 thus ?case by (simp add: mset_merge)
ff561d9cb661 added PQ with merge
nipkow
parents: 66524
diff changeset
   165
next
ff561d9cb661 added PQ with merge
nipkow
parents: 66524
diff changeset
   166
  case 10 thus ?case by (simp add: heap_merge ltree_merge)
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   167
qed
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   168
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   169
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   170
subsection "Complexity"
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   171
64973
nipkow
parents: 64971
diff changeset
   172
lemma pow2_rank_size1: "ltree t \<Longrightarrow> 2 ^ rank t \<le> size1 t"
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   173
proof(induction t)
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   174
  case Leaf show ?case by simp
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   175
next
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   176
  case (Node n l a r)
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   177
  hence "rank r \<le> rank l" by simp
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   178
  hence *: "(2::nat) ^ rank r \<le> 2 ^ rank l" by simp
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   179
  have "(2::nat) ^ rank \<langle>n, l, a, r\<rangle> = 2 ^ rank r + 2 ^ rank r"
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   180
    by(simp add: mult_2)
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   181
  also have "\<dots> \<le> size1 l + size1 r"
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   182
    using Node * by (simp del: power_increasing_iff)
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   183
  also have "\<dots> = size1 \<langle>n, l, a, r\<rangle>" by simp
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   184
  finally show ?case .
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   185
qed
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   186
66492
nipkow
parents: 66424
diff changeset
   187
text\<open>Explicit termination argument: sum of sizes\<close>
nipkow
parents: 66424
diff changeset
   188
66502
nipkow
parents: 66492
diff changeset
   189
fun t_merge :: "'a::ord lheap \<Rightarrow> 'a lheap \<Rightarrow> nat" where
64976
1a4cb9403a10 renaming
nipkow
parents: 64975
diff changeset
   190
"t_merge Leaf t2 = 1" |
1a4cb9403a10 renaming
nipkow
parents: 64975
diff changeset
   191
"t_merge t2 Leaf = 1" |
66492
nipkow
parents: 66424
diff changeset
   192
"t_merge (Node n1 l1 a1 r1 =: t1) (Node n2 l2 a2 r2 =: t2) =
nipkow
parents: 66424
diff changeset
   193
  (if a1 \<le> a2 then 1 + t_merge r1 t2
nipkow
parents: 66424
diff changeset
   194
   else 1 + t_merge r2 t1)"
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   195
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   196
definition t_insert :: "'a::ord \<Rightarrow> 'a lheap \<Rightarrow> nat" where
64976
1a4cb9403a10 renaming
nipkow
parents: 64975
diff changeset
   197
"t_insert x t = t_merge (Node 1 Leaf x Leaf) t"
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   198
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   199
fun t_del_min :: "'a::ord lheap \<Rightarrow> nat" where
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   200
"t_del_min Leaf = 1" |
64976
1a4cb9403a10 renaming
nipkow
parents: 64975
diff changeset
   201
"t_del_min (Node n l a r) = t_merge l r"
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   202
64976
1a4cb9403a10 renaming
nipkow
parents: 64975
diff changeset
   203
lemma t_merge_rank: "t_merge l r \<le> rank l + rank r + 1"
1a4cb9403a10 renaming
nipkow
parents: 64975
diff changeset
   204
proof(induction l r rule: merge.induct)
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   205
  case 3 thus ?case
64976
1a4cb9403a10 renaming
nipkow
parents: 64975
diff changeset
   206
    by(simp)(fastforce split: tree.splits simp del: t_merge.simps)
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   207
qed simp_all
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   208
64976
1a4cb9403a10 renaming
nipkow
parents: 64975
diff changeset
   209
corollary t_merge_log: assumes "ltree l" "ltree r"
1a4cb9403a10 renaming
nipkow
parents: 64975
diff changeset
   210
  shows "t_merge l r \<le> log 2 (size1 l) + log 2 (size1 r) + 1"
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   211
using le_log2_of_power[OF pow2_rank_size1[OF assms(1)]]
64976
1a4cb9403a10 renaming
nipkow
parents: 64975
diff changeset
   212
  le_log2_of_power[OF pow2_rank_size1[OF assms(2)]] t_merge_rank[of l r]
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   213
by linarith
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   214
64973
nipkow
parents: 64971
diff changeset
   215
corollary t_insert_log: "ltree t \<Longrightarrow> t_insert x t \<le> log 2 (size1 t) + 2"
64976
1a4cb9403a10 renaming
nipkow
parents: 64975
diff changeset
   216
using t_merge_log[of "Node 1 Leaf x Leaf" t]
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   217
by(simp add: t_insert_def split: tree.split)
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   218
66492
nipkow
parents: 66424
diff changeset
   219
(* FIXME mv ? *)
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   220
lemma ld_ld_1_less:
66422
8194ed7cf2cb separate file for priority queue interface; extended Leftist_Heap.
nipkow
parents: 64977
diff changeset
   221
  assumes "x > 0" "y > 0" shows "log 2 x + log 2 y + 1 < 2 * log 2 (x+y)"
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   222
proof -
66422
8194ed7cf2cb separate file for priority queue interface; extended Leftist_Heap.
nipkow
parents: 64977
diff changeset
   223
  have "2 powr (log 2 x + log 2 y + 1) = 2*x*y"
64977
50f2f10ab576 tuned proof
nipkow
parents: 64976
diff changeset
   224
    using assms by(simp add: powr_add)
50f2f10ab576 tuned proof
nipkow
parents: 64976
diff changeset
   225
  also have "\<dots> < (x+y)^2" using assms
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   226
    by(simp add: numeral_eq_Suc algebra_simps add_pos_pos)
64977
50f2f10ab576 tuned proof
nipkow
parents: 64976
diff changeset
   227
  also have "\<dots> = 2 powr (2 * log 2 (x+y))"
66492
nipkow
parents: 66424
diff changeset
   228
    using assms by(simp add: powr_add log_powr[symmetric])
64977
50f2f10ab576 tuned proof
nipkow
parents: 64976
diff changeset
   229
  finally show ?thesis by simp
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   230
qed
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   231
64973
nipkow
parents: 64971
diff changeset
   232
corollary t_del_min_log: assumes "ltree t"
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   233
  shows "t_del_min t \<le> 2 * log 2 (size1 t) + 1"
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   234
proof(cases t)
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   235
  case Leaf thus ?thesis using assms by simp
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   236
next
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   237
  case [simp]: (Node _ t1 _ t2)
64976
1a4cb9403a10 renaming
nipkow
parents: 64975
diff changeset
   238
  have "t_del_min t = t_merge t1 t2" by simp
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   239
  also have "\<dots> \<le> log 2 (size1 t1) + log 2 (size1 t2) + 1"
64976
1a4cb9403a10 renaming
nipkow
parents: 64975
diff changeset
   240
    using \<open>ltree t\<close> by (auto simp: t_merge_log simp del: t_merge.simps)
62706
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   241
  also have "\<dots> \<le> 2 * log 2 (size1 t) + 1"
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   242
    using ld_ld_1_less[of "size1 t1" "size1 t2"] by (simp)
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   243
  finally show ?thesis .
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   244
qed
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   245
49c6a54ceab6 added Leftist_Heap
nipkow
parents:
diff changeset
   246
end