(* Author: Peter Lammich
           Tobias Nipkow (tuning)
*)

section \<open>Binomial Heap\<close>

theory Binomial_Heap
imports
  "HOL-Library.Pattern_Aliases"
  Complex_Main
  Priority_Queue_Specs
begin

text \<open>
  We formalize the binomial heap presentation from Okasaki's book.
  We show the functional correctness and complexity of all operations.

  The presentation is engineered for simplicity, and most
  proofs are straightforward and automatic.
\<close>

subsection \<open>Binomial Tree and Heap Datatype\<close>

datatype 'a tree = Node (rank: nat) (root: 'a) (children: "'a tree list")

type_synonym 'a trees = "'a tree list"

subsubsection \<open>Multiset of elements\<close>

fun mset_tree :: "'a::linorder tree \<Rightarrow> 'a multiset" where
  "mset_tree (Node _ a ts) = {#a#} + (\<Sum>t\<in>#mset ts. mset_tree t)"

definition mset_trees :: "'a::linorder trees \<Rightarrow> 'a multiset" where
  "mset_trees ts = (\<Sum>t\<in>#mset ts. mset_tree t)"

lemma mset_tree_simp_alt[simp]:
  "mset_tree (Node r a ts) = {#a#} + mset_trees ts"
  unfolding mset_trees_def by auto
declare mset_tree.simps[simp del]

lemma mset_tree_nonempty[simp]: "mset_tree t \<noteq> {#}"
by (cases t) auto

lemma mset_trees_Nil[simp]:
  "mset_trees [] = {#}"
by (auto simp: mset_trees_def)

lemma mset_trees_Cons[simp]: "mset_trees (t#ts) = mset_tree t + mset_trees ts"
by (auto simp: mset_trees_def)

lemma mset_trees_empty_iff[simp]: "mset_trees ts = {#} \<longleftrightarrow> ts=[]"
by (auto simp: mset_trees_def)

lemma root_in_mset[simp]: "root t \<in># mset_tree t"
by (cases t) auto

lemma mset_trees_rev_eq[simp]: "mset_trees (rev ts) = mset_trees ts"
by (auto simp: mset_trees_def)

subsubsection \<open>Invariants\<close>

text \<open>Binomial tree\<close>
fun btree :: "'a::linorder tree \<Rightarrow> bool" where
"btree (Node r x ts) \<longleftrightarrow>
   (\<forall>t\<in>set ts. btree t) \<and> map rank ts = rev [0..<r]"

text \<open>Heap invariant\<close>
fun heap :: "'a::linorder tree \<Rightarrow> bool" where
"heap (Node _ x ts) \<longleftrightarrow> (\<forall>t\<in>set ts. heap t \<and> x \<le> root t)"

definition "bheap t \<longleftrightarrow> btree t \<and> heap t"

text \<open>Binomial Heap invariant\<close>
definition "invar ts \<longleftrightarrow> (\<forall>t\<in>set ts. bheap t) \<and> (sorted_wrt (<) (map rank ts))"

text \<open>The children of a node are a valid heap\<close>
lemma invar_children:
  "bheap (Node r v ts) \<Longrightarrow> invar (rev ts)"
  by (auto simp: bheap_def invar_def rev_map[symmetric])

subsection \<open>Operations and Their Functional Correctness\<close>

subsubsection \<open>\<open>link\<close>\<close>

context
includes pattern_aliases
begin

fun link :: "('a::linorder) tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
  "link (Node r x\<^sub>1 ts\<^sub>1 =: t\<^sub>1) (Node r' x\<^sub>2 ts\<^sub>2 =: t\<^sub>2) =
    (if x\<^sub>1\<le>x\<^sub>2 then Node (r+1) x\<^sub>1 (t\<^sub>2#ts\<^sub>1) else Node (r+1) x\<^sub>2 (t\<^sub>1#ts\<^sub>2))"

end

lemma invar_link:
  assumes "bheap t\<^sub>1"
  assumes "bheap t\<^sub>2"
  assumes "rank t\<^sub>1 = rank t\<^sub>2"
  shows "bheap (link t\<^sub>1 t\<^sub>2)"
using assms unfolding bheap_def
by (cases "(t\<^sub>1, t\<^sub>2)" rule: link.cases) auto

lemma rank_link[simp]: "rank (link t\<^sub>1 t\<^sub>2) = rank t\<^sub>1 + 1"
by (cases "(t\<^sub>1, t\<^sub>2)" rule: link.cases) simp

lemma mset_link[simp]: "mset_tree (link t\<^sub>1 t\<^sub>2) = mset_tree t\<^sub>1 + mset_tree t\<^sub>2"
by (cases "(t\<^sub>1, t\<^sub>2)" rule: link.cases) simp

subsubsection \<open>\<open>ins_tree\<close>\<close>

fun ins_tree :: "'a::linorder tree \<Rightarrow> 'a trees \<Rightarrow> 'a trees" where
  "ins_tree t [] = [t]"
| "ins_tree t\<^sub>1 (t\<^sub>2#ts) =
  (if rank t\<^sub>1 < rank t\<^sub>2 then t\<^sub>1#t\<^sub>2#ts else ins_tree (link t\<^sub>1 t\<^sub>2) ts)"

lemma bheap0[simp]: "bheap (Node 0 x [])"
unfolding bheap_def by auto

lemma invar_Cons[simp]:
  "invar (t#ts)
  \<longleftrightarrow> bheap t \<and> invar ts \<and> (\<forall>t'\<in>set ts. rank t < rank t')"
by (auto simp: invar_def)

lemma invar_ins_tree:
  assumes "bheap t"
  assumes "invar ts"
  assumes "\<forall>t'\<in>set ts. rank t \<le> rank t'"
  shows "invar (ins_tree t ts)"
using assms
by (induction t ts rule: ins_tree.induct) (auto simp: invar_link less_eq_Suc_le[symmetric])

lemma mset_trees_ins_tree[simp]:
  "mset_trees (ins_tree t ts) = mset_tree t + mset_trees ts"
by (induction t ts rule: ins_tree.induct) auto

lemma ins_tree_rank_bound:
  assumes "t' \<in> set (ins_tree t ts)"
  assumes "\<forall>t'\<in>set ts. rank t\<^sub>0 < rank t'"
  assumes "rank t\<^sub>0 < rank t"
  shows "rank t\<^sub>0 < rank t'"
using assms
by (induction t ts rule: ins_tree.induct) (auto split: if_splits)

subsubsection \<open>\<open>insert\<close>\<close>

hide_const (open) insert

definition insert :: "'a::linorder \<Rightarrow> 'a trees \<Rightarrow> 'a trees" where
"insert x ts = ins_tree (Node 0 x []) ts"

lemma invar_insert[simp]: "invar t \<Longrightarrow> invar (insert x t)"
by (auto intro!: invar_ins_tree simp: insert_def)

lemma mset_trees_insert[simp]: "mset_trees (insert x t) = {#x#} + mset_trees t"
by(auto simp: insert_def)

subsubsection \<open>\<open>merge\<close>\<close>

context
includes pattern_aliases
begin

fun merge :: "'a::linorder trees \<Rightarrow> 'a trees \<Rightarrow> 'a trees" where
  "merge ts\<^sub>1 [] = ts\<^sub>1"
| "merge [] ts\<^sub>2 = ts\<^sub>2"
| "merge (t\<^sub>1#ts\<^sub>1 =: h\<^sub>1) (t\<^sub>2#ts\<^sub>2 =: h\<^sub>2) = (
    if rank t\<^sub>1 < rank t\<^sub>2 then t\<^sub>1 # merge ts\<^sub>1 h\<^sub>2 else
    if rank t\<^sub>2 < rank t\<^sub>1 then t\<^sub>2 # merge h\<^sub>1 ts\<^sub>2
    else ins_tree (link t\<^sub>1 t\<^sub>2) (merge ts\<^sub>1 ts\<^sub>2)
  )"

end

lemma merge_simp2[simp]: "merge [] ts\<^sub>2 = ts\<^sub>2"
by (cases ts\<^sub>2) auto

lemma merge_rank_bound:
  assumes "t' \<in> set (merge ts\<^sub>1 ts\<^sub>2)"
  assumes "\<forall>t\<^sub>1\<in>set ts\<^sub>1. rank t < rank t\<^sub>1"
  assumes "\<forall>t\<^sub>2\<in>set ts\<^sub>2. rank t < rank t\<^sub>2"
  shows "rank t < rank t'"
using assms
by (induction ts\<^sub>1 ts\<^sub>2 arbitrary: t' rule: merge.induct)
   (auto split: if_splits simp: ins_tree_rank_bound)

lemma invar_merge[simp]:
  assumes "invar ts\<^sub>1"
  assumes "invar ts\<^sub>2"
  shows "invar (merge ts\<^sub>1 ts\<^sub>2)"
using assms
by (induction ts\<^sub>1 ts\<^sub>2 rule: merge.induct)
   (auto 0 3 simp: Suc_le_eq intro!: invar_ins_tree invar_link elim!: merge_rank_bound)

text \<open>Longer, more explicit proof of @{thm [source] invar_merge},
      to illustrate the application of the @{thm [source] merge_rank_bound} lemma.\<close>
lemma
  assumes "invar ts\<^sub>1"
  assumes "invar ts\<^sub>2"
  shows "invar (merge ts\<^sub>1 ts\<^sub>2)"
  using assms
proof (induction ts\<^sub>1 ts\<^sub>2 rule: merge.induct)
  case (3 t\<^sub>1 ts\<^sub>1 t\<^sub>2 ts\<^sub>2)
  \<comment> \<open>Invariants of the parts can be shown automatically\<close>
  from "3.prems" have [simp]:
    "bheap t\<^sub>1" "bheap t\<^sub>2"
    (*"invar (merge (t\<^sub>1#ts\<^sub>1) ts\<^sub>2)"
    "invar (merge ts\<^sub>1 (t\<^sub>2#ts\<^sub>2))"
    "invar (merge ts\<^sub>1 ts\<^sub>2)"*)
    by auto

  \<comment> \<open>These are the three cases of the @{const merge} function\<close>
  consider (LT) "rank t\<^sub>1 < rank t\<^sub>2"
         | (GT) "rank t\<^sub>1 > rank t\<^sub>2"
         | (EQ) "rank t\<^sub>1 = rank t\<^sub>2"
    using antisym_conv3 by blast
  then show ?case proof cases
    case LT
    \<comment> \<open>@{const merge} takes the first tree from the left heap\<close>
    then have "merge (t\<^sub>1 # ts\<^sub>1) (t\<^sub>2 # ts\<^sub>2) = t\<^sub>1 # merge ts\<^sub>1 (t\<^sub>2 # ts\<^sub>2)" by simp
    also have "invar \<dots>" proof (simp, intro conjI)
      \<comment> \<open>Invariant follows from induction hypothesis\<close>
      show "invar (merge ts\<^sub>1 (t\<^sub>2 # ts\<^sub>2))"
        using LT "3.IH" "3.prems" by simp

      \<comment> \<open>It remains to show that \<open>t\<^sub>1\<close> has smallest rank.\<close>
      show "\<forall>t'\<in>set (merge ts\<^sub>1 (t\<^sub>2 # ts\<^sub>2)). rank t\<^sub>1 < rank t'"
        \<comment> \<open>Which is done by auxiliary lemma @{thm [source] merge_rank_bound}\<close>
        using LT "3.prems" by (force elim!: merge_rank_bound)
    qed
    finally show ?thesis .
  next
    \<comment> \<open>@{const merge} takes the first tree from the right heap\<close>
    case GT
    \<comment> \<open>The proof is anaologous to the \<open>LT\<close> case\<close>
    then show ?thesis using "3.prems" "3.IH" by (force elim!: merge_rank_bound)
  next
    case [simp]: EQ
    \<comment> \<open>@{const merge} links both first trees, and inserts them into the merged remaining heaps\<close>
    have "merge (t\<^sub>1 # ts\<^sub>1) (t\<^sub>2 # ts\<^sub>2) = ins_tree (link t\<^sub>1 t\<^sub>2) (merge ts\<^sub>1 ts\<^sub>2)" by simp
    also have "invar \<dots>" proof (intro invar_ins_tree invar_link)
      \<comment> \<open>Invariant of merged remaining heaps follows by IH\<close>
      show "invar (merge ts\<^sub>1 ts\<^sub>2)"
        using EQ "3.prems" "3.IH" by auto

      \<comment> \<open>For insertion, we have to show that the rank of the linked tree is \<open>\<le>\<close> the
          ranks in the merged remaining heaps\<close>
      show "\<forall>t'\<in>set (merge ts\<^sub>1 ts\<^sub>2). rank (link t\<^sub>1 t\<^sub>2) \<le> rank t'"
      proof -
        \<comment> \<open>Which is, again, done with the help of @{thm [source] merge_rank_bound}\<close>
        have "rank (link t\<^sub>1 t\<^sub>2) = Suc (rank t\<^sub>2)" by simp
        thus ?thesis using "3.prems" by (auto simp: Suc_le_eq elim!: merge_rank_bound)
      qed
    qed simp_all
    finally show ?thesis .
  qed
qed auto

lemma mset_trees_merge[simp]:
  "mset_trees (merge ts\<^sub>1 ts\<^sub>2) = mset_trees ts\<^sub>1 + mset_trees ts\<^sub>2"
by (induction ts\<^sub>1 ts\<^sub>2 rule: merge.induct) auto

subsubsection \<open>\<open>get_min\<close>\<close>

fun get_min :: "'a::linorder trees \<Rightarrow> 'a" where
  "get_min [t] = root t"
| "get_min (t#ts) = min (root t) (get_min ts)"

lemma bheap_root_min:
  assumes "bheap t"
  assumes "x \<in># mset_tree t"
  shows "root t \<le> x"
using assms unfolding bheap_def
by (induction t arbitrary: x rule: mset_tree.induct) (fastforce simp: mset_trees_def)

lemma get_min_mset:
  assumes "ts\<noteq>[]"
  assumes "invar ts"
  assumes "x \<in># mset_trees ts"
  shows "get_min ts \<le> x"
  using assms
apply (induction ts arbitrary: x rule: get_min.induct)
apply (auto
      simp: bheap_root_min min_def intro: order_trans;
      meson linear order_trans bheap_root_min
      )+
done

lemma get_min_member:
  "ts\<noteq>[] \<Longrightarrow> get_min ts \<in># mset_trees ts"
by (induction ts rule: get_min.induct) (auto simp: min_def)

lemma get_min:
  assumes "mset_trees ts \<noteq> {#}"
  assumes "invar ts"
  shows "get_min ts = Min_mset (mset_trees ts)"
using assms get_min_member get_min_mset
by (auto simp: eq_Min_iff)

subsubsection \<open>\<open>get_min_rest\<close>\<close>

fun get_min_rest :: "'a::linorder trees \<Rightarrow> 'a tree \<times> 'a trees" where
  "get_min_rest [t] = (t,[])"
| "get_min_rest (t#ts) = (let (t',ts') = get_min_rest ts
                     in if root t \<le> root t' then (t,ts) else (t',t#ts'))"

lemma get_min_rest_get_min_same_root:
  assumes "ts\<noteq>[]"
  assumes "get_min_rest ts = (t',ts')"
  shows "root t' = get_min ts"
using assms
by (induction ts arbitrary: t' ts' rule: get_min.induct) (auto simp: min_def split: prod.splits)

lemma mset_get_min_rest:
  assumes "get_min_rest ts = (t',ts')"
  assumes "ts\<noteq>[]"
  shows "mset ts = {#t'#} + mset ts'"
using assms
by (induction ts arbitrary: t' ts' rule: get_min.induct) (auto split: prod.splits if_splits)

lemma set_get_min_rest:
  assumes "get_min_rest ts = (t', ts')"
  assumes "ts\<noteq>[]"
  shows "set ts = Set.insert t' (set ts')"
using mset_get_min_rest[OF assms, THEN arg_cong[where f=set_mset]]
by auto

lemma invar_get_min_rest:
  assumes "get_min_rest ts = (t',ts')"
  assumes "ts\<noteq>[]"
  assumes "invar ts"
  shows "bheap t'" and "invar ts'"
proof -
  have "bheap t' \<and> invar ts'"
    using assms
    proof (induction ts arbitrary: t' ts' rule: get_min.induct)
      case (2 t v va)
      then show ?case
        apply (clarsimp split: prod.splits if_splits)
        apply (drule set_get_min_rest; fastforce)
        done
    qed auto
  thus "bheap t'" and "invar ts'" by auto
qed

subsubsection \<open>\<open>del_min\<close>\<close>

definition del_min :: "'a::linorder trees \<Rightarrow> 'a::linorder trees" where
"del_min ts = (case get_min_rest ts of
   (Node r x ts\<^sub>1, ts\<^sub>2) \<Rightarrow> merge (rev ts\<^sub>1) ts\<^sub>2)"

lemma invar_del_min[simp]:
  assumes "ts \<noteq> []"
  assumes "invar ts"
  shows "invar (del_min ts)"
using assms
unfolding del_min_def
by (auto
      split: prod.split tree.split
      intro!: invar_merge invar_children
      dest: invar_get_min_rest
    )

lemma mset_trees_del_min:
  assumes "ts \<noteq> []"
  shows "mset_trees ts = mset_trees (del_min ts) + {# get_min ts #}"
using assms
unfolding del_min_def
apply (clarsimp split: tree.split prod.split)
apply (frule (1) get_min_rest_get_min_same_root)
apply (frule (1) mset_get_min_rest)
apply (auto simp: mset_trees_def)
done

subsubsection \<open>Instantiating the Priority Queue Locale\<close>

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

interpretation bheaps: Priority_Queue_Merge
  where empty = "[]" and is_empty = "(=) []" and insert = insert
  and get_min = get_min and del_min = del_min and merge = merge
  and invar = invar and mset = mset_trees
proof (unfold_locales, goal_cases)
  case 1 thus ?case by simp
next
  case 2 thus ?case by auto
next
  case 3 thus ?case by auto
next
  case (4 q)
  thus ?case using mset_trees_del_min[of q] get_min[OF _ \<open>invar q\<close>]
    by (auto simp: union_single_eq_diff)
next
  case (5 q) thus ?case using get_min[of q] by auto
next
  case 6 thus ?case by (auto simp add: invar_def)
next
  case 7 thus ?case by simp
next
  case 8 thus ?case by simp
next
  case 9 thus ?case by simp
next
  case 10 thus ?case by simp
qed

subsection \<open>Complexity\<close>

text \<open>The size of a binomial tree is determined by its rank\<close>
lemma size_mset_btree:
  assumes "btree t"
  shows "size (mset_tree t) = 2^rank t"
  using assms
proof (induction t)
  case (Node r v ts)
  hence IH: "size (mset_tree t) = 2^rank t" if "t \<in> set ts" for t
    using that by auto

  from Node have COMPL: "map rank ts = rev [0..<r]" by auto

  have "size (mset_trees ts) = (\<Sum>t\<leftarrow>ts. size (mset_tree t))"
    by (induction ts) auto
  also have "\<dots> = (\<Sum>t\<leftarrow>ts. 2^rank t)" using IH
    by (auto cong: map_cong)
  also have "\<dots> = (\<Sum>r\<leftarrow>map rank ts. 2^r)"
    by (induction ts) auto
  also have "\<dots> = (\<Sum>i\<in>{0..<r}. 2^i)"
    unfolding COMPL
    by (auto simp: rev_map[symmetric] interv_sum_list_conv_sum_set_nat)
  also have "\<dots> = 2^r - 1"
    by (induction r) auto
  finally show ?case
    by (simp)
qed

lemma size_mset_tree:
  assumes "bheap t"
  shows "size (mset_tree t) = 2^rank t"
using assms unfolding bheap_def
by (simp add: size_mset_btree)

text \<open>The length of a binomial heap is bounded by the number of its elements\<close>
lemma size_mset_trees:
  assumes "invar ts"
  shows "length ts \<le> log 2 (size (mset_trees ts) + 1)"
proof -
  from \<open>invar ts\<close> have
    ASC: "sorted_wrt (<) (map rank ts)" and
    TINV: "\<forall>t\<in>set ts. bheap t"
    unfolding invar_def by auto

  have "(2::nat)^length ts = (\<Sum>i\<in>{0..<length ts}. 2^i) + 1"
    by (simp add: sum_power2)
  also have "\<dots> = (\<Sum>i\<leftarrow>[0..<length ts]. 2^i) + 1" (is "_ = ?S + 1")
    by (simp add: interv_sum_list_conv_sum_set_nat)
  also have "?S \<le> (\<Sum>t\<leftarrow>ts. 2^rank t)" (is "_ \<le> ?T")
    using sorted_wrt_less_idx[OF ASC] by(simp add: sum_list_mono2)
  also have "?T + 1 \<le> (\<Sum>t\<leftarrow>ts. size (mset_tree t)) + 1" using TINV
    by (auto cong: map_cong simp: size_mset_tree)
  also have "\<dots> = size (mset_trees ts) + 1"
    unfolding mset_trees_def by (induction ts) auto
  finally have "2^length ts \<le> size (mset_trees ts) + 1" by simp
  then show ?thesis using le_log2_of_power by blast
qed

subsubsection \<open>Timing Functions\<close>

text \<open>
  We define timing functions for each operation, and provide
  estimations of their complexity.
\<close>
definition T_link :: "'a::linorder tree \<Rightarrow> 'a tree \<Rightarrow> nat" where
[simp]: "T_link _ _ = 1"

text \<open>This function is non-canonical: we omitted a \<open>+1\<close> in the \<open>else\<close>-part,
  to keep the following analysis simpler and more to the point.
\<close>
fun T_ins_tree :: "'a::linorder tree \<Rightarrow> 'a trees \<Rightarrow> nat" where
  "T_ins_tree t [] = 1"
| "T_ins_tree t\<^sub>1 (t\<^sub>2 # ts) = (
    (if rank t\<^sub>1 < rank t\<^sub>2 then 1
     else T_link t\<^sub>1 t\<^sub>2 + T_ins_tree (link t\<^sub>1 t\<^sub>2) ts)
  )"

definition T_insert :: "'a::linorder \<Rightarrow> 'a trees \<Rightarrow> nat" where
"T_insert x ts = T_ins_tree (Node 0 x []) ts + 1"

lemma T_ins_tree_simple_bound: "T_ins_tree t ts \<le> length ts + 1"
by (induction t ts rule: T_ins_tree.induct) auto

subsubsection \<open>\<open>T_insert\<close>\<close>

lemma T_insert_bound:
  assumes "invar ts"
  shows "T_insert x ts \<le> log 2 (size (mset_trees ts) + 1) + 2"
proof -
  have "real (T_insert x ts) \<le> real (length ts) + 2"
    unfolding T_insert_def using T_ins_tree_simple_bound
    using of_nat_mono by fastforce
  also note size_mset_trees[OF \<open>invar ts\<close>]
  finally show ?thesis by simp
qed

subsubsection \<open>\<open>T_merge\<close>\<close>

context
includes pattern_aliases
begin

fun T_merge :: "'a::linorder trees \<Rightarrow> 'a trees \<Rightarrow> nat" where
  "T_merge ts\<^sub>1 [] = 1"
| "T_merge [] ts\<^sub>2 = 1"
| "T_merge (t\<^sub>1#ts\<^sub>1 =: h\<^sub>1) (t\<^sub>2#ts\<^sub>2 =: h\<^sub>2) = 1 + (
    if rank t\<^sub>1 < rank t\<^sub>2 then T_merge ts\<^sub>1 h\<^sub>2
    else if rank t\<^sub>2 < rank t\<^sub>1 then T_merge h\<^sub>1 ts\<^sub>2
    else T_ins_tree (link t\<^sub>1 t\<^sub>2) (merge ts\<^sub>1 ts\<^sub>2) + T_merge ts\<^sub>1 ts\<^sub>2
  )"

