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

section \<open>Linked Lists by ML references\<close>

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

section \<open>Definition of Linked Lists\<close>

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

primrec
  node_encode :: "'a::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::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::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::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 \<open>Proving correctness with relational abstraction\<close>

subsection \<open>Definition of list_of, list_of', refs_of and refs_of'\<close>

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 \<open>Properties of these definitions\<close>

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 \<open>More complicated properties of these predicates\<close>

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 \<open>Interaction of these predicates with our heap transitions\<close>

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"
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 \<open>Proving make_llist and traverse correct\<close>

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 \<bind> 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 \<open>Proving correctness of in-place reversal\<close>

subsection \<open>Definition of in-place reversal\<close>

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 \<open>Correctness Proof\<close>

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 \<open>The merge function on Linked Lists\<close>
text \<open>We also prove merge correct\<close>

text\<open>First, we define merge on lists in a natural way.\<close>

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 \<open>Definition of merge function\<close>

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 \<open>Induction refinement by applying the abstraction function to our induct rule\<close>

text \<open>From our original induction rule Lmerge.induct, we derive a new rule with our list_of' predicate\<close>

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 \<open>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.\<close>

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 \<open>Proving merge correct\<close>

text \<open>As many parts of the following three proofs are identical, we could actually move the
same reasoning into an extended induction rule\<close>

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) \<open>r \<noteq> p\<close> 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) \<open>r \<noteq> q\<close> 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 \<open>Code generation\<close>

text \<open>A simple example program\<close>

definition test_1 where "test_1 = (do { ll_xs \<leftarrow> make_llist [1..(15::int)]; xs \<leftarrow> traverse ll_xs; return xs })"
definition test_2 where "test_2 = (do { ll_xs \<leftarrow> make_llist [1..(15::int)]; ll_ys \<leftarrow> rev ll_xs; ys \<leftarrow> 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 \<open>@{code test_1} ()\<close>
ML_val \<open>@{code test_2} ()\<close>
ML_val \<open>@{code test_3} ()\<close>

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

end


\<^marker>\<open>creator Florian Keßler\<close>

section "IMP- to IMP--"

theory IMP_Minus_To_IMP_Minus_Minus imports Binary_Operations
  "IMP_Minus.Big_StepT" "IMP_Minus.Max_Constant"

begin

text \<open> We give a reduction from IMP- to IMP--. The reduction works by bit blasting each register
       of IMP- into several registers in IMP-- each holding a single bit. Arithmetic operations
       and assignment in IMP- are replaced by the binary operations defined in the Binary Operations
       theory. For WHILE and IF, we replace the condition of a single register's content being
       non-zero by checking whether any of the bits in the translated state is non-zero. \<close>

definition var_bit_list:: "nat \<Rightarrow> vname \<Rightarrow> vname list" where
"var_bit_list n v = map (\<lambda>i. var_bit_to_var (v, i)) [0..<n]"

lemma exists_non_zero_in_var_bit_list_iff:
  assumes "finite (range s)" "Max (range s) < 2 ^ n"
  shows "(\<exists>b\<in>set (var_bit_list n v). IMP_Minus_State_To_IMP_Minus_Minus s n b \<noteq> Some Zero)
      \<longleftrightarrow> s v > 0"
  using assms
  by(auto simp: var_bit_list_def IMP_Minus_State_To_IMP_Minus_Minus_def
      IMP_Minus_State_To_IMP_Minus_Minus_with_operands_a_b_def has_bit_one_then_greater_zero
      greater_zero_then_has_bit_one)

fun IMP_Minus_To_IMP_Minus_Minus:: "IMP_Minus_com \<Rightarrow> nat \<Rightarrow> IMP_Minus_Minus_com" where
"IMP_Minus_To_IMP_Minus_Minus Com.SKIP n = SKIP" |
"IMP_Minus_To_IMP_Minus_Minus (Com.Assign v aexp) n = assignment_to_binary n v aexp" |
"IMP_Minus_To_IMP_Minus_Minus (Com.Seq c1 c2) n =
  (IMP_Minus_To_IMP_Minus_Minus c1 n ;; IMP_Minus_To_IMP_Minus_Minus c2 n )" |
"IMP_Minus_To_IMP_Minus_Minus (Com.If v c1 c2) n = (IF (var_bit_list n v)\<noteq>0 THEN
  IMP_Minus_To_IMP_Minus_Minus c1 n ELSE IMP_Minus_To_IMP_Minus_Minus c2 n)" |
"IMP_Minus_To_IMP_Minus_Minus (Com.While v c) n = (WHILE (var_bit_list n v)\<noteq>0 DO
  IMP_Minus_To_IMP_Minus_Minus c n)"

lemma finite_range_stays_finite: "(c1, s1) \<Rightarrow>\<^bsup>t\<^esup> s2 \<Longrightarrow> finite (range s1)
  \<Longrightarrow> finite (range s2)"
  apply(induction c1 s1 t s2 rule: big_step_t_induct)
  apply auto
  by (metis Un_infinite image_Un sup_top_right)

lemma Max_insert_le_when: "finite (range (s :: vname \<Rightarrow> nat)) \<Longrightarrow> y < r \<Longrightarrow>  Max (range s) < r
  \<Longrightarrow> Max (range (s(x := y))) < r"
  apply auto
  apply(subst Max_insert)
    apply(metis Un_infinite image_Un sup_top_right)
   apply(auto simp: )
  apply(subst Max_less_iff)
    apply(metis Un_infinite image_Un sup_top_right)
  by auto

