header "Hash-Maps"
theory Hash_Map
  imports Hash_Table
begin

subsection {* Auxiliary Lemmas *}
lemma map_of_ls_update:
  "map_of (fst (ls_update k v l)) = (map_of l)(k \<mapsto> v)"
  apply (induct l rule: ls_update.induct)
  by (auto simp add: ext Let_def)

lemma map_of_concat:
  "k \<in> dom (map_of(concat l))
  \<Longrightarrow> \<exists>i. k \<in> dom (map_of(l!i)) \<and> i < length l"
  apply (induct l)
  apply simp
  apply auto
  apply (rule_tac x = 0 in exI)
  apply auto
  by (metis Suc_mono domI nth_Cons_Suc)

lemma map_of_concat':
  "k \<in> dom (map_of(l!i)) \<and> i < length l \<Longrightarrow> k \<in> dom (map_of(concat l))"
  apply (induct l arbitrary: i)
  apply simp
  apply auto
  apply (case_tac i)
  apply auto
  done

lemma map_of_concat''':
  "\<exists>i. k \<in> dom (map_of(l!i)) \<and> i < length l
  \<Longrightarrow> k \<in> dom (map_of(concat l))"
proof -
  case goal1
  from this obtain i where "k \<in> dom (map_of (l ! i)) \<and> i < length l" by blast
  from map_of_concat'[OF this] show ?thesis .
qed

lemma map_of_concat'':
  "(k \<in> dom (map_of(concat l)))
  \<longleftrightarrow> (\<exists>i. k \<in> dom (map_of(l!i)) \<and> i < length l)"
  apply rule
  using map_of_concat[of k l]
  apply simp
  using map_of_concat'[of k l]
  by blast

lemma abs_update_length: "length (abs_update k v l) = length l"
  by (simp add: abs_update_def)

lemma ls_update_map_of_eq:
  "map_of (fst (ls_update k v ls)) k = Some v"
  apply (induct ls rule: ls_update.induct)
  by (simp_all add: Let_def)

lemma ls_update_map_of_neq:
  "x \<noteq> k \<Longrightarrow> map_of (fst (ls_update k v ls)) x = map_of ls x"
  apply (induct ls rule: ls_update.induct)
  by (auto simp add: Let_def)

subsection {* Main Definitions and Lemmas *}

definition is_hashmap'
  :: "('k, 'v) map
    \<Rightarrow> ('k \<times> 'v) list list
    \<Rightarrow> ('k\<Colon>{heap,hashable}, 'v\<Colon>heap) hashtable
    \<Rightarrow> assn"
  where
  "is_hashmap' m l ht = is_hashtable l ht * \<up> (map_of (concat l) = m)"

definition is_hashmap
  :: "('k, 'v) map \<Rightarrow> ('k\<Colon>{heap,hashable}, 'v\<Colon>heap) hashtable \<Rightarrow> assn"
  where
  "is_hashmap m ht = (\<exists>\<^sub>Al. is_hashmap' m l ht)"

lemma is_hashmap'_prec:
  "\<forall>s s'. h\<Turnstile>(is_hashmap' m l ht * F1) \<and>\<^sub>A (is_hashmap' m' l' ht * F2)
  \<longrightarrow> l=l' \<and> m=m'"
  unfolding is_hashmap'_def
  apply (auto simp add: preciseD[OF is_hashtable_prec])
  apply (subgoal_tac "l = l'")
  by (auto simp add: preciseD[OF is_hashtable_prec])

lemma is_hashmap_prec: "precise is_hashmap"
  unfolding is_hashmap_def[abs_def]
  apply rule
  by (auto simp add: is_hashmap'_prec)

abbreviation "hm_new \<equiv> ht_new"
lemma hm_new_rule':
  "<emp>
  hm_new::('k\<Colon>{heap,hashable}, 'v\<Colon>heap) hashtable Heap
  <is_hashmap' Map.empty (replicate (def_hashmap_size TYPE('k)) [])>"
  apply (rule cons_post_rule)
  using complete_ht_new
  apply simp
  apply (simp add: is_hashmap'_def)
  done

lemma hm_new_rule:
  "<emp> hm_new <is_hashmap Map.empty>"
  apply (rule cons_post_rule)
  using complete_ht_new
  apply simp
  apply (simp add: is_hashmap_def is_hashmap'_def)
  apply sep_auto
  done

lemma ht_hash_distinct:
  "ht_hash l
  \<Longrightarrow> \<forall>i j . i\<noteq>j \<and> i < length l \<and> j < length l
    \<longrightarrow> set (l!i) \<inter> set (l!j) = {}"
  apply (auto simp add: ht_hash_def)
  apply metis
  done

lemma ht_hash_in_dom_in_dom_bounded_hashcode_nat:
  assumes "ht_hash l"
  assumes "k \<in> dom (map_of(concat l))"
  shows "k \<in> dom (map_of(l!bounded_hashcode_nat (length l) k))"
proof -
  from map_of_concat[OF assms(2)] obtain i
    where i: "k \<in> dom (map_of (l ! i)) \<and> i < length l"
    by blast
  thm ht_hash_def
  hence "\<exists>v. (k,v)\<in>set(l!i)" by (auto dest: map_of_SomeD)
  from this obtain v where v: "(k,v)\<in>set(l!i)" by blast
  from assms(1)[unfolded ht_hash_def] i v bounded_hashcode_nat_bounds
  have "bounded_hashcode_nat (length l) k = i"
    by (metis fst_conv)
  with i show ?thesis by simp
qed

lemma ht_hash_in_dom_bounded_hashcode_nat_in_dom:
  assumes "ht_hash l"
  assumes "1 < length l"
  assumes "k \<in> dom (map_of(l!bounded_hashcode_nat (length l) k))"
  shows "k \<in> dom (map_of(concat l))"
  using map_of_concat'[of k l "bounded_hashcode_nat (length l) k"]
    assms(2,3) bounded_hashcode_nat_bounds[of "length l" k]
  by simp

lemma ht_hash_in_dom_in_dom_bounded_hashcode_nat_eq:
  assumes "ht_hash l"
  assumes "1 < length l"
  shows "(k \<in> dom (map_of(concat l)))
  = (k \<in> dom (map_of(l!bounded_hashcode_nat (length l) k)))"
  apply rule
  using ht_hash_in_dom_in_dom_bounded_hashcode_nat[OF assms(1)]
    ht_hash_in_dom_bounded_hashcode_nat_in_dom[OF assms]
  by simp_all

lemma ht_hash_in_dom_i_bounded_hashcode_nat_i:
  assumes "ht_hash l"
  assumes "1 < length l"
  assumes "i < length l"
  assumes "k \<in> dom (map_of (l!i))"
  shows "i = bounded_hashcode_nat (length l) k"
  using assms
  using bounded_hashcode_nat_bounds
  by (auto simp add: ht_hash_def ht_distinct_def dom_map_of_conv_image_fst)

lemma ht_hash_in_bounded_hashcode_nat_not_i_not_in_dom_i:
  assumes "ht_hash l"
  assumes "1 < length l"
  assumes "i < length l"
  assumes "i \<noteq> bounded_hashcode_nat (length l) k"
  shows "k \<notin> dom (map_of (l!i))"
  using assms
  using bounded_hashcode_nat_bounds
  by (auto simp add: ht_hash_def ht_distinct_def dom_map_of_conv_image_fst)

lemma ht_hash_ht_distinct_in_dom_unique_value:
  assumes "ht_hash l"
  assumes "ht_distinct l"
  assumes "1 < length l"
  assumes "k \<in> dom (map_of (concat l))"
  shows "\<exists>!v. (k,v) \<in> set (concat l)"
proof -
  from assms(4) have ex: "\<exists>v. (k,v) \<in> set (concat l)"
    by (auto dest!: map_of_SomeD)
  have "\<forall>v w. (k,v) \<in> set (concat l) \<and> (k,w) \<in> set (concat l)
    \<longrightarrow> v = w"
  proof (intro allI impI, elim conjE)
    case goal1
    from ht_hash_in_dom_in_dom_bounded_hashcode_nat[OF assms(1,4)]
    have a: "k \<in> dom (map_of (l ! bounded_hashcode_nat (length l) k))" .
    have "\<forall>i. i < length l \<and> i \<noteq> bounded_hashcode_nat (length l) k
      \<longrightarrow> k \<notin> dom(map_of(l!i))"
    proof (intro allI impI, elim conjE)
      case goal1
      from ht_hash_in_bounded_hashcode_nat_not_i_not_in_dom_i[
        OF assms(1,3) goal1]
      show ?case .
    qed
    from goal1(1) a
    have v: "(k,v) \<in> set (l ! bounded_hashcode_nat (length l) k)"
    proof -
      case goal1
      from goal1(1) have "\<exists>i. i < length l \<and> (k, v) \<in> set (l!i)"
        by auto (metis in_set_conv_nth)
      from this obtain i where i: "i < length l \<and> (k, v) \<in> set (l!i)"
        by blast
      hence "k \<in> dom (map_of (l!i))"
        by (metis (no_types) PairE a assms(1) fst_conv ht_hash_def)
      from i ht_hash_in_dom_i_bounded_hashcode_nat_i[OF assms(1,3) _ this]
      have "i = bounded_hashcode_nat (length l) k" by simp
      with i show ?case by simp
    qed
    from goal1(2) a
    have w: "(k,w) \<in> set (l ! bounded_hashcode_nat (length l) k)"
    proof -
      case goal1
      from goal1(1) have "\<exists>i. i < length l \<and> (k, w) \<in> set (l!i)"
        by auto (metis in_set_conv_nth)
      from this obtain i where i: "i < length l \<and> (k, w) \<in> set (l!i)"
        by blast
      hence "k \<in> dom (map_of (l!i))"
        by (metis (no_types) PairE a assms(1) fst_conv ht_hash_def)
      from i ht_hash_in_dom_i_bounded_hashcode_nat_i[OF assms(1,3) _ this]
      have "i = bounded_hashcode_nat (length l) k" by simp
      with i show ?case by simp
    qed
    from assms(2,3) have
      "distinct (map fst (l ! bounded_hashcode_nat (length l) k))"
      by (simp add: ht_distinct_def bounded_hashcode_nat_bounds)
    from Map.map_of_is_SomeI[OF this v] Map.map_of_is_SomeI[OF this w]
    show "v = w" by simp
  qed
  with ex show ?thesis by blast
qed

lemma ht_hash_ht_distinct_map_of:
  assumes "ht_hash l"
  assumes "ht_distinct l"
  assumes "1 < length l"
  shows "map_of (concat l) k
  = map_of(l!bounded_hashcode_nat (length l) k) k"
proof (cases "k \<in> dom (map_of(concat l))")
  case False
  hence a: "map_of (concat l) k = None" by auto
  from ht_hash_in_dom_in_dom_bounded_hashcode_nat_eq[OF assms(1,3)] False
  have "k \<notin> dom (map_of (l ! bounded_hashcode_nat (length l) k))" by simp
  hence "map_of(l!bounded_hashcode_nat (length l) k) k = None" by auto
  with a show ?thesis by simp
next
  case True
  from True obtain y where y: "map_of (concat l) k = Some y" by auto
  hence a: "(k,y) \<in> set (concat l)" by (metis map_of_SomeD)
  from ht_hash_in_dom_in_dom_bounded_hashcode_nat_eq[OF assms(1,3)] True
  have "k \<in> dom (map_of (l ! bounded_hashcode_nat (length l) k))" by simp
  from this obtain z where
    z: "map_of(l!bounded_hashcode_nat (length l) k) k = Some z" by auto
  hence "(k,z) \<in> set (l ! bounded_hashcode_nat (length l) k)"
    by (metis map_of_SomeD)
  with bounded_hashcode_nat_bounds[OF assms(3), of k]
  have b: "(k,z) \<in> set (concat l)" by auto
  from ht_hash_ht_distinct_in_dom_unique_value[OF assms True] a b
  have "y = z" by auto
  with y z show ?thesis by simp
qed

lemma ls_lookup_map_of_pre:
  "distinct (map fst l) \<Longrightarrow> ls_lookup k l = map_of l k"
  apply (induct l)
  apply simp
  apply (case_tac a)
  by simp

lemma ls_lookup_map_of:
  assumes "ht_hash l"
  assumes "ht_distinct l"
  assumes "1 < length l"
  shows "ls_lookup k (l ! bounded_hashcode_nat (length l) k)
  = map_of (concat l) k"
proof -
  from assms(2,3)
  have "distinct (map fst (l ! bounded_hashcode_nat (length l) k))"
    by (simp add: ht_distinct_def bounded_hashcode_nat_bounds)
  from ls_lookup_map_of_pre[OF this]
  have "ls_lookup k (l ! bounded_hashcode_nat (length l) k)
    = map_of (l ! bounded_hashcode_nat (length l) k) k" .
  also from ht_hash_ht_distinct_map_of[OF assms]
  have "map_of (l ! bounded_hashcode_nat (length l) k) k
    = map_of (concat l) k"
    by simp
  finally show ?thesis .
qed

abbreviation "hm_lookup \<equiv> ht_lookup"
lemma hm_lookup_rule':
  "<is_hashmap' m l ht> hm_lookup k ht
    <\<lambda>r. is_hashmap' m l ht *
      \<up>(r = m k)>"
  unfolding is_hashmap'_def
  apply sep_auto
  apply (rule cons_post_rule)
  using complete_ht_lookup[of l ht k]
  apply simp
  apply sep_auto
  by (simp add: ls_lookup_map_of is_hashtable_def)

lemma hm_lookup_rule:
  "<is_hashmap m ht> hm_lookup k ht
    <\<lambda>r. is_hashmap m ht *
      \<up>(r = m k)>"
  unfolding is_hashmap_def
  apply sep_auto
  apply (rule cons_post_rule[OF hm_lookup_rule'])
  by sep_auto

lemma abs_update_map_of'':
  assumes "ht_hash l"
  assumes "ht_distinct l"
  assumes "1 < length l"
  shows "map_of (concat (abs_update k v l)) k = Some v"
proof -
  from ht_hash_ht_distinct_map_of[
    OF ht_hash_update[OF assms(1)]
       ht_distinct_update[OF assms(2)]
       length_update[OF assms(3)],
    of k v k]
  have "map_of (concat (abs_update k v l)) k
    = map_of ((abs_update k v l) ! bounded_hashcode_nat (length l) k) k"
    by (simp add: abs_update_length)
  also have
    "\<dots> = map_of (fst (ls_update k v
                        (l ! bounded_hashcode_nat (length l) k))) k"
    by (simp add: abs_update_def bounded_hashcode_nat_bounds[OF assms(3)])
  also have "... = Some v" by (simp add: ls_update_map_of_eq)
  finally show ?thesis .
qed

lemma abs_update_map_of_hceq:
  assumes "ht_hash l"
  assumes "ht_distinct l"
  assumes "1 < length l"
  assumes "x \<noteq> k"
  assumes "bounded_hashcode_nat (length l) x
    = bounded_hashcode_nat (length l) k"
  shows "map_of (concat (abs_update k v l)) x = map_of (concat l) x"
proof -
  from ht_hash_ht_distinct_map_of[
    OF ht_hash_update[OF assms(1)]
       ht_distinct_update[OF assms(2)]
       length_update[OF assms(3)],
    of k v x]
  have "map_of (concat (abs_update k v l)) x
    = map_of ((abs_update k v l) ! bounded_hashcode_nat (length l) x) x"
    by (simp add: abs_update_length)
  also from assms(5) have
    "\<dots> = map_of (fst (ls_update k v
                        (l ! bounded_hashcode_nat (length l) k))) x"
    by (simp add: abs_update_def bounded_hashcode_nat_bounds[OF assms(3)])
  also have
    "\<dots> = map_of (l ! bounded_hashcode_nat (length l) x) x"
    by (simp add: ls_update_map_of_neq[OF assms(4)] assms(5))
  also from ht_hash_ht_distinct_map_of[OF assms(1-3)] have
    "\<dots> = map_of (concat l) x"
    by simp
  finally show ?thesis .
qed

lemma abs_update_map_of_hcneq:
  assumes "ht_hash l"
  assumes "ht_distinct l"
  assumes "1 < length l"
  assumes "x \<noteq> k"
  assumes "bounded_hashcode_nat (length l) x
    \<noteq> bounded_hashcode_nat (length l) k"
  shows "map_of (concat (abs_update k v l)) x = map_of (concat l) x"
proof -
  from ht_hash_ht_distinct_map_of[
    OF ht_hash_update[OF assms(1)]
        ht_distinct_update[OF assms(2)]
        length_update[OF assms(3)],
    of k v x]
  have "map_of (concat (abs_update k v l)) x
    = map_of ((abs_update k v l) ! bounded_hashcode_nat (length l) x) x"
    by (simp add: abs_update_length)
  also from assms(5)
  have "\<dots> = map_of (l ! bounded_hashcode_nat (length l) x) x"
    by (simp add: abs_update_def bounded_hashcode_nat_bounds[OF assms(3)])
  also from ht_hash_ht_distinct_map_of[OF assms(1-3)]
  have "\<dots> = map_of (concat l) x"
    by simp
  finally show ?thesis .
qed

lemma abs_update_map_of''':
  assumes "ht_hash l"
  assumes "ht_distinct l"
  assumes "1 < length l"
  assumes "x \<noteq> k"
  shows "map_of (concat (abs_update k v l)) x = map_of (concat l) x"
  apply (cases
    "bounded_hashcode_nat (length l) x = bounded_hashcode_nat (length l) k")
  by (auto simp add: abs_update_map_of_hceq[OF assms]
    abs_update_map_of_hcneq[OF assms])