end

text \<open>A crucial idea is to estimate the time in correlation with the
  result length, as each carry reduces the length of the result.\<close>

lemma T_ins_tree_length:
  "T_ins_tree t ts + length (ins_tree t ts) = 2 + length ts"
by (induction t ts rule: ins_tree.induct) auto

lemma T_merge_length:
  "T_merge ts\<^sub>1 ts\<^sub>2 + length (merge ts\<^sub>1 ts\<^sub>2) \<le> 2 * (length ts\<^sub>1 + length ts\<^sub>2) + 1"
by (induction ts\<^sub>1 ts\<^sub>2 rule: T_merge.induct)
   (auto simp: T_ins_tree_length algebra_simps)

text \<open>Finally, we get the desired logarithmic bound\<close>
lemma T_merge_bound:
  fixes ts\<^sub>1 ts\<^sub>2
  defines "n\<^sub>1 \<equiv> size (mset_trees ts\<^sub>1)"
  defines "n\<^sub>2 \<equiv> size (mset_trees ts\<^sub>2)"
  assumes "invar ts\<^sub>1" "invar ts\<^sub>2"
  shows "T_merge ts\<^sub>1 ts\<^sub>2 \<le> 4*log 2 (n\<^sub>1 + n\<^sub>2 + 1) + 1"
proof -
  note n_defs = assms(1,2)

  have "T_merge ts\<^sub>1 ts\<^sub>2 \<le> 2 * real (length ts\<^sub>1) + 2 * real (length ts\<^sub>2) + 1"
    using T_merge_length[of ts\<^sub>1 ts\<^sub>2] by simp
  also note size_mset_trees[OF \<open>invar ts\<^sub>1\<close>]
  also note size_mset_trees[OF \<open>invar ts\<^sub>2\<close>]
  finally have "T_merge ts\<^sub>1 ts\<^sub>2 \<le> 2 * log 2 (n\<^sub>1 + 1) + 2 * log 2 (n\<^sub>2 + 1) + 1"
    unfolding n_defs by (simp add: algebra_simps)
  also have "log 2 (n\<^sub>1 + 1) \<le> log 2 (n\<^sub>1 + n\<^sub>2 + 1)"
    unfolding n_defs by (simp add: algebra_simps)
  also have "log 2 (n\<^sub>2 + 1) \<le> log 2 (n\<^sub>1 + n\<^sub>2 + 1)"
    unfolding n_defs by (simp add: algebra_simps)
  finally show ?thesis by (simp add: algebra_simps)
qed

subsubsection \<open>\<open>T_get_min\<close>\<close>

fun T_get_min :: "'a::linorder trees \<Rightarrow> nat" where
  "T_get_min [t] = 1"
| "T_get_min (t#ts) = 1 + T_get_min ts"

lemma T_get_min_estimate: "ts\<noteq>[] \<Longrightarrow> T_get_min ts = length ts"
by (induction ts rule: T_get_min.induct) auto

lemma T_get_min_bound:
  assumes "invar ts"
  assumes "ts\<noteq>[]"
  shows "T_get_min ts \<le> log 2 (size (mset_trees ts) + 1)"
proof -
  have 1: "T_get_min ts = length ts" using assms T_get_min_estimate by auto
  also note size_mset_trees[OF \<open>invar ts\<close>]
  finally show ?thesis .
qed

subsubsection \<open>\<open>T_del_min\<close>\<close>

fun T_get_min_rest :: "'a::linorder trees \<Rightarrow> nat" where
  "T_get_min_rest [t] = 1"
| "T_get_min_rest (t#ts) = 1 + T_get_min_rest ts"

lemma T_get_min_rest_estimate: "ts\<noteq>[] \<Longrightarrow> T_get_min_rest ts = length ts"
  by (induction ts rule: T_get_min_rest.induct) auto

lemma T_get_min_rest_bound:
  assumes "invar ts"
  assumes "ts\<noteq>[]"
  shows "T_get_min_rest ts \<le> log 2 (size (mset_trees ts) + 1)"
proof -
  have 1: "T_get_min_rest ts = length ts" using assms T_get_min_rest_estimate by auto
  also note size_mset_trees[OF \<open>invar ts\<close>]
  finally show ?thesis .
qed

text\<open>Note that although the definition of function \<^const>\<open>rev\<close> has quadratic complexity,
it can and is implemented (via suitable code lemmas) as a linear time function.
Thus the following definition is justified:\<close>

definition "T_rev xs = length xs + 1"

definition T_del_min :: "'a::linorder trees \<Rightarrow> nat" where
  "T_del_min ts = T_get_min_rest ts + (case get_min_rest ts of (Node _ x ts\<^sub>1, ts\<^sub>2)
                    \<Rightarrow> T_rev ts\<^sub>1 + T_merge (rev ts\<^sub>1) ts\<^sub>2
  ) + 1"

lemma T_del_min_bound:
  fixes ts
  defines "n \<equiv> size (mset_trees ts)"
  assumes "invar ts" and "ts\<noteq>[]"
  shows "T_del_min ts \<le> 6 * log 2 (n+1) + 3"