lemma IMP_Minus_space_growth: "(c1, s1) \<Rightarrow>\<^bsup>t\<^esup> s2 \<Longrightarrow> finite (range s1)
  \<Longrightarrow> max (Max (range s1)) (Max_Constant.max_constant c1) < 2 ^ k
  \<Longrightarrow> (finite (range s2) \<and> Max (range s2) < (2 :: nat) ^ (k + t))"
  apply(frule finite_range_stays_finite)
  apply simp
proof(induction c1 s1 t s2 arbitrary: k rule: big_step_t_induct)
  case (Skip s)
  thus ?case
  by (smt add_lessD1 le_less_trans le_simps max_def mult_2 mult_Suc_right not_le plus_1_eq_Suc
      power.simps power.simps power_add)
next
  case (Assign x a s)
  hence "AExp.aval a s < 2 * 2 ^ k"
    apply - apply(rule aval_le_when) by auto
  hence "Max (range (s(x := aval a s))) < 2 ^ (k + Suc (Suc 0))"
    apply -
    apply(rule Max_insert_le_when)
    using Assign apply auto
    by (smt Assign.prems Max_ge Suc_lessI add_lessD1 le_less_trans max.strict_boundedE
        n_less_m_mult_n nat_zero_less_power_iff not_le_imp_less numeral_1_eq_Suc_0 numeral_eq_iff
        order.asym range_eqI semiring_norm(85) zero_less_numeral)
  thus ?case using Assign by simp
next
  case (Seq c1 s1 x s2 c2 y s3 z)
  hence "finite (range s2)" using finite_range_stays_finite by blast
  hence "\<forall>a. s2 a < 2 ^ (k + x)" using Seq \<open>finite (range s1)\<close> \<open>finite (range s2)\<close> by auto
  have "max_constant c2  < 2 ^ k" using Seq by simp
  hence "max_constant c2 < (2 :: nat) ^ (k + x)"
    apply(auto simp: power_add numeral_2_eq_2)
    by (metis One_nat_def bigstep_progress le_less_trans lessI less_imp_le_nat Seq
        n_less_n_mult_m one_less_power zero_less_power)
  hence "\<forall>a. s3 a < (2 :: nat) ^ (k + x + y)" using Seq \<open>finite (range s2)\<close> by auto
  thus ?case using Seq \<open>z = x + y\<close> \<open>finite (range s3)\<close> by (auto simp: group_cancel.add1)
next
  case (WhileTrue s1 b c x s2 y s3 z)
  hence "finite (range s2)" using finite_range_stays_finite by blast
  hence "\<forall>a. s2 a < 2 ^ (k + x)"
    using WhileTrue \<open>finite (range s1)\<close> \<open>finite (range s2)\<close> by auto
  have "max_constant (WHILE b\<noteq>0 DO c)  < 2 ^ k" using WhileTrue by simp
  hence "max_constant (WHILE b\<noteq>0 DO c) < (2 :: nat) ^ (k + x)"
    by (metis One_nat_def WhileTrue.hyps(2) bigstep_progress le_less_trans lessI
        less_add_same_cancel1 less_imp_le_nat numeral_2_eq_2 power_strict_increasing_iff)
  hence "\<forall>a. s3 a < (2 :: nat) ^ (k + x + y)"
    using WhileTrue \<open>finite (range s2)\<close>
    by auto
  thus ?case using WhileTrue \<open>finite (range s3)\<close>
    by (auto simp: group_cancel.add1 mult_2 trans_less_add2)
qed (auto simp: numeral_2_eq_2 trans_less_add1)

lemma power_of_two_minus: "2 ^ a * c < 2 ^ b \<Longrightarrow> c < (2 :: nat) ^ (b - a)"
proof(induction a arbitrary: c)
  case (Suc a)
  hence "2 * c < 2 ^ (b - a)" by auto
  thus ?case by (smt One_nat_def Suc_diff_Suc diff_is_0_eq less_Suc0
        linordered_comm_semiring_strict_class.comm_mult_strict_left_mono nat_neq_iff not_le
        order.asym plus_1_eq_Suc power.simps(1) power_Suc0_right power_add zero_less_numeral
        zero_less_power)
qed auto

lemma power_of_two_increase_exponent_le: "(2 :: nat) ^ (a + b) * c < r \<Longrightarrow> 2 ^ a * c < r"
  by(auto intro: dual_order.strict_trans2)

lemma move_exponent_to_rhs: "c < (2 :: nat) ^ (a - b) \<Longrightarrow> 2 ^ b * c < 2 ^ a"
  by (smt One_nat_def diff_mult_distrib2 gr_zeroI less_Suc0
      linordered_semidom_class.add_diff_inverse mult_eq_0_iff order.asym power.simps(1)
      power_add power_eq_0_iff zero_less_diff zero_neq_numeral)

subsection \<open>Correctness\<close>

text \<open>First direction of the correctness statement. We show that when an IMP- program run from a
      state where all values are bounded terminates in some state, then the translated IMP-- program
      started on the translated initial state will terminate in the translated final state, after
      a number of steps that is polynomially bigger than the number of steps the IMP- program run
      for. The constants appearing in the polynomial bound have no significance.  \<close>

lemma IMP_Minus_To_IMP_Minus_Minus:
  assumes
    "(c1 :: IMP_Minus_com, s1) \<Rightarrow>\<^bsup>t\<^esup> s2"
    "finite (range s1)"
    "n > t"
    "((2 :: nat) ^ t) * (max (Max (range s1)) (max_constant c1)) < 2 ^ n"
  shows
    "t_small_step_fun (100 * n * (t - 1) + 50)
      (IMP_Minus_To_IMP_Minus_Minus c1 n, IMP_Minus_State_To_IMP_Minus_Minus s1 n)
     = (SKIP, IMP_Minus_State_To_IMP_Minus_Minus s2 n)"
  using assms