lemma abs_update_map_of':
  assumes "ht_hash l"
  assumes "ht_distinct l"
  assumes "1 < length l"
  shows "map_of (concat (abs_update k v l)) x
    = (map_of (concat l)(k \<mapsto> v)) x"
  apply (cases "x = k")
  apply (simp add: abs_update_map_of''[OF assms])
  by (simp add: abs_update_map_of'''[OF assms])

lemma abs_update_map_of:
  assumes "ht_hash l"
  assumes "ht_distinct l"
  assumes "1 < length l"
  shows "map_of (concat (abs_update k v l))
    = map_of (concat l)(k \<mapsto> v) "
  apply (rule ext)
  by (simp add: abs_update_map_of'[OF assms])

lemma ls_insls_map_of:
  assumes "ht_hash ld"
  assumes "ht_distinct ld"
  assumes "1 < length ld"
  assumes "distinct (map fst xs)"
  shows "map_of (concat (ls_insls xs ld))
    = map_of (concat ld) ++ map_of xs"
  using assms
  apply (induct xs arbitrary: ld)
  apply simp
  apply (case_tac a)
  apply (simp only: ls_insls.simps)
proof -
  case goal1
  from goal1(5) goal1(1)[OF ht_hash_update[OF goal1(2)]
    ht_distinct_update[OF goal1(3)]
    length_update[OF goal1(4)]]
    abs_update_map_of[OF goal1(2-4)]
  show ?case
    apply simp
    apply (rule map_add_upd2)
    by (metis dom_map_of_conv_image_fst)
qed

lemma ls_insls_map_of':
  assumes "ht_hash ls"
  assumes "ht_distinct ls"
  assumes "ht_hash ld"
  assumes "ht_distinct ld"
  assumes "1 < length ld"
  assumes "n < length ls"
  shows "map_of (concat (ls_insls (ls ! n) ld))
      ++ map_of (concat (take n ls))
    = map_of (concat ld) ++ map_of (concat (take (Suc n) ls))"
proof -
  from assms(2,6) have "distinct (map fst (ls ! n))"
    by (simp add: ht_distinct_def)
  from ls_insls_map_of[OF assms(3-5) this] assms(6) show ?thesis
    by (simp add: List.take_Suc_conv_app_nth)
qed

lemma ls_copy_map_of:
  assumes "ht_hash ls"
  assumes "ht_distinct ls"
  assumes "ht_hash ld"
  assumes "ht_distinct ld"
  assumes "1 < length ld"
  assumes "n \<le> length ls"
  shows "map_of (concat (ls_copy n ls ld))
  = map_of (concat ld) ++ map_of (concat (take n ls))"
  using assms
  apply (induct n arbitrary: ld)
  apply simp
proof -
  case goal1
  thm ht_hash_ls_insls[OF goal1(4)]
  note a = ht_hash_ls_insls[OF goal1(4), of "ls ! n"]
  note b = ht_distinct_ls_insls[OF goal1(5), of "ls ! n"]
  note c = length_ls_insls[OF goal1(6), of "ls ! n"]
  from goal1 have "n < length ls" by simp
  with
    ls_insls_map_of'[OF goal1(2-6) this]
    goal1(1)[OF assms(1,2) a b c]
  show ?case by simp
qed

lemma ls_rehash_map_of:
  assumes "ht_hash l"
  assumes "ht_distinct l"
  assumes "1 < length l"
  shows "map_of (concat (ls_rehash l)) = map_of (concat l)"
  using assms(3) ls_copy_map_of[OF assms(1,2)
    ht_hash_replicate ht_distinct_replicate]
  by (simp add: ls_rehash_def)

lemma abs_update_rehash_map_of:
  assumes "ht_hash l"
  assumes "ht_distinct l"
  assumes "1 < length l"
  shows "map_of (concat (abs_update k v (ls_rehash l)))
  = map_of (concat l)(k \<mapsto> v)"
proof -
  note a = ht_hash_ls_rehash[of l]
  note b = ht_distinct_ls_rehash[of l]
  note c = length_ls_rehash[OF assms(3)]
  from abs_update_map_of[OF a b c] ls_rehash_map_of[OF assms]
  show ?thesis by simp
qed

abbreviation "hm_update \<equiv> ht_update"
lemma hm_update_rule':
  "<is_hashmap' m l ht>
    hm_update k v ht
  <\<lambda>r. is_hashmap (m(k \<mapsto> v)) r * true>"
proof (cases "length l * load_factor \<le> the_size ht * 100")
  case True
  show ?thesis
    unfolding is_hashmap'_def
    apply sep_auto
    apply (rule cons_post_rule[OF complete_ht_update_rehash[OF True]])
    unfolding is_hashmap_def is_hashmap'_def
    apply sep_auto
    apply (simp add: abs_update_rehash_map_of is_hashtable_def)
    done
next
  case False
  show ?thesis
    unfolding is_hashmap'_def is_hashtable_def
    apply sep_auto
    apply (rule cons_post_rule)
    using complete_ht_update_normal[OF False, simplified is_hashtable_def,
      simplified, of k v]
    apply auto
    unfolding is_hashmap_def is_hashmap'_def
    apply sep_auto
    by (simp add: abs_update_map_of is_hashtable_def)
qed

lemma hm_update_rule:
  "<is_hashmap m ht>
    hm_update k v ht
  <\<lambda>r. is_hashmap (m(k \<mapsto> v)) r * true>"
  unfolding is_hashmap_def[of m]
  by (sep_auto heap add: hm_update_rule')

lemma ls_delete_map_of:
  assumes "distinct (map fst l)"
  shows "map_of (fst (ls_delete k l)) x = ((map_of l) |` (- {k})) x"
  using assms
  apply (induct l rule: ls_delete.induct)
  apply simp
  apply (auto simp add: map_of_eq_None_iff Let_def)
  by (metis ComplD ComplI Compl_insert option.set(2)
    insertE insertI2 map_upd_eq_restrict restrict_map_def)

lemma update_ls_delete_map_of:
  assumes "ht_hash l"
  assumes "ht_distinct l"
  assumes "ht_hash (l[bounded_hashcode_nat (length l) k
  := fst (ls_delete k (l ! bounded_hashcode_nat (length l) k))])"
  assumes "ht_distinct (l[bounded_hashcode_nat (length l) k
  := fst (ls_delete k (l ! bounded_hashcode_nat (length l) k))])"
  assumes "1 < length l"
  shows "map_of (concat (l[bounded_hashcode_nat (length l) k
    := fst (ls_delete k (l ! bounded_hashcode_nat (length l) k))])) x
  = ((map_of (concat l)) |` (- {k})) x"
proof -
  from assms(2) bounded_hashcode_nat_bounds[OF assms(5)] have
    distinct: "distinct (map fst (l ! bounded_hashcode_nat (length l) k))"
    by (auto simp add: ht_distinct_def)
  note id1 = ht_hash_ht_distinct_map_of[OF assms(3,4), simplified,
    OF assms(5)[simplified], of x]
  note id2 = ht_hash_ht_distinct_map_of[OF assms(1,2,5), of x]
  show ?thesis
  proof (cases
      "bounded_hashcode_nat (length l) x = bounded_hashcode_nat (length l) k")
    case True
    with id1
    have "map_of (concat (l[bounded_hashcode_nat (length l) k
      := fst (ls_delete k (l ! bounded_hashcode_nat (length l) k))])) x
      =
      map_of (l[bounded_hashcode_nat (length l) k
        := fst (ls_delete k (l ! bounded_hashcode_nat (length l) k))]
      ! bounded_hashcode_nat (length l) k) x"
      by simp
    also have
      "\<dots> = map_of (fst (ls_delete k
                          (l ! bounded_hashcode_nat (length l) k))) x"
      by (simp add: bounded_hashcode_nat_bounds[OF assms(5)])
    also from ls_delete_map_of[OF distinct] have
      "\<dots> = (map_of (l ! bounded_hashcode_nat (length l) k) |` (- {k})) x"
      by simp
    finally show ?thesis
      by (cases "x = k") (simp_all add: id2 True)
  next
    case False
    with bounded_hashcode_nat_bounds[OF assms(5)] id1 id2[symmetric]
    show ?thesis
      by (cases "x = k") simp_all
  qed
qed

abbreviation "hm_delete \<equiv> ht_delete"
lemma hm_delete_rule':
  "<is_hashmap' m l ht> hm_delete k ht <is_hashmap (m |` (-{k}))>"
  unfolding is_hashmap'_def[of m] is_hashtable_def
  apply sep_auto
  apply (rule cons_post_rule)
  using complete_ht_delete[unfolded is_hashtable_def]
  apply sep_auto
  apply (simp add: is_hashmap_def is_hashmap'_def)
  apply (sep_auto)
  apply (simp add: is_hashtable_def)
  apply (sep_auto)
  by (auto simp add: update_ls_delete_map_of)

lemma hm_delete_rule:
  "<is_hashmap m ht> hm_delete k ht <is_hashmap (m |` (-{k}))>"
  unfolding is_hashmap_def[of m]
  by (sep_auto heap add: hm_delete_rule')

definition hm_isEmpty :: "('k, 'v) hashtable \<Rightarrow> bool Heap" where
  "hm_isEmpty ht \<equiv> return (the_size ht = 0)"

lemma hm_isEmpty_rule':
  "<is_hashmap' m l ht>
  hm_isEmpty ht
  <\<lambda>r. is_hashmap' m l ht * \<up>(r \<longleftrightarrow> m=Map.empty)>"
  unfolding hm_isEmpty_def
  unfolding is_hashmap_def is_hashmap'_def is_hashtable_def ht_size_def
  apply (cases ht, simp)
  apply sep_auto
  done

lemma hm_isEmpty_rule:
  "<is_hashmap m ht> hm_isEmpty ht <\<lambda>r. is_hashmap m ht * \<up>(r \<longleftrightarrow> m=Map.empty)>"
  unfolding is_hashmap_def
  apply (sep_auto heap: hm_isEmpty_rule')
  done

definition hm_size :: "('k, 'v) hashtable \<Rightarrow> nat Heap" where
  "hm_size ht \<equiv> return (the_size ht)"

lemma length_card_dom_map_of:
  assumes "distinct (map fst l)"
  shows "length l = card (dom (map_of l))"
  using assms
  apply (induct l)
  apply simp
  apply simp
  apply (case_tac a)
  apply (auto intro!: fst_conv map_of_SomeD)
  apply (subgoal_tac "aa \<notin> dom (map_of l)")
  apply simp
  by (metis dom_map_of_conv_image_fst)

lemma ht_hash_dom_map_of_disj:
  assumes "ht_hash l"
  assumes "i < length l"
  assumes "j < length l"
  assumes "i \<noteq> j"
  shows "dom (map_of (l!i)) \<inter> dom (map_of(l!j)) = {}"
  using assms
  unfolding ht_hash_def
  apply auto
  by (metis fst_conv map_of_SomeD)

lemma ht_hash_dom_map_of_disj_drop:
  assumes "ht_hash l"
  assumes "i < length l"
  shows "dom (map_of (l!i)) \<inter> dom (map_of (concat (drop (Suc i) l)))
    = {}"
  apply auto
proof -
  case goal1
  from goal1(2) have "x \<in> dom (map_of (concat (drop (Suc i) l)))"
    by auto
  hence "\<exists>j. j < length (drop (Suc i) l)
    \<and> x \<in> dom (map_of ((drop (Suc i) l)!j))"
    by (metis Hash_Map.map_of_concat
      `x \<in> dom (map_of (concat (drop (Suc i) l)))` length_drop)
  from this obtain j where
    j: "j < length (drop (Suc i) l)
      \<and> x \<in> dom (map_of ((drop (Suc i) l)!j))"
    by blast
  hence length: "(Suc i + j) < length l" by auto
  from j have neq: "i \<noteq> (Suc i + j)" by simp
  from j have in_dom: "x \<in> dom (map_of (l!(Suc i + j)))" by auto
  from goal1(1) have in_dom2: "x \<in> dom (map_of (l ! i))" by auto
  from ht_hash_dom_map_of_disj[OF assms length neq] in_dom in_dom2
  show ?case by auto
qed

lemma listsum_length_card_dom_map_of_concat:
  assumes "ht_hash l"
  assumes "ht_distinct l"
  shows "listsum (map length l) = card (dom (map_of (concat l)))"
  using assms
proof -
  from ht_hash_dom_map_of_disj_drop[OF assms(1)]
  have "\<forall>i. i < length l
    \<longrightarrow> dom (map_of (l ! i)) \<inter> dom (map_of (concat (drop (Suc i) l)))
        = {}"
    by auto
  with assms(2) show ?thesis
  proof (induct l)
    case Nil
    thus ?case by simp
  next
    case (Cons l ls)
    from Cons(2) have a: "ht_distinct ls" by (auto simp add: ht_distinct_def)
    from Cons(3) have b: "\<forall>i < length ls. dom (map_of (ls ! i))
      \<inter> dom (map_of (concat (drop (Suc i) ls))) = {}"
      apply simp
      apply (rule allI)
      apply (rule_tac x="Suc i" and P="(\<lambda>i. i<Suc (length ls) \<longrightarrow>
             dom (map_of ((l # ls) ! i)) \<inter> dom (map_of (concat (drop i ls))) =
             {})" in allE)
      by simp_all
    from Cons(2) have "distinct (map fst l)" by (auto simp add: ht_distinct_def)
    note l = length_card_dom_map_of[OF this]
    from Cons(3) have c: "dom (map_of l) \<inter> dom (map_of (concat ls)) = {}"
      apply (rule_tac x="0" and P="(\<lambda>i. i<Suc (length ls) \<longrightarrow>
             dom (map_of ((l # ls) ! i))
               \<inter> dom (map_of (concat (drop i ls)))
             = {})" in allE)
      by simp_all
    from Cons(1)[OF a b] l c show ?case by (simp add: card_Un_disjoint)
  qed
qed

lemma hm_size_rule':
  "<is_hashmap' m l ht>
  hm_size ht
  <\<lambda>r. is_hashmap' m l ht * \<up>(r = card (dom m))>"
  unfolding hm_size_def is_hashmap_def is_hashmap'_def is_hashtable_def
  apply sep_auto
  apply (cases ht)
  apply (simp add: ht_size_def)
  apply sep_auto
  by (simp add: listsum_length_card_dom_map_of_concat)

lemma hm_size_rule:
  "<is_hashmap m ht>
    hm_size ht
  <\<lambda>r. is_hashmap m ht * \<up>(r = card (dom m))>"
  unfolding is_hashmap_def
  by (sep_auto heap: hm_size_rule')

subsection {* Iterators *}

subsubsection {* Definitions *}
type_synonym ('k,'v) hm_it = "(nat \<times> ('k\<times>'v) list \<times> ('k,'v) hashtable)"

fun hm_it_adjust
  :: "nat \<Rightarrow> ('k::{heap,hashable},'v::heap) hashtable \<Rightarrow> nat Heap"
  where
  "hm_it_adjust 0 ht = return 0"
| "hm_it_adjust n ht = do {
    l \<leftarrow> Array.nth (the_array ht) n;
    case l of
      [] \<Rightarrow> hm_it_adjust (n - 1) ht
    | _ \<Rightarrow>  return n
  }"

definition hm_it_init
  :: "('k::{heap,hashable},'v::heap) hashtable \<Rightarrow> ('k,'v) hm_it Heap"
  where
  "hm_it_init ht \<equiv> do {
  n\<leftarrow>Array.len (the_array ht);
  if n = 0 then return (0,[],ht)
  else do {
    i\<leftarrow>hm_it_adjust (n - 1) ht;
    l\<leftarrow>Array.nth (the_array ht) i;
    return (i,l,ht)
  }
}"

definition hm_it_has_next
  :: "('k::{heap,hashable},'v::heap) hm_it \<Rightarrow> bool Heap"
  where "hm_it_has_next it
  \<equiv> return (case it of (0,[],_) \<Rightarrow> False | _ \<Rightarrow> True)"

definition hm_it_next ::
  "('k::{heap,hashable},'v::heap) hm_it
    \<Rightarrow> (('k\<times>'v)\<times>('k,'v) hm_it) Heap"
  where "hm_it_next it \<equiv> case it of
    (i,a#b#l,ht) \<Rightarrow> return (a,(i,b#l,ht))
  | (0,[a],ht) \<Rightarrow> return (a,(0,[],ht))
  | (Suc i,[a],ht) \<Rightarrow> do {
    i \<leftarrow> hm_it_adjust i ht;
    l \<leftarrow> Array.nth (the_array ht) i;
    return (a,(i,rev l,ht))
  }
  "

definition "hm_is_it' l ht l' it \<equiv>
  is_hashtable l ht *
  \<up>(let (i,r,ht')=it in
       ht = ht'
     \<and> l' = (concat (take i l) @ rev r)
     \<and> distinct (map fst (l'))
     \<and> i \<le> length l \<and> (r=[] \<longrightarrow> i=0)
   )"

definition "hm_is_it m ht m' it \<equiv> \<exists>\<^sub>Al l'.
  hm_is_it' l ht l' it
  * \<up>(map_of (concat l) = m \<and> map_of l' = m')
  "

subsubsection {* Auxiliary Lemmas *}
lemma concat_take_Suc_empty: "\<lbrakk> n < length l; l!n=[] \<rbrakk>
  \<Longrightarrow> concat (take (Suc n) l) = concat (take n l)"
  apply (induct n arbitrary: l)
  apply (case_tac l)
  apply auto [2]
  apply (case_tac l)
  apply auto [2]
  done

lemma nth_concat_splitE:
  assumes "i<length (concat ls)"
  obtains j k where
  "j < length ls"
  and "k < length (ls!j)"
  and "concat ls ! i = ls!j!k"
  and "i = length (concat (take j ls)) + k"
  using assms
proof (induct ls arbitrary: i thesis)
  case Nil thus ?case by auto
next
  case (Cons l ls)
  show ?case proof (cases)
    assume L: "i < length l"
    hence "concat (l#ls) ! i = (l#ls)!0!i" by (auto simp: nth_append)
    thus ?thesis
      apply (rule_tac Cons.prems(1)[of 0 i])
      apply (simp_all add: L)
      done
  next
    assume L: "\<not>(i < length l)"
    hence 1: "concat (l#ls)!i = concat ls ! (i - length l)"
      by (auto simp: nth_append)
    obtain j k where
      "j < length ls" and "k < length (ls!j)"
      and "concat ls ! (i - length l) = ls!j!k"
      and "i - length l = length (concat (take j ls)) + k"
      apply (rule Cons.hyps[of "i - length l"])
      using Cons.prems L
      by auto
    thus ?case using L
      apply (rule_tac Cons.prems(1)[of "Suc j" k])
      apply (auto simp: nth_append)
      done
  qed
qed

lemma is_hashmap'_distinct:
  "is_hashtable l ht
    \<Longrightarrow>\<^sub>A is_hashtable l ht * \<up>(distinct (map fst (concat l)))"
  apply (simp add: distinct_conv_nth)
proof (intro allI impI, elim exE)
  fix i j a b
  assume 1: "i < length (concat l)"
  assume 2: "j < length (concat l)"
  assume 3: "i\<noteq>j"

  assume HM: "(a,b) \<Turnstile> is_hashtable l ht"

  from 1 obtain ji ki where
    IFMT: "i = length (concat (take ji l)) + ki"
    and JI_LEN: "ji < length l"
    and KI_LEN: "ki < length (l!ji)"
    and [simp]: "concat l ! i = l!ji!ki"
    by (blast elim: nth_concat_splitE)

  from 2 obtain jj kj where
    JFMT: "j = length (concat (take jj l)) + kj"
    and JJ_LEN: "jj < length l"
    and KJ_LEN: "kj < length (l!jj)"
    and [simp]: "concat l ! j = l!jj!kj"
    by (blast elim: nth_concat_splitE)

  show "fst (concat l ! i) \<noteq> fst (concat l ! j)"
  proof cases
    assume [simp]: "ji=jj"
    with IFMT JFMT `i\<noteq>j` have "ki\<noteq>kj" by auto
    moreover from HM JJ_LEN have "distinct (map fst (l!jj))"
      unfolding is_hashmap'_def is_hashtable_def ht_distinct_def
      by auto
    ultimately show ?thesis using KI_LEN KJ_LEN
      by (simp add: distinct_conv_nth)
  next
    assume NE: "ji\<noteq>jj"
    from HM have
      "\<forall>x\<in>set (l!ji). bounded_hashcode_nat (length l) (fst x) = ji"
      "\<forall>x\<in>set (l!jj). bounded_hashcode_nat (length l) (fst x) = jj"
      unfolding is_hashmap'_def is_hashtable_def ht_hash_def
      using JI_LEN JJ_LEN
      by auto
    with KI_LEN KJ_LEN NE show ?thesis
      apply (auto) by (metis nth_mem)
  qed
qed

lemma take_set: "set (take n l) = { l!i | i. i<n \<and> i<length l }"
  apply (auto simp add: set_conv_nth)
  apply (rule_tac x=i in exI)
  apply auto
  done

lemma skip_empty_aux:
  assumes A: "concat (take (Suc n) l) = concat (take (Suc x) l)"
  assumes L[simp]: "Suc n \<le> length l" "x \<le> n"
  shows "\<forall>i. x<i \<and> i\<le>n \<longrightarrow> l!i=[]"
proof -
  have "take (Suc n) l = take (Suc x + (n - x)) l"
    by simp
  also have "\<dots> = take (Suc x) l @ take (n - x) (drop (Suc x) l)"
    by (simp only: take_add)
  finally   have
    "concat (take (Suc x) l) =
      concat (take (Suc x) l) @ concat (take (n - x) (drop (Suc x) l))"
    using A by simp
  hence 1: "\<forall>l\<in>set (take (n - x) (drop (Suc x) l)). l=[]" by simp
  show ?thesis
  proof safe
    fix i
    assume "x<i" and "i\<le>n"
    hence "l!i \<in> set (take (n - x) (drop (Suc x) l))"
      using L[simp del]
      apply (auto simp: take_set)
      apply (rule_tac x="i - Suc x" in exI)
      apply auto
      done
    with 1 show "l!i=[]" by blast
  qed
qed

lemma take_Suc0:
  "l\<noteq>[] \<Longrightarrow> take (Suc 0) l = [l!0]"
  "0 < length l \<Longrightarrow> take (Suc 0) l = [l!0]"
  "Suc n \<le> length l \<Longrightarrow> take (Suc 0) l = [l!0]"
  by (cases l, auto)+

lemma concat_take_Suc_app_nth:
  assumes "x < length l"
  shows "concat (take (Suc x) l) = concat (take x l) @ l ! x"
  using assms
  by (auto simp: take_Suc_conv_app_nth)

lemma hm_hashcode_eq:
  assumes "j < length (l!i)"
  assumes "i < length l"
  assumes "h \<Turnstile> is_hashtable l ht"
  shows "bounded_hashcode_nat (length l) (fst (l!i!j)) = i"
  using assms
  unfolding is_hashtable_def ht_hash_def
  apply (cases "l!i!j")
  apply (force simp: set_conv_nth)
  done

lemma distinct_imp_distinct_take:
  "distinct (map fst (concat l))
  \<Longrightarrow> distinct (map fst (concat (take x l)))"
  apply (subst (asm) append_take_drop_id[of x l,symmetric])
  apply (simp del: append_take_drop_id)
  done

lemma hm_it_adjust_rule:
  "i<length l \<Longrightarrow> <is_hashtable l ht>
    hm_it_adjust i ht
   <\<lambda>j. is_hashtable l ht * \<up>(
      j\<le>i \<and>
      (concat (take (Suc i) l) = concat (take (Suc j) l)) \<and>
      (j=0 \<or> l!j \<noteq> [])
    )
   >"
proof (induct i)
  case 0 thus ?case by sep_auto
next
  case (Suc n)
  show ?case using Suc.prems
    by (sep_auto
      heap add: Suc.hyps
      simp: concat_take_Suc_empty
      split: list.split)
qed

lemma hm_it_next_rule': "l'\<noteq>[] \<Longrightarrow>
    <hm_is_it' l ht l' it>
      hm_it_next it
    <\<lambda>((k,v),it').
      hm_is_it' l ht (butlast l') it'
    * \<up>(last l' = (k,v) \<and> distinct (map fst l') )>"
  unfolding hm_it_next_def hm_is_it'_def is_hashmap'_def
  using [[hypsubst_thin = true]]
  apply (sep_auto (plain)
    split: nat.split list.split
    heap: hm_it_adjust_rule
    simp: take_Suc0)
  apply (simp split: prod.split nat.split list.split)
  apply (intro allI impI conjI)
  apply auto []
  apply auto []
  apply sep_auto []

  apply (sep_auto (plain)
    heap: hm_it_adjust_rule)
  apply auto []
  apply sep_auto

  apply (cases l, auto) []
  apply (metis SUP_upper fst_image_mp image_mono set_concat)

  apply (drule skip_empty_aux, simp_all) []
  defer
  apply (auto simp: concat_take_Suc_app_nth) []

  apply auto []
  apply sep_auto

  apply (auto simp: butlast_append) []
  apply (auto simp: butlast_append) []

  apply sep_auto
  apply (auto simp: butlast_append) []
  apply (auto simp: butlast_append) []
  by (metis Ex_list_of_length Suc_leD concat_take_Suc_app_nth le_neq_implies_less le_trans nat.inject not_less_eq_eq)

subsubsection {* Main Lemmas *}

lemma hm_it_next_rule: "m'\<noteq>Map.empty \<Longrightarrow>
    <hm_is_it m ht m' it>
      hm_it_next it
    <\<lambda>((k,v),it'). hm_is_it m ht (m' |` (-{k})) it' * \<up>(m' k = Some v)>"
proof -
  { fix ys a
    have aux3: "
      \<lbrakk>distinct (map fst ys); a \<notin> fst ` set ys\<rbrakk> \<Longrightarrow> map_of ys a = None"
      by (induct ys) auto
  } note aux3 = this

  assume "m'\<noteq>Map.empty"
  thus ?thesis
    unfolding hm_is_it_def
    apply (sep_auto heap: hm_it_next_rule')
    apply (case_tac l' rule: rev_cases,
      auto simp: restrict_map_def aux3 intro!: ext) []
    apply (case_tac l' rule: rev_cases, auto)
    done
qed

lemma hm_it_init_rule:
  fixes ht :: "('k::{heap,hashable},'v::heap) hashtable"
  shows "<is_hashmap m ht> hm_it_init ht <hm_is_it m ht m>\<^sub>t"
  unfolding hm_it_init_def is_hashmap_def is_hashmap'_def
    hm_is_it_def hm_is_it'_def
  apply (sep_auto simp del: map_of_append heap add: hm_it_adjust_rule)
  apply (case_tac l, auto) []
  apply (sep_auto simp del: concat_eq_Nil_conv map_of_append)
  apply (auto simp: distinct_imp_distinct_take
    dest: ent_fwd[OF _ is_hashmap'_distinct]) []

  apply (drule sym)
  apply (auto
    simp: is_hashtable_def ht_distinct_def rev_map[symmetric]) []

  apply (auto simp: set_conv_nth) []
  apply (hypsubst_thin)
  apply (drule_tac j=ia in hm_hashcode_eq, simp_all) []
  apply (drule_tac j=ib in hm_hashcode_eq, simp_all) []

  apply (auto
    simp: is_hashmap'_def is_hashtable_def ht_distinct_def) []

  apply (clarsimp)
  apply (drule ent_fwd[OF _ is_hashmap'_distinct])
  apply clarsimp
  apply (subst concat_take_Suc_app_nth)
  apply (case_tac l,auto) []
  apply (simp)
  apply (hypsubst_thin)
  apply (subst (asm) (2) concat_take_Suc_app_nth)
  apply (case_tac l,auto) []
  apply (subst map_of_rev_distinct)
  apply auto
  done

lemma hm_it_has_next_rule:
  "<hm_is_it m ht m' it> hm_it_has_next it
    <\<lambda>r. hm_is_it m ht m' it * \<up>(r\<longleftrightarrow>m'\<noteq>Map.empty)>"
  unfolding is_hashmap'_def hm_is_it_def hm_is_it'_def hm_it_has_next_def
  by (sep_auto split: nat.split list.split)

lemma hm_it_finish: "hm_is_it m p m' it \<Longrightarrow>\<^sub>A is_hashmap m p"
  unfolding hm_is_it_def hm_is_it'_def is_hashmap_def is_hashmap'_def
  by sep_auto

end


section\<open>Library of basic $\ZF$ results\label{sec:zf-lib}\<close>

theory ZF_Library
  imports
    "ZF-Constructible.Normal"

begin

text\<open>This theory gathers basic ``combinatorial'' results that can be proved
in $\ZF$ (that is, without using the Axiom of Choice $\AC$).
\<close>

text\<open>We begin by setting up math-friendly notation.\<close>

no_notation oadd (infixl \<open>++\<close> 65)
no_notation sum (infixr \<open>+\<close> 65)
notation oadd (infixl \<open>+\<close> 65)
notation nat (\<open>\<omega>\<close>)
notation csucc (\<open>_\<^sup>+\<close> [90])
no_notation Aleph (\<open>\<aleph>_\<close> [90] 90)
notation Aleph (\<open>\<aleph>\<^bsub>_\<^esub>\<close>)
syntax "_ge"  :: "[i,i] \<Rightarrow> o"  (infixl \<open>\<ge>\<close> 50)
translations "x \<ge> y" \<rightharpoonup> "y \<le> x"

subsection\<open>Some minimal arithmetic/ordinal stuff\<close>

lemma Un_leD1 : "i \<union> j \<le> k \<Longrightarrow> Ord(i) \<Longrightarrow> Ord(j) \<Longrightarrow> Ord(k) \<Longrightarrow> i \<le> k"
  by (rule Un_least_lt_iff[THEN iffD1[THEN conjunct1]],simp_all)

lemma Un_leD2 : "i \<union> j \<le> k \<Longrightarrow> Ord(i) \<Longrightarrow> Ord(j) \<Longrightarrow> Ord(k) \<Longrightarrow> j \<le> k"
  by (rule Un_least_lt_iff[THEN iffD1[THEN conjunct2]],simp_all)

lemma Un_memD1: "i \<union> j \<in> k \<Longrightarrow> Ord(i) \<Longrightarrow> Ord(j) \<Longrightarrow> Ord(k) \<Longrightarrow> i \<le> k"
  by (drule ltI, assumption, drule leI, rule Un_least_lt_iff[THEN iffD1[THEN conjunct1]],simp_all)

lemma Un_memD2 : "i \<union> j \<in> k \<Longrightarrow> Ord(i) \<Longrightarrow> Ord(j) \<Longrightarrow> Ord(k) \<Longrightarrow> j \<le> k"
  by (drule ltI, assumption, drule leI, rule Un_least_lt_iff[THEN iffD1[THEN conjunct2]],simp_all)

text\<open>This lemma allows to apply arithmetic simprocs to ordinal addition\<close>
lemma nat_oadd_add[simp]:
  assumes "m \<in> \<omega>" "n \<in> \<omega>" shows "n + m = n #+ m"
  using assms
  by induct simp_all

lemma Ord_has_max_imp_succ:
  assumes "Ord(\<gamma>)" "\<beta> \<in> \<gamma>" "\<forall>\<alpha>\<in>\<gamma>. \<alpha> \<le> \<beta>"
  shows "\<gamma> = succ(\<beta>)"
  using assms Ord_trans[of _ \<beta> \<gamma>]
  unfolding lt_def
  by (intro equalityI subsetI) auto

lemma Least_antitone:
  assumes
    "Ord(j)" "P(j)" "\<And>i. P(i) \<Longrightarrow> Q(i)"
  shows
    "(\<mu> i. Q(i)) \<le> (\<mu> i. P(i))"
  using assms LeastI2[of P j Q] Least_le by simp

lemma Least_set_antitone:
  "Ord(j) \<Longrightarrow> j\<in>A \<Longrightarrow> A \<subseteq> B \<Longrightarrow> (\<mu> i. i\<in>B) \<le> (\<mu> i. i\<in>A)"
  using subset_iff by (auto intro:Least_antitone)

lemma le_neq_imp_lt:
  "x\<le>y \<Longrightarrow> x\<noteq>y \<Longrightarrow> x<y"
  using ltD ltI[of x y] le_Ord2
  unfolding succ_def by auto

text\<open>Strict upper bound of a set of ordinals.\<close>
definition
  str_bound :: "i\<Rightarrow>i" where
  "str_bound(A) \<equiv> \<Union>a\<in>A. succ(a)"

lemma str_bound_type [TC]: "\<forall>a\<in>A. Ord(a) \<Longrightarrow> Ord(str_bound(A))"
  unfolding str_bound_def by auto

lemma str_bound_lt: "\<forall>a\<in>A. Ord(a) \<Longrightarrow> \<forall>a\<in>A. a < str_bound(A)"
  unfolding str_bound_def using str_bound_type
  by (blast intro:ltI)

lemma naturals_lt_nat[intro]: "n \<in> \<omega> \<Longrightarrow> n < \<omega>"
  unfolding lt_def by simp

text\<open>The next two lemmas are handy when one is constructing
some object recursively. The first handles injectivity (of recursively
constructed sequences of sets), while the second is helpful for
establishing a symmetry argument.\<close>
lemma Int_eq_zero_imp_not_eq:
  assumes
    "\<And>x y. x\<in>D \<Longrightarrow> y \<in> D \<Longrightarrow> x \<noteq> y \<Longrightarrow> A(x) \<inter> A(y) = 0"
    "\<And>x. x\<in>D \<Longrightarrow> A(x) \<noteq> 0" "a\<in>D" "b\<in>D" "a\<noteq>b"
  shows
    "A(a) \<noteq> A(b)"
  using assms by fastforce

lemma lt_neq_symmetry:
  assumes
    "\<And>\<alpha> \<beta>. \<alpha> \<in> \<gamma> \<Longrightarrow> \<beta> \<in> \<gamma> \<Longrightarrow> \<alpha> < \<beta> \<Longrightarrow> Q(\<alpha>,\<beta>)"
    "\<And>\<alpha> \<beta>. Q(\<alpha>,\<beta>) \<Longrightarrow> Q(\<beta>,\<alpha>)"
    "\<alpha> \<in> \<gamma>" "\<beta> \<in> \<gamma>" "\<alpha> \<noteq> \<beta>"
    "Ord(\<gamma>)"
  shows
    "Q(\<alpha>,\<beta>)"
proof -
  from assms
  consider "\<alpha><\<beta>" | "\<beta><\<alpha>"
    using Ord_linear_lt[of \<alpha> \<beta> thesis] Ord_in_Ord[of \<gamma>]
    by auto
  then
  show ?thesis by cases (auto simp add:assms)
qed

lemma cardinal_succ_not_0: "|A| = succ(n) \<Longrightarrow> A \<noteq> 0"
  by auto

lemma Ord_eq_Collect_lt: "i<\<alpha> \<Longrightarrow> {j\<in>\<alpha>. j<i} = i"
  \<comment> \<open>almost the same proof as @{thm [source] nat_eq_Collect_lt}\<close>
  apply (rule equalityI)
  apply (blast dest: ltD)
  apply (auto simp add: Ord_mem_iff_lt)
  apply (rule Ord_trans ltI[OF _ lt_Ord]; auto simp add:lt_def dest:ltD)+
  done

subsection\<open>Manipulation of function spaces\<close>

definition
  Finite_to_one :: "[i,i] \<Rightarrow> i" where
  "Finite_to_one(X,Y) \<equiv> {f:X\<rightarrow>Y. \<forall>y\<in>Y. Finite({x\<in>X . f`x = y})}"

lemma Finite_to_oneI[intro]:
  assumes "f:X\<rightarrow>Y" "\<And>y. y\<in>Y \<Longrightarrow> Finite({x\<in>X . f`x = y})"
  shows "f \<in> Finite_to_one(X,Y)"
  using assms unfolding Finite_to_one_def by simp

lemma Finite_to_oneD[dest]:
  "f \<in> Finite_to_one(X,Y) \<Longrightarrow> f:X\<rightarrow>Y"
  "f \<in> Finite_to_one(X,Y) \<Longrightarrow> y\<in>Y \<Longrightarrow>  Finite({x\<in>X . f`x = y})"
  unfolding Finite_to_one_def by simp_all

lemma subset_Diff_Un: "X \<subseteq> A \<Longrightarrow> A = (A - X) \<union> X " by auto

lemma Diff_bij:
  assumes "\<forall>A\<in>F. X \<subseteq> A" shows "(\<lambda>A\<in>F. A-X) \<in> bij(F, {A-X. A\<in>F})"
  using assms unfolding bij_def inj_def surj_def
  by (auto intro:lam_type, subst subset_Diff_Un[of X]) auto

lemma function_space_nonempty:
  assumes "b\<in>B"
  shows "(\<lambda>x\<in>A. b) : A \<rightarrow> B"
  using assms lam_type by force

lemma vimage_lam: "(\<lambda>x\<in>A. f(x)) -`` B = { x\<in>A . f(x) \<in> B }"
  using lam_funtype[of A f, THEN [2] domain_type]
    lam_funtype[of A f, THEN [2] apply_equality] lamI[of _ A f]
  by auto blast

lemma range_fun_subset_codomain:
  assumes "h:B \<rightarrow> C"
  shows "range(h) \<subseteq> C"
  unfolding range_def domain_def converse_def using range_type[OF _ assms]  by auto

lemma Pi_rangeD:
  assumes "f\<in>Pi(A,B)" "b \<in> range(f)"
  shows "\<exists>a\<in>A. f`a = b"
  using assms apply_equality[OF _ assms(1), of _ b]
    domain_type[OF _ assms(1)] by auto

lemma Pi_range_eq: "f \<in> Pi(A,B) \<Longrightarrow> range(f) = {f ` x . x \<in> A}"
  using Pi_rangeD[of f A B] apply_rangeI[of f A B]
  by blast

lemma Pi_vimage_subset : "f \<in> Pi(A,B) \<Longrightarrow> f-``C \<subseteq> A"
  unfolding Pi_def by auto

lemma apply_in_codomain_Ord:
  assumes
    "Ord(\<gamma>)" "\<gamma>\<noteq>0" "f: A \<rightarrow> \<gamma>"
  shows
    "f`x\<in>\<gamma>"
proof (cases "x\<in>A")
  case True
  from assms \<open>x\<in>A\<close>
  show ?thesis
    using   domain_of_fun apply_rangeI  by simp
next
  case False
  from assms \<open>x\<notin>A\<close>
  show ?thesis
    using apply_0 Ord_0_lt ltD domain_of_fun by auto
qed

lemma range_eq_image:
  assumes "f:A\<rightarrow>B"
  shows "range(f) = f``A"
proof
  show "f `` A \<subseteq> range(f)"
    unfolding image_def by blast
  {
    fix x
    assume "x\<in>range(f)"
    with assms
    have "x\<in>f``A"
      using domain_of_fun[of f A "\<lambda>_. B"] by auto
  }
  then
  show "range(f) \<subseteq> f `` A" ..
qed

lemma Image_sub_codomain: "f:A\<rightarrow>B \<Longrightarrow> f``C \<subseteq> B"
  using image_subset fun_is_rel[of _ _ "\<lambda>_ . B"] by force

lemma inj_to_Image:
  assumes
    "f:A\<rightarrow>B" "f \<in> inj(A,B)"
  shows
    "f \<in> inj(A,f``A)"
  using assms inj_inj_range range_eq_image by force

lemma inj_imp_surj:
  fixes f b
  notes inj_is_fun[dest]
  defines [simp]: "ifx(x) \<equiv> if x\<in>range(f) then converse(f)`x else b"
  assumes "f \<in> inj(B,A)" "b\<in>B"
  shows "(\<lambda>x\<in>A. ifx(x)) \<in> surj(A,B)"
proof -
  from assms
  have "converse(f) \<in> surj(range(f),B)" "range(f) \<subseteq> A"
    "converse(f) : range(f) \<rightarrow> B"
    using inj_converse_surj range_fun_subset_codomain surj_is_fun by blast+
  with \<open>b\<in>B\<close>
  show "(\<lambda>x\<in>A. ifx(x)) \<in> surj(A,B)"
    unfolding surj_def
  proof (intro CollectI lam_type ballI; elim CollectE)
    fix y
    assume "y \<in> B" "\<forall>y\<in>B. \<exists>x\<in>range(f). converse(f) ` x = y"
    with \<open>range(f) \<subseteq> A\<close>
    show "\<exists>x\<in>A. (\<lambda>x\<in>A. ifx(x)) ` x = y"
      by (drule_tac bspec, auto)
  qed simp
qed

lemma fun_Pi_disjoint_Un:
  assumes "f \<in> Pi(A,B)" "g \<in> Pi(C,D)"  "A \<inter> C = 0"
  shows "f \<union> g \<in> Pi(A \<union> C, \<lambda>x. B(x) \<union> D(x))"
  using assms
  by (simp add: Pi_iff extension Un_rls) (unfold function_def, blast)

lemma Un_restrict_decomposition:
  assumes "f \<in> Pi(A,B)"
  shows "f = restrict(f, A \<inter> C) \<union> restrict(f, A - C)"
  using assms
proof (rule fun_extension)
  from assms
  have "restrict(f,A\<inter>C) \<union> restrict(f,A-C) \<in> Pi(A\<inter>C \<union> (A-C), \<lambda>x. B(x)\<union>B(x))"
    using restrict_type2[of f A B]
    by (rule_tac fun_Pi_disjoint_Un) force+
  moreover
  have "(A \<inter> C) \<union> (A - C) = A" by auto
  ultimately
  show "restrict(f, A \<inter> C) \<union> restrict(f, A - C) \<in> Pi(A, B)" by simp
next
  fix x
  assume "x \<in> A"
  with assms
  show "f ` x = (restrict(f, A \<inter> C) \<union> restrict(f, A - C)) ` x"
    using restrict fun_disjoint_apply1[of _ "restrict(f,_)"]
      fun_disjoint_apply2[of _ "restrict(f,_)"]
      domain_restrict[of f] apply_0 domain_of_fun
    by (cases "x\<in>C") simp_all
qed

lemma restrict_eq_imp_Un_into_Pi:
  assumes "f \<in> Pi(A,B)" "g \<in> Pi(C,D)" "restrict(f, A \<inter> C) = restrict(g, A \<inter> C)"
  shows "f \<union> g \<in> Pi(A \<union> C, \<lambda>x. B(x) \<union> D(x))"
proof -
  note assms
  moreover from this
  have "x \<notin> g \<Longrightarrow> x \<notin> restrict(g, A \<inter> C)" for x
    using restrict_subset[of g "A \<inter> C"] by auto
  moreover from calculation
  have "x \<in> f \<Longrightarrow> x \<in> restrict(f, A - C) \<or> x \<in> restrict(g, A \<inter> C)" for x
    by (subst (asm) Un_restrict_decomposition[of f A B "C"]) auto
  ultimately
  have "f \<union> g = restrict(f, A - C) \<union> g"
    using restrict_subset[of g "A \<inter> C"]
    by (subst Un_restrict_decomposition[of f A B "C"]) auto
  moreover
  have "A - C \<union> C = A \<union> C" by auto
  moreover
  note assms
  ultimately
  show ?thesis
    using fun_Pi_disjoint_Un[OF
        restrict_type2[of f A B "A-C"], of g C D]
    by auto
qed

lemma restrict_eq_imp_Un_into_Pi':
  assumes "f \<in> Pi(A,B)" "g \<in> Pi(C,D)"
    "restrict(f, domain(f) \<inter> domain(g)) = restrict(g, domain(f) \<inter> domain(g))"
  shows "f \<union> g \<in> Pi(A \<union> C, \<lambda>x. B(x) \<union> D(x))"
  using  assms domain_of_fun restrict_eq_imp_Un_into_Pi by simp

lemma restrict_subset_Sigma: "f \<subseteq> Sigma(C,B) \<Longrightarrow> restrict(f,A) \<subseteq> Sigma(A\<inter>C, B)"
  by (auto simp add: restrict_def)

subsection\<open>Finite sets\<close>

lemma Replace_sing1:
  "\<lbrakk> (\<exists>a. P(d,a)) \<and> (\<forall>y y'. P(d,y) \<longrightarrow> P(d,y') \<longrightarrow> y=y') \<rbrakk> \<Longrightarrow> \<exists>a. {y . x \<in> {d}, P(x,y)} = {a}"
  by blast

\<comment> \<open>Not really necessary\<close>
lemma Replace_sing2:
  assumes "\<forall>a. \<not> P(d,a)"
  shows "{y . x \<in> {d}, P(x,y)} = 0"
  using assms by auto

lemma Replace_sing3:
  assumes "\<exists>c e. c \<noteq> e \<and> P(d,c) \<and> P(d,e)"
  shows "{y . x \<in> {d}, P(x,y)} = 0"
proof -
  {
    fix z
    {
      assume "\<forall>y. P(d, y) \<longrightarrow> y = z"
      with assms
      have "False" by auto
    }
    then
    have "z \<notin> {y . x \<in> {d}, P(x,y)}"
      using Replace_iff by auto
  }
  then
  show ?thesis
    by (intro equalityI subsetI) simp_all
qed

lemma Replace_Un: "{b . a \<in> A \<union> B, Q(a, b)} =
        {b . a \<in> A, Q(a, b)} \<union> {b . a \<in> B, Q(a, b)}"
  by (intro equalityI subsetI) (auto simp add:Replace_iff)

lemma Replace_subset_sing: "\<exists>z. {y . x \<in> {d}, P(x,y)} \<subseteq> {z}"
proof -
  consider
    (1) "(\<exists>a. P(d,a)) \<and> (\<forall>y y'. P(d,y) \<longrightarrow> P(d,y') \<longrightarrow> y=y')" |
    (2) "\<forall>a. \<not> P(d,a)" | (3) "\<exists>c e. c \<noteq> e \<and> P(d,c) \<and> P(d,e)" by auto
  then
  show "\<exists>z. {y . x \<in> {d}, P(x,y)} \<subseteq> {z}"
  proof (cases)
    case 1
    then show ?thesis using Replace_sing1[of P d] by auto
  next
    case 2
    then show ?thesis by auto
  next
    case 3
    then show ?thesis using Replace_sing3[of P d] by auto
  qed
qed

lemma Finite_Replace: "Finite(A) \<Longrightarrow> Finite(Replace(A,Q))"
proof (induct rule:Finite_induct)
  case 0
  then
  show ?case by simp
next
  case (cons x B)
  moreover
  have "{b . a \<in> cons(x, B), Q(a, b)} =
        {b . a \<in> B, Q(a, b)} \<union> {b . a \<in> {x}, Q(a, b)}"
    using Replace_Un unfolding cons_def by auto
  moreover
  obtain d where "{b . a \<in> {x}, Q(a, b)} \<subseteq> {d}"
    using Replace_subset_sing[of _ Q] by blast
  moreover from this
  have "Finite({b . a \<in> {x}, Q(a, b)})"
    using subset_Finite by simp
  ultimately
  show ?case using subset_Finite by simp
qed

lemma Finite_domain: "Finite(A) \<Longrightarrow> Finite(domain(A))"
  using Finite_Replace unfolding domain_def
  by auto

lemma Finite_converse: "Finite(A) \<Longrightarrow> Finite(converse(A))"
  using Finite_Replace unfolding converse_def
  by auto

lemma Finite_range: "Finite(A) \<Longrightarrow> Finite(range(A))"
  using Finite_domain Finite_converse unfolding range_def
  by blast

lemma Finite_Sigma: "Finite(A) \<Longrightarrow> \<forall>x. Finite(B(x)) \<Longrightarrow> Finite(Sigma(A,B))"
  unfolding Sigma_def using Finite_RepFun Finite_Union
  by simp

lemma Finite_Pi: "Finite(A) \<Longrightarrow> \<forall>x. Finite(B(x)) \<Longrightarrow> Finite(Pi(A,B))"
  using Finite_Sigma
    Finite_Pow subset_Finite[of "Pi(A,B)" "Pow(Sigma(A,B))"]
  unfolding Pi_def
  by auto

subsection\<open>Basic results on equipollence, cardinality and related concepts\<close>

lemma lepollD[dest]: "A \<lesssim> B \<Longrightarrow> \<exists>f. f \<in> inj(A, B)"
  unfolding lepoll_def .

lemma lepollI[intro]: "f \<in> inj(A, B) \<Longrightarrow> A \<lesssim> B"
  unfolding lepoll_def by blast

lemma eqpollD[dest]: "A \<approx> B \<Longrightarrow> \<exists>f. f \<in> bij(A, B)"
  unfolding eqpoll_def .

declare bij_imp_eqpoll[intro]

lemma range_of_subset_eqpoll:
  assumes "f \<in> inj(X,Y)" "S \<subseteq> X"
  shows "S \<approx> f `` S"
  using assms restrict_bij by blast

text\<open>I thank Miguel Pagano for this proof.\<close>
lemma function_space_eqpoll_cong:
  assumes
    "A \<approx> A'" "B \<approx> B'"
  shows
    "A \<rightarrow> B \<approx> A' \<rightarrow> B'"
proof -
  from assms(1)[THEN eqpoll_sym] assms(2)
  obtain f g where "f \<in> bij(A',A)" "g \<in> bij(B,B')"
    by blast
  then
  have "converse(g) : B' \<rightarrow> B" "converse(f): A \<rightarrow> A'"
    using bij_converse_bij bij_is_fun by auto
  show ?thesis
    unfolding eqpoll_def
  proof (intro exI fg_imp_bijective, rule_tac [1-2] lam_type)
    fix F
    assume "F: A \<rightarrow> B"
    with \<open>f \<in> bij(A',A)\<close> \<open>g \<in> bij(B,B')\<close>
    show "g O F O f : A' \<rightarrow> B'"
      using bij_is_fun comp_fun by blast
  next
    fix F
    assume "F: A' \<rightarrow> B'"
    with \<open>converse(g) : B' \<rightarrow> B\<close> \<open>converse(f): A \<rightarrow> A'\<close>
    show "converse(g) O F O converse(f) : A \<rightarrow> B"
      using comp_fun by blast
  next
    from \<open>f\<in>_\<close> \<open>g\<in>_\<close> \<open>converse(f)\<in>_\<close> \<open>converse(g)\<in>_\<close>
    have "(\<And>x. x \<in> A' \<rightarrow> B' \<Longrightarrow> converse(g) O x O converse(f) \<in> A \<rightarrow> B)"
      using bij_is_fun comp_fun by blast
    then
    have "(\<lambda>x\<in>A \<rightarrow> B. g O x O f) O (\<lambda>x\<in>A' \<rightarrow> B'. converse(g) O x O converse(f))
          =  (\<lambda>x\<in>A' \<rightarrow> B' . (g O converse(g)) O x O (converse(f) O f))"
      using lam_cong comp_assoc comp_lam[of "A' \<rightarrow> B'" ] by auto
    also
    have "... = (\<lambda>x\<in>A' \<rightarrow> B' . id(B') O x O (id(A')))"
      using left_comp_inverse[OF bij_is_inj[OF \<open>f\<in>_\<close>]]
        right_comp_inverse[OF bij_is_surj[OF \<open>g\<in>_\<close>]]
      by auto
    also
    have "... = (\<lambda>x\<in>A' \<rightarrow> B' . x)"
      using left_comp_id[OF fun_is_rel] right_comp_id[OF fun_is_rel]  lam_cong by auto
    also
    have "... = id(A'\<rightarrow>B')" unfolding id_def by simp
    finally
    show "(\<lambda>x\<in>A -> B. g O x O f) O (\<lambda>x\<in>A' -> B'. converse(g) O x O converse(f)) = id(A' -> B')" .
  next
    from \<open>f\<in>_\<close> \<open>g\<in>_\<close>
    have "(\<And>x. x \<in> A \<rightarrow> B \<Longrightarrow> g O x O f \<in> A' \<rightarrow> B')"
      using bij_is_fun comp_fun by blast
    then
    have "(\<lambda>x\<in>A' -> B'. converse(g) O x O converse(f)) O (\<lambda>x\<in>A -> B. g O x O f)
          = (\<lambda>x\<in>A \<rightarrow> B . (converse(g) O g) O x O (f O converse(f)))"
      using comp_lam comp_assoc by auto
    also
    have "... = (\<lambda>x\<in>A \<rightarrow> B . id(B) O x O (id(A)))"
      using
        right_comp_inverse[OF bij_is_surj[OF \<open>f\<in>_\<close>]]
        left_comp_inverse[OF bij_is_inj[OF \<open>g\<in>_\<close>]] lam_cong
      by auto
    also
    have "... = (\<lambda>x\<in>A \<rightarrow> B . x)"
      using left_comp_id[OF fun_is_rel] right_comp_id[OF fun_is_rel] lam_cong by auto
    also
    have "... = id(A\<rightarrow>B)" unfolding id_def by simp
    finally
    show "(\<lambda>x\<in>A' \<rightarrow> B'. converse(g) O x O converse(f)) O (\<lambda>x\<in>A -> B. g O x O f) = id(A -> B)" .
  qed
qed

lemma curry_eqpoll:
  fixes d \<nu>1 \<nu>2  \<kappa>
  shows "\<nu>1 \<rightarrow> \<nu>2 \<rightarrow> \<kappa> \<approx> \<nu>1 \<times> \<nu>2 \<rightarrow> \<kappa>"
  unfolding eqpoll_def
proof (intro exI, rule lam_bijective,
    rule_tac [1-2] lam_type, rule_tac [2] lam_type)
  fix f z
  assume "f : \<nu>1 \<rightarrow> \<nu>2 \<rightarrow> \<kappa>" "z \<in> \<nu>1 \<times> \<nu>2"
  then
  show "f`fst(z)`snd(z) \<in> \<kappa>"
    by simp
next
  fix f x y
  assume "f : \<nu>1 \<times> \<nu>2 \<rightarrow> \<kappa>" "x\<in>\<nu>1" "y\<in>\<nu>2"
  then
  show "f`\<langle>x,y\<rangle> \<in> \<kappa>" by simp
next \<comment> \<open>one composition is the identity:\<close>
  fix f
  assume "f : \<nu>1 \<times> \<nu>2 \<rightarrow> \<kappa>"
  then
  show "(\<lambda>x\<in>\<nu>1 \<times> \<nu>2. (\<lambda>x\<in>\<nu>1. \<lambda>xa\<in>\<nu>2. f ` \<langle>x, xa\<rangle>) ` fst(x) ` snd(x)) = f"
    by (auto intro:fun_extension)
qed simp \<comment> \<open>the other composition follows automatically\<close>

lemma Pow_eqpoll_function_space:
  fixes d X
  notes bool_of_o_def [simp]
  defines [simp]:"d(A) \<equiv> (\<lambda>x\<in>X. bool_of_o(x\<in>A))"
    \<comment> \<open>the witnessing map for the thesis:\<close>
  shows "Pow(X) \<approx> X \<rightarrow> 2"
  unfolding eqpoll_def
proof (intro exI, rule lam_bijective)
  \<comment> \<open>We give explicit mutual inverses\<close>
  fix A
  assume "A\<in>Pow(X)"
  then
  show "d(A) : X \<rightarrow> 2"
    using lam_type[of _ "\<lambda>x. bool_of_o(x\<in>A)" "\<lambda>_. 2"]
    by force
  from \<open>A\<in>Pow(X)\<close>
  show "{y\<in>X. d(A)`y = 1} = A"
    by (auto)
next
  fix f
  assume "f: X\<rightarrow>2"
  then
  show "d({y \<in> X . f ` y = 1}) = f"
    using apply_type[OF \<open>f: X\<rightarrow>2\<close>]
    by (force intro:fun_extension)
qed blast

lemma cantor_inj: "f \<notin> inj(Pow(A),A)"
  using inj_imp_surj[OF _ Pow_bottom] cantor_surj by blast

definition
  cexp :: "[i,i] \<Rightarrow> i" ("_\<^bsup>\<up>_\<^esup>" [76,1] 75) where
  "\<kappa>\<^bsup>\<up>\<nu>\<^esup> \<equiv> |\<nu> \<rightarrow> \<kappa>|"

lemma Card_cexp: "Card(\<kappa>\<^bsup>\<up>\<nu>\<^esup>)"
  unfolding cexp_def Card_cardinal by simp

lemma eq_csucc_ord:
  "Ord(i) \<Longrightarrow> i\<^sup>+ = |i|\<^sup>+"
  using Card_lt_iff Least_cong unfolding csucc_def by auto

text\<open>I thank Miguel Pagano for this proof.\<close>
lemma lesspoll_csucc:
  assumes "Ord(\<kappa>)"
  shows "d \<prec> \<kappa>\<^sup>+ \<longleftrightarrow> d \<lesssim> \<kappa>"
proof
  assume "d \<prec> \<kappa>\<^sup>+"
  moreover
  note Card_is_Ord \<open>Ord(\<kappa>)\<close>
  moreover from calculation
  have "\<kappa> < \<kappa>\<^sup>+" "Card(\<kappa>\<^sup>+)"
    using Ord_cardinal_eqpoll csucc_basic by simp_all
  moreover from calculation
  have "d \<prec> |\<kappa>|\<^sup>+" "Card(|\<kappa>|)" "d \<approx> |d|"
    using eq_csucc_ord[of \<kappa>] lesspoll_imp_eqpoll eqpoll_sym by simp_all
  moreover from calculation
  have "|d| < |\<kappa>|\<^sup>+"
    using lesspoll_cardinal_lt csucc_basic by simp
  moreover from calculation
  have "|d| \<lesssim> |\<kappa>|"
    using Card_lt_csucc_iff le_imp_lepoll by simp
  moreover from calculation
  have "|d| \<lesssim> \<kappa>"
    using lepoll_eq_trans Ord_cardinal_eqpoll by simp
  ultimately
  show "d \<lesssim> \<kappa>"
    using eq_lepoll_trans by simp
next
  from \<open>Ord(\<kappa>)\<close>
  have "\<kappa> < \<kappa>\<^sup>+" "Card(\<kappa>\<^sup>+)"
    using csucc_basic by simp_all
  moreover
  assume "d \<lesssim> \<kappa>"
  ultimately
  have "d \<lesssim> \<kappa>\<^sup>+"
    using le_imp_lepoll leI lepoll_trans by simp
  moreover
  from \<open>d \<lesssim> \<kappa>\<close> \<open>Ord(\<kappa>)\<close>
  have "\<kappa>\<^sup>+ \<lesssim> \<kappa>" if "d \<approx> \<kappa>\<^sup>+"
    using eqpoll_sym[OF that] eq_lepoll_trans[OF _ \<open>d\<lesssim>\<kappa>\<close>] by simp
  moreover from calculation \<open>Card(_)\<close>
  have "\<not> d \<approx> \<kappa>\<^sup>+"
    using lesspoll_irrefl lesspoll_trans1 lt_Card_imp_lesspoll[OF _ \<open>\<kappa> <_\<close>]
    by auto
  ultimately
  show "d \<prec> \<kappa>\<^sup>+"
    unfolding lesspoll_def by simp
qed

abbreviation
  Infinite :: "i\<Rightarrow>o" where
  "Infinite(X) \<equiv> \<not> Finite(X)"

lemma Infinite_not_empty: "Infinite(X) \<Longrightarrow> X \<noteq> 0"
  using empty_lepollI by auto

lemma Infinite_imp_nats_lepoll:
  assumes "Infinite(X)" "n \<in> \<omega>"
  shows "n \<lesssim> X"
  using \<open>n \<in> \<omega>\<close>
proof (induct)
  case 0
  then
  show ?case using empty_lepollI by simp
next
  case (succ x)
  show ?case
  proof -
    from \<open>Infinite(X)\<close> and \<open>x \<in> \<omega>\<close>
    have "\<not> (x \<approx> X)"
      using eqpoll_sym unfolding Finite_def by auto
    with \<open>x \<lesssim> X\<close>
    obtain f where "f \<in> inj(x,X)" "f \<notin> surj(x,X)"
      unfolding bij_def eqpoll_def by auto
    moreover from this
    obtain b where "b \<in> X" "\<forall>a\<in>x. f`a \<noteq> b"
      using inj_is_fun unfolding surj_def by auto
    ultimately
    have "f \<in> inj(x,X-{b})"
      unfolding inj_def by (auto intro:Pi_type)
    then
    have "cons(\<langle>x, b\<rangle>, f) \<in> inj(succ(x), cons(b, X - {b}))"
      using inj_extend[of f x "X-{b}" x b] unfolding succ_def
      by (auto dest:mem_irrefl)
    moreover from \<open>b\<in>X\<close>
    have "cons(b, X - {b}) = X" by auto
    ultimately
    show "succ(x) \<lesssim> X" by auto
  qed
qed

lemma zero_lesspoll: assumes "0<\<kappa>" shows "0 \<prec> \<kappa>"
  using assms eqpoll_0_iff[THEN iffD1, of \<kappa>] eqpoll_sym
  unfolding lesspoll_def lepoll_def
  by (auto simp add:inj_def)

lemma lepoll_nat_imp_Infinite: "\<omega> \<lesssim> X \<Longrightarrow> Infinite(X)"
proof (rule ccontr, simp)
  assume "\<omega> \<lesssim> X" "Finite(X)"
  moreover from this
  obtain n where "X \<approx> n" "n \<in> \<omega>"
    unfolding Finite_def by auto
  moreover from calculation
  have "\<omega> \<lesssim> n"
    using lepoll_eq_trans by simp
  ultimately
  show "False"
    using lepoll_nat_imp_Finite nat_not_Finite by simp
qed

lemma InfCard_imp_Infinite: "InfCard(\<kappa>) \<Longrightarrow> Infinite(\<kappa>)"
  using le_imp_lepoll[THEN lepoll_nat_imp_Infinite, of \<kappa>]
  unfolding InfCard_def by simp

lemma lt_surj_empty_imp_Card:
  assumes "Ord(\<kappa>)" "\<And>\<alpha>. \<alpha> < \<kappa> \<Longrightarrow> surj(\<alpha>,\<kappa>) = 0"
  shows "Card(\<kappa>)"
proof -
  {
    assume "|\<kappa>| < \<kappa>"
    with assms
    have "False"
      using LeastI[of "\<lambda>i. i \<approx> \<kappa>" \<kappa>, OF eqpoll_refl]
        Least_le[of "\<lambda>i. i \<approx> \<kappa>" "|\<kappa>|", OF Ord_cardinal_eqpoll]
      unfolding Card_def cardinal_def eqpoll_def bij_def
      by simp
  }
  with assms
  show ?thesis
    using Ord_cardinal_le[of \<kappa>] not_lt_imp_le[of "|\<kappa>|" \<kappa>] le_anti_sym
    unfolding Card_def by auto
qed

subsection\<open>Morphisms of binary relations\<close>

text\<open>The main case of interest is in the case of partial orders.\<close>

lemma mono_map_mono:
  assumes
    "f \<in> mono_map(A,r,B,s)" "B \<subseteq> C"
  shows
    "f \<in> mono_map(A,r,C,s)"
  unfolding mono_map_def
proof (intro CollectI ballI impI)
  from \<open>f \<in> mono_map(A,_,B,_)\<close>
  have "f: A \<rightarrow> B"
    using mono_map_is_fun by simp
  with \<open>B\<subseteq>C\<close>
  show "f: A \<rightarrow> C"
    using fun_weaken_type by simp
  fix x y
  assume "x\<in>A" "y\<in>A" "\<langle>x,y\<rangle> \<in> r"
  moreover from this and \<open>f: A \<rightarrow> B\<close>
  have "f`x \<in> B" "f`y \<in> B"
    using apply_type by simp_all
  moreover
  note \<open>f \<in> mono_map(_,r,_,s)\<close>
  ultimately
  show "\<langle>f ` x, f ` y\<rangle> \<in> s"
    unfolding mono_map_def by blast
qed

lemma ordertype_zero_imp_zero: "ordertype(A,r) = 0 \<Longrightarrow> A = 0"
  using ordermap_type[of A r]
  by (cases "A=0") auto

lemma mono_map_increasing:
  "j\<in>mono_map(A,r,B,s) \<Longrightarrow> a\<in>A \<Longrightarrow> c\<in>A \<Longrightarrow> \<langle>a,c\<rangle>\<in>r \<Longrightarrow> \<langle>j`a,j`c\<rangle>\<in>s"
  unfolding mono_map_def by simp

lemma linear_mono_map_reflects:
  assumes
    "linear(\<alpha>,r)" "trans[\<beta>](s)" "irrefl(\<beta>,s)" "f\<in>mono_map(\<alpha>,r,\<beta>,s)"
    "x\<in>\<alpha>" "y\<in>\<alpha>" "\<langle>f`x,f`y\<rangle>\<in>s"
  shows
    "\<langle>x,y\<rangle>\<in>r"
proof -
  from \<open>f\<in>mono_map(_,_,_,_)\<close>
  have preserves:"x\<in>\<alpha> \<Longrightarrow> y\<in>\<alpha> \<Longrightarrow> \<langle>x,y\<rangle>\<in>r \<Longrightarrow> \<langle>f`x,f`y\<rangle>\<in>s" for x y
    unfolding mono_map_def by blast
  {
    assume "\<langle>x, y\<rangle> \<notin> r" "x\<in>\<alpha>" "y\<in>\<alpha>"
    moreover
    note \<open>\<langle>f`x,f`y\<rangle>\<in>s\<close> and \<open>linear(\<alpha>,r)\<close>
    moreover from calculation
    have "y = x \<or> \<langle>y,x\<rangle>\<in>r"
      unfolding linear_def by blast
    moreover
    note preserves [of y x]
    ultimately
    have "y = x \<or> \<langle>f`y, f`x\<rangle>\<in> s" by blast
    moreover from \<open>f\<in>mono_map(_,_,\<beta>,_)\<close> \<open>x\<in>\<alpha>\<close> \<open>y\<in>\<alpha>\<close>
    have "f`x\<in>\<beta>" "f`y\<in>\<beta>"
      using apply_type[OF mono_map_is_fun] by simp_all
    moreover
    note \<open>\<langle>f`x,f`y\<rangle>\<in>s\<close>  \<open>trans[\<beta>](s)\<close> \<open>irrefl(\<beta>,s)\<close>
    ultimately
    have "False"
      using trans_onD[of \<beta> s "f`x" "f`y" "f`x"] irreflE by blast
  }
  with assms
  show "\<langle>x,y\<rangle>\<in>r" by blast
qed

lemma irrefl_Memrel: "irrefl(x, Memrel(x))"
  unfolding irrefl_def using mem_irrefl by auto

lemmas Memrel_mono_map_reflects = linear_mono_map_reflects
  [OF well_ord_is_linear[OF well_ord_Memrel] well_ord_is_trans_on[OF well_ord_Memrel]
    irrefl_Memrel]

\<comment> \<open>Same proof as Paulson's @{thm [source] mono_map_is_inj}\<close>
lemma mono_map_is_inj':
  "\<lbrakk> linear(A,r);  irrefl(B,s);  f \<in> mono_map(A,r,B,s) \<rbrakk> \<Longrightarrow> f \<in> inj(A,B)"
  unfolding irrefl_def mono_map_def inj_def using linearE
  by (clarify, rename_tac x w)
    (erule_tac x=w and y=x in linearE, assumption+, (force intro: apply_type)+)

lemma mono_map_imp_ord_iso_image:
  assumes
    "linear(\<alpha>,r)" "trans[\<beta>](s)"  "irrefl(\<beta>,s)" "f\<in>mono_map(\<alpha>,r,\<beta>,s)"
  shows
    "f \<in> ord_iso(\<alpha>,r,f``\<alpha>,s)"
  unfolding ord_iso_def
proof (intro CollectI ballI iffI)
  \<comment> \<open>Enough to show it's bijective and preserves both ways\<close>
  from assms
  have "f \<in> inj(\<alpha>,\<beta>)"
    using mono_map_is_inj' by blast
  moreover from \<open>f \<in> mono_map(_,_,_,_)\<close>
  have "f \<in> surj(\<alpha>, f``\<alpha>)"
    unfolding mono_map_def using surj_image by auto
  ultimately
  show "f \<in> bij(\<alpha>, f``\<alpha>)"
    unfolding bij_def using inj_is_fun inj_to_Image by simp
  from \<open>f\<in>mono_map(_,_,_,_)\<close>
  show "x\<in>\<alpha> \<Longrightarrow> y\<in>\<alpha> \<Longrightarrow> \<langle>x,y\<rangle>\<in>r \<Longrightarrow> \<langle>f`x,f`y\<rangle>\<in>s" for x y
    unfolding mono_map_def by blast
  with assms
  show "\<langle>f`x,f`y\<rangle>\<in>s \<Longrightarrow> x\<in>\<alpha> \<Longrightarrow> y\<in>\<alpha> \<Longrightarrow> \<langle>x,y\<rangle>\<in>r" for x y
    using linear_mono_map_reflects
    by blast
qed

text\<open>We introduce the following notation for strictly increasing maps
between ordinals.\<close>

abbreviation
  mono_map_Memrel :: "[i,i] \<Rightarrow> i" (infixr \<open>\<rightarrow>\<^sub><\<close> 60) where
  "\<alpha> \<rightarrow>\<^sub>< \<beta> \<equiv> mono_map(\<alpha>,Memrel(\<alpha>),\<beta>,Memrel(\<beta>))"

lemma mono_map_imp_ord_iso_Memrel:
  assumes
    "Ord(\<alpha>)" "Ord(\<beta>)" "f:\<alpha> \<rightarrow>\<^sub>< \<beta>"
  shows
    "f \<in> ord_iso(\<alpha>,Memrel(\<alpha>),f``\<alpha>,Memrel(\<beta>))"
  using assms mono_map_imp_ord_iso_image[OF well_ord_is_linear[OF well_ord_Memrel]
      well_ord_is_trans_on[OF well_ord_Memrel] irrefl_Memrel] by blast

lemma mono_map_ordertype_image':
  assumes
    "X\<subseteq>\<alpha>" "Ord(\<alpha>)" "Ord(\<beta>)" "f \<in> mono_map(X,Memrel(\<alpha>),\<beta>,Memrel(\<beta>))"
  shows
    "ordertype(f``X,Memrel(\<beta>)) = ordertype(X,Memrel(\<alpha>))"
  using assms mono_map_is_fun[of f X _ \<beta>]  ordertype_eq
    mono_map_imp_ord_iso_image[OF well_ord_is_linear[OF well_ord_Memrel, THEN linear_subset]
      well_ord_is_trans_on[OF well_ord_Memrel] irrefl_Memrel, of \<alpha> X \<beta> f]
    well_ord_subset[OF well_ord_Memrel]  Image_sub_codomain[of f X \<beta> X] by auto

lemma mono_map_ordertype_image:
  assumes
    "Ord(\<alpha>)" "Ord(\<beta>)" "f:\<alpha> \<rightarrow>\<^sub>< \<beta>"
  shows
    "ordertype(f``\<alpha>,Memrel(\<beta>)) = \<alpha>"
  using assms mono_map_is_fun ordertype_Memrel ordertype_eq[of f \<alpha> "Memrel(\<alpha>)"]
    mono_map_imp_ord_iso_Memrel well_ord_subset[OF well_ord_Memrel] Image_sub_codomain[of _ \<alpha>]
  by auto

lemma apply_in_image: "f:A\<rightarrow>B \<Longrightarrow> a\<in>A \<Longrightarrow> f`a \<in> f``A"
  using range_eq_image apply_rangeI[of f]  by simp

lemma Image_subset_Ord_imp_lt:
  assumes
    "Ord(\<alpha>)" "h``A \<subseteq> \<alpha>" "x\<in>domain(h)" "x\<in>A" "function(h)"
  shows
    "h`x < \<alpha>"
  using assms
  unfolding domain_def using imageI ltI function_apply_equality by auto

lemma ordermap_le_arg:
  assumes
    "X\<subseteq>\<beta>" "x\<in>X" "Ord(\<beta>)"
  shows
    "x\<in>X \<Longrightarrow> ordermap(X,Memrel(\<beta>))`x\<le>x"
proof (induct rule:Ord_induct[OF subsetD, OF assms])
  case (1 x)
  have "wf[X](Memrel(\<beta>))"
    using wf_imp_wf_on[OF wf_Memrel] .
  with 1
  have "ordermap(X,Memrel(\<beta>))`x = {ordermap(X,Memrel(\<beta>))`y . y\<in>{y\<in>X . y\<in>x \<and> y\<in>\<beta>}}"
    using ordermap_unfold Ord_trans[of _ x \<beta>] by auto
  also from assms
  have "... = {ordermap(X,Memrel(\<beta>))`y . y\<in>{y\<in>X . y\<in>x}}"
    using Ord_trans[of _ x \<beta>] Ord_in_Ord by blast
  finally
  have ordm:"ordermap(X,Memrel(\<beta>))`x = {ordermap(X,Memrel(\<beta>))`y . y\<in>{y\<in>X . y\<in>x}}" .
  from 1
  have "y\<in>x \<Longrightarrow> y\<in>X \<Longrightarrow> ordermap(X,Memrel(\<beta>))`y \<le> y" for y by simp
  with \<open>x\<in>\<beta>\<close> and \<open>Ord(\<beta>)\<close>
  have "y\<in>x \<Longrightarrow> y\<in>X \<Longrightarrow> ordermap(X,Memrel(\<beta>))`y \<in> x" for y
    using ltI[OF _ Ord_in_Ord[of \<beta> x]] lt_trans1 ltD by blast
  with ordm
  have "ordermap(X,Memrel(\<beta>))`x \<subseteq> x" by auto
  with \<open>x\<in>X\<close> assms
  show ?case
    using subset_imp_le Ord_in_Ord[of \<beta> x] Ord_ordermap
      well_ord_subset[OF well_ord_Memrel, of \<beta>] by force
qed

lemma subset_imp_ordertype_le:
  assumes
    "X\<subseteq>\<beta>" "Ord(\<beta>)"
  shows
    "ordertype(X,Memrel(\<beta>))\<le>\<beta>"
proof -
  {
    fix x
    assume "x\<in>X"
    with assms
    have "ordermap(X,Memrel(\<beta>))`x \<le> x"
      using ordermap_le_arg by simp
    with \<open>x\<in>X\<close> and assms
    have "ordermap(X,Memrel(\<beta>))`x \<in> \<beta>" (is "?y \<in> _")
      using ltD[of ?y "succ(x)"] Ord_trans[of  ?y x \<beta>] by auto
  }
  then
  have "ordertype(X, Memrel(\<beta>)) \<subseteq> \<beta>"
    using ordertype_unfold[of X] by auto
  with assms
  show ?thesis
    using subset_imp_le Ord_ordertype[OF well_ord_subset, OF well_ord_Memrel] by simp
qed

lemma mono_map_imp_le:
  assumes
    "f\<in>mono_map(\<alpha>, Memrel(\<alpha>),\<beta>, Memrel(\<beta>))" "Ord(\<alpha>)" "Ord(\<beta>)"
  shows
    "\<alpha>\<le>\<beta>"
proof -
  from assms
  have "f \<in> \<langle>\<alpha>, Memrel(\<alpha>)\<rangle> \<cong> \<langle>f``\<alpha>, Memrel(\<beta>)\<rangle>"
    using mono_map_imp_ord_iso_Memrel by simp
  then
  have "converse(f) \<in> \<langle>f``\<alpha>, Memrel(\<beta>)\<rangle> \<cong> \<langle>\<alpha>, Memrel(\<alpha>)\<rangle>"
    using ord_iso_sym by simp
  with \<open>Ord(\<alpha>)\<close>
  have "\<alpha> = ordertype(f``\<alpha>,Memrel(\<beta>))"
    using ordertype_eq well_ord_Memrel ordertype_Memrel by auto
  also from assms
  have "ordertype(f``\<alpha>,Memrel(\<beta>)) \<le> \<beta>"
    using subset_imp_ordertype_le mono_map_is_fun[of f] Image_sub_codomain[of f] by force
  finally
  show ?thesis .
qed

\<comment> \<open>\<^term>\<open>Ord(A) \<Longrightarrow> f \<in> mono_map(A, Memrel(A), B, Memrel(Aa)) \<Longrightarrow> f \<in> inj(A, B)\<close>\<close>
lemmas Memrel_mono_map_is_inj = mono_map_is_inj
  [OF well_ord_is_linear[OF well_ord_Memrel]
    wf_imp_wf_on[OF wf_Memrel]]

lemma mono_mapI:
  assumes "f: A\<rightarrow>B" "\<And>x y. x\<in>A \<Longrightarrow> y\<in>A \<Longrightarrow> \<langle>x,y\<rangle>\<in>r \<Longrightarrow> \<langle>f`x,f`y\<rangle>\<in>s"
  shows   "f \<in> mono_map(A,r,B,s)"
  unfolding mono_map_def using assms by simp

lemmas mono_mapD = mono_map_is_fun mono_map_increasing

bundle mono_map_rules =  mono_mapI[intro!] mono_map_is_fun[dest] mono_mapD[dest]

lemma nats_le_InfCard:
  assumes "n \<in> \<omega>" "InfCard(\<kappa>)"
  shows "n \<le> \<kappa>"
  using assms Ord_is_Transset
    le_trans[of n \<omega> \<kappa>, OF le_subset_iff[THEN iffD2]]
  unfolding InfCard_def Transset_def by simp

lemma nat_into_InfCard:
  assumes "n \<in> \<omega>" "InfCard(\<kappa>)"
  shows "n \<in> \<kappa>"
  using assms  le_imp_subset[of \<omega> \<kappa>]
  unfolding InfCard_def by auto

subsection\<open>Alephs are infinite cardinals\<close>

lemma Aleph_zero_eq_nat: "\<aleph>\<^bsub>0\<^esub> = \<omega>"
  unfolding Aleph_def by simp

lemma InfCard_Aleph:
  notes Aleph_zero_eq_nat[simp]
  assumes "Ord(\<alpha>)"
  shows "InfCard(\<aleph>\<^bsub>\<alpha>\<^esub>)"
proof -
  have "\<not> (\<aleph>\<^bsub>\<alpha>\<^esub> \<in> \<omega>)"
  proof (cases "\<alpha>=0")
    case True
    then show ?thesis using mem_irrefl by auto
  next
    case False
    with \<open>Ord(\<alpha>)\<close>
    have "\<omega> \<in> \<aleph>\<^bsub>\<alpha>\<^esub>" using Ord_0_lt[of \<alpha>] ltD  by (auto dest:Aleph_increasing)
    then show ?thesis using foundation by blast
  qed
  with \<open>Ord(\<alpha>)\<close>
  have "\<not> (|\<aleph>\<^bsub>\<alpha>\<^esub>| \<in> \<omega>)"
    using Card_cardinal_eq by auto
  then
  have "\<not> Finite(\<aleph>\<^bsub>\<alpha>\<^esub>)" by auto
  with \<open>Ord(\<alpha>)\<close>
  show ?thesis
    using Inf_Card_is_InfCard by simp
qed

text\<open>Most properties of cardinals depend on $\AC$, even for the countable.
Here we just state the definition of this concept, and most proofs will
appear after assuming Choice.\<close>
\<comment> \<open>Kunen's Definition I.10.5\<close>
definition
  countable :: "i\<Rightarrow>o" where
  "countable(X) \<equiv> X \<lesssim> \<omega>"

lemma countableI[intro]: "X \<lesssim> \<omega> \<Longrightarrow> countable(X)"
  unfolding countable_def by simp

lemma countableD[dest]: "countable(X) \<Longrightarrow> X \<lesssim> \<omega>"
  unfolding countable_def by simp

text\<open>A \<^emph>\<open>delta system\<close> is family of sets with a common pairwise
intersection. We will work with this notion in Section~\ref{sec:dsl},
but we state the definition here in order to have it available in a
choiceless context.\<close>

definition
  delta_system :: "i \<Rightarrow> o" where
  "delta_system(D) \<equiv> \<exists>r. \<forall>A\<in>D. \<forall>B\<in>D. A \<noteq> B \<longrightarrow> A \<inter> B = r"

lemma delta_systemI[intro]:
  assumes "\<forall>A\<in>D. \<forall>B\<in>D. A \<noteq> B \<longrightarrow> A \<inter> B = r"
  shows "delta_system(D)"
  using assms unfolding delta_system_def by simp

lemma delta_systemD[dest]:
  "delta_system(D) \<Longrightarrow> \<exists>r. \<forall>A\<in>D. \<forall>B\<in>D. A \<noteq> B \<longrightarrow> A \<inter> B = r"
  unfolding delta_system_def by simp

text\<open>Hence, pairwise intersections equal the intersection of the whole
family.\<close>

lemma delta_system_root_eq_Inter:
  assumes "delta_system(D)"
  shows "\<forall>A\<in>D. \<forall>B\<in>D. A \<noteq> B \<longrightarrow> A \<inter> B = \<Inter>D"
proof (clarify, intro equalityI, auto)
  fix A' B' x C
  assume hyp:"A'\<in>D" "B'\<in> D" "A'\<noteq>B'" "x\<in>A'" "x\<in>B'" "C\<in>D"
  with assms
  obtain r where delta:"\<forall>A\<in>D. \<forall>B\<in>D. A \<noteq> B \<longrightarrow> A \<inter> B = r"
    by auto
  show "x \<in> C"
  proof (cases "C=A'")
    case True
    with hyp and assms
    show ?thesis by simp
  next
    case False
    moreover
    note hyp
    moreover from calculation and delta
    have "r = C \<inter> A'" "A' \<inter> B' = r" "x\<in>r" by auto
    ultimately
    show ?thesis by simp
  qed
qed

lemmas Limit_Aleph = InfCard_Aleph[THEN InfCard_is_Limit]

lemmas Aleph_cont = Normal_imp_cont[OF Normal_Aleph]
lemmas Aleph_sup = Normal_Union[OF _ _ Normal_Aleph]

bundle Ord_dests = Limit_is_Ord[dest] Card_is_Ord[dest]
bundle Aleph_dests = Aleph_cont[dest] Aleph_sup[dest]
bundle Aleph_intros = Aleph_increasing[intro!]
bundle Aleph_mem_dests = Aleph_increasing[OF ltI, THEN ltD, dest]

subsection\<open>Transfinite recursive constructions\<close>

definition
  rec_constr :: "[i,i] \<Rightarrow> i" where
  "rec_constr(f,\<alpha>) \<equiv> transrec(\<alpha>,\<lambda>a g. f`(g``a))"

text\<open>The function \<^term>\<open>rec_constr\<close> allows to perform \<^emph>\<open>recursive
     constructions\<close>: given a choice function on the powerset of some
     set, a transfinite sequence is created by successively choosing
     some new element.

     The next result explains its use.\<close>

lemma rec_constr_unfold: "rec_constr(f,\<alpha>) = f`({rec_constr(f,\<beta>). \<beta>\<in>\<alpha>})"
  using def_transrec[OF rec_constr_def, of f \<alpha>] image_lam by simp

lemma rec_constr_type: assumes "f:Pow(G)\<rightarrow> G" "Ord(\<alpha>)"
  shows "rec_constr(f,\<alpha>) \<in> G"
  using assms(2,1)
  by (induct rule:trans_induct)
    (subst rec_constr_unfold, rule apply_type[of f "Pow(G)" "\<lambda>_. G"], auto)

end


(*  Title:      HOL/Proofs/Lambda/LambdaType.thy
    Author:     Stefan Berghofer
    Copyright   2000 TU Muenchen
*)

section \<open>Simply-typed lambda terms\<close>

theory LambdaType imports ListApplication begin

subsection \<open>Environments\<close>

definition
  shift :: "(nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a"  ("_\<langle>_:_\<rangle>" [90, 0, 0] 91) where
  "e\<langle>i:a\<rangle> = (\<lambda>j. if j < i then e j else if j = i then a else e (j - 1))"

lemma shift_gt [simp]: "j < i \<Longrightarrow> (e\<langle>i:T\<rangle>) j = e j"
  by (simp add: shift_def)

lemma shift_lt [simp]: "i < j \<Longrightarrow> (e\<langle>i:T\<rangle>) j = e (j - 1)"
  by (simp add: shift_def)

lemma shift_commute [simp]: "e\<langle>i:U\<rangle>\<langle>0:T\<rangle> = e\<langle>0:T\<rangle>\<langle>Suc i:U\<rangle>"
  by (rule ext) (simp_all add: shift_def split: nat.split)

subsection \<open>Types and typing rules\<close>

datatype type =
    Atom nat
  | Fun type type    (infixr "\<Rightarrow>" 200)

inductive typing :: "(nat \<Rightarrow> type) \<Rightarrow> dB \<Rightarrow> type \<Rightarrow> bool"  ("_ \<turnstile> _ : _" [50, 50, 50] 50)
  where
    Var [intro!]: "env x = T \<Longrightarrow> env \<turnstile> Var x : T"
  | Abs [intro!]: "env\<langle>0:T\<rangle> \<turnstile> t : U \<Longrightarrow> env \<turnstile> Abs t : (T \<Rightarrow> U)"
  | App [intro!]: "env \<turnstile> s : T \<Rightarrow> U \<Longrightarrow> env \<turnstile> t : T \<Longrightarrow> env \<turnstile> (s \<degree> t) : U"

inductive_cases typing_elims [elim!]:
  "e \<turnstile> Var i : T"
  "e \<turnstile> t \<degree> u : T"
  "e \<turnstile> Abs t : T"

primrec
  typings :: "(nat \<Rightarrow> type) \<Rightarrow> dB list \<Rightarrow> type list \<Rightarrow> bool"
where
    "typings e [] Ts = (Ts = [])"
  | "typings e (t # ts) Ts =
      (case Ts of
        [] \<Rightarrow> False
      | T # Ts \<Rightarrow> e \<turnstile> t : T \<and> typings e ts Ts)"

abbreviation
  typings_rel :: "(nat \<Rightarrow> type) \<Rightarrow> dB list \<Rightarrow> type list \<Rightarrow> bool"
    ("_ \<tturnstile> _ : _" [50, 50, 50] 50) where
  "env \<tturnstile> ts : Ts == typings env ts Ts"

abbreviation
  funs :: "type list \<Rightarrow> type \<Rightarrow> type"  (infixr "\<Rrightarrow>" 200) where
  "Ts \<Rrightarrow> T == foldr Fun Ts T"

subsection \<open>Some examples\<close>

schematic_goal "e \<turnstile> Abs (Abs (Abs (Var 1 \<degree> (Var 2 \<degree> Var 1 \<degree> Var 0)))) : ?T"
  by force

schematic_goal "e \<turnstile> Abs (Abs (Abs (Var 2 \<degree> Var 0 \<degree> (Var 1 \<degree> Var 0)))) : ?T"
  by force

subsection \<open>Lists of types\<close>

lemma lists_typings:
    "e \<tturnstile> ts : Ts \<Longrightarrow> listsp (\<lambda>t. \<exists>T. e \<turnstile> t : T) ts"
  apply (induct ts arbitrary: Ts)
   apply (case_tac Ts)
     apply simp
     apply (rule listsp.Nil)
    apply simp
  apply (case_tac Ts)
   apply simp
  apply simp
  apply (rule listsp.Cons)
   apply blast
  apply blast
  done

lemma types_snoc: "e \<tturnstile> ts : Ts \<Longrightarrow> e \<turnstile> t : T \<Longrightarrow> e \<tturnstile> ts @ [t] : Ts @ [T]"
  apply (induct ts arbitrary: Ts)
  apply simp
  apply (case_tac Ts)
  apply simp+
  done

lemma types_snoc_eq: "e \<tturnstile> ts @ [t] : Ts @ [T] =
  (e \<tturnstile> ts : Ts \<and> e \<turnstile> t : T)"
  apply (induct ts arbitrary: Ts)
  apply (case_tac Ts)
  apply simp+
  apply (case_tac Ts)
  apply (case_tac "ts @ [t]")
  apply simp+
  done

lemma rev_exhaust2 [extraction_expand]:
  obtains (Nil) "xs = []"  |  (snoc) ys y where "xs = ys @ [y]"
  \<comment> \<open>Cannot use \<open>rev_exhaust\<close> from the \<open>List\<close>
    theory, since it is not constructive\<close>
  apply (subgoal_tac "\<forall>ys. xs = rev ys \<longrightarrow> thesis")
  apply (erule_tac x="rev xs" in allE)
  apply simp
  apply (rule allI)
  apply (rule impI)
  apply (case_tac ys)
  apply simp
  apply simp
  done

lemma types_snocE:
  assumes \<open>e \<tturnstile> ts @ [t] : Ts\<close>
  obtains Us and U where \<open>Ts = Us @ [U]\<close> \<open>e \<tturnstile> ts : Us\<close> \<open>e \<turnstile> t : U\<close>
proof (cases Ts rule: rev_exhaust2)
  case Nil
  with assms show ?thesis
    by (cases "ts @ [t]") simp_all
next
  case (snoc Us U)
  with assms have "e \<tturnstile> ts @ [t] : Us @ [U]" by simp
  then have "e \<tturnstile> ts : Us" "e \<turnstile> t : U" by (simp_all add: types_snoc_eq)
  with snoc show ?thesis by (rule that)
qed

subsection \<open>n-ary function types\<close>

lemma list_app_typeD:
    "e \<turnstile> t \<degree>\<degree> ts : T \<Longrightarrow> \<exists>Ts. e \<turnstile> t : Ts \<Rrightarrow> T \<and> e \<tturnstile> ts : Ts"
  apply (induct ts arbitrary: t T)
   apply simp
  apply (rename_tac a b t T)
  apply atomize
  apply simp
  apply (erule_tac x = "t \<degree> a" in allE)
  apply (erule_tac x = T in allE)
  apply (erule impE)
   apply assumption
  apply (elim exE conjE)
  apply (ind_cases "e \<turnstile> t \<degree> u : T" for t u T)
  apply (rule_tac x = "Ta # Ts" in exI)
  apply simp
  done

lemma list_app_typeE:
  "e \<turnstile> t \<degree>\<degree> ts : T \<Longrightarrow> (\<And>Ts. e \<turnstile> t : Ts \<Rrightarrow> T \<Longrightarrow> e \<tturnstile> ts : Ts \<Longrightarrow> C) \<Longrightarrow> C"
  by (insert list_app_typeD) fast

lemma list_app_typeI:
    "e \<turnstile> t : Ts \<Rrightarrow> T \<Longrightarrow> e \<tturnstile> ts : Ts \<Longrightarrow> e \<turnstile> t \<degree>\<degree> ts : T"
  apply (induct ts arbitrary: t T Ts)
   apply simp
  apply (rename_tac a b t T Ts)
  apply atomize
  apply (case_tac Ts)
   apply simp
  apply simp
  apply (erule_tac x = "t \<degree> a" in allE)
  apply (erule_tac x = T in allE)
  apply (rename_tac list)
  apply (erule_tac x = list in allE)
  apply (erule impE)
   apply (erule conjE)
   apply (erule typing.App)
   apply assumption
  apply blast
  done

text \<open>
For the specific case where the head of the term is a variable,
the following theorems allow to infer the types of the arguments
without analyzing the typing derivation. This is crucial
for program extraction.
\<close>

theorem var_app_type_eq:
  "e \<turnstile> Var i \<degree>\<degree> ts : T \<Longrightarrow> e \<turnstile> Var i \<degree>\<degree> ts : U \<Longrightarrow> T = U"
  apply (induct ts arbitrary: T U rule: rev_induct)
  apply simp
  apply (ind_cases "e \<turnstile> Var i : T" for T)
  apply (ind_cases "e \<turnstile> Var i : T" for T)
  apply simp
  apply simp
  apply (ind_cases "e \<turnstile> t \<degree> u : T" for t u T)
  apply (ind_cases "e \<turnstile> t \<degree> u : T" for t u T)
  apply atomize
  apply (erule_tac x="Ta \<Rightarrow> T" in allE)
  apply (erule_tac x="Tb \<Rightarrow> U" in allE)
  apply (erule impE)
  apply assumption
  apply (erule impE)
  apply assumption
  apply simp
  done

lemma var_app_types: "e \<turnstile> Var i \<degree>\<degree> ts \<degree>\<degree> us : T \<Longrightarrow> e \<tturnstile> ts : Ts \<Longrightarrow>
  e \<turnstile> Var i \<degree>\<degree> ts : U \<Longrightarrow> \<exists>Us. U = Us \<Rrightarrow> T \<and> e \<tturnstile> us : Us"
  apply (induct us arbitrary: ts Ts U)
  apply simp
  apply (erule var_app_type_eq)
  apply assumption
  apply simp
  apply (rename_tac a b ts Ts U)
  apply atomize
  apply (case_tac U)
  apply (rule FalseE)
  apply simp
  apply (erule list_app_typeE)
  apply (ind_cases "e \<turnstile> t \<degree> u : T" for t u T)
  apply (rename_tac nat Tsa Ta)
  apply (drule_tac T="Atom nat" and U="Ta \<Rightarrow> Tsa \<Rrightarrow> T" in var_app_type_eq)
  apply assumption
  apply simp
  apply (rename_tac nat type1 type2)
  apply (erule_tac x="ts @ [a]" in allE)
  apply (erule_tac x="Ts @ [type1]" in allE)
  apply (erule_tac x="type2" in allE)
  apply simp
  apply (erule impE)
  apply (rule types_snoc)
  apply assumption
  apply (erule list_app_typeE)
  apply (ind_cases "e \<turnstile> t \<degree> u : T" for t u T)
  apply (drule_tac T="type1 \<Rightarrow> type2" and U="Ta \<Rightarrow> Tsa \<Rrightarrow> T" in var_app_type_eq)
  apply assumption
  apply simp
  apply (erule impE)
  apply (rule typing.App)
  apply assumption
  apply (erule list_app_typeE)
  apply (ind_cases "e \<turnstile> t \<degree> u : T" for t u T)
  apply (frule_tac T="type1 \<Rightarrow> type2" and U="Ta \<Rightarrow> Tsa \<Rrightarrow> T" in var_app_type_eq)
  apply assumption
  apply simp
  apply (erule exE)
  apply (rule_tac x="type1 # Us" in exI)
  apply simp
  apply (erule list_app_typeE)
  apply (ind_cases "e \<turnstile> t \<degree> u : T" for t u T)
  apply (frule_tac T="type1 \<Rightarrow> Us \<Rrightarrow> T" and U="Ta \<Rightarrow> Tsa \<Rrightarrow> T" in var_app_type_eq)
  apply assumption
  apply simp
  done

lemma var_app_typesE: "e \<turnstile> Var i \<degree>\<degree> ts : T \<Longrightarrow>
  (\<And>Ts. e \<turnstile> Var i : Ts \<Rrightarrow> T \<Longrightarrow> e \<tturnstile> ts : Ts \<Longrightarrow> P) \<Longrightarrow> P"
  apply (drule var_app_types [of _ _ "[]", simplified])
  apply (iprover intro: typing.Var)+
  done

lemma abs_typeE: "e \<turnstile> Abs t : T \<Longrightarrow> (\<And>U V. e\<langle>0:U\<rangle> \<turnstile> t : V \<Longrightarrow> P) \<Longrightarrow> P"
  apply (cases T)
  apply (rule FalseE)
  apply (erule typing.cases)
  apply simp_all
  apply atomize
  apply (rename_tac type1 type2)
  apply (erule_tac x="type1" in allE)
  apply (erule_tac x="type2" in allE)
  apply (erule mp)
  apply (erule typing.cases)
  apply simp_all
  done

subsection \<open>Lifting preserves well-typedness\<close>

lemma lift_type [intro!]: "e \<turnstile> t : T \<Longrightarrow> e\<langle>i:U\<rangle> \<turnstile> lift t i : T"
  by (induct arbitrary: i U set: typing) auto

lemma lift_types:
  "e \<tturnstile> ts : Ts \<Longrightarrow> e\<langle>i:U\<rangle> \<tturnstile> (map (\<lambda>t. lift t i) ts) : Ts"
  apply (induct ts arbitrary: Ts)
   apply simp
  apply (case_tac Ts)
   apply auto
  done

subsection \<open>Substitution lemmas\<close>

lemma subst_lemma:
    "e \<turnstile> t : T \<Longrightarrow> e' \<turnstile> u : U \<Longrightarrow> e = e'\<langle>i:U\<rangle> \<Longrightarrow> e' \<turnstile> t[u/i] : T"
  apply (induct arbitrary: e' i U u set: typing)
    apply (rule_tac x = x and y = i in linorder_cases)
      apply auto
  apply blast
  done

lemma substs_lemma:
  "e \<turnstile> u : T \<Longrightarrow> e\<langle>i:T\<rangle> \<tturnstile> ts : Ts \<Longrightarrow>
     e \<tturnstile> (map (\<lambda>t. t[u/i]) ts) : Ts"
  apply (induct ts arbitrary: Ts)
   apply (case_tac Ts)
    apply simp
   apply simp
  apply atomize
  apply (case_tac Ts)
   apply simp
  apply simp
  apply (erule conjE)
  apply (erule (1) subst_lemma)
  apply (rule refl)
  done

subsection \<open>Subject reduction\<close>

lemma subject_reduction: "e \<turnstile> t : T \<Longrightarrow> t \<rightarrow>\<^sub>\<beta> t' \<Longrightarrow> e \<turnstile> t' : T"
  apply (induct arbitrary: t' set: typing)
    apply blast
   apply blast
  apply atomize
  apply (ind_cases "s \<degree> t \<rightarrow>\<^sub>\<beta> t'" for s t t')
    apply hypsubst
    apply (ind_cases "env \<turnstile> Abs t : T \<Rightarrow> U" for env t T U)
    apply (rule subst_lemma)
      apply assumption
     apply assumption
    apply (rule ext)
    apply (case_tac x)
     apply auto
  done

theorem subject_reduction': "t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<Longrightarrow> e \<turnstile> t : T \<Longrightarrow> e \<turnstile> t' : T"
  by (induct set: rtranclp) (iprover intro: subject_reduction)+

subsection \<open>Alternative induction rule for types\<close>

lemma type_induct [induct type]:
  assumes
  "(\<And>T. (\<And>T1 T2. T = T1 \<Rightarrow> T2 \<Longrightarrow> P T1) \<Longrightarrow>
    (\<And>T1 T2. T = T1 \<Rightarrow> T2 \<Longrightarrow> P T2) \<Longrightarrow> P T)"
  shows "P T"
proof (induct T)
  case Atom
  show ?case by (rule assms) simp_all
next
  case Fun
  show ?case by (rule assms) (insert Fun, simp_all)
qed

end


section\<open>The First Monotonicity Calculus\<close>
theory Mcalc
imports Mono
begin

context ProblemIk begin

subsection\<open>Naked variables\<close>

fun nvT where
"nvT (Var x) = {x}"
|
"nvT (Fn f Tl) = {}"

fun nvA where
"nvA (Eq T1 T2) = nvT T1 \<union> nvT T2"
|
"nvA (Pr p Tl) = {}"

fun nvL where
"nvL (Pos at) = nvA at"
|
"nvL (Neg at) = {}"

definition "nvC c \<equiv> \<Union> (set (map nvL c))"

definition "nvPB \<equiv> \<Union> c \<in> \<Phi>. nvC c"

lemma nvT_vars[simp]: "x \<in> nvT T \<Longrightarrow> x \<in> vars T"
by (induct T) (auto split: if_splits)

lemma nvA_varsA[simp]: "x \<in> nvA at \<Longrightarrow> x \<in> varsA at"
by (cases at, auto)

lemma nvL_varsL[simp]: "x \<in> nvL l \<Longrightarrow> x \<in> varsL l"
by (cases l, auto)

lemma nvC_varsC[simp]: "x \<in> nvC c \<Longrightarrow> x \<in> varsC c"
unfolding varsC_def nvC_def by(induct c, auto)

lemma nvPB_varsPB[simp]: "x \<in> nvPB \<Longrightarrow> x \<in> varsPB \<Phi>"
unfolding varsPB_def nvPB_def by auto

subsection\<open>The calculus\<close>

inductive mcalc (infix "\<turnstile>" 40) where
 [simp]: "infTp \<sigma> \<Longrightarrow> \<sigma> \<turnstile> c"
|[simp]: "(\<forall> x \<in> nvC c. tpOfV x \<noteq> \<sigma>) \<Longrightarrow> \<sigma> \<turnstile> c"

lemma mcalc_iff: "\<sigma> \<turnstile> c \<longleftrightarrow> infTp \<sigma> \<or> (\<forall> x \<in> nvC c. tpOfV x \<noteq> \<sigma>)"
unfolding mcalc.simps by simp

end (* context ProblemIk *)

locale ProblemIkMcalc = ProblemIk wtFsym wtPsym arOf resOf parOf \<Phi> infTp
for wtFsym :: "'fsym \<Rightarrow> bool" and wtPsym :: "'psym \<Rightarrow> bool"
and arOf :: "'fsym \<Rightarrow> 'tp list"
and resOf and parOf and \<Phi> and infTp
+ assumes mcalc: "\<And> \<sigma> c. c \<in> \<Phi> \<Longrightarrow> \<sigma> \<turnstile> c"

locale ModelIkMcalc =
ModelIk wtFsym wtPsym arOf resOf parOf \<Phi> infTp intT intF intP +
ProblemIkMcalc wtFsym wtPsym arOf resOf parOf \<Phi> infTp
for wtFsym :: "'fsym \<Rightarrow> bool" and wtPsym :: "'psym \<Rightarrow> bool"
and arOf :: "'fsym \<Rightarrow> 'tp list"
and resOf and parOf and \<Phi> and infTp and intT and intF and intP

subsection\<open>Extension of a structure to an infinite structure
by adding indistinguishable elements\<close>

context ModelIkMcalc begin

text\<open>The projection from univ to a structure:\<close>

definition proj where "proj \<sigma> a \<equiv> if intT \<sigma> a then a else pickT \<sigma>"

lemma intT_proj[simp]: "intT \<sigma> (proj \<sigma> a)"
unfolding proj_def using pickT by auto

lemma proj_id[simp]: "intT \<sigma> a \<Longrightarrow> proj \<sigma> a = a"
unfolding proj_def by auto

lemma surj_proj:
assumes "intT \<sigma> a"   shows "\<exists> b. proj \<sigma> b = a"
using assms by (intro exI[of _ a]) simp

definition "I_intT \<sigma> (a::univ) \<equiv> infTp \<sigma> \<longrightarrow> intT \<sigma> a"
definition "I_intF f al \<equiv> intF f (map2 proj (arOf f) al)"
definition "I_intP p al \<equiv> intP p (map2 proj (parOf p) al)"

lemma not_infTp_I_intT[simp]: "\<not> infTp \<sigma> \<Longrightarrow> I_intT \<sigma> a" unfolding I_intT_def by simp

lemma infTp_I_intT[simp]: "infTp \<sigma> \<Longrightarrow> I_intT \<sigma> a = intT \<sigma> a" unfolding I_intT_def by simp

lemma NE_I_intT: "NE (I_intT \<sigma>)"
using NE_intT by (cases "infTp \<sigma>", auto)

lemma I_intF:
assumes f: "wtFsym f" and al: "list_all2 I_intT (arOf f) al"
shows "I_intT (resOf f) (I_intF f al)"
unfolding I_intT_def I_intF_def apply safe apply(rule intF[OF f])
using al unfolding list_all2_length by auto

lemma Tstruct_I_intT: "Tstruct I_intT"
by standard (rule NE_I_intT)

lemma inf_I_intT: "infinite {a. I_intT \<sigma> a}"
by (cases "infTp \<sigma>", auto)

lemma InfStruct: "IInfStruct I_intT I_intF I_intP"
apply standard using NE_I_intT I_intF Tstruct_I_intT inf_I_intT by auto

end (* context ModelIkMcalc *)

sublocale ModelIkMcalc < InfStruct where
intT = I_intT and intF = I_intF and intP = I_intP
using InfStruct .

subsection\<open>The soundness of the calculus\<close>

text\<open>In what follows, ``Ik'' stands for the original
(augmented with infiniteness-knowledge)
and ``I'' for the infinite structure constructed from it
through the above sublocale statement.\<close>

context ModelIkMcalc begin

text\<open>The environment translation along the projection:\<close>
definition "transE \<xi> \<equiv> \<lambda> x. proj (tpOfV x) (\<xi> x)"

lemma wtE_transE[simp]: "I.wtE \<xi> \<Longrightarrow> Ik.wtE (transE \<xi>)"
unfolding Ik.wtE_def I.wtE_def transE_def by auto

abbreviation "Ik_intT \<equiv> intT"
abbreviation "Ik_intF \<equiv> intF"
abbreviation "Ik_intP \<equiv> intP"

lemma Ik_intT_int:
assumes wt: "Ik.wt T" and \<xi>: "I.wtE \<xi>"
and snv: "\<And> \<sigma>. infTp \<sigma> \<or> (\<forall> x \<in> nvT T. tpOfV x \<noteq> \<sigma>)"
shows "Ik_intT (tpOf T) (I.int \<xi> T)"
proof(cases "\<exists> x. T = Var x")
  case True then obtain x where T: "T = Var x" by auto
  show ?thesis proof(cases "infTp (tpOf T)")
    case True thus ?thesis using T using wtE_transE[OF \<xi>]
    by (metis I.wt_int I_intT_def \<xi> wt)
  next
    case False hence "\<forall> x \<in> nvT T. tpOfV x \<noteq> tpOf T" using snv by auto
    hence "Ik.full (tpOf T)" using T by (cases T, simp_all)
    thus ?thesis unfolding Ik.full_def by simp
  qed
next
  case False hence nonVar: "\<not> (\<exists> x. T = Var x)" by (cases T, auto)
  thus ?thesis using nonVar wt apply(induct T, force)
  unfolding I_intF_def tpOf.simps int.simps
  apply(rule Ik.intF, simp) apply(rule listAll2_map2I) by auto
qed

lemma int_transE_proj:
  assumes wt: "Ik.wt T"
  shows "Ik.int (transE \<xi>) T = proj (tpOf T) (I.int \<xi> T)"
  using wt proof (induct T)
  case (Fn f Tl)
  have 0: "Ik_intT (resOf f) (I_intF f (map (int \<xi>) Tl))" (is "Ik_intT ?\<sigma> ?a")
    unfolding I_intF_def apply(rule Ik.intF)
    using Fn unfolding list_all2_length list_all_iff by auto
  have 1: "proj ?\<sigma> ?a = ?a" using proj_id[OF 0] .
  show ?case
    using [[unfold_abs_def = false]]
    unfolding Ik.int.simps int.simps tpOf.simps 1
    unfolding I_intF_def apply(rule arg_cong[of _ _ "intF f"])
  proof (rule nth_equalityI)
    have l[simp]: "length (arOf f) = length Tl" using Fn by simp
    fix i assume "i < length (map (Ik.int (transE \<xi>)) Tl)"
    hence i[simp]: "i < length Tl" by simp
    have 0: "arOf f ! i = tpOf (Tl ! i)" using Fn by simp
    have [simp]: "Ik.int (transE \<xi>) (Tl ! i) = proj (arOf f ! i) (I.int \<xi> (Tl ! i))"
      unfolding 0 using Fn by (auto simp: list_all_length transE_def)
    show "map (Ik.int (transE \<xi>)) Tl ! i =
          map2 proj (arOf f) (map (I.int \<xi>) Tl) ! i"
      using Fn unfolding list_all_length by simp
  qed(use Fn in simp)
qed simp

lemma int_transE_snv[simp]:
assumes wt: "Ik.wt T" and \<xi>: "I.wtE \<xi>" and snv: "\<And> \<sigma>. infTp \<sigma> \<or> (\<forall> x \<in> nvT T. tpOfV x \<noteq> \<sigma>)"
shows "Ik.int (transE \<xi>) T = I.int \<xi> T"
unfolding int_transE_proj[OF wt] apply(rule proj_id)
using Ik_intT_int[OF wt \<xi> snv] .

lemma int_transE_Fn:
assumes wt: "list_all wt Tl" and f: "wtFsym f" and \<xi>: "I.wtE \<xi>"
and ar: "arOf f = map tpOf Tl"
shows "Ik.int (transE \<xi>) (Fn f Tl) = I.int \<xi> (Fn f Tl)"
apply(rule int_transE_snv) using assms by auto

lemma intP_transE[simp]:
assumes wt: "list_all wt Tl" and p: "wtPsym p" and ar: "parOf p = map tpOf Tl"
shows "Ik_intP p (map (Ik.int (transE \<xi>)) Tl) = I_intP p (map (I.int \<xi>) Tl)"
unfolding I_intP_def apply(rule arg_cong[of _ _ "Ik_intP p"])
apply(rule nth_equalityI) using assms
using int_transE_proj unfolding list_all_length by auto

lemma satA_snvA_transE[simp]:
assumes wtA: "Ik.wtA at" and \<xi>: "I.wtE \<xi>"
and pA: "\<And> \<sigma>. infTp \<sigma> \<or> (\<forall> x \<in> nvA at. tpOfV x \<noteq> \<sigma>)"
shows "Ik.satA (transE \<xi>) at \<longleftrightarrow> I.satA \<xi> at"
using assms apply (cases at, simp_all add: ball_Un) by (metis int_transE_snv)

(* The next contrapositive twist is crucial for proving satL_transE: *)
lemma satA_transE[simp]:
assumes wtA: "Ik.wtA at" and "I.satA \<xi> at"
shows "Ik.satA (transE \<xi>) at"
using assms apply(cases at) using int_transE_proj by auto

lemma satL_snvL_transE[simp]:
assumes wtL: "Ik.wtL l" and \<xi>: "I.wtE \<xi>"
and pL: "\<And> \<sigma>. infTp \<sigma> \<or> (\<forall> x \<in> nvL l. tpOfV x \<noteq> \<sigma>)" and "Ik.satL (transE \<xi>) l"
shows "I.satL \<xi> l"
using assms by (cases l) auto

lemma satC_snvC_transE[simp]:
assumes wtC: "Ik.wtC c" and \<xi>: "I.wtE \<xi>"
and pC: "\<And> \<sigma>. \<sigma> \<turnstile> c" and "Ik.satC (transE \<xi>) c"
shows "I.satC \<xi> c"
using assms unfolding Ik.mcalc_iff Ik.satC_def satC_def Ik.wtC_def nvC_def
unfolding list_all_iff list_ex_iff apply simp by (metis nth_mem satL_snvL_transE)

lemma satPB_snvPB_transE[simp]:
assumes \<xi>: "I.wtE \<xi>"  shows "I.satPB \<xi> \<Phi>"
using Ik.wt_\<Phi> Ik.sat_\<Phi>[OF wtE_transE[OF \<xi>]]
using mcalc \<xi> unfolding Ik.satPB_def satPB_def Ik.wtPB_def nvPB_def by auto

lemma I_SAT: "I.SAT \<Phi>" unfolding I.SAT_def by auto

lemma InfModel: "IInfModel I_intT I_intF I_intP"
by standard (rule I_SAT)

end (* context ModelIkMcalc *)

sublocale ModelIkMcalc < inf?: InfModel where
intT = I_intT and intF = I_intF and intP = I_intP
using InfModel .

context ProblemIkMcalc begin

abbreviation "MModelIkMcalc \<equiv> ModelIkMcalc wtFsym wtPsym arOf resOf parOf \<Phi> infTp"

end (* context ProblemIkMcalc *)

text\<open>Final theorem in sublocale form: Any problem that passes the
  monotonicity calculus is monotonic:\<close>

sublocale ProblemIkMcalc < MonotProblem
by standard (rule monot)

end