proof -
  obtain r x ts\<^sub>1 ts\<^sub>2 where GM: "get_min_rest ts = (Node r x ts\<^sub>1, ts\<^sub>2)"
    by (metis surj_pair tree.exhaust_sel)

  have I1: "invar (rev ts\<^sub>1)" and I2: "invar ts\<^sub>2"
    using invar_get_min_rest[OF GM \<open>ts\<noteq>[]\<close> \<open>invar ts\<close>] invar_children
    by auto

  define n\<^sub>1 where "n\<^sub>1 = size (mset_trees ts\<^sub>1)"
  define n\<^sub>2 where "n\<^sub>2 = size (mset_trees ts\<^sub>2)"

  have "n\<^sub>1 \<le> n" "n\<^sub>1 + n\<^sub>2 \<le> n" unfolding n_def n\<^sub>1_def n\<^sub>2_def
    using mset_get_min_rest[OF GM \<open>ts\<noteq>[]\<close>]
    by (auto simp: mset_trees_def)

  have "T_del_min ts = real (T_get_min_rest ts) + real (T_rev ts\<^sub>1) + real (T_merge (rev ts\<^sub>1) ts\<^sub>2) + 1"
    unfolding T_del_min_def GM
    by simp
  also have "T_get_min_rest ts \<le> log 2 (n+1)"
    using T_get_min_rest_bound[OF \<open>invar ts\<close> \<open>ts\<noteq>[]\<close>] unfolding n_def by simp
  also have "T_rev ts\<^sub>1 \<le> 1 + log 2 (n\<^sub>1 + 1)"
    unfolding T_rev_def n\<^sub>1_def using size_mset_trees[OF I1] by simp
  also have "T_merge (rev ts\<^sub>1) ts\<^sub>2 \<le> 4*log 2 (n\<^sub>1 + n\<^sub>2 + 1) + 1"
    unfolding n\<^sub>1_def n\<^sub>2_def using T_merge_bound[OF I1 I2] by (simp add: algebra_simps)
  finally have "T_del_min ts \<le> log 2 (n+1) + log 2 (n\<^sub>1 + 1) + 4*log 2 (real (n\<^sub>1 + n\<^sub>2) + 1) + 3"
    by (simp add: algebra_simps)
  also note \<open>n\<^sub>1 + n\<^sub>2 \<le> n\<close>
  also note \<open>n\<^sub>1 \<le> n\<close>
  finally show ?thesis by (simp add: algebra_simps)
qed

end


section \<open>Rules, and the chains we can make with them\<close>
text \<open>This describes graph rules, and the reasoning is fully on graphs here (no semantics).
      The formalisation builds up to Lemma 4 in the paper.\<close>
theory RulesAndChains
imports LabeledGraphs
begin

type_synonym ('l,'v) graph_seq = "(nat \<Rightarrow> ('l, 'v) labeled_graph)"

text \<open>Definition 8.\<close>
definition chain :: "('l, 'v) graph_seq \<Rightarrow> bool" where
  "chain S \<equiv> \<forall> i. subgraph (S i) (S (i + 1))"

lemma chain_then_restrict:
  assumes "chain S" shows "S i = restrict (S i)"
  using assms[unfolded chain_def graph_homomorphism_def] by auto

lemma chain:
  assumes "chain S"
  shows "j \<ge> i \<Longrightarrow> subgraph (S i) (S j)"
proof(induct "j-i" arbitrary:i j)
  case 0
  then show ?case using chain_then_restrict[OF assms] assms[unfolded chain_def] by auto
next
  case (Suc x)
  hence j:"i + x + 1 = j" by auto
  thus ?case
    using subgraph_trans[OF Suc(1) assms[unfolded chain_def,rule_format,of "i+x"],of i,unfolded j]
    using Suc by auto
qed

lemma chain_def2:
  "chain S = (\<forall> i j. j \<ge> i \<longrightarrow> subgraph (S i) (S j))"
proof
  show "chain S \<Longrightarrow> \<forall>i j. i \<le> j \<longrightarrow> subgraph (S i) (S j)" using chain by auto
  show "\<forall>i j. i \<le> j \<longrightarrow> subgraph (S i) (S j) \<Longrightarrow> chain S" unfolding chain_def by simp
qed

text \<open>Second part of definition 8.\<close>
definition chain_sup :: "('l, 'v) graph_seq \<Rightarrow> ('l, 'v) labeled_graph" where
  "chain_sup S \<equiv> LG (\<Union> i. edges (S i)) (\<Union> i. vertices (S i))"

lemma chain_sup_const[simp]:
  "chain_sup (\<lambda> x. S) = S"
  unfolding chain_sup_def by auto

lemma chain_sup_subgraph[intro]:
  assumes "chain S"
  shows "subgraph (S j) (chain_sup S)"
proof -
  have c1: "S j = restrict (S j)" for j
    using assms[unfolded chain_def,rule_format,of j] graph_homomorphism_def by auto
  hence c2: "chain_sup S = restrict (chain_sup S)"
    unfolding chain_sup_def by fastforce
  have c3: "graph_union (S j) (chain_sup S) = chain_sup S"
    unfolding chain_sup_def graph_union_def by auto
  show ?thesis unfolding subgraph_def using c1 c2 c3 by auto
qed

lemma chain_sup_graph[intro]:
  assumes "chain S"
  shows "graph (chain_sup S)"
  using chain_sup_subgraph[OF assms]
  unfolding subgraph_def by auto

lemma map_graph_chain_sup:
"map_graph g (chain_sup S) = chain_sup (map_graph g o S)"
  unfolding map_graph_def chain_sup_def by auto

lemma graph_union_chain_sup[intro]:
  assumes "\<And> i. graph_union (S i) C = C"
  shows "graph_union (chain_sup S) C = C"
proof
  from assms have e:"edges (S i) \<subseteq> edges C" and v:"vertices (S i) \<subseteq> vertices C" for i
    by (auto simp:graph_union_iff)
  show "edges (chain_sup S) \<subseteq> edges C" using e unfolding chain_sup_def by auto
  show "vertices (chain_sup S) \<subseteq> vertices C" using v unfolding chain_sup_def by auto
qed

type_synonym ('l,'v) Graph_PreRule = "('l, 'v) labeled_graph \<times> ('l, 'v) labeled_graph"
text \<open>Definition 9.\<close>
abbreviation graph_rule :: "('l,'v) Graph_PreRule \<Rightarrow> bool" where
"graph_rule R \<equiv> subgraph (fst R) (snd R) \<and> finite_graph (snd R)"

definition set_of_graph_rules :: "('l,'v) Graph_PreRule set \<Rightarrow> bool" where
"set_of_graph_rules Rs \<equiv> \<forall> R\<in>Rs. graph_rule R"

lemma set_of_graph_rulesD[dest]:
  assumes "set_of_graph_rules Rs" "R \<in> Rs"
  shows "finite_graph (fst R)" "finite_graph (snd R)" "subgraph (fst R) (snd R)"
  using assms(1)[unfolded set_of_graph_rules_def] assms(2)
        rev_finite_subset[of "vertices (snd R)"]
        rev_finite_subset[of "edges (snd R)"]
  unfolding subgraph_def graph_union_iff by auto

text \<open>We define @{term agree_on} as an equivalence.\<close>
definition agree_on where
"agree_on G f\<^sub>1 f\<^sub>2 \<equiv> (\<forall> v \<in> vertices G. f\<^sub>1 `` {v} = f\<^sub>2 `` {v})"

lemma agree_on_comm[intro]: "agree_on X f g = agree_on X g f" unfolding agree_on_def by auto
lemma agree_on_refl[intro]:
  "agree_on R f f" unfolding agree_on_def by auto
lemma agree_on_trans:
  assumes "agree_on X f g" "agree_on X g h"
  shows "agree_on X f h" using assms unfolding agree_on_def by auto

lemma agree_on_equivp:
  shows "equivp (agree_on G)"
  by (auto intro:agree_on_trans intro!:equivpI simp:reflp_def symp_def transp_def agree_on_comm)

lemma agree_on_subset:
  assumes "f \<subseteq> g" "vertices G \<subseteq> Domain f" "univalent g"
  shows "agree_on G f g"
  using assms unfolding agree_on_def by auto

lemma agree_iff_subset[simp]:
  assumes "graph_homomorphism G X f" "univalent g"
  shows "agree_on G f g \<longleftrightarrow> f \<subseteq> g"
  using assms unfolding agree_on_def graph_homomorphism_def by auto

lemma agree_on_ext:
  assumes "agree_on G f\<^sub>1 f\<^sub>2"
  shows "agree_on G (f\<^sub>1 O g) (f\<^sub>2 O g)"
  using assms unfolding agree_on_def by auto

lemma agree_on_then_eq:
  assumes "agree_on G f\<^sub>1 f\<^sub>2" "Domain f\<^sub>1 = vertices G" "Domain f\<^sub>2 = vertices G"
  shows "f\<^sub>1 = f\<^sub>2"
proof -
  from assms have agr:"\<And> v. v\<in>Domain f\<^sub>1 \<Longrightarrow> f\<^sub>1 `` {v} = f\<^sub>2 `` {v}" unfolding agree_on_def by auto
  have agr2:"\<And> v. v\<notin>Domain f\<^sub>1 \<Longrightarrow> f\<^sub>1 `` {v} = {}"
            "\<And> v. v\<notin>Domain f\<^sub>2 \<Longrightarrow> f\<^sub>2 `` {v} = {}" by auto
  with agr agr2 assms have "\<And> v. f\<^sub>1 `` {v} = f\<^sub>2 `` {v}" by blast
  thus ?thesis by auto
qed

lemma agree_on_subg_compose:
  assumes "agree_on R g h" "agree_on F f g" "subgraph F R"
  shows "agree_on F f h"
  using assms unfolding agree_on_def subgraph_def graph_union_iff by auto

definition extensible :: "('l,'x) Graph_PreRule \<Rightarrow> ('l,'v) labeled_graph \<Rightarrow> ('x \<times> 'v) set \<Rightarrow> bool"
  where
"extensible R G f \<equiv> (\<exists> g. graph_homomorphism (snd R) G g \<and> agree_on (fst R) f g)"

lemma extensibleI[intro]: (* not nice as a standard rule, since obtained variables cannot be used *)
  assumes "graph_homomorphism R2 G g" "agree_on R1 f g"
  shows "extensible (R1,R2) G f"
  using assms unfolding extensible_def by auto

lemma extensible_refl_concr[simp]:
  assumes "graph_homomorphism (LG e\<^sub>1 v) G f"
  shows "extensible (LG e\<^sub>1 v, LG e\<^sub>2 v) G f \<longleftrightarrow> graph_homomorphism (LG e\<^sub>2 v) G f"
proof
  assume "extensible (LG e\<^sub>1 v, LG e\<^sub>2 v) G f"
  then obtain g where g: "graph_homomorphism (LG e\<^sub>2 v) G g" "agree_on (LG e\<^sub>1 v) f g"
    unfolding extensible_def by auto
  hence d:"Domain f = Domain g" "univalent f" "univalent g" using assms
    unfolding graph_homomorphism_def by auto
  from g have subs:"f \<subseteq> g"
    by(subst agree_iff_subset[symmetric,OF assms],auto simp:graph_homomorphism_def)
  with d have "f = g" by auto
  thus "graph_homomorphism (LG e\<^sub>2 v) G f" using g by auto
qed (auto simp: assms extensible_def)

lemma   extensible_chain_sup[intro]:
assumes "chain S" "extensible R (S j) f"
shows "extensible R (chain_sup S) f"
proof -
  from assms obtain g where g:"graph_homomorphism (snd R) (S j) g \<and> agree_on (fst R) f g"
    unfolding extensible_def by auto
  have [simp]:"g O Id_on (vertices (S j)) = g" using g[unfolded graph_homomorphism_def] by auto
  from g assms(1)
  have "graph_homomorphism (snd R) (S j) g" "subgraph (S j) (chain_sup S)" by auto
  from graph_homomorphism_composes[OF this]
  have "graph_homomorphism (snd R) (chain_sup S) g" by auto
  thus ?thesis using g unfolding extensible_def by blast
qed

text \<open>Definition 11.\<close>
definition maintained :: "('l,'x) Graph_PreRule \<Rightarrow> ('l,'v) labeled_graph \<Rightarrow> bool"
  where "maintained R G \<equiv> \<forall> f. graph_homomorphism (fst R) G f \<longrightarrow> extensible R G f"

abbreviation maintainedA
  :: "('l,'x) Graph_PreRule set \<Rightarrow> ('l, 'v) labeled_graph \<Rightarrow> bool"
  where "maintainedA Rs G \<equiv> \<forall> R\<in>Rs. maintained R G"

lemma maintainedI[intro]:
  assumes "\<And> f. graph_homomorphism A G f \<Longrightarrow> extensible (A,B) G f"
  shows "maintained (A,B) G"
  using assms unfolding maintained_def by auto
lemma maintainedD[dest]:
  assumes "maintained (A,B) G" "graph_homomorphism A G f"
  shows "extensible (A,B) G f"
  using assms unfolding maintained_def by auto

lemma maintainedD2[dest]:
  assumes "maintained (A,B) G" "graph_homomorphism A G f"
          "\<And> g. graph_homomorphism B G g \<Longrightarrow> f \<subseteq> g \<Longrightarrow> thesis"
        shows thesis
  using maintainedD[OF assms(1,2),unfolded extensible_def]
proof
  fix g
  assume "graph_homomorphism (snd (A, B)) G g \<and> agree_on (fst (A, B)) f g"
  hence "graph_homomorphism B G g" "f \<subseteq> g"
    using assms(2) unfolding graph_homomorphism_def2 agree_on_def by auto
  from assms(3)[OF this] show thesis.
qed

lemma extensible_refl[intro]:
  "graph_homomorphism R G f \<Longrightarrow> extensible (R,R) G f"
  unfolding extensible_def by auto

lemma maintained_refl[intro]:
  "maintained (R,R) G" by auto

text \<open>Alternate version of definition 8.\<close>
definition fin_maintained :: "('l,'x) Graph_PreRule \<Rightarrow> ('l,'v) labeled_graph \<Rightarrow> bool"
  where
"fin_maintained R G \<equiv> \<forall> F f. finite_graph F
                         \<longrightarrow> subgraph F (fst R)
                         \<longrightarrow> extensible (F,fst R) G f
                         \<longrightarrow> graph_homomorphism F G f
                         \<longrightarrow> extensible (F,snd R) G f"

lemma fin_maintainedI [intro]:
  assumes "\<And> F f. finite_graph F
           \<Longrightarrow> subgraph F (fst R)
           \<Longrightarrow> extensible (F,fst R) G f
           \<Longrightarrow> graph_homomorphism F G f
           \<Longrightarrow> extensible (F,snd R) G f"
  shows "fin_maintained R G" using assms unfolding fin_maintained_def by auto

lemma maintained_then_fin_maintained[simp]:
  assumes maintained:"maintained R G"
  shows "fin_maintained R G"
proof
  fix F f
  assume subg:"subgraph F (fst R)"
     and ext:"extensible (F, fst R) G f" and igh:"graph_homomorphism F G f"
  from ext[unfolded extensible_def prod.sel] obtain g where
     g:"graph_homomorphism (fst R) G g" "agree_on F f g" by blast
  from maintained[unfolded maintained_def,rule_format,OF g(1)] g(2) subg
       agree_on_subg_compose
  show "extensible (F, snd R) G f" unfolding extensible_def prod.sel by blast
qed