proof(induction c1 s1 t s2 rule: big_step_t_induct)
  case (Assign x a s)
  moreover hence "s v < (2 :: nat) ^ n" for v
    using Max_range_le_then_element_le[where ?s=s and ?x="2^n" and ?y=v] by fastforce
  ultimately show ?case
    apply(subst t_small_step_fun_increase_time[where ?t="50 * (n + 1)"])
    apply(clarsimp | safe)+
    apply(subst assignment_to_binary_correct[simplified])
    by (auto simp: aval_le_when IMP_Minus_State_To_IMP_Minus_Minus_def fun_eq_iff
        split!: option.splits)
next
  case (Seq c1 s1 x s2 c2 y s3 z)
  hence "(2 :: nat) ^ x \<le> 2 ^ z" by simp
  hence "((2 :: nat) ^ x) * max (Max (range s1)) (max_constant (c1 ;; c2)) < 2 ^ n" using Seq(8)
    by (meson leD leI less_le_trans mult_less_cancel2)
  hence "2 ^ x * max (Max (range s1)) (max_constant c1) < 2 ^ n" by (simp add: nat_mult_max_right)
  have "max (Max (range s1)) (max_constant (c1)) < 2 ^ (n - z)"
    using power_of_two_minus Seq.prems(3) by fastforce
  have "Max (range s2) < 2 ^ (n - y)"
    using IMP_Minus_space_growth[OF \<open>(c1, s1) \<Rightarrow>\<^bsup> x \<^esup> s2\<close> \<open>finite (range s1)\<close>
        \<open>max (Max (range s1)) (max_constant (c1)) < 2 ^ (n - z)\<close>] \<open>z = x + y\<close> \<open>n > z \<close> by auto
  hence "2 ^ y * Max (range s2) < 2 ^ n"
    by (smt Seq.hyps Seq.prems diff_is_0_eq gr_implies_not0 less_diff_conv
        linordered_comm_semiring_strict_class.comm_mult_strict_left_mono
        linordered_semidom_class.add_diff_inverse not_le not_less_iff_gr_or_eq power_add
        zero_less_numeral zero_less_power)
  moreover have "2 ^ y * max_constant c2 < 2 ^ n"
    using \<open>z = x + y\<close> \<open>2 ^ z * max (Max (range s1)) (max_constant (c1;; c2)) < 2 ^ n\<close>
      power_of_two_increase_exponent_le[where ?b=x]
    by(auto simp: add.commute nat_mult_max_right)
  ultimately have "2 ^ y * max (Max (range s2)) (max_constant c2) < 2 ^ n" by simp
  moreover have "finite (range s2)" using finite_range_stays_finite Seq by simp
  ultimately show ?case using Seq \<open>2 ^ x * max (Max (range s1)) (max_constant c1) < 2 ^ n\<close>
    apply simp
    apply(rule seq_terminates_when[where ?t1.0="100 * n * (x - Suc 0) + 50" and
          ?t2.0="100 * n * (y - Suc 0) + 50"])
      apply auto apply(cases x) apply(cases y) prefer 3 apply(cases y)
    using bigstep_progress by(auto simp: algebra_simps)
next
  case (IfTrue s b c1 x t y c2)
  hence "(2 ^ y) * Max (range s) < 2 ^ n"
    by (meson le_less_trans max.cobounded1 move_exponent_to_rhs power_of_two_minus)
  hence "Max (range s) < 2 ^ n" by(auto intro: le_less_trans[OF _ \<open>2 ^ y * Max (range s) < 2 ^ n\<close>])
  thus ?case apply(simp only: t_small_step_fun_terminate_iff)
    using IfTrue apply(simp add: t_small_step_fun_small_step_fun exists_non_zero_in_var_bit_list_iff)
    apply(rule t_small_step_fun_increase_time[where ?t="100 * n * (x - 1) + 50"])
     apply(cases x) using bigstep_progress apply (auto simp: algebra_simps)
    using IfTrue.IH bigstep_progress by(fastforce simp: nat_mult_max_right)+
next
  case (IfFalse s b c2 x t y c1)
  hence "(2 ^ y) * Max (range s) < 2 ^ n"
    by (meson le_less_trans max.cobounded1 move_exponent_to_rhs power_of_two_minus)
  hence "Max (range s) < 2 ^ n" by(auto intro: le_less_trans[OF _ \<open>2 ^ y * Max (range s) < 2 ^ n\<close>])
  then show ?case apply(simp only: t_small_step_fun_terminate_iff)
    using IfFalse apply(simp add: t_small_step_fun_small_step_fun exists_non_zero_in_var_bit_list_iff)
    apply(rule t_small_step_fun_increase_time[where ?t="100 * n * (x - 1) + 50"])
     apply(cases x) using bigstep_progress apply (auto simp: algebra_simps)
    using IfFalse.IH bigstep_progress by(fastforce simp: nat_mult_max_right)+
next
  case (WhileFalse s b c)
  hence "(2 ^ Suc (Suc 0)) * Max (range s) < 2 ^ n"
    by (meson le_less_trans max.cobounded1 move_exponent_to_rhs power_of_two_minus)
  hence "Max (range s) < 2 ^ n"
    by(auto intro: le_less_trans[OF _ \<open>(2 ^ Suc (Suc 0)) * Max (range s) < 2 ^ n\<close>])
  then show ?case using WhileFalse
    by(simp add: t_small_step_fun_terminate_iff exists_non_zero_in_var_bit_list_iff)
