theory Ch2Prof
imports Complex_Main
begin

(*simplify the naming *)
declare [[names_short]]

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

lemma add_02: "add m 0 = m"
apply(induction m)
apply(auto)
done

thm add_02

lemma add_comm: "add x (add y z) = add (add x y) z"
  apply (induction x)
  apply (auto)
  done

lemma add_assoc0[simp]: "add m (Suc n) = Suc (add m n)"
apply (induction m)
apply (auto)
done

fun double :: "nat \<Rightarrow> nat" where
"double 0 = 0" | "double (Suc m) = add (Suc (Suc 0) ) (double m)"

value "double (2::nat)"

lemma double_0: "double m = add m m"
apply (induction m)
apply (auto)
done

(* List part *)
fun app:: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"app Nil ys = ys" | "app (Cons x xs) ys = Cons x (app xs ys)"

lemma app_Nil2 [simp]: "app xs Nil = xs"
  apply (induction xs)
  apply (auto)
done

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

lemma app_rev [simp]: "rev (app xs ys) = app (rev ys) (rev xs) "
  apply (induction xs)
  apply (auto)
done

fun count :: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
"count i (Cons x xs) = (if i = x then Suc (count i xs) else (count i xs)) " | "count i Nil = 0"

fun length :: "'a list \<Rightarrow> nat " where
"length (Cons x xs) = Suc (length xs)" | "length Nil = 0"

lemma count_lessThenLength : "count x xs \<le> length xs"
  apply (induction xs)
  apply (auto )
  done

fun snoc :: "'a list \<Rightarrow>'a \<Rightarrow> 'a list " where
"snoc Nil elem = (Cons elem Nil)" | "snoc (Cons v vs) el = Cons v (snoc vs el)"

fun reverse :: "'a list \<Rightarrow> 'a list "  where
"reverse (Cons v vs) = snoc (reverse vs)  v" | "reverse Nil = Nil"

lemma snoc_app [simp] : "snoc xs x = app xs (Cons x Nil)"
  apply (induction xs)
  apply (auto)
  done

(*This is a hack*)
lemma reverse_rev [simp]: "reverse xs = rev xs"
  apply (induction xs)
  apply (auto)
  done

lemma reverse_reverse : "reverse (reverse xs) = xs"
  apply (induction xs)
  apply (auto)
done

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

lemma sum_upto_short : "sum_upto n = n * (n +1 ) div 2 "
  apply (induction n)
  apply (auto )
  done

(* Tree definition *)

datatype 'a tree = Tip | Node "'a tree"  'a "'a tree"

fun mirror :: "'a tree \<Rightarrow> 'a tree" where
"mirror Tip = Tip" |
"mirror (Node l a r ) = Node (mirror r) a (mirror l)"

lemma "mirror (mirror t ) = t"
  apply (induction t)
  apply (auto)
  done

fun contents :: "'a tree \<Rightarrow> 'a list" where
"contents Tip = Nil" |
"contents (Node l a r ) = Cons a (app (contents l) (contents r))"

fun sum_tree :: "nat tree \<Rightarrow> nat" where
"sum_tree Tip = 0" |
"sum_tree (Node l a r ) = a + (sum_tree l) + (sum_tree r)"

fun sum_list :: "nat list \<Rightarrow> nat" where
"sum_list Nil = 0"|
"sum_list (Cons x xs) = x + sum_list xs"

lemma sum_list_app [simp] :"sum_list l1 + sum_list l2 = sum_list (app l1 l2) "
  apply (induction l1)
  apply (induction l2)
  apply (auto)
done

lemma sum_list_contents_eq_sum_tree: "sum_tree t = sum_list ( contents t )"
  apply (induction t rule: contents.induct)
  apply (auto)
  done

datatype 'a tree2 = Tip 'a | Node "'a tree2"  'a "'a tree2"

fun pre_order :: "'a tree2 \<Rightarrow> 'a list " where
"pre_order (Tip v) = Cons v Nil" |
"pre_order (Node l a r) = (Cons a (app (pre_order l) (pre_order r)))"

fun post_order :: "'a tree2 \<Rightarrow> 'a list " where
"post_order (Tip v) = Cons v Nil" |
"post_order (Node l a r ) = snoc (app (post_order l) (post_order r)) a"

fun mirror2 :: "'a tree2 \<Rightarrow> 'a tree2" where
"mirror2 (Tip v) = Tip v" | "mirror2 (Node l a r) = Node (mirror2 r) a (mirror2 l) "

lemma [simp] : "mirror2 (mirror2 t)= t"
  apply (induction t)
  apply (auto)
done

lemma app_nil2 [simp] : "app (Cons x Nil) (Cons y l2) = app (Cons x (Cons y Nil)) l2"
  apply (induction l2)
  apply (auto)
done

lemma "pre_order (mirror2 t) = rev (post_order t)"
  apply (induction t )
  apply (auto)
  done

(* Intersperse *)
fun intersperse :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"intersperse e []       = []" |
"intersperse e (x # []) = x # []" |
"intersperse e (x # xs) = x # e # (intersperse e xs)"

lemma "(map f (intersperse a xs)) = (intersperse (f a) (map f xs))"
  apply (induction xs rule:intersperse.induct)
  apply auto
done

(* rev *)
fun itrev :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"itrev []       ys = ys" |
"itrev (x # xs) ys = itrev xs (x # ys)"

lemma "itrev xs ys = rev xs @ ys"
  apply (induction xs arbitrary:ys)
  apply auto
  done

fun itadd :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"itadd (Suc m) n = itadd m (Suc n)" |
"itadd 0 n = n"

lemma "itadd m n = add m n"
  apply (induction m arbitrary: n)
  apply auto
  done

(* No Elem Tree*)
datatype tree0 = Tip | Node tree0 tree0

fun nodes:: "tree0 \<Rightarrow> nat" where
"nodes Tip = 1" |
"nodes (Node x y) = 1 + (nodes x) + (nodes y)"

fun explode :: "nat \<Rightarrow> tree0 \<Rightarrow> tree0 " where
"explode 0 t = t"|
"explode (Suc n) t = Node (explode n t) (explode n t)"

(*lemma explode_suc : "nodes (explode (Suc n) t ) = nodes (explode n (Node t t ))"
  apply auto
  done
*)

lemma explode_expand: "explode (Suc n) t = Node (explode n t) (explode n t)"

  apply (induction n)
  apply auto
  done

lemma "nodes(explode (Suc n) t ) = 1 + 2 * nodes (explode n t)"
  apply auto
  done

lemma "nodes (explode n t) =  (2^n - 1) + (2 ^ n) * nodes t"
  apply (induction n )
  apply auto
  done

(* arithmetic Example *)

datatype exp = Var | Const int | Add exp exp | Mult exp exp

fun eval :: "exp \<Rightarrow> int \<Rightarrow> int" where
"eval Var x = x" |
"eval (Const c) x = c" |
"eval (Add e1 e2) x = eval e1 x + eval e2 x" |
"eval (Mult e1 e2) x = eval e1 x * eval e2 x"

fun build_exp:: "int list \<Rightarrow> exp" where
"build_exp (x #xs) = Add (Const x) (Mult Var (build_exp xs))" |
"build_exp [] = Const 0"

fun evalp :: "int list  \<Rightarrow> int \<Rightarrow> int" where
"evalp is i = eval (build_exp is) i"

end


theory Ex1_4
  imports Main
begin

primrec first_pos :: "('a \<Rightarrow> bool)  \<Rightarrow> 'a list \<Rightarrow> nat" where
  "first_pos _ [] = 0"|
  "first_pos P (x#xs) = (if P x then 0 else (1 + first_pos P xs))"

value "first_pos (op = 3) [1::nat,3,5,3,1]"

value "first_pos (\<lambda>x .x  > 4 ) [1::nat , 3, 5, 7]"

value "first_pos (op < 1 o length ) [[] , [1,2], [3]]"
    (*thm Cons.hyps*)
  (*
lemma "\<forall>x. x \<in> set ls  \<and> (P x = False) \<Longrightarrow> first_pos P ls = length ls"
proof (induct ls)
  case Nil
  then show ?case by simp
  next
    case (Cons a ls)
    assume hyp1:"\<forall>x. x \<in> set ls \<and> P x = False \<Longrightarrow> first_pos P ls = length ls"
       and hyp2:"\<forall>x. x \<in> set (a # ls) \<and> P x = False"
    show ?case
    proof (cases "P a")
      case True
      assume a:"P a"
      show ?thesis using hyp2 and a by simp
    next
      case False
      assume a:"\<not> P a"
      show ?thesis
      proof (cases "a \<in> set ls")
        case True
        assume "a \<in> set ls"
        then show ?thesis using hyp1 hyp2 by fastforce
      next
        case False
        assume b:"a \<notin> set ls"
        from hyp2 have c:"\<forall>x . (x = a \<or> x \<in> set ls) \<and> P x = False" by simp
        then show ?thesis
      qed

    qed
qed
  *)
lemma "list_all (\<lambda>x. \<not> (P x)) xs \<Longrightarrow> first_pos P xs = length xs"   by (induct xs, auto)

lemma "list_all (\<lambda>x. \<not> P x) (take (first_pos P xs) xs)" by (induct xs , auto)

lemma "first_pos (\<lambda>x . P x \<or> Q x) xs = min (first_pos P xs) (first_pos Q xs)" by (induct xs , auto)
(*
lemma "let Q = (\<lambda>x. (x = 2) \<or> (x = 3) \<or> (x = 4)) ; P = (\<lambda>x . (x = 1) \<or> (x = 3) \<or> (x = 4)) ; xs = [1,2,3::nat] ; ys = [1,2,4::nat] in
      \<not>(\<exists>Fn . (first_pos (\<lambda>x . P x \<and> Q x) xs = Fn (first_pos P xs) (first_pos Q xs)) \<and> (first_pos (\<lambda>x . P x \<and> Q x) ys = Fn (first_pos P ys) (first_pos Q ys)))"
proof -
  *)

lemma  " max (first_pos P xs) (first_pos Q xs) \<le> first_pos (\<lambda> x . P x \<and> Q x) xs" by (induct xs , simp_all)
(*
lemma "\<forall>x  . P x \<longrightarrow> Q x \<Longrightarrow> first_pos P xs = first_pos (\<lambda>x . P x \<and> Q x) xs " by (induct xs , simp_all)
*)
lemma "\<forall>x . P x \<longrightarrow> Q x \<Longrightarrow> first_pos Q xs \<le> first_pos P xs" by (induct xs , simp_all)

primrec count :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> nat" where
  "count _ [] = 0"|
  "count P (x # xs) = (if P x then 1 else 0) + count P xs"

lemma helper : "count P (xs @ ys) = count P xs + count P ys" by (induct xs ; simp)

lemma "count P xs = count P (rev xs) " by (induct xs ;  simp add : helper)

lemma "count P xs = length (filter P xs)" by (induct xs;  simp add : helper)


section {*\isaheader{Implementing Unique Priority Queues by Annotated Lists}*}
theory PrioUniqueByAnnotatedList
imports
  "../spec/AnnotatedListSpec"
  "../spec/PrioUniqueSpec"
begin

text {*
  In this theory we use annotated lists to implement unique priority queues
  with totally ordered elements.

  This theory is written as a generic adapter from the AnnotatedList interface
  to the unique priority queue interface.

  The annotated list stores a sequence of elements annotated with
  priorities\footnote{Technically, the annotated list elements are of unit-type,
  and the annotations hold both, the priority queue elements and the priorities.
  This is required as we defined annotated lists to only sum up the elements
  annotations.}

  The monoids operations forms the maximum over the elements and
  the minimum over the priorities.
  The sequence of pairs is ordered by ascending elements' order.
  The insertion point for a new element, or the priority of an existing element
  can be found by splitting the
  sequence at the point where the maximum of the elements read so far gets
  bigger than the element to be inserted.

  The minimum priority can be read out as the sum over the whole sequence.
  Finding the element with minimum priority is done by splitting the sequence
  at the point where the minimum priority of the elements read so far becomes
  equal to the minimum priority of the whole sequence.
*}

subsection "Definitions"

subsubsection "Monoid"
datatype ('e, 'a) LP = Infty | LP 'e 'a