lemma fin_maintained_maintained:
  assumes "finite_graph (fst R)"
  shows "fin_maintained R G \<longleftrightarrow> maintained R G" (is "?lhs = ?rhs")
proof
  from assms rev_finite_subset
  have fin:"finite (vertices (fst R))"
           "finite (edges (fst R))"
           "subgraph (fst R) (fst R)"
    unfolding subgraph_def graph_union_iff by auto
  assume ?lhs
  with fin have "extensible (fst R, fst R) G f \<Longrightarrow> graph_homomorphism (fst R) G f
         \<Longrightarrow> extensible R G f" for f unfolding fin_maintained_def by auto
  thus ?rhs by (simp add: extensible_refl maintained_def)
qed simp

lemma extend_for_chain:
assumes "g 0 = f"
    and "\<And> i. graph_homomorphism (S i) C (g i)"
    and "\<And> i. agree_on (S i) (g i) (g (i + 1))"
    and "chain S"
  shows "extensible (S 0, chain_sup S) C f"
proof
  let ?g = "\<Union>i. g i"
  from assms(4)[unfolded chain_def subgraph_def graph_union_iff]
  have v:"vertices (S i) \<subseteq> vertices (S (i + 1))"
    and e:"edges (S i) \<subseteq> edges (S (i + 1))" for i by auto
  { fix a b i
    assume a:"(a, b) \<in> g i"
    hence "a \<in> vertices (S i)" using assms(2)[of i]
      unfolding graph_homomorphism_def2 by auto
    from assms(3)[unfolded agree_on_def,rule_format,OF this] a
    have "(a, b) \<in> g (Suc i)" by auto
  }
  hence gi:"g i \<subseteq> g (Suc i)" for i by auto
  have gij:"i \<le> j \<Longrightarrow> g i \<subseteq> g j" for i j proof(induct j)
    case (Suc j) with gi[of j] show ?case by (cases "i = Suc j",auto)
  qed auto
  from assms(1) have f_subset:"f \<subseteq> ?g" by auto
  from assms(2)[of 0,unfolded assms(1)] have domf:"Domain f = vertices (S 0)"
    and grC:"graph C" and v_dom:"vertices (S i) = Domain (g i)" for i using assms(2)
    unfolding graph_homomorphism_def by auto
  { fix x y z i j assume "(x, y) \<in> g i" "(x, z) \<in> g j"
    with gij[of i "max i j"] gij[of j "max i j"]
    have "(x,y) \<in> g (max i j)" "(x,z) \<in> g (max i j)" by auto
    with assms(2)[unfolded graph_homomorphism_def]
    have "y = z" by auto
  } note univ_strong = this
  hence univ:"univalent ?g" unfolding univalent_def by auto
  { fix xa x i
    assume "(xa, x) \<in> g i"
    hence "x \<in> vertices (map_graph (g i) (S i))"
      using assms(2) unfolding graph_homomorphism_def by auto
    hence "x \<in> vertices C"
      using assms(2) unfolding graph_homomorphism_def2 graph_union_iff by blast
  } note eq_v = this
  { fix l x y x' y' j i
    assume "(l,x,y) \<in> edges (S j)" "(x, x') \<in> g i" "(y, y') \<in> g i"
    with gij[of i "max i j"] gij[of j "max i j"]
         chain[OF assms(4),unfolded subgraph_def graph_union_iff, of i "max i j"]
         chain[OF assms(4),unfolded subgraph_def graph_union_iff, of j "max i j"]
    have "(x,x') \<in> g (max i j)" "(y,y') \<in> g (max i j)"
         "(l,x,y) \<in> edges (S (max i j))" by auto
    hence "(l, x', y') \<in> edges C"
      using assms(2)[unfolded graph_homomorphism_def2 graph_union_iff] by auto
  } note eq_e = this
  have "graph_union (map_graph (g i) (chain_sup S)) C = C" for i
    unfolding graph_union_iff using eq_e eq_v
    unfolding graph_homomorphism_def2 chain_sup_def by auto
  hence subg:"graph_union (map_graph ?g (chain_sup S)) C = C"
    apply (rule graph_map_union) using gij by auto
  have "(\<Union>i. vertices (S i)) = (\<Union>i. Domain (g i))" using v_dom by auto
  hence vd:"vertices (chain_sup S) = Domain ?g"
    unfolding chain_sup_def by auto
  show "graph_homomorphism (chain_sup S) C ?g"
    unfolding graph_homomorphism_def2
    using univ chain_sup_graph[OF assms(4)] grC vd subg by auto
  show "agree_on (S 0) f ?g" using agree_on_subset[OF f_subset _ univ] domf by auto
qed

text \<open>Definition 8, second part.\<close>
definition consequence_graph
  where "consequence_graph Rs G \<equiv> graph G \<and> (\<forall> R \<in> Rs. subgraph (fst R) (snd R) \<and> maintained R G)"

lemma consequence_graphI[intro]:
  assumes "\<And> R. R\<in> Rs \<Longrightarrow> maintained R G"
          "\<And> R. R\<in> Rs \<Longrightarrow> subgraph (fst R) (snd R)"
          "graph G"
  shows "consequence_graph Rs G"
  unfolding consequence_graph_def fin_maintained_def using assms by auto

lemma consequence_graphD[dest]:
  assumes "consequence_graph Rs G"
  shows "\<And> R. R\<in> Rs \<Longrightarrow> maintained R G"
        "\<And> R. R\<in> Rs \<Longrightarrow> subgraph (fst R) (snd R)"
        "graph G"
  using assms unfolding consequence_graph_def fin_maintained_def by auto

text \<open>Definition 8 states: If furthermore S is a subgraph of G,
    and (S, G) is maintained in each consequence graph maintaining Rs,
    then G is a least consequence graph of S maintaining Rs.
    Note that the type of 'each consequence graph' isn't given here.
   Taken literally, this should mean 'for every possible type'.
   We avoid quantifying on types by making the type an argument.
   Consequently, when proving 'least', the first argument should be free.\<close>
definition least
  :: "'x itself \<Rightarrow> (('l, 'v) Graph_PreRule) set \<Rightarrow> ('l, 'c) labeled_graph \<Rightarrow> ('l, 'c) labeled_graph \<Rightarrow> bool"
  where "least _ Rs S G \<equiv> subgraph S G \<and>
            (\<forall> C :: ('l, 'x) labeled_graph. consequence_graph Rs C \<longrightarrow> maintained (S,G) C)"

lemma leastI[intro]:
assumes "subgraph S (G:: ('l, 'c) labeled_graph)"
        "\<And> C :: ('l, 'x) labeled_graph. consequence_graph Rs C \<Longrightarrow> maintained (S,G) C"
      shows "least (t:: 'x itself) Rs S G"
  using assms unfolding least_def by auto

definition least_consequence_graph
  :: "'x itself \<Rightarrow> (('l, 'v) Graph_PreRule) set
     \<Rightarrow> ('l, 'c) labeled_graph \<Rightarrow> ('l, 'c) labeled_graph \<Rightarrow> bool"
  where "least_consequence_graph t Rs S G \<equiv> consequence_graph Rs G \<and> least t Rs S G"

lemma least_consequence_graphI[intro]:
assumes "consequence_graph Rs (G:: ('l, 'c) labeled_graph)"
        "subgraph S G"
        "\<And> C :: ('l, 'x) labeled_graph. consequence_graph Rs C \<Longrightarrow> maintained (S,G) C"
      shows "least_consequence_graph (t:: 'x itself) Rs S G"
  using assms unfolding least_consequence_graph_def least_def by auto

text \<open>Definition 12.\<close>
definition fair_chain where
  "fair_chain Rs S \<equiv> chain S \<and>
    (\<forall> R f i. (R \<in> Rs \<and> graph_homomorphism (fst R) (S i) f) \<longrightarrow> (\<exists> j. extensible R (S j) f))"

lemma fair_chainI[intro]:
  assumes "chain S"
    "\<And> R f i. R \<in> Rs \<Longrightarrow> graph_homomorphism (fst R) (S i) f \<Longrightarrow> \<exists> j. extensible R (S j) f"
  shows "fair_chain Rs S"
  using assms unfolding fair_chain_def by blast

lemma fair_chainD:
  assumes "fair_chain Rs S"
  shows "chain S"
        "R \<in> Rs \<Longrightarrow> graph_homomorphism (fst R) (S i) f \<Longrightarrow> \<exists> j. extensible R (S j) f"
  using assms unfolding fair_chain_def by blast+

lemma find_graph_occurence_vertices:
  assumes "chain S" "finite V" "univalent f" "f `` V \<subseteq> vertices (chain_sup S)"
  shows "\<exists> i. f `` V \<subseteq> vertices (S i)"
  using assms(2,4)
proof(induct V)
  case empty thus ?case by auto
next
  case (insert v V)
  from insert.prems have V:"f `` V \<subseteq> vertices (chain_sup S)"
    and v:"f `` {v} \<subseteq> vertices (chain_sup S)" by auto
  from insert.hyps(3)[OF V] obtain i where i:"f `` V \<subseteq> vertices (S i)" by auto
  have "\<exists> j. f `` {v} \<subseteq> vertices (S j)"
  proof(cases "(f `` {v}) = {}")
    case False
    then obtain v' where f:"(v,v') \<in> f" by auto
    hence "v' \<in> vertices (chain_sup S)" using v by auto
    then show ?thesis using assms(3) f unfolding chain_sup_def by auto
  qed auto
  then obtain j where j:"f `` {v} \<subseteq> vertices (S j)" by blast
  have sg:"subgraph (S i) (S (max i j))" "subgraph (S j) (S (max i j))"
    by(rule chain[OF assms(1)],force)+
  have V:"(f \<inter> V \<times> UNIV) `` V \<subseteq> vertices (S (max i j))"
    using i subgraph_subset[OF sg(1)] by auto
  have v:"f `` {v} \<subseteq> vertices (S (max i j))" using j subgraph_subset[OF sg(2)] by auto
  have "f `` insert v V \<subseteq> vertices (S (max i j))" using v V by auto
  thus ?case by blast
qed

lemma find_graph_occurence_edges:
  assumes "chain S" "finite E" "univalent f"
        "on_triple f `` E \<subseteq> edges (chain_sup S)"
      shows "\<exists> i. on_triple f `` E \<subseteq> edges (S i)"
  using assms(2,4)
proof(induct E)
  case empty thus ?case unfolding graph_homomorphism_def by auto
next
  case (insert e E)
  have univ:"univalent (on_triple f)" using assms(3) by auto
  have [simp]:"restrict (S i) = S i" for i
    using chain[OF assms(1),unfolded subgraph_def,of i i] by auto
  from insert.prems have E:"on_triple f `` E \<subseteq> edges (chain_sup S)"
    and e:"on_triple f `` {e} \<subseteq> edges (chain_sup S)" by auto
  with insert.hyps obtain i where i:"on_triple f `` E \<subseteq> edges (S i)" by auto
  have "\<exists> j. on_triple f `` {e} \<subseteq> edges (S j)"
  proof(cases "on_triple f `` {e} = {}")
    case False
    then obtain e' where f:"(e,e') \<in> on_triple f" by auto
    hence "e' \<in> edges (chain_sup S)" using e by auto
    then show ?thesis using univ f unfolding chain_sup_def by auto
  qed auto
  then obtain j where j:"on_triple f `` {e} \<subseteq> edges (S j)" by blast
  have sg:"subgraph (S i) (S (max i j))" "subgraph (S j) (S (max i j))"
    by(rule chain[OF assms(1)],force)+
  have E:"on_triple f `` E \<subseteq> edges (S (max i j))"
    using i subgraph_subset[OF sg(1)] by auto
  have e:"on_triple f `` {e} \<subseteq> edges (S (max i j))" using j subgraph_subset[OF sg(2)] by auto
  have "on_triple f `` insert e E \<subseteq> edges (S (max i j))" using e E by auto
  thus ?case by blast
qed

lemma find_graph_occurence:
  assumes "chain S" "finite E" "finite V" "graph_homomorphism (LG E V) (chain_sup S) f"
  shows "\<exists> i. graph_homomorphism (LG E V) (S i) f"
proof -
  have [simp]:"restrict (S i) = S i" for i
    using chain[OF assms(1),unfolded subgraph_def,of i i] by auto
  from assms[unfolded graph_homomorphism_def edge_preserving labeled_graph.sel]
  have u:"univalent f"
   and e:"on_triple f `` E \<subseteq> edges (chain_sup S)"
   and v:"f `` V \<subseteq> vertices (chain_sup S)"
    by blast+
  from find_graph_occurence_edges[OF assms(1,2) u e]
  obtain i where i:"on_triple f `` E \<subseteq> edges (S i)" by blast
  from find_graph_occurence_vertices[OF assms(1,3) u v]
  obtain j where j:"f `` V \<subseteq> vertices (S j)" by blast
  have sg:"subgraph (S i) (S (max i j))" "subgraph (S j) (S (max i j))"
    by(rule chain[OF assms(1)],force)+
  have e:"on_triple f `` E \<subseteq> edges (S (max i j))"
   and v:"f `` V \<subseteq> vertices (S (max i j))"
    using i j subgraph_subset(2)[OF sg(1)] subgraph_subset(1)[OF sg(2)] by auto
  have "graph_homomorphism (LG E V) (S (max i j)) f"
  proof(rule graph_homomorphismI)
    from assms[unfolded graph_homomorphism_def edge_preserving labeled_graph.sel] e v
    show "vertices (LG E V) = Domain f"
     and "univalent f"
     and "LG E V = restrict (LG E V)"
     and "f `` vertices (LG E V) \<subseteq> vertices (S (max i j))"
     and "edge_preserving f (edges (LG E V)) (edges (S (max i j)))"
     and "S (max i j) = restrict (S (max i j))" by auto
  qed
  thus ?thesis by auto
qed

text \<open>Lemma 3.
      Recall that in the paper, graph rules use finite graphs, i.e. both sides should be finite.
      We strengthen lemma 3 by requiring only the left hand side to be a finite graph.\<close>
lemma fair_chain_impl_consequence_graph:
  assumes "fair_chain Rs S" "\<And> R. R \<in> Rs \<Longrightarrow> subgraph (fst R) (snd R) \<and> finite_graph (fst R)"
  shows "consequence_graph Rs (chain_sup S)"
proof -
  { fix R assume a:"R \<in> Rs"
    have fin_v:"finite (vertices (fst R))" and fin_e: "finite (edges (fst R))"
      using assms(2)[OF a] by auto
    { fix f assume "graph_homomorphism (LG (edges (fst R)) (vertices (fst R))) (chain_sup S) f"
      with find_graph_occurence[OF fair_chainD(1)[OF assms(1)] fin_e fin_v]
      obtain i where "graph_homomorphism (fst R) (S i) f" by auto
      from fair_chainD(2)[OF assms(1) a this] obtain j
         where "extensible R (S j) f" by blast
      hence "extensible R (chain_sup S) f" using fair_chainD(1)[OF assms(1)] by auto
    }
    hence "maintained R (chain_sup S)" unfolding maintained_def by auto
  } note mnt = this
  from assms have "chain S" unfolding fair_chain_def by auto
  thus ?thesis unfolding consequence_graph_def using mnt assms(2) by blast