next
  case (WhileTrue s1 b c x s2 y s3 z)
  hence "(2 ^ z) * Max (range s1) < 2 ^ n"
    by (meson le_less_trans max.cobounded1 move_exponent_to_rhs power_of_two_minus)
  hence "Max (range s1) < 2 ^ n" by(auto intro: le_less_trans[OF _ \<open>2 ^ z * Max (range s1) < 2 ^ n\<close>])
  have "(2 :: nat) ^ x \<le> 2 ^ z" using WhileTrue by simp
  hence "((2 :: nat) ^ x) * max (Max (range s1)) (max_constant (WHILE b\<noteq>0 DO c)) < 2 ^ n"
    using \<open>2 ^ z * max (Max (range s1)) (max_constant (WHILE b\<noteq>0 DO c)) < 2 ^ n\<close>
    by (meson leD leI less_le_trans mult_less_cancel2)
  hence "2 ^ x * max (Max (range s1)) (max_constant c) < 2 ^ n" by (simp add: nat_mult_max_right)
  have "max (Max (range s1)) (max_constant c) < 2 ^ (n - z)"
    using power_of_two_minus WhileTrue by (metis Max_Constant.max_constant.simps)
  have "Max (range s2) < 2 ^ (n - (y + 1))"
    using IMP_Minus_space_growth[OF \<open>(c, s1) \<Rightarrow>\<^bsup> x \<^esup> s2\<close> \<open>finite (range s1)\<close>
        \<open>max (Max (range s1)) (max_constant c) < 2 ^ (n - z)\<close>] \<open>1 + x + y = z\<close> \<open>n > z \<close> by auto
  hence "2 ^ (y + 1) * Max (range s2) < 2 ^ n" using move_exponent_to_rhs by blast
  moreover have "2 ^ (y + 1) * max_constant  (WHILE b\<noteq>0 DO c) < 2 ^ n"
    using \<open>1 + x + y = z\<close> \<open>2 ^ z * max (Max (range s1)) (max_constant (WHILE b\<noteq>0 DO c)) < 2 ^ n\<close>
      power_of_two_increase_exponent_le[where ?a="1 + y" and ?b=x]
    by(auto simp: add.commute nat_mult_max_right)
  ultimately have "2 ^ (y + 1) * max (Max (range s2)) (max_constant (WHILE b\<noteq>0 DO c)) < 2 ^ n"
    by simp
  moreover have "finite (range s2)" using finite_range_stays_finite WhileTrue by simp
  ultimately show ?case using Seq \<open>2 ^ x * max (Max (range s1)) (max_constant c) < 2 ^ n\<close>
    apply(simp only: t_small_step_fun_terminate_iff)
    using \<open>s1 b \<noteq> 0\<close> \<open>finite (range s1)\<close> \<open>Max (range s1) < 2 ^ n\<close>
    apply(simp add: exists_non_zero_in_var_bit_list_iff)
    apply(rule seq_terminates_when[where ?t1.0="100 * n * (x - Suc 0) + 50" and
          ?t2.0="100 * n * (y - Suc 0) + 50"])
      using WhileTrue
    using bigstep_progress by(auto simp: algebra_simps)
qed auto

text \<open>The other direction. Observe that we assume that the IMP- program terminates after a limited
      number of steps, that is, we don't show that termination of the IMP- program follows from
      termination of the translated IMP-- program \<close>

