(*  Title:      HOL/Imperative_HOL/ex/Linked_Lists.thy
    Author:     Lukas Bulwahn, TU Muenchen
*)

section {* Linked Lists by ML references *}

theory Linked_Lists
imports "../Imperative_HOL" "~~/src/HOL/Library/Code_Target_Int"
begin

section {* Definition of Linked Lists *}

setup {* Sign.add_const_constraint (@{const_name Ref}, SOME @{typ "nat \<Rightarrow> 'a\<Colon>type ref"}) *}
datatype 'a node = Empty | Node 'a "'a node ref"

primrec
  node_encode :: "'a\<Colon>countable node \<Rightarrow> nat"
where
  "node_encode Empty = 0"
  | "node_encode (Node x r) = Suc (to_nat (x, r))"

instance node :: (countable) countable
proof (rule countable_classI [of "node_encode"])
  fix x y :: "'a\<Colon>countable node"
  show "node_encode x = node_encode y \<Longrightarrow> x = y"
  by (induct x, auto, induct y, auto, induct y, auto)
qed

instance node :: (heap) heap ..

primrec make_llist :: "'a\<Colon>heap list \<Rightarrow> 'a node Heap"
where
  [simp del]: "make_llist []     = return Empty"
            | "make_llist (x#xs) = do { tl \<leftarrow> make_llist xs;
                                        next \<leftarrow> ref tl;
                                        return (Node x next)
                                   }"

partial_function (heap) traverse :: "'a\<Colon>heap node \<Rightarrow> 'a list Heap"
where
  [code del]: "traverse l =
    (case l of Empty \<Rightarrow> return []
     | Node x r \<Rightarrow> do { tl \<leftarrow> Ref.lookup r;
                              xs \<leftarrow> traverse tl;
                              return (x#xs)
                         })"

lemma traverse_simps[code, simp]:
  "traverse Empty      = return []"
  "traverse (Node x r) = do { tl \<leftarrow> Ref.lookup r;
                              xs \<leftarrow> traverse tl;
                              return (x#xs)
                         }"
by (simp_all add: traverse.simps[of "Empty"] traverse.simps[of "Node x r"])

section {* Proving correctness with relational abstraction *}

subsection {* Definition of list_of, list_of', refs_of and refs_of' *}

primrec list_of :: "heap \<Rightarrow> ('a::heap) node \<Rightarrow> 'a list \<Rightarrow> bool"
where
  "list_of h r [] = (r = Empty)"
| "list_of h r (a#as) = (case r of Empty \<Rightarrow> False | Node b bs \<Rightarrow> (a = b \<and> list_of h (Ref.get h bs) as))"

definition list_of' :: "heap \<Rightarrow> ('a::heap) node ref \<Rightarrow> 'a list \<Rightarrow> bool"
where
  "list_of' h r xs = list_of h (Ref.get h r) xs"

primrec refs_of :: "heap \<Rightarrow> ('a::heap) node \<Rightarrow> 'a node ref list \<Rightarrow> bool"
where
  "refs_of h r [] = (r = Empty)"
| "refs_of h r (x#xs) = (case r of Empty \<Rightarrow> False | Node b bs \<Rightarrow> (x = bs) \<and> refs_of h (Ref.get h bs) xs)"

primrec refs_of' :: "heap \<Rightarrow> ('a::heap) node ref \<Rightarrow> 'a node ref list \<Rightarrow> bool"
where
  "refs_of' h r [] = False"
| "refs_of' h r (x#xs) = ((x = r) \<and> refs_of h (Ref.get h x) xs)"

subsection {* Properties of these definitions *}

lemma list_of_Empty[simp]: "list_of h Empty xs = (xs = [])"
by (cases xs, auto)

lemma list_of_Node[simp]: "list_of h (Node x ps) xs = (\<exists>xs'. (xs = x # xs') \<and> list_of h (Ref.get h ps) xs')"
by (cases xs, auto)

lemma list_of'_Empty[simp]: "Ref.get h q = Empty \<Longrightarrow> list_of' h q xs = (xs = [])"
unfolding list_of'_def by simp

lemma list_of'_Node[simp]: "Ref.get h q = Node x ps \<Longrightarrow> list_of' h q xs = (\<exists>xs'. (xs = x # xs') \<and> list_of' h ps xs')"
unfolding list_of'_def by simp

lemma list_of'_Nil: "list_of' h q [] \<Longrightarrow> Ref.get h q = Empty"
unfolding list_of'_def by simp

lemma list_of'_Cons:
assumes "list_of' h q (x#xs)"
obtains n where "Ref.get h q = Node x n" and "list_of' h n xs"
using assms unfolding list_of'_def by (auto split: node.split_asm)

lemma refs_of_Empty[simp] : "refs_of h Empty xs = (xs = [])"
  by (cases xs, auto)

lemma refs_of_Node[simp]: "refs_of h (Node x ps) xs = (\<exists>prs. xs = ps # prs \<and> refs_of h (Ref.get h ps) prs)"
  by (cases xs, auto)

lemma refs_of'_def': "refs_of' h p ps = (\<exists>prs. (ps = (p # prs)) \<and> refs_of h (Ref.get h p) prs)"
by (cases ps, auto)

lemma refs_of'_Node:
  assumes "refs_of' h p xs"
  assumes "Ref.get h p = Node x pn"
  obtains pnrs
  where "xs = p # pnrs" and "refs_of' h pn pnrs"
using assms
unfolding refs_of'_def' by auto

lemma list_of_is_fun: "\<lbrakk> list_of h n xs; list_of h n ys\<rbrakk> \<Longrightarrow> xs = ys"
proof (induct xs arbitrary: ys n)
  case Nil thus ?case by auto