qed

text \<open>We extract the weak universal property from the definition of weak pushout step.
      Again, the paper allows for arbitrary types in the quantifier,
          but we fix the type here in the definition that will be used in @{term pushout_step}.
          The type used here should suffice (and we cannot quantify over types anyways)\<close>
definition weak_universal ::
    "'x itself \<Rightarrow> ('a, 'c) Graph_PreRule \<Rightarrow> ('a, 'b) labeled_graph \<Rightarrow> ('a, 'b) labeled_graph \<Rightarrow>
     ('c \<times> 'b) set \<Rightarrow> ('c \<times> 'b) set \<Rightarrow> bool" where
"weak_universal _ R G\<^sub>1 G\<^sub>2 f\<^sub>1 f\<^sub>2 \<equiv> (\<forall> h\<^sub>1 h\<^sub>2 G::('a, 'x) labeled_graph.
             (graph_homomorphism (snd R) G h\<^sub>1 \<and> graph_homomorphism G\<^sub>1 G h\<^sub>2 \<and> f\<^sub>1 O h\<^sub>2 \<subseteq> h\<^sub>1)
         \<longrightarrow> (\<exists> h. graph_homomorphism G\<^sub>2 G h \<and> h\<^sub>2 \<subseteq> h))"

lemma weak_universalI[intro]:
  assumes "\<And> h\<^sub>1 h\<^sub>2 G::('a, 'x) labeled_graph.
         graph_homomorphism (snd R) G h\<^sub>1 \<Longrightarrow> graph_homomorphism G\<^sub>1 G h\<^sub>2 \<Longrightarrow> f\<^sub>1 O h\<^sub>2 \<subseteq> h\<^sub>1
         \<Longrightarrow> (\<exists> h. graph_homomorphism G\<^sub>2 G h \<and> h\<^sub>2 \<subseteq> h)"
  shows "weak_universal (t:: 'x itself) R (G\<^sub>1::('a, 'b) labeled_graph) G\<^sub>2 f\<^sub>1 f\<^sub>2"
  using assms unfolding weak_universal_def by force

text \<open>Definition 13\<close>
definition pushout_step ::
    "'x itself \<Rightarrow> ('a, 'c) Graph_PreRule \<Rightarrow> ('a, 'b) labeled_graph \<Rightarrow> ('a, 'b) labeled_graph \<Rightarrow> bool" where
"pushout_step t R G\<^sub>1 G\<^sub>2 \<equiv> subgraph G\<^sub>1 G\<^sub>2 \<and>
  (\<exists> f\<^sub>1 f\<^sub>2. graph_homomorphism (fst R) G\<^sub>1 f\<^sub>1 \<and>
           graph_homomorphism (snd R) G\<^sub>2 f\<^sub>2 \<and>
           f\<^sub>1 \<subseteq> f\<^sub>2 \<and>
           weak_universal t R G\<^sub>1 G\<^sub>2 f\<^sub>1 f\<^sub>2
  )"

text \<open>Definition 14\<close>
definition Simple_WPC ::
    "'x itself \<Rightarrow> (('a, 'b) Graph_PreRule) set \<Rightarrow> (('a, 'd) graph_seq) \<Rightarrow> bool" where
"Simple_WPC t Rs S \<equiv> set_of_graph_rules Rs
   \<and> (\<forall> i. (graph (S i) \<and> S i = S (Suc i)) \<or> (\<exists> R \<in> Rs. pushout_step t R (S i) (S (Suc i))))"

lemma Simple_WPCI [intro]:
  assumes "set_of_graph_rules Rs" "graph (S 0)"
          "\<And> i. (S i = S (Suc i)) \<or> (\<exists> R \<in> Rs. pushout_step t R (S i) (S (Suc i)))"
        shows "Simple_WPC t Rs S"
proof -
  have "graph (S i)" for i proof(induct i)
    case (Suc i)
    then show ?case using assms(3) unfolding pushout_step_def subgraph_def by metis
  qed (fact assms)
  thus ?thesis using assms unfolding Simple_WPC_def by auto
qed

lemma Simple_WPC_Chain[simp]:
  assumes "Simple_WPC t Rs S"
  shows "chain S"
proof -
  have "subgraph (S i) (S (Suc i))" for i using assms
    unfolding Simple_WPC_def pushout_step_def by (cases "graph (S i) \<and> S i = S (Suc i)",auto)
  thus ?thesis unfolding chain_def by auto
qed

text \<open>Definition 14, second part. \<close>
inductive WPC ::
    "'x itself \<Rightarrow> (('a, 'b) Graph_PreRule) set \<Rightarrow> (('a, 'd) graph_seq) \<Rightarrow> bool"
  where
    wpc_simpl [simp, intro]: "Simple_WPC t Rs S \<Longrightarrow> WPC t Rs S"
  | wpc_combo [simp, intro]: "chain S \<Longrightarrow> (\<And> i. \<exists> S'. S' 0 = S i \<and> chain_sup S' = S (Suc i) \<and> WPC t Rs S') \<Longrightarrow> WPC t Rs S"

lemma extensible_from_chainI:
  assumes ch:"chain S"
  and igh:"graph_homomorphism (S 0) C f"
  and ind:"\<And> f i. graph_homomorphism (S i) C f \<Longrightarrow>
                \<exists>h. (graph_homomorphism (S (Suc i)) C h) \<and> agree_on (S i) f h"
  shows "extensible (S 0,chain_sup S) C f"
proof -
  have ch:"chain S" using assms by auto
  hence r0:"\<exists>x. graph_homomorphism (S 0) C x \<and> (0 = 0 \<longrightarrow> x = f)"
    using igh by auto
  { fix i x
    assume "graph_homomorphism (S i) C x \<and> (i = 0 \<longrightarrow> x = f)"
    hence "graph_homomorphism (S i) C x" by auto
    from ind[OF this]
    have "\<exists>y. (graph_homomorphism (S (Suc i)) C y \<and> (Suc i = 0 \<longrightarrow> y = f)) \<and> agree_on (S i) x y"
      by auto
  }
  with r0
  have "\<exists> g. (\<forall> i. (graph_homomorphism (S i) C (g i) \<and> (i = 0 \<longrightarrow> g i = f))
                \<and> agree_on (S i) (g i) (g (Suc i)) )" by (rule dependent_nat_choice)
  then obtain g where
       mtn:"g 0 = f"
           "graph_homomorphism (S i) C (g i)"
           "agree_on (S i) (g i) (g (i + 1))" for i by auto
  from extend_for_chain[OF mtn ch] show ?thesis.
qed

text \<open>Towards Lemma 4, this is the key inductive property.\<close>
lemma wpc_least:
  assumes "WPC (t:: 'x itself) Rs S"
  shows "least t Rs (S 0) (chain_sup S)"
  using assms
proof(induction S)
  case (wpc_simpl t Rs S)
  hence gr:"set_of_graph_rules Rs"
    and ps:"\<And> i. S i = S (Suc i) \<or> (\<exists>R\<in>Rs. pushout_step t R (S i) (S (i + 1)))"
    unfolding Simple_WPC_def by auto
  have ch[intro]:"chain S" using wpc_simpl by auto
  show ?case
  proof fix C::"('a,'x) labeled_graph"
    assume cgC:"consequence_graph Rs C"
    show "maintained (S 0, chain_sup S) C"
    proof(standard,rule extensible_from_chainI,goal_cases)
      case (3 f x i)
      show ?case proof(cases "S i = S (Suc i)")
        case True
        with 3 show ?thesis by auto
      next
        case False
        with ps[of i,unfolded pushout_step_def] obtain R f\<^sub>1 f\<^sub>2 where
        R:"(fst R,snd R) \<in> Rs" and f\<^sub>1:"graph_homomorphism (fst R) (S i) f\<^sub>1"
        and wu:"weak_universal t R (S i) (S (i + 1)) f\<^sub>1 f\<^sub>2" by auto
        from graph_homomorphism_composes[OF f\<^sub>1 3(2)]
        have ih_comp:"graph_homomorphism (fst R) C (f\<^sub>1 O x)".
        with maintainedD[OF consequence_graphD(1)[OF cgC R]]
        have "extensible (fst R, snd R) C (f\<^sub>1 O x)" by auto
        from this[unfolded extensible_def prod.sel]
        obtain g where g:"graph_homomorphism (snd R) C g" "f\<^sub>1 O x \<subseteq> g"
          using agree_iff_subset[OF ih_comp] unfolding graph_homomorphism_def by auto
        from weak_universalD[OF wu g(1) 3(2) g(2)] obtain h where
          h:"graph_homomorphism (S (i + 1)) C h" "x \<subseteq> h" by auto
        hence "agree_on (S i) x h"
          by(subst agree_iff_subset[OF 3(2)], auto simp:graph_homomorphism_def)
        then show ?thesis using h(1) by auto
      qed
    qed auto
  qed auto
next
  case (wpc_combo S t Rs)
  hence ps:"\<And> i. \<exists>S'. S' 0 = S i \<and>
         chain_sup S' = S (Suc i) \<and>
         WPC t Rs S' \<and>
         least t Rs (S' 0) (chain_sup S')"
    and ch[intro]:"chain S" unfolding Simple_WPC_def by auto
  show ?case proof fix C :: "('a, 'x) labeled_graph"
    assume cgC:"consequence_graph Rs C"
    show "maintained (S 0, chain_sup S) C"
    proof(standard,rule extensible_from_chainI,goal_cases)
      case (3 f g i)
      from ps[of i] have "least t Rs (S i) (S (Suc i))" by auto
      with cgC have ss:"subgraph (S i) (S (Suc i))" "maintained (S i, S (Suc i)) C"
        unfolding least_def by auto
      from ss(2) 3(2) have "extensible (S i, S (Suc i)) C g" by auto
      thus ?case unfolding extensible_def prod.sel.
    qed auto
  qed auto
qed

text \<open>Lemma 4.\<close>
lemma wpc_least_consequence_graph:
  assumes "WPC t Rs S" "consequence_graph Rs (chain_sup S)"
  shows "least_consequence_graph t Rs (S 0) (chain_sup S)"
  using wpc_least assms unfolding least_consequence_graph_def 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_MSortBUPermutes
  imports "../../Test_Base"
begin

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

fun map :: "('a => 'b) => 'a list => 'b list" where
  "map f (nil2) = nil2"
| "map f (cons2 y xs) = cons2 (f y) (map f xs)"

fun lmerge :: "int list => int list => int list" where
  "lmerge (nil2) y = y"
| "lmerge (cons2 z x2) (nil2) = cons2 z x2"
| "lmerge (cons2 z x2) (cons2 x3 x4) =
     (if z <= x3 then cons2 z (lmerge x2 (cons2 x3 x4)) else
        cons2 x3 (lmerge (cons2 z x2) x4))"

fun pairwise :: "(int list) list => (int list) list" where
  "pairwise (nil2) = nil2"
| "pairwise (cons2 xs (nil2)) = cons2 xs (nil2)"
| "pairwise (cons2 xs (cons2 ys xss)) =
     cons2 (lmerge xs ys) (pairwise xss)"

(*fun did not finish the proof*)
function mergingbu :: "(int list) list => int list" where
  "mergingbu (nil2) = nil2"
| "mergingbu (cons2 xs (nil2)) = xs"
| "mergingbu (cons2 xs (cons2 z x2)) =
     mergingbu (pairwise (cons2 xs (cons2 z x2)))"
  by pat_completeness auto

fun msortbu :: "int list => int list" where
  "msortbu x = mergingbu (map (% (y :: int) => cons2 y (nil2)) x)"

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

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

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

theorem property0 :
  "isPermutation (msortbu xs) xs"
  oops

end


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

section\<open>Rank of a matrix\<close>

theory Rank
imports
      Rank_Nullity_Theorem.Dim_Formula
begin

subsection\<open>Row rank, column rank and rank\<close>

text\<open>Definitions of row rank, column rank and rank\<close>

definition row_rank :: "'a::{field}^'n^'m=>nat"
  where "row_rank A = vec.dim (row_space A)"

definition col_rank :: "'a::{field}^'n^'m=>nat"
  where "col_rank A = vec.dim (col_space A)"

lemma rank_def: "rank A = row_rank A"
  by (auto simp: row_rank_def row_rank_def_gen row_space_def)

subsection\<open>Properties\<close>

lemma rrk_is_preserved:
fixes A::"'a::{field}^'cols^'rows::{finite, wellorder}"
  and P::"'a::{field}^'rows::{finite, wellorder}^'rows::{finite, wellorder}"
assumes inv_P: "invertible P"
shows "row_rank A = row_rank (P**A)"
by (metis row_space_is_preserved row_rank_def inv_P)

lemma crk_is_preserved:
fixes A::"'a::{field}^'cols::{finite, wellorder}^'rows"
  and P::"'a::{field}^'rows^'rows"
assumes inv_P: "invertible P"
shows "col_rank A = col_rank (P**A)"
  using rank_nullity_theorem_matrices unfolding ncols_def
  by (metis col_rank_def inv_P nat_add_left_cancel null_space_is_preserved)

end


(* Author: Tobias Nipkow *)

section \<open>Unbalanced Tree Implementation of Set\<close>

theory Tree_Set
imports
  "~~/src/HOL/Library/Tree"
  Cmp
  Set_by_Ordered
begin

fun isin :: "'a::linorder tree \<Rightarrow> 'a \<Rightarrow> bool" where
"isin Leaf x = False" |
"isin (Node l a r) x =
  (case cmp x a of
     LT \<Rightarrow> isin l x |
     EQ \<Rightarrow> True |
     GT \<Rightarrow> isin r x)"

hide_const (open) insert

fun insert :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"insert x Leaf = Node Leaf x Leaf" |
"insert x (Node l a r) =
  (case cmp x a of
     LT \<Rightarrow> Node (insert x l) a r |
     EQ \<Rightarrow> Node l a r |
     GT \<Rightarrow> Node l a (insert x r))"

fun del_min :: "'a tree \<Rightarrow> 'a * 'a tree" where
"del_min (Node l a r) =
  (if l = Leaf then (a,r) else let (x,l') = del_min l in (x, Node l' a r))"

fun delete :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"delete x Leaf = Leaf" |
"delete x (Node l a r) =
  (case cmp x a of
     LT \<Rightarrow>  Node (delete x l) a r |
     GT \<Rightarrow>  Node l a (delete x r) |
     EQ \<Rightarrow> if r = Leaf then l else let (a',r') = del_min r in Node l a' r')"

subsection "Functional Correctness Proofs"