lemma IMP_Minus_Minus_To_IMP_Minus_aux:
  assumes "(c :: IMP_Minus_com, s1) \<Rightarrow>\<^bsup>t'\<^esup> s2"
    "t' \<le> t"
    "finite (range s1)"
    "n > t"
    "((2 :: nat) ^ t) * (max (Max (range s1)) (max_constant c)) < 2 ^ n"
    "t_small_step_fun t''
      (IMP_Minus_To_IMP_Minus_Minus c n, IMP_Minus_State_To_IMP_Minus_Minus s1 n)
     = (SKIP, s2')"
  shows
    "s2' = IMP_Minus_State_To_IMP_Minus_Minus s2 n"
proof -
  have "t_small_step_fun (100 * n * (t' - 1) + 50)
      (IMP_Minus_To_IMP_Minus_Minus c n, IMP_Minus_State_To_IMP_Minus_Minus s1 n)
     = (SKIP, IMP_Minus_State_To_IMP_Minus_Minus s2 n)"
    using assms by(fastforce intro: IMP_Minus_To_IMP_Minus_Minus dual_order.strict_trans2)
  thus ?thesis by(metis Pair_inject assms less_imp_le_nat not_less t_small_step_fun_increase_time)
qed

subsection \<open>Variables\<close>

text \<open>We give a few lemmas that specify what variables appear in translated IMP-- programs. \<close>

lemma IMP_Minus_To_IMP_Minus_Minus_variables:
  "n > 0 \<Longrightarrow> set (enumerate_variables (IMP_Minus_To_IMP_Minus_Minus c n)) \<subseteq>
    { var_bit_to_var (w, i) | w i. i < n \<and> w \<in> set (Max_Constant.all_variables c) }
    \<union> { operand_bit_to_var (op, i) | op i. i < n \<and> (op = CHR ''a'' \<or> op = CHR ''b'') }
    \<union> { ''carry'' }"
proof(induction c)
  case SKIP
  then show ?case by(auto simp: enumerate_variables_def)
next
  case (Assign v a)
  thus ?case using assignment_to_binary_variables[where ?n=n and ?v=v and ?a=a] by auto
next
  case (Seq c1 c2)
  then show ?case by(auto simp: set_enumerate_variables_seq)
next
  case (If x1 c1 c2)
  then show ?case by(auto simp: set_enumerate_variables_if var_bit_list_def)
next
  case (While x1 c)
  then show ?case by(auto simp: set_enumerate_variables_while var_bit_list_def)
qed

lemma card_of_set_comprehension_of_set_list: "card { f x |x. x \<in> set l} \<le> length (remdups l)"
proof(induction l)
  case (Cons a l)
  have "{ f x |x. x \<in> set (a # l)} = { f a } \<union> { f x |x. x \<in> set l}" by auto
  thus ?case using Cons apply auto
     apply (metis (mono_tags, lifting) card.infinite card_insert_if finite_insert mem_Collect_eq)
    by (metis (no_types, lifting) Suc_le_mono card.infinite card_insert_disjoint finite_insert
        insert_absorb le_SucI)
qed auto

lemma card_union_le: "card U \<le> a \<Longrightarrow> card W \<le> b \<Longrightarrow> card (U \<union> W) \<le> (a + b)"
  using card_Un_le[where ?A=U and ?B=W] by simp

lemma card_union_le_intro: "card U \<le> a \<Longrightarrow> card W \<le> b \<Longrightarrow> c \<ge> a + b \<Longrightarrow> card (U \<union> W) \<le> c"
  using card_Un_le[where ?A=U and ?B=W] by simp

lemma IMP_Minus_To_IMP_Minus_Minus_variables_length:
  assumes "n > 0"
  shows "length (enumerate_variables (IMP_Minus_To_IMP_Minus_Minus c n)) \<le>
    (n + 1) * (Max_Constant.num_variables c) + 2 * n + 1"
proof -
  have "finite { var_bit_to_var (w, i) | w i. i < n \<and> w \<in> set (Max_Constant.all_variables c) }
    \<and> card { var_bit_to_var (w, i) | w i. i < n \<and> w \<in> set (Max_Constant.all_variables c) }
    \<le> n * (Max_Constant.num_variables c)"
  proof(induction n)
    case (Suc n)
    have "{var_bit_to_var (w, i) |w i. i < Suc n \<and> w \<in> set (Max_Constant.all_variables c)}
      = {var_bit_to_var (w, i) |w i. i < n \<and> w \<in> set (Max_Constant.all_variables c)}
        \<union> { var_bit_to_var (w, n) |w. w \<in> set (Max_Constant.all_variables c) }"
      by auto
    moreover have "card {var_bit_to_var (w, n) |w. w \<in> set (Max_Constant.all_variables c)}
      \<le> num_variables c"
      using card_of_set_comprehension_of_set_list num_variables_def by fastforce
    ultimately show ?case using Suc by (simp add: card_union_le sup_commute)
  qed auto
  moreover have "card {CHR ''?'' # CHR ''$'' # w |w. w \<in> set (Max_Constant.all_variables c)}
    \<le> num_variables c" using card_of_set_comprehension_of_set_list num_variables_def by fastforce
  moreover have "finite {operand_bit_to_var (op, i) |op i. i < n \<and> (op = CHR ''a'' \<or> op = CHR ''b'')}
    \<and> card { operand_bit_to_var (op, i) |op i. i < n \<and> (op = CHR ''a'' \<or> op = CHR ''b'') } \<le> 2 * n"
  proof (induction n)
    case (Suc n)
    have "{operand_bit_to_var (op, i) |op i. i < Suc n \<and> (op = CHR ''a'' \<or> op = CHR ''b'')}
      = { operand_bit_to_var (op, i) |op i. i < n \<and> (op = CHR ''a'' \<or> op = CHR ''b'') }
        \<union> { operand_bit_to_var (CHR ''a'', n), operand_bit_to_var (CHR ''b'', n)}" by auto
    thus ?case using Suc by(auto intro!: card_insert_le_m1)
  qed auto
  ultimately have
    f: "finite ({ var_bit_to_var (w, i) | w i. i < n \<and> w \<in> set (Max_Constant.all_variables c) }
    \<union> { operand_bit_to_var (op, i) | op i. i < n \<and> (op = CHR ''a'' \<or> op = CHR ''b'') }
    \<union> { ''carry'' })" and
    "card ({ var_bit_to_var (w, i) | w i. i < n \<and> w \<in> set (Max_Constant.all_variables c) }
    \<union> { operand_bit_to_var (op, i) | op i. i < n \<and> (op = CHR ''a'' \<or> op = CHR ''b'') }
    \<union> { ''carry'' }) \<le> (n + 1) * (num_variables c) + 2 * n + 1"
    by(auto simp: card_union_le intro!: card_insert_le_m1 card_union_le_intro)
  hence "card (set (enumerate_variables (IMP_Minus_To_IMP_Minus_Minus c n)))
    \<le> (n + 1) * (num_variables c) + 2 * n + 1"
    using card_mono[OF f IMP_Minus_To_IMP_Minus_Minus_variables[OF \<open>n > 0\<close>]] by simp
  thus ?thesis by(simp add:  distinct_card[OF enumerate_variables_distinct])
qed

lemma var_bit_in_IMP_Minus_Minus_variables_then_bit_less_n: "n > 0 \<Longrightarrow> var_bit_to_var (a, b)
           \<in> set (enumerate_variables (IMP_Minus_To_IMP_Minus_Minus c n)) \<Longrightarrow> b < n"
  apply(frule set_mp[OF IMP_Minus_To_IMP_Minus_Minus_variables])
  by auto

