theory hw12_tmpl
imports
  "HOL-Data_Structures.Base_FDS"
  "HOL-Data_Structures.Tree2"
  "HOL-Library.Multiset"
  Complex_Main
begin

text \<open>
  \Homework{Explicit Priorities}{6.7.2018}

  Modify the priority queue interface to handle multisets of pairs of
  data and priority, i.e., the new \<open>mset\<close> function has the signature
  @{text \<open>mset::'q \<Rightarrow> ('d\<times>'a::linorder) multiset\<close>}.

  Next, implement the new interface using leftist heaps.
  No complexity proofs are required.

  Hints:
    \<^item> Start with the existing theories, and modify them!
    \<^item> Be careful to design a good specification for \<open>get_min\<close>!

\<close>

(** This template provides a copy of the relevant theories, ready for modification. *)

text \<open>Priority queue interface:\<close>

locale Priority_Queue =
fixes empty :: "'q"
and is_empty :: "'q \<Rightarrow> bool"
and insert :: "('d\<times>'a::linorder) \<Rightarrow> 'q \<Rightarrow> 'q"
and get_min :: "'q \<Rightarrow> ('d\<times>'a::linorder)"
and del_min :: "'q \<Rightarrow> 'q"
and invar :: "'q \<Rightarrow> bool"
and mset :: "'q \<Rightarrow> ('d\<times>'a::linorder) multiset"
assumes mset_empty: "mset empty = {#}"
and is_empty: "invar q \<Longrightarrow> is_empty q = (mset q = {#})"
and mset_insert: "invar q \<Longrightarrow> mset (insert x q) = mset q + {#x#}"
and mset_del_min: "invar q \<Longrightarrow> mset q \<noteq> {#} \<Longrightarrow>
    mset (del_min q) = mset q - {# get_min q #}"
and mset_get_min: "invar q \<Longrightarrow> mset q \<noteq> {#} \<Longrightarrow> get_min q \<in> set_mset(mset q) \<Longrightarrow> \<forall>p \<in> set_mset(mset q). snd (get_min q) \<le> snd p"
and invar_empty: "invar empty"
and invar_insert: "invar q \<Longrightarrow> invar (insert x q)"
and invar_del_min: "invar q \<Longrightarrow> mset q \<noteq> {#} \<Longrightarrow> invar (del_min q)"

text \<open>Extend locale with \<open>merge\<close>. Need to enforce that \<open>'q\<close> is the same in both locales.\<close>

locale Priority_Queue_Merge = Priority_Queue where empty = empty for empty :: 'q +
fixes merge :: "'q \<Rightarrow> 'q \<Rightarrow> 'q"
assumes mset_merge: "\<lbrakk> invar q1; invar q2 \<rbrakk> \<Longrightarrow> mset (merge q1 q2) = mset q1 + mset q2"
and invar_merge: "\<lbrakk> invar q1; invar q2 \<rbrakk> \<Longrightarrow> invar (merge q1 q2)"

fun mset_tree :: "(('d\<times>'a),'b) tree \<Rightarrow> ('d\<times>'a) multiset" where
"mset_tree Leaf = {#}" |
"mset_tree (Node _ l a r) = {#a#} + mset_tree l + mset_tree r"

type_synonym ('d, 'a) lheap = "(('d\<times>'a),nat)tree"

fun rank :: "('d, 'a) lheap \<Rightarrow> nat" where
"rank Leaf = 0" |
"rank (Node _ _ _ r) = rank r + 1"

fun rk :: "('d, 'a) lheap \<Rightarrow> nat" where
"rk Leaf = 0" |
"rk (Node n _ _ _) = n"

text{* The invariants: *}

fun (in linorder) heap :: "(('d\<times>'a),'b) tree \<Rightarrow> bool" where
"heap Leaf = True" |
"heap (Node _ l (d,m) r) =
  (heap l \<and> heap r \<and> (\<forall>(x,y) \<in> set_mset(mset_tree l + mset_tree r). m \<le> y))"

fun ltree :: "('d, 'a) lheap \<Rightarrow> bool" where
"ltree Leaf = True" |
"ltree (Node n l a r) =
 (n = rank r + 1 \<and> rank l \<ge> rank r \<and> ltree l & ltree r)"

definition node :: "('d, 'a) lheap \<Rightarrow> ('d\<times>'a) \<Rightarrow> ('d, 'a) lheap \<Rightarrow> ('d, 'a) lheap" where
"node l a r =
 (let rl = rk l; rr = rk r
  in if rl \<ge> rr then Node (rr+1) l a r else Node (rl+1) r a l)"

fun get_min :: "('d, 'a) lheap \<Rightarrow> ('d\<times>'a::linorder)" where
"get_min(Node n l a r) = a"

text \<open>For function \<open>merge\<close>:\<close>
unbundle pattern_aliases
declare size_prod_measure[measure_function]

fun merge :: "('d, 'a::ord) lheap \<Rightarrow> ('d, 'a) lheap \<Rightarrow> ('d, 'a) lheap" where
"merge Leaf t2 = t2" |
"merge t1 Leaf = t1" |
"merge (Node n1 l1 (d1,a1) r1 =: t1) (Node n2 l2 (d2,a2) r2 =: t2) =
   (if a1 \<le> a2 then node l1 (d1,a1) (merge r1 t2)
    else node l2 (d2,a2) (merge r2 t1))"

lemma merge_code: "merge t1 t2 = (case (t1,t2) of
  (Leaf, _) \<Rightarrow> t2 |
  (_, Leaf) \<Rightarrow> t1 |
  (Node n1 l1 a1 r1, Node n2 l2 a2 r2) \<Rightarrow>
    if snd a1 \<le> snd a2 then node l1 a1 (merge r1 t2) else node l2 a2 (merge r2 t1))"
by(induction t1 t2 rule: merge.induct) (simp_all split: tree.split)

hide_const (open) insert

definition insert :: "('d\<times>'a::ord) \<Rightarrow> ('d, 'a) lheap \<Rightarrow> ('d, 'a) lheap" where
"insert x t = merge (Node 1 Leaf x Leaf) t"

fun del_min :: "('d, 'a::ord) lheap \<Rightarrow> ('d, 'a) lheap" where
"del_min Leaf = Leaf" |
"del_min (Node n l x r) = merge l r"

subsection "Lemmas"

lemma mset_tree_empty: "mset_tree t = {#} \<longleftrightarrow> t = Leaf"
by(cases t) auto

lemma rk_eq_rank[simp]: "ltree t \<Longrightarrow> rk t = rank t"
by(cases t) auto

lemma ltree_node: "ltree (node l a r) \<longleftrightarrow> ltree l \<and> ltree r"
by(auto simp add: node_def)

lemma heap_node: "heap (node l (d,a) r) \<longleftrightarrow>
  heap l \<and> heap r \<and> (\<forall>(x,y) \<in> set_mset(mset_tree l + mset_tree r). a \<le> y)"
by(auto simp add: node_def)

subsection "Functional Correctness"

lemma mset_merge: "mset_tree (merge h1 h2) = mset_tree h1 + mset_tree h2"
by (induction h1 h2 rule: merge.induct) (auto simp add: node_def ac_simps)

lemma mset_insert: "mset_tree (insert x t) = mset_tree t + {#x#}"
by (auto simp add: insert_def mset_merge)

lemma get_min: "\<lbrakk> heap h;  h \<noteq> Leaf \<rbrakk> \<Longrightarrow>  get_min h \<in> set_mset(mset_tree h) \<Longrightarrow> \<forall>(x,y) \<in> set_mset(mset_tree h). snd (get_min h) \<le> y"
  apply(induction h)
   apply auto
   apply blast
  by blast

lemma mset_del_min: "mset_tree (del_min h) = mset_tree h - {# get_min h #}"
by (cases h) (auto simp: mset_merge)

lemma ltree_merge: "\<lbrakk> ltree l; ltree r \<rbrakk> \<Longrightarrow> ltree (merge l r)"
proof(induction l r rule: merge.induct)
  case (3 n1 l1 d1 a1 r1 n2 l2 d2 a2 r2)
  show ?case (is "ltree(merge ?t1 ?t2)")
  proof cases
    assume "a1 \<le> a2"
    hence "ltree (merge ?t1 ?t2) = ltree (node l1 (d1,a1) (merge r1 ?t2))" by simp
    also have "\<dots> = (ltree l1 \<and> ltree(merge r1 ?t2))"
      by(simp add: ltree_node)
    also have "..." using "3.prems" "3.IH"(1)[OF `a1 \<le> a2`] by (simp)
    finally show ?thesis .
  next (* analogous but automatic *)
    assume "\<not> a1 \<le> a2"
    thus ?thesis using 3 by(simp)(auto simp: ltree_node)
  qed
qed simp_all

lemma heap_merge: "\<lbrakk> heap l; heap r \<rbrakk> \<Longrightarrow> heap (merge l r)"
proof(induction l r rule: merge.induct)
  case 3 thus ?case by(auto simp: heap_node mset_merge ball_Un)
qed simp_all

lemma ltree_insert: "ltree t \<Longrightarrow> ltree(insert x t)"
by(simp add: insert_def ltree_merge del: merge.simps split: tree.split)

lemma heap_insert_aux1_aux1[simp]: "heap \<langle>a, \<langle>\<rangle>, x, \<langle>\<rangle>\<rangle>"
  by(induction x)(auto)

lemma heap_insert_aux1[simp]:  "heap t \<Longrightarrow> heap (merge \<langle>a, \<langle>\<rangle>, x, \<langle>\<rangle>\<rangle> t)"
  apply(induction t)
  by(auto simp add:heap_merge)

lemma heap_insert: "heap t \<Longrightarrow> heap(insert x t)"
by(simp add: insert_def heap_merge del: merge.simps split: tree.split)

lemma ltree_del_min: "ltree t \<Longrightarrow> ltree(del_min t)"
by(cases t)(auto simp add: ltree_merge simp del: merge.simps)

lemma heap_del_min: "heap t \<Longrightarrow> heap(del_min t)"
by(cases t)(auto simp add: heap_merge simp del: merge.simps)

text \<open>Last step of functional correctness proof: combine all the above lemmas
to show that leftist heaps satisfy the specification of priority queues with merge.\<close>

interpretation lheap: Priority_Queue_Merge
where empty = Leaf and is_empty = "\<lambda>h. h = Leaf"
and insert = insert and del_min = del_min
and get_min = get_min and merge = merge
and invar = "\<lambda>h. heap h \<and> ltree h" and mset = mset_tree
proof(standard, goal_cases)
  case 1 show ?case by simp
next
  case (2 q) show ?case by (cases q) auto
next
  case 3 show ?case by(rule mset_insert)
next
  case 4 show ?case by(rule mset_del_min)
next
  case 5 thus ?case
    by (metis (full_types) case_prodE get_min mset_tree.simps(1) prod.sel(2))
next
  case 6 thus ?case by(simp)
next
  case 7 thus ?case by(simp add: heap_insert ltree_insert)
next
  case 8 thus ?case by(simp add: heap_del_min ltree_del_min)
next
  case 9 thus ?case by (simp add: mset_merge)
next
  case 10 thus ?case by (simp add: heap_merge ltree_merge)
qed

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

(* Author: Thomas Sewell *)

section "Enumeration Instances for Words"

theory Enumeration_Word
  imports
    "HOL-Library.Word"
    More_Word
    Enumeration
    Even_More_List
begin

lemma length_word_enum: "length (enum :: 'a :: len word list) = 2 ^ LENGTH('a)"
  by (simp add: enum_word_def)

lemma fromEnum_unat[simp]: "fromEnum (x :: 'a::len word) = unat x"
proof -
  have "enum ! the_index enum x = x" by (auto intro: nth_the_index)
  moreover
  have "the_index enum x < length (enum::'a::len word list)" by (auto intro: the_index_bounded)
  moreover
  { fix y assume "of_nat y = x"
    moreover assume "y < 2 ^ LENGTH('a)"
    ultimately have "y = unat x" using of_nat_inverse by fastforce
  }
  ultimately
  show ?thesis by (simp add: fromEnum_def enum_word_def)
qed

lemma toEnum_of_nat[simp]: "n < 2 ^ LENGTH('a) \<Longrightarrow> (toEnum n :: 'a :: len word) = of_nat n"
  by (simp add: toEnum_def length_word_enum enum_word_def)

instantiation word :: (len) enumeration_both
begin

definition
  enum_alt_word_def: "enum_alt \<equiv> alt_from_ord (enum :: ('a :: len) word list)"

instance
  by (intro_classes, simp add: enum_alt_word_def)

end

definition
  upto_enum_step :: "('a :: len) word \<Rightarrow> 'a word \<Rightarrow> 'a word \<Rightarrow> 'a word list" ("[_ , _ .e. _]")
where
  "upto_enum_step a b c \<equiv>
      if c < a then [] else map (\<lambda>x. a + x * (b - a)) [0 .e. (c - a) div (b - a)]"
  (* in the wraparound case, bad things happen. *)

lemma maxBound_word:
  "(maxBound::'a::len word) = -1"
  by (simp add: maxBound_def enum_word_def last_map of_nat_diff)

lemma minBound_word:
  "(minBound::'a::len word) = 0"
  by (simp add: minBound_def enum_word_def upt_conv_Cons)

lemma maxBound_max_word:
  "(maxBound::'a::len word) = max_word"
  by (fact maxBound_word)

lemma upto_enum_red':
  assumes lt: "1 \<le> X"
  shows "[(0::'a :: len word) .e. X - 1] =  map of_nat [0 ..< unat X]"
proof -
  have lt': "unat X < 2 ^ LENGTH('a)"
    by (rule unat_lt2p)

  show ?thesis
    apply (subst upto_enum_red)
    apply (simp del: upt.simps)
    apply (subst Suc_unat_diff_1 [OF lt])
    apply (rule map_cong [OF refl])
    apply (rule toEnum_of_nat)
    apply simp
    apply (erule order_less_trans [OF _ lt'])
    done
qed

lemma upto_enum_red2:
  assumes szv: "sz < LENGTH('a :: len)"
  shows "[(0:: 'a :: len word) .e. 2 ^ sz - 1] =
  map of_nat [0 ..< 2 ^ sz]" using szv
  apply (subst unat_power_lower[OF szv, symmetric])
  apply (rule upto_enum_red')
  apply (subst word_le_nat_alt, simp)
  done

lemma upto_enum_step_red:
  assumes szv: "sz < LENGTH('a)"
  and   usszv: "us \<le> sz"
  shows "[0 :: 'a :: len word , 2 ^ us .e. 2 ^ sz - 1] =
  map (\<lambda>x. of_nat x * 2 ^ us) [0 ..< 2 ^ (sz - us)]" using szv
  unfolding upto_enum_step_def
  apply (subst if_not_P)
   apply (rule leD)
   apply (subst word_le_nat_alt)
   apply (subst unat_minus_one)
    apply simp
   apply simp
  apply simp
  apply (subst upto_enum_red)
  apply (simp del: upt.simps)
  apply (subst Suc_div_unat_helper [where 'a = 'a, OF szv usszv, symmetric])
  apply clarsimp
  apply (subst toEnum_of_nat)
   apply (erule order_less_trans)
   using szv
   apply simp
  apply simp
  done

lemma upto_enum_word:
  "[x .e. y] = map of_nat [unat x ..< Suc (unat y)]"
  apply (subst upto_enum_red)
  apply clarsimp
  apply (subst toEnum_of_nat)
   prefer 2
   apply (rule refl)
  apply (erule disjE, simp)
  apply clarsimp
  apply (erule order_less_trans)
  apply simp
  done

lemma word_upto_Cons_eq:
  "x < y \<Longrightarrow> [x::'a::len word .e. y] = x # [x + 1 .e. y]"
  apply (subst upto_enum_red)
  apply (subst upt_conv_Cons)
  apply simp_all
   apply unat_arith
  apply (simp only: list.map list.inject upto_enum_red to_from_enum simp_thms)
  apply simp_all
  apply unat_arith
  done

lemma distinct_enum_upto:
  "distinct [(0 :: 'a::len word) .e. b]"
proof -
  have "\<And>(b::'a word). [0 .e. b] = nths enum {..< Suc (fromEnum b)}"
    apply (subst upto_enum_red)
    apply (subst nths_upt_eq_take)
    apply (subst enum_word_def)
    apply (subst take_map)
    apply (subst take_upt)
     apply (simp only: add_0 fromEnum_unat)
     apply (rule order_trans [OF _ order_eq_refl])
      apply (rule Suc_leI [OF unat_lt2p])
     apply simp
    apply clarsimp
    apply (rule toEnum_of_nat)
    apply (erule order_less_trans [OF _ unat_lt2p])
    done

  then show ?thesis
    by (rule ssubst) (rule distinct_nthsI, simp)
qed

lemma upto_enum_set_conv [simp]:
  fixes a :: "'a :: len word"
  shows "set [a .e. b] = {x. a \<le> x \<and> x \<le> b}"
  apply (subst upto_enum_red)
  apply (subst set_map)
  apply safe
    apply simp
    apply clarsimp
    apply (erule disjE)
     apply simp
     apply (erule iffD2 [OF word_le_nat_alt])
    apply clarsimp
  apply simp_all
    apply (metis le_unat_uoi nat_less_le toEnum_of_nat unsigned_less word_le_nat_alt)
   apply (metis le_unat_uoi less_or_eq_imp_le toEnum_of_nat unsigned_less word_le_nat_alt)
    apply (rule_tac x="fromEnum x" in image_eqI)
   apply clarsimp
  apply clarsimp
  apply transfer
  apply auto
  done

lemma upto_enum_less:
  assumes xin: "x \<in> set [(a::'a::len word).e.2 ^ n - 1]"
  and     nv:  "n < LENGTH('a::len)"
  shows   "x < 2 ^ n"
proof (cases n)
  case 0
  then show ?thesis using xin by simp
next
  case (Suc m)
  show ?thesis using xin nv le_m1_iff_lt p2_gt_0 by auto
qed

lemma upto_enum_len_less:
  "\<lbrakk> n \<le> length [a, b .e. c]; n \<noteq> 0 \<rbrakk> \<Longrightarrow> a \<le> c"
  unfolding upto_enum_step_def
  by (simp split: if_split_asm)

lemma length_upto_enum_step:
  fixes x :: "'a :: len word"
  shows "x \<le> z \<Longrightarrow> length [x , y .e. z] = (unat ((z - x) div (y - x))) + 1"
  unfolding upto_enum_step_def
  by (simp add: upto_enum_red)

lemma map_length_unfold_one:
  fixes x :: "'a::len word"
  assumes xv: "Suc (unat x) < 2 ^ LENGTH('a)"
  and     ax: "a < x"
  shows   "map f [a .e. x] = f a # map f [a + 1 .e. x]"
  by (subst word_upto_Cons_eq, auto, fact+)

lemma length_upto_enum [simp]:
  fixes a :: "'a :: len word"
  shows "length [a .e. b] = Suc (unat b) - unat a"
  apply (simp add: word_le_nat_alt upto_enum_red)
  apply (clarsimp simp: Suc_diff_le)
  done

lemma length_upto_enum_cases:
  fixes a :: "'a::len word"
  shows "length [a .e. b] = (if a \<le> b then Suc (unat b) - unat a else 0)"
  apply (case_tac "a \<le> b")
   apply (clarsimp)
  apply (clarsimp simp: upto_enum_def)
  apply unat_arith
  done

lemma length_upto_enum_less_one:
  "\<lbrakk>a \<le> b; b \<noteq> 0\<rbrakk>
  \<Longrightarrow> length [a .e. b - 1] = unat (b - a)"
  apply clarsimp
  apply (subst unat_sub[symmetric], assumption)
  apply clarsimp
  done

lemma drop_upto_enum:
  "drop (unat n) [0 .e. m] = [n .e. m]"
  apply (clarsimp simp: upto_enum_def)
  apply (induct m, simp)
  by (metis drop_map drop_upt plus_nat.add_0)

lemma distinct_enum_upto' [simp]:
  "distinct [a::'a::len word .e. b]"
  apply (subst drop_upto_enum [symmetric])
  apply (rule distinct_drop)
  apply (rule distinct_enum_upto)
  done

lemma length_interval:
  "\<lbrakk>set xs = {x. (a::'a::len word) \<le> x \<and> x \<le> b}; distinct xs\<rbrakk>
  \<Longrightarrow> length xs = Suc (unat b) - unat a"
  apply (frule distinct_card)
  apply (subgoal_tac "set xs = set [a .e. b]")
   apply (cut_tac distinct_card [where xs="[a .e. b]"])
    apply (subst (asm) length_upto_enum)
    apply clarsimp
   apply (rule distinct_enum_upto')
  apply simp
  done

lemma enum_word_div:
  fixes v :: "'a :: len word" shows
  "\<exists>xs ys. enum = xs @ [v] @ ys
             \<and> (\<forall>x \<in> set xs. x < v)
             \<and> (\<forall>y \<in> set ys. v < y)"
  apply (simp only: enum_word_def)
  apply (subst upt_add_eq_append'[where j="unat v"])
    apply simp
   apply (rule order_less_imp_le, simp)
  apply (simp add: upt_conv_Cons)
  apply (intro exI conjI)
    apply fastforce
   apply clarsimp
   apply (drule of_nat_mono_maybe[rotated, where 'a='a])
    apply simp
   apply simp
  apply (clarsimp simp: Suc_le_eq)
  apply (drule of_nat_mono_maybe[rotated, where 'a='a])
   apply simp
  apply simp
  done

end


theory Submission
  imports Defs
begin

fun add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "add 0 x = x" |
  "add (Suc n) x = 1 + add n x"

theorem add_assoc: "add (add x y) z = add x (add y z)"
  by (induction x) simp+

lemma add_0:"add x 0 = x"
  by (induction x) simp+

lemma add_plus:"add x y = add (x+y) 0"
  using add_0 by (induction x) simp+

theorem add_commut: "add x y = add y x"
  using add_plus add_0 by simp

datatype wexp = N val | V vname | Plus wexp wexp | Where wexp vname wexp

fun wval :: "wexp \<Rightarrow> state \<Rightarrow> val" where
  "wval (N n) s = n" |
  "wval (V x) s = s x" |
  "wval (Plus w1 w2) s = wval w1 s + wval w2 s" |
  "wval (Where w1 x w2) s = undefined"

fun inline :: "wexp \<Rightarrow> aexp" where
  "inline _ = undefined"

value
  "inline (Where (Plus (V ''x'') (V ''x'')) ''x'' (Plus (N 1) (N 1))) =
     aexp.Plus (aexp.Plus (aexp.N 1) (aexp.N 1)) (aexp.Plus (aexp.N 1) (aexp.N 1))"

theorem val_inline: "aval (inline e) s = wval e s"
  sorry

fun elim :: "wexp \<Rightarrow> wexp" where
  "elim _ = undefined"

theorem wval_elim: "wval (elim e) s = wval e s"
  sorry

end


theory TeodoraVasicSeminarski2
  imports Complex_Main
begin

declare [[show_types]]
(*Seminarski 1*)
(*lemma final:
  fixes n m k l::nat
  assumes "k > 0""m > 0""l > 0""n > 1""(n^k + m*n^l + 1) dvd (n^(k+l) - 1)"
  shows "(m = 1 \<and> l = 2*k) \<or> ((l dvd k) \<and> m = (n^(k-l) - 1)/(n^l - 1))"
  sorry
*)

lemma help1:
  fixes n m k l::nat
  assumes "k > 0""m > 0""l > 0""n > 1""(n^k + m*n^l + 1) dvd (n^(k+l) - 1)"
  shows "(n^k + m*n^l + 1) dvd (n^(k+l) + n^k + m*n^l)"
proof-
  have "(n^k + m*n^l + 1) dvd (n^(k+l) - 1)" using assms(5) by blast
  then have "(n^k + m*n^l + 1) dvd ((n^(k+l) - 1) + (n^k + m*n^l + 1))" using dvd_add_triv_right_iff by blast
  then have "(n^k + m*n^l + 1) dvd (n^(k+l) + n^k + m*n^l)" by (metis add.commute add_diff_inverse_nat assms(4) group_cancel.add1 not_less_zero power_0 power_strict_increasing_iff)
  then show ?thesis by auto
qed

lemma help2:
  fixes n m k l::nat
  assumes "k > 0""m > 0""l > 0""n > 1""(n^k + m*n^l + 1) dvd (n^(k+l) - 1)""l \<ge> k"
  shows "n^k + m*n^l + 1 dvd n^l + m*n^(l-k) + 1"
proof-
  have "n^l/n^k = n^(l-k)"
    by (metis One_nat_def Suc_leI assms(4) assms(6) dvd_power_iff_le numerals(2) of_nat_1 of_nat_less_0_iff power_diff real_of_nat_div)
  then have "m*n^l/n^k = m*n^(l-k)"
    by (metis of_nat_mult times_divide_eq_right)
  then have "n^(k+l)/n^k = n^l"
    by (metis add_diff_cancel_left' assms(4) le_add1 le_imp_power_dvd not_one_less_zero power_diff real_of_nat_div)
  then have "n^k/n^k = 1"
    using assms(4) by auto
  then have "(n^(k+l) + n^k + m*n^l)/n^k = (n^l + 1 + m*n^(l-k))"
    by (metis (no_types, lifting) \<open>real (m * n ^ l) / real (n ^ k) = real (m * n ^ (l - k))\<close> \<open>real (n ^ (k + l)) / real (n ^ k) = real (n ^ l)\<close> add_divide_distrib of_nat_1 of_nat_add)
  then have "(n^(k+l) + n^k + m*n^l)/n^k = (n^l + m*n^(l-k) + 1)"
    by auto
  have "n^k dvd (n^(k+l) + n^k + m*n^l)"
    by (simp add: assms(6) le_imp_power_dvd)
  have "(n^k + m*n^l + 1) mod n = 1"
    using assms(1) assms(4) assms(6) mod_nat_eqI by force
  then have "(n^k + m*n^l + 1) dvd (n^(k+l) + n^k + m*n^l)" using assms(1) assms(2) assms(3) assms(4) assms(5) help1 by presburger
  then have "(n^k + m*n^l + 1) dvd (n^(k+l) + n^k + m*n^l)/n^k" by (metis \<open>(n ^ k + m * n ^ l + 1) mod n = 1\<close> bot_nat_0.not_eq_extremum dvd_def less_numeral_extra(1) mod_0 nonzero_mult_div_cancel_left of_nat_eq_0_iff times_divide_eq_right)
  then have "n^k + m*n^l + 1 dvd n^l + m*n^(l-k) + 1" sorry
  then show ?thesis by fastforce
qed

lemma help3:
  fixes n m k l::nat
  assumes "k > 0""m > 0""l > 0""n > 1""(n^k + m*n^l + 1) dvd (n^(k+l) - 1)""l \<ge> k"
  shows "2*(n^k + m*n^l + 1) > 2*m*n^l + 1"
proof-
  have"2*(n^k + m*n^l + 1) = 2*n^k + 2*m*n^l + 2" by auto
  then have "\<dots> > 2*m*n^l + 1"
    by linarith
  then show ?thesis by auto
qed

lemma help4:
  fixes n m k l::nat
  assumes "k > 0""m > 0""l > 0""n > 1""(n^k + m*n^l + 1) dvd (n^(k+l) - 1)""l \<ge> k"
  shows "2*m*n^l + 1 > n^l + m*n^(l-k) + 1"
proof-
  have "m*n^l > m*n^(l-k)"
    by (meson assms(1) assms(2) assms(3) assms(4) diff_less mult_less_mono2 power_strict_increasing_iff)
  then have "m*n^l \<ge> n^l" by simp
  then have "2*m*n^l > n^l + m*n^(l-k)"
    using \<open>(m::nat) * (n::nat) ^ ((l::nat) - (k::nat)) < m * n ^ l\<close> by linarith
  then show ?thesis
    using add_less_mono1 by blast
qed

lemma help5:
  fixes n m k l::nat
  assumes "k > 0""m > 0""l > 0""n > 1""(n^k + m*n^l + 1) dvd (n^(k+l) - 1)""l \<ge> k""2*(n^k + m*n^l + 1) > 2*m*n^l + 1""2*m*n^l + 1 > n^l + m*n^(l-k) + 1"
    "n^k + m*n^l + 1 dvd n^l + m*n^(l-k) + 1"
  shows "n^k + m*n^l + 1 = n^l + m*n^(l-k) + 1"
proof-
  have "2*(n^k + m*n^l + 1) > n^l + m*n^(l-k) + 1"
    using assms(7) assms(8) order_less_trans by blast
  then have "n^k + m*n^l + 1 \<ge> n^l + m*n^(l-k) + 1" sorry
  then show ?thesis
    by (metis add_gr_0 assms(9) le_neq_implies_less less_one nat_dvd_not_less)
qed

lemma help6:
   fixes n m k l::nat
  assumes "k > 0""m > 0""l > 0""n > 1""(n^k + m*n^l + 1) dvd (n^(k+l) - 1)""l \<ge> k""2*(n^k + m*n^l + 1) > 2*m*n^l + 1""2*m*n^l + 1 > n^l + m*n^(l-k) + 1"
    "n^k + m*n^l + 1 = n^l + m*n^(l-k) + 1"
  shows "m = 1 \<and> l = 2*k"
  sorry

lemma help7:
  fixes n m k l::nat
  assumes "k > 0""m > 0""l > 0""n > 1""(n^k + m*n^l + 1) dvd (n^(k+l) - 1)""l < k"
  shows "l dvd k \<and> m = (n^(k-l)-1)/(n^l - 1)"
  sorry

lemma final1:
  fixes n m k l::nat
  assumes "k > 0""m > 0""l > 0""n > 1""(n^k + m*n^l + 1) dvd (n^(k+l) - 1)"
  shows "(m = 1 \<and> l = 2*k) \<or> ((l dvd k) \<and> m = (n^(k-l) - 1)/(n^l - 1))"
  by (metis assms(1) assms(2) assms(3) assms(4) assms(5) help2 help3 help4 help5 help6 help7 linorder_not_less)

end


theory IMP2_Binary_Heap
  imports IMP2.IMP2 IMP2.IMP2_Aux_Lemmas
begin
section \<open>Introduction\<close>
text \<open>In this submission imperative versions of the following array-based binary minimum heap
      functions are implemented and verified: insert, get-min, delete-min, make-heap.
      The latter three are then used to prove the correctness of an in-place heapsort, which sorts
      an array in descending order. To do that in Isabelle/HOL, the proof framework IMP2
      \<^cite>\<open>"IMP2-AFP"\<close> is used. Here arrays are modeled by \<open>int \<Rightarrow> int\<close> functions. The imperative
      implementations are iterative versions of the partly recursive algorithms described in
      \<^cite>\<open>"MS"\<close> and \<^cite>\<open>"CLRS"\<close>.

      This submission starts with the basic definitions and lemmas, which are needed for array-based
      binary heaps. These definitions and lemmas are parameterised with an arbitrary (transitive)
      comparison function (where such a function is needed), so they are not only applicable to
      minimum heaps. After some more general, useful lemmas on arrays, the imperative minimum heap
      functions and the heapsort are implemented and verified.\<close>

section \<open>Heap Related Definitions and Theorems\<close>
subsection \<open>Array Bounds\<close>
text \<open>A small helper function is used to define valid array indices. Note that the lower index
      bound \<open>l\<close> is arbitrary and not fixed to 0 or 1. The upper index bound \<open>r\<close> is not a valid
      index itself, so that the empty array can be denoted by having \<open>l = r\<close>.\<close>
abbreviation bounded :: "int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" where
  "bounded l r x \<equiv> l \<le> x \<and> x < r"

subsection \<open>Parent and Children\<close>

subsubsection \<open>Definitions\<close>
text \<open>For the notion of an array-based binary heap, the parent and child relations on the array
      indices need to be defined.\<close>
definition parent :: "int \<Rightarrow> int \<Rightarrow> int" where
  "parent l c = l + (c - l - 1) div 2"

definition l_child :: "int \<Rightarrow> int \<Rightarrow> int" where
  "l_child l p = 2 * p - l + 1"

definition r_child :: "int \<Rightarrow> int \<Rightarrow> int" where
  "r_child l p = 2 * p - l + 2"

subsubsection \<open>Lemmas\<close>
lemma parent_upper_bound: "parent l c < c \<longleftrightarrow> l \<le> c"
  unfolding parent_def by auto

lemma parent_upper_bound_alt: "l \<le> parent l c \<Longrightarrow> parent l c < c"
  unfolding parent_def by simp

lemma parent_lower_bound: "l \<le> parent l c \<longleftrightarrow> l < c"
  unfolding parent_def by linarith

lemma grand_parent_upper_bound: "parent l (parent l c) < c \<longleftrightarrow> l \<le> c"
  unfolding parent_def by linarith

corollary parent_bounds: "l < x \<Longrightarrow> x < r \<Longrightarrow> bounded l r (parent l x)"
  using parent_lower_bound parent_upper_bound_alt by fastforce

lemma l_child_lower_bound: " p < l_child l p \<longleftrightarrow> l \<le> p"
  unfolding l_child_def by simp

corollary l_child_lower_bound_alt: "l \<le> x \<Longrightarrow> x \<le> p \<Longrightarrow> x < l_child l p"
  using l_child_lower_bound[of p l] by linarith

lemma parent_l_child[simp]: "parent l (l_child l n) = n"
  unfolding parent_def l_child_def by simp

lemma r_child_lower_bound: "l \<le> p \<Longrightarrow> p < r_child l p"
  unfolding r_child_def by simp

corollary r_child_lower_bound_alt: "l \<le> x \<Longrightarrow> x \<le> p \<Longrightarrow> x < r_child l p"
  using r_child_lower_bound[of l p] by linarith

lemma parent_r_child[simp]: "parent l (r_child l n) = n"
  unfolding parent_def r_child_def by simp

lemma smaller_l_child: "l_child l x < r_child l x"
  unfolding l_child_def r_child_def by simp

lemma parent_two_children:
  "(c = l_child l p \<or> c = r_child l p) \<longleftrightarrow> parent l c = p"
  unfolding parent_def l_child_def r_child_def by linarith

subsection \<open>Heap Invariants\<close>
subsubsection \<open>Definitions\<close>
text \<open>The following heap invariants and the following lemmas are parameterised with an arbitrary
      (transitive) comparison function. For the concrete function implementations at the end of
      this submission \<open>\<le>\<close> on ints is used.\<close>

text \<open>For the \<open>make_heap\<close> function, which transforms an unordered array into a valid heap,
      the notion of a partial heap is needed. Here the heap invariant only holds for array indices
      between a certain valid array index \<open>m\<close> and \<open>r\<close>. The standard heap invariant is then
      simply the special case where \<open>m = l\<close>.\<close>
definition is_partial_heap
  :: "('a::order \<Rightarrow> 'a::order \<Rightarrow> bool) \<Rightarrow> (int \<Rightarrow> 'a::order) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" where
  "is_partial_heap cmp heap l m r = (\<forall> x. bounded m r x \<longrightarrow>
               bounded m r (parent l x) \<longrightarrow> cmp (heap (parent l x)) (heap x))"

abbreviation is_heap
  :: "('a::order \<Rightarrow> 'a::order \<Rightarrow> bool) \<Rightarrow> (int \<Rightarrow> 'a::order) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" where
  "is_heap cmp heap l r \<equiv> is_partial_heap cmp heap l l r"

text \<open>During all of the modifying heap functions the heap invariant is temporarily violated at
      a single index \<open>i\<close> and it is then gradually restored by either \<open>sift_down\<close> or
      \<open>sift_up\<close>. The following definitions formalize these weakened invariants.

      The second part of the conjunction in the following definitions states, that the comparison
      between the parent of \<open>i\<close> and each of the children of \<open>i\<close> evaluates to \<open>True\<close> without
      explicitly using the child relations.\<close>
definition is_partial_heap_except_down
  :: "('a::order \<Rightarrow> 'a::order \<Rightarrow> bool) \<Rightarrow> (int \<Rightarrow> 'a::order) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" where
  "is_partial_heap_except_down cmp heap l m r i = (\<forall> x. bounded m r x \<longrightarrow>
    ((parent l x \<noteq> i \<longrightarrow> bounded m r (parent l x) \<longrightarrow> cmp (heap (parent l x)) (heap x)) \<and>
     (parent l x = i \<longrightarrow> bounded m r (parent l (parent l x))
                     \<longrightarrow> cmp (heap (parent l (parent l x))) (heap x))))"

abbreviation is_heap_except_down
  :: "('a::order \<Rightarrow> 'a::order \<Rightarrow> bool) \<Rightarrow> (int \<Rightarrow> 'a::order) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" where
  "is_heap_except_down cmp heap l r i \<equiv> is_partial_heap_except_down cmp heap l l r i"

text \<open>As mentioned the notion of a partial heap is only needed for \<open>make_heap\<close>,
      which only uses \<open>sift_down\<close> internally, so there doesn't need to be an additional
      definition for the partial heap version of the \<open>sift_up\<close> invariant.\<close>
definition is_heap_except_up
  :: "('a::order \<Rightarrow> 'a::order \<Rightarrow> bool) \<Rightarrow> (int \<Rightarrow> 'a::order) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" where
  "is_heap_except_up cmp heap l r i = (\<forall> x. bounded l r x \<longrightarrow>
    ((x \<noteq> i \<longrightarrow> bounded l r (parent l x) \<longrightarrow> cmp (heap (parent l x)) (heap x)) \<and>
     (parent l x = i \<longrightarrow> bounded l r (parent l (parent l x))
                     \<longrightarrow> cmp (heap (parent l (parent l x))) (heap x))))"

subsubsection \<open>Lemmas\<close>

lemma empty_partial_heap[simp]: "is_partial_heap cmp heap l r r"
  unfolding is_partial_heap_def by linarith

lemma is_partial_heap_smaller_back:
  "is_partial_heap cmp heap l m r \<Longrightarrow> r' \<le> r \<Longrightarrow> is_partial_heap cmp heap l m r'"
  unfolding is_partial_heap_def by simp

lemma is_partial_heap_smaller_front:
  "is_partial_heap cmp heap l m r \<Longrightarrow> m \<le> m' \<Longrightarrow> is_partial_heap cmp heap l m' r"
  unfolding is_partial_heap_def by simp

text \<open>The second half of each array is a is a partial binary heap, since it contains only leafs,
      which are all trivial binary heaps.\<close>
lemma snd_half_is_partial_heap:
  "(l + r) div 2 \<le> m \<Longrightarrow> is_partial_heap cmp heap l m r"
  unfolding is_partial_heap_def parent_def by linarith

lemma modify_outside_partial_heap:
  assumes
    "heap = heap' on {m..<r}"
    "is_partial_heap cmp heap l m r"
  shows "is_partial_heap cmp heap' l m r"
  using assms eq_onD unfolding is_partial_heap_def by fastforce

text \<open>The next few lemmas formalize how the heap invariant is weakened, when the heap is modified
      in a certain way.\<close>

text \<open>This lemma is used by \<open>make_heap\<close>.\<close>
lemma partial_heap_added_first_el:
  assumes
    "l \<le> m" "m \<le> r"
    "is_partial_heap cmp heap l (m + 1) r"
  shows "is_partial_heap_except_down cmp heap l m r m"
 unfolding is_partial_heap_except_down_def
proof
  fix x
  let ?p_x = "parent l x"
  let ?gp_x = "parent l ?p_x"
  show "bounded m r x \<longrightarrow>
        (?p_x \<noteq> m \<longrightarrow> bounded m r ?p_x \<longrightarrow> cmp (heap ?p_x) (heap x)) \<and>
        (?p_x = m \<longrightarrow> bounded m r ?gp_x \<longrightarrow> cmp (heap ?gp_x) (heap x))"
  proof
    assume x_bound: "bounded m r x"
    have p_x_lower: "?p_x \<noteq> m \<longrightarrow> bounded m r ?p_x \<longrightarrow> ?p_x \<ge> m + 1"
      by simp
    hence "?p_x \<noteq> m \<longrightarrow> bounded m r ?p_x \<longrightarrow> x \<ge> m + 1"
      using parent_upper_bound[of l x] x_bound assms(1) by linarith
    hence p_invariant: "(?p_x \<noteq> m \<longrightarrow> bounded m r ?p_x \<longrightarrow> cmp (heap ?p_x) (heap x))"
      using assms(3) is_partial_heap_def p_x_lower x_bound by blast

    have gp_up_bound: "(?p_x = m \<longrightarrow> ?gp_x < m)"
      by (simp add: assms(1) parent_upper_bound)
    show "(?p_x \<noteq> m \<longrightarrow> bounded m r ?p_x \<longrightarrow> cmp (heap ?p_x) (heap x)) \<and>
          (?p_x = m \<longrightarrow> bounded m r ?gp_x \<longrightarrow> cmp (heap ?gp_x) (heap x))"
      using gp_up_bound p_invariant by linarith
  qed
qed

text \<open>This lemma is used by \<open>del_min\<close>.\<close>
lemma heap_changed_first_el:
  assumes "is_heap cmp heap l r" "l \<le> r"
  shows "is_heap_except_down cmp (heap(l := b)) l r l"
proof -
  have "is_partial_heap cmp heap l (l + 1) r"
    using assms(1) is_partial_heap_smaller_front by fastforce
  hence "is_partial_heap cmp (heap(l := b)) l (l + 1) r"
    using modify_outside_partial_heap[of heap] by simp
  thus ?thesis
    by (simp add: assms(2) partial_heap_added_first_el)
qed

text \<open>This lemma is used by \<open>insert\<close>.\<close>

subsubsection \<open>First Heap Element\<close>
text \<open>The next step is to show that the first element of the heap is always the ``smallest''
      according to the given comparison function. For the proof a rule for strong induction on lower
      bounded integers is needed. Its proof is based on the proof of strong induction on natural
      numbers found in \<^cite>\<open>"Str_Ind"\<close>.\<close>
lemma strong_int_gr_induct_helper:
  assumes "k < (i::int)" "(\<And>i. k < i \<Longrightarrow> (\<And>j. k < j \<Longrightarrow> j < i \<Longrightarrow> P j) \<Longrightarrow> P i)"
  shows "\<And>j. k < j \<Longrightarrow> j < i \<Longrightarrow> P j"
  using assms
proof(induction i rule: int_gr_induct)
  case base
  then show ?case by linarith
next
  case (step i)
  then show ?case
  proof(cases "j = i")
    case True
    then show ?thesis using step.IH step.prems(1,3) by blast
  next
    case False
    hence "j < i" using step.prems(2) by simp
    then show ?thesis using step.IH step.prems(1,3) by blast
  qed
qed

theorem strong_int_gr_induct:
  assumes
    "k < (i::int)"
    "(\<And>i. k < i \<Longrightarrow> (\<And>j. k < j \<Longrightarrow> j < i \<Longrightarrow> P j) \<Longrightarrow> P i)"
  shows "P i"
  using assms less_induct strong_int_gr_induct_helper by blast

text \<open>Now the main theorem, that the first heap element is the ``smallest'' according to the
      given comparison function, can be proven.\<close>
theorem heap_first_el:
  assumes
    "is_heap cmp heap l r"
    "transp cmp"
    "l < x" "x < r"
  shows "cmp (heap l) (heap x)"
  using assms unfolding is_partial_heap_def
proof(induction x rule: strong_int_gr_induct[of l])
  case 1
  then show ?case using assms(3) by simp
next
  case (2 i)
  have cmp_pi_i: "cmp (heap (parent l i)) (heap i)"
    using "2.hyps" "2.prems"(1,4) parent_bounds by simp
  then show ?case
  proof(cases)
    assume "parent l i > l"
    then have "cmp (heap l) (heap (parent l i))"
      using "2.IH" "2.prems"(1,2,4) parent_upper_bound_alt by simp
    then show ?thesis
      using "2.prems"(2) cmp_pi_i transpE by metis
  next
    assume "\<not> parent l i > l"
    then have "parent l i = l"
      using "2.hyps" dual_order.order_iff_strict parent_lower_bound by metis
    then show ?thesis
      using cmp_pi_i by simp
  qed
qed

section \<open>General Lemmas on Arrays\<close>
text \<open>Some additional lemmas on @{const "mset_ran"}, @{const "swap"} and @{const "eq_on"} are needed
      for the final proofs.\<close>

subsection \<open>Lemmas on @{const "mset_ran"}\<close>
abbreviation arr_mset :: "(int \<Rightarrow> 'a) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> 'a multiset" where
  "arr_mset arr l r \<equiv> mset_ran arr {l..<r}"

lemma in_mset_imp_in_array:
  "x \<in># (arr_mset arr l r) \<longleftrightarrow> (\<exists>i. bounded l r i \<and> arr i = x)"
  unfolding mset_ran_def by fastforce

lemma arr_mset_remove_last:
  "l \<le> r \<Longrightarrow> arr_mset arr l r = arr_mset arr l (r + 1) - {#arr r#}"
  by (simp add: intvs_upper_decr mset_ran_def)

lemma arr_mset_append:
  "l \<le> r \<Longrightarrow> arr_mset arr l (r + 1) = arr_mset arr l r + {#arr r#}"
  using arr_mset_remove_last[of l r arr] by simp

corollary arr_mset_append_alt:
  "l \<le> r \<Longrightarrow> arr_mset (arr(r := b)) l (r + 1) = arr_mset arr l r + {#b#}"
  by (simp add: arr_mset_append mset_ran_subst_outside)

lemma arr_mset_remove_first:
  "i \<le> r \<Longrightarrow> arr_mset arr (i - 1) r = arr_mset arr i r + {#arr (i - 1)#}"
  by(induction r rule: int_ge_induct) (auto simp add: arr_mset_append)

lemma arr_mset_split:
  assumes "l \<le> m" "m \<le> r"
  shows "arr_mset arr l r = arr_mset arr l m + arr_mset arr m r"
  using assms
proof(induction m rule: int_ge_induct[of l])
  case (step i)
  have add_last: "arr_mset arr l (i + 1) = arr_mset arr l i + {#arr i#}"
    using step arr_mset_append by blast
  have rem_first: "arr_mset arr (i+1) r = arr_mset arr i r - {#arr i#}"
    by (metis step.prems arr_mset_remove_first add_diff_cancel_right')
  show ?case
    using step add_last rem_first by fastforce
qed (simp)

text \<open>That the first element in a heap is the ``smallest'', can now be expressed using multisets.\<close>
corollary heap_first_el_alt:
  assumes
    "transp cmp"
    "is_heap cmp heap l r"
    "x \<in># (arr_mset heap l r)"
    "heap l \<noteq> x"
  shows "cmp (heap l) x"
  by(metis assms heap_first_el in_mset_imp_in_array le_less)

subsection \<open>Lemmas on @{term "swap"} and @{term "eq_on"}\<close>

lemma eq_on_subset:
  "arr1 = arr2 on R \<Longrightarrow> S \<subseteq> R \<Longrightarrow> arr1 = arr2 on S"
  by (simp add: eq_on_def set_mp)

lemma swap_swaps:
  "arr' = swap arr x y \<Longrightarrow> arr' y = arr x \<and> arr' x = arr y"
  unfolding swap_def by simp

lemma swap_only_swaps:
  "arr' = swap arr x y \<Longrightarrow> z \<noteq> x \<Longrightarrow> z \<noteq> y \<Longrightarrow> arr' z = arr z"
  unfolding swap_def by simp

lemma swap_commute: "swap arr x y = swap arr y x"
  unfolding swap_def by fastforce

lemma swap_eq_on:
  "arr1 = arr2 on S \<Longrightarrow> x \<notin> S \<Longrightarrow> y \<notin> S \<Longrightarrow> arr1 = swap arr2 x y on S"
  unfolding swap_def by simp

corollary swap_parent_eq_on:
  assumes
    "arr1 = arr2 on - {l..<r}"
    "l < c" "c < r"
  shows "arr1 = swap arr2 (parent l c) c on - {l..<r} "
  using parent_bounds swap_eq_on assms by fastforce

corollary swap_child_eq_on:
  assumes
    "arr1 = arr2 on - {l..<r}"
    "c = l_child l p \<or> c = r_child l p"
    "l \<le> p" "c < r"
  shows "arr1 = swap arr2 p c on - {l..<r} "
  by (metis assms parent_lower_bound parent_two_children swap_parent_eq_on)

lemma swap_child_mset:
  assumes
    "arr_mset arr1 l r = arr_mset arr2 l r"
    "c = l_child l p \<or> c = r_child l p"
    "l \<le> p" "c < r"
  shows "arr_mset arr1 l r = arr_mset (swap arr2 p c) l r"
proof -
  have child_bounded: "l < c \<and> c < r"
    by (metis assms(2-4) parent_lower_bound parent_two_children)
  have parent_bounded: "bounded l r p"
    by (metis assms(2-4) dual_order.strict_trans parent_two_children parent_upper_bound_alt)
  thus ?thesis
    using assms(1) child_bounded mset_ran_swap[of p "{l..<r}" c arr2] atLeastLessThan_iff
    by simp
qed

text \<open>The following lemma shows, which propositions have to hold on the pre-swap array, so that
      a comparison between two elements holds on the post-swap array. This is useful for the
      proofs of the loop invariants of \<open>sift_up\<close> and \<open>sift_down\<close>. The lemma is kept
      quite general (except for the argument order) and could probably be more closely
      related to the parent relation for more concise proofs.\<close>
lemma cmp_swapI:
  fixes arr::"'a::order \<Rightarrow> 'a::order"
  assumes
    "m < n \<and> x < y"
    "m < n \<and> x < y \<Longrightarrow> x = m \<Longrightarrow> y = n \<Longrightarrow> P (arr n) (arr m)"
    "m < n \<and> x < y \<Longrightarrow> x \<noteq> m \<Longrightarrow> x \<noteq> n \<Longrightarrow> y \<noteq> m \<Longrightarrow> y \<noteq> n \<Longrightarrow> P (arr m) (arr n)"
    "m < n \<and> x < y \<Longrightarrow> x = m \<Longrightarrow> y \<noteq> m \<Longrightarrow> y \<noteq> n \<Longrightarrow>  P (arr y) (arr n)"
    "m < n \<and> x < y \<Longrightarrow> x = n \<Longrightarrow> y \<noteq> m \<Longrightarrow> y \<noteq> n \<Longrightarrow>  P (arr m) (arr y)"
    "m < n \<and> x < y \<Longrightarrow> x \<noteq> m \<Longrightarrow> x \<noteq> n \<Longrightarrow> y = n \<Longrightarrow> P (arr m) (arr x)"
    "m < n \<and> x < y \<Longrightarrow> x \<noteq> m \<Longrightarrow> x \<noteq> n \<Longrightarrow> y = m \<Longrightarrow> P (arr x) (arr n)"
  shows "P (swap arr x y m) (swap arr x y n)"
  by (metis assms order.asym swap_only_swaps swap_swaps)

section \<open>Imperative Heap Implementation\<close>
text \<open>The following imperative heap functions are based on \<^cite>\<open>"MS"\<close> and \<^cite>\<open>"CLRS"\<close>. All functions,
      that are recursive in these books, are iterative in the following implementations. The
      function definitions are done with IMP2 \<^cite>\<open>"IMP2-AFP"\<close>. From now on the heaps only contain
      ints and only use \<open>\<le>\<close> as comparison function. The auxiliary lemmas used from now on are
      heavily modeled after the proof goals, that are generated by the vcg tool (also part of IMP2).\<close>

subsection \<open>Simple Functions\<close>
subsubsection \<open>Parent, Children and Swap\<close>
text \<open>In this section the parent and children relations are expressed as IMP2 procedures.
      Additionally a simple procedure, that swaps two array elements, is defined.\<close>
procedure_spec prnt (l, x) returns p
  assumes True
    ensures "p = parent l\<^sub>0 x\<^sub>0"
  defines \<open>p = ((x - l - 1) / 2 + l)\<close>
  by vcg (simp add: parent_def)

procedure_spec left_child (l, x) returns lc
  assumes True
    ensures "lc = l_child l\<^sub>0 x\<^sub>0"
  defines \<open>lc = 2 * x - l + 1\<close>
  by vcg (simp add: l_child_def)

procedure_spec right_child (l, x) returns rc
  assumes True
    ensures "rc = r_child l\<^sub>0 x\<^sub>0"
  defines \<open>rc = 2 * x - l + 2\<close>
  by vcg (simp add: r_child_def)

procedure_spec swp (heap, x, y) returns heap
  assumes True
    ensures "heap = swap heap\<^sub>0 x\<^sub>0 y\<^sub>0 "
  defines \<open>tmp = heap[x]; heap[x] = heap[y]; heap[y] = tmp\<close>
  by vcg (simp add: swap_def)

subsubsection \<open>\<open>get_min\<close>\<close>
text \<open>In this section \<open>get_min\<close> is defined, which simply returns the first element (the minimum) of
      the heap. For this definition an additional theorem is proven, which enables the use of
      @{const "Min_mset"} in the postcondition.\<close>

theorem heap_minimum:
  assumes
    "l < r"
    "is_heap (\<le>) heap l r"
  shows "heap l = Min_mset (arr_mset heap l r)"
proof -
  have "(\<forall>x \<in># (arr_mset heap l r). (heap l) \<le> x)"
    using assms(2) heap_first_el_alt transp_on_le by blast
  thus ?thesis
    by (simp add: assms(1) dual_order.antisym)
qed

procedure_spec get_min (heap, l, r) returns min
  assumes "l < r \<and> is_heap (\<le>) heap l r"
    ensures "min = Min_mset (arr_mset heap\<^sub>0 l\<^sub>0 r\<^sub>0)"
  for heap[] l r
  defines \<open>min = heap[l]\<close>
  by vcg (simp add: heap_minimum)

subsection \<open>Modifying Functions\<close>

subsubsection \<open>\<open>sift_up\<close> and \<open>insert\<close>\<close>
text \<open>The next heap function is \<open>insert\<close>, which internally uses \<open>sift_up\<close>. In the beginning of
      this section \<open>sift_up_step\<close> is proven, which states that each \<open>sift_up\<close> loop iteration
      correctly transforms the weakened heap invariant. For its proof two additional
      auxiliary lemmas are used. After \<open>sift_up_step\<close> \<open>sift_up\<close> and then \<open>insert\<close> are verified.\<close>

text \<open>\<open>sift_up_step\<close> can be proven directly by the smt-solver without auxiliary lemmas, but they
      were introduced to show the proof details. The analogous proofs for \<open>sift_down\<close> were
      just solved with smt, since the proof structure should be very similar, even though the
      \<open>sift_down\<close> proof goals are slightly more complex.\<close>
lemma sift_up_step_aux1:
  fixes heap::"int \<Rightarrow> int"
  assumes
    "is_heap_except_up (\<le>) heap l r x"
    "parent l x \<ge> l"
    "(heap x) \<le> (heap (parent l x))"
    "bounded l r k"
    "k \<noteq> (parent l x)"
    "bounded l r (parent l k)"
  shows "(swap heap (parent l x) x (parent l k)) \<le> (swap heap (parent l x) x k)"
  apply(intro cmp_swapI[of "(parent l k)" k "(parent l x)" x "(\<le>)" heap])
  subgoal using assms(2,6) parent_upper_bound_alt by blast
  subgoal using assms(3) by blast
  subgoal using assms(1,4,6) unfolding is_heap_except_up_def by blast
  subgoal using assms(1,3,4,6) unfolding is_heap_except_up_def by fastforce
  subgoal using assms(5) by blast
  subgoal by blast
  subgoal using assms(1,2,4) unfolding is_heap_except_up_def by simp
  done

lemma sift_up_step_aux2:
  fixes heap::"int \<Rightarrow> int"
  assumes
    "is_heap_except_up (\<le>) heap l r x"
    "parent l x \<ge> l"
    "heap x \<le> (heap (parent l x))"
    "bounded l r k"
    "parent l k = parent l x"
    "bounded l r (parent l (parent l k))"
  shows
    "swap heap (parent l x) x (parent l (parent l k)) \<le> swap heap (parent l x) x k"
  using assms unfolding is_heap_except_up_def
proof-
  let ?gp_k = "parent l (parent l k)"
  let ?gp_x = "parent l (parent l x)"
  have gp_k_eq_gp_x: "swap heap (parent l x) x ?gp_k = heap ?gp_x"
    by (metis assms(2,5) grand_parent_upper_bound less_irrefl swap_only_swaps)
  show ?thesis
      using assms unfolding is_heap_except_up_def
  proof(cases)
    assume k_eq_x: "k = x"
    have "swap heap (parent l x) x k = heap (parent l x)"
      by (metis k_eq_x swap_swaps)
    then show ?thesis
      using assms(1,2,4,6) unfolding is_heap_except_up_def
      by (metis gp_k_eq_gp_x k_eq_x parent_bounds parent_lower_bound)
  next
    assume k_neq_x: "k \<noteq> x"
    have "swap heap (parent l x) x k = heap k"
      by (metis assms(5) gp_k_eq_gp_x k_neq_x swap_only_swaps)
    then show ?thesis using assms unfolding is_heap_except_up_def
      by (metis gp_k_eq_gp_x k_neq_x order_trans parent_bounds parent_lower_bound)
  qed
qed

lemma sift_up_step:
  fixes heap::"int \<Rightarrow> int"
  assumes
    "is_heap_except_up (\<le>) heap l r x"
    "parent l x \<ge> l"
    "(heap x) \<le> (heap (parent l x))"
  shows "is_heap_except_up (\<le>) (swap heap (parent l x) x) l r (parent l x)"
  using assms sift_up_step_aux1 sift_up_step_aux2
  unfolding is_heap_except_up_def by blast

text \<open>\<open>sift_up\<close> restores the heap invariant, that is only violated at the current position, by
      iteratively swapping the current element with its parent until the beginning of the array is
      reached or the current element is bigger than its parent.\<close>
procedure_spec sift_up (heap, l, r, x) returns heap
  assumes "is_heap_except_up (\<le>) heap l r x \<and> bounded l r x"
    ensures "is_heap (\<le>) heap l\<^sub>0 r\<^sub>0 \<and>
             arr_mset heap\<^sub>0 l\<^sub>0 r\<^sub>0 = arr_mset heap l\<^sub>0 r\<^sub>0 \<and>
             heap\<^sub>0 = heap on - {l\<^sub>0..<r\<^sub>0}"
  for heap[] l x r
  defines \<open>
    p = prnt(l, x);
    while (x > l \<and> heap[x] \<le> heap[p])
      @variant \<open>x - l\<close>
      @invariant \<open>is_heap_except_up (\<le>) heap l r x \<and> p = parent l x \<and>
                  bounded l r x \<and> arr_mset heap\<^sub>0 l\<^sub>0 r\<^sub>0 = arr_mset heap l r \<and>
                  heap\<^sub>0 = heap  on - {l..<r}\<close>
    {
        heap = swp(heap, p, x);
        x = p;
        p = prnt(l, x)
    }\<close>
  apply vcg_cs
  apply(intro conjI)
  subgoal using parent_lower_bound sift_up_step by blast
  subgoal using parent_lower_bound by blast
  subgoal using parent_bounds by blast
  subgoal using parent_bounds by (simp add: mset_ran_swap)
  subgoal using swap_parent_eq_on by blast
  subgoal using parent_upper_bound by simp
  subgoal unfolding is_heap_except_up_def is_partial_heap_def
    by (metis le_less not_less parent_lower_bound)
  done

text \<open>\<open>insert\<close> inserts an element into a heap by appending it to the heap and restoring the heap
      invariant with @{const "sift_up"}.\<close>
procedure_spec insert (heap, l, r, el) returns (heap, l, r)
  assumes "is_heap (\<le>) heap l r \<and> l \<le> r"
    ensures "is_heap (\<le>) heap l r \<and>
             arr_mset heap l r = arr_mset heap\<^sub>0 l\<^sub>0 r\<^sub>0 + {#el\<^sub>0#} \<and>
             l = l\<^sub>0 \<and> r = r\<^sub>0 + 1  \<and> heap\<^sub>0 = heap on - {l..<r}"
  for heap l r el
  defines \<open>
    heap[r] = el;
    x = r;
    r = r + 1;
    heap = sift_up(heap, l, r, x)
  \<close>
  apply vcg_cs
  subgoal by (simp add: heap_appended_el)
  subgoal by (metis arr_mset_append_alt add_mset_add_single)
  done

subsubsection \<open>\<open>sift_down\<close>, \<open>del_min\<close> and \<open>make_heap\<close>\<close>
text \<open>The next heap functions are \<open>del_min\<close> and \<open>make_heap\<close>, which both use \<open>sift_down\<close> to
      restore/establish the heap invariant. \<open>sift_down\<close> is proven first (this time without
      additional auxiliary lemmas) followed by \<open>del_min\<close> and \<open>make_heap\<close>.\<close>

text \<open>\<open>sift_down\<close> restores the heap invariant, that is only violated at the current position, by
      iteratively swapping the current element with its smallest child until the end of
      the array is reached or the current element is smaller than its children.\<close>
procedure_spec sift_down(heap, l, r, x) returns heap
  assumes "is_partial_heap_except_down (\<le>) heap l x r x \<and> l \<le> x \<and> x \<le> r"
    ensures "is_partial_heap (\<le>) heap l\<^sub>0 x\<^sub>0 r\<^sub>0 \<and>
             arr_mset heap\<^sub>0 l\<^sub>0 r\<^sub>0 = arr_mset heap l\<^sub>0 r\<^sub>0 \<and>
             heap\<^sub>0 = heap on - {l\<^sub>0..<r\<^sub>0}"
  defines \<open>
   lc = left_child(l, x);
   rc = right_child(l, x);
    while (lc < r \<and> (heap[lc] < heap[x] \<or> (rc < r \<and> heap[rc] < heap[x])))
      @variant \<open>r - x\<close>
      @invariant \<open>is_partial_heap_except_down (\<le>) heap l x\<^sub>0 r x \<and>
                  x\<^sub>0 \<le> x \<and> x \<le> r \<and> lc = l_child l x \<and> rc = r_child l x \<and>
                  arr_mset heap\<^sub>0 l r = arr_mset heap l r \<and>
                  heap\<^sub>0 = heap on - {l..<r}\<close>
  {
    smallest = lc;
    if (rc < r \<and> heap[rc] < heap[lc]) {
      smallest = rc
    };
    heap = swp(heap, x, smallest);
    x = smallest;
    lc = left_child(l, x);
    rc = right_child(l, x)
  }\<close>
  apply vcg_cs
  subgoal
    apply(intro conjI)
    subgoal unfolding is_partial_heap_except_down_def
      by (smt parent_two_children swap_swaps swap_only_swaps
          swap_commute parent_upper_bound_alt)
    subgoal using r_child_lower_bound_alt by fastforce
    subgoal using swap_child_mset order_trans by blast
    subgoal using swap_child_eq_on by fastforce
    done
  subgoal
    by (meson less_le_trans not_le order.asym r_child_lower_bound)
  subgoal
    apply(intro conjI)
    subgoal unfolding is_partial_heap_except_down_def
      by (smt parent_two_children swap_swaps swap_only_swaps
          swap_commute parent_upper_bound_alt)
    subgoal using l_child_lower_bound_alt by fastforce
    subgoal using swap_child_mset order_trans by blast
    subgoal using swap_child_eq_on by fastforce
    done
  subgoal
    by (meson less_le_trans not_le order.asym l_child_lower_bound)
  subgoal unfolding is_partial_heap_except_down_def is_partial_heap_def
    by (metis dual_order.strict_trans not_less parent_two_children smaller_l_child)
  done

text \<open>\<open>del_min\<close> needs an additional lemma which shows, that it actually removes (only) the minimum
      from the heap.\<close>
lemma del_min_mset:
  fixes heap::"int \<Rightarrow> int"
  assumes
    "l < r"
    "is_heap (\<le>) heap l r"
    "mod_heap = heap(l := heap (r - 1))"
    "arr_mset mod_heap l (r - 1) = arr_mset new_heap l (r - 1)"
  shows
    "arr_mset new_heap l (r - 1) = arr_mset heap l r - {#Min_mset (arr_mset heap l r)#}"
proof -
  let ?heap_mset = "arr_mset heap l r"
  have l_is_min: "heap l = Min_mset ?heap_mset"
    using assms(1,2) heap_minimum by blast
  have "(arr_mset mod_heap l r) = ?heap_mset + {#heap (r-1)#} - {#heap l#}"
    by (simp add: assms(1,3) mset_ran_subst_inside)
  hence "(arr_mset mod_heap l (r - 1)) = ?heap_mset - {#heap l#}"
    by (simp add: assms(1,3) arr_mset_remove_last)
  thus ?thesis
    using assms(4) l_is_min by simp
qed

text \<open>\<open>del_min\<close> removes the minimum element from the heap by replacing the first element with the
      last element, shrinking the array by one and subsequently restoring the heap invariant
      with @{const "sift_down"}.\<close>
procedure_spec del_min (heap, l, r) returns (heap, l, r)
  assumes "l < r \<and> is_heap (\<le>) heap l r"
    ensures "is_heap (\<le>) heap l r \<and>
             arr_mset heap l r = arr_mset heap\<^sub>0 l\<^sub>0 r\<^sub>0 - {#Min_mset (arr_mset heap\<^sub>0 l\<^sub>0 r\<^sub>0)#} \<and>
             l = l\<^sub>0 \<and> r = r\<^sub>0 - 1 \<and>
             heap\<^sub>0 = heap on - {l\<^sub>0..<r\<^sub>0}"
  for heap l r
  defines \<open>
    r = r - 1;
    heap[l] = heap[r];
    heap = sift_down(heap, l, r, l)
  \<close>
  apply vcg_cs
  subgoal by (simp add: heap_changed_first_el is_partial_heap_smaller_back)
  subgoal
    apply(rule conjI)
    subgoal using del_min_mset by blast
    subgoal by (simp add: eq_on_def intvs_incdec(3) intvs_lower_incr)
    done
  done

text \<open>\<open>make_heap\<close> transforms an arbitrary array into a heap by iterating through all array
      positions from the middle of the array up to the beginning of the array and calling
      @{const "sift_down"} for each one.\<close>
procedure_spec make_heap (heap, l, r) returns heap
  assumes "l \<le> r"
    ensures "is_heap (\<le>) heap l\<^sub>0 r\<^sub>0 \<and>
             arr_mset heap l\<^sub>0 r\<^sub>0 = arr_mset heap\<^sub>0 l\<^sub>0 r\<^sub>0 \<and>
             heap\<^sub>0 = heap on - {l\<^sub>0..< r\<^sub>0}"
  for heap[] l r
  defines \<open>
    y = (r + l)/2 - 1;
    while (y \<ge> l)
          @variant \<open>y - l + 1\<close>
          @invariant \<open>is_partial_heap (\<le>) heap l (y + 1) r \<and>
                      arr_mset heap l r = arr_mset heap\<^sub>0 l\<^sub>0 r\<^sub>0 \<and>
                      l - 1 \<le> y \<and> y < r \<and> heap\<^sub>0 = heap on - {l..<r}\<close>
    {
      heap = sift_down(heap, l, r, y);
      y = y - 1
    }\<close>
  apply(vcg_cs)
  subgoal
    apply(rule conjI)
    subgoal by (simp add: snd_half_is_partial_heap add.commute)
    subgoal by linarith
    done
  subgoal using partial_heap_added_first_el le_less by blast
  subgoal using eq_on_trans by blast
  subgoal using dual_order.antisym by fastforce
  done

subsection \<open>Heapsort Implementation\<close>

text \<open>The final part of this submission is the implementation of the in-place heapsort. Firstly it
      builds the \<open>\<le>\<close>-heap and then it iteratively removes the minimum of the heap, which is put at
      the now vacant end of the shrinking heap. This is done until the heap is empty, which leaves
      the array sorted in descending order.\<close>
subsubsection \<open>Auxiliary Lemmas\<close>
text \<open>Firstly the notion of a sorted array is needed. This is more or less the same as
      @{const "ran_sorted"} generalized for arbitrary comparison functions.\<close>
definition array_is_sorted :: "(int \<Rightarrow> int \<Rightarrow> bool) \<Rightarrow>  (int \<Rightarrow> int) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" where
  "array_is_sorted cmp a l r \<equiv> \<forall>i. \<forall>j. bounded l r i \<longrightarrow> bounded l r j \<longrightarrow> i < j \<longrightarrow> cmp (a i) (a j)"

text \<open>This lemma states, that the heapsort doesn't change the elements contained in the array during
      the loop iterations.\<close>
lemma heap_sort_mset_step:
  fixes arr::"int \<Rightarrow> int"
  assumes
    "l < m" "m \<le> r"
    "arr_mset arr' l (m - 1) = arr_mset arr l m - {#Min_mset (arr_mset arr l m)#}"
    "arr = arr' on - {l..<m}"
    "mod_arr = arr'(m - 1 := Min_mset (arr_mset arr l m))"
  shows "arr_mset arr l r = arr_mset mod_arr l r"
proof -
  let ?min = "{#Min_mset (arr_mset arr l m)#}"
  let ?new_arr_mset = "arr_mset mod_arr"
  have middle: "?new_arr_mset (m - 1) m = ?min"
    by (simp add: assms(5))
  have first_half: "?new_arr_mset l (m - 1) = arr_mset arr l m - ?min"
    by (simp add: assms(3,5) mset_ran_subst_outside)
  hence "?new_arr_mset l m = ?new_arr_mset l (m - 1) + ?new_arr_mset (m - 1) m"
    by (metis assms(1,3,5) diff_add_cancel middle arr_mset_append_alt zle_diff1_eq)
  hence first_half_middle: "?new_arr_mset l m = arr_mset arr l m"
    using middle first_half assms(1) by simp

  hence "mod_arr = arr on - {l..<m}"
    using assms(1,4,5) eq_on_sym eq_on_trans by auto
  then have second_half: "arr_mset arr m r = arr_mset mod_arr m r"
    by (simp add: eq_on_def mset_ran_cong)

  then show ?thesis
    by (metis arr_mset_split assms(1,2) first_half_middle le_less)
qed

text \<open>This lemma states, that each loop iteration leaves the growing second half of the array
      sorted in descending order.\<close>
lemma heap_sort_second_half_sorted_step:
  fixes arr::"int \<Rightarrow> int"
  assumes
    "l\<^sub>0 < m" "m \<le> r\<^sub>0"
    "arr = arr' on - {l\<^sub>0..<m}"
    "\<forall>i. \<forall>j. bounded m r\<^sub>0 i \<longrightarrow> bounded m r\<^sub>0 j \<longrightarrow>  i < j \<longrightarrow> arr j \<le> arr i"
    "\<forall>x\<in>#arr_mset arr l\<^sub>0 m. \<forall>y\<in>#arr_mset arr m r\<^sub>0. \<not> x < y"
    "bounded (m - 1) r\<^sub>0 i"
    "bounded (m - 1) r\<^sub>0 j"
    "i < j"
    "mod_arr = (arr'(m - 1 := Min_mset (arr_mset arr l\<^sub>0 m)))"
  shows "mod_arr j \<le> mod_arr i"
proof -
  have second_half_eq: "mod_arr = arr on {m..< r\<^sub>0}"
    using assms(3, 9) unfolding eq_on_def by simp
  have j_stricter_bound: "bounded m r\<^sub>0 j"
    using assms(6-8) by simp
  then have el_at_j: "mod_arr j \<in># arr_mset arr m r\<^sub>0"
    using eq_onD second_half_eq by fastforce
  then show ?thesis
  proof(cases)
    assume "i = (m-1)"
    then have "mod_arr i \<in># arr_mset arr l\<^sub>0 m"
      by (simp add: assms(1, 9))
    then show ?thesis
      using assms(5) el_at_j not_less by blast
  next
    assume "i \<noteq> (m-1)"
    then have "bounded m r\<^sub>0 i"
      using assms(6) by simp
    then show ?thesis
      using assms(4, 8) eq_on_def j_stricter_bound second_half_eq by force
  qed
qed

text \<open>The following lemma shows that all elements in the first part of the array (the binary heap)
      are bigger than the elements in the second part (the sorted part) after every iteration. This
      lemma and the invariant of the \<open>heap_sort\<close> loop use \<open>\<not> x < y\<close> instead of \<open>x \<ge> y\<close> since
      \<open>vcg_cs\<close> doesn't terminate in the latter case.\<close>
lemma heap_sort_fst_part_bigger_snd_part_step:
  fixes arr::"int \<Rightarrow> int"
  assumes
    "l\<^sub>0 < m"
    "m \<le> r\<^sub>0"
    "arr_mset arr' l\<^sub>0 (m - 1) = arr_mset arr l\<^sub>0 m - {#Min_mset (arr_mset arr l\<^sub>0 m)#}"
    "arr = arr' on - {l\<^sub>0..<m}"
    "\<forall>x\<in>#arr_mset arr l\<^sub>0 m. \<forall>y\<in>#arr_mset arr m r\<^sub>0. \<not> x < y"
    "mod_arr = arr'(m - 1 := Min_mset (arr_mset arr l\<^sub>0 m))"
    "x\<in>#arr_mset mod_arr l\<^sub>0 (m - 1)"
    "y\<in>#arr_mset mod_arr (m - 1) r\<^sub>0"
  shows "\<not> x < y"
proof -
  have "{m..<r\<^sub>0} \<subseteq> - {l\<^sub>0..<m}"
    by auto
  hence "arr' = arr on {m..<r\<^sub>0}"
    using assms(4) eq_on_sym eq_on_subset by blast
  hence arr_eq_on: "mod_arr = arr on {m..<r\<^sub>0}"
    by (simp add: assms(6))
  hence same_mset: "arr_mset mod_arr m r\<^sub>0 = arr_mset arr m r\<^sub>0"
    using mset_ran_cong by blast
  have "x \<in># arr_mset arr l\<^sub>0 m" using same_mset assms
    by (metis assms(3,6,7) add_mset_remove_trivial_eq lran_upd_outside(2)
        mset_lran cancel_ab_semigroup_add_class.diff_right_commute
        diff_single_trivial multi_self_add_other_not_self order_refl)
  then have x_bigger_min: "x \<ge> Min_mset (arr_mset arr l\<^sub>0 m)"
    using Min_le by blast
  have y_smaller_min: "y \<le> Min_mset (arr_mset arr l\<^sub>0 m)"
  proof(cases "y = mod_arr (m - 1)")
    case False
    hence "y\<in>#arr_mset mod_arr (m - 1) r\<^sub>0 - {#mod_arr (m - 1)#}"
      by (metis assms(8) diff_single_trivial insert_DiffM insert_noteq_member)
    then have "y\<in>#arr_mset arr m r\<^sub>0"
      by (simp add: assms(2) intvs_decr_l mset_ran_insert same_mset)
    then show ?thesis
      using assms(1) assms(5) by fastforce
  qed (simp add: assms(6))
  then show ?thesis
    using x_bigger_min by linarith
qed

subsubsection \<open>Implementation\<close>
text \<open>Now finally the correctness of the \<open>heap_sort\<close> is shown. As mentioned, it starts by
      transforming the array into a minimum heap using @{const "make_heap"}. Then in each
      iteration it removes the first element from the heap with @{const "del_min"} after its value
      was retrieved with @{const "get_min"}. This value is then put at the position freed by
      @{const "del_min"}.\<close>
program_spec heap_sort
  assumes "l \<le> r"
    ensures "array_is_sorted (\<ge>) arr l\<^sub>0 r\<^sub>0 \<and>
             arr_mset arr\<^sub>0 l\<^sub>0 r\<^sub>0 = arr_mset arr l\<^sub>0 r\<^sub>0 \<and>
             arr\<^sub>0 = arr on - {l\<^sub>0 ..<r\<^sub>0 } \<and> l = l\<^sub>0 \<and> r = r\<^sub>0"
  for l r arr[]
  defines \<open>
    arr = make_heap(arr, l, r);
    m = r;
    while (m > l)
      @variant \<open>m - l + 1\<close>
      @invariant \<open>is_heap (\<le>) arr l m \<and>
        array_is_sorted (\<ge>) arr m r\<^sub>0 \<and>
        (\<forall>x \<in># arr_mset arr l\<^sub>0 m. \<forall>y \<in># arr_mset arr m r\<^sub>0. \<not> x < y) \<and>
        arr_mset arr\<^sub>0 l\<^sub>0 r\<^sub>0 = arr_mset arr l\<^sub>0 r\<^sub>0 \<and>
        l \<le> m \<and> m \<le> r\<^sub>0 \<and> l = l\<^sub>0 \<and> arr\<^sub>0 = arr on - {l\<^sub>0 ..<r\<^sub>0}\<close>
    {
      min = get_min(arr, l, m);
      (arr, l, m) = del_min(arr, l, m);
      arr[m] = min
    }
  \<close>
  apply vcg_cs
  subgoal unfolding array_is_sorted_def by simp
  subgoal
    apply(intro conjI)
    subgoal unfolding is_partial_heap_def by simp
    subgoal unfolding array_is_sorted_def using heap_sort_second_half_sorted_step
      by blast
    subgoal using heap_sort_fst_part_bigger_snd_part_step by blast
    subgoal using heap_sort_mset_step by blast
    subgoal unfolding eq_on_def
      by (metis ComplD ComplI atLeastLessThan_iff less_le_trans)
    done
  done
end


(*  Title:      ZF/ex/BinEx.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge

Examples of performing binary arithmetic by simplification.
*)

theory BinEx imports ZF begin
(*All runtimes below are on a 300MHz Pentium*)

lemma "#13  $+  #19 = #32"
by simp (*0 secs*)

lemma "#1234  $+  #5678 = #6912"
by simp (*190 msec*)

lemma "#1359  $+  #-2468 = #-1109"
by simp (*160 msec*)

lemma "#93746  $+  #-46375 = #47371"
by simp (*300 msec*)

lemma "$- #65745 = #-65745"
by simp (*80 msec*)

(* negation of ~54321 *)
lemma "$- #-54321 = #54321"
by simp (*90 msec*)

lemma "#13  $*  #19 = #247"
by simp (*110 msec*)

lemma "#-84  $*  #51 = #-4284"
by simp (*210 msec*)

(*The worst case for 8-bit operands *)
lemma "#255  $*  #255 = #65025"
by simp (*730 msec*)

lemma "#1359  $*  #-2468 = #-3354012"
by simp (*1.04 secs*)

(** Comparisons **)

lemma "(#89) $* #10 \<noteq> #889"
by simp

lemma "(#13) $< #18 $- #4"
by simp

lemma "(#-345) $< #-242 $+ #-100"
by simp

lemma "(#13557456) $< #18678654"
by simp

lemma "(#999999) $\<le> (#1000001 $+ #1) $- #2"
by simp

lemma "(#1234567) $\<le> #1234567"
by simp

(*** Quotient and remainder!! [they could be faster] ***)

lemma "#23 zdiv #3 = #7"
by simp

lemma "#23 zmod #3 = #2"
by simp

(** negative dividend **)

lemma "#-23 zdiv #3 = #-8"
by simp

lemma "#-23 zmod #3 = #1"
by simp

(** negative divisor **)

lemma "#23 zdiv #-3 = #-8"
by simp

lemma "#23 zmod #-3 = #-1"
by simp

(** Negative dividend and divisor **)

lemma "#-23 zdiv #-3 = #7"
by simp

lemma "#-23 zmod #-3 = #-2"
by simp

end


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

datatype ('a, 'b) pair = pair2 "'a" "'b"

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

fun select :: "'a => (('a, ('a list)) pair) list =>
               (('a, ('a list)) pair) list" where
"select x (nil2) = nil2"
| "select x (cons2 (pair2 y2 ys) x2) =
     cons2 (pair2 y2 (cons2 x ys)) (select x x2)"

fun select2 :: "'a list => (('a, ('a list)) pair) list" where
"select2 (nil2) = nil2"
| "select2 (cons2 y xs) =
     cons2 (pair2 y xs) (select y (select2 xs))"

fun formula :: "(('a, ('a list)) pair) list =>
                ('a list) list" where
"formula (nil2) = nil2"
| "formula (cons2 (pair2 y2 ys) z) =
     cons2 (cons2 y2 ys) (formula z)"

fun elem :: "'a => 'a list => bool" where
"elem x (nil2) = False"
| "elem x (cons2 z xs) = ((z = x) | (elem x xs))"

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
"deleteBy x y (nil2) = nil2"
| "deleteBy x y (cons2 y2 ys) =
     (if (x y) y2 then ys else cons2 y2 (deleteBy x y ys))"

fun isPermutation :: "'a list => 'a list => bool" where
"isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z x2) = False"
| "isPermutation (cons2 x3 xs) y =
     ((elem x3 y) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 y)))"

fun all :: "('a => bool) => 'a list => bool" where
"all p (nil2) = True"
| "all p (cons2 y xs) = ((p y) & (all p xs))"

theorem property0 :
  "all
     (% (x :: 'a list) => isPermutation x xs) (formula (select2 xs))"
  oops

end


theory VecSum_tests
imports
  test_utils
  VecSum
begin

subsection \<open>Test Values\<close>

definition l1 :: "float list" where
  "l1 = [
    float_of_int 43,
    float_of_int 34538,
    float_of_int 3 / float_of_int 44,
    float_of_int 0,
    float_of_int 0,
    float_of_int (-348976754389282980)]"
  (* result:
  [Float.Float (- 5452761787332007) 6, Float.Float 723951696777 (- 35),
  Float.Float 0 0, Float.Float 0 0, Float.Float (- 146313) (- 56), Float.Float 0 0]
  *)

definition l2 :: "float list" where
  "l2 = [
    float_of_int 3,
    float_of_int 6,
    float_of_int 44,
    float_of_int 2 / float_of_int 5,
    float_of_int 1 / float_of_int 23]"
  (* result:
  [Float.Float 7521500899407355 (- 47), Float.Float 89 (- 55), Float.Float 13 (- 53),
  Float.Float 0 0, Float.Float 0 0]
  *)

definition l3 :: "float list" where
  "l3 = [
    float_of_int 3452345234533456344,
    float_of_int 3,
    float_of_int 5 / float_of_int 325432345453464552
  ]"
  (* result:
    [Float.Float 6742861786198157 9, Float.Float 4985960341560939 (- 108), 3]
  *)

value "let (a, b) = (float_of_int 345234523, float_of_int 34)
  in fst (twoSum (a, b)) \<doteq> hd (vecSum [a, b])
  \<and> snd (twoSum (a, b)) \<doteq> last (vecSum [a, b])"

subsection \<open>Printing\<close>

--\<open>convert hardware floats to Float.float for an exact representation\<close>
abbreviation toNF :: "float \<Rightarrow> Float.float" where
  "toNF \<equiv> normfloat o toFloat"

(* print to the output panel *)
value "map toNF (vecSum l1)"
value "map toNF (vecSum l2)"
value "map toNF (vecSum l3)"

(* alternative: print to raw output *)
value [code] "let
  _ = println (STR ''Test 1:'');
  _ = map (println_sw_float o toFloat) (vecSum l1);
  _ = println (STR ''Test 2:'');
  _ = map (println_sw_float o toFloat) (vecSum l2);
  _ = println (STR ''Test 3:'');
  _ = map (println_sw_float o toFloat) (vecSum l3)
  in println (STR ''Done.'')"

subsection \<open>Testing against another implementation\<close>

fun VecSum_Joldes_et_al :: "float list \<Rightarrow> float list" where
  "VecSum_Joldes_et_al [] = []"
| "VecSum_Joldes_et_al [a] = [a]"
| "VecSum_Joldes_et_al (a0 # a1 # as) = (let
    (s, e) = twoSum (a0, a1) in
    (e # VecSum_Joldes_et_al (s # as)))"

definition t_a where "t_a = vecSum l1"
definition t_b where "t_b = VecSum_Joldes_et_al l1"

value "map (\<lambda>(x, y). x \<doteq> y) (zip t_a (last t_b # butlast (t_b)))"
(* ToDo: replace by lemma *)

type_synonym mpf = "float \<times> float list"

fun TwoSum_component :: "float \<Rightarrow> mpf \<Rightarrow> mpf" where
  "TwoSum_component f (a, es) = (let
    (x, y) = twoSum (f, a)
  in (x, y # es))"

fun gmtoll :: "mpf \<Rightarrow> float \<Rightarrow> mpf" where
  "gmtoll (a, es) f = foldr TwoSum_component (a # es) (f, [])"

fun build_mpf :: "float list \<Rightarrow> mpf" where
  "build_mpf [] = undefined" |
  "build_mpf (f # fs) = foldl gmtoll (f, []) fs"

abbreviation "l4 \<equiv> map float_of_int [456, 44, 2, -4463456345534634635, 25, 43534, 65]"
abbreviation "l4' \<equiv> map float_of_int [456, 44, 2, -4463456345534634635, 25, 43534]"
abbreviation "l4'' \<equiv> map float_of_int [456, 44, 2, -4463456345534634635, 25]"
abbreviation "l4''' \<equiv> map float_of_int [456, 44, 2, -4463456345534634635]"
abbreviation "l5 \<equiv> map float_of_int [456, 44, 2]"

abbreviation "l \<equiv> l4"
abbreviation "mpf_out \<equiv> build_mpf l"
definition "out \<equiv> fst mpf_out # snd mpf_out"

definition "timing_test (_::unit) = build_mpf l4"

--\<open>Beware of the inexact representation\<close>
ML \<open>val timing_test_ml = @{code timing_test}\<close>
ML \<open>timing_test_ml ()\<close>
ML \<open>val build_mpf_ml = @{code build_mpf}\<close> (*ToDo: test nbuild_mpf *)
ML \<open>val test =  flat (replicate 100 [12.324245, 234.234, 12.234, 2345.0345])\<close>
ML \<open>build_mpf_ml test\<close>
ML \<open>timing_test_ml ()\<close>

value[code] out
ML \<open>@{code out}\<close>
value [code] "map (toNF) out"
value [code] "map (toNF) out ! 0"
value [code] "map (toNF) out ! 1"
value [code] "map (toNF) out ! 2"
value [code] "map (toNF) out ! 3"
value [code] "map (toNF) out ! 4"
value [code] "map (toNF) out ! 5"

declare twoSum.simps[simp del]

lemma "P mpf_out"
  apply (clarsimp split: prod.split)
  oops

lemma "P out"
  apply (clarsimp simp add: out_def split: prod.split)
  unfolding gmtoll.simps
  oops

end


theory PosRat
  imports Main HOL.Rat
begin

section Definitions

typedef prat = "{ r :: rat |r. r \<ge> 0}" by fastforce

setup_lifting type_definition_prat

lift_definition pwrite :: "prat" is "1" by simp
lift_definition pnone :: "prat" is "0" by simp
lift_definition half :: "prat" is "1 / 2" by fastforce

lift_definition pgte :: "prat \<Rightarrow> prat \<Rightarrow> bool" is "(\<ge>)" done
lift_definition pgt :: "prat \<Rightarrow> prat \<Rightarrow> bool" is "(>)" done
(* lift_definition lte :: "prat \<Rightarrow> prat \<Rightarrow> bool" is "(\<le>)" done *)
lift_definition lt :: "prat \<Rightarrow> prat \<Rightarrow> bool" is "(<)" done
lift_definition ppos :: "prat \<Rightarrow> bool" is "\<lambda>p. p > 0" done

lift_definition pmult :: "prat \<Rightarrow> prat \<Rightarrow> prat" is "(*)" by simp
lift_definition padd :: "prat \<Rightarrow> prat \<Rightarrow> prat" is "(+)" by simp

lift_definition pdiv :: "prat \<Rightarrow> prat \<Rightarrow> prat" is "(/)" by simp

lift_definition pmin :: "prat \<Rightarrow> prat \<Rightarrow> prat" is "(min)" by simp
lift_definition pmax :: "prat \<Rightarrow> prat \<Rightarrow> prat" is "(max)" by simp

section Lemmas

lemma pmin_comm:
  "pmin a b = pmin b a"
  by (metis Rep_prat_inverse min.commute pmin.rep_eq)

lemma pmin_greater:
  "pgte a (pmin a b)"
  by (simp add: pgte.rep_eq pmin.rep_eq)

lemma pmin_is:
  assumes "pgte a b"
  shows "pmin a b = b"
  by (metis Rep_prat_inject assms min_absorb2 pgte.rep_eq pmin.rep_eq)

lemma pmax_comm:
  "pmax a b = pmax b a"
  by (metis Rep_prat_inverse max.commute pmax.rep_eq)

lemma pmax_smaller:
  "pgte (pmax a b) a"
  by (simp add: pgte.rep_eq pmax.rep_eq)

lemma pmax_is:
  assumes "pgte a b"
  shows "pmax a b = a"
  by (metis Rep_prat_inject assms max.absorb_iff1 pgte.rep_eq pmax.rep_eq)

lemma pmax_is_smaller:
  assumes "pgte x a"
      and "pgte x b"
    shows "pgte x (pmax a b)"
proof (cases "pgte a b")
  case True
  then show ?thesis
    by (simp add: assms(1) pmax_is)
next
  case False
  then show ?thesis
    using assms(2) pgte.rep_eq pmax.rep_eq by auto
qed

lemma half_between_0_1:
  "ppos half \<and> pgt pwrite half"
  by (simp add: half.rep_eq pgt.rep_eq ppos.rep_eq pwrite.rep_eq)

lemma pgt_implies_pgte:
  assumes "pgt a b"
  shows "pgte a b"
  by (meson assms less_imp_le pgt.rep_eq pgte.rep_eq)

lemma half_plus_half:
  "padd half half = pwrite"
  by (metis Rep_prat_inject divide_less_eq_numeral1(1) dual_order.irrefl half.rep_eq less_divide_eq_numeral1(1) linorder_neqE_linordered_idom mult.right_neutral one_add_one padd.rep_eq pwrite.rep_eq ring_class.ring_distribs(1))

lemma padd_comm:
  "padd a b = padd b a"
  by (metis Rep_prat_inject add.commute padd.rep_eq)

lemma padd_asso:
  "padd (padd a b) c = padd a (padd b c)"
  by (metis Rep_prat_inverse group_cancel.add1 padd.rep_eq)

lemma p_greater_exists:
  "pgte a b \<longleftrightarrow> (\<exists>r. a = padd b r)"
proof (rule iffI)
  show "pgte a b \<Longrightarrow> \<exists>r. a = padd b r"
  proof -
    assume asm: "pgte a b"
    obtain aa bb where "aa = Rep_prat a" "bb = Rep_prat b"
      by simp
    then have "aa \<ge> bb" using asm
      using pgte.rep_eq by fastforce
    then obtain rr where "rr = aa - bb"
      by simp
    then have "a = padd b (Abs_prat rr)"
      by (metis Abs_prat_inverse Rep_prat_inject \<open>aa = Rep_prat a\<close> \<open>bb = Rep_prat b\<close> \<open>bb \<le> aa\<close> add.commute diff_add_cancel diff_ge_0_iff_ge mem_Collect_eq padd.rep_eq)
    then show "\<exists>r. a = padd b r" by blast
  qed
  show "\<exists>r. a = padd b r \<Longrightarrow> pgte a b"
    using Rep_prat padd.rep_eq pgte.rep_eq by force
qed

lemma pgte_antisym:
  assumes "pgte a b"
      and "pgte b a"
    shows "a = b"
  by (metis Rep_prat_inverse assms(1) assms(2) leD le_less pgte.rep_eq)

lemma greater_sum_both:
  assumes "pgte a (padd b c)"
  shows "\<exists>a1 a2. a = padd a1 a2 \<and> pgte a1 b \<and> pgte a2 c"
proof -
  obtain aa bb cc where "aa = Rep_prat a" "bb = Rep_prat b" "cc = Rep_prat c"
    by simp
  then have "aa \<ge> bb + cc"
    using assms padd.rep_eq pgte.rep_eq by auto
  then obtain x where "aa = bb + x" "x \<ge> cc"
    by (metis add.commute add_le_cancel_left diff_add_cancel)
  then show ?thesis
    by (metis assms order_refl p_greater_exists padd_asso pgte.rep_eq)
qed

lemma padd_cancellative:
  assumes "a = padd x b"
      and "a = padd y b"
    shows "x = y"
  by (metis Rep_prat_inject add_le_cancel_right assms(1) assms(2) leD less_eq_rat_def padd.rep_eq)

lemma not_pgte_charact:
  "\<not> pgte a b \<longleftrightarrow> pgt b a"
  by (meson not_less pgt.rep_eq pgte.rep_eq)

lemma pgte_pgt:
  assumes "pgt a b"
      and "pgte c d"
    shows "pgt (padd a c) (padd b d)"
  using assms(1) assms(2) padd.rep_eq pgt.rep_eq pgte.rep_eq by auto

lemma pmult_distr:
  "pmult a (padd b c) = padd (pmult a b) (pmult a c)"
  by (metis Rep_prat_inject distrib_left padd.rep_eq pmult.rep_eq)

lemma pmult_comm:
  "pmult a b = pmult b a"
  by (metis Rep_prat_inject mult.commute pmult.rep_eq)

lemma pmult_special:
  "pmult pwrite x = x"
  "pmult pnone x = pnone"
  apply (metis Rep_prat_inverse comm_monoid_mult_class.mult_1 pmult.rep_eq pwrite.rep_eq)
  by (metis Rep_prat_inverse mult_zero_left pmult.rep_eq pnone.rep_eq)

definition pinv where
  "pinv p = pdiv pwrite p"

lemma pinv_double_half:
  assumes "ppos p"
  shows "pmult half (pinv p) = pinv (padd p p)"
proof -
  have "(Fract 1 2) * ((Fract 1 1) / (Rep_prat p)) = (Fract 1 1) / (Rep_prat p + Rep_prat p)"
    by (metis (no_types, lifting) One_rat_def comm_monoid_mult_class.mult_1 divide_rat mult_2 mult_rat rat_number_expand(3) times_divide_times_eq)
  then show ?thesis
    by (metis Rep_prat_inject half.rep_eq mult_2 mult_numeral_1_right numeral_One padd.rep_eq pdiv.rep_eq pinv_def pmult.rep_eq pwrite.rep_eq times_divide_times_eq)
qed

lemma ppos_mult:
  assumes "ppos a"
      and "ppos b"
    shows "ppos (pmult a b)"
  using assms(1) assms(2) pmult.rep_eq ppos.rep_eq by auto

lemma padd_zero:
  "pnone = padd a b \<longleftrightarrow> a = pnone \<and> b = pnone"
  by (metis Rep_prat Rep_prat_inject add.right_neutral leD le_add_same_cancel2 less_eq_rat_def mem_Collect_eq padd.rep_eq pnone.rep_eq)

lemma ppos_add:
  assumes "ppos a"
  shows "ppos (padd a b)"
  by (metis Rep_prat Rep_prat_inject assms dual_order.strict_iff_order mem_Collect_eq padd_zero pnone.rep_eq ppos.rep_eq)

lemma pinv_inverts:
  assumes "pgte a b"
      and "ppos b"
    shows "pgte (pinv b) (pinv a)"
proof -
  have "Rep_prat a \<ge> Rep_prat b"
    using assms(1) pgte.rep_eq by auto
  then have "(Fract 1 1) / Rep_prat b \<ge> (Fract 1 1) / Rep_prat a"
    by (metis One_rat_def assms(2) frac_le le_numeral_extra(4) ppos.rep_eq zero_le_one)
  then show ?thesis
    by (simp add: One_rat_def pdiv.rep_eq pgte.rep_eq pinv_def pwrite.rep_eq)
qed

lemma pinv_pmult_ok:
  assumes "ppos p"
  shows "pmult p (pinv p) = pwrite"
proof -
  obtain r where "r = Rep_prat p" by simp
  then have "r * ((Fract 1 1) / r) = Fract 1 1"
    using assms ppos.rep_eq by force
  then show ?thesis
    by (metis One_rat_def Rep_prat_inject \<open>r = Rep_prat p\<close> pdiv.rep_eq pinv_def pmult.rep_eq pwrite.rep_eq)
qed

lemma pinv_pwrite:
  "pinv pwrite = pwrite"
  by (metis Rep_prat_inverse div_by_1 pdiv.rep_eq pinv_def pwrite.rep_eq)

lemma pmult_ppos:
  assumes "ppos a"
      and "ppos b"
    shows "ppos (pmult a b)"
  using assms(1) assms(2) pmult.rep_eq ppos.rep_eq by auto

lemma ppos_inv:
  assumes "ppos p"
  shows "ppos (pinv p)"
by (metis Rep_prat Rep_prat_inverse assms less_eq_rat_def mem_Collect_eq not_one_le_zero pinv_pmult_ok pmult_comm pmult_special(2) pnone.rep_eq ppos.rep_eq pwrite.rep_eq)

lemma pmin_pmax:
  assumes "pgte x (pmin a b)"
  shows "x = pmin (pmax x a) (pmax x b)"
proof (cases "pgte x a")
  case True
  then show ?thesis
    by (metis pmax_is pmax_smaller pmin_comm pmin_is)
next
  case False
  then show ?thesis
    by (metis assms not_pgte_charact pgt_implies_pgte pmax_is pmax_smaller pmin_comm pmin_is)
qed

definition comp_one where
  "comp_one p = (SOME r. padd p r = pwrite)"

lemma padd_comp_one:
  assumes "pgte pwrite x"
  shows "padd x (comp_one x) = pwrite"
  by (metis (mono_tags, lifting) assms comp_one_def p_greater_exists someI_ex)

lemma ppos_eq_pnone:
  "ppos p \<longleftrightarrow> p \<noteq> pnone"
  by (metis Rep_prat Rep_prat_inject dual_order.strict_iff_order mem_Collect_eq pnone.rep_eq ppos.rep_eq)

lemma pmult_order:
  assumes "pgte a b"
  shows "pgte (pmult p a) (pmult b p)"
  using assms p_greater_exists pmult_comm pmult_distr by force

lemma multiply_smaller_pwrite:
  assumes "pgte pwrite a"
      and "pgte pwrite b"
    shows "pgte pwrite (pmult a b)"
  by (metis assms(1) assms(2) p_greater_exists padd_asso pmult_order pmult_special(1))

lemma pmult_pdiv_cancel:
  assumes "ppos a"
  shows "pmult a (pdiv x a) = x"
  by (metis Rep_prat_inject assms divide_cancel_right dual_order.strict_iff_order nonzero_mult_div_cancel_left pdiv.rep_eq pmult.rep_eq ppos.rep_eq)

lemma pmult_padd:
  "pmult a (padd (pmult b x) (pmult c y)) = padd (pmult (pmult a b) x) (pmult (pmult a c) y)"
  by (metis Rep_prat_inject mult.assoc pmult.rep_eq pmult_distr)

lemma pdiv_smaller:
  assumes "pgte a b"
      and "ppos a"
  shows "pgte pwrite (pdiv b a)"
proof -
  let ?a = "Rep_prat a"
  let ?b = "Rep_prat b"
  have "?b / ?a \<le> 1"
    by (meson assms(1) assms(2) divide_le_eq_1_pos pgte.rep_eq ppos.rep_eq)
  then show ?thesis
    by (simp add: pdiv.rep_eq pgte.rep_eq pwrite.rep_eq)
qed

lemma sum_coeff:
  assumes "ppos a"
      and "ppos b"
    shows "padd (pdiv a (padd a b)) (pdiv b (padd a b)) = pwrite"
proof -
  let ?a = "Rep_prat a"
  let ?b = "Rep_prat b"
  have "(?a / (?a + ?b)) + (?b / (?a + ?b)) = 1"
    by (metis add_divide_distrib add_pos_pos assms(1) assms(2) less_irrefl ppos.rep_eq right_inverse_eq)
  then show ?thesis
    by (metis Rep_prat_inject padd.rep_eq pdiv.rep_eq pwrite.rep_eq)
qed

lemma padd_one_ineq_sum:
  assumes "padd a b = pwrite"
      and "pgte x aa"
      and "pgte x bb"
    shows "pgte x (padd (pmult a aa) (pmult b bb))"
  by (metis (mono_tags, lifting) Rep_prat assms(1) assms(2) assms(3) convex_bound_le mem_Collect_eq padd.rep_eq pgte.rep_eq pmult.rep_eq pwrite.rep_eq)

end


theory Check
  imports Submission
begin

theorem G_is_replicate: "(w \<in> G) \<Longrightarrow> \<exists>n. w = replicate n a @ replicate n b"
  by (rule Submission.G_is_replicate)

theorem replicate_G: "(w = replicate n a @ replicate n b) \<Longrightarrow> w \<in> G"
  by (rule Submission.replicate_G)

theorem execs_append: "\<And>s. execs (xs @ ys) s = execs ys (execs xs s)"
  by (rule Submission.execs_append)

theorem val_maxvar_same: "\<forall>n \<le> maxvar e. s n = s' n \<Longrightarrow> val e s = val e s'"
  by (rule Submission.val_maxvar_same)

theorem compiler_correct: "execs (cmp e (maxvar e + 1)) s 0 = val e (s o Suc)"
  by (rule Submission.compiler_correct)

end


theory IArray_Examples
imports "HOL-Library.IArray" "HOL-Library.Code_Target_Numeral"
begin

lemma "IArray [True,False] !! 1 = False"
by eval

lemma "IArray.length (IArray [[],[]]) = 2"
by eval

lemma "IArray.list_of (IArray [1,3::int]) = [1,3]"
by eval

lemma "IArray.list_of (IArray.of_fun (%n. n*n) 5) = [0,1,4,9,16]"
by eval

lemma "\<not> IArray.all (\<lambda>x. x > 2) (IArray [1,3::int])"
by eval

lemma "IArray.exists (\<lambda>x. x > 2) (IArray [1,3::int])"
by eval

fun sum2 :: "'a::monoid_add iarray \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a" where
"sum2 A n s = (if n=0 then s else sum2 A (n - 1) (s + A!!(n - 1)))"

definition sum :: "'a::monoid_add iarray \<Rightarrow> 'a" where
"sum A = sum2 A (IArray.length A) 0"

lemma "sum (IArray [1,2,3,4,5,6,7,8,9::int]) = 45"
by eval

end


theory Chapter13_5
imports Main
begin

unbundle lattice_syntax

text\<open>
\setcounter{exercise}{10}

\begin{exercise}
Take the Isabelle theories that define commands, big-step semantics,
annotated commands and the collecting semantics and extend them with a
nondeterministic choice construct. Start with Exercise~\ref{exe:IMP:OR}
and extend type \<open>com\<close>, then extend type \<open>acom\<close> with a
corresponding construct:
\begin{alltt}
  Or "'a acom" "'a acom" 'a     ("_ OR// _//{_}"  [60, 61, 0] 60)
\end{alltt}
Finally extend function \<open>Step\<close>. Update proofs as well.
Hint: think of \<open>OR\<close> as a nondeterministic conditional without a test.
\end{exercise}

\exercise
Prove the following lemmas in a detailed and readable style:
\<close>

lemma fixes x0 :: "'a :: order"
assumes "\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y"  and  "f q \<le> q"  and  "x0 \<le> q"
shows "(f ^^ i) x0 \<le> q"
(* your definition/proof here *)

lemma fixes x0 :: "'a :: order"
assumes "\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y" and "x0 \<le> f x0"
shows "(f ^^ i) x0 \<le> (f ^^ (i+1)) x0"
(* your definition/proof here *)

text\<open>
\endexercise

\exercise% needs lattice_syntax
Let @{typ 'a} be a complete lattice and
let \<open>f :: 'a \<Rightarrow> 'a\<close> be a monotone function.
Give a readable proof that if \<open>P\<close> is a set of pre-fixpoints of \<open>f\<close>
then @{term"\<Sqinter> P"} is also a pre-fixpoint of \<open>f\<close>:
\<close>

lemma fixes P :: "'a::complete_lattice set"
assumes "mono f" and "\<forall>p \<in> P. f p \<le> p"
shows "f(\<Sqinter> P) \<le> \<Sqinter> P"
(* your definition/proof here *)

text\<open>
Sledgehammer should give you a proof you can start from.
\endexercise
\<close>

end


theory VC_Condition
imports "HOL-Nominal.Nominal"
begin

text \<open>
  We give here two examples showing that if we use the variable
  convention carelessly in rule inductions, we might end
  up with faulty lemmas. The point is that the examples
  are not variable-convention compatible and therefore in the
  nominal data package one is protected from such bogus reasoning.
\<close>

text \<open>We define alpha-equated lambda-terms as usual.\<close>
atom_decl name

nominal_datatype lam =
    Var "name"
  | App "lam" "lam"
  | Lam "\<guillemotleft>name\<guillemotright>lam" ("Lam [_]._" [100,100] 100)

text \<open>
  The inductive relation 'unbind' unbinds the top-most
  binders of a lambda-term; this relation is obviously
  not a function, since it does not respect alpha-
  equivalence. However as a relation 'unbind' is ok and
  a similar relation has been used in our formalisation
  of the algorithm W.\<close>

inductive
  unbind :: "lam \<Rightarrow> name list \<Rightarrow> lam \<Rightarrow> bool" ("_ \<mapsto> _,_" [60,60,60] 60)
where
  u_var: "(Var a) \<mapsto> [],(Var a)"
| u_app: "(App t1 t2) \<mapsto> [],(App t1 t2)"
| u_lam: "t\<mapsto>xs,t' \<Longrightarrow> (Lam [x].t) \<mapsto> (x#xs),t'"

text \<open>
  We can show that Lam [x].Lam [x].Var x unbinds to [x,x],Var x
  and also to [z,y],Var y (though the proof for the second is a
  bit clumsy).\<close>

lemma unbind_lambda_lambda1:
  shows "Lam [x].Lam [x].(Var x)\<mapsto>[x,x],(Var x)"
by (auto intro: unbind.intros)

lemma unbind_lambda_lambda2:
  shows "Lam [x].Lam [x].(Var x)\<mapsto>[y,z],(Var z)"
proof -
  have "Lam [x].Lam [x].(Var x) = Lam [y].Lam [z].(Var z)"
    by (auto simp add: lam.inject alpha calc_atm abs_fresh fresh_atm)
  moreover
  have "Lam [y].Lam [z].(Var z) \<mapsto> [y,z],(Var z)"
    by (auto intro: unbind.intros)
  ultimately
  show "Lam [x].Lam [x].(Var x)\<mapsto>[y,z],(Var z)" by simp
qed

text \<open>Unbind is equivariant ...\<close>
equivariance unbind

text \<open>
  ... but it is not variable-convention compatible (see Urban,
  Berghofer, Norrish [2007]). This condition requires for rule u_lam to
  have the binder x not being a free variable in this rule's conclusion.
  Because this condition is not satisfied, Isabelle will not derive a
  strong induction principle for 'unbind' - that means Isabelle does not
  allow us to use the variable convention in induction proofs over 'unbind'.
  We can, however, force Isabelle to derive the strengthening induction
  principle and see what happens.\<close>

nominal_inductive unbind
  sorry

text \<open>
  To obtain a faulty lemma, we introduce the function 'bind'
  which takes a list of names and abstracts them away in
  a given lambda-term.\<close>

fun
  bind :: "name list \<Rightarrow> lam \<Rightarrow> lam"
where
  "bind [] t = t"
| "bind (x#xs) t = Lam [x].(bind xs t)"

text \<open>
  Although not necessary for our main argument below, we can
  easily prove that bind undoes the unbinding.\<close>

lemma bind_unbind:
  assumes a: "t \<mapsto> xs,t'"
  shows "t = bind xs t'"
using a by (induct) (auto)

text \<open>
  The next lemma shows by induction on xs that if x is a free
  variable in t, and x does not occur in xs, then x is a free
  variable in bind xs t. In the nominal tradition we formulate
  'is a free variable in' as 'is not fresh for'.\<close>

lemma free_variable:
  fixes x::"name"
  assumes a: "\<not>(x\<sharp>t)" and b: "x\<sharp>xs"
  shows "\<not>(x\<sharp>bind xs t)"
using a b
by (induct xs)
   (auto simp add: fresh_list_cons abs_fresh fresh_atm)

text \<open>
  Now comes the first faulty lemma. It is derived using the
  variable convention (i.e. our strong induction principle).
  This faulty lemma states that if t unbinds to x#xs and t',
  and x is a free variable in t', then it is also a free
  variable in bind xs t'. We show this lemma by assuming that
  the binder x is fresh w.r.t. to the xs unbound previously.\<close>

lemma faulty1:
  assumes a: "t\<mapsto>(x#xs),t'"
  shows "\<not>(x\<sharp>t') \<Longrightarrow> \<not>(x\<sharp>bind xs t')"
using a
by (nominal_induct t xs'\<equiv>"x#xs" t' avoiding: xs rule: unbind.strong_induct)
   (simp_all add: free_variable)

text \<open>
  Obviously this lemma is bogus. For example, in
  case Lam [x].Lam [x].(Var x) \<mapsto> [x,x],(Var x).
  As a result, we can prove False.\<close>

lemma false1:
  shows "False"
proof -
  fix x
  have "Lam [x].Lam [x].(Var x)\<mapsto>[x,x],(Var x)"
  and  "\<not>(x\<sharp>Var x)" by (simp_all add: unbind_lambda_lambda1 fresh_atm)
  then have "\<not>(x\<sharp>(bind [x] (Var x)))" by (rule faulty1)
  moreover
  have "x\<sharp>(bind [x] (Var x))" by (simp add: abs_fresh)
  ultimately
  show "False" by simp
qed

text \<open>
  The next example is slightly simpler, but looks more
  contrived than 'unbind'. This example, called 'strip' just
  strips off the top-most binders from lambdas.\<close>

inductive
  strip :: "lam \<Rightarrow> lam \<Rightarrow> bool" ("_ \<rightarrow> _" [60,60] 60)
where
  s_var: "(Var a) \<rightarrow> (Var a)"
| s_app: "(App t1 t2) \<rightarrow> (App t1 t2)"
| s_lam: "t \<rightarrow> t' \<Longrightarrow> (Lam [x].t) \<rightarrow> t'"

text \<open>
  The relation is equivariant but we have to use again
  sorry to derive a strong induction principle.\<close>

equivariance strip

nominal_inductive strip
  sorry

text \<open>
  The second faulty lemma shows that a variable being fresh
  for a term is also fresh for this term after striping.\<close>

lemma faulty2:
  fixes x::"name"
  assumes a: "t \<rightarrow> t'"
  shows "x\<sharp>t \<Longrightarrow> x\<sharp>t'"
using a
by (nominal_induct t t'\<equiv>t' avoiding: t' rule: strip.strong_induct)
   (auto simp add: abs_fresh)

text \<open>Obviously Lam [x].Var x is a counter example to this lemma.\<close>

lemma false2:
  shows "False"
proof -
  fix x
  have "Lam [x].(Var x) \<rightarrow> (Var x)" by (auto intro: strip.intros)
  moreover
  have "x\<sharp>Lam [x].(Var x)" by (simp add: abs_fresh)
  ultimately have "x\<sharp>(Var x)" by (simp only: faulty2)
  then show "False" by (simp add: fresh_atm)
qed

text \<open>A similar effect can be achieved by using naive inversion
  on rules.\<close>

lemma false3:
  shows "False"
proof -
  fix x
  have "Lam [x].(Var x) \<rightarrow> (Var x)" by (auto intro: strip.intros)
  moreover obtain y::"name" where fc: "y\<sharp>x" by (rule exists_fresh) (rule fin_supp)
  then have "Lam [x].(Var x) = Lam [y].(Var y)"
    by (simp add: lam.inject alpha calc_atm fresh_atm)
  ultimately have "Lam [y].(Var y) \<rightarrow> (Var x)" by simp
  then have "Var y \<rightarrow> Var x" using fc
    by (cases rule: strip.strong_cases[where x=y])
       (simp_all add: lam.inject alpha abs_fresh)
  then show "False" using fc
    by (cases) (simp_all add: lam.inject fresh_atm)
qed

text \<open>
  Moral: Who would have thought that the variable convention
  is in general an unsound reasoning principle.
\<close>

end