fun p_unwrap :: "('e,'a) LP \<Rightarrow> ('e \<times> 'a)" where
  "p_unwrap (LP e a) = (e , a)"

fun p_min :: "('e::linorder, 'a::linorder) LP \<Rightarrow> ('e, 'a) LP \<Rightarrow> ('e, 'a) LP"  where
  "p_min Infty Infty = Infty"|
  "p_min Infty (LP e a) = LP e a"|
  "p_min (LP e a) Infty = LP e a"|
  "p_min (LP e1 a) (LP e2 b) = (LP (max e1 e2) (min a b))"

fun e_less_eq :: "'e \<Rightarrow> ('e::linorder, 'a::linorder) LP \<Rightarrow> bool"  where
  "e_less_eq e Infty = False"|
  "e_less_eq e (LP e' _) = (e \<le> e')"

text_raw{*\paragraph{Instantiation of classes}\ \\*}
lemma p_min_re_neut[simp]: "p_min a Infty = a" by (induct a) auto
lemma p_min_le_neut[simp]: "p_min Infty a = a" by (induct a) auto
lemma p_min_asso: "p_min (p_min a b) c = p_min a (p_min b c)"
  apply(induct a b  rule: p_min.induct )
  apply (auto)
  apply (induct c)
  apply (auto)
apply (metis max.assoc)
apply (metis min.assoc)
  done

lemma lp_mono: "class.monoid_add p_min Infty" by  unfold_locales  (auto simp add: p_min_asso)

instantiation LP :: (linorder,linorder) monoid_add
begin
definition zero_def: "0 == Infty"
definition plus_def: "a+b == p_min a b"

instance by
  intro_classes
(auto simp add: p_min_asso zero_def plus_def)
end

fun p_less_eq :: "('e, 'a::linorder) LP \<Rightarrow> ('e, 'a) LP \<Rightarrow> bool" where
  "p_less_eq (LP e a) (LP f b) = (a \<le> b)"|
  "p_less_eq  _ Infty = True"|
  "p_less_eq Infty (LP e a) = False"

fun p_less :: "('e, 'a::linorder) LP \<Rightarrow> ('e, 'a) LP \<Rightarrow> bool" where
  "p_less (LP e a) (LP f b) = (a < b)"|
  "p_less (LP e a) Infty = True"|
  "p_less Infty _ = False"

lemma p_less_le_not_le : "p_less x y \<longleftrightarrow> p_less_eq x y \<and> \<not> (p_less_eq y x)"
  by (induct x y rule: p_less.induct) auto

lemma p_order_refl : "p_less_eq x x"
  by (induct x) auto

lemma p_le_inf : "p_less_eq Infty x \<Longrightarrow> x = Infty"
  by (induct x) auto

lemma p_order_trans : "\<lbrakk>p_less_eq x y; p_less_eq y z\<rbrakk> \<Longrightarrow> p_less_eq x z"
  apply (induct y z rule: p_less.induct)
  apply auto
  apply (induct x)
  apply auto
  apply (cases x)
  apply auto
  apply(induct x)
  apply (auto simp add: p_le_inf)
  apply (metis p_le_inf p_less_eq.simps(2))
  done

lemma p_linear2 : "p_less_eq x y \<or> p_less_eq y x"
  apply (induct x y rule: p_less_eq.induct)
  apply auto
  done

instantiation LP :: (type, linorder) preorder
begin
definition plesseq_def: "less_eq = p_less_eq"
definition pless_def: "less = p_less"

instance
  apply (intro_classes)
  apply (simp only: p_less_le_not_le pless_def plesseq_def)
  apply (simp only: p_order_refl plesseq_def pless_def)
  apply (simp only: plesseq_def)
  apply (metis p_order_trans)
  done

end

subsubsection "Operations"

definition aluprio_\<alpha> :: "('s \<Rightarrow> (unit \<times> ('e::linorder,'a::linorder) LP) list)
  \<Rightarrow> 's \<Rightarrow> ('e::linorder \<rightharpoonup>  'a::linorder)"
  where
  "aluprio_\<alpha> \<alpha> ft == (map_of (map p_unwrap (map snd (\<alpha> ft))))"

definition aluprio_invar :: "('s \<Rightarrow> (unit \<times> ('c::linorder, 'd::linorder) LP) list)
  \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> bool"
  where
  "aluprio_invar \<alpha> invar ft ==
     invar ft
     \<and> (\<forall> x\<in>set (\<alpha> ft). snd x\<noteq>Infty)
     \<and> sorted (map fst (map p_unwrap (map snd (\<alpha> ft))))
     \<and> distinct (map fst (map p_unwrap (map snd (\<alpha> ft)))) "

definition aluprio_empty  where
  "aluprio_empty empt = empt"

definition aluprio_isEmpty  where
  "aluprio_isEmpty isEmpty = isEmpty"