lemma "sorted(inorder t) \<Longrightarrow> isin t x = (x \<in> elems (inorder t))"
by (induction t) (auto simp: elems_simps1)

lemma isin_set: "sorted(inorder t) \<Longrightarrow> isin t x = (x \<in> elems (inorder t))"
by (induction t) (auto simp: elems_simps2)

lemma inorder_insert:
  "sorted(inorder t) \<Longrightarrow> inorder(insert x t) = ins_list x (inorder t)"
by(induction t) (auto simp: ins_list_simps)

lemma del_minD:
  "del_min t = (x,t') \<Longrightarrow> t \<noteq> Leaf \<Longrightarrow> x # inorder t' = inorder t"
by(induction t arbitrary: t' rule: del_min.induct)
  (auto simp: sorted_lems split: prod.splits if_splits)

lemma inorder_delete:
  "sorted(inorder t) \<Longrightarrow> inorder(delete x t) = del_list x (inorder t)"
by(induction t) (auto simp: del_list_simps del_minD split: prod.splits)

interpretation Set_by_Ordered
where empty = Leaf and isin = isin and insert = insert and delete = delete
and inorder = inorder and inv = "\<lambda>_. True"
proof (standard, goal_cases)
  case 1 show ?case by simp
next
  case 2 thus ?case by(simp add: isin_set)
next
  case 3 thus ?case by(simp add: inorder_insert)
next
  case 4 thus ?case by(simp add: inorder_delete)
qed (rule TrueI)+

end


(*  Title:      HOL/Datatype_Examples/Koenig.thy
    Author:     Dmitriy Traytel, TU Muenchen
    Author:     Andrei Popescu, TU Muenchen
    Copyright   2012

Koenig's lemma.
*)

section \<open>Koenig's Lemma\<close>

theory Koenig
imports TreeFI "HOL-Library.Stream"
begin

(* infinite trees: *)
coinductive infiniteTr where
"\<lbrakk>tr' \<in> set (sub tr); infiniteTr tr'\<rbrakk> \<Longrightarrow> infiniteTr tr"

lemma infiniteTr_strong_coind[consumes 1, case_names sub]:
assumes *: "phi tr" and
**: "\<And> tr. phi tr \<Longrightarrow> \<exists> tr' \<in> set (sub tr). phi tr' \<or> infiniteTr tr'"
shows "infiniteTr tr"
using assms by (elim infiniteTr.coinduct) blast

lemma infiniteTr_coind[consumes 1, case_names sub, induct pred: infiniteTr]:
assumes *: "phi tr" and
**: "\<And> tr. phi tr \<Longrightarrow> \<exists> tr' \<in> set (sub tr). phi tr'"
shows "infiniteTr tr"
using assms by (elim infiniteTr.coinduct) blast

lemma infiniteTr_sub[simp]:
"infiniteTr tr \<Longrightarrow> (\<exists> tr' \<in> set (sub tr). infiniteTr tr')"
by (erule infiniteTr.cases) blast

primcorec konigPath where
  "shd (konigPath t) = lab t"
| "stl (konigPath t) = konigPath (SOME tr. tr \<in> set (sub t) \<and> infiniteTr tr)"

(* proper paths in trees: *)
coinductive properPath where
"\<lbrakk>shd as = lab tr; tr' \<in> set (sub tr); properPath (stl as) tr'\<rbrakk> \<Longrightarrow>
 properPath as tr"

lemma properPath_strong_coind[consumes 1, case_names shd_lab sub]:
assumes *: "phi as tr" and
**: "\<And> as tr. phi as tr \<Longrightarrow> shd as = lab tr" and
***: "\<And> as tr.
         phi as tr \<Longrightarrow>
         \<exists> tr' \<in> set (sub tr). phi (stl as) tr' \<or> properPath (stl as) tr'"
shows "properPath as tr"
using assms by (elim properPath.coinduct) blast

lemma properPath_coind[consumes 1, case_names shd_lab sub, induct pred: properPath]:
assumes *: "phi as tr" and
**: "\<And> as tr. phi as tr \<Longrightarrow> shd as = lab tr" and
***: "\<And> as tr.
         phi as tr \<Longrightarrow>
         \<exists> tr' \<in> set (sub tr). phi (stl as) tr'"
shows "properPath as tr"
using properPath_strong_coind[of phi, OF * **] *** by blast

lemma properPath_shd_lab:
"properPath as tr \<Longrightarrow> shd as = lab tr"
by (erule properPath.cases) blast

lemma properPath_sub:
"properPath as tr \<Longrightarrow>
 \<exists> tr' \<in> set (sub tr). phi (stl as) tr' \<or> properPath (stl as) tr'"
by (erule properPath.cases) blast

(* prove the following by coinduction *)
theorem Konig:
  assumes "infiniteTr tr"
  shows "properPath (konigPath tr) tr"
proof-
  {fix as
   assume "infiniteTr tr \<and> as = konigPath tr" hence "properPath as tr"
   proof (coinduction arbitrary: tr as rule: properPath_coind)
     case (sub tr as)
     let ?t = "SOME t'. t' \<in> set (sub tr) \<and> infiniteTr t'"
     from sub have "\<exists>t' \<in> set (sub tr). infiniteTr t'" by simp
     then have "\<exists>t'. t' \<in> set (sub tr) \<and> infiniteTr t'" by blast
     then have "?t \<in> set (sub tr) \<and> infiniteTr ?t" by (rule someI_ex)
     moreover have "stl (konigPath tr) = konigPath ?t" by simp
     ultimately show ?case using sub by blast
   qed simp
  }
  thus ?thesis using assms by blast
qed

(* some more stream theorems *)

primcorec plus :: "nat stream \<Rightarrow> nat stream \<Rightarrow> nat stream" (infixr "\<oplus>" 66) where
  "shd (plus xs ys) = shd xs + shd ys"
| "stl (plus xs ys) = plus (stl xs) (stl ys)"

definition scalar :: "nat \<Rightarrow> nat stream \<Rightarrow> nat stream" (infixr "\<cdot>" 68) where
  [simp]: "scalar n = smap (\<lambda>x. n * x)"

primcorec ones :: "nat stream" where "ones = 1 ## ones"
primcorec twos :: "nat stream" where "twos = 2 ## twos"
definition ns :: "nat \<Rightarrow> nat stream" where [simp]: "ns n = scalar n ones"

lemma "ones \<oplus> ones = twos"
  by coinduction simp

lemma "n \<cdot> twos = ns (2 * n)"
  by coinduction simp

lemma prod_scalar: "(n * m) \<cdot> xs = n \<cdot> m \<cdot> xs"
  by (coinduction arbitrary: xs) auto

lemma scalar_plus: "n \<cdot> (xs \<oplus> ys) = n \<cdot> xs \<oplus> n \<cdot> ys"
  by (coinduction arbitrary: xs ys) (auto simp: add_mult_distrib2)

lemma plus_comm: "xs \<oplus> ys = ys \<oplus> xs"
  by (coinduction arbitrary: xs ys) auto

lemma plus_assoc: "(xs \<oplus> ys) \<oplus> zs = xs \<oplus> ys \<oplus> zs"
  by (coinduction arbitrary: xs ys zs) auto

end


(*<*)theory PDL imports Base begin(*>*)

subsection\<open>Propositional Dynamic Logic --- PDL\<close>

text\<open>\index{PDL|(}
The formulae of PDL are built up from atomic propositions via
negation and conjunction and the two temporal
connectives \<open>AX\<close> and \<open>EF\<close>\@. Since formulae are essentially
syntax trees, they are naturally modelled as a datatype:%
\footnote{The customary definition of PDL
@{cite "HarelKT-DL"} looks quite different from ours, but the two are easily
shown to be equivalent.}
\<close>

datatype formula = Atom "atom"
                  | Neg formula
                  | And formula formula
                  | AX formula
                  | EF formula

text\<open>\noindent
This resembles the boolean expression case study in
\S\ref{sec:boolex}.
A validity relation between states and formulae specifies the semantics.
The syntax annotation allows us to write \<open>s \<Turnstile> f\<close> instead of
\hbox{\<open>valid s f\<close>}. The definition is by recursion over the syntax:
\<close>

primrec valid :: "state \<Rightarrow> formula \<Rightarrow> bool"   ("(_ \<Turnstile> _)" [80,80] 80)
where
"s \<Turnstile> Atom a  = (a \<in> L s)" |
"s \<Turnstile> Neg f   = (\<not>(s \<Turnstile> f))" |
"s \<Turnstile> And f g = (s \<Turnstile> f \<and> s \<Turnstile> g)" |
"s \<Turnstile> AX f    = (\<forall>t. (s,t) \<in> M \<longrightarrow> t \<Turnstile> f)" |
"s \<Turnstile> EF f    = (\<exists>t. (s,t) \<in> M\<^sup>* \<and> t \<Turnstile> f)"

text\<open>\noindent
The first three equations should be self-explanatory. The temporal formula
\<^term>\<open>AX f\<close> means that \<^term>\<open>f\<close> is true in \emph{A}ll ne\emph{X}t states whereas
\<^term>\<open>EF f\<close> means that there \emph{E}xists some \emph{F}uture state in which \<^term>\<open>f\<close> is
true. The future is expressed via \<open>\<^sup>*\<close>, the reflexive transitive
closure. Because of reflexivity, the future includes the present.

Now we come to the model checker itself. It maps a formula into the
set of states where the formula is true.  It too is defined by
recursion over the syntax:\<close>

primrec mc :: "formula \<Rightarrow> state set" where
"mc(Atom a)  = {s. a \<in> L s}" |
"mc(Neg f)   = -mc f" |
"mc(And f g) = mc f \<inter> mc g" |
"mc(AX f)    = {s. \<forall>t. (s,t) \<in> M  \<longrightarrow> t \<in> mc f}" |
"mc(EF f)    = lfp(\<lambda>T. mc f \<union> (M\<inverse> `` T))"

text\<open>\noindent
Only the equation for \<^term>\<open>EF\<close> deserves some comments. Remember that the
postfix \<open>\<inverse>\<close> and the infix \<open>``\<close> are predefined and denote the
converse of a relation and the image of a set under a relation.  Thus
\<^term>\<open>M\<inverse> `` T\<close> is the set of all predecessors of \<^term>\<open>T\<close> and the least
fixed point (\<^term>\<open>lfp\<close>) of \<^term>\<open>\<lambda>T. mc f \<union> M\<inverse> `` T\<close> is the least set
\<^term>\<open>T\<close> containing \<^term>\<open>mc f\<close> and all predecessors of \<^term>\<open>T\<close>. If you
find it hard to see that \<^term>\<open>mc(EF f)\<close> contains exactly those states from
which there is a path to a state where \<^term>\<open>f\<close> is true, do not worry --- this
will be proved in a moment.

First we prove monotonicity of the function inside \<^term>\<open>lfp\<close>
in order to make sure it really has a least fixed point.
\<close>

lemma mono_ef: "mono(\<lambda>T. A \<union> (M\<inverse> `` T))"
apply(rule monoI)
apply blast
done

text\<open>\noindent
Now we can relate model checking and semantics. For the \<open>EF\<close> case we need
a separate lemma:
\<close>

lemma EF_lemma:
  "lfp(\<lambda>T. A \<union> (M\<inverse> `` T)) = {s. \<exists>t. (s,t) \<in> M\<^sup>* \<and> t \<in> A}"

txt\<open>\noindent
The equality is proved in the canonical fashion by proving that each set
includes the other; the inclusion is shown pointwise:
\<close>

apply(rule equalityI)
 apply(rule subsetI)
 apply(simp)(*<*)apply(rename_tac s)(*>*)

txt\<open>\noindent
Simplification leaves us with the following first subgoal
@{subgoals[display,indent=0,goals_limit=1]}
which is proved by \<^term>\<open>lfp\<close>-induction:
\<close>

 apply(erule lfp_induct_set)
  apply(rule mono_ef)
 apply(simp)
txt\<open>\noindent
Having disposed of the monotonicity subgoal,
simplification leaves us with the following goal:
\begin{isabelle}
\ {\isadigit{1}}{\isachardot}\ {\isasymAnd}x{\isachardot}\ x\ {\isasymin}\ A\ {\isasymor}\isanewline
\ \ \ \ \ \ \ \ \ x\ {\isasymin}\ M{\isasyminverse}\ {\isacharbackquote}{\isacharbackquote}\ {\isacharparenleft}lfp\ {\isacharparenleft}\dots{\isacharparenright}\ {\isasyminter}\ {\isacharbraceleft}x{\isachardot}\ {\isasymexists}t{\isachardot}\ {\isacharparenleft}x{\isacharcomma}\ t{\isacharparenright}\ {\isasymin}\ M\isactrlsup {\isacharasterisk}\ {\isasymand}\ t\ {\isasymin}\ A{\isacharbraceright}{\isacharparenright}\isanewline
\ \ \ \ \ \ \ \ {\isasymLongrightarrow}\ {\isasymexists}t{\isachardot}\ {\isacharparenleft}x{\isacharcomma}\ t{\isacharparenright}\ {\isasymin}\ M\isactrlsup {\isacharasterisk}\ {\isasymand}\ t\ {\isasymin}\ A
\end{isabelle}
It is proved by \<open>blast\<close>, using the transitivity of
\isa{M\isactrlsup {\isacharasterisk}}.
\<close>

 apply(blast intro: rtrancl_trans)

txt\<open>
We now return to the second set inclusion subgoal, which is again proved
pointwise:
\<close>

apply(rule subsetI)
apply(simp, clarify)

txt\<open>\noindent
After simplification and clarification we are left with
@{subgoals[display,indent=0,goals_limit=1]}
This goal is proved by induction on \<^term>\<open>(s,t)\<in>M\<^sup>*\<close>. But since the model
checker works backwards (from \<^term>\<open>t\<close> to \<^term>\<open>s\<close>), we cannot use the
induction theorem @{thm[source]rtrancl_induct}: it works in the
forward direction. Fortunately the converse induction theorem
@{thm[source]converse_rtrancl_induct} already exists:
@{thm[display,margin=60]converse_rtrancl_induct[no_vars]}
It says that if \<^prop>\<open>(a,b)\<in>r\<^sup>*\<close> and we know \<^prop>\<open>P b\<close> then we can infer
\<^prop>\<open>P a\<close> provided each step backwards from a predecessor \<^term>\<open>z\<close> of
\<^term>\<open>b\<close> preserves \<^term>\<open>P\<close>.
\<close>

apply(erule converse_rtrancl_induct)

txt\<open>\noindent
The base case
@{subgoals[display,indent=0,goals_limit=1]}
is solved by unrolling \<^term>\<open>lfp\<close> once
\<close>

 apply(subst lfp_unfold[OF mono_ef])

txt\<open>
@{subgoals[display,indent=0,goals_limit=1]}
and disposing of the resulting trivial subgoal automatically:
\<close>

 apply(blast)

txt\<open>\noindent
The proof of the induction step is identical to the one for the base case:
\<close>

apply(subst lfp_unfold[OF mono_ef])
apply(blast)
done

text\<open>
The main theorem is proved in the familiar manner: induction followed by
\<open>auto\<close> augmented with the lemma as a simplification rule.
\<close>

theorem "mc f = {s. s \<Turnstile> f}"
apply(induct_tac f)
apply(auto simp add: EF_lemma)
done

text\<open>
\begin{exercise}
\<^term>\<open>AX\<close> has a dual operator \<^term>\<open>EN\<close>
(``there exists a next state such that'')%
\footnote{We cannot use the customary \<open>EX\<close>: it is reserved
as the \textsc{ascii}-equivalent of \<open>\<exists>\<close>.}
with the intended semantics
@{prop[display]"(s \<Turnstile> EN f) = (\<exists>t. (s,t) \<in> M \<and> t \<Turnstile> f)"}
Fortunately, \<^term>\<open>EN f\<close> can already be expressed as a PDL formula. How?

Show that the semantics for \<^term>\<open>EF\<close> satisfies the following recursion equation:
@{prop[display]"(s \<Turnstile> EF f) = (s \<Turnstile> f | s \<Turnstile> EN(EF f))"}
\end{exercise}
\index{PDL|)}
\<close>
(*<*)
theorem main: "mc f = {s. s \<Turnstile> f}"
apply(induct_tac f)
apply(auto simp add: EF_lemma)
done

lemma aux: "s \<Turnstile> f = (s \<in> mc f)"
apply(simp add: main)
done

lemma "(s \<Turnstile> EF f) = (s \<Turnstile> f | s \<Turnstile> Neg(AX(Neg(EF f))))"
apply(simp only: aux)
apply(simp)
apply(subst lfp_unfold[OF mono_ef], fast)
done

end
(*>*)


(*  Title:      Schutz_Spacetime/Util.thy
    Authors:    Richard Schmoetten, Jake Palmer and Jacques D. Fleuriot
                University of Edinburgh, 2021
*)
theory Util
imports Main

begin

text \<open>Some "utility" proofs -- little proofs that come in handy every now and then.\<close>

text \<open>
  We need this in order to obtain a natural number which can be passed to the ordering function,
  distinct from two others, in the case of a finite set of events with cardinality a least 3.
\<close>

lemma is_free_nat:
  assumes "(m::nat) < n"
      and "n < c"
      and "c \<ge> 3"
  shows "\<exists>k::nat. k < m \<or> (m < k \<and> k < n) \<or> (n < k \<and> k < c)"
using assms by presburger

text \<open>Helpful proofs on sets.\<close>

lemma set_le_two [simp]: "card {a, b} \<le> 2"
  by (simp add: card_insert_if)

lemma set_le_three [simp]: "card {a, b, c} \<le> 3"
  by (simp add: card_insert_if)

lemma card_subset: "\<lbrakk>card Y = n; Y \<subseteq> X\<rbrakk> \<Longrightarrow> card X \<ge> n \<or> infinite X"
  using card_mono by blast

lemma card_subset_finite: "\<lbrakk>finite X; card Y = n; Y \<subseteq> X\<rbrakk> \<Longrightarrow> card X \<ge> n"
  using card_subset by auto

lemma three_subset: "\<lbrakk>x \<noteq> y; x \<noteq> z; y \<noteq> z; {x,y,z} \<subseteq> X\<rbrakk> \<Longrightarrow> card X \<ge> 3 \<or> infinite X"
  apply (case_tac "finite X")
  apply (auto simp : card_mono)
  apply (erule_tac Y = "{x,y,z}" in card_subset_finite)
  by auto

lemma three_in_set3:
  assumes "card X \<ge> 3"
  obtains x y z where "x\<in>X" and "y\<in>X" and "z\<in>X" and "x\<noteq>y" and "x\<noteq>z" and "y\<noteq>z"
  using assms by (auto simp add: card_le_Suc_iff numeral_3_eq_3)

lemma card_Collect_nat:
  assumes "(j::nat)>i"
  shows "card {i..j} = j-i+1"
  using card_atLeastAtMost
  using Suc_diff_le assms le_eq_less_or_eq by presburger

lemma inf_3_elms: assumes "infinite X" shows "(\<exists>x\<in>X. \<exists>y\<in>X. \<exists>z\<in>X. x \<noteq> y \<and> y \<noteq> z \<and> x \<noteq> z)"
proof -
  obtain x y where 1: "x\<in>X" "y\<in>X" "y\<noteq>x"
    by (metis assms finite.emptyI finite.insertI rev_finite_subset singleton_iff subsetI)
  have "infinite (X-{x,y})"
    using infinite_remove by (simp add: assms)
  then obtain z where 2: "z\<in>X" "x\<noteq>z" "z\<noteq>y"
    using infinite_imp_nonempty by (metis Diff_eq_empty_iff insertCI subset_eq)
  show ?thesis using 1 2 by blast
qed

lemma card_3_dist: "card {x,y,z} = 3 \<longleftrightarrow> x\<noteq>y \<and> x\<noteq>z \<and> y\<noteq>z"
  by (simp add: eval_nat_numeral card_insert_if)

lemma card_3_eq:
  "card X = 3 \<longleftrightarrow> (\<exists>x y z. X={x,y,z} \<and> x \<noteq> y \<and> y \<noteq> z \<and> x \<noteq> z)"
  (is "card X = 3 \<longleftrightarrow> ?card3 X")
proof
  assume asm: "card X = 3" hence "card X \<ge> 3" by simp
  then obtain x y z where "x \<noteq> y \<and> y \<noteq> z \<and> x \<noteq> z" "{x,y,z} \<subseteq> X"
    apply (simp add: eval_nat_numeral)
    by (auto simp add: card_le_Suc_iff)
  thus "?card3 X"
    using Finite_Set.card_subset_eq \<open>card X = 3\<close>
    apply (simp add: eval_nat_numeral)
    by (smt (verit, ccfv_threshold) \<open>{x, y, z} \<subseteq> X\<close> card.empty card.infinite card_insert_if
      card_subset_eq empty_iff finite.emptyI insertE nat.distinct(1))
next
  show "?card3 X \<Longrightarrow> card X = 3"
    by (smt (z3) card.empty card.insert eval_nat_numeral(2) finite.intros(1) finite_insert insertE
      insert_absorb insert_not_empty numeral_3_eq_3 semiring_norm(26,27))
qed

lemma card_3_eq':
    "\<lbrakk>card X = 3; card {a,b,c} = 3; {a,b,c} \<subseteq>X\<rbrakk> \<Longrightarrow> X = {a,b,c}"
    "\<lbrakk>card X = 3; a \<in> X; b \<in> X; c \<in> X; a \<noteq> b; a \<noteq> c; b \<noteq> c\<rbrakk> \<Longrightarrow> X = {a,b,c}"
proof -
  show "\<lbrakk>card X = 3; card {a,b,c} = 3; {a,b,c} \<subseteq>X\<rbrakk> \<Longrightarrow> X = {a,b,c}"
    by (metis card.infinite card_subset_eq zero_neq_numeral)
  thus "\<lbrakk>card X = 3; a \<in> X; b \<in> X; c \<in> X; a \<noteq> b; a \<noteq> c; b \<noteq> c\<rbrakk> \<Longrightarrow> X = {a,b,c}"
    by (meson card_3_dist empty_subsetI insert_subset)
qed

lemma card_4_eq:
  "card X = 4 \<longleftrightarrow> (\<exists>S\<^sub>1. \<exists>S\<^sub>2. \<exists>S\<^sub>3. \<exists>S\<^sub>4. X = {S\<^sub>1, S\<^sub>2, S\<^sub>3, S\<^sub>4} \<and>
    S\<^sub>1 \<noteq> S\<^sub>2 \<and> S\<^sub>1 \<noteq> S\<^sub>3 \<and> S\<^sub>1 \<noteq> S\<^sub>4 \<and> S\<^sub>2 \<noteq> S\<^sub>3 \<and> S\<^sub>2 \<noteq> S\<^sub>4 \<and> S\<^sub>3 \<noteq> S\<^sub>4)"
  (is "card X = 4 \<longleftrightarrow> ?card4 X")