next
  case (Cons x xs')
  thus ?case
    by (cases ys,  auto split: node.split_asm)
qed

lemma refs_of_is_fun: "\<lbrakk> refs_of h n xs; refs_of h n ys\<rbrakk> \<Longrightarrow> xs = ys"
proof (induct xs arbitrary: ys n)
  case Nil thus ?case by auto
next
  case (Cons x xs')
  thus ?case
    by (cases ys,  auto split: node.split_asm)
qed

lemma refs_of'_is_fun: "\<lbrakk> refs_of' h p as; refs_of' h p bs \<rbrakk> \<Longrightarrow> as = bs"
unfolding refs_of'_def' by (auto dest: refs_of_is_fun)

lemma list_of_refs_of_HOL:
  assumes "list_of h r xs"
  shows "\<exists>rs. refs_of h r rs"
using assms
proof (induct xs arbitrary: r)
  case Nil thus ?case by auto
next
  case (Cons x xs')
  thus ?case
    by (cases r, auto)
qed

lemma list_of_refs_of:
  assumes "list_of h r xs"
  obtains rs where "refs_of h r rs"
using list_of_refs_of_HOL[OF assms]
by auto

lemma list_of'_refs_of'_HOL:
  assumes "list_of' h r xs"
  shows "\<exists>rs. refs_of' h r rs"
proof -
  from assms obtain rs' where "refs_of h (Ref.get h r) rs'"
    unfolding list_of'_def by (rule list_of_refs_of)
  thus ?thesis unfolding refs_of'_def' by auto
qed

lemma list_of'_refs_of':
  assumes "list_of' h r xs"
  obtains rs where "refs_of' h r rs"
using list_of'_refs_of'_HOL[OF assms]
by auto

lemma refs_of_list_of_HOL:
  assumes "refs_of h r rs"
  shows "\<exists>xs. list_of h r xs"
using assms
proof (induct rs arbitrary: r)
  case Nil thus ?case by auto
next
  case (Cons r rs')
  thus ?case
    by (cases r, auto)
qed

lemma refs_of_list_of:
  assumes "refs_of h r rs"
  obtains xs where "list_of h r xs"
using refs_of_list_of_HOL[OF assms]
by auto

lemma refs_of'_list_of'_HOL:
  assumes "refs_of' h r rs"
  shows "\<exists>xs. list_of' h r xs"
using assms
unfolding list_of'_def refs_of'_def'
by (auto intro: refs_of_list_of)

lemma refs_of'_list_of':
  assumes "refs_of' h r rs"
  obtains xs where "list_of' h r xs"
using refs_of'_list_of'_HOL[OF assms]
by auto

lemma refs_of'E: "refs_of' h q rs \<Longrightarrow> q \<in> set rs"
unfolding refs_of'_def' by auto

lemma list_of'_refs_of'2:
  assumes "list_of' h r xs"
  shows "\<exists>rs'. refs_of' h r (r#rs')"
proof -
  from assms obtain rs where "refs_of' h r rs" by (rule list_of'_refs_of')
  thus ?thesis by (auto simp add: refs_of'_def')
qed

subsection {* More complicated properties of these predicates *}

lemma list_of_append:
  "list_of h n (as @ bs) \<Longrightarrow> \<exists>m. list_of h m bs"
apply (induct as arbitrary: n)
apply auto
apply (case_tac n)
apply auto
done

lemma refs_of_append: "refs_of h n (as @ bs) \<Longrightarrow> \<exists>m. refs_of h m bs"
apply (induct as arbitrary: n)
apply auto
apply (case_tac n)
apply auto
done

lemma refs_of_next:
assumes "refs_of h (Ref.get h p) rs"
  shows "p \<notin> set rs"
proof (rule ccontr)
  assume a: "\<not> (p \<notin> set rs)"
  from this obtain as bs where split:"rs = as @ p # bs" by (fastforce dest: split_list)
  with assms obtain q where "refs_of h q (p # bs)" by (fast dest: refs_of_append)
  with assms split show "False"
    by (cases q,auto dest: refs_of_is_fun)
qed

lemma refs_of_distinct: "refs_of h p rs \<Longrightarrow> distinct rs"
proof (induct rs arbitrary: p)
  case Nil thus ?case by simp
next
  case (Cons r rs')
  thus ?case
    by (cases p, auto simp add: refs_of_next)
qed

lemma refs_of'_distinct: "refs_of' h p rs \<Longrightarrow> distinct rs"
  unfolding refs_of'_def'
  by (fastforce simp add: refs_of_distinct refs_of_next)

subsection {* Interaction of these predicates with our heap transitions *}

lemma list_of_set_ref: "refs_of h q rs \<Longrightarrow> p \<notin> set rs \<Longrightarrow> list_of (Ref.set p v h) q as = list_of h q as"
using assms
proof (induct as arbitrary: q rs)
  case Nil thus ?case by simp
next
  case (Cons x xs)
  thus ?case
  proof (cases q)
    case Empty thus ?thesis by auto
  next
    case (Node a ref)
    from Cons(2) Node obtain rs' where 1: "refs_of h (Ref.get h ref) rs'" and rs_rs': "rs = ref # rs'" by auto
    from Cons(3) rs_rs' have "ref \<noteq> p" by fastforce
    hence ref_eq: "Ref.get (Ref.set p v h) ref = (Ref.get h ref)" by (auto simp add: Ref.get_set_neq)
    from rs_rs' Cons(3) have 2: "p \<notin> set rs'" by simp
    from Cons.hyps[OF 1 2] Node ref_eq show ?thesis by simp
  qed
qed

lemma refs_of_set_ref: "refs_of h q rs \<Longrightarrow> p \<notin> set rs \<Longrightarrow> refs_of (Ref.set p v h) q as = refs_of h q as"
proof (induct as arbitrary: q rs)
  case Nil thus ?case by simp
next
  case (Cons x xs)
  thus ?case
  proof (cases q)
    case Empty thus ?thesis by auto
  next
    case (Node a ref)
    from Cons(2) Node obtain rs' where 1: "refs_of h (Ref.get h ref) rs'" and rs_rs': "rs = ref # rs'" by auto
    from Cons(3) rs_rs' have "ref \<noteq> p" by fastforce
    hence ref_eq: "Ref.get (Ref.set p v h) ref = (Ref.get h ref)" by (auto simp add: Ref.get_set_neq)
    from rs_rs' Cons(3) have 2: "p \<notin> set rs'" by simp
    from Cons.hyps[OF 1 2] Node ref_eq show ?thesis by auto
  qed
qed

lemma refs_of_set_ref2: "refs_of (Ref.set p v h) q rs \<Longrightarrow> p \<notin> set rs \<Longrightarrow> refs_of (Ref.set p v h) q rs = refs_of h q rs"
proof (induct rs arbitrary: q)
  case Nil thus ?case by simp
next
  case (Cons x xs)
  thus ?case
  proof (cases q)
    case Empty thus ?thesis by auto
  next
    case (Node a ref)
    from Cons(2) Node have 1:"refs_of (Ref.set p v h) (Ref.get (Ref.set p v h) ref) xs" and x_ref: "x = ref" by auto
    from Cons(3) this have "ref \<noteq> p" by fastforce
    hence ref_eq: "Ref.get (Ref.set p v h) ref = (Ref.get h ref)" by (auto simp add: Ref.get_set_neq)
    from Cons(3) have 2: "p \<notin> set xs" by simp
    with Cons.hyps 1 2 Node ref_eq show ?thesis
      by simp
  qed
qed

lemma list_of'_set_ref:
  assumes "refs_of' h q rs"
  assumes "p \<notin> set rs"
  shows "list_of' (Ref.set p v h) q as = list_of' h q as"
proof -
  from assms have "q \<noteq> p" by (auto simp only: dest!: refs_of'E)
  with assms show ?thesis
    unfolding list_of'_def refs_of'_def'
    by (auto simp add: list_of_set_ref)
qed

lemma list_of'_set_next_ref_Node[simp]:
  assumes "list_of' h r xs"
  assumes "Ref.get h p = Node x r'"
  assumes "refs_of' h r rs"
  assumes "p \<notin> set rs"
  shows "list_of' (Ref.set p (Node x r) h) p (x#xs) = list_of' h r xs"
using assms
unfolding list_of'_def refs_of'_def'
by (auto simp add: list_of_set_ref Ref.noteq_sym)

lemma refs_of'_set_ref:
  assumes "refs_of' h q rs"
  assumes "p \<notin> set rs"
  shows "refs_of' (Ref.set p v h) q as = refs_of' h q as"
using assms
proof -
  from assms have "q \<noteq> p" by (auto simp only: dest!: refs_of'E)
  with assms show ?thesis
    unfolding refs_of'_def'
    by (auto simp add: refs_of_set_ref)
qed

lemma refs_of'_set_ref2:
  assumes "refs_of' (Ref.set p v h) q rs"
  assumes "p \<notin> set rs"
  shows "refs_of' (Ref.set p v h) q as = refs_of' h q as"
using assms
proof -
  from assms have "q \<noteq> p" by (auto simp only: dest!: refs_of'E)
  with assms show ?thesis
    unfolding refs_of'_def'
    apply auto
    apply (subgoal_tac "prs = prsa")
    apply (insert refs_of_set_ref2[of p v h "Ref.get h q"])
    apply (erule_tac x="prs" in meta_allE)
    apply auto
    apply (auto dest: refs_of_is_fun)
    done
qed

lemma refs_of'_set_next_ref:
assumes "Ref.get h1 p = Node x pn"
assumes "refs_of' (Ref.set p (Node x r1) h1) p rs"
obtains r1s where "rs = (p#r1s)" and "refs_of' h1 r1 r1s"
proof -
  from assms refs_of'_distinct[OF assms(2)] have "\<exists> r1s. rs = (p # r1s) \<and> refs_of' h1 r1 r1s"
    apply -
    unfolding refs_of'_def'[of _ p]
    apply (auto, frule refs_of_set_ref2) by (auto dest: Ref.noteq_sym)
  with assms that show thesis by auto
qed

section {* Proving make_llist and traverse correct *}

lemma refs_of_invariant:
  assumes "refs_of h (r::('a::heap) node) xs"
  assumes "\<forall>refs. refs_of h r refs \<longrightarrow> (\<forall>ref \<in> set refs. Ref.present h ref \<and> Ref.present h' ref \<and> Ref.get h ref = Ref.get h' ref)"
  shows "refs_of h' r xs"
using assms
proof (induct xs arbitrary: r)
  case Nil thus ?case by simp
next
  case (Cons x xs')
  from Cons(2) obtain v where Node: "r = Node v x" by (cases r, auto)
  from Cons(2) Node have refs_of_next: "refs_of h (Ref.get h x) xs'" by simp
  from Cons(2-3) Node have ref_eq: "Ref.get h x = Ref.get h' x" by auto
  from ref_eq refs_of_next have 1: "refs_of h (Ref.get h' x) xs'" by simp
  from Cons(2) Cons(3) have "\<forall>ref \<in> set xs'. Ref.present h ref \<and> Ref.present h' ref \<and> Ref.get h ref = Ref.get h' ref"
    by fastforce
  with Cons(3) 1 have 2: "\<forall>refs. refs_of h (Ref.get h' x) refs \<longrightarrow> (\<forall>ref \<in> set refs. Ref.present h ref \<and> Ref.present h' ref \<and> Ref.get h ref = Ref.get h' ref)"
    by (fastforce dest: refs_of_is_fun)
  from Cons.hyps[OF 1 2] have "refs_of h' (Ref.get h' x) xs'" .
  with Node show ?case by simp
qed

lemma refs_of'_invariant:
  assumes "refs_of' h r xs"
  assumes "\<forall>refs. refs_of' h r refs \<longrightarrow> (\<forall>ref \<in> set refs. Ref.present h ref \<and> Ref.present h' ref \<and> Ref.get h ref = Ref.get h' ref)"
  shows "refs_of' h' r xs"
using assms
proof -
  from assms obtain prs where refs:"refs_of h (Ref.get h r) prs" and xs_def: "xs = r # prs"
    unfolding refs_of'_def' by auto
  from xs_def assms have x_eq: "Ref.get h r = Ref.get h' r" by fastforce
  from refs assms xs_def have 2: "\<forall>refs. refs_of h (Ref.get h r) refs \<longrightarrow>
     (\<forall>ref\<in>set refs. Ref.present h ref \<and> Ref.present h' ref \<and> Ref.get h ref = Ref.get h' ref)"
    by (fastforce dest: refs_of_is_fun)
  from refs_of_invariant [OF refs 2] xs_def x_eq show ?thesis
    unfolding refs_of'_def' by auto
qed

lemma list_of_invariant:
  assumes "list_of h (r::('a::heap) node) xs"
  assumes "\<forall>refs. refs_of h r refs \<longrightarrow> (\<forall>ref \<in> set refs. Ref.present h ref \<and> Ref.present h' ref \<and> Ref.get h ref = Ref.get h' ref)"
  shows "list_of h' r xs"
using assms
proof (induct xs arbitrary: r)
  case Nil thus ?case by simp
next
  case (Cons x xs')

  from Cons(2) obtain ref where Node: "r = Node x ref"
    by (cases r, auto)
  from Cons(2) obtain rs where rs_def: "refs_of h r rs" by (rule list_of_refs_of)
  from Node rs_def obtain rss where refs_of: "refs_of h r (ref#rss)" and rss_def: "rs = ref#rss" by auto
  from Cons(3) Node refs_of have ref_eq: "Ref.get h ref = Ref.get h' ref"
    by auto
  from Cons(2) ref_eq Node have 1: "list_of h (Ref.get h' ref) xs'" by simp
  from refs_of Node ref_eq have refs_of_ref: "refs_of h (Ref.get h' ref) rss" by simp
  from Cons(3) rs_def have rs_heap_eq: "\<forall>ref\<in>set rs. Ref.present h ref \<and> Ref.present h' ref \<and> Ref.get h ref = Ref.get h' ref" by simp
  from refs_of_ref rs_heap_eq rss_def have 2: "\<forall>refs. refs_of h (Ref.get h' ref) refs \<longrightarrow>
          (\<forall>ref\<in>set refs. Ref.present h ref \<and> Ref.present h' ref \<and> Ref.get h ref = Ref.get h' ref)"
    by (auto dest: refs_of_is_fun)
  from Cons(1)[OF 1 2]
  have "list_of h' (Ref.get h' ref) xs'" .
  with Node show ?case
    unfolding list_of'_def
    by simp
qed

lemma effect_ref:
  assumes "effect (ref v) h h' x"
  obtains "Ref.get h' x = v"
  and "\<not> Ref.present h x"
  and "Ref.present h' x"
  and "\<forall>y. Ref.present h y \<longrightarrow> Ref.get h y = Ref.get h' y"
 (* and "lim h' = Suc (lim h)" *)
  and "\<forall>y. Ref.present h y \<longrightarrow> Ref.present h' y"
  using assms
  unfolding Ref.ref_def
  apply (elim effect_heapE)
  unfolding Ref.alloc_def
  apply (simp add: Let_def)
  unfolding Ref.present_def
  apply auto
  unfolding Ref.get_def Ref.set_def
  apply auto
  done

lemma make_llist:
assumes "effect (make_llist xs) h h' r"
shows "list_of h' r xs \<and> (\<forall>rs. refs_of h' r rs \<longrightarrow> (\<forall>ref \<in> (set rs). Ref.present h' ref))"
using assms
proof (induct xs arbitrary: h h' r)
  case Nil thus ?case by (auto elim: effect_returnE simp add: make_llist.simps)
next
  case (Cons x xs')
  from Cons.prems obtain h1 r1 r' where make_llist: "effect (make_llist xs') h h1 r1"
    and effect_refnew:"effect (ref r1) h1 h' r'" and Node: "r = Node x r'"
    unfolding make_llist.simps
    by (auto elim!: effect_bindE effect_returnE)
  from Cons.hyps[OF make_llist] have list_of_h1: "list_of h1 r1 xs'" ..
  from Cons.hyps[OF make_llist] obtain rs' where rs'_def: "refs_of h1 r1 rs'" by (auto intro: list_of_refs_of)
  from Cons.hyps[OF make_llist] rs'_def have refs_present: "\<forall>ref\<in>set rs'. Ref.present h1 ref" by simp
  from effect_refnew rs'_def refs_present have refs_unchanged: "\<forall>refs. refs_of h1 r1 refs \<longrightarrow>
         (\<forall>ref\<in>set refs. Ref.present h1 ref \<and> Ref.present h' ref \<and> Ref.get h1 ref = Ref.get h' ref)"
    by (auto elim!: effect_ref dest: refs_of_is_fun)
  with list_of_invariant[OF list_of_h1 refs_unchanged] Node effect_refnew have fstgoal: "list_of h' r (x # xs')"
    unfolding list_of.simps
    by (auto elim!: effect_refE)
  from refs_unchanged rs'_def have refs_still_present: "\<forall>ref\<in>set rs'. Ref.present h' ref" by auto
  from refs_of_invariant[OF rs'_def refs_unchanged] refs_unchanged Node effect_refnew refs_still_present
  have sndgoal: "\<forall>rs. refs_of h' r rs \<longrightarrow> (\<forall>ref\<in>set rs. Ref.present h' ref)"
    by (fastforce elim!: effect_refE dest: refs_of_is_fun)
  from fstgoal sndgoal show ?case ..
qed

lemma traverse: "list_of h n r \<Longrightarrow> effect (traverse n) h h r"
proof (induct r arbitrary: n)
  case Nil
  thus ?case
    by (auto intro: effect_returnI)
next
  case (Cons x xs)
  thus ?case
  apply (cases n, auto)
  by (auto intro!: effect_bindI effect_returnI effect_lookupI)
qed

lemma traverse_make_llist':
  assumes effect: "effect (make_llist xs \<guillemotright>= traverse) h h' r"
  shows "r = xs"
proof -
  from effect obtain h1 r1
    where makell: "effect (make_llist xs) h h1 r1"
    and trav: "effect (traverse r1) h1 h' r"
    by (auto elim!: effect_bindE)
  from make_llist[OF makell] have "list_of h1 r1 xs" ..
  from traverse [OF this] trav show ?thesis
    using effect_deterministic by fastforce
qed

section {* Proving correctness of in-place reversal *}

subsection {* Definition of in-place reversal *}

partial_function (heap) rev' :: "('a::heap) node ref \<Rightarrow> 'a node ref \<Rightarrow> 'a node ref Heap"
where
  [code]: "rev' q p =
   do {
     v \<leftarrow> !p;
     (case v of
        Empty \<Rightarrow> return q
      | Node x next \<Rightarrow>
        do {
          p := Node x q;
          rev' p next
        })
    }"

primrec rev :: "('a:: heap) node \<Rightarrow> 'a node Heap"
where
  "rev Empty = return Empty"
| "rev (Node x n) = do { q \<leftarrow> ref Empty; p \<leftarrow> ref (Node x n); v \<leftarrow> rev' q p; !v }"

subsection {* Correctness Proof *}

lemma rev'_invariant:
  assumes "effect (rev' q p) h h' v"
  assumes "list_of' h q qs"
  assumes "list_of' h p ps"
  assumes "\<forall>qrs prs. refs_of' h q qrs \<and> refs_of' h p prs \<longrightarrow> set prs \<inter> set qrs = {}"
  shows "\<exists>vs. list_of' h' v vs \<and> vs = (List.rev ps) @ qs"
using assms
proof (induct ps arbitrary: qs p q h)
  case Nil
  thus ?case
    unfolding rev'.simps[of q p] list_of'_def
    by (auto elim!: effect_bindE effect_lookupE effect_returnE)
next
  case (Cons x xs)
  (*"LinkedList.list_of h' (get_ref v h') (List.rev xs @ x # qsa)"*)
  from Cons(4) obtain ref where
    p_is_Node: "Ref.get h p = Node x ref"
    (*and "ref_present ref h"*)
    and list_of'_ref: "list_of' h ref xs"
    unfolding list_of'_def by (cases "Ref.get h p", auto)
  from p_is_Node Cons(2) have effect_rev': "effect (rev' p ref) (Ref.set p (Node x q) h) h' v"
    by (auto simp add: rev'.simps [of q p] elim!: effect_bindE effect_lookupE effect_updateE)
  from Cons(3) obtain qrs where qrs_def: "refs_of' h q qrs" by (elim list_of'_refs_of')
  from Cons(4) obtain prs where prs_def: "refs_of' h p prs" by (elim list_of'_refs_of')
  from qrs_def prs_def Cons(5) have distinct_pointers: "set qrs \<inter> set prs = {}" by fastforce
  from qrs_def prs_def distinct_pointers refs_of'E have p_notin_qrs: "p \<notin> set qrs" by fastforce
  from Cons(3) qrs_def this have 1: "list_of' (Ref.set p (Node x q) h) p (x#qs)"
    unfolding list_of'_def
    apply (simp)
    unfolding list_of'_def[symmetric]
    by (simp add: list_of'_set_ref)
  from list_of'_refs_of'2[OF Cons(4)] p_is_Node prs_def obtain refs where refs_def: "refs_of' h ref refs" and prs_refs: "prs = p # refs"
    unfolding refs_of'_def' by auto
  from prs_refs prs_def have p_not_in_refs: "p \<notin> set refs"
    by (fastforce dest!: refs_of'_distinct)
  with refs_def p_is_Node list_of'_ref have 2: "list_of' (Ref.set p (Node x q) h) ref xs"
    by (auto simp add: list_of'_set_ref)
  from p_notin_qrs qrs_def have refs_of1: "refs_of' (Ref.set p (Node x q) h) p (p#qrs)"
    unfolding refs_of'_def'
    apply (simp)
    unfolding refs_of'_def'[symmetric]
    by (simp add: refs_of'_set_ref)
  from p_not_in_refs p_is_Node refs_def have refs_of2: "refs_of' (Ref.set p (Node x q) h) ref refs"
    by (simp add: refs_of'_set_ref)
  from p_not_in_refs refs_of1 refs_of2 distinct_pointers prs_refs have 3: "\<forall>qrs prs. refs_of' (Ref.set p (Node x q) h) p qrs \<and> refs_of' (Ref.set p (Node x q) h) ref prs \<longrightarrow> set prs \<inter> set qrs = {}"
    apply - apply (rule allI)+ apply (rule impI) apply (erule conjE)
    apply (drule refs_of'_is_fun) back back apply assumption
    apply (drule refs_of'_is_fun) back back apply assumption
    apply auto done
  from Cons.hyps [OF effect_rev' 1 2 3] show ?case by simp
qed

lemma rev_correctness:
  assumes list_of_h: "list_of h r xs"
  assumes validHeap: "\<forall>refs. refs_of h r refs \<longrightarrow> (\<forall>r \<in> set refs. Ref.present h r)"
  assumes effect_rev: "effect (rev r) h h' r'"
  shows "list_of h' r' (List.rev xs)"
using assms
proof (cases r)
  case Empty
  with list_of_h effect_rev show ?thesis
    by (auto simp add: list_of_Empty elim!: effect_returnE)
next
  case (Node x ps)
  with effect_rev obtain p q h1 h2 h3 v where
    init: "effect (ref Empty) h h1 q"
    "effect (ref (Node x ps)) h1 h2 p"
    and effect_rev':"effect (rev' q p) h2 h3 v"
    and lookup: "effect (!v) h3 h' r'"
    using rev.simps
    by (auto elim!: effect_bindE)
  from init have a1:"list_of' h2 q []"
    unfolding list_of'_def
    by (auto elim!: effect_ref)
  from list_of_h obtain refs where refs_def: "refs_of h r refs" by (rule list_of_refs_of)
  from validHeap init refs_def have heap_eq: "\<forall>refs. refs_of h r refs \<longrightarrow> (\<forall>ref\<in>set refs. Ref.present h ref \<and> Ref.present h2 ref \<and> Ref.get h ref = Ref.get h2 ref)"
    by (fastforce elim!: effect_ref dest: refs_of_is_fun)
  from list_of_invariant[OF list_of_h heap_eq] have "list_of h2 r xs" .
  from init this Node have a2: "list_of' h2 p xs"
    apply -
    unfolding list_of'_def
    apply (auto elim!: effect_refE)
    done
  from init have refs_of_q: "refs_of' h2 q [q]"
    by (auto elim!: effect_ref)
  from refs_def Node have refs_of'_ps: "refs_of' h ps refs"
    by (auto simp add: refs_of'_def'[symmetric])
  from validHeap refs_def have all_ref_present: "\<forall>r\<in>set refs. Ref.present h r" by simp
  from init refs_of'_ps this
    have heap_eq: "\<forall>refs. refs_of' h ps refs \<longrightarrow> (\<forall>ref\<in>set refs. Ref.present h ref \<and> Ref.present h2 ref \<and> Ref.get h ref = Ref.get h2 ref)"
    by (auto elim!: effect_ref [where ?'a="'a node", where ?'b="'a node", where ?'c="'a node"] dest: refs_of'_is_fun)
  from refs_of'_invariant[OF refs_of'_ps this] have "refs_of' h2 ps refs" .
  with init have refs_of_p: "refs_of' h2 p (p#refs)"
    by (auto elim!: effect_refE simp add: refs_of'_def')
  with init all_ref_present have q_is_new: "q \<notin> set (p#refs)"
    by (auto elim!: effect_refE intro!: Ref.noteq_I)
  from refs_of_p refs_of_q q_is_new have a3: "\<forall>qrs prs. refs_of' h2 q qrs \<and> refs_of' h2 p prs \<longrightarrow> set prs \<inter> set qrs = {}"
    by (fastforce simp only: list.set dest: refs_of'_is_fun)
  from rev'_invariant [OF effect_rev' a1 a2 a3] have "list_of h3 (Ref.get h3 v) (List.rev xs)"
    unfolding list_of'_def by auto
  with lookup show ?thesis
    by (auto elim: effect_lookupE)
qed

section {* The merge function on Linked Lists *}
text {* We also prove merge correct *}

text{* First, we define merge on lists in a natural way. *}

fun Lmerge :: "('a::ord) list \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "Lmerge (x#xs) (y#ys) =
     (if x \<le> y then x # Lmerge xs (y#ys) else y # Lmerge (x#xs) ys)"
| "Lmerge [] ys = ys"
| "Lmerge xs [] = xs"

subsection {* Definition of merge function *}

partial_function (heap) merge :: "('a::{heap, ord}) node ref \<Rightarrow> 'a node ref \<Rightarrow> 'a node ref Heap"
where
[code]: "merge p q = (do { v \<leftarrow> !p; w \<leftarrow> !q;
  (case v of Empty \<Rightarrow> return q
          | Node valp np \<Rightarrow>
            (case w of Empty \<Rightarrow> return p
                     | Node valq nq \<Rightarrow>
                       if (valp \<le> valq) then do {
                         npq \<leftarrow> merge np q;
                         p := Node valp npq;
                         return p }
                       else do {
                         pnq \<leftarrow> merge p nq;
                         q := Node valq pnq;
                         return q }))})"

lemma if_return: "(if P then return x else return y) = return (if P then x else y)"
by auto

lemma if_distrib_App: "(if P then f else g) x = (if P then f x else g x)"
by auto
lemma redundant_if: "(if P then (if P then x else z) else y) = (if P then x else y)"
  "(if P then x else (if P then z else y)) = (if P then x else y)"
by auto

lemma sum_distrib: "case_sum fl fr (case x of Empty \<Rightarrow> y | Node v n \<Rightarrow> (z v n)) = (case x of Empty \<Rightarrow> case_sum fl fr y | Node v n \<Rightarrow> case_sum fl fr (z v n))"
by (cases x) auto

subsection {* Induction refinement by applying the abstraction function to our induct rule *}

text {* From our original induction rule Lmerge.induct, we derive a new rule with our list_of' predicate *}

lemma merge_induct2:
  assumes "list_of' h (p::'a::{heap, ord} node ref) xs"
  assumes "list_of' h q ys"
  assumes "\<And> ys p q. \<lbrakk> list_of' h p []; list_of' h q ys; Ref.get h p = Empty \<rbrakk> \<Longrightarrow> P p q [] ys"
  assumes "\<And> x xs' p q pn. \<lbrakk> list_of' h p (x#xs'); list_of' h q []; Ref.get h p = Node x pn; Ref.get h q = Empty \<rbrakk> \<Longrightarrow> P p q (x#xs') []"
  assumes "\<And> x xs' y ys' p q pn qn.
  \<lbrakk> list_of' h p (x#xs'); list_of' h q (y#ys'); Ref.get h p = Node x pn; Ref.get h q = Node y qn;
  x \<le> y; P pn q xs' (y#ys') \<rbrakk>
  \<Longrightarrow> P p q (x#xs') (y#ys')"
  assumes "\<And> x xs' y ys' p q pn qn.
  \<lbrakk> list_of' h p (x#xs'); list_of' h q (y#ys'); Ref.get h p = Node x pn; Ref.get h q = Node y qn;
  \<not> x \<le> y; P p qn (x#xs') ys'\<rbrakk>
  \<Longrightarrow> P p q (x#xs') (y#ys')"
  shows "P p q xs ys"
using assms(1-2)
proof (induct xs ys arbitrary: p q rule: Lmerge.induct)
  case (2 ys)
  from 2(1) have "Ref.get h p = Empty" unfolding list_of'_def by simp
  with 2(1-2) assms(3) show ?case by blast
next
  case (3 x xs')
  from 3(1) obtain pn where Node: "Ref.get h p = Node x pn" by (rule list_of'_Cons)
  from 3(2) have "Ref.get h q = Empty" unfolding list_of'_def by simp
  with Node 3(1-2) assms(4) show ?case by blast
next
  case (1 x xs' y ys')
  from 1(3) obtain pn where pNode:"Ref.get h p = Node x pn"
    and list_of'_pn: "list_of' h pn xs'" by (rule list_of'_Cons)
  from 1(4) obtain qn where qNode:"Ref.get h q = Node y qn"
    and  list_of'_qn: "list_of' h qn ys'" by (rule list_of'_Cons)
  show ?case
  proof (cases "x \<le> y")
    case True
    from 1(1)[OF True list_of'_pn 1(4)] assms(5) 1(3-4) pNode qNode True
    show ?thesis by blast
  next
    case False
    from 1(2)[OF False 1(3) list_of'_qn] assms(6) 1(3-4) pNode qNode False
    show ?thesis by blast
  qed
qed

text {* secondly, we add the effect statement in the premise, and derive the effect statements for the single cases which we then eliminate with our effect elim rules. *}

lemma merge_induct3:
assumes  "list_of' h p xs"
assumes  "list_of' h q ys"
assumes  "effect (merge p q) h h' r"
assumes  "\<And> ys p q. \<lbrakk> list_of' h p []; list_of' h q ys; Ref.get h p = Empty \<rbrakk> \<Longrightarrow> P p q h h q [] ys"
assumes  "\<And> x xs' p q pn. \<lbrakk> list_of' h p (x#xs'); list_of' h q []; Ref.get h p = Node x pn; Ref.get h q = Empty \<rbrakk> \<Longrightarrow> P p q h h p (x#xs') []"
assumes  "\<And> x xs' y ys' p q pn qn h1 r1 h'.
  \<lbrakk> list_of' h p (x#xs'); list_of' h q (y#ys');Ref.get h p = Node x pn; Ref.get h q = Node y qn;
  x \<le> y; effect (merge pn q) h h1 r1 ; P pn q h h1 r1 xs' (y#ys'); h' = Ref.set p (Node x r1) h1 \<rbrakk>
  \<Longrightarrow> P p q h h' p (x#xs') (y#ys')"
assumes "\<And> x xs' y ys' p q pn qn h1 r1 h'.
  \<lbrakk> list_of' h p (x#xs'); list_of' h q (y#ys'); Ref.get h p = Node x pn; Ref.get h q = Node y qn;
  \<not> x \<le> y; effect (merge p qn) h h1 r1; P p qn h h1 r1 (x#xs') ys'; h' = Ref.set q (Node y r1) h1 \<rbrakk>
  \<Longrightarrow> P p q h h' q (x#xs') (y#ys')"
shows "P p q h h' r xs ys"
using assms(3)
proof (induct arbitrary: h' r rule: merge_induct2[OF assms(1) assms(2)])
  case (1 ys p q)
  from 1(3-4) have "h = h' \<and> r = q"
    unfolding merge.simps[of p q]
    by (auto elim!: effect_lookupE effect_bindE effect_returnE)
  with assms(4)[OF 1(1) 1(2) 1(3)] show ?case by simp
next
  case (2 x xs' p q pn)
  from 2(3-5) have "h = h' \<and> r = p"
    unfolding merge.simps[of p q]
    by (auto elim!: effect_lookupE effect_bindE effect_returnE)
  with assms(5)[OF 2(1-4)] show ?case by simp
next
  case (3 x xs' y ys' p q pn qn)
  from 3(3-5) 3(7) obtain h1 r1 where
    1: "effect (merge pn q) h h1 r1"
    and 2: "h' = Ref.set p (Node x r1) h1 \<and> r = p"
    unfolding merge.simps[of p q]
    by (auto elim!: effect_lookupE effect_bindE effect_returnE effect_ifE effect_updateE)
  from 3(6)[OF 1] assms(6) [OF 3(1-5)] 1 2 show ?case by simp
next
  case (4 x xs' y ys' p q pn qn)
  from 4(3-5) 4(7) obtain h1 r1 where
    1: "effect (merge p qn) h h1 r1"
    and 2: "h' = Ref.set q (Node y r1) h1 \<and> r = q"
    unfolding merge.simps[of p q]
    by (auto elim!: effect_lookupE effect_bindE effect_returnE effect_ifE effect_updateE)
  from 4(6)[OF 1] assms(7) [OF 4(1-5)] 1 2 show ?case by simp
qed

subsection {* Proving merge correct *}

text {* As many parts of the following three proofs are identical, we could actually move the
same reasoning into an extended induction rule *}

lemma merge_unchanged:
  assumes "refs_of' h p xs"
  assumes "refs_of' h q ys"
  assumes "effect (merge p q) h h' r'"
  assumes "set xs \<inter> set ys = {}"
  assumes "r \<notin> set xs \<union> set ys"
  shows "Ref.get h r = Ref.get h' r"
proof -
  from assms(1) obtain ps where ps_def: "list_of' h p ps" by (rule refs_of'_list_of')
  from assms(2) obtain qs where qs_def: "list_of' h q qs" by (rule refs_of'_list_of')
  show ?thesis using assms(1) assms(2) assms(4) assms(5)
  proof (induct arbitrary: xs ys r rule: merge_induct3[OF ps_def qs_def assms(3)])
    case 1 thus ?case by simp
  next
    case 2 thus ?case by simp
  next
    case (3 x xs' y ys' p q pn qn h1 r1 h' xs ys r)
    from 3(9) 3(3) obtain pnrs
      where pnrs_def: "xs = p#pnrs"
      and refs_of'_pn: "refs_of' h pn pnrs"
      by (rule refs_of'_Node)
    with 3(12) have r_in: "r \<notin> set pnrs \<union> set ys" by auto
    from pnrs_def 3(12) have "r \<noteq> p" by auto
    with 3(11) 3(12) pnrs_def refs_of'_distinct[OF 3(9)] have p_in: "p \<notin> set pnrs \<union> set ys" by auto
    from 3(11) pnrs_def have no_inter: "set pnrs \<inter> set ys = {}" by auto
    from 3(7)[OF refs_of'_pn 3(10) this p_in] 3(3) have p_is_Node: "Ref.get h1 p = Node x pn"
      by simp
    from 3(7)[OF refs_of'_pn 3(10) no_inter r_in] 3(8) `r \<noteq> p` show ?case
      by simp
  next
    case (4 x xs' y ys' p q pn qn h1 r1 h' xs ys r)
    from 4(10) 4(4) obtain qnrs
      where qnrs_def: "ys = q#qnrs"
      and refs_of'_qn: "refs_of' h qn qnrs"
      by (rule refs_of'_Node)
    with 4(12) have r_in: "r \<notin> set xs \<union> set qnrs" by auto
    from qnrs_def 4(12) have "r \<noteq> q" by auto
    with 4(11) 4(12) qnrs_def refs_of'_distinct[OF 4(10)] have q_in: "q \<notin> set xs \<union> set qnrs" by auto
    from 4(11) qnrs_def have no_inter: "set xs \<inter> set qnrs = {}" by auto
    from 4(7)[OF 4(9) refs_of'_qn this q_in] 4(4) have q_is_Node: "Ref.get h1 q = Node y qn" by simp
    from 4(7)[OF 4(9) refs_of'_qn no_inter r_in] 4(8) `r \<noteq> q` show ?case
      by simp
  qed
qed

lemma refs_of'_merge:
  assumes "refs_of' h p xs"
  assumes "refs_of' h q ys"
  assumes "effect (merge p q) h h' r"
  assumes "set xs \<inter> set ys = {}"
  assumes "refs_of' h' r rs"
  shows "set rs \<subseteq> set xs \<union> set ys"
proof -
  from assms(1) obtain ps where ps_def: "list_of' h p ps" by (rule refs_of'_list_of')
  from assms(2) obtain qs where qs_def: "list_of' h q qs" by (rule refs_of'_list_of')
  show ?thesis using assms(1) assms(2) assms(4) assms(5)
  proof (induct arbitrary: xs ys rs rule: merge_induct3[OF ps_def qs_def assms(3)])
    case 1
    from 1(5) 1(7) have "rs = ys" by (fastforce simp add: refs_of'_is_fun)
    thus ?case by auto
  next
    case 2
    from 2(5) 2(8) have "rs = xs" by (auto simp add: refs_of'_is_fun)
    thus ?case by auto
  next
    case (3 x xs' y ys' p q pn qn h1 r1 h' xs ys rs)
    from 3(9) 3(3) obtain pnrs
      where pnrs_def: "xs = p#pnrs"
      and refs_of'_pn: "refs_of' h pn pnrs"
      by (rule refs_of'_Node)
    from 3(10) 3(9) 3(11) pnrs_def refs_of'_distinct[OF 3(9)] have p_in: "p \<notin> set pnrs \<union> set ys" by auto
    from 3(11) pnrs_def have no_inter: "set pnrs \<inter> set ys = {}" by auto
    from merge_unchanged[OF refs_of'_pn 3(10) 3(6) no_inter p_in] have p_stays: "Ref.get h1 p = Ref.get h p" ..
    from 3 p_stays obtain r1s
      where rs_def: "rs = p#r1s" and refs_of'_r1:"refs_of' h1 r1 r1s"
      by (auto elim: refs_of'_set_next_ref)
    from 3(7)[OF refs_of'_pn 3(10) no_inter refs_of'_r1] rs_def pnrs_def show ?case by auto
  next
    case (4 x xs' y ys' p q pn qn h1 r1 h' xs ys rs)
    from 4(10) 4(4) obtain qnrs
      where qnrs_def: "ys = q#qnrs"
      and refs_of'_qn: "refs_of' h qn qnrs"
      by (rule refs_of'_Node)
    from 4(10) 4(9) 4(11) qnrs_def refs_of'_distinct[OF 4(10)] have q_in: "q \<notin> set xs \<union> set qnrs" by auto
    from 4(11) qnrs_def have no_inter: "set xs \<inter> set qnrs = {}" by auto
    from merge_unchanged[OF 4(9) refs_of'_qn 4(6) no_inter q_in] have q_stays: "Ref.get h1 q = Ref.get h q" ..
    from 4 q_stays obtain r1s
      where rs_def: "rs = q#r1s" and refs_of'_r1:"refs_of' h1 r1 r1s"
      by (auto elim: refs_of'_set_next_ref)
    from 4(7)[OF 4(9) refs_of'_qn no_inter refs_of'_r1] rs_def qnrs_def show ?case by auto
  qed
qed

lemma
  assumes "list_of' h p xs"
  assumes "list_of' h q ys"
  assumes "effect (merge p q) h h' r"
  assumes "\<forall>qrs prs. refs_of' h q qrs \<and> refs_of' h p prs \<longrightarrow> set prs \<inter> set qrs = {}"
  shows "list_of' h' r (Lmerge xs ys)"
using assms(4)
proof (induct rule: merge_induct3[OF assms(1-3)])
  case 1
  thus ?case by simp
next
  case 2
  thus ?case by simp
next
  case (3 x xs' y ys' p q pn qn h1 r1 h')
  from 3(1) obtain prs where prs_def: "refs_of' h p prs" by (rule list_of'_refs_of')
  from 3(2) obtain qrs where qrs_def: "refs_of' h q qrs" by (rule list_of'_refs_of')
  from prs_def 3(3) obtain pnrs
    where pnrs_def: "prs = p#pnrs"
    and refs_of'_pn: "refs_of' h pn pnrs"
    by (rule refs_of'_Node)
  from prs_def qrs_def 3(9) pnrs_def refs_of'_distinct[OF prs_def] have p_in: "p \<notin> set pnrs \<union> set qrs" by fastforce
  from prs_def qrs_def 3(9) pnrs_def have no_inter: "set pnrs \<inter> set qrs = {}" by fastforce
  from no_inter refs_of'_pn qrs_def have no_inter2: "\<forall>qrs prs. refs_of' h q qrs \<and> refs_of' h pn prs \<longrightarrow> set prs \<inter> set qrs = {}"
    by (fastforce dest: refs_of'_is_fun)
  from merge_unchanged[OF refs_of'_pn qrs_def 3(6) no_inter p_in] have p_stays: "Ref.get h1 p = Ref.get h p" ..
  from 3(7)[OF no_inter2] obtain rs where rs_def: "refs_of' h1 r1 rs" by (rule list_of'_refs_of')
  from refs_of'_merge[OF refs_of'_pn qrs_def 3(6) no_inter this] p_in have p_rs: "p \<notin> set rs" by auto
  with 3(7)[OF no_inter2] 3(1-5) 3(8) p_rs rs_def p_stays
  show ?case by (auto simp: list_of'_set_ref)
next
  case (4 x xs' y ys' p q pn qn h1 r1 h')
  from 4(1) obtain prs where prs_def: "refs_of' h p prs" by (rule list_of'_refs_of')
  from 4(2) obtain qrs where qrs_def: "refs_of' h q qrs" by (rule list_of'_refs_of')
  from qrs_def 4(4) obtain qnrs
    where qnrs_def: "qrs = q#qnrs"
    and refs_of'_qn: "refs_of' h qn qnrs"
    by (rule refs_of'_Node)
  from prs_def qrs_def 4(9) qnrs_def refs_of'_distinct[OF qrs_def] have q_in: "q \<notin> set prs \<union> set qnrs" by fastforce
  from prs_def qrs_def 4(9) qnrs_def have no_inter: "set prs \<inter> set qnrs = {}" by fastforce
  from no_inter refs_of'_qn prs_def have no_inter2: "\<forall>qrs prs. refs_of' h qn qrs \<and> refs_of' h p prs \<longrightarrow> set prs \<inter> set qrs = {}"
    by (fastforce dest: refs_of'_is_fun)
  from merge_unchanged[OF prs_def refs_of'_qn 4(6) no_inter q_in] have q_stays: "Ref.get h1 q = Ref.get h q" ..
  from 4(7)[OF no_inter2] obtain rs where rs_def: "refs_of' h1 r1 rs" by (rule list_of'_refs_of')
  from refs_of'_merge[OF prs_def refs_of'_qn 4(6) no_inter this] q_in have q_rs: "q \<notin> set rs" by auto
  with 4(7)[OF no_inter2] 4(1-5) 4(8) q_rs rs_def q_stays
  show ?case by (auto simp: list_of'_set_ref)
qed

section {* Code generation *}

text {* A simple example program *}

definition test_1 where "test_1 = (do { ll_xs <- make_llist [1..(15::int)]; xs <- traverse ll_xs; return xs })"
definition test_2 where "test_2 = (do { ll_xs <- make_llist [1..(15::int)]; ll_ys <- rev ll_xs; ys <- traverse ll_ys; return ys })"

definition test_3 where "test_3 =
  (do {
    ll_xs \<leftarrow> make_llist (filter (%n. n mod 2 = 0) [2..8]);
    ll_ys \<leftarrow> make_llist (filter (%n. n mod 2 = 1) [5..11]);
    r \<leftarrow> ref ll_xs;
    q \<leftarrow> ref ll_ys;
    p \<leftarrow> merge r q;
    ll_zs \<leftarrow> !p;
    zs \<leftarrow> traverse ll_zs;
    return zs
  })"

code_reserved SML upto

ML_val {* @{code test_1} () *}
ML_val {* @{code test_2} () *}
ML_val {* @{code test_3} () *}

export_code test_1 test_2 test_3 checking SML SML_imp OCaml? OCaml_imp? Haskell? Scala Scala_imp

end


section {* \isaheader{The type of associative lists} *}
theory Assoc_List
  imports
  "~~/src/HOL/Library/AList"
  "../Iterator/SetIteratorOperations"
begin

subsection {* Type @{text "('a, 'b) assoc_list" } *}

typedef ('k, 'v) assoc_list = "{xs :: ('k \<times> 'v) list. distinct (map fst xs)}"
morphisms impl_of Assoc_List
by(rule exI[where x="[]"]) simp

lemma assoc_list_ext: "impl_of xs = impl_of ys \<Longrightarrow> xs = ys"
by(simp add: impl_of_inject)

lemma expand_assoc_list_eq: "xs = ys \<longleftrightarrow> impl_of xs = impl_of ys"
by(simp add: impl_of_inject)

lemma impl_of_distinct [simp, intro]: "distinct (map fst (impl_of al))"
using impl_of[of al] by simp

lemma impl_of_distinct_full [simp, intro]: "distinct (impl_of al)"
using impl_of_distinct[of al]
unfolding distinct_map by simp

lemma Assoc_List_impl_of [code abstype]: "Assoc_List (impl_of al) = al"
by(rule impl_of_inverse)

subsection {* Primitive operations *}

definition empty :: "('k, 'v) assoc_list"
where [code del]: "empty = Assoc_List []"

definition lookup :: "('k, 'v) assoc_list \<Rightarrow> 'k \<Rightarrow> 'v option"
where [code]: "lookup al = map_of (impl_of al)"

definition update_with :: "'v \<Rightarrow> 'k \<Rightarrow> ('v \<Rightarrow> 'v) \<Rightarrow> ('k, 'v) assoc_list \<Rightarrow> ('k, 'v) assoc_list"
where [code del]: "update_with v k f al = Assoc_List (AList.update_with_aux v k f (impl_of al))"

definition delete :: "'k \<Rightarrow> ('k, 'v) assoc_list \<Rightarrow> ('k, 'v) assoc_list"
where [code del]: "delete k al = Assoc_List (AList.delete_aux k (impl_of al))"

definition iteratei :: "('k, 'v) assoc_list \<Rightarrow> ('s\<Rightarrow>bool) \<Rightarrow> ('k \<times> 'v \<Rightarrow> 's \<Rightarrow> 's) \<Rightarrow> 's \<Rightarrow> 's"
where [code]: "iteratei al c f = foldli (impl_of al) c f"

lemma impl_of_empty [code abstract]: "impl_of empty = []"
by(simp add: empty_def Assoc_List_inverse)

lemma impl_of_update_with [code abstract]:
  "impl_of (update_with v k f al) = AList.update_with_aux v k f (impl_of al)"
by(simp add: update_with_def Assoc_List_inverse)

lemma impl_of_delete [code abstract]:
  "impl_of (delete k al) = AList.delete_aux k (impl_of al)"
by(simp add: delete_def Assoc_List_inverse)

subsection {* Abstract operation properties *}

lemma lookup_empty [simp]: "lookup empty k = None"
by(simp add: empty_def lookup_def Assoc_List_inverse)

lemma lookup_empty': "lookup empty = Map.empty"
by(rule ext) simp

lemma lookup_update_with [simp]:
  "lookup (update_with v k f al) = (lookup al)(k \<mapsto> case lookup al k of None \<Rightarrow> f v | Some v \<Rightarrow> f v)"
by(simp add: lookup_def update_with_def Assoc_List_inverse map_of_update_with_aux)

lemma lookup_delete [simp]: "lookup (delete k al) = (lookup al)(k := None)"
by(simp add: lookup_def delete_def Assoc_List_inverse distinct_delete map_of_delete_aux')

lemma finite_dom_lookup [simp, intro!]: "finite (dom (lookup m))"
by(simp add: lookup_def finite_dom_map_of)

lemma iteratei_correct:
  "map_iterator (iteratei m) (lookup m)"
unfolding iteratei_def[abs_def] lookup_def map_to_set_def
by (simp add: set_iterator_foldli_correct)

subsection {* Derived operations *}

definition update :: "'key \<Rightarrow> 'val \<Rightarrow> ('key, 'val) assoc_list \<Rightarrow> ('key, 'val) assoc_list"
where "update k v = update_with v k (\<lambda>_. v)"

definition set :: "('key, 'val) assoc_list \<Rightarrow> ('key \<times> 'val) set"
where "set al = List.set (impl_of al)"

lemma lookup_update [simp]: "lookup (update k v al) = (lookup al)(k \<mapsto> v)"
by(simp add: update_def split: option.split)

lemma set_empty [simp]: "set empty = {}"
by(simp add: set_def empty_def Assoc_List_inverse)

lemma set_update_with:
  "set (update_with v k f al) =
  (set al - {k} \<times> UNIV \<union> {(k, f (case lookup al k of None \<Rightarrow> v | Some v \<Rightarrow> v))})"
by(simp add: set_def update_with_def Assoc_List_inverse set_update_with_aux lookup_def)

lemma set_update: "set (update k v al) = (set al - {k} \<times> UNIV \<union> {(k, v)})"
by(simp add: update_def set_update_with)

lemma set_delete: "set (delete k al) = set al - {k} \<times> UNIV"
by(simp add: set_def delete_def Assoc_List_inverse set_delete_aux)

subsection {* Type classes *}

instantiation assoc_list :: (equal, equal) equal begin

definition "equal_class.equal (al :: ('a, 'b) assoc_list) al' == impl_of al = impl_of al'"

instance
proof
qed (simp add: equal_assoc_list_def impl_of_inject)

end

instantiation assoc_list :: (type, type) size begin

definition "size (al :: ('a, 'b) assoc_list) = length (impl_of al)"

instance ..
end

hide_const (open) impl_of empty lookup update_with set update delete iteratei

subsection {* @{const map_ran} *}

text {* @{term map_ran} with more general type - lemmas replicated from AList in HOL/Library *}

hide_const (open) map_ran

primrec
  map_ran :: "('key \<Rightarrow> 'val \<Rightarrow> 'val') \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val') list"
where
    "map_ran f [] = []"
  | "map_ran f (p#ps) = (fst p, f (fst p) (snd p)) # map_ran f ps"

lemma map_ran_conv: "map_of (map_ran f al) k = map_option (f k) (map_of al k)"
  by (induct al) auto

lemma dom_map_ran: "fst ` set (map_ran f al) = fst ` set al"
  by (induct al) auto

lemma distinct_map_ran: "distinct (map fst al) \<Longrightarrow> distinct (map fst (map_ran f al))"
  by (induct al) (auto simp add: dom_map_ran)

lemma map_ran_filter: "map_ran f [(a, _)\<leftarrow>ps. fst p \<noteq> a] = [(a, _)\<leftarrow>map_ran f ps. fst p \<noteq> a]"
  by (induct ps) auto

lemma clearjunk_map_ran: "AList.clearjunk (map_ran f al)
  = map_ran f (AList.clearjunk al)"
  by (induct al rule: clearjunk.induct) (simp_all add: AList.delete_eq map_ran_filter)

text {* new lemmas and definitions *}

lemma map_ran_cong [fundef_cong]:
  "\<lbrakk> al = al'; \<And>k v. (k, v) \<in> set al \<Longrightarrow> f k v = g k v \<rbrakk> \<Longrightarrow> map_ran f al = map_ran g al'"
by hypsubst_thin (induct al', auto)

lemma size_list_delete: "size_list f (AList.delete a al) \<le> size_list f al"
by(induct al) simp_all

lemma size_list_clearjunk: "size_list f (AList.clearjunk al) \<le> size_list f al"
by(induct al)(auto simp add: clearjunk_delete intro: le_trans[OF size_list_delete])

lemma set_delete_conv: "set (AList.delete a al) = set al - ({a} \<times> UNIV)"
proof(induct al)
  case (Cons kv al)
  thus ?case by(cases kv) auto
qed simp

lemma set_clearjunk_subset: "set (AList.clearjunk al) \<subseteq> set al"
by(induct al)(auto simp add: clearjunk_delete set_delete_conv)

lemma map_ran_conv_map:
  "map_ran f xs = map (\<lambda>(k, v). (k, f k v)) xs"
by(induct xs) auto

lemma card_dom_map_of: "distinct (map fst al) \<Longrightarrow> card (dom (map_of al)) = length al"
by(induct al)(auto simp add: card_insert_if finite_dom_map_of dom_map_of_conv_image_fst)

lemma map_of_map_inj_fst:
  assumes "inj f"
  shows "map_of (map (\<lambda>(k, v). (f k, v)) xs) (f x) = map_of xs x"
by(induct xs)(auto dest: injD[OF `inj f`])

lemma length_map_ran [simp]: "length (map_ran f xs) = length xs"
by(induct xs) simp_all

lemma length_update:
  "length (AList.update k v xs)
  = (if k \<in> fst ` set xs then length xs else Suc (length xs))"
by(induct xs) simp_all

lemma length_distinct:
  "distinct (map fst xs) \<Longrightarrow> length (AList.delete k xs)
  = (if k \<in> fst ` set xs then length xs - 1 else length xs)"
  by(induct xs)(auto split: split_if_asm simp add: in_set_conv_nth)

lemma finite_Assoc_List_set_image:
  assumes "finite (Assoc_List.set ` A)"
  shows "finite A"
proof -
  have "Assoc_List.set ` A = set ` Assoc_List.impl_of ` A"
    by (auto simp add: Assoc_List.set_def)
  with assms finite_set_image have "finite (Assoc_List.impl_of ` A)" by auto
  with assoc_list_ext show ?thesis by (metis inj_onI finite_imageD)
qed

end


theory Interval_Integral_HK
imports Vector_Derivative_On
begin

subsection \<open>interval integral\<close>
  \<comment> \<open>TODO: move to repo ?!\<close>
  \<comment> \<open>TODO: replace with Bochner Integral?!
           But FTC for Bochner requires continuity and euclidean space!\<close>

definition has_ivl_integral ::
    "(real \<Rightarrow> 'b::real_normed_vector) \<Rightarrow> 'b \<Rightarrow> real \<Rightarrow> real \<Rightarrow> bool"\<comment> \<open>TODO: generalize?\<close>
  (infixr "has'_ivl'_integral" 46)
  where "(f has_ivl_integral y) a b \<longleftrightarrow> (if a \<le> b then (f has_integral y) {a .. b} else (f has_integral - y) {b .. a})"

definition ivl_integral::"real \<Rightarrow> real \<Rightarrow> (real \<Rightarrow> 'a) \<Rightarrow> 'a::real_normed_vector"
  where "ivl_integral a b f = integral {a .. b} f - integral {b .. a} f"

lemma integral_emptyI[simp]:
  fixes a b::real
  shows  "a \<ge> b \<Longrightarrow> integral {a..b} f = 0" "a > b \<Longrightarrow> integral {a..b} f = 0"
  by (cases "a = b") auto

lemma ivl_integral_unique: "(f has_ivl_integral y) a b \<Longrightarrow> ivl_integral a b f = y"
  using integral_unique[of f y "{a .. b}"] integral_unique[of f "- y" "{b .. a}"]
  unfolding ivl_integral_def has_ivl_integral_def
  by (auto split: if_split_asm)

lemma fundamental_theorem_of_calculus_ivl_integral:
  fixes f :: "real \<Rightarrow> 'a::banach"
  shows "(f has_vderiv_on f') (closed_segment a b) \<Longrightarrow> (f' has_ivl_integral f b - f a) a b"
  by (auto simp: has_ivl_integral_def closed_segment_eq_real_ivl intro!: fundamental_theorem_of_calculus')

lemma
  fixes f :: "real \<Rightarrow> 'a::banach"
  assumes "f integrable_on (closed_segment a b)"
  shows indefinite_ivl_integral_continuous:
    "continuous_on (closed_segment a b) (\<lambda>x. ivl_integral a x f)"
    "continuous_on (closed_segment b a) (\<lambda>x. ivl_integral a x f)"
  using assms
  by (auto simp: ivl_integral_def closed_segment_eq_real_ivl split: if_split_asm
    intro!: indefinite_integral_continuous_1 indefinite_integral_continuous_1'
      continuous_intros intro: continuous_on_eq)

lemma
  fixes f :: "real \<Rightarrow> 'a::banach"
  assumes "f integrable_on (closed_segment a b)"
  assumes "c \<in> closed_segment a b"
  shows indefinite_ivl_integral_continuous_subset:
    "continuous_on (closed_segment a b) (\<lambda>x. ivl_integral c x f)"
proof -
  from assms have "f integrable_on (closed_segment c a)" "f integrable_on (closed_segment c b)"
     by (auto simp: closed_segment_eq_real_ivl integrable_on_subinterval
      integrable_on_insert_iff split: if_splits)
  then have "continuous_on (closed_segment a c \<union> closed_segment c b) (\<lambda>x. ivl_integral c x f)"
    by (auto intro!: indefinite_ivl_integral_continuous continuous_on_closed_Un)
  also have "closed_segment a c \<union> closed_segment c b = closed_segment a b"
    using assms by (auto simp: closed_segment_eq_real_ivl)
  finally show ?thesis .
qed

lemma real_Icc_closed_segment: fixes a b::real shows "a \<le> b \<Longrightarrow> {a .. b} = closed_segment a b"
  by (auto simp: closed_segment_eq_real_ivl)

lemma ivl_integral_zero[simp]: "ivl_integral a a f = 0"
  by (auto simp: ivl_integral_def)

lemma ivl_integral_cong:
  assumes "\<And>x. x \<in> closed_segment a b \<Longrightarrow> g x = f x"
  assumes "a = c" "b = d"
  shows "ivl_integral a b f = ivl_integral c d g"
  using assms integral_spike[of "{}" "closed_segment a b" f g]
  by (auto simp: ivl_integral_def closed_segment_eq_real_ivl split: if_split_asm)

lemma ivl_integral_diff:
  "f integrable_on (closed_segment s t) \<Longrightarrow> g integrable_on (closed_segment s t) \<Longrightarrow>
    ivl_integral s t (\<lambda>x. f x - g x) = ivl_integral s t f - ivl_integral s t g"
  using Henstock_Kurzweil_Integration.integral_diff[of f "closed_segment s t" g]
  by (auto simp: ivl_integral_def closed_segment_eq_real_ivl split: if_split_asm)

lemma ivl_integral_norm_bound_ivl_integral:
  fixes f :: "real \<Rightarrow> 'a::banach"
  assumes "f integrable_on (closed_segment a b)"
    and "g integrable_on (closed_segment a b)"
    and "\<And>x. x \<in> closed_segment a b \<Longrightarrow> norm (f x) \<le> g x"
  shows "norm (ivl_integral a b f) \<le> abs (ivl_integral a b g)"
  using integral_norm_bound_integral[OF assms]
  by (auto simp: ivl_integral_def closed_segment_eq_real_ivl split: if_split_asm)

lemma ivl_integral_norm_bound_integral:
  fixes f :: "real \<Rightarrow> 'a::banach"
  assumes "f integrable_on (closed_segment a b)"
    and "g integrable_on (closed_segment a b)"
    and "\<And>x. x \<in> closed_segment a b \<Longrightarrow> norm (f x) \<le> g x"
  shows "norm (ivl_integral a b f) \<le> integral (closed_segment a b) g"
  using integral_norm_bound_integral[OF assms]
  by (auto simp: ivl_integral_def closed_segment_eq_real_ivl split: if_split_asm)

lemma norm_ivl_integral_le:
  fixes f :: "real \<Rightarrow> real"
  assumes "f integrable_on (closed_segment a b)"
    and "g integrable_on (closed_segment a b)"
    and "\<And>x. x \<in> closed_segment a b \<Longrightarrow> f x \<le> g x"
    and "\<And>x. x \<in> closed_segment a b \<Longrightarrow> 0 \<le> f x"
  shows "abs (ivl_integral a b f) \<le> abs (ivl_integral a b g)"
proof (cases "a = b")
  case True then show ?thesis
    by simp
next
  case False
  have "0 \<le> integral {a..b} f" "0 \<le> integral {b..a} f"
    by (metis le_cases Henstock_Kurzweil_Integration.integral_nonneg assms(1) assms(4) closed_segment_eq_real_ivl integral_emptyI(1))+
  then show ?thesis
    using integral_le[OF assms(1-3)]
    unfolding ivl_integral_def closed_segment_eq_real_ivl
    by (simp split: if_split_asm)
qed

lemma ivl_integral_const [simp]:
  shows "ivl_integral a b (\<lambda>x. c) = (b - a) *\<^sub>R c"
  by (auto simp: ivl_integral_def algebra_simps)

lemma ivl_integral_has_vector_derivative:
  fixes f :: "real \<Rightarrow> 'a::banach"
  assumes "continuous_on (closed_segment a b) f"
    and "x \<in> closed_segment a b"
  shows "((\<lambda>u. ivl_integral a u f) has_vector_derivative f x) (at x within closed_segment a b)"
proof -
  have "((\<lambda>x. integral {x..a} f) has_vector_derivative 0) (at x within {a..b})" if "a \<le> x" "x \<le> b"
    by (rule has_vector_derivative_transform) (auto simp: that)
  moreover
  have "((\<lambda>x. integral {a..x} f) has_vector_derivative 0) (at x within {b..a})" if "b \<le> x" "x \<le> a"
    by (rule has_vector_derivative_transform) (auto simp: that)
  ultimately
  show ?thesis
    using assms
    by (auto simp: ivl_integral_def closed_segment_eq_real_ivl
        intro!: derivative_eq_intros
        integral_has_vector_derivative[of a b f] integral_has_vector_derivative[of b a "-f"]
        integral_has_vector_derivative'[of b a f])
qed

lemma ivl_integral_has_vderiv_on:
  fixes f :: "real \<Rightarrow> 'a::banach"
  assumes "continuous_on (closed_segment a b) f"
  shows "((\<lambda>u. ivl_integral a u f) has_vderiv_on f) (closed_segment a b)"
  using ivl_integral_has_vector_derivative[OF assms]
  by (auto simp: has_vderiv_on_def)

lemma ivl_integral_has_vderiv_on_subset_segment:
  fixes f :: "real \<Rightarrow> 'a::banach"
  assumes "continuous_on (closed_segment a b) f"
    and "c \<in> closed_segment a b"
  shows "((\<lambda>u. ivl_integral c u f) has_vderiv_on f) (closed_segment a b)"
proof -
  have "(closed_segment c a) \<subseteq> (closed_segment a b)" "(closed_segment c b) \<subseteq> (closed_segment a b)"
    using assms by (auto simp: closed_segment_eq_real_ivl split: if_splits)
  then have "((\<lambda>u. ivl_integral c u f) has_vderiv_on f) ((closed_segment c a) \<union> (closed_segment c b))"
    by (auto intro!: has_vderiv_on_union_closed ivl_integral_has_vderiv_on assms
      intro: continuous_on_subset)
  also have "(closed_segment c a) \<union> (closed_segment c b) = (closed_segment a b)"
    using assms by (auto simp: closed_segment_eq_real_ivl split: if_splits)
  finally show ?thesis .
qed

lemma ivl_integral_has_vector_derivative_subset:
  fixes f :: "real \<Rightarrow> 'a::banach"
  assumes "continuous_on (closed_segment a b) f"
    and "x \<in> closed_segment a b"
    and "c \<in> closed_segment a b"
  shows "((\<lambda>u. ivl_integral c u f) has_vector_derivative f x) (at x within closed_segment a b)"
  using ivl_integral_has_vderiv_on_subset_segment[OF assms(1)] assms(2-)
  by (auto simp: has_vderiv_on_def)

lemma
  compact_interval_eq_Inf_Sup:
  fixes A::"real set"
  assumes "is_interval A" "compact A" "A \<noteq> {}"
  shows "A = {Inf A .. Sup A}"
  apply (auto simp: closed_segment_eq_real_ivl
      intro!: cInf_lower cSup_upper bounded_imp_bdd_below bounded_imp_bdd_above
      compact_imp_bounded assms)
  by (metis assms(1) assms(2) assms(3) cInf_eq_minimum cSup_eq_maximum compact_attains_inf
      compact_attains_sup mem_is_interval_1_I)

lemma ivl_integral_has_vderiv_on_compact_interval:
  fixes f :: "real \<Rightarrow> 'a::banach"
  assumes "continuous_on A f"
    and "c \<in> A" "is_interval A" "compact A"
  shows "((\<lambda>u. ivl_integral c u f) has_vderiv_on f) A"
proof -
  have "A = {Inf A .. Sup A}"
    by (rule compact_interval_eq_Inf_Sup) (use assms in auto)
  also have "\<dots> = closed_segment (Inf A) (Sup A)" using assms
    by (auto simp add: closed_segment_eq_real_ivl
        intro!: cInf_le_cSup bounded_imp_bdd_below bounded_imp_bdd_above compact_imp_bounded)
  finally have *: "A = closed_segment (Inf A) (Sup A)" .
  show ?thesis
    apply (subst *)
    apply (rule ivl_integral_has_vderiv_on_subset_segment)
    unfolding *[symmetric]
    by fact+
qed

lemma ivl_integral_has_vector_derivative_compact_interval:
  fixes f :: "real \<Rightarrow> 'a::banach"
  assumes "continuous_on A f"
    and "is_interval A" "compact A" "x \<in> A" "c \<in> A"
  shows "((\<lambda>u. ivl_integral c u f) has_vector_derivative f x) (at x within A)"
  using ivl_integral_has_vderiv_on_compact_interval[OF assms(1)] assms(2-)
  by (auto simp: has_vderiv_on_def)

lemma ivl_integral_combine:
  fixes f::"real \<Rightarrow> 'a::banach"
  assumes "f integrable_on (closed_segment a b)"
  assumes "f integrable_on (closed_segment b c)"
  assumes "f integrable_on (closed_segment a c)"
  shows "ivl_integral a b f + ivl_integral b c f = ivl_integral a c f"
proof -
  show ?thesis
    using assms
      Henstock_Kurzweil_Integration.integral_combine[of a b c f]
      Henstock_Kurzweil_Integration.integral_combine[of a c b f]
      Henstock_Kurzweil_Integration.integral_combine[of b a c f]
      Henstock_Kurzweil_Integration.integral_combine[of b c a f]
      Henstock_Kurzweil_Integration.integral_combine[of c a b f]
      Henstock_Kurzweil_Integration.integral_combine[of c b a f]
    by (cases "a \<le> b"; cases "b \<le> c"; cases "a \<le> c")
       (auto simp: algebra_simps ivl_integral_def closed_segment_eq_real_ivl)
qed

lemma integral_equation_swap_initial_value:
  fixes x::"real\<Rightarrow>'a::banach"
  assumes "\<And>t. t \<in> closed_segment t0 t1 \<Longrightarrow> x t = x t0 + ivl_integral t0 t (\<lambda>t. f t (x t))"
  assumes t: "t \<in> closed_segment t0 t1"
  assumes int: "(\<lambda>t. f t (x t)) integrable_on closed_segment t0 t1"
  shows "x t = x t1 + ivl_integral t1 t (\<lambda>t. f t (x t))"
proof -
  from t int have "(\<lambda>t. f t (x t)) integrable_on closed_segment t0 t"
    "(\<lambda>t. f t (x t)) integrable_on closed_segment t t1"
    by (auto intro: integrable_on_subinterval simp: closed_segment_eq_real_ivl split: if_split_asm)
  with assms(1)[of t] assms(2-)
  have "x t - x t0 = ivl_integral t0 t1 (\<lambda>t. f t (x t)) + ivl_integral t1 t (\<lambda>t. f t (x t))"
    by (subst ivl_integral_combine) (auto simp: closed_segment_commute)
  then have "x t + x t1 - (x t0 + ivl_integral t0 t1 (\<lambda>t. f t (x t))) =
    x t1 + ivl_integral t1 t (\<lambda>t. f t (x t))"
    by (simp add: algebra_simps)
  also have "x t0 + ivl_integral t0 t1 (\<lambda>t. f t (x t)) = x t1"
    by (auto simp: assms(1)[symmetric])
  finally show ?thesis  by simp
qed

lemma has_integral_nonpos:
  fixes f :: "'n::euclidean_space \<Rightarrow> real"
  assumes "(f has_integral i) s"
    and "\<forall>x\<in>s. f x \<le> 0"
  shows "i \<le> 0"
  by (rule has_integral_nonneg[of "-f" "-i" s, simplified])
    (auto intro!: has_integral_neg simp: fun_Compl_def assms)

lemma has_ivl_integral_nonneg:
  fixes f :: "real \<Rightarrow> real"
  assumes "(f has_ivl_integral i) a b"
    and "\<And>x. a \<le> x \<Longrightarrow> x \<le> b \<Longrightarrow> 0 \<le> f x"
    and "\<And>x. b \<le> x \<Longrightarrow> x \<le> a \<Longrightarrow> f x \<le> 0"
  shows "0 \<le> i"
  using assms has_integral_nonneg[of f i "{a .. b}"] has_integral_nonpos[of f "-i" "{b .. a}"]
  by (auto simp: has_ivl_integral_def Ball_def not_le split: if_split_asm)

lemma has_ivl_integral_ivl_integral:
  "f integrable_on (closed_segment a b) \<longleftrightarrow> (f has_ivl_integral (ivl_integral a b f)) a b"
  by (auto simp: closed_segment_eq_real_ivl has_ivl_integral_def ivl_integral_def)

lemma ivl_integral_nonneg:
  fixes f :: "real \<Rightarrow> real"
  assumes "f integrable_on (closed_segment a b)"
    and "\<And>x. a \<le> x \<Longrightarrow> x \<le> b \<Longrightarrow> 0 \<le> f x"
    and "\<And>x. b \<le> x \<Longrightarrow> x \<le> a \<Longrightarrow> f x \<le> 0"
  shows "0 \<le> ivl_integral a b f"
  by (rule has_ivl_integral_nonneg[OF assms(1)[unfolded has_ivl_integral_ivl_integral] assms(2-3)])

lemma ivl_integral_bound:
  fixes f::"real \<Rightarrow> 'a::banach"
  assumes "continuous_on (closed_segment a b) f"
  assumes "\<And>t. t \<in> (closed_segment a b) \<Longrightarrow> norm (f t) \<le> B"
  shows "norm (ivl_integral a b f) \<le> B * abs (b - a)"
  using integral_bound[of a b f B]
    integral_bound[of b a f B]
    assms
  by (auto simp: closed_segment_eq_real_ivl has_ivl_integral_def ivl_integral_def split: if_splits)

lemma ivl_integral_minus_sets:
  fixes f::"real \<Rightarrow> 'a::banach"
  shows "f integrable_on (closed_segment c a) \<Longrightarrow> f integrable_on (closed_segment c b) \<Longrightarrow> f integrable_on (closed_segment a b) \<Longrightarrow>
    ivl_integral c a f - ivl_integral c b f = ivl_integral b a f"
  using ivl_integral_combine[of f c b a]
  by (auto simp: algebra_simps closed_segment_commute)

lemma ivl_integral_minus_sets':
  fixes f::"real \<Rightarrow> 'a::banach"
  shows "f integrable_on (closed_segment a c) \<Longrightarrow> f integrable_on (closed_segment b c) \<Longrightarrow> f integrable_on (closed_segment a b) \<Longrightarrow>
    ivl_integral a c f - ivl_integral b c f = ivl_integral a b f"
  using ivl_integral_combine[of f a b c]
  by (auto simp: algebra_simps closed_segment_commute)

end


(*
    Title:      Gauss_Jordan_PA_IArrays.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

section\<open>Obtaining explicitly the invertible matrix which transforms a matrix to its reduced row echelon form over nested iarrays\<close>

theory Gauss_Jordan_PA_IArrays
imports
  Gauss_Jordan_PA
  Gauss_Jordan_IArrays
begin

subsection\<open>Definitions\<close>

definition "Gauss_Jordan_in_ij_iarrays_PA A' i j =
(let  P = fst A'; A = snd A'; n = least_non_zero_position_of_vector_from_index (column_iarray j A) i; interchange_A = interchange_rows_iarray A i n;
 interchange_P = interchange_rows_iarray P i n; P' = mult_row_iarray interchange_P i (1 / interchange_A !! i !! j)
 in (IArray.of_fun (\<lambda>s. if s = i then P' !! s else row_add_iarray P' s i (- interchange_A !! s !! j) !! s) (nrows_iarray A), Gauss_Jordan_in_ij_iarrays A i j))"

definition Gauss_Jordan_column_k_iarrays_PA :: "('a::{field} iarray iarray \<times> nat \<times> 'a::{field} iarray iarray) => nat => ('a iarray iarray \<times> nat \<times> 'a iarray iarray)"
  where "Gauss_Jordan_column_k_iarrays_PA A' k=(let P = fst A'; i = fst (snd A'); A = snd (snd A') in
  if (vector_all_zero_from_index (i, (column_iarray k A))) \<or> i = (nrows_iarray A) then (P,i,A) else let Gauss = Gauss_Jordan_in_ij_iarrays_PA (P, A) i k
    in (fst Gauss, i + 1, snd Gauss))"

definition Gauss_Jordan_upt_k_iarrays_PA :: "'a::{field} iarray iarray => nat => ('a::{field} iarray iarray \<times> 'a iarray iarray)"
  where "Gauss_Jordan_upt_k_iarrays_PA A k = (let foldl = foldl Gauss_Jordan_column_k_iarrays_PA (mat_iarray 1 (nrows_iarray A), 0, A) [0..<Suc k] in (fst foldl, snd (snd foldl)))"

definition Gauss_Jordan_iarrays_PA :: "'a::{field} iarray iarray => ('a iarray iarray  \<times> 'a iarray iarray)"
  where "Gauss_Jordan_iarrays_PA A = Gauss_Jordan_upt_k_iarrays_PA A (ncols_iarray A - 1)"

subsection\<open>Proofs\<close>

subsubsection\<open>Properties of @{term "Gauss_Jordan_in_ij_iarrays_PA"}\<close>

lemma Gauss_Jordan_in_ij_iarrays_PA_def'[code]:
"Gauss_Jordan_in_ij_iarrays_PA A' i j =
(let  P = fst A'; A = snd A'; n = least_non_zero_position_of_vector_from_index (column_iarray j A) i;
  interchange_A = interchange_rows_iarray A i n; A' = mult_row_iarray interchange_A i (1 / interchange_A !! i !! j);
  interchange_P = interchange_rows_iarray P i n; P' = mult_row_iarray interchange_P i (1 / interchange_A !! i !! j)
 in (IArray.of_fun (\<lambda>s. if s = i then P' !! s else row_add_iarray P' s i (- interchange_A !! s !! j) !! s) (nrows_iarray A),
    (IArray.of_fun (\<lambda>s. if s = i then A' !! s else row_add_iarray A' s i (- interchange_A !! s !! j) !! s) (nrows_iarray A))))"
unfolding Gauss_Jordan_in_ij_iarrays_PA_def Gauss_Jordan_in_ij_iarrays_def Let_def ..

lemma snd_Gauss_Jordan_in_ij_iarrays_PA:
 shows "snd (Gauss_Jordan_in_ij_iarrays_PA (P, A) i j) = Gauss_Jordan_in_ij_iarrays A i j"
unfolding Gauss_Jordan_in_ij_iarrays_PA_def Gauss_Jordan_in_ij_iarrays_def Let_def snd_conv ..

lemma matrix_to_iarray_snd_Gauss_Jordan_in_ij_iarrays_PA:
 assumes "\<not> vector_all_zero_from_index (to_nat i, vec_to_iarray (column j A))"
 shows "matrix_to_iarray (snd (Gauss_Jordan_in_ij_PA (P,A) i j)) = snd (Gauss_Jordan_in_ij_iarrays_PA (matrix_to_iarray P,matrix_to_iarray A) (to_nat i) (to_nat j))"
by (metis assms matrix_to_iarray_Gauss_Jordan_in_ij snd_Gauss_Jordan_in_ij_PA_eq snd_Gauss_Jordan_in_ij_iarrays_PA)

lemma matrix_to_iarray_fst_Gauss_Jordan_in_ij_iarrays_PA:
 assumes not_all_zero: "\<not> vector_all_zero_from_index (to_nat i, vec_to_iarray (column j A))"
 shows "matrix_to_iarray (fst (Gauss_Jordan_in_ij_PA (P,A) i j)) = fst (Gauss_Jordan_in_ij_iarrays_PA (matrix_to_iarray P,matrix_to_iarray A) (to_nat i) (to_nat j))"
proof (unfold Gauss_Jordan_in_ij_PA_def Gauss_Jordan_in_ij_iarrays_PA_def Let_def fst_conv snd_conv, rule matrix_to_iarray_eq_of_fun, auto simp del: IArray.length_def IArray.sub_def)
show "vec_to_iarray (mult_row (interchange_rows P i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) i (1 / A $ (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ j) $ i) =
    mult_row_iarray (interchange_rows_iarray (matrix_to_iarray P) (to_nat i)
       (least_non_zero_position_of_vector_from_index (column_iarray (to_nat j) (matrix_to_iarray A)) (to_nat i))) (to_nat i)
     (1 / interchange_rows_iarray (matrix_to_iarray A) (to_nat i)
           (least_non_zero_position_of_vector_from_index (column_iarray (to_nat j) (matrix_to_iarray A)) (to_nat i)) !! to_nat i !! to_nat j) !! to_nat i"
    unfolding vec_to_iarray_column[symmetric]
    unfolding vec_to_iarray_least_non_zero_position_of_vector_from_index'[OF not_all_zero]
    unfolding matrix_to_iarray_interchange_rows[symmetric]
    unfolding matrix_to_iarray_mult_row[symmetric]
    unfolding matrix_to_iarray_nth
    unfolding interchange_rows_i
    unfolding vec_matrix ..
next
fix ia
show "vec_to_iarray (row_add (mult_row (interchange_rows P i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) i (1 / A $ (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ j)) ia i
            (- interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ ia $ j) $ ia) =
         row_add_iarray (mult_row_iarray (interchange_rows_iarray (matrix_to_iarray P) (to_nat i)
              (least_non_zero_position_of_vector_from_index (column_iarray (to_nat j) (matrix_to_iarray A)) (to_nat i))) (to_nat i)
            (1 / interchange_rows_iarray (matrix_to_iarray A) (to_nat i)
                  (least_non_zero_position_of_vector_from_index (column_iarray (to_nat j) (matrix_to_iarray A)) (to_nat i)) !!
                 to_nat i !! to_nat j)) (to_nat ia) (to_nat i)
          (- interchange_rows_iarray (matrix_to_iarray A) (to_nat i)
              (least_non_zero_position_of_vector_from_index (column_iarray (to_nat j) (matrix_to_iarray A)) (to_nat i)) !!
             to_nat ia !! to_nat j) !! to_nat ia"
    unfolding vec_to_iarray_column[symmetric]
    unfolding vec_to_iarray_least_non_zero_position_of_vector_from_index'[OF not_all_zero]
    unfolding matrix_to_iarray_interchange_rows[symmetric]
    unfolding matrix_to_iarray_mult_row[symmetric]
    unfolding matrix_to_iarray_nth
    unfolding interchange_rows_i
    unfolding matrix_to_iarray_row_add[symmetric]
    unfolding vec_matrix ..
next
show "nrows_iarray (matrix_to_iarray A) = IArray.length (matrix_to_iarray
       (\<chi> s. if s = i then mult_row (interchange_rows P i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) i (1 / interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ i $ j) $ s
             else row_add (mult_row (interchange_rows P i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) i (1 / interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ i $ j)) s i
             (- interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ s $ j) $ s))"
unfolding length_eq_card_rows nrows_eq_card_rows ..
qed

subsubsection\<open>Properties about @{term "Gauss_Jordan_column_k_iarrays_PA"}\<close>

lemma matrix_to_iarray_fst_Gauss_Jordan_column_k_PA:
assumes i: "i\<le>nrows A" and k: "k<ncols A"
shows "matrix_to_iarray (fst (Gauss_Jordan_column_k_PA (P,i,A) k)) = fst (Gauss_Jordan_column_k_iarrays_PA (matrix_to_iarray P, i, matrix_to_iarray A) k)"
proof (cases "i<nrows A")
case True
show ?thesis
unfolding Gauss_Jordan_column_k_PA_def Gauss_Jordan_column_k_iarrays_PA_def Let_def
unfolding snd_conv fst_conv
unfolding matrix_vector_all_zero_from_index
unfolding to_nat_from_nat_id[OF True[unfolded nrows_def]]
unfolding matrix_to_iarray_nrows
using matrix_to_iarray_fst_Gauss_Jordan_in_ij_iarrays_PA[of "from_nat i" "from_nat k" A P]
using matrix_to_iarray_snd_Gauss_Jordan_in_ij_iarrays_PA[of "from_nat i" "from_nat k" A  P]
unfolding to_nat_from_nat_id[OF True[unfolded nrows_def]]
unfolding to_nat_from_nat_id[OF k[unfolded ncols_def]]
unfolding vec_to_iarray_column'[OF k] by auto
next
case False
hence i_eq_nrows:"i=nrows A" using i by simp
thus ?thesis
unfolding Gauss_Jordan_column_k_PA_def Gauss_Jordan_column_k_iarrays_PA_def Let_def
unfolding snd_conv fst_conv unfolding matrix_to_iarray_nrows by fastforce
qed

lemma matrix_to_iarray_snd_Gauss_Jordan_column_k_PA:
assumes i: "i\<le>nrows A" and k: "k<ncols A"
shows "(fst (snd (Gauss_Jordan_column_k_PA (P,i,A) k))) = fst (snd (Gauss_Jordan_column_k_iarrays_PA (matrix_to_iarray P, i, matrix_to_iarray A) k))"
using matrix_to_iarray_Gauss_Jordan_column_k_1[OF k i]
unfolding Gauss_Jordan_column_k_def Gauss_Jordan_column_k_iarrays_def
unfolding Gauss_Jordan_column_k_PA_def Gauss_Jordan_column_k_iarrays_PA_def snd_conv fst_conv Let_def
unfolding snd_Gauss_Jordan_in_ij_iarrays_PA
unfolding snd_if_conv
unfolding snd_Gauss_Jordan_in_ij_PA_eq
by fastforce

lemma matrix_to_iarray_third_Gauss_Jordan_column_k_PA:
assumes i: "i\<le>nrows A" and k: "k<ncols A"
shows "matrix_to_iarray (snd (snd (Gauss_Jordan_column_k_PA (P,i,A) k))) = snd (snd (Gauss_Jordan_column_k_iarrays_PA (matrix_to_iarray P, i, matrix_to_iarray A) k))"
using matrix_to_iarray_Gauss_Jordan_column_k_2[OF k i]
unfolding Gauss_Jordan_column_k_def Gauss_Jordan_column_k_iarrays_def
unfolding Gauss_Jordan_column_k_PA_def Gauss_Jordan_column_k_iarrays_PA_def snd_conv fst_conv Let_def
unfolding snd_Gauss_Jordan_in_ij_iarrays_PA
unfolding snd_if_conv snd_Gauss_Jordan_in_ij_PA_eq by fast

subsubsection\<open>Properties about @{term "Gauss_Jordan_upt_k_iarrays_PA"}\<close>

lemma
assumes "k<ncols A"
shows matrix_to_iarray_fst_Gauss_Jordan_upt_k_PA: "matrix_to_iarray (fst (Gauss_Jordan_upt_k_PA A k)) = fst (Gauss_Jordan_upt_k_iarrays_PA (matrix_to_iarray A) k)"
and matrix_to_iarray_snd_Gauss_Jordan_upt_k_PA: "matrix_to_iarray (snd (Gauss_Jordan_upt_k_PA A k)) = (snd (Gauss_Jordan_upt_k_iarrays_PA (matrix_to_iarray A) k))"
and "fst (snd (foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<Suc k])) =
    fst (snd (foldl Gauss_Jordan_column_k_iarrays_PA (mat_iarray 1 (nrows_iarray (matrix_to_iarray A)), 0, matrix_to_iarray A) [0..<Suc k]))"
and "fst (snd (foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<Suc k])) \<le> nrows A"
using assms
proof (induct k)
assume zero_less_ncols: "0 < ncols A"
show " matrix_to_iarray (fst (Gauss_Jordan_upt_k_PA A 0)) = fst (Gauss_Jordan_upt_k_iarrays_PA (matrix_to_iarray A) 0)"
unfolding Gauss_Jordan_upt_k_PA_def Gauss_Jordan_upt_k_iarrays_PA_def Let_def fst_conv apply auto
unfolding nrows_eq_card_rows unfolding matrix_to_iarray_mat[symmetric]
by (rule matrix_to_iarray_fst_Gauss_Jordan_column_k_PA, auto simp add: zero_less_ncols)
show "matrix_to_iarray (snd (Gauss_Jordan_upt_k_PA A 0)) = snd (Gauss_Jordan_upt_k_iarrays_PA (matrix_to_iarray A) 0)"
unfolding Gauss_Jordan_upt_k_PA_def Gauss_Jordan_upt_k_iarrays_PA_def Let_def fst_conv snd_conv apply auto
unfolding nrows_eq_card_rows unfolding matrix_to_iarray_mat[symmetric]
by (rule matrix_to_iarray_third_Gauss_Jordan_column_k_PA, auto simp add: zero_less_ncols)
show "fst (snd (foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<Suc 0])) =
    fst (snd (foldl Gauss_Jordan_column_k_iarrays_PA (mat_iarray 1 (nrows_iarray (matrix_to_iarray A)), 0, matrix_to_iarray A) [0..<Suc 0]))"
apply simp unfolding nrows_eq_card_rows unfolding matrix_to_iarray_mat[symmetric]
by (rule matrix_to_iarray_snd_Gauss_Jordan_column_k_PA, auto simp add: zero_less_ncols)
show "fst (snd (foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<Suc 0])) \<le> nrows A"
by (simp add: fst_snd_Gauss_Jordan_column_k_PA_eq fst_Gauss_Jordan_column_k)
next
fix k assume "(k < ncols A \<Longrightarrow> matrix_to_iarray (fst (Gauss_Jordan_upt_k_PA A k)) = fst (Gauss_Jordan_upt_k_iarrays_PA (matrix_to_iarray A) k))"
and "(k < ncols A \<Longrightarrow> matrix_to_iarray (snd (Gauss_Jordan_upt_k_PA A k)) = snd (Gauss_Jordan_upt_k_iarrays_PA (matrix_to_iarray A) k))"
and "(k < ncols A \<Longrightarrow> fst (snd (foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<Suc k])) =
         fst (snd (foldl Gauss_Jordan_column_k_iarrays_PA (mat_iarray 1 (nrows_iarray (matrix_to_iarray A)), 0, matrix_to_iarray A) [0..<Suc k])))"
and "(k < ncols A \<Longrightarrow> fst (snd (foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<Suc k])) \<le> nrows A)"
and Suc_k: "Suc k < ncols A"
hence hyp1: "matrix_to_iarray (fst (Gauss_Jordan_upt_k_PA A k)) = fst (Gauss_Jordan_upt_k_iarrays_PA (matrix_to_iarray A) k)"
and hyp2: "matrix_to_iarray (snd (Gauss_Jordan_upt_k_PA A k)) = snd (Gauss_Jordan_upt_k_iarrays_PA (matrix_to_iarray A) k)"
and hyp3: "fst (snd (foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<Suc k])) =
         fst (snd (foldl Gauss_Jordan_column_k_iarrays_PA (mat_iarray 1 (nrows_iarray (matrix_to_iarray A)), 0, matrix_to_iarray A) [0..<Suc k]))"
and hyp4: "fst (snd (foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<Suc k])) \<le> nrows A"
by linarith+

have suc_rw: "[0..<Suc (Suc k)] = [0..<Suc k] @ [Suc k]" by simp
define A' where "A' = foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<Suc k]"
define B where "B = foldl Gauss_Jordan_column_k_iarrays_PA (mat_iarray 1 (nrows_iarray (matrix_to_iarray A)), 0, matrix_to_iarray A) [0..<Suc k]"
have A'_eq: "A' = (fst A', fst (snd A'), snd (snd A'))" by auto

have fst_A': "matrix_to_iarray (fst A') = fst B" unfolding A'_def B_def by (rule hyp1[unfolded Gauss_Jordan_upt_k_PA_def Gauss_Jordan_upt_k_iarrays_PA_def Let_def fst_conv])
have fst_snd_A': "fst (snd A') = fst (snd B)" unfolding A'_def B_def by (rule hyp3[unfolded Gauss_Jordan_upt_k_PA_def Gauss_Jordan_upt_k_iarrays_PA_def ])
have snd_snd_A': "matrix_to_iarray (snd (snd A')) = (snd (snd B))"
unfolding A'_def B_def
by (rule hyp2[unfolded Gauss_Jordan_upt_k_PA_def Gauss_Jordan_upt_k_iarrays_PA_def Let_def fst_conv snd_conv])

show "matrix_to_iarray (fst (Gauss_Jordan_upt_k_PA A (Suc k))) = fst (Gauss_Jordan_upt_k_iarrays_PA (matrix_to_iarray A) (Suc k))"
proof -
have "matrix_to_iarray (fst (Gauss_Jordan_upt_k_PA A (Suc k))) = matrix_to_iarray (fst (foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<Suc (Suc k)]))"
unfolding Gauss_Jordan_upt_k_PA_def Let_def fst_conv ..
also have "... = matrix_to_iarray (fst (Gauss_Jordan_column_k_PA (foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<Suc k]) (Suc k)))"
unfolding suc_rw foldl_append unfolding List.foldl.simps ..
also have "... = matrix_to_iarray (fst (Gauss_Jordan_column_k_PA (fst A',fst (snd A'), snd (snd A')) (Suc k)))" unfolding A'_def by simp
also have "... = fst (Gauss_Jordan_column_k_iarrays_PA (matrix_to_iarray (fst A'), fst (snd A'), matrix_to_iarray (snd (snd A'))) (Suc k))"
proof (rule matrix_to_iarray_fst_Gauss_Jordan_column_k_PA)
 show "fst (snd A') \<le> nrows (snd (snd A'))" using hyp4 unfolding nrows_def A'_def .
 show  "Suc k < ncols (snd (snd A'))" using Suc_k unfolding ncols_def .
qed
also have "... =  fst (Gauss_Jordan_column_k_iarrays_PA (fst B, fst (snd B), snd (snd B)) (Suc k))"
unfolding fst_A' fst_snd_A' snd_snd_A' ..
also have "... = fst (Gauss_Jordan_upt_k_iarrays_PA (matrix_to_iarray A) (Suc k))"
unfolding Gauss_Jordan_upt_k_iarrays_PA_def Let_def fst_conv
unfolding suc_rw foldl_append unfolding List.foldl.simps B_def by fastforce
finally show ?thesis .
qed

show "matrix_to_iarray (snd (Gauss_Jordan_upt_k_PA A (Suc k))) = snd (Gauss_Jordan_upt_k_iarrays_PA (matrix_to_iarray A) (Suc k))"
proof -
  have "matrix_to_iarray (snd (Gauss_Jordan_upt_k_PA A (Suc k))) =  matrix_to_iarray (snd (snd (foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<Suc (Suc k)])))"
  unfolding Gauss_Jordan_upt_k_PA_def Let_def snd_conv ..
also have "... =  matrix_to_iarray (snd (snd (Gauss_Jordan_column_k_PA (foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<Suc k]) (Suc k))))"
unfolding suc_rw foldl_append unfolding List.foldl.simps ..
also have "... = matrix_to_iarray (snd (snd (Gauss_Jordan_column_k_PA (fst A',fst (snd A'), snd (snd A')) (Suc k))))" unfolding A'_def by simp
also have "... =  snd (snd (Gauss_Jordan_column_k_iarrays_PA (matrix_to_iarray (fst A'), fst (snd A'), matrix_to_iarray (snd (snd A'))) (Suc k)))"
proof (rule matrix_to_iarray_third_Gauss_Jordan_column_k_PA)
 show "fst (snd A') \<le> nrows (snd (snd A'))" using hyp4 unfolding nrows_def A'_def .
 show  "Suc k < ncols (snd (snd A'))" using Suc_k unfolding ncols_def .
qed
also have "... = snd (snd (Gauss_Jordan_column_k_iarrays_PA (fst B, fst (snd B), snd (snd B)) (Suc k)))"
unfolding fst_A' fst_snd_A' snd_snd_A' ..
also have "... = snd (Gauss_Jordan_upt_k_iarrays_PA (matrix_to_iarray A) (Suc k))"
unfolding Gauss_Jordan_upt_k_iarrays_PA_def Let_def fst_conv
unfolding suc_rw foldl_append unfolding List.foldl.simps B_def by fastforce
finally show ?thesis .
qed

show "fst (snd (foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<Suc (Suc k)])) =
        fst (snd (foldl Gauss_Jordan_column_k_iarrays_PA (mat_iarray 1 (nrows_iarray (matrix_to_iarray A)), 0, matrix_to_iarray A) [0..<Suc (Suc k)]))"
proof -
have "fst (snd (foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<Suc (Suc k)])) =
  fst (snd (Gauss_Jordan_column_k_PA (foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<Suc k]) (Suc k)))"
unfolding suc_rw foldl_append unfolding List.foldl.simps ..
also have "... = fst (snd (Gauss_Jordan_column_k_PA (fst A',fst (snd A'), snd (snd A')) (Suc k)))"
unfolding A'_def by simp
also have "... = fst (snd (Gauss_Jordan_column_k_iarrays_PA (matrix_to_iarray (fst A'),fst (snd A'), matrix_to_iarray (snd (snd A'))) (Suc k)))"
proof (rule matrix_to_iarray_snd_Gauss_Jordan_column_k_PA)
 show "fst (snd A') \<le> nrows (snd (snd A'))" using hyp4 unfolding nrows_def A'_def .
 show "Suc k < ncols (snd (snd A'))" using Suc_k unfolding ncols_def .
qed
also have  "\<dots> = fst (snd (Gauss_Jordan_column_k_iarrays_PA (fst B,fst (snd B), snd (snd B)) (Suc k)))"
unfolding fst_A' fst_snd_A' snd_snd_A' ..
also have "... = fst (snd (foldl Gauss_Jordan_column_k_iarrays_PA (mat_iarray 1 (nrows_iarray (matrix_to_iarray A)), 0, matrix_to_iarray A) [0..<Suc (Suc k)]))"
unfolding B_def unfolding nrows_eq_card_rows unfolding matrix_to_iarray_mat[symmetric] by auto
finally show ?thesis .
qed
show "fst (snd (foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<Suc (Suc k)])) \<le> nrows A"
by (metis snd_foldl_Gauss_Jordan_column_k_eq Suc_k fst_foldl_Gauss_Jordan_column_k_less)
qed

subsubsection\<open>Properties about @{term "Gauss_Jordan_iarrays_PA"}\<close>

lemma matrix_to_iarray_fst_Gauss_Jordan_PA:
shows "matrix_to_iarray (fst (Gauss_Jordan_PA A)) = fst (Gauss_Jordan_iarrays_PA (matrix_to_iarray A))"
  unfolding Gauss_Jordan_PA_def Gauss_Jordan_iarrays_PA_def
  using matrix_to_iarray_fst_Gauss_Jordan_upt_k_PA[of "ncols A - 1" A]
  by (simp add: ncols_def ncols_eq_card_columns)

lemma matrix_to_iarray_snd_Gauss_Jordan_PA:
shows "matrix_to_iarray (snd (Gauss_Jordan_PA A)) = snd (Gauss_Jordan_iarrays_PA (matrix_to_iarray A))"
  unfolding Gauss_Jordan_PA_def Gauss_Jordan_iarrays_PA_def
  using matrix_to_iarray_snd_Gauss_Jordan_upt_k_PA[of "ncols A - 1" A]
  by (simp add: ncols_def ncols_eq_card_columns)

lemma Gauss_Jordan_iarrays_PA_mult:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows "snd (Gauss_Jordan_iarrays_PA (matrix_to_iarray A)) = fst (Gauss_Jordan_iarrays_PA (matrix_to_iarray A)) **i (matrix_to_iarray A)"
proof -
have "snd (Gauss_Jordan_PA A) = fst (Gauss_Jordan_PA A) ** A" using fst_Gauss_Jordan_PA[of A] ..
hence "matrix_to_iarray (snd (Gauss_Jordan_PA A)) = matrix_to_iarray (fst (Gauss_Jordan_PA A) ** A)" by simp
thus ?thesis unfolding matrix_to_iarray_snd_Gauss_Jordan_PA matrix_to_iarray_matrix_matrix_mult matrix_to_iarray_fst_Gauss_Jordan_PA .
qed

lemma snd_snd_Gauss_Jordan_column_k_iarrays_PA_eq:
shows "snd (snd (Gauss_Jordan_column_k_iarrays_PA (P,i,A) k)) = snd (Gauss_Jordan_column_k_iarrays (i,A) k)"
unfolding Gauss_Jordan_column_k_iarrays_PA_def Gauss_Jordan_column_k_iarrays_def unfolding Let_def snd_conv fst_conv unfolding snd_Gauss_Jordan_in_ij_iarrays_PA by auto

lemma fst_snd_Gauss_Jordan_column_k_iarrays_PA_eq:
shows "fst (snd (Gauss_Jordan_column_k_iarrays_PA (P,i,A) k)) = fst (Gauss_Jordan_column_k_iarrays (i,A) k)"
unfolding Gauss_Jordan_column_k_iarrays_PA_def Gauss_Jordan_column_k_iarrays_def unfolding Let_def snd_conv fst_conv by auto

lemma foldl_Gauss_Jordan_column_k_iarrays_eq:
"snd (foldl Gauss_Jordan_column_k_iarrays_PA (B, 0, A) [0..<k]) = foldl Gauss_Jordan_column_k_iarrays (0, A) [0..<k]"
proof (induct k)
case 0
show ?case by simp
case (Suc k)
have suc_rw: "[0..<Suc k] = [0..<k] @ [k]" by simp
show ?case
unfolding suc_rw foldl_append unfolding List.foldl.simps
by (metis Suc.hyps fst_snd_Gauss_Jordan_column_k_iarrays_PA_eq snd_snd_Gauss_Jordan_column_k_iarrays_PA_eq surjective_pairing)
qed

lemma snd_Gauss_Jordan_upt_k_iarrays_PA:
shows "snd (Gauss_Jordan_upt_k_iarrays_PA A k) = (Gauss_Jordan_upt_k_iarrays A k)"
unfolding Gauss_Jordan_upt_k_iarrays_PA_def Gauss_Jordan_upt_k_iarrays_def Let_def
using foldl_Gauss_Jordan_column_k_iarrays_eq[of "mat_iarray 1 (nrows_iarray A)" A "Suc k"] by simp

lemma snd_Gauss_Jordan_iarrays_PA_eq: "snd (Gauss_Jordan_iarrays_PA A) = Gauss_Jordan_iarrays A"
unfolding Gauss_Jordan_iarrays_def Gauss_Jordan_iarrays_PA_def
using snd_Gauss_Jordan_upt_k_iarrays_PA by auto

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.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_StoogeSortCount
imports "../../Test_Base"
begin

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

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

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

fun take :: "int => 'a list => 'a list" where
"take y z =
   (if y <= 0 then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => cons2 z2 (take (y - 1) xs)))"

fun sort2 :: "int => int => int list" where
"sort2 y z =
   (if y <= z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

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

fun length :: "'a list => int" where
"length (nil2) = 0"
| "length (cons2 z l) = 1 + (length l)"

fun drop :: "int => 'a list => 'a list" where
"drop y z =
   (if y <= 0 then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => drop (y - 1) xs1))"

fun splitAt :: "int => 'a list =>
                (('a list), ('a list)) pair" where
"splitAt y z = pair2 (take y z) (drop y z)"

function stooge1sort2 :: "int list => int list"
         and stoogesort :: "int list => int list"
         and stooge1sort1 :: "int list => int list" where
"stooge1sort2 y =
   (case splitAt ((op div) (length y) 3) (reverse y) of
      pair2 ys2 zs2 => x (stoogesort zs2) (reverse ys2))"
| "stoogesort (nil2) = nil2"
| "stoogesort (cons2 z (nil2)) = cons2 z (nil2)"
| "stoogesort (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "stoogesort (cons2 z (cons2 y2 (cons2 x3 x4))) =
     stooge1sort2
       (stooge1sort1 (stooge1sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "stooge1sort1 y =
     (case splitAt ((op div) (length y) 3) y of
        pair2 ys2 zs1 => x ys2 (stoogesort zs1))"
by pat_completeness auto

fun count :: "'a => 'a list => int" where
"count y (nil2) = 0"
| "count y (cons2 z2 ys) =
     (if (y = z2) then 1 + (count y ys) else count y ys)"

theorem property0 :
  "((count y (stoogesort xs)) = (count y xs))"
  oops

end


section \<open>Product Manifold\<close>
theory Product_Manifold
  imports Differentiable_Manifold
begin

locale c_manifold_prod =
  m1: c_manifold charts1 k +
  m2: c_manifold charts2 k for k charts1 charts2

begin

lift_definition prod_chart :: "('a, 'b) chart \<Rightarrow> ('c, 'd) chart \<Rightarrow> ('a \<times> 'c, 'b \<times> 'd) chart"
  is "\<lambda>(d::'a set, d'::'b set, f::'a\<Rightarrow>'b, f'::'b\<Rightarrow>'a).
      \<lambda>(e::'c set, e'::'d set, g::'c\<Rightarrow>'d, g'::'d\<Rightarrow>'c).
        (d \<times> e, d' \<times> e', \<lambda>(x,y). (f x, g y), \<lambda>(x,y). (f' x, g' y))"
  by (auto intro: open_Times simp: homeomorphism_prod)

lemma domain_prod_chart[simp]: "domain (prod_chart c1 c2) = domain c1 \<times> domain c2"
  and codomain_prod_chart[simp]: "codomain (prod_chart c1 c2) = codomain c1 \<times> codomain c2"
  and apply_prod_chart[simp]: "apply_chart (prod_chart c1 c2) = (\<lambda>(x,y). (c1 x, c2 y))"
  and inv_chart_prod_chart[simp]: "inv_chart (prod_chart c1 c2) = (\<lambda>(x,y). (inv_chart c1 x, inv_chart c2 y))"
  by (transfer, auto)+

lemma prod_chart_compat:
  "k-smooth_compat (prod_chart c1 c2) (prod_chart d1 d2)"
  if compat1: "k-smooth_compat c1 d1" and compat2: "k-smooth_compat c2 d2"
  unfolding smooth_compat_def
  apply (auto simp add: comp_def case_prod_beta cong del: image_cong_simp)
   apply (simp add: Times_Int_Times image_prod)
   apply (rule smooth_on_Pair')
      apply (auto intro!: continuous_intros)
    apply (auto simp: compat1[unfolded smooth_compat_def comp_def])
    apply (auto simp: compat2[unfolded smooth_compat_def comp_def])
   apply (simp add: Times_Int_Times image_prod)
   apply (rule smooth_on_Pair')
     apply (auto intro!: continuous_intros)
    apply (auto simp: compat2[unfolded smooth_compat_def comp_def])
    apply (auto simp: compat1[unfolded smooth_compat_def comp_def])
  done

definition prod_charts :: "('a \<times> 'c, 'b \<times> 'd) chart set" where
  "prod_charts = {prod_chart c1 c2 | c1 c2. c1 \<in> charts1 \<and> c2 \<in> charts2}"

lemma c_manifold_atlas_product: "c_manifold prod_charts k"
  apply (unfold_locales)
proof -
  fix c d assume c: "c \<in> prod_charts" and d: "d \<in> prod_charts"
  obtain c1 c2 where c_def: "c = prod_chart c1 c2" and c1: "c1 \<in> charts1" and c2: "c2 \<in> charts2"
    using c prod_charts_def by auto
  obtain d1 d2 where d_def: "d = prod_chart d1 d2" and d1: "d1 \<in> charts1" and d2: "d2 \<in> charts2"
    using d prod_charts_def by auto
  have compat1: "k-smooth_compat c1 d1"
    using c1 d1 by (auto intro: m1.pairwise_compat)
  have compat2: "k-smooth_compat c2 d2"
    using c2 d2 by (auto intro: m2.pairwise_compat)
  show "k-smooth_compat c d"
    unfolding c_def d_def
  using compat1 compat2 by (rule prod_chart_compat)
qed

end

end


(*  Title:      HOL/UNITY/Comp/Priority.thy
    Author:     Sidi O Ehmety, Cambridge University Computer Laboratory
    Copyright   2001  University of Cambridge
*)

section\<open>The priority system\<close>

theory Priority imports PriorityAux begin

text\<open>From Charpentier and Chandy,
Examples of Program Composition Illustrating the Use of Universal Properties
   In J. Rolim (editor), Parallel and Distributed Processing,
   Spriner LNCS 1586 (1999), pages 1215-1227.\<close>

type_synonym state = "(vertex*vertex)set"
type_synonym command = "vertex=>(state*state)set"

consts
  init :: "(vertex*vertex)set"
  \<comment>\<open>the initial state\<close>

text\<open>Following the definitions given in section 4.4\<close>

definition highest :: "[vertex, (vertex*vertex)set]=>bool"
  where "highest i r \<longleftrightarrow> A i r = {}"
    \<comment>\<open>i has highest priority in r\<close>

definition lowest :: "[vertex, (vertex*vertex)set]=>bool"
  where "lowest i r \<longleftrightarrow> R i r = {}"
    \<comment>\<open>i has lowest priority in r\<close>

definition act :: command
  where "act i = {(s, s'). s'=reverse i s & highest i s}"

definition Component :: "vertex=>state program"
  where "Component i = mk_total_program({init}, {act i}, UNIV)"
    \<comment>\<open>All components start with the same initial state\<close>

text\<open>Some Abbreviations\<close>
definition Highest :: "vertex=>state set"
  where "Highest i = {s. highest i s}"

definition Lowest :: "vertex=>state set"
  where "Lowest i = {s. lowest i s}"

definition Acyclic :: "state set"
  where "Acyclic = {s. acyclic s}"

definition Maximal :: "state set"
    \<comment>\<open>Every ``above'' set has a maximal vertex\<close>
  where "Maximal = (\<Inter>i. {s. ~highest i s-->(\<exists>j \<in> above i  s. highest j s)})"

definition Maximal' :: "state set"
    \<comment>\<open>Maximal vertex: equivalent definition\<close>
  where "Maximal' = (\<Inter>i. Highest i Un (\<Union>j. {s. j \<in> above i s} Int Highest j))"

definition Safety :: "state set"
  where "Safety = (\<Inter>i. {s. highest i s --> (\<forall>j \<in> neighbors i s. ~highest j s)})"

  (* Composition of a finite set of component;
     the vertex 'UNIV' is finite by assumption *)

definition system :: "state program"
  where "system = (\<Squnion>i. Component i)"

declare highest_def [simp] lowest_def [simp]
declare Highest_def [THEN def_set_simp, simp]
    and Lowest_def  [THEN def_set_simp, simp]

declare Component_def [THEN def_prg_Init, simp]
declare act_def [THEN def_act_simp, simp]

subsection\<open>Component correctness proofs\<close>

text\<open>neighbors is stable\<close>
lemma Component_neighbors_stable: "Component i \<in> stable {s. neighbors k s = n}"
by (simp add: Component_def, safety, auto)

text\<open>property 4\<close>
lemma Component_waits_priority: "Component i: {s. ((i,j):s) = b} Int (- Highest i) co {s. ((i,j):s)=b}"
by (simp add: Component_def, safety)

text\<open>property 5: charpentier and Chandy mistakenly express it as
 'transient Highest i'. Consider the case where i has neighbors\<close>
lemma Component_yields_priority:
 "Component i: {s. neighbors i s \<noteq> {}} Int Highest i
               ensures - Highest i"
apply (simp add: Component_def)
apply (ensures_tac "act i", blast+)
done

text\<open>or better\<close>
lemma Component_yields_priority': "Component i \<in> Highest i ensures Lowest i"
apply (simp add: Component_def)
apply (ensures_tac "act i", blast+)
done

text\<open>property 6: Component doesn't introduce cycle\<close>
lemma Component_well_behaves: "Component i \<in> Highest i co Highest i Un Lowest i"
by (simp add: Component_def, safety, fast)

text\<open>property 7: local axiom\<close>
lemma locality: "Component i \<in> stable {s. \<forall>j k. j\<noteq>i & k\<noteq>i--> ((j,k):s) = b j k}"
by (simp add: Component_def, safety)

subsection\<open>System  properties\<close>
text\<open>property 8: strictly universal\<close>

lemma Safety: "system \<in> stable Safety"
apply (unfold Safety_def)
apply (rule stable_INT)
apply (simp add: system_def, safety, fast)
done

text\<open>property 13: universal\<close>
lemma p13: "system \<in> {s. s = q} co {s. s=q} Un {s. \<exists>i. derive i q s}"
by (simp add: system_def Component_def mk_total_program_def totalize_JN, safety, blast)

text\<open>property 14: the 'above set' of a Component that hasn't got
      priority doesn't increase\<close>
lemma above_not_increase:
     "system \<in> -Highest i Int {s. j\<notin>above i s} co {s. j\<notin>above i s}"
apply (insert reach_lemma [of concl: j])
apply (simp add: system_def Component_def mk_total_program_def totalize_JN,
       safety)
apply (simp add: trancl_converse, blast)
done

lemma above_not_increase':
     "system \<in> -Highest i Int {s. above i s = x} co {s. above i s <= x}"
apply (insert above_not_increase [of i])
apply (simp add: trancl_converse constrains_def, blast)
done

text\<open>p15: universal property: all Components well behave\<close>
lemma system_well_behaves: "system \<in> Highest i co Highest i Un Lowest i"
  by (simp add: system_def Component_def mk_total_program_def totalize_JN, safety, auto)

lemma Acyclic_eq: "Acyclic = (\<Inter>i. {s. i\<notin>above i s})"
  by (auto simp add: Acyclic_def acyclic_def trancl_converse)

lemmas system_co =
      constrains_Un [OF above_not_increase [rule_format] system_well_behaves]

lemma Acyclic_stable: "system \<in> stable Acyclic"
apply (simp add: stable_def Acyclic_eq)
apply (auto intro!: constrains_INT system_co [THEN constrains_weaken]
            simp add: image0_r_iff_image0_trancl trancl_converse)
done

lemma Acyclic_subset_Maximal: "Acyclic <= Maximal"
apply (unfold Acyclic_def Maximal_def, clarify)
apply (drule above_lemma_b, auto)
done

text\<open>property 17: original one is an invariant\<close>
lemma Acyclic_Maximal_stable: "system \<in> stable (Acyclic Int Maximal)"
by (simp add: Acyclic_subset_Maximal [THEN Int_absorb2] Acyclic_stable)

text\<open>property 5: existential property\<close>

lemma Highest_leadsTo_Lowest: "system \<in> Highest i leadsTo Lowest i"
apply (simp add: system_def Component_def mk_total_program_def totalize_JN)
apply (ensures_tac "act i", auto)
done

text\<open>a lowest i can never be in any abover set\<close>
lemma Lowest_above_subset: "Lowest i <= (\<Inter>k. {s. i\<notin>above k s})"
by (auto simp add: image0_r_iff_image0_trancl trancl_converse)

text\<open>property 18: a simpler proof than the original, one which uses psp\<close>
lemma Highest_escapes_above: "system \<in> Highest i leadsTo (\<Inter>k. {s. i\<notin>above k s})"
apply (rule leadsTo_weaken_R)
apply (rule_tac [2] Lowest_above_subset)
apply (rule Highest_leadsTo_Lowest)
done

lemma Highest_escapes_above':
     "system \<in> Highest j Int {s. j \<in> above i s} leadsTo {s. j\<notin>above i s}"
by (blast intro: leadsTo_weaken [OF Highest_escapes_above Int_lower1 INT_lower])

subsection\<open>The main result: above set decreases\<close>

text\<open>The original proof of the following formula was wrong\<close>

lemma Highest_iff_above0: "Highest i = {s. above i s ={}}"
by (auto simp add: image0_trancl_iff_image0_r)

lemmas above_decreases_lemma =
     psp [THEN leadsTo_weaken, OF Highest_escapes_above' above_not_increase']

lemma above_decreases:
     "system \<in> (\<Union>j. {s. above i s = x} Int {s. j \<in> above i s} Int Highest j)
               leadsTo {s. above i s < x}"
apply (rule leadsTo_UN)
apply (rule single_leadsTo_I, clarify)
apply (rule_tac x = "above i xa" in above_decreases_lemma)
apply (simp_all (no_asm_use) add: Highest_iff_above0)
apply blast+
done

(** Just a massage of conditions to have the desired form ***)
lemma Maximal_eq_Maximal': "Maximal = Maximal'"
by (unfold Maximal_def Maximal'_def Highest_def, blast)

lemma Acyclic_subset:
   "x\<noteq>{} ==>
    Acyclic Int {s. above i s = x} <=
    (\<Union>j. {s. above i s = x} Int {s. j \<in> above i s} Int Highest j)"
apply (rule_tac B = "Maximal' Int {s. above i s = x}" in subset_trans)
apply (simp (no_asm) add: Maximal_eq_Maximal' [symmetric])
apply (blast intro: Acyclic_subset_Maximal [THEN subsetD])
apply (simp (no_asm) del: above_def add: Maximal'_def Highest_iff_above0)
apply blast
done

lemmas above_decreases' = leadsTo_weaken_L [OF above_decreases Acyclic_subset]
lemmas above_decreases_psp = psp_stable [OF above_decreases' Acyclic_stable]

lemma above_decreases_psp':
"x\<noteq>{}==> system \<in> Acyclic Int {s. above i s = x} leadsTo
                   Acyclic Int {s. above i s < x}"
by (erule above_decreases_psp [THEN leadsTo_weaken], blast, auto)

lemmas finite_psubset_induct = wf_finite_psubset [THEN leadsTo_wf_induct]

lemma Progress: "system \<in> Acyclic leadsTo Highest i"
apply (rule_tac f = "%s. above i s" in finite_psubset_induct)
apply (simp del: above_def
            add: Highest_iff_above0 vimage_def finite_psubset_def, clarify)
apply (case_tac "m={}")
apply (rule Int_lower2 [THEN [2] leadsTo_weaken_L])
apply (force simp add: leadsTo_refl)
apply (rule_tac A' = "Acyclic Int {x. above i x < m}" in leadsTo_weaken_R)
apply (blast intro: above_decreases_psp')+
done

text\<open>We have proved all (relevant) theorems given in the paper.  We didn't
assume any thing about the relation @{term r}.  It is not necessary that
@{term r} be a priority relation as assumed in the original proof.  It
suffices that we start from a state which is finite and acyclic.\<close>

end