definition aluprio_insert ::
  "((('e::linorder,'a::linorder) LP \<Rightarrow> bool)
  \<Rightarrow> ('e,'a) LP \<Rightarrow> 's \<Rightarrow> ('s \<times> (unit \<times> ('e,'a) LP) \<times> 's))
    \<Rightarrow> ('s \<Rightarrow> ('e,'a) LP)
      \<Rightarrow> ('s \<Rightarrow> bool)
        \<Rightarrow> ('s \<Rightarrow> 's \<Rightarrow> 's)
          \<Rightarrow> ('s \<Rightarrow> unit \<Rightarrow> ('e,'a) LP \<Rightarrow> 's)
            \<Rightarrow> 's \<Rightarrow> 'e \<Rightarrow> 'a \<Rightarrow> 's"
  where
  "
  aluprio_insert splits annot isEmpty app consr s e a =
    (if e_less_eq e (annot s) \<and> \<not> isEmpty s
    then
      (let (l, (_,lp) , r) = splits (e_less_eq e) Infty s in
        (if e < fst (p_unwrap lp)
        then
          app (consr (consr l () (LP e a))  () lp) r
        else
          app (consr l () (LP e a)) r  ))
    else
      consr s () (LP e a))
  "

definition aluprio_pop :: "((('e::linorder,'a::linorder) LP \<Rightarrow> bool) \<Rightarrow> ('e,'a) LP
  \<Rightarrow> 's \<Rightarrow> ('s \<times> (unit \<times> ('e,'a) LP) \<times> 's))
    \<Rightarrow> ('s \<Rightarrow> ('e,'a) LP)
      \<Rightarrow> ('s \<Rightarrow> 's \<Rightarrow> 's)
        \<Rightarrow> 's
          \<Rightarrow> 'e \<times>'a \<times>'s"
  where
  "aluprio_pop splits annot app s =
    (let (l, (_,lp) , r) = splits (\<lambda> x. x \<le> (annot s)) Infty s
    in
      (case lp of
        (LP e a) \<Rightarrow>
          (e, a, app l r) ))"

definition aluprio_prio ::
  "((('e::linorder,'a::linorder) LP \<Rightarrow> bool) \<Rightarrow> ('e,'a) LP \<Rightarrow> 's
  \<Rightarrow> ('s \<times> (unit \<times> ('e,'a) LP) \<times> 's))
    \<Rightarrow> ('s \<Rightarrow> ('e,'a) LP)
      \<Rightarrow> ('s \<Rightarrow> bool)
        \<Rightarrow> 's \<Rightarrow> 'e \<Rightarrow> 'a option"
  where
  "
  aluprio_prio splits annot isEmpty s e =
    (if e_less_eq e (annot s) \<and> \<not> isEmpty s
    then
      (let (l, (_,lp) , r) = splits (e_less_eq e) Infty s in
        (if e = fst (p_unwrap lp)
        then
          Some (snd (p_unwrap lp))
        else
          None))
    else
      None)
  "

lemmas aluprio_defs =
aluprio_invar_def
aluprio_\<alpha>_def
aluprio_empty_def
aluprio_isEmpty_def
aluprio_insert_def
aluprio_pop_def
aluprio_prio_def

subsection "Correctness"

subsubsection "Auxiliary Lemmas"

lemma p_linear: "(x::('e, 'a::linorder) LP) \<le> y \<or> y \<le> x"
  by (unfold plesseq_def) (simp only: p_linear2)

lemma e_less_eq_mon1: "e_less_eq e x \<Longrightarrow> e_less_eq e (x + y)"
  apply (cases x)
  apply (auto simp add: plus_def)
  apply (cases y)
  apply (auto simp add: max.coboundedI1)
  done
lemma e_less_eq_mon2: "e_less_eq e y \<Longrightarrow> e_less_eq e (x + y)"
  apply (cases x)
  apply (auto simp add: plus_def)
  apply (cases y)
  apply (auto simp add: max.coboundedI2)
  done
lemmas e_less_eq_mon =
  e_less_eq_mon1
  e_less_eq_mon2

lemma p_less_eq_mon:
  "(x::('e::linorder,'a::linorder) LP) \<le> z \<Longrightarrow> (x + y) \<le> z"
  apply(cases y)
  apply(auto simp add: plus_def)
  apply (cases x)
  apply (cases z)
  apply (auto simp add: plesseq_def)
  apply (cases z)
  apply (auto simp add: min.coboundedI1)
  done

lemma e_less_eq_listsum:
  "\<lbrakk>\<not> e_less_eq e (listsum xs)\<rbrakk> \<Longrightarrow> \<forall>x \<in> set xs. \<not> e_less_eq e x"
proof (induct xs)
  case Nil thus ?case by simp
next
  case (Cons a xs)
  hence "\<not> e_less_eq e (listsum xs)" by (auto simp add: e_less_eq_mon)
  hence v1: "\<forall>x\<in>set xs. \<not> e_less_eq e x" using Cons.hyps by simp
  from Cons.prems have "\<not> e_less_eq e a" by (auto simp add: e_less_eq_mon)
  with v1 show "\<forall>x\<in>set (a#xs). \<not> e_less_eq e x" by simp
qed

lemma e_less_eq_p_unwrap:
  "\<lbrakk>x \<noteq> Infty;\<not> e_less_eq e x\<rbrakk> \<Longrightarrow> fst (p_unwrap x) < e"
  by (cases x) auto

lemma e_less_eq_refl :
  "b \<noteq> Infty \<Longrightarrow> e_less_eq (fst (p_unwrap b)) b"
  by (cases b) auto

lemma e_less_eq_listsum2:
  assumes
  "\<forall>x\<in>set (\<alpha>s). snd x \<noteq> Infty"
  "((), b) \<in> set (\<alpha>s)"
  shows "e_less_eq (fst (p_unwrap b)) (listsum (map snd (\<alpha>s)))"
  apply(insert assms)
  apply (induct "\<alpha>s")
  apply (auto simp add: zero_def e_less_eq_mon e_less_eq_refl)
  done

lemma e_less_eq_lem1:
  "\<lbrakk>\<not> e_less_eq e a;e_less_eq e (a + b)\<rbrakk> \<Longrightarrow> e_less_eq e b"
  apply (auto simp add: plus_def)
  apply (cases a)
  apply auto
  apply (cases b)
  apply auto
  apply (metis le_max_iff_disj)
  done

lemma p_unwrap_less_sum: "snd (p_unwrap ((LP e aa) + b)) \<le> aa"
  apply (cases b)
  apply (auto simp add: plus_def)
done

lemma  listsum_less_elems: "\<forall>x\<in>set xs. snd x \<noteq> Infty \<Longrightarrow>
  \<forall>y\<in>set (map snd (map p_unwrap (map snd xs))).
              snd (p_unwrap (listsum (map snd xs))) \<le> y"
    proof (induct xs)
    case Nil thus ?case by simp
    next
    case (Cons a as) thus ?case
      apply auto
      apply (cases "(snd a)" rule: p_unwrap.cases)
      apply auto
      apply (cases "listsum (map snd as)")
      apply auto
      apply (metis linorder_linear p_min_re_neut p_unwrap.simps
        plus_def[abs_def] snd_eqD)
      apply (auto simp add: p_unwrap_less_sum)
      apply (unfold plus_def)
      apply (cases "(snd a, listsum (map snd as))" rule: p_min.cases)
      apply auto
      apply (cases "map snd as")
      apply (auto simp add: infadd)
      apply (metis min.coboundedI2 snd_conv)
      done
qed

lemma distinct_sortet_list_app:
  "\<lbrakk>sorted xs; distinct xs; xs = as @ b # cs\<rbrakk>
  \<Longrightarrow> \<forall> x\<in> set cs. b < x"
  by (metis distinct.simps(2) distinct_append
    linorder_antisym_conv2 sorted_Cons sorted_append)

lemma distinct_sorted_list_lem1:
  assumes
  "sorted xs"
  "sorted ys"
  "distinct xs"
  "distinct ys"
  " \<forall> x \<in> set xs. x < e"
  " \<forall> y \<in> set ys. e < y"
  shows
  "sorted (xs @ e # ys)"
  "distinct (xs @ e # ys)"
proof -
  from assms (5,6)
  have "\<forall>x\<in>set xs. \<forall>y\<in>set ys. x \<le> y" by force
  thus "sorted (xs @ e # ys)"
    using assms
    by (auto simp add: sorted_append sorted_Cons)
  have "set xs \<inter> set ys = {}" using assms (5,6) by force
  thus "distinct (xs @ e # ys)"
    using assms
    by (auto simp add: distinct_append)
qed

lemma distinct_sorted_list_lem2:
  assumes
  "sorted xs"
  "sorted ys"
  "distinct xs"
  "distinct ys"
  "e < e'"
  " \<forall> x \<in> set xs. x < e"
  " \<forall> y \<in> set ys. e' < y"
  shows
  "sorted (xs @ e # e' # ys)"
  "distinct (xs @ e # e' # ys)"
proof -
  have "sorted (e' # ys)"
    "distinct (e' # ys)"
    "\<forall> y \<in> set (e' # ys). e < y"
    using assms(2,4,5,7)
    by (auto simp add: sorted_Cons)
  thus "sorted (xs @ e # e' # ys)"
  "distinct (xs @ e # e' # ys)"
    using assms(1,3,6) distinct_sorted_list_lem1[of xs "e' # ys" e]
    by auto
qed

lemma map_of_distinct_upd:
  "x \<notin> set (map fst xs) \<Longrightarrow> [x \<mapsto> y] ++ map_of xs = (map_of xs) (x \<mapsto> y)"
  by (induct xs) (auto simp add: fun_upd_twist)

lemma map_of_distinct_upd2:
  assumes "x \<notin> set(map fst xs)"
  "x \<notin> set (map fst ys)"
  shows "map_of (xs @ (x,y) # ys) = (map_of (xs @ ys))(x \<mapsto> y)"
  apply(insert assms)
  apply(induct xs)
  apply (auto intro: ext)
  done

lemma map_of_distinct_upd3:
  assumes "x \<notin> set(map fst xs)"
  "x \<notin> set (map fst ys)"
  shows "map_of (xs @ (x,y) # ys) = (map_of (xs @ (x,y') # ys))(x \<mapsto> y)"
  apply(insert assms)
  apply(induct xs)
  apply (auto intro: ext)
  done

lemma map_of_distinct_upd4:
  assumes "x \<notin> set(map fst xs)"
  "x \<notin> set (map fst ys)"
  shows "map_of (xs @ ys) = (map_of (xs @ (x,y) # ys))(x := None)"
  apply(insert assms)
  apply(induct xs)

  apply clarsimp
  apply (metis dom_map_of_conv_image_fst fun_upd_None_restrict
    restrict_complement_singleton_eq restrict_map_self)

  apply (auto simp add: map_of_eq_None_iff) []
  done

lemma map_of_distinct_lookup:
  assumes "x \<notin> set(map fst xs)"
  "x \<notin> set (map fst ys)"
  shows "map_of (xs @ (x,y) # ys) x = Some y"
proof -
  have "map_of (xs @ (x,y) # ys) = (map_of (xs @ ys)) (x \<mapsto> y)"
    using assms map_of_distinct_upd2 by simp
  thus ?thesis
    by simp
qed

lemma ran_distinct:
  assumes dist: "distinct (map fst al)"
  shows "ran (map_of al) = snd ` set al"
using assms proof (induct al)
  case Nil then show ?case by simp
next
  case (Cons kv al)
  then have "ran (map_of al) = snd ` set al" by simp
  moreover from Cons.prems have "map_of al (fst kv) = None"
    by (simp add: map_of_eq_None_iff)
  ultimately show ?case by (simp only: map_of.simps ran_map_upd) simp
qed

subsubsection "Finite"

lemma aluprio_finite_correct: "uprio_finite (aluprio_\<alpha> \<alpha>) (aluprio_invar \<alpha> invar)"
  by(unfold_locales) (simp add: aluprio_defs finite_dom_map_of)

subsubsection "Empty"
lemma aluprio_empty_correct:
  assumes "al_empty \<alpha> invar empt"
  shows "uprio_empty (aluprio_\<alpha> \<alpha>) (aluprio_invar \<alpha> invar) (aluprio_empty empt)"
proof -
  interpret al_empty \<alpha> invar empt by fact
  show ?thesis
    apply (unfold_locales)
    apply (auto simp add: empty_correct aluprio_defs)
    done
qed

subsubsection "Is Empty"

lemma aluprio_isEmpty_correct:
  assumes "al_isEmpty \<alpha> invar isEmpty"
  shows "uprio_isEmpty (aluprio_\<alpha> \<alpha>) (aluprio_invar \<alpha> invar) (aluprio_isEmpty isEmpty)"
proof -
  interpret al_isEmpty \<alpha> invar isEmpty by fact
  show ?thesis
    apply (unfold_locales)
    apply (auto simp add: aluprio_defs isEmpty_correct)
    done
qed

subsubsection "Insert"

lemma annot_inf:
  assumes A: "invar s" "\<forall>x\<in>set (\<alpha> s). snd x \<noteq> Infty" "al_annot \<alpha> invar annot"
  shows "annot s = Infty \<longleftrightarrow> \<alpha> s = [] "
proof -
  from A have invs: "invar s" by (simp add: aluprio_defs)
  interpret al_annot \<alpha> invar annot by fact
  show "annot s = Infty \<longleftrightarrow> \<alpha> s = []"
  proof (cases "\<alpha> s = []")
    case True
    hence "map snd (\<alpha> s) = []" by simp
    hence "listsum (map snd (\<alpha> s)) = Infty"
      by (auto simp add: zero_def)
    with invs have  "annot s = Infty" by (auto simp add: annot_correct)
    with True show ?thesis by simp
  next
    case False
    hence " \<exists>x xs. (\<alpha> s) = x # xs" by (cases "\<alpha> s") auto
    from this obtain x xs where [simp]: "(\<alpha> s) = x # xs" by blast
    from this assms(2) have "snd x \<noteq> Infty" by (auto simp add: aluprio_defs)
    hence "listsum (map snd (\<alpha> s)) \<noteq> Infty" by (auto simp add: infadd)
    thus ?thesis using annot_correct invs False by simp
  qed
qed

lemma e_less_eq_annot:

  assumes "al_annot \<alpha> invar annot"
   "invar s" "\<forall>x\<in>set (\<alpha> s). snd x \<noteq> Infty" "\<not> e_less_eq e (annot s)"
  shows "\<forall>x \<in> set (map (fst \<circ> (p_unwrap \<circ> snd)) (\<alpha> s)). x < e"
proof -
  interpret al_annot \<alpha> invar annot by fact
  from assms(2) have "annot s = listsum (map snd (\<alpha> s))"
    by (auto simp add: annot_correct)
  with assms(4) have
    "\<forall>x \<in> set (map snd (\<alpha> s)). \<not> e_less_eq e x"
    by (metis e_less_eq_listsum)
  with assms(3)
  show ?thesis
    by (auto simp add: e_less_eq_p_unwrap)
qed

lemma aluprio_insert_correct:
  assumes
  "al_splits \<alpha> invar splits"
  "al_annot \<alpha> invar annot"
  "al_isEmpty \<alpha> invar isEmpty"
  "al_app \<alpha> invar app"
  "al_consr \<alpha> invar consr"
  shows
  "uprio_insert (aluprio_\<alpha> \<alpha>) (aluprio_invar \<alpha> invar)
    (aluprio_insert splits annot isEmpty app consr)"
proof -
  interpret al_splits \<alpha> invar splits by fact
  interpret al_annot \<alpha> invar annot by fact
  interpret al_isEmpty \<alpha> invar isEmpty by fact
  interpret al_app \<alpha> invar app by fact
  interpret al_consr \<alpha> invar consr by fact
  show ?thesis
  proof (unfold_locales, unfold aluprio_defs, goal_cases)
    case g1asms: (1 s e a)
    thus ?case proof (cases "e_less_eq e (annot s) \<and> \<not> isEmpty s")
      case False with g1asms show  ?thesis
        apply (auto simp add: consr_correct )
      proof goal_cases
        case prems: 1
        with assms(2) have
          "\<forall>x \<in> set (map (fst \<circ> (p_unwrap \<circ> snd)) (\<alpha> s)). x < e"
          by (simp add: e_less_eq_annot)
        with prems(3) show ?case
          by(auto simp add: sorted_append)
      next
        case prems: 2
        hence "annot s = listsum (map snd (\<alpha> s))"
          by (simp add: annot_correct)
        with prems
        show ?case
          by (auto simp add: e_less_eq_listsum2)
      next
        case prems: 3
        hence "\<alpha> s = []" by (auto simp add: isEmpty_correct)
        thus ?case by simp
      next
        case prems: 4
        hence "\<alpha> s = []" by (auto simp add: isEmpty_correct)
        with prems show ?case by simp
      qed
    next
      case True note T1 = this
      obtain l uu lp r where
        l_lp_r: "(splits (e_less_eq e) Infty s) = (l, ((), lp), r) "
        by (cases "splits (e_less_eq e) Infty s", auto)
      note v2 = splits_correct[of s "e_less_eq e" Infty l "()" lp r]
      have
        v3: "invar s"
        "\<not> e_less_eq e Infty"
        "e_less_eq e (Infty + listsum (map snd (\<alpha> s)))"
        using T1 g1asms annot_correct
        by (auto simp add: plus_def)
      have
        v4: "\<alpha> s = \<alpha> l @ ((), lp) # \<alpha> r"
        "\<not> e_less_eq e (Infty + listsum (map snd (\<alpha> l)))"
        "e_less_eq e (Infty + listsum (map snd (\<alpha> l)) + lp)"
        "invar l"
        "invar r"
        using v2[OF v3(1) _ v3(2) v3(3) l_lp_r] e_less_eq_mon(1) by auto
      hence v5: "e_less_eq e lp"
        by (metis e_less_eq_lem1)
      hence v6: "e \<le> (fst (p_unwrap lp))"
        by (cases lp) auto
      have "(Infty + listsum (map snd (\<alpha> l))) = (annot l)"
        by (metis add_0_left annot_correct v4(4) zero_def)
      hence v7:"\<not> e_less_eq e (annot l)"
        using v4(2) by simp
      have "\<forall>x\<in>set (\<alpha> l). snd x \<noteq> Infty"
        using g1asms v4(1) by simp
      hence v7: "\<forall>x \<in> set (map (fst \<circ> (p_unwrap \<circ> snd)) (\<alpha> l)). x < e"
        using v4(4) v7 assms(2)
        by(simp add: e_less_eq_annot)
      have v8:"map fst (map p_unwrap (map snd (\<alpha> s))) =
        map fst (map p_unwrap (map snd (\<alpha> l))) @ fst(p_unwrap lp) #
        map fst (map p_unwrap (map snd (\<alpha> r)))"
        using v4(1)
        by simp
      note distinct_sortet_list_app[of "map fst (map p_unwrap (map snd (\<alpha> s)))"
        "map fst (map p_unwrap (map snd (\<alpha> l)))" "fst(p_unwrap lp)"
        "map fst (map p_unwrap (map snd (\<alpha> r)))"]
      hence v9:
        "\<forall> x\<in>set (map (fst \<circ> (p_unwrap \<circ> snd)) (\<alpha> r)). fst(p_unwrap lp) < x"
        using v4(1) g1asms v8
        by auto
      have v10:
        "sorted (map fst (map p_unwrap (map snd (\<alpha> l))))"
        "distinct (map fst (map p_unwrap (map snd (\<alpha> l))))"
        "sorted (map fst (map p_unwrap (map snd (\<alpha> r))))"
        "distinct (map fst (map p_unwrap (map snd (\<alpha> l))))"
        using g1asms v8
        by (auto simp add: sorted_append sorted_Cons)

      from l_lp_r T1 g1asms show ?thesis
      proof (fold aluprio_insert_def, cases "e < fst (p_unwrap lp)")
        case True
        hence v11:
          "aluprio_insert splits annot isEmpty app consr s e a
            = app (consr (consr l () (LP e a)) () lp) r"
          using l_lp_r T1
          by (auto simp add: aluprio_defs)
        have  v12: "invar (app (consr (consr l () (LP e a)) () lp) r)"
          using v4(4,5)
          by (auto simp add: app_correct consr_correct)
        have v13:
          "\<alpha> (app (consr (consr l () (LP e a)) () lp) r)
            = \<alpha> l @ ((),(LP e a)) # ((), lp) # \<alpha> r"
          using v4(4,5) by (auto simp add: app_correct consr_correct)
        hence v14:
          "(\<forall>x\<in>set (\<alpha> (app (consr (consr l () (LP e a)) () lp) r)).
             snd x \<noteq> Infty)"
          using g1asms v4(1)
          by auto
        have v15: "e = fst(p_unwrap (LP e a))" by simp
        hence v16:
          "sorted (map fst (map p_unwrap
             (map snd (\<alpha> l @ ((),(LP e a)) # ((), lp) # \<alpha> r))))"
          "distinct (map fst (map p_unwrap
             (map snd (\<alpha> l @ ((),(LP e a)) # ((), lp) # \<alpha> r))))"
          using v10(1,3) v7 True v9 v4(1) g1asms distinct_sorted_list_lem2
          by (auto simp add: sorted_append sorted_Cons)
        thus "invar (aluprio_insert splits annot isEmpty app consr s e a) \<and>
          (\<forall>x\<in>set (\<alpha> (aluprio_insert splits annot isEmpty app consr s e a)).
             snd x \<noteq> Infty) \<and>
          sorted (map fst (map p_unwrap (map snd (\<alpha>
             (aluprio_insert splits annot isEmpty app consr s e a))))) \<and>
          distinct (map fst (map p_unwrap (map snd (\<alpha>
             (aluprio_insert splits annot isEmpty app consr s e a)))))"
          using v11 v12 v13 v14
          by simp
      next
        case False
        hence v11:
          "aluprio_insert splits annot isEmpty app consr s e a
             = app (consr l () (LP e a)) r"
          using l_lp_r T1
          by (auto simp add: aluprio_defs)
        have  v12: "invar (app (consr l () (LP e a)) r)" using v4(4,5)
          by (auto simp add: app_correct consr_correct)
        have v13: "\<alpha> (app (consr l () (LP e a)) r) = \<alpha> l @ ((),(LP e a)) # \<alpha> r"
          using v4(4,5) by (auto simp add: app_correct consr_correct)
        hence v14: "(\<forall>x\<in>set (\<alpha> (app (consr l () (LP e a)) r)). snd x \<noteq> Infty)"
          using g1asms v4(1)
          by auto
        have v15: "e = fst(p_unwrap (LP e a))" by simp
        have v16: "e = fst(p_unwrap lp)"
          using False v5 by (cases lp) auto
        hence v17:
          "sorted (map fst (map p_unwrap
            (map snd (\<alpha> l @ ((),(LP e a)) # \<alpha> r))))"
          "distinct (map fst (map p_unwrap
            (map snd (\<alpha> l @ ((),(LP e a)) # \<alpha> r))))"
          using v16 v15 v10(1,3) v7 True v9 v4(1)
            g1asms distinct_sorted_list_lem1
          by (auto simp add: sorted_append sorted_Cons)
        thus "invar (aluprio_insert splits annot isEmpty app consr s e a) \<and>
          (\<forall>x\<in>set (\<alpha> (aluprio_insert splits annot isEmpty app consr s e a)).
            snd x \<noteq> Infty) \<and>
          sorted (map fst (map p_unwrap (map snd (\<alpha>
            (aluprio_insert splits annot isEmpty app consr s e a))))) \<and>
          distinct (map fst (map p_unwrap (map snd (\<alpha>
            (aluprio_insert splits annot isEmpty app consr s e a)))))"
          using v11 v12 v13 v14
          by simp
      qed
    qed
  next
    case g1asms: (2 s e a)
    thus ?case proof (cases "e_less_eq e (annot s) \<and> \<not> isEmpty s")
      case False with g1asms show  ?thesis
        apply (auto simp add: consr_correct)
      proof goal_cases
        case prems: 1
        with assms(2) have
          "\<forall>x \<in> set (map (fst \<circ> (p_unwrap \<circ> snd)) (\<alpha> s)). x < e"
          by (simp add: e_less_eq_annot)
        hence "e \<notin> set (map fst ((map (p_unwrap \<circ> snd)) (\<alpha> s)))"
          by auto
        thus ?case
          by (auto simp add: map_of_distinct_upd)
      next
        case prems: 2
        hence "\<alpha> s = []" by (auto simp add: isEmpty_correct)
        thus ?case
          by simp
      qed
    next
      case True note T1 = this
      obtain l uu lp r where
        l_lp_r: "(splits (e_less_eq e) Infty s) = (l, ((), lp), r) "
        by (cases "splits (e_less_eq e) Infty s", auto)
      note v2 = splits_correct[of s "e_less_eq e" Infty l "()" lp r]
      have
        v3: "invar s"
        "\<not> e_less_eq e Infty"
        "e_less_eq e (Infty + listsum (map snd (\<alpha> s)))"
        using T1 g1asms annot_correct
        by (auto simp add: plus_def)
      have
        v4: "\<alpha> s = \<alpha> l @ ((), lp) # \<alpha> r"
        "\<not> e_less_eq e (Infty + listsum (map snd (\<alpha> l)))"
        "e_less_eq e (Infty + listsum (map snd (\<alpha> l)) + lp)"
        "invar l"
        "invar r"
        using v2[OF v3(1) _ v3(2) v3(3) l_lp_r] e_less_eq_mon(1) by auto
      hence v5: "e_less_eq e lp"
        by (metis e_less_eq_lem1)
      hence v6: "e \<le> (fst (p_unwrap lp))"
        by (cases lp) auto
      have "(Infty + listsum (map snd (\<alpha> l))) = (annot l)"
        by (metis add_0_left annot_correct v4(4) zero_def)
      hence v7:"\<not> e_less_eq e (annot l)"
        using v4(2) by simp
      have "\<forall>x\<in>set (\<alpha> l). snd x \<noteq> Infty"
        using g1asms v4(1) by simp
      hence v7: "\<forall>x \<in> set (map (fst \<circ> (p_unwrap \<circ> snd)) (\<alpha> l)). x < e"
        using v4(4) v7 assms(2)
        by(simp add: e_less_eq_annot)
      have v8:"map fst (map p_unwrap (map snd (\<alpha> s))) =
        map fst (map p_unwrap (map snd (\<alpha> l))) @ fst(p_unwrap lp) #
        map fst (map p_unwrap (map snd (\<alpha> r)))"
        using v4(1)
        by simp
      note distinct_sortet_list_app[of "map fst (map p_unwrap (map snd (\<alpha> s)))"
        "map fst (map p_unwrap (map snd (\<alpha> l)))" "fst(p_unwrap lp)"
        "map fst (map p_unwrap (map snd (\<alpha> r)))"]
      hence v9: "
        \<forall> x\<in>set (map (fst \<circ> (p_unwrap \<circ> snd)) (\<alpha> r)). fst(p_unwrap lp) < x"
        using v4(1) g1asms v8
        by auto
      hence v10: " \<forall> x\<in>set (map (fst \<circ> (p_unwrap \<circ> snd)) (\<alpha> r)). e < x"
        using v6 by auto
      have v11:
        "e \<notin> set (map fst (map p_unwrap (map snd (\<alpha> l))))"
        "e \<notin> set (map fst (map p_unwrap (map snd (\<alpha> r))))"
        using v7 v10 v8 g1asms
        by auto
      from l_lp_r T1 g1asms show ?thesis
      proof (fold aluprio_insert_def, cases "e < fst (p_unwrap lp)")
        case True
        hence v12:
          "aluprio_insert splits annot isEmpty app consr s e a
            = app (consr (consr l () (LP e a)) () lp) r"
          using l_lp_r T1
          by (auto simp add: aluprio_defs)
        have v13:
          "\<alpha> (app (consr (consr l () (LP e a)) () lp) r)
            = \<alpha> l @ ((),(LP e a)) # ((), lp) # \<alpha> r"
          using v4(4,5) by (auto simp add: app_correct consr_correct)
        have v14: "e = fst(p_unwrap (LP e a))" by simp
        have v15: "e \<notin> set (map fst (map p_unwrap (map snd(((),lp)#\<alpha> r))))"
          using v11(2) True by auto
        note map_of_distinct_upd2[OF v11(1) v15]
        thus
          "map_of (map p_unwrap (map snd (\<alpha>
              (aluprio_insert splits annot isEmpty app consr s e a))))
            = map_of (map p_unwrap (map snd (\<alpha> s)))(e \<mapsto> a)"
          using v12 v13 v4(1)
          by simp
      next
        case False
        hence v12:
          "aluprio_insert splits annot isEmpty app consr s e a
            = app (consr l () (LP e a)) r"
          using l_lp_r T1
          by (auto simp add: aluprio_defs)
        have v13:
          "\<alpha> (app (consr l () (LP e a)) r) = \<alpha> l @ ((),(LP e a)) # \<alpha> r"
          using v4(4,5) by (auto simp add: app_correct consr_correct)
        have v14: "e = fst(p_unwrap lp)"
          using False v5 by (cases lp) auto
        note v15 = map_of_distinct_upd3[OF v11(1) v11(2)]
        have v16:"(map p_unwrap (map snd (\<alpha> s))) =
          (map p_unwrap (map snd (\<alpha> l))) @ (e,snd(p_unwrap lp)) #
          (map p_unwrap (map snd (\<alpha> r)))"
          using v4(1) v14
          by simp
        note v15[of a "snd(p_unwrap lp)"]
        thus
          "map_of (map p_unwrap (map snd (\<alpha>
              (aluprio_insert splits annot isEmpty app consr s e a))))
            = map_of (map p_unwrap (map snd (\<alpha> s)))(e \<mapsto> a)"
          using v12 v13 v16
          by simp
      qed
    qed
  qed
qed

subsubsection "Prio"
lemma aluprio_prio_correct:
  assumes
  "al_splits \<alpha> invar splits"
  "al_annot \<alpha> invar annot"
  "al_isEmpty \<alpha> invar isEmpty"
  shows
  "uprio_prio (aluprio_\<alpha> \<alpha>) (aluprio_invar \<alpha> invar) (aluprio_prio splits annot isEmpty)"
proof -
  interpret al_splits \<alpha> invar splits by fact
  interpret al_annot \<alpha> invar annot by fact
  interpret al_isEmpty \<alpha> invar isEmpty by fact
  show ?thesis
  proof (unfold_locales)
    fix s e
    assume inv1: "aluprio_invar \<alpha> invar s"
    hence sinv: "invar s"
      "(\<forall> x\<in>set (\<alpha> s). snd x\<noteq>Infty)"
      "sorted (map fst (map p_unwrap (map snd (\<alpha> s))))"
      "distinct (map fst (map p_unwrap (map snd (\<alpha> s))))"
      by (auto simp add: aluprio_defs)
    show "aluprio_prio splits annot isEmpty s e = aluprio_\<alpha> \<alpha> s e"
    proof(cases "e_less_eq e (annot s) \<and> \<not> isEmpty s")
      case False note F1 = this
      thus ?thesis
      proof(cases "isEmpty s")
        case True
        hence "\<alpha> s = []"
          using sinv isEmpty_correct by simp
        hence "aluprio_\<alpha> \<alpha> s = empty" by (simp add:aluprio_defs)
        hence "aluprio_\<alpha> \<alpha> s e = None" by simp
        thus "aluprio_prio splits annot isEmpty s e = aluprio_\<alpha> \<alpha> s e"
          using F1
          by (auto simp add: aluprio_defs)
      next
        case False
        hence v3:"\<not> e_less_eq e (annot s)"  using F1 by simp
        note v4=e_less_eq_annot[OF assms(2)]
        note v4[OF sinv(1) sinv(2) v3]
        hence v5:"e\<notin>set (map (fst \<circ> (p_unwrap \<circ> snd)) (\<alpha> s))"
          by auto
        hence "map_of (map (p_unwrap \<circ> snd) (\<alpha> s)) e = None"
          using map_of_eq_None_iff
          by (metis map_map map_of_eq_None_iff set_map v5)
        thus "aluprio_prio splits annot isEmpty s e = aluprio_\<alpha> \<alpha> s e"
          using F1
          by (auto simp add: aluprio_defs)
      qed
    next
      case True note T1 = this
      obtain l uu lp r where
        l_lp_r: "(splits (e_less_eq e) Infty s) = (l, ((), lp), r) "
        by (cases "splits (e_less_eq e) Infty s", auto)
      note v2 = splits_correct[of s "e_less_eq e" Infty l "()" lp r]
      have
        v3: "invar s"
        "\<not> e_less_eq e Infty"
        "e_less_eq e (Infty + listsum (map snd (\<alpha> s)))"
        using T1 sinv annot_correct
        by (auto simp add: plus_def)
      have
        v4: "\<alpha> s = \<alpha> l @ ((), lp) # \<alpha> r"
        "\<not> e_less_eq e (Infty + listsum (map snd (\<alpha> l)))"
        "e_less_eq e (Infty + listsum (map snd (\<alpha> l)) + lp)"
        "invar l"
        "invar r"
        using v2[OF v3(1) _ v3(2) v3(3) l_lp_r] e_less_eq_mon(1) by auto
      hence v5: "e_less_eq e lp"
        by (metis e_less_eq_lem1)
      hence v6: "e \<le> (fst (p_unwrap lp))"
        by (cases lp) auto
      have "(Infty + listsum (map snd (\<alpha> l))) = (annot l)"
        by (metis add_0_left annot_correct v4(4) zero_def)
      hence v7:"\<not> e_less_eq e (annot l)"
        using v4(2) by simp
      have "\<forall>x\<in>set (\<alpha> l). snd x \<noteq> Infty"
        using sinv v4(1) by simp
      hence v7: "\<forall>x \<in> set (map (fst \<circ> (p_unwrap \<circ> snd)) (\<alpha> l)). x < e"
        using v4(4) v7 assms(2)
        by(simp add: e_less_eq_annot)
      have v8:"map fst (map p_unwrap (map snd (\<alpha> s))) =
        map fst (map p_unwrap (map snd (\<alpha> l))) @ fst(p_unwrap lp) #
        map fst (map p_unwrap (map snd (\<alpha> r)))"
        using v4(1)
        by simp
      note distinct_sortet_list_app[of "map fst (map p_unwrap (map snd (\<alpha> s)))"
        "map fst (map p_unwrap (map snd (\<alpha> l)))" "fst(p_unwrap lp)"
        "map fst (map p_unwrap (map snd (\<alpha> r)))"]
      hence v9:
        "\<forall> x\<in>set (map (fst \<circ> (p_unwrap \<circ> snd)) (\<alpha> r)). fst(p_unwrap lp) < x"
        using v4(1) sinv v8
        by auto
      hence v10: " \<forall> x\<in>set (map (fst \<circ> (p_unwrap \<circ> snd)) (\<alpha> r)). e < x"
        using v6 by auto
      have v11:
        "e \<notin> set (map fst (map p_unwrap (map snd (\<alpha> l))))"
        "e \<notin> set (map fst (map p_unwrap (map snd (\<alpha> r))))"
        using v7 v10 v8 sinv
        by auto
      from l_lp_r T1 sinv show ?thesis
      proof (cases "e = fst (p_unwrap lp)")
        case False
        have v12: "e \<notin> set (map fst (map p_unwrap (map snd(\<alpha> s))))"
          using v11 False v4(1) by auto
        hence "map_of (map (p_unwrap \<circ> snd) (\<alpha> s)) e = None"
          using map_of_eq_None_iff
          by (metis map_map map_of_eq_None_iff set_map v12)
        thus ?thesis
          using T1 False l_lp_r
          by (auto simp add: aluprio_defs)
      next
        case True
        have v12: "map (p_unwrap \<circ> snd) (\<alpha> s) =
          map p_unwrap (map snd (\<alpha> l)) @ (e,snd (p_unwrap lp)) #
          map p_unwrap (map snd (\<alpha> r))"
          using v4(1) True by simp
        note map_of_distinct_lookup[OF v11]
        hence
          "map_of (map (p_unwrap \<circ> snd) (\<alpha> s)) e = Some (snd (p_unwrap lp))"
          using v12 by simp
        thus ?thesis
          using T1 True l_lp_r
          by (auto simp add: aluprio_defs)
      qed
    qed
  qed
qed

subsubsection "Pop"

lemma aluprio_pop_correct:
  assumes "al_splits \<alpha> invar splits"
  "al_annot \<alpha> invar annot"
  "al_app \<alpha> invar app"
  shows
  "uprio_pop (aluprio_\<alpha> \<alpha>) (aluprio_invar \<alpha> invar) (aluprio_pop splits annot app)"
proof -
  interpret al_splits \<alpha> invar splits by fact
  interpret al_annot \<alpha> invar annot by fact
  interpret al_app \<alpha> invar app by fact
  show ?thesis
  proof (unfold_locales)
    fix s e a s'
    assume A: "aluprio_invar \<alpha> invar s"
      "aluprio_\<alpha> \<alpha> s \<noteq> empty"
      "aluprio_pop splits annot app s = (e, a, s')"
    hence v1: "\<alpha> s \<noteq> []"
      by (auto simp add: aluprio_defs)
    obtain l lp r where
      l_lp_r: "splits (\<lambda> x. x\<le>annot s) Infty s = (l,((),lp),r)"
      by (cases "splits (\<lambda> x. x\<le>annot s) Infty s", auto)
    have invs:
      "invar s"
      "(\<forall>x\<in>set (\<alpha> s). snd x \<noteq> Infty)"
      "sorted (map fst (map p_unwrap (map snd (\<alpha> s))))"
      "distinct (map fst (map p_unwrap (map snd (\<alpha> s))))"
      using A by (auto simp add:aluprio_defs)
    note a1 = annot_inf[of invar s \<alpha> annot]
    note a1[OF invs(1) invs(2) assms(2)]
    hence v2: "annot s \<noteq> Infty"
      using v1 by simp
    hence v3:
      "\<not> Infty \<le> annot s"
      by(cases "annot s") (auto simp add: plesseq_def)
    have v4: "annot s = listsum (map snd (\<alpha> s))"
      by (auto simp add: annot_correct invs(1))
    hence
      v5:
      "(Infty + listsum (map snd (\<alpha> s))) \<le> annot s"
      by (auto simp add: plus_def)
    note p_mon = p_less_eq_mon[of _ "annot s"]
    note v6 = splits_correct[OF invs(1)]
    note v7 = v6[of "\<lambda> x. x \<le> annot s"]
    note v7[OF _ v3 v5 l_lp_r] p_mon
    hence v8:
      " \<alpha> s = \<alpha> l @ ((), lp) # \<alpha> r"
      "\<not> Infty + listsum (map snd (\<alpha> l)) \<le> annot s"
      "Infty + listsum (map snd (\<alpha> l)) + lp \<le> annot s"
      "invar l"
      "invar r"
      by auto
    hence v9: "lp \<noteq> Infty"
      using invs(2) by auto
    hence v10:
      "s' = app l r"
      "(e,a) = p_unwrap lp"
      using l_lp_r A(3)
      apply (auto simp add: aluprio_defs)
      apply (cases lp)
      apply auto
      apply (cases lp)
      apply auto
      done
    have "lp \<le> annot s"
      using v8(2,3) p_less_eq_lem1
      by auto
    hence v11: "a \<le> snd (p_unwrap (annot s))"
      using v10(2) v2 v9
      apply (cases "annot s")
      apply auto
      apply (cases lp)
      apply (auto simp add: plesseq_def)
      done
    note listsum_less_elems[OF invs(2)]
    hence v12: "\<forall>y\<in>set (map snd (map p_unwrap (map snd (\<alpha> s)))). a \<le> y"
      using v4 v11 by auto
    have "ran (aluprio_\<alpha> \<alpha> s) = set (map snd (map p_unwrap (map snd (\<alpha> s))))"
      using ran_distinct[OF invs(4)]
      apply (unfold aluprio_defs)
      apply (simp only: set_map)
      done
    hence ziel1: "\<forall>y\<in>ran (aluprio_\<alpha> \<alpha> s). a \<le> y"
      using v12 by simp
    have v13:
      "map p_unwrap (map snd (\<alpha> s))
        = map p_unwrap (map  snd (\<alpha> l)) @ (e,a) # map p_unwrap (map snd (\<alpha> r))"
      using v8(1) v10 by auto
     hence v14:
      "map fst (map p_unwrap (map snd (\<alpha> s)))
         = map fst (map p_unwrap (map snd (\<alpha> l))) @ e
             # map fst (map p_unwrap (map snd (\<alpha> r)))"
       by auto
    hence v15:
      "e \<notin> set (map fst (map p_unwrap (map snd (\<alpha> l))))"
      "e \<notin> set (map fst (map p_unwrap (map snd (\<alpha> r))))"
      using invs(4) by auto
    note map_of_distinct_lookup[OF v15]
    note this[of a]
    hence ziel2: "aluprio_\<alpha> \<alpha> s e = Some a"
      using  v13
      by (unfold aluprio_defs, auto)
    have v16:
      "\<alpha> s' = \<alpha> l @ \<alpha> r"
      "invar s'"
      using v8(4,5) app_correct v10 by auto
    note map_of_distinct_upd4[OF v15]
    note this[of a]
    hence
      ziel3: "aluprio_\<alpha> \<alpha> s' = (aluprio_\<alpha> \<alpha> s)(e := None)"
      unfolding aluprio_defs
      using v16(1) v13 by auto
    have ziel4: "aluprio_invar \<alpha> invar s'"
      using v16 v8(1) invs(2,3,4)
      unfolding aluprio_defs
      by (auto simp add: sorted_Cons sorted_append)

    show "aluprio_invar \<alpha> invar s' \<and>
          aluprio_\<alpha> \<alpha> s' = (aluprio_\<alpha> \<alpha> s)(e := None) \<and>
          aluprio_\<alpha> \<alpha> s e = Some a \<and> (\<forall>y\<in>ran (aluprio_\<alpha> \<alpha> s). a \<le> y)"
      using ziel1 ziel2 ziel3 ziel4 by simp
  qed
qed

lemmas aluprio_correct =
  aluprio_finite_correct
  aluprio_empty_correct
  aluprio_isEmpty_correct
  aluprio_insert_correct
  aluprio_pop_correct
  aluprio_prio_correct

locale aluprio_defs = StdALDefs ops
  for ops :: "(unit,('e::linorder,'a::linorder) LP,'s) alist_ops"
begin
  definition [icf_rec_def]: "aluprio_ops \<equiv> \<lparr>
    upr_\<alpha> = aluprio_\<alpha> \<alpha>,
    upr_invar = aluprio_invar \<alpha> invar,
    upr_empty = aluprio_empty empty,
    upr_isEmpty = aluprio_isEmpty isEmpty,
    upr_insert = aluprio_insert splits annot isEmpty app consr,
    upr_pop = aluprio_pop splits annot app,
    upr_prio = aluprio_prio splits annot isEmpty
    \<rparr>"

end

locale aluprio = aluprio_defs ops + StdAL ops
  for ops :: "(unit,('e::linorder,'a::linorder) LP,'s) alist_ops"
begin
  lemma aluprio_ops_impl: "StdUprio aluprio_ops"
    apply (rule StdUprio.intro)
    apply (simp_all add: icf_rec_unf)
    apply (rule aluprio_correct)
    apply (rule aluprio_correct, unfold_locales) []
    apply (rule aluprio_correct, unfold_locales) []
    apply (rule aluprio_correct, unfold_locales) []
    apply (rule aluprio_correct, unfold_locales) []
    apply (rule aluprio_correct, unfold_locales) []
    done
end

end


section {* Isomorphisms Between Predicates, Sets and Relations *}

theory P2S2R
imports Main

begin

notation relcomp (infixl ";" 70)
notation inf (infixl "\<sqinter>" 70)
notation sup (infixl "\<squnion>" 65)
notation Id_on ("s2r")
notation Domain ("r2s")
notation Collect ("p2s")

definition rel_n :: "'a rel \<Rightarrow> 'a rel" where
  "rel_n  \<equiv> (\<lambda>X. Id \<inter> - X)"

lemma subid_meet: "R \<subseteq> Id \<Longrightarrow> S \<subseteq> Id \<Longrightarrow> R \<inter> S = R ; S"
  by blast

subsection{* Isomorphism Between Sets and Relations *}

type_synonym 'a pred = "'a \<Rightarrow> bool"

lemma srs: "r2s \<circ> s2r = id"
  by auto

lemma rsr: "R \<subseteq> Id \<Longrightarrow> s2r (r2s R) = R"
  by (auto simp: Id_def Id_on_def Domain_def)

lemma s2r_inj: "inj s2r"
  by (metis Domain_Id_on injI)

lemma r2s_inj: "R \<subseteq> Id \<Longrightarrow> S \<subseteq> Id \<Longrightarrow> r2s R = r2s S \<Longrightarrow> R = S"
  by (metis rsr)

lemma s2r_surj: "\<forall>R \<subseteq> Id. \<exists>A. R = s2r A"
  using rsr by auto

lemma r2s_surj: "\<forall>A. \<exists>R \<subseteq> Id. A = r2s R"
  by (metis Domain_Id_on Id_onE pair_in_Id_conv subsetI)

lemma s2r_union_hom: "s2r (A \<union> B) = s2r A \<union> s2r B"
  by (simp add: Id_on_def)

lemma s2r_inter_hom: "s2r (A \<inter> B) = s2r A \<inter> s2r B"
  by (auto simp: Id_on_def)

lemma s2r_inter_hom_var: "s2r (A \<inter> B) = s2r A ; s2r B"
  by (auto simp: Id_on_def)

lemma s2r_compl_hom: "s2r (- A) = rel_n (s2r A)"
  by (auto simp add: rel_n_def)

lemma r2s_union_hom: "r2s (R \<union> S) = r2s R \<union> r2s S"
  by auto

lemma r2s_inter_hom: "R \<subseteq> Id \<Longrightarrow> S \<subseteq> Id \<Longrightarrow> r2s (R \<inter> S) = r2s R \<inter> r2s S"
  by auto

lemma r2s_inter_hom_var: "R \<subseteq> Id \<Longrightarrow> S \<subseteq> Id \<Longrightarrow> r2s (R ; S) = r2s R \<inter> r2s S"
  by (metis r2s_inter_hom subid_meet)

lemma r2s_ad_hom: "R \<subseteq> Id \<Longrightarrow> r2s (rel_n R) = - r2s R"
  by (metis r2s_surj rsr s2r_compl_hom)

subsection {* Isomorphism Between Predicates and Sets *}

definition s2p :: "'a set \<Rightarrow> 'a pred" where
  "s2p S = (\<lambda>x. x \<in> S)"

lemma sps [simp]: "s2p \<circ> p2s = id"
  by (intro ext, simp add: s2p_def)

lemma psp [simp]: "p2s \<circ> s2p = id"
  by (intro ext, simp add: s2p_def)

lemma s2p_bij: "bij s2p"
  using o_bij psp sps by blast

lemma p2s_bij: "bij p2s"
  using o_bij psp sps by blast

lemma s2p_compl_hom: "s2p (- A) = - (s2p A)"
  by (metis Collect_mem_eq comp_eq_dest_lhs id_apply sps uminus_set_def)

lemma s2p_inter_hom: "s2p (A \<inter> B) = (s2p A) \<sqinter> (s2p B)"
  by (metis Collect_mem_eq comp_eq_dest_lhs id_apply inf_set_def sps)

lemma s2p_union_hom: "s2p (A \<union> B) = (s2p A) \<squnion> (s2p B)"
  by (auto simp: s2p_def)

lemma p2s_neg_hom: "p2s (- P) = - (p2s P)"
  by fastforce

lemma p2s_conj_hom: "p2s (P \<sqinter> Q) = p2s P \<inter> p2s Q"
  by blast

lemma p2s_disj_hom: "p2s (P \<squnion> Q) = p2s P \<union> p2s Q"
  by blast

subsection {* Isomorphism Between Predicates and Relations *}

definition p2r :: "'a pred \<Rightarrow> 'a rel" where
  "p2r P = {(s,s) |s. P s}"

definition r2p :: "'a rel \<Rightarrow> 'a pred" where
  "r2p R = (\<lambda>x. x \<in> Domain R)"

lemma p2r_subid: "p2r P \<subseteq> Id"
  by (simp add: p2r_def subset_eq)

lemma p2s2r: "p2r = s2r \<circ> p2s"
proof (intro ext)
  fix P :: "'a pred"
  have "{(a, a) |a. P a} = {(b, a). b = a \<and> P b}"
    by blast
  thus "p2r P = (s2r \<circ> p2s) P"
    by (simp add: Id_on_def' p2r_def)
qed

lemma r2s2p: "r2p = s2p \<circ> r2s"
  by (intro ext, simp add: r2p_def s2p_def)

lemma prp [simp]: "r2p \<circ> p2r = id"
  by (intro ext, simp add: p2s2r r2p_def)

lemma rpr: "R \<subseteq> Id \<Longrightarrow> p2r (r2p R) = R"
  by (metis comp_apply id_apply p2s2r psp r2s2p rsr)

lemma p2r_inj: "inj p2r"
  by (metis comp_eq_dest_lhs id_apply injI prp)

lemma r2p_inj: "R \<subseteq> Id \<Longrightarrow> S \<subseteq> Id \<Longrightarrow> r2p R = r2p S \<Longrightarrow> R = S"
  by (metis rpr)

lemma p2r_surj: "\<forall> R \<subseteq> Id. \<exists>P. R = p2r P"
  using rpr by auto

lemma r2p_surj: "\<forall>P. \<exists>R \<subseteq> Id. P = r2p R"
  by (metis comp_apply id_apply p2r_subid prp)

lemma p2r_neg_hom: "p2r (- P) = rel_n (p2r P)"
  by (simp add: p2s2r p2s_neg_hom s2r_compl_hom)

lemma p2r_conj_hom [simp]: "p2r P \<inter> p2r Q = p2r (P \<sqinter> Q)"
  by (simp add: p2s2r p2s_conj_hom s2r_inter_hom)

lemma p2r_conj_hom_var [simp]: "p2r P ; p2r Q = p2r (P \<sqinter> Q)"
  by (simp add: p2s2r p2s_conj_hom s2r_inter_hom_var)

lemma p2r_id_neg [simp]: "Id \<inter> - p2r p = p2r (-p)"
  by (auto simp: p2r_def)

lemma p2r_disj_hom [simp]: "p2r P \<union> p2r Q = p2r (P \<squnion> Q)"
  by (simp add: p2s2r p2s_disj_hom s2r_union_hom)

lemma r2p_ad_hom: "R \<subseteq> Id \<Longrightarrow> r2p (rel_n R) = - (r2p R)"
  by (simp add: r2s2p r2s_ad_hom s2p_compl_hom)

lemma r2p_inter_hom: "R \<subseteq> Id \<Longrightarrow> S \<subseteq> Id \<Longrightarrow> r2p (R \<inter> S) = (r2p R) \<sqinter> (r2p S)"
  by (simp add: r2s2p r2s_inter_hom s2p_inter_hom)

lemma r2p_inter_hom_var: "R \<subseteq> Id \<Longrightarrow> S \<subseteq> Id \<Longrightarrow> r2p (R ; S) = (r2p R) \<sqinter> (r2p S)"
  by (simp add: r2s2p r2s_inter_hom_var s2p_inter_hom)

lemma rel_to_pred_union_hom: "R \<subseteq> Id \<Longrightarrow> S \<subseteq> Id \<Longrightarrow> r2p (R \<union> S) = (r2p R) \<squnion> (r2p S)"
  by (simp add: Domain_Un_eq r2s2p s2p_union_hom)

end


theory E2_2
  imports Main
begin

datatype nat = nil | suc nat

fun add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "add nil n = n" |
  "add (suc m) n = suc (add m n)"

lemma add_assoc : "add (add x y) z = add x (add y z)"
  apply(induction x)
  apply(auto)
  done

lemma add_02 [simp] : "add m nil = m"
  apply(induction m)
  apply(auto)
  done

lemma add_03 [simp] : "suc (add m n) = add m (suc n)"
  apply(induction m)
  apply(auto)
  done

lemma add_commut : "add m n = add n m"
  apply(induction m)
  apply(auto)
  done

fun double :: "nat\<Rightarrow> nat" where
  "double nil = nil" |
  "double (suc m) = suc (suc (double m))"

lemma double_02 : "double m = add m m"
  apply(induction m)
  apply(auto)
  done

end


theory Exercises
imports Main
begin

text \<open> Exercise 4.1 \<close>

datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

fun set :: "'a tree \<Rightarrow> 'a set" where
"set Tip = {}"|
"set (Node t1 n t2) = {n} \<union> (set t1) \<union> (set t2)"

fun ord :: "int tree \<Rightarrow> bool" where
"ord Tip = True"|
"ord (Node t1 n t2) = ((\<forall>x \<in> (set t1). x \<le> n) \<and> (\<forall>x \<in> (set t2). x \<le> n) \<and> (ord t1) \<and> (ord t2))"

fun ins :: "int tree \<Rightarrow> int \<Rightarrow> int tree" where
"ins (Tip) j = Node Tip j Tip"|
"ins (Node t1 n t2) j = (if j=n
                        then (Node t1 n t2)
                        else if j > n
                             then (Node (Node t1 n t2) j Tip)
                             else (Node (ins t1 j) n t2)
                        )"
value "ord (ins (Node (Node Tip (5::int) Tip) 6 (Node Tip 3 Tip)) 4)"

lemma set_ins: "set (ins t n) = {n} \<union> (set t)"
  apply(induction t arbitrary:n)
  apply(auto)
done

lemma ord_ins: "ord t \<Longrightarrow> ord (ins t n)"
  apply(induction t arbitrary:n)
  apply(auto simp add: set_ins)
  done

text \<open> End of exercise 4.1 \<close>

text \<open> Exercise 4.2 \<close>

inductive palindrome :: "'a list \<Rightarrow> bool" where
"palindrome []"|
"palindrome [a]"|
"palindrome xs \<Longrightarrow> palindrome (a#xs@[a])"

lemma "palindrome xs \<Longrightarrow> rev xs = xs"
  apply(induction rule: palindrome.induct)
  apply(simp_all)
done

text \<open> End of exercise 4.2 \<close>

text \<open> Exercise 4.3 \<close>

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
refl : "star r x x" |
step : "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

inductive star' :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
refl' : "star' r x x" |
step' : "star' r x y \<Longrightarrow> r y z \<Longrightarrow> star' r x z"

lemma  "star r x y \<Longrightarrow> star' r x y"
  apply(induction rule:star.induct)
  apply(auto intro: refl')
done

lemma [simp]: "star r x y \<Longrightarrow> r y z \<Longrightarrow> star r x z"
  apply(induction rule: star.induct)
  apply(auto intro: refl step)
done

lemma "star' r x y \<Longrightarrow> star r x y"
  apply(induction rule:star'.induct)
  apply(auto intro: refl)
done

text \<open> End of exercise 4.3 \<close>

text \<open> Exercise 4.4 \<close>

inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
i0:"iter r 0 x x"|
iN:"r x y \<Longrightarrow> iter r n y z \<Longrightarrow> iter r (n+1) x z"

lemma "star r x y \<Longrightarrow> \<exists>n. iter r n x y"
  apply(induction rule: star.induct)
  apply(auto intro: i0 iN)
done

text \<open> End of exercise 4.4 \<close>

text \<open> Exercise 4.6 \<close>

datatype aexp = N int | V string | Plus aexp aexp

fun aval :: "aexp \<Rightarrow> (string \<Rightarrow> int) \<Rightarrow> int" where
"aval (N a) s = a" |
"aval (V x) s = s x" |
"aval (Plus a b) s = aval a s + aval b s"

inductive rel_aval :: "aexp \<Rightarrow> (string \<Rightarrow> int) \<Rightarrow> int \<Rightarrow> bool" where
ra_N: "rel_aval (N a) s a" |
ra_V: "rel_aval (V x) s (s x)" |
ra_Plus: "rel_aval p s int_p \<Longrightarrow> rel_aval q s int_v \<Longrightarrow> rel_aval (Plus p q) s (int_p + int_v)"

theorem rel_aval_aval: "rel_aval a s v \<Longrightarrow> aval a s = v"
  apply (induction rule: rel_aval.induct)
  apply (auto)
done

theorem aval_rel_aval: "aval a s = v \<Longrightarrow> rel_aval a s v"
  apply (induction a arbitrary: v)
  apply (auto intro: ra_N ra_V ra_Plus)
done

theorem "rel_aval a s v \<longleftrightarrow> aval a s = v"
  apply (auto intro: aval_rel_aval rel_aval_aval)
done

text \<open> End of exercise 4.6 \<close>


(*  Title:      HOL/Number_Theory/Residues.thy
    Author:     Jeremy Avigad

An algebraic treatment of residue rings, and resulting proofs of
Euler's theorem and Wilson's theorem.
*)

section \<open>Residue rings\<close>

theory Residues
imports Cong MiscAlgebra
begin

definition QuadRes :: "int \<Rightarrow> int \<Rightarrow> bool" where
  "QuadRes p a = (\<exists>y. ([y^2 = a] (mod p)))"

definition Legendre :: "int \<Rightarrow> int \<Rightarrow> int" where
  "Legendre a p = (if ([a = 0] (mod p)) then 0
    else if QuadRes p a then 1
    else -1)"

subsection \<open>A locale for residue rings\<close>

definition residue_ring :: "int \<Rightarrow> int ring"
where
  "residue_ring m =
    \<lparr>carrier = {0..m - 1},
     mult = \<lambda>x y. (x * y) mod m,
     one = 1,
     zero = 0,
     add = \<lambda>x y. (x + y) mod m\<rparr>"

locale residues =
  fixes m :: int and R (structure)
  assumes m_gt_one: "m > 1"
  defines "R \<equiv> residue_ring m"
begin

lemma abelian_group: "abelian_group R"
  apply (insert m_gt_one)
  apply (rule abelian_groupI)
  apply (unfold R_def residue_ring_def)
  apply (auto simp add: mod_add_right_eq [symmetric] ac_simps)
  apply (case_tac "x = 0")
  apply force
  apply (subgoal_tac "(x + (m - x)) mod m = 0")
  apply (erule bexI)
  apply auto
  done

lemma comm_monoid: "comm_monoid R"
  apply (insert m_gt_one)
  apply (unfold R_def residue_ring_def)
  apply (rule comm_monoidI)
  apply auto
  apply (subgoal_tac "x * y mod m * z mod m = z * (x * y mod m) mod m")
  apply (erule ssubst)
  apply (subst mod_mult_right_eq [symmetric])+
  apply (simp_all only: ac_simps)
  done

lemma cring: "cring R"
  apply (rule cringI)
  apply (rule abelian_group)
  apply (rule comm_monoid)
  apply (unfold R_def residue_ring_def, auto)
  apply (subst mod_add_eq [symmetric])
  apply (subst mult.commute)
  apply (subst mod_mult_right_eq [symmetric])
  apply (simp add: field_simps)
  done

end

sublocale residues < cring
  by (rule cring)

context residues
begin

text \<open>
  These lemmas translate back and forth between internal and
  external concepts.
\<close>

lemma res_carrier_eq: "carrier R = {0..m - 1}"
  unfolding R_def residue_ring_def by auto

lemma res_add_eq: "x \<oplus> y = (x + y) mod m"
  unfolding R_def residue_ring_def by auto

lemma res_mult_eq: "x \<otimes> y = (x * y) mod m"
  unfolding R_def residue_ring_def by auto

lemma res_zero_eq: "\<zero> = 0"
  unfolding R_def residue_ring_def by auto

lemma res_one_eq: "\<one> = 1"
  unfolding R_def residue_ring_def units_of_def by auto

lemma res_units_eq: "Units R = {x. 0 < x \<and> x < m \<and> coprime x m}"
  apply (insert m_gt_one)
  apply (unfold Units_def R_def residue_ring_def)
  apply auto
  apply (subgoal_tac "x \<noteq> 0")
  apply auto
  apply (metis invertible_coprime_int)
  apply (subst (asm) coprime_iff_invertible'_int)
  apply (auto simp add: cong_int_def mult.commute)
  done

lemma res_neg_eq: "\<ominus> x = (- x) mod m"
  apply (insert m_gt_one)
  apply (unfold R_def a_inv_def m_inv_def residue_ring_def)
  apply auto
  apply (rule the_equality)
  apply auto
  apply (subst mod_add_right_eq [symmetric])
  apply auto
  apply (subst mod_add_left_eq [symmetric])
  apply auto
  apply (subgoal_tac "y mod m = - x mod m")
  apply simp
  apply (metis minus_add_cancel mod_mult_self1 mult.commute)
  done

lemma finite [iff]: "finite (carrier R)"
  by (subst res_carrier_eq) auto

lemma finite_Units [iff]: "finite (Units R)"
  by (subst res_units_eq) auto

text \<open>
  The function \<open>a \<mapsto> a mod m\<close> maps the integers to the
  residue classes. The following lemmas show that this mapping
  respects addition and multiplication on the integers.
\<close>

lemma mod_in_carrier [iff]: "a mod m \<in> carrier R"
  unfolding res_carrier_eq
  using insert m_gt_one by auto

lemma add_cong: "(x mod m) \<oplus> (y mod m) = (x + y) mod m"
  unfolding R_def residue_ring_def
  apply auto
  apply presburger
  done

lemma mult_cong: "(x mod m) \<otimes> (y mod m) = (x * y) mod m"
  unfolding R_def residue_ring_def
  by auto (metis mod_mult_eq)

lemma zero_cong: "\<zero> = 0"
  unfolding R_def residue_ring_def by auto

lemma one_cong: "\<one> = 1 mod m"
  using m_gt_one unfolding R_def residue_ring_def by auto

(* FIXME revise algebra library to use 1? *)
lemma pow_cong: "(x mod m) (^) n = x^n mod m"
  apply (insert m_gt_one)
  apply (induct n)
  apply (auto simp add: nat_pow_def one_cong)
  apply (metis mult.commute mult_cong)
  done

lemma neg_cong: "\<ominus> (x mod m) = (- x) mod m"
  by (metis mod_minus_eq res_neg_eq)

lemma (in residues) prod_cong: "finite A \<Longrightarrow> (\<Otimes>i\<in>A. (f i) mod m) = (\<Prod>i\<in>A. f i) mod m"
  by (induct set: finite) (auto simp: one_cong mult_cong)

lemma (in residues) sum_cong: "finite A \<Longrightarrow> (\<Oplus>i\<in>A. (f i) mod m) = (\<Sum>i\<in>A. f i) mod m"
  by (induct set: finite) (auto simp: zero_cong add_cong)

lemma mod_in_res_units [simp]:
  assumes "1 < m" and "coprime a m"
  shows "a mod m \<in> Units R"
proof (cases "a mod m = 0")
  case True with assms show ?thesis
    by (auto simp add: res_units_eq gcd_red_int [symmetric])
next
  case False
  from assms have "0 < m" by simp
  with pos_mod_sign [of m a] have "0 \<le> a mod m" .
  with False have "0 < a mod m" by simp
  with assms show ?thesis
    by (auto simp add: res_units_eq gcd_red_int [symmetric] ac_simps)
qed

lemma res_eq_to_cong: "(a mod m) = (b mod m) \<longleftrightarrow> [a = b] (mod m)"
  unfolding cong_int_def by auto

text \<open>Simplifying with these will translate a ring equation in R to a congruence.\<close>
lemmas res_to_cong_simps = add_cong mult_cong pow_cong one_cong
    prod_cong sum_cong neg_cong res_eq_to_cong

text \<open>Other useful facts about the residue ring.\<close>
lemma one_eq_neg_one: "\<one> = \<ominus> \<one> \<Longrightarrow> m = 2"
  apply (simp add: res_one_eq res_neg_eq)
  apply (metis add.commute add_diff_cancel mod_mod_trivial one_add_one uminus_add_conv_diff
    zero_neq_one zmod_zminus1_eq_if)
  done

end

subsection \<open>Prime residues\<close>

locale residues_prime =
  fixes p :: nat and R (structure)
  assumes p_prime [intro]: "prime p"
  defines "R \<equiv> residue_ring (int p)"

sublocale residues_prime < residues p
  apply (unfold R_def residues_def)
  using p_prime apply auto
  apply (metis (full_types) of_nat_1 of_nat_less_iff prime_gt_1_nat)
  done

context residues_prime
begin

lemma is_field: "field R"
  apply (rule cring.field_intro2)
  apply (rule cring)
  apply (auto simp add: res_carrier_eq res_one_eq res_zero_eq res_units_eq)
  apply (rule classical)
  apply (erule notE)
  apply (subst gcd.commute)
  apply (rule prime_imp_coprime_int)
  apply (simp add: p_prime)
  apply (rule notI)
  apply (frule zdvd_imp_le)
  apply auto
  done

lemma res_prime_units_eq: "Units R = {1..p - 1}"
  apply (subst res_units_eq)
  apply auto
  apply (subst gcd.commute)
  apply (auto simp add: p_prime prime_imp_coprime_int zdvd_not_zless)
  done

end

sublocale residues_prime < field
  by (rule is_field)

section \<open>Test cases: Euler's theorem and Wilson's theorem\<close>

subsection \<open>Euler's theorem\<close>

text \<open>The definition of the phi function.\<close>

definition phi :: "int \<Rightarrow> nat"
  where "phi m = card {x. 0 < x \<and> x < m \<and> gcd x m = 1}"

lemma phi_def_nat: "phi m = card {x. 0 < x \<and> x < nat m \<and> gcd x (nat m) = 1}"
  apply (simp add: phi_def)
  apply (rule bij_betw_same_card [of nat])
  apply (auto simp add: inj_on_def bij_betw_def image_def)
  apply (metis dual_order.irrefl dual_order.strict_trans leI nat_1 transfer_nat_int_gcd(1))
  apply (metis One_nat_def of_nat_0 of_nat_1 of_nat_less_0_iff int_nat_eq nat_int
    transfer_int_nat_gcd(1) of_nat_less_iff)
  done

lemma prime_phi:
  assumes "2 \<le> p" "phi p = p - 1"
  shows "prime p"
proof -
  have *: "{x. 0 < x \<and> x < p \<and> coprime x p} = {1..p - 1}"
    using assms unfolding phi_def_nat
    by (intro card_seteq) fastforce+
  have False if **: "1 < x" "x < p" and "x dvd p" for x :: nat
  proof -
    from * have cop: "x \<in> {1..p - 1} \<Longrightarrow> coprime x p"
      by blast
    have "coprime x p"
      apply (rule cop)
      using ** apply auto
      done
    with \<open>x dvd p\<close> \<open>1 < x\<close> show ?thesis
      by auto
  qed
  then show ?thesis
    using \<open>2 \<le> p\<close>
    by (simp add: prime_nat_iff)
       (metis One_nat_def dvd_pos_nat nat_dvd_not_less nat_neq_iff not_gr0
              not_numeral_le_zero one_dvd)
qed

lemma phi_zero [simp]: "phi 0 = 0"
  unfolding phi_def
(* Auto hangs here. Once again, where is the simplification rule
   1 \<equiv> Suc 0 coming from? *)
  apply (auto simp add: card_eq_0_iff)
(* Add card_eq_0_iff as a simp rule? delete card_empty_imp? *)
  done

lemma phi_one [simp]: "phi 1 = 0"
  by (auto simp add: phi_def card_eq_0_iff)

lemma (in residues) phi_eq: "phi m = card (Units R)"
  by (simp add: phi_def res_units_eq)

lemma (in residues) euler_theorem1:
  assumes a: "gcd a m = 1"
  shows "[a^phi m = 1] (mod m)"
proof -
  from a m_gt_one have [simp]: "a mod m \<in> Units R"
    by (intro mod_in_res_units)
  from phi_eq have "(a mod m) (^) (phi m) = (a mod m) (^) (card (Units R))"
    by simp
  also have "\<dots> = \<one>"
    by (intro units_power_order_eq_one) auto
  finally show ?thesis
    by (simp add: res_to_cong_simps)
qed

(* In fact, there is a two line proof!

lemma (in residues) euler_theorem1:
  assumes a: "gcd a m = 1"
  shows "[a^phi m = 1] (mod m)"
proof -
  have "(a mod m) (^) (phi m) = \<one>"
    by (simp add: phi_eq units_power_order_eq_one a m_gt_one)
  then show ?thesis
    by (simp add: res_to_cong_simps)
qed

*)

text \<open>Outside the locale, we can relax the restriction \<open>m > 1\<close>.\<close>
lemma euler_theorem:
  assumes "m \<ge> 0"
    and "gcd a m = 1"
  shows "[a^phi m = 1] (mod m)"
proof (cases "m = 0 | m = 1")
  case True
  then show ?thesis by auto
next
  case False
  with assms show ?thesis
    by (intro residues.euler_theorem1, unfold residues_def, auto)
qed

lemma (in residues_prime) phi_prime: "phi p = nat p - 1"
  apply (subst phi_eq)
  apply (subst res_prime_units_eq)
  apply auto
  done

lemma phi_prime: "prime (int p) \<Longrightarrow> phi p = nat p - 1"
  apply (rule residues_prime.phi_prime)
  apply simp
  apply (erule residues_prime.intro)
  done

lemma fermat_theorem:
  fixes a :: int
  assumes "prime (int p)"
    and "\<not> p dvd a"
  shows "[a^(p - 1) = 1] (mod p)"
proof -
  from assms have "[a ^ phi p = 1] (mod p)"
    by (auto intro!: euler_theorem intro!: prime_imp_coprime_int[of p]
             simp: gcd.commute[of _ "int p"])
  also have "phi p = nat p - 1"
    by (rule phi_prime) (rule assms)
  finally show ?thesis
    by (metis nat_int)
qed

lemma fermat_theorem_nat:
  assumes "prime (int p)" and "\<not> p dvd a"
  shows "[a ^ (p - 1) = 1] (mod p)"
  using fermat_theorem [of p a] assms
  by (metis of_nat_1 of_nat_power transfer_int_nat_cong zdvd_int)

subsection \<open>Wilson's theorem\<close>

lemma (in field) inv_pair_lemma: "x \<in> Units R \<Longrightarrow> y \<in> Units R \<Longrightarrow>
    {x, inv x} \<noteq> {y, inv y} \<Longrightarrow> {x, inv x} \<inter> {y, inv y} = {}"
  apply auto
  apply (metis Units_inv_inv)+
  done

lemma (in residues_prime) wilson_theorem1:
  assumes a: "p > 2"
  shows "[fact (p - 1) = (-1::int)] (mod p)"
proof -
  let ?Inverse_Pairs = "{{x, inv x}| x. x \<in> Units R - {\<one>, \<ominus> \<one>}}"
  have UR: "Units R = {\<one>, \<ominus> \<one>} \<union> \<Union>?Inverse_Pairs"
    by auto
  have "(\<Otimes>i\<in>Units R. i) = (\<Otimes>i\<in>{\<one>, \<ominus> \<one>}. i) \<otimes> (\<Otimes>i\<in>\<Union>?Inverse_Pairs. i)"
    apply (subst UR)
    apply (subst finprod_Un_disjoint)
    apply (auto intro: funcsetI)
    using inv_one apply auto[1]
    using inv_eq_neg_one_eq apply auto
    done
  also have "(\<Otimes>i\<in>{\<one>, \<ominus> \<one>}. i) = \<ominus> \<one>"
    apply (subst finprod_insert)
    apply auto
    apply (frule one_eq_neg_one)
    using a apply force
    done
  also have "(\<Otimes>i\<in>(\<Union>?Inverse_Pairs). i) = (\<Otimes>A\<in>?Inverse_Pairs. (\<Otimes>y\<in>A. y))"
    apply (subst finprod_Union_disjoint)
    apply auto
    apply (metis Units_inv_inv)+
    done
  also have "\<dots> = \<one>"
    apply (rule finprod_one)
    apply auto
    apply (subst finprod_insert)
    apply auto
    apply (metis inv_eq_self)
    done
  finally have "(\<Otimes>i\<in>Units R. i) = \<ominus> \<one>"
    by simp
  also have "(\<Otimes>i\<in>Units R. i) = (\<Otimes>i\<in>Units R. i mod p)"
    apply (rule finprod_cong')
    apply auto
    apply (subst (asm) res_prime_units_eq)
    apply auto
    done
  also have "\<dots> = (\<Prod>i\<in>Units R. i) mod p"
    apply (rule prod_cong)
    apply auto
    done
  also have "\<dots> = fact (p - 1) mod p"
    apply (simp add: fact_prod)
    apply (insert assms)
    apply (subst res_prime_units_eq)
    apply (simp add: int_prod zmod_int prod_int_eq)
    done
  finally have "fact (p - 1) mod p = \<ominus> \<one>" .
  then show ?thesis
    by (metis of_nat_fact Divides.transfer_int_nat_functions(2)
      cong_int_def res_neg_eq res_one_eq)
qed

lemma wilson_theorem:
  assumes "prime p"
  shows "[fact (p - 1) = - 1] (mod p)"
proof (cases "p = 2")
  case True
  then show ?thesis
    by (simp add: cong_int_def fact_prod)
next
  case False
  then show ?thesis
    using assms prime_ge_2_nat
    by (metis residues_prime.wilson_theorem1 residues_prime.intro le_eq_less_or_eq)
qed

end


section \<open>Challenge 1.B\<close>
theory Challenge1B
  imports Challenge1A "HOL-Library.Multiset"
begin

(* TODO: Move *)
lemma mset_concat:
  "mset (concat xs) = fold (+) (map mset xs) {#}"
proof -
  have "mset (concat xs) + a = fold (+) (map mset xs) a" for a
  proof (induction xs arbitrary: a)
    case Nil
    then show ?case
      by auto
  next
    case (Cons x xs)
    show ?case
      using Cons.IH[of "mset x + a", symmetric] by simp
  qed
  from this[of "{#}"] show ?thesis
    by auto
qed

subsection \<open>Merging Two Segments\<close>

fun merge :: "'a::{linorder} list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   "merge [] l2 = l2"
 | "merge l1 [] = l1"
 | "merge (x1 # l1) (x2 # l2) =
    (if (x1 < x2) then x1 # (merge l1 (x2 # l2)) else x2 # (merge (x1 # l1) l2))"

lemma merge_correct:
  assumes "sorted l1"
  assumes "sorted l2"
  shows "
    sorted (merge l1 l2)
  \<and> mset (merge l1 l2) = mset l1 + mset l2
  \<and> set (merge l1 l2) = set l1 \<union> set l2"
  using assms
proof (induction l1 arbitrary: l2)
  case Nil thus ?case
    by simp
next
  case (Cons x1 l1 l2)
  note IH = Cons.IH

  show ?case
    using Cons.prems
  proof (induction l2)
    case Nil then show ?case
      by simp
  next
    case (Cons x2 l2)
    then show ?case
      using IH by (force split: if_split_asm)
  qed
qed

subsection \<open>Merging a List of Segments\<close>

function merge_list :: "'a::{linorder} list list \<Rightarrow> 'a list list \<Rightarrow> 'a list" where
   "merge_list [] [] = []"
 | "merge_list [] [l] = l"
 | "merge_list (la # acc2) [] = merge_list [] (la # acc2)"
 | "merge_list (la # acc2) [l] = merge_list [] (l # la # acc2)"
 | "merge_list acc2 (l1 # l2 # ls) =
    merge_list ((merge l1 l2) # acc2) ls"
by pat_completeness simp_all
termination by (relation "measure (\<lambda>(acc, ls). 3 * length acc + 2 * length ls)"; simp)

lemma merge_list_correct:
assumes "\<And>l. l \<in> set ls \<Longrightarrow> sorted l"
assumes "\<And>l. l \<in> set as \<Longrightarrow> sorted l"
shows "
  sorted (merge_list as ls)
\<and> mset (merge_list as ls) = mset (concat (as @ ls))
\<and> set (merge_list as ls) = set (concat (as @ ls))"
using assms
proof (induction as ls rule: merge_list.induct)
next
  case (4 la acc2 l)
  then show ?case
    by (auto simp: algebra_simps)
next
  case (5 acc2 l1 l2 ls)
  have "sorted (merge_list (merge l1 l2 # acc2) ls)
    \<and> mset (merge_list (merge l1 l2 # acc2) ls) = mset (concat ((merge l1 l2 # acc2) @ ls))
    \<and> set (merge_list (merge l1 l2 # acc2) ls) = set (concat ((merge l1 l2 # acc2) @ ls))"
    using 5(2-) merge_correct[of l1 l2] by (intro 5(1)) auto
  then show ?case
    using merge_correct[of l1 l2] 5(2-) by auto
qed simp+

subsection \<open>GHC-Sort\<close>

definition
  "ghc_sort xs = merge_list [] (map (\<lambda>ys. if decr ys then rev ys else ys) (cuts xs))"

lemma decr_sorted:
  assumes "decr xs"
  shows "sorted (rev xs)"
  using assms by (induction xs rule: decr.induct) (auto simp: sorted_append)

lemma incr_sorted:
  assumes "incr xs"
  shows "sorted xs"
  using assms by (induction xs rule: incr.induct) auto

lemma reverse_phase_sorted:
  "\<forall>ys \<in> set (map (\<lambda>ys. if decr ys then rev ys else ys) (cuts xs)). sorted ys"
  using cuts_incr_decr by (auto intro: decr_sorted incr_sorted)

lemma reverse_phase_elements:
  "set (concat (map (\<lambda>ys. if decr ys then rev ys else ys) (cuts xs))) = set xs"
proof -
  have "set (concat (map (\<lambda>ys. if decr ys then rev ys else ys) (cuts xs)))
    = set (concat (cuts xs))"
    by auto
  also have "\<dots> = set xs"
    by (simp add: concat_cuts)
  finally show ?thesis .
qed

lemma reverse_phase_permutation:
  "mset (concat (map (\<lambda>ys. if decr ys then rev ys else ys) (cuts xs))) = mset xs"
proof -
  have "mset (concat (map (\<lambda>ys. if decr ys then rev ys else ys) (cuts xs)))
    = mset (concat (cuts xs))"
    unfolding mset_concat by (auto simp: comp_def intro!: arg_cong2[where f = "fold (+)"])
  also have "\<dots> = mset xs"
    by (simp add: concat_cuts)
  finally show ?thesis .
qed

subsection \<open>Correctness Lemmas\<close>
text \<open>The result is sorted and a permutation of the original elements.\<close>

theorem sorted_ghc_sort:
  "sorted (ghc_sort xs)"
  unfolding ghc_sort_def using reverse_phase_sorted
  by (intro merge_list_correct[THEN conjunct1]) auto

theorem permutation_ghc_sort:
  "mset (ghc_sort xs) = mset xs"
  unfolding ghc_sort_def
  apply (subst merge_list_correct[THEN conjunct2])
  subgoal
    using reverse_phase_sorted by auto
  subgoal
    using reverse_phase_sorted by auto
  apply (subst (2) reverse_phase_permutation[symmetric])
  apply simp
  done

corollary elements_ghc_sort: "set (ghc_sort xs) = set xs"
  using permutation_ghc_sort by (metis set_mset_mset)

subsection \<open>Executable Code\<close>
export_code ghc_sort checking SML Scala OCaml? Haskell?

value [code] "ghc_sort [1,2,7,3,5,6,9,8,4]"

end