proof
  assume "card X = 4"
  hence "card X \<ge> 4" by auto
  then obtain S\<^sub>1 S\<^sub>2 S\<^sub>3 S\<^sub>4 where
    0: "S\<^sub>1\<in>X \<and> S\<^sub>2\<in>X \<and> S\<^sub>3\<in>X \<and> S\<^sub>4\<in>X" and
    1: "S\<^sub>1 \<noteq> S\<^sub>2 \<and> S\<^sub>1 \<noteq> S\<^sub>3 \<and> S\<^sub>1 \<noteq> S\<^sub>4 \<and> S\<^sub>2 \<noteq> S\<^sub>3 \<and> S\<^sub>2 \<noteq> S\<^sub>4 \<and> S\<^sub>3 \<noteq> S\<^sub>4"
    apply (simp add: eval_nat_numeral)
    by (auto simp add: card_le_Suc_iff)
  then have 2: "{S\<^sub>1, S\<^sub>2, S\<^sub>3, S\<^sub>4} \<subseteq> X" "card {S\<^sub>1, S\<^sub>2, S\<^sub>3, S\<^sub>4} = 4" by auto
  have "X = {S\<^sub>1, S\<^sub>2, S\<^sub>3, S\<^sub>4}"
    using Finite_Set.card_subset_eq \<open>card X = 4\<close>
    apply (simp add: eval_nat_numeral)
    by (smt (z3) \<open>card X = 4\<close> 2 card.infinite card_subset_eq nat.distinct(1))
  thus "?card4 X" using 1 by blast
next
  show "?card4 X \<Longrightarrow> card X = 4"
    by (smt (z3) card.empty card.insert eval_nat_numeral(2) finite.intros(1) finite_insert insertE
      insert_absorb insert_not_empty numeral_3_eq_3 semiring_norm(26,27))
qed

text \<open>These lemmas make life easier with some of the ordering proofs.\<close>

lemma less_3_cases: "n < 3 \<Longrightarrow> n = 0 \<or> n = Suc 0 \<or> n = Suc (Suc 0)"
  by auto

end


theory E2_11
  imports Main
begin

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

fun eval :: "exp \<Rightarrow> int \<Rightarrow> int" where
  "eval Var x = x" |
  "eval (Const e) x = e" |
  "eval (Add lhs rhs) x = (eval lhs x) + (eval rhs x)" |
  "eval (Mult lhs rhs) x = (eval lhs x) * (eval rhs x)"

fun evalp :: "int list \<Rightarrow> int \<Rightarrow> int" where
  "evalp [] v = 0" |
  "evalp (x # xs) v = x + v * (evalp xs v)"

fun add_coeffs :: "int list \<Rightarrow> int list \<Rightarrow> int list" where
  "add_coeffs [] rhs = rhs" |
  "add_coeffs lhs [] = lhs" |
  "add_coeffs (x # xs) (y # ys) = (x + y) # (add_coeffs xs ys)"

fun mul_coeffs :: "int list \<Rightarrow> int list \<Rightarrow> int list" where
  "mul_coeffs [] ys = []" |
  "mul_coeffs (x # xs) ys = add_coeffs (map ((*) x) ys) (0 # (mul_coeffs xs ys))"

fun coeffs :: "exp \<Rightarrow> int list" where
  "coeffs Var = [0, 1]" |
  "coeffs (Const c) = [c]" |
  "coeffs (Add lhs rhs) = add_coeffs (coeffs lhs) (coeffs rhs)" |
  "coeffs (Mult lhs rhs) = mul_coeffs (coeffs lhs) (coeffs rhs)"

lemma addcl [simp] : "evalp (add_coeffs A B) x = evalp A x + evalp B x"
  apply(induction A B rule: add_coeffs.induct)
  by (auto simp add: algebra_simps)

lemma mulcc [simp] : "evalp (map ((*) a) ys) x = a * evalp ys x"
  apply(induction ys)
  by (auto simp add: algebra_simps)

lemma mulcl [simp] : "evalp (mul_coeffs A B) x = evalp A x * evalp B x"
  apply(induction A arbitrary: B x)
  by (auto simp add: algebra_simps)

lemma "evalp (coeffs e) x = eval e x"
  apply(induction e rule: coeffs.induct)
  by (auto simp add: algebra_simps)

end


theory day1
  imports Main
begin
(*datatype bool = True | False*)
fun nnot :: "bool \<Rightarrow> bool" where
  "nnot True = False" |
  "nnot False = True"
value "nnot True"

fun conj :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
  "conj True True = True"|
  "conj _ _ = False"
value "conj True False"

(*datatype nat = Zero | Suc nat*)
(*self make is harm*)
value "Zero"
fun add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "add 0 n = n"|
  "add (Suc m) n = Suc(add m n)"
value "add (Suc (Suc 0))(Suc 0)"

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

thm add_02(*you can check theorem*)

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

(*ex2.2*)
lemma add_comm[simp]: "add m n = add n m"
  apply(induction n)
    apply(simp)
  apply(auto)
  done

lemma add_exch[simp]: "add (add x y) z = add x (add y z)"
  apply(induction x)
   apply(auto)
  done

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

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

(*datatype 'a list = Nil | Cons 'a "'a list"*)
value "Cons (Suc Zero) (Cons Zero Nil)"
value "Cons True (Cons False (Cons True Nil))"

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

value "app (Cons True (Cons True Nil))(Cons False Nil)"

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

value "rev (Cons True (Cons False (Cons True (Cons False Nil))))"

lemma revrev_rev[simp]: "rev (app left right) = app (rev left)(rev right)"
  sorry

lemma rev_def[simp]: "rev (rev m) = m"
  sorry

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

value "count True (Cons True (Cons False (Cons True Nil)))"
  value "length (Cons True (Cons True Nil))"

lemma count_less[simp]: "count x xs \<le> length xs"
  apply(induction xs)
   apply(auto)
  done

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

value "sum_upto (Suc (Suc (Suc 0)))"
  value "(Suc 0)*2"

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

fun even::"nat \<Rightarrow> bool" where
  "even 0 = True"|
  "even (Suc x) = (if (even x) then False else True)"

fun match::"bool \<Rightarrow> bool \<Rightarrow> bool" where
  "match True True = True"|
  "match False False = True"|
  "match _ _ = False"

lemma mid[simp]: "even (a + b) = match (even a)(even b)"
  apply(induction a)
    apply(induction b)
    apply(auto)
  sorry

lemma winter: "even (Suc(Suc(Suc(Suc 0))) * n) = True"
  apply(induction n)
   apply(auto)
  done

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

end


theory E2_6
  imports Main
begin

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

fun contents :: "'a tree \<Rightarrow> 'a list" where
  "contents Tip = []" |
  "contents (Node l v r) = v # ((contents l) @ (contents r))"

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

