(*  Title:      HOL/Library/AList.thy
    Author:     Norbert Schirmer, Tobias Nipkow, Martin Wildmoser, TU Muenchen
*)

section \<open>Implementation of Association Lists\<close>

theory AList
  imports Main
begin

context
begin

text \<open>
  The operations preserve distinctness of keys and
  function @{term "clearjunk"} distributes over them. Since
  @{term clearjunk} enforces distinctness of keys it can be used
  to establish the invariant, e.g. for inductive proofs.
\<close>

subsection \<open>\<open>update\<close> and \<open>updates\<close>\<close>

qualified primrec update :: "'key \<Rightarrow> 'val \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
  where
    "update k v [] = [(k, v)]"
  | "update k v (p # ps) = (if fst p = k then (k, v) # ps else p # update k v ps)"

lemma update_conv': "map_of (update k v al)  = (map_of al)(k\<mapsto>v)"
  by (induct al) (auto simp add: fun_eq_iff)

corollary update_conv: "map_of (update k v al) k' = ((map_of al)(k\<mapsto>v)) k'"
  by (simp add: update_conv')

lemma dom_update: "fst ` set (update k v al) = {k} \<union> fst ` set al"
  by (induct al) auto

lemma update_keys:
  "map fst (update k v al) =
    (if k \<in> set (map fst al) then map fst al else map fst al @ [k])"
  by (induct al) simp_all

lemma distinct_update:
  assumes "distinct (map fst al)"
  shows "distinct (map fst (update k v al))"
  using assms by (simp add: update_keys)

lemma update_filter:
  "a \<noteq> k \<Longrightarrow> update k v [q\<leftarrow>ps. fst q \<noteq> a] = [q\<leftarrow>update k v ps. fst q \<noteq> a]"
  by (induct ps) auto

lemma update_triv: "map_of al k = Some v \<Longrightarrow> update k v al = al"
  by (induct al) auto

lemma update_nonempty [simp]: "update k v al \<noteq> []"
  by (induct al) auto

lemma update_eqD: "update k v al = update k v' al' \<Longrightarrow> v = v'"
proof (induct al arbitrary: al')
  case Nil
  then show ?case
    by (cases al') (auto split: if_split_asm)
next
  case Cons
  then show ?case
    by (cases al') (auto split: if_split_asm)
qed

lemma update_last [simp]: "update k v (update k v' al) = update k v al"
  by (induct al) auto

text \<open>Note that the lists are not necessarily the same:
        @{term "update k v (update k' v' []) = [(k', v'), (k, v)]"} and
        @{term "update k' v' (update k v []) = [(k, v), (k', v')]"}.\<close>

lemma update_swap:
  "k \<noteq> k' \<Longrightarrow> map_of (update k v (update k' v' al)) = map_of (update k' v' (update k v al))"
  by (simp add: update_conv' fun_eq_iff)

lemma update_Some_unfold:
  "map_of (update k v al) x = Some y \<longleftrightarrow>
    x = k \<and> v = y \<or> x \<noteq> k \<and> map_of al x = Some y"
  by (simp add: update_conv' map_upd_Some_unfold)

lemma image_update [simp]: "x \<notin> A \<Longrightarrow> map_of (update x y al) ` A = map_of al ` A"
  by (simp add: update_conv')

qualified definition updates ::
    "'key list \<Rightarrow> 'val list \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
  where "updates ks vs = fold (case_prod update) (zip ks vs)"

lemma updates_simps [simp]:
  "updates [] vs ps = ps"
  "updates ks [] ps = ps"
  "updates (k#ks) (v#vs) ps = updates ks vs (update k v ps)"
  by (simp_all add: updates_def)

lemma updates_key_simp [simp]:
  "updates (k # ks) vs ps =
    (case vs of [] \<Rightarrow> ps | v # vs \<Rightarrow> updates ks vs (update k v ps))"
  by (cases vs) simp_all

lemma updates_conv': "map_of (updates ks vs al) = (map_of al)(ks[\<mapsto>]vs)"
proof -
  have "map_of \<circ> fold (case_prod update) (zip ks vs) =
      fold (\<lambda>(k, v) f. f(k \<mapsto> v)) (zip ks vs) \<circ> map_of"
    by (rule fold_commute) (auto simp add: fun_eq_iff update_conv')
  then show ?thesis
    by (auto simp add: updates_def fun_eq_iff map_upds_fold_map_upd foldl_conv_fold split_def)
qed

lemma updates_conv: "map_of (updates ks vs al) k = ((map_of al)(ks[\<mapsto>]vs)) k"
  by (simp add: updates_conv')

lemma distinct_updates:
  assumes "distinct (map fst al)"
  shows "distinct (map fst (updates ks vs al))"
proof -
  have "distinct (fold
       (\<lambda>(k, v) al. if k \<in> set al then al else al @ [k])
       (zip ks vs) (map fst al))"
    by (rule fold_invariant [of "zip ks vs" "\<lambda>_. True"]) (auto intro: assms)
  moreover have "map fst \<circ> fold (case_prod update) (zip ks vs) =
      fold (\<lambda>(k, v) al. if k \<in> set al then al else al @ [k]) (zip ks vs) \<circ> map fst"
    by (rule fold_commute) (simp add: update_keys split_def case_prod_beta comp_def)
  ultimately show ?thesis
    by (simp add: updates_def fun_eq_iff)
qed

lemma updates_append1[simp]: "size ks < size vs \<Longrightarrow>
    updates (ks@[k]) vs al = update k (vs!size ks) (updates ks vs al)"
  by (induct ks arbitrary: vs al) (auto split: list.splits)

lemma updates_list_update_drop[simp]:
  "size ks \<le> i \<Longrightarrow> i < size vs \<Longrightarrow>
    updates ks (vs[i:=v]) al = updates ks vs al"
  by (induct ks arbitrary: al vs i) (auto split: list.splits nat.splits)

lemma update_updates_conv_if:
  "map_of (updates xs ys (update x y al)) =
    map_of
     (if x \<in> set (take (length ys) xs)
      then updates xs ys al
      else (update x y (updates xs ys al)))"
  by (simp add: updates_conv' update_conv' map_upd_upds_conv_if)

lemma updates_twist [simp]:
  "k \<notin> set ks \<Longrightarrow>
    map_of (updates ks vs (update k v al)) = map_of (update k v (updates ks vs al))"
  by (simp add: updates_conv' update_conv')

lemma updates_apply_notin [simp]:
  "k \<notin> set ks \<Longrightarrow> map_of (updates ks vs al) k = map_of al k"
  by (simp add: updates_conv)

lemma updates_append_drop [simp]:
  "size xs = size ys \<Longrightarrow> updates (xs @ zs) ys al = updates xs ys al"
  by (induct xs arbitrary: ys al) (auto split: list.splits)

lemma updates_append2_drop [simp]:
  "size xs = size ys \<Longrightarrow> updates xs (ys @ zs) al = updates xs ys al"
  by (induct xs arbitrary: ys al) (auto split: list.splits)

subsection \<open>\<open>delete\<close>\<close>

qualified definition delete :: "'key \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
  where delete_eq: "delete k = filter (\<lambda>(k', _). k \<noteq> k')"

lemma delete_simps [simp]:
  "delete k [] = []"
  "delete k (p # ps) = (if fst p = k then delete k ps else p # delete k ps)"
  by (auto simp add: delete_eq)

lemma delete_conv': "map_of (delete k al) = (map_of al)(k := None)"
  by (induct al) (auto simp add: fun_eq_iff)

corollary delete_conv: "map_of (delete k al) k' = ((map_of al)(k := None)) k'"
  by (simp add: delete_conv')

lemma delete_keys: "map fst (delete k al) = removeAll k (map fst al)"
  by (simp add: delete_eq removeAll_filter_not_eq filter_map split_def comp_def)

lemma distinct_delete:
  assumes "distinct (map fst al)"
  shows "distinct (map fst (delete k al))"
  using assms by (simp add: delete_keys distinct_removeAll)

lemma delete_id [simp]: "k \<notin> fst ` set al \<Longrightarrow> delete k al = al"
  by (auto simp add: image_iff delete_eq filter_id_conv)

lemma delete_idem: "delete k (delete k al) = delete k al"
  by (simp add: delete_eq)

lemma map_of_delete [simp]: "k' \<noteq> k \<Longrightarrow> map_of (delete k al) k' = map_of al k'"
  by (simp add: delete_conv')

lemma delete_notin_dom: "k \<notin> fst ` set (delete k al)"
  by (auto simp add: delete_eq)

lemma dom_delete_subset: "fst ` set (delete k al) \<subseteq> fst ` set al"
  by (auto simp add: delete_eq)

lemma delete_update_same: "delete k (update k v al) = delete k al"
  by (induct al) simp_all

lemma delete_update: "k \<noteq> l \<Longrightarrow> delete l (update k v al) = update k v (delete l al)"
  by (induct al) simp_all

lemma delete_twist: "delete x (delete y al) = delete y (delete x al)"
  by (simp add: delete_eq conj_commute)

lemma length_delete_le: "length (delete k al) \<le> length al"
  by (simp add: delete_eq)

subsection \<open>\<open>update_with_aux\<close> and \<open>delete_aux\<close>\<close>

qualified primrec update_with_aux ::
    "'val \<Rightarrow> 'key \<Rightarrow> ('val \<Rightarrow> 'val) \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
  where
    "update_with_aux v k f [] = [(k, f v)]"
  | "update_with_aux v k f (p # ps) =
      (if (fst p = k) then (k, f (snd p)) # ps else p # update_with_aux v k f ps)"

text \<open>
  The above @{term "delete"} traverses all the list even if it has found the key.
  This one does not have to keep going because is assumes the invariant that keys are distinct.
\<close>
qualified fun delete_aux :: "'key \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
  where
    "delete_aux k [] = []"
  | "delete_aux k ((k', v) # xs) = (if k = k' then xs else (k', v) # delete_aux k xs)"

lemma map_of_update_with_aux':
  "map_of (update_with_aux v k f ps) k' =
    ((map_of ps)(k \<mapsto> (case map_of ps k of None \<Rightarrow> f v | Some v \<Rightarrow> f v))) k'"
  by (induct ps) auto

lemma map_of_update_with_aux:
  "map_of (update_with_aux v k f ps) =
    (map_of ps)(k \<mapsto> (case map_of ps k of None \<Rightarrow> f v | Some v \<Rightarrow> f v))"
  by (simp add: fun_eq_iff map_of_update_with_aux')

lemma dom_update_with_aux: "fst ` set (update_with_aux v k f ps) = {k} \<union> fst ` set ps"
  by (induct ps) auto

lemma distinct_update_with_aux [simp]:
  "distinct (map fst (update_with_aux v k f ps)) = distinct (map fst ps)"
  by (induct ps) (auto simp add: dom_update_with_aux)

lemma set_update_with_aux:
  "distinct (map fst xs) \<Longrightarrow>
    set (update_with_aux v k f xs) =
      (set xs - {k} \<times> UNIV \<union> {(k, f (case map_of xs k of None \<Rightarrow> v | Some v \<Rightarrow> v))})"
  by (induct xs) (auto intro: rev_image_eqI)

lemma set_delete_aux: "distinct (map fst xs) \<Longrightarrow> set (delete_aux k xs) = set xs - {k} \<times> UNIV"
  apply (induct xs)
   apply simp_all
  apply clarsimp
  apply (fastforce intro: rev_image_eqI)
  done

lemma dom_delete_aux: "distinct (map fst ps) \<Longrightarrow> fst ` set (delete_aux k ps) = fst ` set ps - {k}"
  by (auto simp add: set_delete_aux)

lemma distinct_delete_aux [simp]: "distinct (map fst ps) \<Longrightarrow> distinct (map fst (delete_aux k ps))"
proof (induct ps)
  case Nil
  then show ?case by simp
next
  case (Cons a ps)
  obtain k' v where a: "a = (k', v)"
    by (cases a)
  show ?case
  proof (cases "k' = k")
    case True
    with Cons a show ?thesis by simp
  next
    case False
    with Cons a have "k' \<notin> fst ` set ps" "distinct (map fst ps)"
      by simp_all
    with False a have "k' \<notin> fst ` set (delete_aux k ps)"
      by (auto dest!: dom_delete_aux[where k=k])
    with Cons a show ?thesis
      by simp
  qed
qed

lemma map_of_delete_aux':
  "distinct (map fst xs) \<Longrightarrow> map_of (delete_aux k xs) = (map_of xs)(k := None)"
  apply (induct xs)
   apply (fastforce simp add: map_of_eq_None_iff fun_upd_twist)
  apply (auto intro!: ext)
  apply (simp add: map_of_eq_None_iff)
  done

lemma map_of_delete_aux:
  "distinct (map fst xs) \<Longrightarrow> map_of (delete_aux k xs) k' = ((map_of xs)(k := None)) k'"
  by (simp add: map_of_delete_aux')

lemma delete_aux_eq_Nil_conv: "delete_aux k ts = [] \<longleftrightarrow> ts = [] \<or> (\<exists>v. ts = [(k, v)])"
  by (cases ts) (auto split: if_split_asm)

subsection \<open>\<open>restrict\<close>\<close>

qualified definition restrict :: "'key set \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
  where restrict_eq: "restrict A = filter (\<lambda>(k, v). k \<in> A)"

lemma restr_simps [simp]:
  "restrict A [] = []"
  "restrict A (p#ps) = (if fst p \<in> A then p # restrict A ps else restrict A ps)"
  by (auto simp add: restrict_eq)

lemma restr_conv': "map_of (restrict A al) = ((map_of al)|` A)"
proof
  show "map_of (restrict A al) k = ((map_of al)|` A) k" for k
    apply (induct al)
     apply simp
    apply (cases "k \<in> A")
     apply auto
    done
qed

corollary restr_conv: "map_of (restrict A al) k = ((map_of al)|` A) k"
  by (simp add: restr_conv')

lemma distinct_restr: "distinct (map fst al) \<Longrightarrow> distinct (map fst (restrict A al))"
  by (induct al) (auto simp add: restrict_eq)

lemma restr_empty [simp]:
  "restrict {} al = []"
  "restrict A [] = []"
  by (induct al) (auto simp add: restrict_eq)

lemma restr_in [simp]: "x \<in> A \<Longrightarrow> map_of (restrict A al) x = map_of al x"
  by (simp add: restr_conv')

lemma restr_out [simp]: "x \<notin> A \<Longrightarrow> map_of (restrict A al) x = None"
  by (simp add: restr_conv')

lemma dom_restr [simp]: "fst ` set (restrict A al) = fst ` set al \<inter> A"
  by (induct al) (auto simp add: restrict_eq)

lemma restr_upd_same [simp]: "restrict (-{x}) (update x y al) = restrict (-{x}) al"
  by (induct al) (auto simp add: restrict_eq)

lemma restr_restr [simp]: "restrict A (restrict B al) = restrict (A\<inter>B) al"
  by (induct al) (auto simp add: restrict_eq)

lemma restr_update[simp]:
  "map_of (restrict D (update x y al)) =
    map_of ((if x \<in> D then (update x y (restrict (D-{x}) al)) else restrict D al))"
  by (simp add: restr_conv' update_conv')

lemma restr_delete [simp]:
  "delete x (restrict D al) = (if x \<in> D then restrict (D - {x}) al else restrict D al)"
  apply (simp add: delete_eq restrict_eq)
  apply (auto simp add: split_def)
proof -
  have "y \<noteq> x \<longleftrightarrow> x \<noteq> y" for y
    by auto
  then show "[p \<leftarrow> al. fst p \<in> D \<and> x \<noteq> fst p] = [p \<leftarrow> al. fst p \<in> D \<and> fst p \<noteq> x]"
    by simp
  assume "x \<notin> D"
  then have "y \<in> D \<longleftrightarrow> y \<in> D \<and> x \<noteq> y" for y
    by auto
  then show "[p \<leftarrow> al . fst p \<in> D \<and> x \<noteq> fst p] = [p \<leftarrow> al . fst p \<in> D]"
    by simp
qed

lemma update_restr:
  "map_of (update x y (restrict D al)) = map_of (update x y (restrict (D - {x}) al))"
  by (simp add: update_conv' restr_conv') (rule fun_upd_restrict)

lemma update_restr_conv [simp]:
  "x \<in> D \<Longrightarrow>
    map_of (update x y (restrict D al)) = map_of (update x y (restrict (D - {x}) al))"
  by (simp add: update_conv' restr_conv')

lemma restr_updates [simp]:
  "length xs = length ys \<Longrightarrow> set xs \<subseteq> D \<Longrightarrow>
    map_of (restrict D (updates xs ys al)) =
      map_of (updates xs ys (restrict (D - set xs) al))"
  by (simp add: updates_conv' restr_conv')

lemma restr_delete_twist: "(restrict A (delete a ps)) = delete a (restrict A ps)"
  by (induct ps) auto

subsection \<open>\<open>clearjunk\<close>\<close>

qualified function clearjunk  :: "('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
  where
    "clearjunk [] = []"
  | "clearjunk (p#ps) = p # clearjunk (delete (fst p) ps)"
  by pat_completeness auto
termination
  by (relation "measure length") (simp_all add: less_Suc_eq_le length_delete_le)

lemma map_of_clearjunk: "map_of (clearjunk al) = map_of al"
  by (induct al rule: clearjunk.induct) (simp_all add: fun_eq_iff)

lemma clearjunk_keys_set: "set (map fst (clearjunk al)) = set (map fst al)"
  by (induct al rule: clearjunk.induct) (simp_all add: delete_keys)

lemma dom_clearjunk: "fst ` set (clearjunk al) = fst ` set al"
  using clearjunk_keys_set by simp

lemma distinct_clearjunk [simp]: "distinct (map fst (clearjunk al))"
  by (induct al rule: clearjunk.induct) (simp_all del: set_map add: clearjunk_keys_set delete_keys)

lemma ran_clearjunk: "ran (map_of (clearjunk al)) = ran (map_of al)"
  by (simp add: map_of_clearjunk)

lemma ran_map_of: "ran (map_of al) = snd ` set (clearjunk al)"
proof -
  have "ran (map_of al) = ran (map_of (clearjunk al))"
    by (simp add: ran_clearjunk)
  also have "\<dots> = snd ` set (clearjunk al)"
    by (simp add: ran_distinct)
  finally show ?thesis .
qed

lemma clearjunk_update: "clearjunk (update k v al) = update k v (clearjunk al)"
  by (induct al rule: clearjunk.induct) (simp_all add: delete_update)

lemma clearjunk_updates: "clearjunk (updates ks vs al) = updates ks vs (clearjunk al)"
proof -
  have "clearjunk \<circ> fold (case_prod update) (zip ks vs) =
      fold (case_prod update) (zip ks vs) \<circ> clearjunk"
    by (rule fold_commute) (simp add: clearjunk_update case_prod_beta o_def)
  then show ?thesis
    by (simp add: updates_def fun_eq_iff)
qed

lemma clearjunk_delete: "clearjunk (delete x al) = delete x (clearjunk al)"
  by (induct al rule: clearjunk.induct) (auto simp add: delete_idem delete_twist)

lemma clearjunk_restrict: "clearjunk (restrict A al) = restrict A (clearjunk al)"
  by (induct al rule: clearjunk.induct) (auto simp add: restr_delete_twist)

lemma distinct_clearjunk_id [simp]: "distinct (map fst al) \<Longrightarrow> clearjunk al = al"
  by (induct al rule: clearjunk.induct) auto

lemma clearjunk_idem: "clearjunk (clearjunk al) = clearjunk al"
  by simp

lemma length_clearjunk: "length (clearjunk al) \<le> length al"
proof (induct al rule: clearjunk.induct [case_names Nil Cons])
  case Nil
  then show ?case by simp
next
  case (Cons kv al)
  moreover have "length (delete (fst kv) al) \<le> length al"
    by (fact length_delete_le)
  ultimately have "length (clearjunk (delete (fst kv) al)) \<le> length al"
    by (rule order_trans)
  then show ?case
    by simp
qed

lemma delete_map:
  assumes "\<And>kv. fst (f kv) = fst kv"
  shows "delete k (map f ps) = map f (delete k ps)"
  by (simp add: delete_eq filter_map comp_def split_def assms)

lemma clearjunk_map:
  assumes "\<And>kv. fst (f kv) = fst kv"
  shows "clearjunk (map f ps) = map f (clearjunk ps)"
  by (induct ps rule: clearjunk.induct [case_names Nil Cons])
    (simp_all add: clearjunk_delete delete_map assms)

subsection \<open>\<open>map_ran\<close>\<close>

definition map_ran :: "('key \<Rightarrow> 'val \<Rightarrow> 'val) \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
  where "map_ran f = map (\<lambda>(k, v). (k, f k v))"

lemma map_ran_simps [simp]:
  "map_ran f [] = []"
  "map_ran f ((k, v) # ps) = (k, f k v) # map_ran f ps"
  by (simp_all add: map_ran_def)

lemma dom_map_ran: "fst ` set (map_ran f al) = fst ` set al"
  by (simp add: map_ran_def image_image split_def)

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

lemma distinct_map_ran: "distinct (map fst al) \<Longrightarrow> distinct (map fst (map_ran f al))"
  by (simp add: map_ran_def split_def comp_def)

lemma map_ran_filter: "map_ran f [p\<leftarrow>ps. fst p \<noteq> a] = [p\<leftarrow>map_ran f ps. fst p \<noteq> a]"
  by (simp add: map_ran_def filter_map split_def comp_def)

lemma clearjunk_map_ran: "clearjunk (map_ran f al) = map_ran f (clearjunk al)"
  by (simp add: map_ran_def split_def clearjunk_map)

subsection \<open>\<open>merge\<close>\<close>

qualified definition merge :: "('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
  where "merge qs ps = foldr (\<lambda>(k, v). update k v) ps qs"

lemma merge_simps [simp]:
  "merge qs [] = qs"
  "merge qs (p#ps) = update (fst p) (snd p) (merge qs ps)"
  by (simp_all add: merge_def split_def)

lemma merge_updates: "merge qs ps = updates (rev (map fst ps)) (rev (map snd ps)) qs"
  by (simp add: merge_def updates_def foldr_conv_fold zip_rev zip_map_fst_snd)

lemma dom_merge: "fst ` set (merge xs ys) = fst ` set xs \<union> fst ` set ys"
  by (induct ys arbitrary: xs) (auto simp add: dom_update)

lemma distinct_merge: "distinct (map fst xs) \<Longrightarrow> distinct (map fst (merge xs ys))"
  by (simp add: merge_updates distinct_updates)

lemma clearjunk_merge: "clearjunk (merge xs ys) = merge (clearjunk xs) ys"
  by (simp add: merge_updates clearjunk_updates)

lemma merge_conv': "map_of (merge xs ys) = map_of xs ++ map_of ys"
proof -
  have "map_of \<circ> fold (case_prod update) (rev ys) =
      fold (\<lambda>(k, v) m. m(k \<mapsto> v)) (rev ys) \<circ> map_of"
    by (rule fold_commute) (simp add: update_conv' case_prod_beta split_def fun_eq_iff)
  then show ?thesis
    by (simp add: merge_def map_add_map_of_foldr foldr_conv_fold fun_eq_iff)
qed

corollary merge_conv: "map_of (merge xs ys) k = (map_of xs ++ map_of ys) k"
  by (simp add: merge_conv')

lemma merge_empty: "map_of (merge [] ys) = map_of ys"
  by (simp add: merge_conv')

lemma merge_assoc [simp]: "map_of (merge m1 (merge m2 m3)) = map_of (merge (merge m1 m2) m3)"
  by (simp add: merge_conv')

lemma merge_Some_iff:
  "map_of (merge m n) k = Some x \<longleftrightarrow>
    map_of n k = Some x \<or> map_of n k = None \<and> map_of m k = Some x"
  by (simp add: merge_conv' map_add_Some_iff)

lemmas merge_SomeD [dest!] = merge_Some_iff [THEN iffD1]

lemma merge_find_right [simp]: "map_of n k = Some v \<Longrightarrow> map_of (merge m n) k = Some v"
  by (simp add: merge_conv')

lemma merge_None [iff]: "(map_of (merge m n) k = None) = (map_of n k = None \<and> map_of m k = None)"
  by (simp add: merge_conv')

lemma merge_upd [simp]: "map_of (merge m (update k v n)) = map_of (update k v (merge m n))"
  by (simp add: update_conv' merge_conv')

lemma merge_updatess [simp]:
  "map_of (merge m (updates xs ys n)) = map_of (updates xs ys (merge m n))"
  by (simp add: updates_conv' merge_conv')

lemma merge_append: "map_of (xs @ ys) = map_of (merge ys xs)"
  by (simp add: merge_conv')

subsection \<open>\<open>compose\<close>\<close>

qualified function compose :: "('key \<times> 'a) list \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> ('key \<times> 'b) list"
  where
    "compose [] ys = []"
  | "compose (x # xs) ys =
      (case map_of ys (snd x) of
        None \<Rightarrow> compose (delete (fst x) xs) ys
      | Some v \<Rightarrow> (fst x, v) # compose xs ys)"
  by pat_completeness auto
termination
  by (relation "measure (length \<circ> fst)") (simp_all add: less_Suc_eq_le length_delete_le)

lemma compose_first_None [simp]: "map_of xs k = None \<Longrightarrow> map_of (compose xs ys) k = None"
  by (induct xs ys rule: compose.induct) (auto split: option.splits if_split_asm)

lemma compose_conv: "map_of (compose xs ys) k = (map_of ys \<circ>\<^sub>m map_of xs) k"
proof (induct xs ys rule: compose.induct)
  case 1
  then show ?case by simp
next
  case (2 x xs ys)
  show ?case
  proof (cases "map_of ys (snd x)")
    case None
    with 2 have hyp: "map_of (compose (delete (fst x) xs) ys) k =
        (map_of ys \<circ>\<^sub>m map_of (delete (fst x) xs)) k"
      by simp
    show ?thesis
    proof (cases "fst x = k")
      case True
      from True delete_notin_dom [of k xs]
      have "map_of (delete (fst x) xs) k = None"
        by (simp add: map_of_eq_None_iff)
      with hyp show ?thesis
        using True None
        by simp
    next
      case False
      from False have "map_of (delete (fst x) xs) k = map_of xs k"
        by simp
      with hyp show ?thesis
        using False None by (simp add: map_comp_def)
    qed
  next
    case (Some v)
    with 2
    have "map_of (compose xs ys) k = (map_of ys \<circ>\<^sub>m map_of xs) k"
      by simp
    with Some show ?thesis
      by (auto simp add: map_comp_def)
  qed
qed

lemma compose_conv': "map_of (compose xs ys) = (map_of ys \<circ>\<^sub>m map_of xs)"
  by (rule ext) (rule compose_conv)

lemma compose_first_Some [simp]: "map_of xs k = Some v \<Longrightarrow> map_of (compose xs ys) k = map_of ys v"
  by (simp add: compose_conv)

lemma dom_compose: "fst ` set (compose xs ys) \<subseteq> fst ` set xs"
proof (induct xs ys rule: compose.induct)
  case 1
  then show ?case by simp
next
  case (2 x xs ys)
  show ?case
  proof (cases "map_of ys (snd x)")
    case None
    with "2.hyps" have "fst ` set (compose (delete (fst x) xs) ys) \<subseteq> fst ` set (delete (fst x) xs)"
      by simp
    also have "\<dots> \<subseteq> fst ` set xs"
      by (rule dom_delete_subset)
    finally show ?thesis
      using None by auto
  next
    case (Some v)
    with "2.hyps" have "fst ` set (compose xs ys) \<subseteq> fst ` set xs"
      by simp
    with Some show ?thesis
      by auto
  qed
qed

lemma distinct_compose:
  assumes "distinct (map fst xs)"
  shows "distinct (map fst (compose xs ys))"
  using assms
proof (induct xs ys rule: compose.induct)
  case 1
  then show ?case by simp
next
  case (2 x xs ys)
  show ?case
  proof (cases "map_of ys (snd x)")
    case None
    with 2 show ?thesis by simp
  next
    case (Some v)
    with 2 dom_compose [of xs ys] show ?thesis
      by auto
  qed
qed

lemma compose_delete_twist: "compose (delete k xs) ys = delete k (compose xs ys)"
proof (induct xs ys rule: compose.induct)
  case 1
  then show ?case by simp
next
  case (2 x xs ys)
  show ?case
  proof (cases "map_of ys (snd x)")
    case None
    with 2 have hyp: "compose (delete k (delete (fst x) xs)) ys =
        delete k (compose (delete (fst x) xs) ys)"
      by simp
    show ?thesis
    proof (cases "fst x = k")
      case True
      with None hyp show ?thesis
        by (simp add: delete_idem)
    next
      case False
      from None False hyp show ?thesis
        by (simp add: delete_twist)
    qed
  next
    case (Some v)
    with 2 have hyp: "compose (delete k xs) ys = delete k (compose xs ys)"
      by simp
    with Some show ?thesis
      by simp
  qed
qed

lemma compose_clearjunk: "compose xs (clearjunk ys) = compose xs ys"
  by (induct xs ys rule: compose.induct)
    (auto simp add: map_of_clearjunk split: option.splits)

lemma clearjunk_compose: "clearjunk (compose xs ys) = compose (clearjunk xs) ys"
  by (induct xs rule: clearjunk.induct)
    (auto split: option.splits simp add: clearjunk_delete delete_idem compose_delete_twist)

lemma compose_empty [simp]: "compose xs [] = []"
  by (induct xs) (auto simp add: compose_delete_twist)

lemma compose_Some_iff:
  "(map_of (compose xs ys) k = Some v) \<longleftrightarrow>
    (\<exists>k'. map_of xs k = Some k' \<and> map_of ys k' = Some v)"
  by (simp add: compose_conv map_comp_Some_iff)

lemma map_comp_None_iff:
  "map_of (compose xs ys) k = None \<longleftrightarrow>
    (map_of xs k = None \<or> (\<exists>k'. map_of xs k = Some k' \<and> map_of ys k' = None))"
  by (simp add: compose_conv map_comp_None_iff)

subsection \<open>\<open>map_entry\<close>\<close>

qualified fun map_entry :: "'key \<Rightarrow> ('val \<Rightarrow> 'val) \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
  where
    "map_entry k f [] = []"
  | "map_entry k f (p # ps) =
      (if fst p = k then (k, f (snd p)) # ps else p # map_entry k f ps)"

lemma map_of_map_entry:
  "map_of (map_entry k f xs) =
    (map_of xs)(k := case map_of xs k of None \<Rightarrow> None | Some v' \<Rightarrow> Some (f v'))"
  by (induct xs) auto

lemma dom_map_entry: "fst ` set (map_entry k f xs) = fst ` set xs"
  by (induct xs) auto

lemma distinct_map_entry:
  assumes "distinct (map fst xs)"
  shows "distinct (map fst (map_entry k f xs))"
  using assms by (induct xs) (auto simp add: dom_map_entry)

subsection \<open>\<open>map_default\<close>\<close>

fun map_default :: "'key \<Rightarrow> 'val \<Rightarrow> ('val \<Rightarrow> 'val) \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
  where
    "map_default k v f [] = [(k, v)]"
  | "map_default k v f (p # ps) =
      (if fst p = k then (k, f (snd p)) # ps else p # map_default k v f ps)"

lemma map_of_map_default:
  "map_of (map_default k v f xs) =
    (map_of xs)(k := case map_of xs k of None \<Rightarrow> Some v | Some v' \<Rightarrow> Some (f v'))"
  by (induct xs) auto

lemma dom_map_default: "fst ` set (map_default k v f xs) = insert k (fst ` set xs)"
  by (induct xs) auto

lemma distinct_map_default:
  assumes "distinct (map fst xs)"
  shows "distinct (map fst (map_default k v f xs))"
  using assms by (induct xs) (auto simp add: dom_map_default)

end

end


theory MyFirst
  imports Main

begin
lemma two_two: "2 + 2 = 4"
  by auto


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

datatype Nat = Z | S "Nat"

fun le :: "Nat => Nat => bool" where
"le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

fun ge :: "Nat => Nat => bool" where
"ge x y = le y x"

theorem property0 :
  "ge x x"
  oops

end


(*  Title:      HOL/Datatype_Examples/Derivation_Trees/DTree.thy
    Author:     Andrei Popescu, TU Muenchen
    Copyright   2012

Derivation trees with nonterminal internal nodes and terminal leaves.
*)

section {* Trees with Nonterminal Internal Nodes and Terminal Leaves *}

theory DTree
imports Prelim
begin

typedecl N
typedecl T

codatatype dtree = NNode (root: N) (ccont: "(T + dtree) fset")

subsection{* Transporting the Characteristic Lemmas from @{text "fset"} to @{text "set"} *}

definition "Node n as \<equiv> NNode n (the_inv fset as)"
definition "cont \<equiv> fset o ccont"
definition "unfold rt ct \<equiv> corec_dtree rt (the_inv fset o image (map_sum id Inr) o ct)"
definition "corec rt ct \<equiv> corec_dtree rt (the_inv fset o ct)"

lemma finite_cont[simp]: "finite (cont tr)"
  unfolding cont_def comp_apply by (cases tr, clarsimp)

lemma Node_root_cont[simp]:
  "Node (root tr) (cont tr) = tr"
  unfolding Node_def cont_def comp_apply
  apply (rule trans[OF _ dtree.collapse])
  apply (rule arg_cong2[OF refl the_inv_into_f_f[unfolded inj_on_def]])
  apply (simp_all add: fset_inject)
  done

lemma dtree_simps[simp]:
assumes "finite as" and "finite as'"
shows "Node n as = Node n' as' \<longleftrightarrow> n = n' \<and> as = as'"
using assms dtree.inject unfolding Node_def
by (metis fset_to_fset)

lemma dtree_cases[elim, case_names Node Choice]:
assumes Node: "\<And> n as. \<lbrakk>finite as; tr = Node n as\<rbrakk> \<Longrightarrow> phi"
shows phi
apply(cases rule: dtree.exhaust[of tr])
using Node unfolding Node_def
by (metis Node Node_root_cont finite_cont)

lemma dtree_sel_ctr[simp]:
"root (Node n as) = n"
"finite as \<Longrightarrow> cont (Node n as) = as"
unfolding Node_def cont_def by auto

lemmas root_Node = dtree_sel_ctr(1)
lemmas cont_Node = dtree_sel_ctr(2)

lemma dtree_cong:
assumes "root tr = root tr'" and "cont tr = cont tr'"
shows "tr = tr'"
by (metis Node_root_cont assms)

lemma rel_set_cont:
"rel_set \<chi> (cont tr1) (cont tr2) = rel_fset \<chi> (ccont tr1) (ccont tr2)"
unfolding cont_def comp_def rel_fset_fset ..

lemma dtree_coinduct[elim, consumes 1, case_names Lift, induct pred: "HOL.eq"]:
assumes phi: "\<phi> tr1 tr2" and
Lift: "\<And> tr1 tr2. \<phi> tr1 tr2 \<Longrightarrow>
                  root tr1 = root tr2 \<and> rel_set (rel_sum op = \<phi>) (cont tr1) (cont tr2)"
shows "tr1 = tr2"
using phi apply(elim dtree.coinduct)
apply(rule Lift[unfolded rel_set_cont]) .

lemma unfold:
"root (unfold rt ct b) = rt b"
"finite (ct b) \<Longrightarrow> cont (unfold rt ct b) = image (id \<oplus> unfold rt ct) (ct b)"
using dtree.corec_sel[of rt "the_inv fset o image (map_sum id Inr) o ct" b] unfolding unfold_def
apply blast
unfolding cont_def comp_def
by (simp add: case_sum_o_inj map_sum.compositionality image_image)

lemma corec:
"root (corec rt ct b) = rt b"
"finite (ct b) \<Longrightarrow> cont (corec rt ct b) = image (id \<oplus> ([[id, corec rt ct]])) (ct b)"
using dtree.corec_sel[of rt "the_inv fset \<circ> ct" b] unfolding corec_def
unfolding cont_def comp_def id_def
by simp_all

end


theory ND_FiniteAssms
imports ND
begin

lemma ND_finite_assms: "\<Gamma> \<turnstile> F \<Longrightarrow> \<exists>\<Gamma>'. \<Gamma>' \<subseteq> \<Gamma> \<and> finite \<Gamma>' \<and> (\<Gamma>' \<turnstile> F)"
proof(induction rule: ND.induct)
  case (Ax F \<Gamma>) thus ?case by(intro exI[of _ "{F}"]) (simp add: ND.Ax)
next
  case (AndI \<Gamma> F G)
  from AndI.IH(1) guess \<Gamma>1 .. moreover
  from AndI.IH(2) guess \<Gamma>2 .. ultimately
  show ?case by(intro exI[where x="\<Gamma>1\<union>\<Gamma>2"]) (force elim: Weaken intro!: ND.AndI)
next
  case (CC F \<Gamma>)
  from CC.IH guess \<Gamma>' .. note \<Gamma>' = this
  thus ?case proof(cases "Not F \<in> \<Gamma>'") text\<open>case distinction: Did we actually use @{term "\<^bold>\<not>F"}?\<close>
    case False hence "\<Gamma>' \<subseteq> \<Gamma>" using \<Gamma>' by blast
    with \<Gamma>' show ?thesis using BotE by(intro exI[where x="\<Gamma>'"]) fast
  next
    case True
    then obtain \<Gamma>'' where "\<Gamma>' = \<^bold>\<not> F\<triangleright>\<Gamma>''" "\<^bold>\<not> F \<notin> \<Gamma>''" by (meson Set.set_insert)
    hence "\<Gamma>'' \<subseteq> \<Gamma>" "finite \<Gamma>''" "\<^bold>\<not> F\<triangleright>\<Gamma>'' \<turnstile> \<bottom>" using \<Gamma>' by auto
    thus ?thesis using ND.CC by auto
  qed
next
  case AndE1 thus ?case by(blast dest: ND.AndE1) next
  case AndE2 thus ?case by(blast dest: ND.AndE2)
next
  case OrI1 thus ?case by(blast dest: ND.OrI1) next
  case OrI2 thus ?case by(blast dest: ND.OrI2)
next
  case (OrE \<Gamma> F G H)
  from OrE.IH(1) guess \<Gamma>1 .. moreover
  from OrE.IH(2) guess \<Gamma>2 .. moreover
  from OrE.IH(3) guess \<Gamma>3 ..
  note IH = calculation this
  let ?w = "\<Gamma>1 \<union> (\<Gamma>2 - {F}) \<union> (\<Gamma>3 - {G})"
  from IH have "?w \<turnstile> F \<^bold>\<or> G" using Weaken[OF _ sup_ge1] by metis moreover
  from IH have "F\<triangleright>?w \<turnstile> H" "G\<triangleright>?w \<turnstile> H" using Weaken by (metis Un_commute Un_insert_right Un_upper1 Weaken insert_Diff_single)+ ultimately
  have "?w \<turnstile> H" using ND.OrE by blast
  thus ?case using IH by(intro exI[where x="?w"]) auto
  text\<open>Clever evasion of the case distinction made for CC.\<close>
next
  case (ImpI F \<Gamma> G)
  from ImpI.IH guess \<Gamma>' ..
  thus ?case by (intro exI[where x="\<Gamma>' - {F}"]) (force elim: Weaken intro!: ND.ImpI)
next
  case (ImpE \<Gamma> F G)
  from ImpE.IH(1) guess \<Gamma>1 .. moreover
  from ImpE.IH(2) guess \<Gamma>2 .. ultimately
  show ?case by(intro exI[where x="\<Gamma>1 \<union> \<Gamma>2"]) (force elim: Weaken intro: ND.ImpE[where F=F])
next
  case (NotE \<Gamma> F)
  from NotE.IH(1) guess \<Gamma>1 .. moreover
  from NotE.IH(2) guess \<Gamma>2 .. ultimately
  show ?case by(intro exI[where x="\<Gamma>1 \<union> \<Gamma>2"]) (force elim: Weaken intro: ND.NotE[where F=F])
next
  case (NotI F \<Gamma>)
  from NotI.IH guess \<Gamma>' ..
  thus ?case by(intro exI[where x="\<Gamma>' - {F}"]) (force elim: Weaken intro: ND.NotI[where F=F])
qed

text\<open>We thought that a lemma like this would be necessary for the ND completeness by SC completeness proof
  (this lemma shows that if we made an ND proof, we can always limit ourselves to a finite set of assumptions --
   and thus put all the assumptions into one formula).
That is not the case, since in the completeness proof,
we assume a valid entailment and have to show (the existence of) a derivation.
The author hopes that his misunderstanding can help the reader's understanding.\<close>
corollary ND_no_assms:
  assumes "\<Gamma> \<turnstile> F"
  obtains \<Gamma>' where "set \<Gamma>' \<subseteq> \<Gamma> \<and> ({} \<turnstile> \<^bold>\<And>\<Gamma>' \<^bold>\<rightarrow> F)"
proof(goal_cases)
  case 1
  from ND_finite_assms[OF assms] obtain \<Gamma>' where "\<Gamma>'\<subseteq>\<Gamma>" "finite \<Gamma>'" "\<Gamma>' \<turnstile> F" by blast
  from \<open>finite \<Gamma>'\<close> obtain G where \<Gamma>'[simp]: "\<Gamma>' = set G"  using finite_list by blast
  with \<open>\<Gamma>'\<subseteq>\<Gamma>\<close> have "set G \<subseteq> \<Gamma>" by clarify
  moreover from \<open>\<Gamma>' \<turnstile> F\<close> have "{} \<turnstile> \<^bold>\<And> G \<^bold>\<rightarrow> F" unfolding \<Gamma>' AssmBigAnd .
  ultimately show ?case by(intro 1[where \<Gamma>'=G] conjI)
qed

end


theory Hypermap
  imports "Fun_Graph"
begin

section \<open>Hypermap\<close>

record 'a pre_hypermap =
  darts :: "'a set"
  edge :: "'a perm"
  node :: "'a perm"
  face :: "'a perm"

locale pre_hypermap =
  fixes H :: "'a pre_hypermap" (structure)

locale hypermap = pre_hypermap +
  assumes edgeK: "edge H (node H (face H x)) = x"
  and finite_darts: "finite (darts H)"
  and perm_edge: "edge H permutes darts H"
  and perm_node: "node H permutes darts H"
  and perm_face: "face H permutes darts H"
begin

text \<open>Basic properties of the functions\<close>
lemma nodeK: "node H (face H (edge H x)) = x"
  by (meson apply_inj_eq_iff edgeK)

lemma faceK: "face H (edge H (node H x)) = x"
  by (meson apply_inj_eq_iff nodeK)

lemma edge_inv: "inv (edge H) = node H * face H"
  by (metis apply_perm_sequence inverse_perm.rep_eq nodeK perm_edge perm_eqI
      permutes_surj surj_iff_all)

lemma node_inv: "inv (node H) = face H * edge H"
  by (metis Perm.apply_perm_inverse apply_perm_sequence faceK perm_eq_iff
      perm_node permutes_surj surj_iff_all)

lemma face_inv: "inv (face H) = edge H * node H"
  by (metis apply_perm_sequence inverse_perm.rep_eq edgeK perm_face perm_eqI
      permutes_surj surj_iff_all)
end

text \<open>Paths in the function graphs\<close>
definition cedge where
 "cedge h \<equiv> (Gr (darts h) (edge h))"

lemma (in hypermap) wf_cedge: "pair_wf_digraph (cedge H)"
  unfolding cedge_def by (simp add: perm_edge Gr_wf_perm)

lemma cedge_eq: "x \<in> darts h \<Longrightarrow> x\<rightarrow>\<^bsub>cedge h\<^esub>y \<longleftrightarrow> (edge h x = y)"
  by (metis Gr_eq cedge_def)

definition cnode where
 "cnode h \<equiv> (Gr (darts h) (node h))"

lemma (in hypermap) wf_cnode: "pair_wf_digraph (cnode H)"
  unfolding cnode_def by (simp add: perm_node Gr_wf_perm wf_digraph_wp_iff)

lemma cnode_eq: "x \<in> darts h \<Longrightarrow> x\<rightarrow>\<^bsub>cnode h\<^esub>y \<longleftrightarrow> (node h x = y)"
  by (metis Gr_eq cnode_def)

definition cface where
  "cface h \<equiv> (Gr (darts h) (face h))"

lemma (in hypermap) wf_cface: "pair_wf_digraph (cface H)"
  unfolding cface_def by (simp add: perm_face Gr_wf_perm)

lemma cface_eq: "x \<in> darts H \<Longrightarrow> x\<rightarrow>\<^bsub>cface H\<^esub>y \<longleftrightarrow> (face H x = y)"
  by (metis Gr_eq cface_def)

definition glink
  where "glink h = pair_union (cedge h) (pair_union (cnode h) (cface h))"

lemma (in hypermap) wf_glink: "pair_wf_digraph (glink H)"
  unfolding glink_def by (simp add: wf_cface wf_cnode wf_cedge wf_pair_union)

lemma verts_glink: "verts (glink H) = darts H"
  by (simp add: cedge_def cface_def cnode_def glink_def)

lemma (in hypermap) glink_enf:
  assumes "x \<in> darts H"
  shows "x\<rightarrow>\<^bsub>glink H\<^esub>y \<longleftrightarrow> edge H x = y \<or> node H x = y \<or> face H x = y"
  apply (rule iffI)
   apply (metis Gr_eq assms cedge_eq cface_def cnode_def glink_def pair_union_arcs_disj)
  by (metis assms cedge_eq cface_eq cnode_eq glink_def pair_union_arcs_disj)

context hypermap begin
lemma cedge_connect_sym: "wf_digraph.connect_sym (cedge H)"
  by (metis cedge_def perm_edge perm_on.intro perm_on.perm_connect_sym)

lemma cnode_connect_sym: "wf_digraph.connect_sym (cnode H)"
  by (metis cnode_def perm_node perm_on.intro perm_on.perm_connect_sym)

lemma cface_connect_sym: "wf_digraph.connect_sym (cface H)"
  by (metis cface_def perm_face perm_on.intro perm_on.perm_connect_sym)

lemma glink_connect_sym: "wf_digraph.connect_sym (glink H)"
proof -
  interpret pair_wf_digraph "glink H" by (simp add: wf_glink)
  have "v \<rightarrow>\<^sup>*\<^bsub>glink H\<^esub>u" if "u \<rightarrow>\<^sup>*\<^bsub>glink H\<^esub>v" for u v
  using that proof (induct rule: reachable_induct)
    case base
    then show ?case by simp
  next
    case (step x y)
    then have "y = edge H x \<or> y = node H x \<or> y = face H x"
      by (metis glink_def Gr_eq cedge_def cface_def cnode_def pair_union_arcs_disj with_proj_simps(3))
    also have "(y = edge H x \<longrightarrow> y \<rightarrow>\<^sup>*\<^bsub>cedge H\<^esub> x) \<and>
               (y = node H x \<longrightarrow> y \<rightarrow>\<^sup>*\<^bsub>cnode H\<^esub> x) \<and>
               (y = face H x \<longrightarrow> y \<rightarrow>\<^sup>*\<^bsub>cface H\<^esub> x)"
      by (metis Gr_eq cedge_connect_sym cnode_connect_sym cface_connect_sym cedge_def cface_def
          cnode_def glink_def pair_union_arcs_disj step.hyps(2) wf_cedge wf_cnode wf_cface
          wf_digraph.reach_sym_arc wf_digraph_wp_iff with_proj_simps(3))
    ultimately have "y \<rightarrow>\<^sup>*\<^bsub>cedge H\<^esub>x \<or> y \<rightarrow>\<^sup>*\<^bsub>cnode H\<^esub> x \<or> y \<rightarrow>\<^sup>*\<^bsub>cface H\<^esub> x"
      by fastforce
    then have "y \<rightarrow>\<^sup>*\<^bsub>glink H\<^esub> x"
      unfolding glink_def by (metis (no_types, hide_lams) reach_in_union comm_pair_union
          with_proj_union Gr_wf cedge_def cface_def cnode_def compatibleI_with_proj perm_edge
          perm_face perm_node permutes_in_image wellformed_union wf_digraph_wp_iff)
    then show "y \<rightarrow>\<^sup>*\<^bsub>glink H\<^esub> u"
      by (meson reachable_trans step.hyps(3))
  qed
  then show ?thesis unfolding connect_sym_def by blast
qed

definition "connected_hypermap \<equiv> strongly_connected (glink H)"
end

text \<open>All connected components are in the same equivalence class\<close>
section \<open>Genus\<close>
definition euler_rhs :: "'a pre_hypermap \<Rightarrow> nat" where
"euler_rhs h = count_cycles_on (darts h) (edge h) +
               count_cycles_on (darts h) (node h) +
               count_cycles_on (darts h) (face h)"

definition euler_lhs :: "'a pre_hypermap \<Rightarrow> nat" where
"euler_lhs h = card (pre_digraph.sccs (glink h)) * 2 + card (darts h)"

definition genus where
"genus h \<equiv> (euler_lhs h - euler_rhs h) div 2"

definition planar where
"planar h \<equiv> genus h = 0"

section \<open>Jordan\<close>

definition clink where
"clink h \<equiv> pair_union (cface h) ((cnode h)\<^sup>R)"

context hypermap
begin

lemma wf_clink: "pair_wf_digraph (clink H)"
  by (simp add: clink_def pair_wf_digraph.wf_reverse wf_cface wf_cnode wf_pair_union)

lemma finite_clink: "fin_digraph (clink H)"
  apply (auto simp add: fin_digraph_def wf_clink wf_digraph_wp_iff)
  by (simp add: cface_def clink_def cnode_def fin_digraph_axioms_def finite_darts
      perm_node perm_on.Gr_reverse_eq_inv perm_on.intro)

lemma verts_clink [simp]: "verts (clink H) = darts H"
  by (simp add: cface_def clink_def cnode_def perm_node perm_on.Gr_reverse_eq_inv perm_on.intro)

lemma clinkP: "(y\<rightarrow>\<^bsub>cnode H\<^esub> x \<or> x \<rightarrow>\<^bsub>cface H\<^esub> y) \<longleftrightarrow> x\<rightarrow>\<^bsub>clink H\<^esub> y"
  unfolding clink_def apply (rule iffI)
   apply (meson arc_reverse pair_union_arcs_disj)
  by (metis converse_iff pair_pre_digraph.select_convs(2)
      pair_union_arcs_disj reverse_def with_proj_simps(3))

lemma arc_clink: "x \<in> darts H \<Longrightarrow> x \<rightarrow>\<^bsub>clink H\<^esub>y \<longleftrightarrow> y = face H x \<or> x = node H y"
proof
  show "x \<rightarrow>\<^bsub>clink H\<^esub> y \<Longrightarrow> y = (face H) \<langle>$\<rangle> x \<or> x = (node H) \<langle>$\<rangle> y"
    by (metis Gr_eq cface_def clink_def cnode_def converse.cases pair_pre_digraph.select_convs(2)
      pair_union_arcs_disj reverse_def with_proj_simps(3))
  assume *:"x \<in> darts H" "y = face H x \<or> x = node H y"
  then show "x \<rightarrow>\<^bsub>clink H\<^esub>y"
    by (metis Gr_eq cface_def clinkP cnode_def perm_face perm_node permutes_in_image)
qed

lemma parcs_clink:
  assumes "a \<in> darts H"
  shows "(a,b) \<in> parcs (clink H) \<longleftrightarrow> a = node H b \<or> b = face H a"
  apply rule
   apply (metis arc_clink pair_wf_digraph.in_arcsD1 verts_clink wf_clink with_proj_simps(1,3))
  using assms arc_clink with_proj_simps(3) by blast

lemma clinkN: "x \<in> darts H \<Longrightarrow> node H x\<rightarrow>\<^bsub>clink H\<^esub>x"
  by (metis Gr_eq clinkP cnode_def)

lemma clinkF: "x \<in> darts H \<Longrightarrow> x\<rightarrow>\<^bsub>clink H\<^esub>face H x"
  by (metis Gr_eq cface_def hypermap.clinkP hypermap_axioms)

lemma clink_connect_sym: "wf_digraph.connect_sym (clink H)"
proof -
  interpret pair_wf_digraph "clink H" by (rule wf_clink)
  have "v \<rightarrow>\<^sup>*\<^bsub>clink H\<^esub>u \<Longrightarrow> u \<rightarrow>\<^sup>*\<^bsub>clink H\<^esub>v" for u v
  proof (induct rule: reachable_induct)
    case base
    then show ?case by simp
  next
    case (step x y)
    then consider (node) "x = node H y" | (face) "y = face H x"
      by (metis parcs_clink reachable_in_vertsE verts_clink)
    then have "y\<rightarrow>\<^sup>*\<^bsub>clink H\<^esub>x"
    proof cases
      case node
      then have "y \<rightarrow>\<^sup>*\<^bsub>(cnode H)\<^sup>R\<^esub> x"
        by (metis cnode_connect_sym cnode_eq head_in_verts reach_reverse snd_conv step.hyps(2)
            verts_clink wf_cnode wf_digraph.reach_sym_arc wf_digraph_wp_iff with_proj_simps(1))
      then show ?thesis
        by (metis (no_types, hide_lams) clink_def comm_pair_union compatibleI_with_proj
            pair_wf_digraph.wf_reverse reach_in_union wf_cface wf_cnode wf_digraph_wp_iff
            with_proj_union)
    next
      case face
      then have "y \<rightarrow>\<^sup>*\<^bsub>cface H\<^esub> x"
        by (metis Gr_eq cface_connect_sym cface_def reachable_in_vertsE step.hyps(3) verts_clink
            wf_cface wf_digraph.reach_sym_arc wf_digraph_wp_iff)
      then show ?thesis
        by (smt (verit, ccfv_threshold) clinkP in_arcsD2 reachable_adj_trans reachable_refl
            step.hyps(2) wf_cface wf_digraph.reachable_induct wf_digraph_wp_iff with_proj_simps(3))
    qed
    then show "y \<rightarrow>\<^sup>*\<^bsub>clink H\<^esub> v"
      by (meson reachable_trans step.hyps(3))
  qed
  then show ?thesis unfolding connect_sym_def by blast
qed

lemma clink_glink: "u \<rightarrow>\<^sup>*\<^bsub>clink H\<^esub>v \<longleftrightarrow> u \<rightarrow>\<^sup>*\<^bsub>glink H\<^esub>v" (is "?L \<longleftrightarrow> ?R")
proof
  interpret pair_wf_digraph "clink H" by (rule wf_clink)
  assume ?L then show ?R
  proof (induct rule: reachable_induct)
    case base
    then have "u \<in> darts H"
      by (metis Gr_pverts cface_def clink_def cnode_def pair_pre_digraph.simps(1) pair_union_def
          perm_node perm_on.Gr_reverse_eq_inv perm_on.intro sup.idem)
    then have "u \<in> pverts (glink H)"
      by (simp add: cedge_def glink_def pair_union_def)
    then show ?case
      by (simp add: wf_glink wf_digraph.reachable_refl wf_digraph_wp_iff)
  next
    case (step x y)
    then show ?case
      by (smt (verit, ccfv_SIG) clink_def converse_iff glink_connect_sym glink_def wf_glink
     pair_pre_digraph.simps(2) pair_union_arcs_disj reverse_def wf_digraph.reach_sym_arc
     wf_digraph.reachable_adj_trans wf_digraph.reachable_trans wf_digraph_wp_iff with_proj_simps(3))
  qed
next
  interpret pair_wf_digraph "glink H" by (rule wf_glink)
  assume ?R then show ?L
  proof (induct rule: reachable_induct)
    case base
    then show ?case
      by (metis Gr_verts Un_iff cedge_def cface_def clink_def cnode_def glink_def
          pair_pre_digraph.simps(1) pair_union_def wf_clink wf_digraph.reachable_refl
          wf_digraph_wp_iff with_proj_simps(1))
  next
    case (step x y)
    then consider (edge) "x\<rightarrow>\<^bsub>cedge H\<^esub>y" | (node) "x\<rightarrow>\<^bsub>cnode H\<^esub>y" | (face) "x\<rightarrow>\<^bsub>cface H\<^esub>y"
      by (metis with_proj_simps(3) glink_def pair_union_arcs_disj)
    then show ?case
      proof cases
        case edge
        then show ?thesis
          by (metis (no_types, hide_lams) step.hyps(3) wf_digraph.reachable_trans Gr_eq cedge_def
            clinkF clinkN clink_connect_sym fin_digraph.axioms(1) finite_clink hypermap.nodeK
            hypermap_axioms perm_edge perm_node permutes_in_image wf_digraph.adj_reachable_trans
            wf_digraph.reach_sym_arc)
      next
        case node
        then show ?thesis
          by (meson clinkP clink_connect_sym fin_digraph.axioms(1) finite_clink step.hyps(3)
              wf_digraph.adj_reachable_trans wf_digraph.connect_sym_def)
      next
        case face
        then show ?thesis
          by (metis Gr_eq cface_def clinkF fin_digraph.axioms(1) finite_clink step.hyps(3)
              wf_digraph.reachable_adj_trans)
      qed
   qed
qed

context begin
interpretation clink: pair_wf_digraph "clink H" by (rule wf_clink)

lemma connected_clink:
  assumes "connected_hypermap" "x \<in> (darts H)" "y \<in> (darts H)"
  shows "\<exists>p. clink.apath x p y"
proof -
  from assms have "x \<rightarrow>\<^sup>*\<^bsub>glink H\<^esub> y"
    by (metis connected_hypermap_def strongly_connected_def verts_glink)
  then show ?thesis
    using clink_glink clink.reachable_apath by simp
qed

text \<open>A "Moebius path" is a contour that cannot appear in a planar map, as it goes from the inside
      of a ring to the outside\<close>

fun moebius_path where
  "moebius_path [] = False"
| "moebius_path (_ # []) = False"
| "moebius_path (x # p) = (vpath (x#p) (clink H)
                    \<and> appears_before p (face H (edge H (last p))) (node H x))"

lemma moebius_path_length: "moebius_path p \<Longrightarrow> length p \<ge> 3"
proof -
  assume *: "moebius_path p"
  then have less_2: "False" if "length p < 2"
    using that hypermap.moebius_path.elims(2) hypermap_axioms by fastforce
  {
    assume "length p = 2"
    then obtain x y where "p = [x,y]"
      by (metis (no_types, hide_lams) One_nat_def Suc_1 length_0_conv length_Suc_conv)
    then have "x \<noteq> y"
      by (metis * distinct_length_2_or_more hypermap.moebius_path.simps(3) hypermap_axioms vpath_def)
    also have "appears_before [y] (face H (edge H y)) (node H x)"
      using * \<open>p = [x, y]\<close> by auto
    then have "x = y"
      by (metis appears_before_in empty_set faceK list.simps(15) singletonD)
    ultimately have False by simp
  }
  then show ?thesis
    using less_2 by force
qed

definition "jordan = (\<forall>p. \<not> (moebius_path p))"
end
end

section \<open>Dual walkups\<close>
definition "permN h \<equiv> \<lparr>darts = darts h, edge = node h, node = face h, face = edge h\<rparr>"

definition "permF h \<equiv> \<lparr>darts = darts h, edge = face h, node = edge h, face = node h\<rparr>"

context hypermap begin

lemma hypermap_permN: "hypermap (permN H)"
  by (simp add: finite_darts hypermap_def nodeK permN_def perm_edge perm_face perm_node)

lemma darts_permN: "darts (permN H) = darts H"
  by (simp add: permN_def)

lemma permN_connect1_glink: "x\<rightarrow>\<^bsub>glink H\<^esub>y \<longleftrightarrow> x\<rightarrow>\<^bsub>glink (permN H)\<^esub>y"
  by (metis (no_types, lifting) cedge_def cface_def cnode_def glink_def pair_union_arcs_disj
      permN_def pre_hypermap.select_convs(1-4))

lemma permN_glink: "glink H = glink (permN H)"
proof -
  have "verts (glink H) = verts (glink (permN H))"
    by (simp add: cedge_def cface_def cnode_def glink_def permN_def)
  also have "arcs (glink H) = arcs (glink (permN H))"
    apply (simp add: set_eq_iff)
    using permN_connect1_glink by auto
  ultimately show ?thesis
    by simp
qed

lemma connected_permN: "connected_hypermap \<Longrightarrow> hypermap.connected_hypermap (permN H)"
  by (simp add: connected_hypermap_def hypermap.connected_hypermap_def hypermap_permN permN_glink)

lemma genus_permN: "genus H = genus (permN H)"
proof -
  have "euler_lhs H = euler_lhs (permN H)"
    by (simp add: euler_lhs_def permN_def permN_glink)
  moreover have "euler_rhs H = euler_rhs (permN H)"
    by (simp add: euler_rhs_def permN_def)
  ultimately show ?thesis
    by (simp add: genus_def)
qed

lemma planar_permN: "planar H = planar (permN H)"
  by (simp add: genus_permN planar_def)

lemma hypermap_permF: "hypermap (permF H)"
  by (simp add: finite_darts hypermap_def faceK permF_def perm_edge perm_face perm_node)

lemma darts_permF: "darts (permF H) = darts H"
  by (simp add: permF_def)

lemma permF_connect1_glink: "x\<rightarrow>\<^bsub>glink H\<^esub>y \<longleftrightarrow> x\<rightarrow>\<^bsub>glink (permF H)\<^esub>y"
  by (metis (no_types, lifting) cedge_def cface_def cnode_def glink_def pair_union_arcs_disj
      permF_def pre_hypermap.select_convs(1,2,3,4))

lemma permF_glink: "glink H = glink (permF H)"
proof -
  have "verts (glink H) = verts (glink (permF H))"
    by (simp add: cedge_def cface_def cnode_def glink_def permF_def)
  also have "arcs (glink H) = arcs (glink (permF H))"
    apply (simp add: set_eq_iff)
    using permF_connect1_glink by auto
  ultimately show ?thesis
    by simp
qed

lemma connected_permF: "connected_hypermap \<Longrightarrow> hypermap.connected_hypermap (permF H)"
  by (simp add: connected_hypermap_def hypermap.connected_hypermap_def hypermap_permF permF_glink)

lemma genus_permF: "genus H = genus (permF H)"
proof -
  have "euler_lhs H = euler_lhs (permF H)"
    by (simp add: euler_lhs_def permF_def permF_glink)
  moreover have "euler_rhs H = euler_rhs (permF H)"
    by (simp add: euler_rhs_def permF_def)
  ultimately show ?thesis
    by (simp add: genus_def)
qed

lemma planar_permF: "planar H = planar (permF H)"
  by (simp add: genus_permF planar_def)

(*
definition dual :: "'a pre_hypermap" where
"dual = \<lparr>darts = darts H, edge = inverse (edge H), node = inverse (face H), face = inverse (node H)\<rparr>"

lemma "hypermap dual"
proof
  show "(edge dual) \<langle>$\<rangle> (node dual) \<langle>$\<rangle> (face dual) \<langle>$\<rangle> x = x" for x
    using dual_def nodeK by auto
  show "finite (darts dual)"
    by (simp add: dual_def finite_darts)
  show "edge dual permutes darts dual"
       "node dual permutes darts dual"
       "face dual permutes darts dual"
    by (simp_all add: perm_on.inverse_permutes dual_def perm_edge perm_node perm_face perm_on_def)
qed*)
end
end