lemma var_bit_in_IMP_Minus_Minus_variables: "v \<in> set (Max_Constant.all_variables c)
  \<Longrightarrow> i < n \<Longrightarrow> var_bit_to_var (v, i) \<in>  set (enumerate_variables (IMP_Minus_To_IMP_Minus_Minus c n))"
  apply(induction c)
  by(auto simp: assignment_to_binary_def binary_adder_def set_enumerate_variables_seq
      copy_atom_to_operand_variables adder_def com_list_to_seq_variables full_adder_variables
      binary_subtractor_def subtract_handle_underflow_variables set_enumerate_variables_if
      var_bit_list_def set_enumerate_variables_while binary_parity_variables
      binary_right_shift_def assign_shifted_bits_and_zero_most_significant_def
      assign_shifted_bits_variables
      split: aexp.splits atomExp.splits)

end


theory Discrete_Log imports
  CryptHOL.CryptHOL
  Cyclic_Group_Ext
begin

locale dis_log =
  fixes \<G> :: "'grp cyclic_group" (structure)
  assumes order_gt_0 [simp]: "order \<G> > 0"
begin

type_synonym 'grp' dislog_adv = "'grp' \<Rightarrow> nat spmf"

type_synonym 'grp' dislog_adv' = "'grp' \<Rightarrow> (nat \<times> nat) spmf"

type_synonym 'grp' dislog_adv2 = "'grp' \<times> 'grp' \<Rightarrow> nat spmf"

definition dis_log :: "'grp dislog_adv \<Rightarrow> bool spmf"
where "dis_log \<A> = TRY do {
  x \<leftarrow> sample_uniform (order \<G>);
  let h = \<^bold>g [^] x;
  x'\<leftarrow> \<A> h;
  return_spmf ([x = x'] (mod order \<G>))} ELSE return_spmf False"

definition advantage :: "'grp dislog_adv \<Rightarrow> real"
where "advantage \<A> \<equiv> spmf (dis_log \<A>) True"

lemma lossless_dis_log: "\<lbrakk>0 < order \<G>; \<forall> h. lossless_spmf (\<A> h)\<rbrakk> \<Longrightarrow> lossless_spmf (dis_log \<A>)"
by(auto simp add:  dis_log_def)

end

locale dis_log_alt =
  fixes \<G> :: "'grp cyclic_group" (structure)
    and x :: nat
  assumes order_gt_0 [simp]: "order \<G> > 0"
begin

sublocale dis_log: dis_log \<G>
  unfolding dis_log_def by simp

definition "g' = \<^bold>g [^] x"

definition dis_log2 :: "'grp dis_log.dislog_adv' \<Rightarrow> bool spmf"
where "dis_log2 \<A> = TRY do {
    w \<leftarrow> sample_uniform (order \<G>);
    let h = \<^bold>g [^] w;
    (w1',w2') \<leftarrow> \<A> h;
    return_spmf ([w = (w1' + x * w2')]  (mod (order \<G>)))} ELSE return_spmf False"

definition advantage2 :: "'grp dis_log.dislog_adv' \<Rightarrow> real"
where "advantage2 \<A> \<equiv> spmf (dis_log2 \<A>) True"

definition adversary2 :: "('grp \<Rightarrow> (nat \<times> nat) spmf) \<Rightarrow> 'grp \<Rightarrow> nat spmf"
  where "adversary2 \<A> h = do {
    (w1,w2) \<leftarrow> \<A> h;
    return_spmf (w1 + x * w2)}"