lemma "sum_tree t = sum_list (contents t)"
  apply(induction t)
  apply(auto)
  done

end


(*  Title:      RSAPSS/Cryptinverts.thy
    Author:     Christina Lindenberg, Kai Wirt, Technische Universität Darmstadt
    Copyright:  2005 - Technische Universität Darmstadt
*)

section "Correctness proof for RSA"

theory Cryptinverts
imports  Crypt Productdivides  "HOL-Number_Theory.Residues"
begin

text \<open>
  In this theory we show, that a RSA encrypted message can be decrypted
\<close>

primrec pred:: "nat \<Rightarrow> nat"
where
  "pred 0 = 0"
| "pred (Suc a) = a"

lemma pred_unfold:
  "pred n = n - 1"
  by (induct n) simp_all

lemma fermat:
  assumes "prime p" "m mod p \<noteq> 0"
  shows "m^(p-(1::nat)) mod p = 1"
proof -
  from assms have "[m ^ (p - 1) = 1] (mod p)"
    using fermat_theorem [of p m] by (simp add: mod_eq_0_iff_dvd)
  then show ?thesis
    using \<open>prime p\<close> prime_gt_1_nat [of p] by (simp add: cong_def)
qed

lemma cryptinverts_hilf1: "prime p \<Longrightarrow> (m * m ^(k * pred p)) mod p = m mod p"
  apply (cases "m mod p = 0")
  apply (simp add: mod_mult_left_eq)
  apply (simp only: mult.commute [of k "pred p"]
    power_mult mod_mult_right_eq [of "m" "(m^pred p)^k" "p"]
    remainderexp [of "m^pred p" "p" "k", symmetric])
   apply (insert fermat [of p m], auto)
  apply (simp add: mult.commute [of k] power_mult pred_unfold)
  by (metis One_nat_def mod_mult_right_eq mult.right_neutral power_Suc_0 power_mod)

lemma cryptinverts_hilf2: "prime p \<Longrightarrow> m*(m^(k * (pred p) * (pred q))) mod p = m mod p"
  apply (simp add: mult.commute [of "k * pred p" "pred q"] mult.assoc [symmetric])
  apply (rule cryptinverts_hilf1 [of "p" "m" "(pred q) * k"])
  apply simp
  done

lemma cryptinverts_hilf3: "prime q \<Longrightarrow> m*(m^(k * (pred p) * (pred q))) mod q = m mod q"
  by (fact cryptinverts_hilf1)

lemma cryptinverts_hilf4:
  "m ^ x mod (p * q) = m" if "prime p" "prime q" "p \<noteq> q"
    "m < p * q" "x mod (pred p * pred q) = 1"
proof (cases x)
  case 0
  with that show ?thesis
    by simp
next
  case (Suc x)
  with that(5) have "Suc x mod (pred p * pred q) = Suc 0"
    by simp
  then have "pred p * pred q dvd x"
    using dvd_minus_mod [of "(pred p * pred q)" "Suc x"]
    by simp
  then obtain y where "x = pred p * pred q * y" ..
  then have "m ^ Suc x mod p = m mod p" and "m ^ Suc x mod q = m mod q"
    using cryptinverts_hilf2 [of p m y q, OF \<open>prime p\<close>]
      cryptinverts_hilf3 [of q m y p, OF \<open>prime q\<close>]
    by (simp_all add: ac_simps)
  with that Suc show ?thesis
    by (auto intro: specializedtoprimes1a)
qed

lemma primmultgreater: fixes p::nat shows "\<lbrakk> prime p; prime q; p \<noteq> 2; q \<noteq> 2\<rbrakk> \<Longrightarrow> 2 < p*q"
  apply (simp add: prime_nat_iff)
  apply (insert mult_le_mono [of 2 p 2 q])
  apply auto
  done

lemma primmultgreater2: fixes p::nat shows "\<lbrakk>prime p; prime q; p \<noteq> q\<rbrakk> \<Longrightarrow>  2 < p*q"
  apply (cases "p = 2")
   apply simp+
  apply (simp add: prime_nat_iff)
  apply (cases "q = 2")
   apply (simp add: prime_nat_iff)
  apply (erule primmultgreater)
  apply auto
  done

lemma cryptinverts: "\<lbrakk> prime p; prime q; p \<noteq> q; n = p*q; m < n;
    e*d mod ((pred p)*(pred q)) = 1\<rbrakk> \<Longrightarrow> rsa_crypt (rsa_crypt m e n) d n = m"
  apply (insert cryptinverts_hilf4 [of p q m "e*d"])
  apply (insert cryptcorrect [of "p*q" "rsa_crypt m e (p * q)" d])
  apply (insert cryptcorrect [of "p*q" m e])
  apply (insert primmultgreater2 [of p q])
  apply (simp add: prime_nat_iff)
  apply (simp add: cryptcorrect remainderexp [of "m^e" "p*q" d] power_mult [symmetric])
  done

end


(*
  File:    Misc.thy
  Authors: Max W. Haslbeck, Manuel Eberl
*)
section \<open>Auxiliary material\<close>
theory Misc
  imports "HOL-Analysis.Analysis"
begin

text \<open>Based on @{term sorted_list_of_set} and @{term the_inv_into} we construct a bijection between
  a finite set A of type 'a::linorder and a set of natural numbers @{term "{..< card A}"}\<close>

lemma bij_betw_mono_on_the_inv_into:
  fixes A::"'a::linorder set" and B::"'b::linorder set"
  assumes b: "bij_betw f A B" and m: "mono_on f A"
  shows "mono_on (the_inv_into A f) B"
proof (rule ccontr)
  assume "\<not> mono_on (the_inv_into A f) B"
  then have "\<exists>r s. r \<in> B \<and> s \<in> B \<and> r \<le> s \<and> \<not> the_inv_into A f s \<ge> the_inv_into A f r"
    unfolding mono_on_def by blast
  then obtain r s where rs: "r \<in> B" "s \<in> B" "r \<le> s" "the_inv_into A f s < the_inv_into A f r"
    by fastforce
  have f: "f (the_inv_into A f b) = b" if "b \<in> B" for b
    using that assms f_the_inv_into_f_bij_betw by metis
  have "the_inv_into A f s \<in> A" "the_inv_into A f r \<in> A"
    using rs assms by (auto simp add: bij_betw_def the_inv_into_into)
  then have "f (the_inv_into A f s) \<le> f (the_inv_into A f r)"
   using rs by (intro mono_onD[OF m]) (auto)
  then have "r = s"
    using rs f by simp
  then show False
    using rs by auto
qed

lemma rev_removeAll_removeAll_rev: "rev (removeAll x xs) = removeAll x (rev xs)"
  by (simp add: removeAll_filter_not_eq rev_filter)

lemma sorted_list_of_set_Min_Cons:
  assumes "finite A" "A \<noteq> {}"
  shows "sorted_list_of_set A = Min A # sorted_list_of_set (A - {Min A})"
proof -
  have *: "A = insert (Min A) A"
    using assms Min_in by (auto)
  then have "sorted_list_of_set A = insort (Min A) (sorted_list_of_set (A - {Min A}))"
    using assms by (subst *, intro sorted_list_of_set_insert) auto
  also have "\<dots> = Min A # sorted_list_of_set (A - {Min A})"
    using assms by (intro insort_is_Cons) (auto)
  finally show ?thesis
    by simp
qed

lemma sorted_list_of_set_filter:
  assumes "finite A"
  shows "sorted_list_of_set ({x\<in>A. P x}) = filter P (sorted_list_of_set A)"
  using assms proof (induction "sorted_list_of_set A" arbitrary: A)
  case (Cons x xs)
  have x: "x \<in> A"
    using Cons sorted_list_of_set list.set_intros(1) by metis
  have "sorted_list_of_set A = Min A # sorted_list_of_set (A - {Min A})"
    using Cons by (intro sorted_list_of_set_Min_Cons) auto
  then have 1: "x = Min A" "xs = sorted_list_of_set (A - {x})"
    using Cons by auto
  { assume Px: "P x"
    have 2: "sorted_list_of_set {x \<in> A. P x} = Min {x \<in> A. P x} # sorted_list_of_set ({x \<in> A. P x} - {Min {x \<in> A. P x}})"
      using Px Cons 1 sorted_list_of_set_eq_Nil_iff
      by (intro sorted_list_of_set_Min_Cons) fastforce+
    also have 3: "Min {x \<in> A. P x} = x"
      using Cons 1 Px x by (auto intro!: Min_eqI)
    also have 4: "{x \<in> A. P x} - {x} = {y \<in> A - {x}. P y}"
      by blast
    also have 5: "sorted_list_of_set {y \<in> A - {x}. P y} = filter P (sorted_list_of_set (A - {x}))"
      using 1 Cons by (intro Cons) (auto)
    also have "\<dots> = filter P xs"
      using 1 by simp
    also have "filter P (sorted_list_of_set A) = x # filter P xs"
      using Px by (simp flip: \<open>x # xs = sorted_list_of_set A\<close>)
    finally have ?case
      by auto }
  moreover
  { assume Px: "\<not> P x"
    then have "{x \<in> A. P x} = {y \<in> A - {x}. P y}"
      by blast
    also have "sorted_list_of_set \<dots> = filter P (sorted_list_of_set (A - {x}))"
      using 1 Cons by (intro Cons) auto
    also have  "filter P (sorted_list_of_set (A - {x})) = filter P (sorted_list_of_set A)"
      using 1 Px by (simp flip: \<open>x # xs = sorted_list_of_set A\<close>)
    finally have ?case
      by simp }
  ultimately show ?case
    by blast
qed (use sorted_list_of_set_eq_Nil_iff in fastforce)

lemma sorted_list_of_set_Max_snoc:
  assumes "finite A" "A \<noteq> {}"
  shows "sorted_list_of_set A = sorted_list_of_set (A - {Max A}) @ [Max A]"
proof -
  have *: "A = insert (Max A) A"
    using assms Max_in by (auto)
  then have "sorted_list_of_set A = insort (Max A) (sorted_list_of_set (A - {Max A}))"
    using assms by (subst *, intro sorted_list_of_set_insert) auto
  also have "\<dots> = sorted_list_of_set (A - {Max A}) @ [Max A]"
    using assms by (intro sorted_insort_is_snoc) (auto)
  finally show ?thesis
    by simp
qed

lemma sorted_list_of_set_image:
  assumes "mono_on g A" "inj_on g A"
  shows "(sorted_list_of_set (g ` A)) = map g (sorted_list_of_set A)"
proof (cases "finite A")
  case True
  then show ?thesis
    using assms proof (induction "sorted_list_of_set A" arbitrary: A)
    case Nil
    then show ?case
      using sorted_list_of_set_eq_Nil_iff by fastforce
  next
    case (Cons x xs A)
    have not_empty_A: "A \<noteq> {}"
      using Cons sorted_list_of_set_eq_Nil_iff by auto
    have *: "Min (g ` A) = g (Min A)"
    proof -
      have "g (Min A) \<le> g a" if "a \<in> A" for a
        using that Cons Min_in Min_le not_empty_A by (auto intro!: mono_onD[of g])
      then show ?thesis
        using Cons not_empty_A by (intro Min_eqI) auto
    qed
    have "g ` A \<noteq> {}" "finite (g ` A)"
      using Cons by auto
    then have "(sorted_list_of_set (g ` A)) =
             Min (g ` A) # sorted_list_of_set ((g ` A) - {Min (g ` A)})"
      by (auto simp add: sorted_list_of_set_Min_Cons)
    also have "(g ` A) - {Min (g ` A)} = g ` (A - {Min A})"
      using Cons Min_in not_empty_A * by (subst inj_on_image_set_diff[of _ A]) auto
    also have "sorted_list_of_set (g ` (A - {Min A})) = map g (sorted_list_of_set (A - {Min A}))"
      using not_empty_A Cons mono_on_subset[of _ A "A - {Min A}"] inj_on_subset[of _ A "A - {Min A}"]
      by (intro Cons) (auto simp add: sorted_list_of_set_Min_Cons)
    finally show ?case
      using Cons not_empty_A * by (auto simp add: sorted_list_of_set_Min_Cons)
  qed
next
  case False
  then show ?thesis
    using assms by (simp add: finite_image_iff)
qed

lemma sorted_list_of_set_length: "length (sorted_list_of_set A) = card A"
  using distinct_card sorted_list_of_set[of A] by (cases "finite A") fastforce+

lemma sorted_list_of_set_bij_betw:
  assumes "finite A"
  shows "bij_betw (\<lambda>n. sorted_list_of_set A ! n) {..<card A} A"
  by (rule bij_betw_nth) (fastforce simp add: assms sorted_list_of_set_length)+

lemma nth_mono_on:
  assumes "sorted xs" "distinct xs" "set xs = A"
  shows "mono_on (\<lambda>n. xs ! n) {..<card A}"
  using assms by (intro mono_onI sorted_nth_mono) (auto simp add: distinct_card)

lemma sorted_list_of_set_mono_on:
  "finite A \<Longrightarrow> mono_on (\<lambda>n. sorted_list_of_set A ! n) {..<card A}"
  by (rule nth_mono_on) (auto)

definition bij_mono_map_set_to_nat :: "'a::linorder set \<Rightarrow> 'a \<Rightarrow> nat" where
  "bij_mono_map_set_to_nat A =
    (\<lambda>x. if x \<in> A then the_inv_into {..<card A} ((!) (sorted_list_of_set A)) x
                  else card A)"

lemma bij_mono_map_set_to_nat:
  assumes "finite A"
  shows "bij_betw (bij_mono_map_set_to_nat A) A {..<card A}"
        "mono_on (bij_mono_map_set_to_nat A) A"
        "(bij_mono_map_set_to_nat A) ` A = {..<card A}"
proof -
  let ?f = "bij_mono_map_set_to_nat A"
  have "bij_betw (the_inv_into {..<card A} ((!) (sorted_list_of_set A))) A {..<card A}"
    using assms sorted_list_of_set_bij_betw  bij_betw_the_inv_into by blast
  moreover have "bij_betw (the_inv_into {..<card A} ((!) (sorted_list_of_set A))) A {..<card A}
                     = bij_betw ?f A {..<card A}"
    unfolding bij_mono_map_set_to_nat_def by (rule bij_betw_cong) simp
  ultimately show *: "bij_betw (bij_mono_map_set_to_nat A) A {..<card A}"
    by blast
  have "mono_on (the_inv_into {..<card A} ((!) (sorted_list_of_set A))) A"
    using assms sorted_list_of_set_bij_betw
      sorted_list_of_set_mono_on by (intro bij_betw_mono_on_the_inv_into) auto
  then show "mono_on (bij_mono_map_set_to_nat A) A"
    unfolding bij_mono_map_set_to_nat_def using mono_onD by (intro mono_onI) (auto)
  show "?f ` A = {..<card A}"
      using assms bij_betw_imp_surj_on * by blast
qed

end