definition dis_log3 :: "'grp dis_log.dislog_adv2 \<Rightarrow> bool spmf"
where "dis_log3 \<A> = TRY do {
    w \<leftarrow> sample_uniform (order \<G>);
    let (h,w) = ((\<^bold>g [^] w, g' [^] w), w);
    w' \<leftarrow> \<A> h;
    return_spmf ([w = w'] (mod (order \<G>)))} ELSE return_spmf False"

definition advantage3 :: "'grp dis_log.dislog_adv2 \<Rightarrow> real"
  where "advantage3 \<A> \<equiv> spmf (dis_log3 \<A>) True"

definition adversary3:: "'grp dis_log.dislog_adv2 \<Rightarrow> 'grp \<Rightarrow> nat spmf"
  where "adversary3 \<A> g = do {
    \<A> (g, g [^] x)}"

end

locale dis_log_alt_reductions = dis_log_alt + cyclic_group \<G>
begin

lemma dis_log_adv3:
  shows "advantage3 \<A> = dis_log.advantage (adversary3 \<A>)"
  unfolding dis_log_alt.advantage3_def
  by(simp add: advantage3_def dis_log.advantage_def adversary3_def dis_log.dis_log_def dis_log3_def Let_def g'_def power_swap)

lemma dis_log_adv2:
  shows  "advantage2 \<A> = dis_log.advantage (adversary2 \<A>)"
  unfolding dis_log_alt.advantage2_def
  by(simp add: advantage2_def dis_log2_def dis_log.advantage_def dis_log.dis_log_def adversary2_def split_def)

end

end


(*
    File:        Infinite.thy
    Time-stamp:  <2016-01-02T14:32:52Z>
    Author:      JRF
    Web:         http://jrf.cocolog-nifty.com/software/2016/01/post.html
    Logic Image: ZF (of Isabelle2015)
*)

theory Infinite imports Finite Cardinal begin

definition Infinite :: "i => o" where
  "Infinite(X) == ALL F: Fin(X). X ~= F"

lemma InfiniteI:
  "[| !! x. [| x: Fin(X); x = X |] ==> False |] ==> Infinite(X)"
apply (unfold Infinite_def)
apply blast
done

lemma InfiniteI2:
  "X ~: Fin(X) ==> Infinite(X)"
apply (unfold Infinite_def)
apply blast
done

lemma Infinite_imp_not_empty:
  "Infinite(X) ==> X ~= 0"
apply (unfold Infinite_def)
apply (drule bspec)
by (rule Fin.intros)

lemma neq_subset_imp_bex_not_mem:
  "[| A ~= B; B <= A |] ==> EX x: A. x ~: B"
apply (rule swap)
apply (erule contrapos)
apply (rule equalityI)
apply (assumption, assumption)
apply (rule subsetI)
apply (rule swap)
apply (rule_tac [2] bexI)
apply assumption+
done

lemma InfiniteD:
  "[| Infinite(X); F: Fin(X) |] ==> EX x: X. x ~: F"
apply (unfold Infinite_def)
(* apply blast *)
apply (drule bspec)
apply assumption
apply (drule FinD)
apply (erule neq_subset_imp_bex_not_mem)
apply assumption
done

lemmas InfiniteE = InfiniteD [THEN bexE]

lemma Infinite_not_Finite_iff: "Infinite(X) <-> ~ Finite(X)"
apply (simp add: Infinite_def Finite_Fin_iff)
apply blast
done

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_09
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun t22 :: "Nat => Nat => Nat" where
  "t22 (Z) y = y"
| "t22 (S z) y = S (t22 z y)"

fun t2 :: "Nat => Nat => Nat" where
  "t2 (Z) y = Z"
| "t2 (S z) (Z) = S z"
| "t2 (S z) (S x2) = t2 z x2"

theorem property0 :
  "((t2 (t2 i j) k) = (t2 i (t22 j k)))"
  oops

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_regexp_SeqAssociative
imports "../../Test_Base"
begin

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

datatype A = X | Y

datatype R
         = Nil | Eps | Atom "A" | Plus "R" "R" | Seq "R" "R" | Star "R"

fun seq :: "R => R => R" where
"seq x y =
   (case x of
      Nil => Nil
      | other =>
          (case y of
             Nil => Nil
             | other =>
                 (case x of
                    Eps => y
                    | other =>
                        (case y of
                           Eps => x
                           | other => Seq x y))))"

fun plus :: "R => R => R" where
"plus x y =
   (case x of
      Nil => y
      | other =>
          (case y of
             Nil => x
             | other => Plus x y))"

fun eqA :: "A => A => bool" where
"eqA (X) (X) = True"
| "eqA (X) (Y) = False"
| "eqA (Y) (X) = False"
| "eqA (Y) (Y) = True"

fun eps :: "R => bool" where
"eps x =
   (case x of
      Eps => True
      | Plus p q => ((eps p) | (eps q))
      | Seq r q2 => ((eps r) & (eps q2))
      | Star y => True
      | other => False)"

fun epsR :: "R => R" where
"epsR x = (if eps x then Eps else Nil)"

fun step :: "R => A => R" where
"step x y =
   (case x of
      Atom a => (if eqA a y then Eps else Nil)
      | Plus p q => plus (step p y) (step q y)
      | Seq r q2 => plus (seq (step r y) q2) (seq (epsR r) (step q2 y))
      | Star p2 => seq (step p2 y) x
      | other => Nil)"

fun recognise :: "R => A list => bool" where
"recognise x (nil2) = eps x"
| "recognise x (cons2 z xs) = recognise (step x z) xs"

theorem property0 :
  "((recognise (Seq p (Seq q r)) s) =
      (recognise (Seq (Seq p q) r) s))"
  oops

end


theory prop_38
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun equal2 :: "Nat => Nat => bool" where
  "equal2 (Z) (Z) = True"
  | "equal2 (Z) (S z) = False"
  | "equal2 (S x2) (Z) = False"
  | "equal2 (S x2) (S y2) = equal2 x2 y2"
  fun count :: "Nat => Nat list => Nat" where
  "count x (Nil2) = Z"
  | "count x (Cons2 z ys) =
       (if equal2 x z then S (count x ys) else count x ys)"
  fun append :: "'a list => 'a list => 'a list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  (*hipster equal2 count append *)
lemma lemma_a [thy_expl]: "equal2 x4 y4 = equal2 y4 x4"
by (hipster_induct_schemes equal2.simps)

lemma lemma_aa [thy_expl]: "equal2 x2 x2 = True"
by (hipster_induct_schemes equal2.simps)

lemma lemma_ab [thy_expl]: "equal2 x2 (S x2) = False"
by (hipster_induct_schemes equal2.simps)

  theorem x0 :
    "(count n (append xs (Cons2 n (Nil2)))) = (S (count n xs))"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


theory Demo5 imports Main begin

subsection{* Propositional logic, introduction rules *}

lemma "A \<longrightarrow> A"
proof (rule impI)
  assume "A"
  show "A" by assumption
qed

text{* \isakeyword{proof} *}

lemma "A \<longrightarrow> A"
proof
  assume A
  show A by assumption
qed

text{* \isakeyword{.} *}

lemma "A \<longrightarrow> A"
proof
  assume "A"
  show "A" .
qed

text{* \isakeyword{by} *}

lemma "A \<longrightarrow> A" by (rule impI)

lemma "A \<longrightarrow> A \<and> A"
proof
  assume "A"
  show "A \<and> A" by (rule conjI)
qed

text{* \isakeyword{..} *}

lemma "A \<longrightarrow> A \<and> A"
proof
  assume "A"
  show "A \<and> A" ..
qed

subsubsection{*Elimination rules*}

lemma "A \<and> B \<longrightarrow> B \<and> A"
proof
  assume AB: "A \<and> B"
  from AB show "B \<and> A"
  proof
    assume "A" "B"
    show "B \<and> A" ..
  qed
qed

end


(*  Title:      CCL/ex/List.thy
    Author:     Martin Coen, Cambridge University Computer Laboratory
    Copyright   1993  University of Cambridge
*)

section \<open>Programs defined over lists\<close>

theory List
imports Nat
begin

definition map :: "[i\<Rightarrow>i,i]\<Rightarrow>i"
  where "map(f,l) == lrec(l, [], \<lambda>x xs g. f(x)$g)"

definition comp :: "[i\<Rightarrow>i,i\<Rightarrow>i]\<Rightarrow>i\<Rightarrow>i"  (infixr "\<circ>" 55)
  where "f \<circ> g == (\<lambda>x. f(g(x)))"

definition append :: "[i,i]\<Rightarrow>i"  (infixr "@" 55)
  where "l @ m == lrec(l, m, \<lambda>x xs g. x$g)"

axiomatization member :: "[i,i]\<Rightarrow>i"  (infixr "mem" 55)  (* FIXME dangling eq *)
  where member_ax: "a mem l == lrec(l, false, \<lambda>h t g. if eq(a,h) then true else g)"

definition filter :: "[i,i]\<Rightarrow>i"
  where "filter(f,l) == lrec(l, [], \<lambda>x xs g. if f`x then x$g else g)"

definition flat :: "i\<Rightarrow>i"
  where "flat(l) == lrec(l, [], \<lambda>h t g. h @ g)"

definition partition :: "[i,i]\<Rightarrow>i" where
  "partition(f,l) == letrec part l a b be lcase(l, <a,b>, \<lambda>x xs.
                            if f`x then part(xs,x$a,b) else part(xs,a,x$b))
                    in part(l,[],[])"

definition insert :: "[i,i,i]\<Rightarrow>i"
  where "insert(f,a,l) == lrec(l, a$[], \<lambda>h t g. if f`a`h then a$h$t else h$g)"

definition isort :: "i\<Rightarrow>i"
  where "isort(f) == lam l. lrec(l, [], \<lambda>h t g. insert(f,h,g))"

definition qsort :: "i\<Rightarrow>i" where
  "qsort(f) == lam l. letrec qsortx l be lcase(l, [], \<lambda>h t.
                                   let p be partition(f`h,t)
                                   in split(p, \<lambda>x y. qsortx(x) @ h$qsortx(y)))
                          in qsortx(l)"

lemmas list_defs = map_def comp_def append_def filter_def flat_def
  insert_def isort_def partition_def qsort_def

lemma listBs [simp]:
  "\<And>f g. (f \<circ> g) = (\<lambda>a. f(g(a)))"
  "\<And>a f g. (f \<circ> g)(a) = f(g(a))"
  "\<And>f. map(f,[]) = []"
  "\<And>f x xs. map(f,x$xs) = f(x)$map(f,xs)"
  "\<And>m. [] @ m = m"
  "\<And>x xs m. x$xs @ m = x$(xs @ m)"
  "\<And>f. filter(f,[]) = []"
  "\<And>f x xs. filter(f,x$xs) = if f`x then x$filter(f,xs) else filter(f,xs)"
  "flat([]) = []"
  "\<And>x xs. flat(x$xs) = x @ flat(xs)"
  "\<And>a f. insert(f,a,[]) = a$[]"
  "\<And>a f xs. insert(f,a,x$xs) = if f`a`x then a$x$xs else x$insert(f,a,xs)"
  by (simp_all add: list_defs)

lemma nmapBnil: "n:Nat \<Longrightarrow> map(f) ^ n ` [] = []"
  apply (erule Nat_ind)
   apply simp_all
  done

lemma nmapBcons: "n:Nat \<Longrightarrow> map(f)^n`(x$xs) = (f^n`x)$(map(f)^n`xs)"
  apply (erule Nat_ind)
   apply simp_all
  done

lemma mapT: "\<lbrakk>\<And>x. x:A \<Longrightarrow> f(x):B; l : List(A)\<rbrakk> \<Longrightarrow> map(f,l) : List(B)"
  apply (unfold map_def)
  apply typechk
  apply blast
  done

lemma appendT: "\<lbrakk>l : List(A); m : List(A)\<rbrakk> \<Longrightarrow> l @ m : List(A)"
  apply (unfold append_def)
  apply typechk
  done

lemma appendTS:
  "\<lbrakk>l : {l:List(A). m : {m:List(A).P(l @ m)}}\<rbrakk> \<Longrightarrow> l @ m : {x:List(A). P(x)}"
  by (blast intro!: appendT)

lemma filterT: "\<lbrakk>f:A->Bool; l : List(A)\<rbrakk> \<Longrightarrow> filter(f,l) : List(A)"
  apply (unfold filter_def)
  apply typechk
  done

lemma flatT: "l : List(List(A)) \<Longrightarrow> flat(l) : List(A)"
  apply (unfold flat_def)
  apply (typechk appendT)
  done

lemma insertT: "\<lbrakk>f : A->A->Bool; a:A; l : List(A)\<rbrakk> \<Longrightarrow> insert(f,a,l) : List(A)"
  apply (unfold insert_def)
  apply typechk
  done

lemma insertTS:
  "\<lbrakk>f : {f:A->A->Bool. a : {a:A. l : {l:List(A).P(insert(f,a,l))}}} \<rbrakk> \<Longrightarrow>
   insert(f,a,l)  : {x:List(A). P(x)}"
  by (blast intro!: insertT)

lemma partitionT: "\<lbrakk>f:A->Bool; l : List(A)\<rbrakk> \<Longrightarrow> partition(f,l) : List(A)*List(A)"
  apply (unfold partition_def)
  apply typechk
  apply clean_ccs
  apply (rule ListPRI [THEN wfstI, THEN ListPR_wf [THEN wmap_wf, THEN wfI]])
    apply assumption+
  apply (rule ListPRI [THEN wfstI, THEN ListPR_wf [THEN wmap_wf, THEN wfI]])
   apply assumption+
  done

end