header "Hash-Tables"
theory Hash_Table
  imports "../../Collections/Lib/HashCode" "../Sep_Main"
begin

subsection {* Datatype *}

subsubsection {* Definition *}

datatype ('k, 'v) hashtable = HashTable "('k \<times> 'v) list array" nat

primrec the_array :: "('k, 'v) hashtable \<Rightarrow> ('k \<times> 'v) list array" where
  "the_array (HashTable a _) = a"

primrec the_size :: "('k, 'v) hashtable \<Rightarrow> nat" where
  "the_size (HashTable _ n) = n"

subsubsection {* Storable on Heap *}

fun
  hs_encode :: "('k::countable, 'v::countable) hashtable \<Rightarrow> nat"
  where
  "hs_encode (HashTable a n) = to_nat (n, a)"

instance hashtable :: (countable, countable) countable
proof (rule countable_classI[of "hs_encode"])
  case goal1 thus ?case
    by (cases x, cases y, auto)
qed

instance hashtable :: (heap, heap) heap ..

subsection {* Assertions *}

subsubsection {* Assertion for Hashtable *}

definition ht_table
  :: "('k\<Colon>heap \<times> 'v\<Colon>heap) list list \<Rightarrow> ('k, 'v) hashtable \<Rightarrow> assn"
  where
  "ht_table l ht = (the_array ht) \<mapsto>\<^sub>a l"

definition ht_size :: "'a list list \<Rightarrow> nat \<Rightarrow> bool" where
  "ht_size l n \<equiv> n = listsum (map length l)"

definition ht_hash :: "('k\<Colon>hashable \<times> 'v) list list \<Rightarrow> bool" where
  "ht_hash l
  \<equiv> \<forall>i<length l. \<forall>x\<in>set (l!i).
      bounded_hashcode_nat (length l) (fst x) = i"

definition ht_distinct :: "('k \<times> 'v) list list \<Rightarrow> bool" where
  "ht_distinct l \<equiv> \<forall>i<length l. distinct (map fst (l!i))"

definition is_hashtable
  :: "('k\<Colon>{heap,hashable} \<times> 'v\<Colon>heap) list list
    \<Rightarrow> ('k, 'v) hashtable \<Rightarrow> assn"
  where
  "is_hashtable l ht =
  (the_array ht \<mapsto>\<^sub>a l) *
  \<up>(ht_size l (the_size ht)
    \<and> ht_hash l
    \<and> ht_distinct l
    \<and> 1 < length l)"

lemma is_hashtable_prec:
  "precise is_hashtable"
  apply rule
  unfolding is_hashtable_def
  by (auto simp add: preciseD[OF snga_prec])

text {* These rules are quite useful for automated methods, to avoid unfolding
  of definitions, that might be used folded in other lemmas,
  like induction hypothesis. However, they show in some sense a possibility for
  modularization improvement, as it should be enough to show an implication
  and know that the @{text "nth"} and @{text "len"} operations do not change
  the heap. *}
lemma ht_array_nth_rule[sep_heap_rules]:
    "i<length l \<Longrightarrow> <is_hashtable l ht>
      Array.nth (the_array ht) i
      <\<lambda>r. is_hashtable l ht * \<up>(r = l!i)>"
  unfolding is_hashtable_def
  by sep_auto

lemma ht_array_length_rule[sep_heap_rules]:
    "<is_hashtable l ht>
      Array.len (the_array ht)
      <\<lambda>r. is_hashtable l ht * \<up>(r = length l)>"
  unfolding is_hashtable_def
  by sep_auto

subsection {* New *}

subsubsection {* Definition *}

definition ht_new_sz
  :: "nat \<Rightarrow> ('k\<Colon>{heap,hashable}, 'v\<Colon>heap) hashtable Heap"
  where
  "ht_new_sz n \<equiv> do { let l = replicate n [];
  a \<leftarrow> Array.of_list l;
  return (HashTable a 0) }"

definition ht_new :: "('k\<Colon>{heap,hashable}, 'v\<Colon>heap) hashtable Heap"
  where "ht_new \<equiv> ht_new_sz (def_hashmap_size TYPE('k))"

subsubsection {* Complete Correctness *}

lemma ht_hash_replicate[simp, intro!]: "ht_hash (replicate n [])"
  apply (induct n)
  apply (auto simp add: ht_hash_def)
  apply (case_tac i)
  apply auto
  done

lemma ht_size_replicate[simp, intro!]: "ht_size (replicate n []) 0"
  by (simp add: ht_size_def)

 -- "We can't create hash tables with a size of zero"
lemma complete_ht_new_sz:
  shows "1 < n \<Longrightarrow> <emp> ht_new_sz n <is_hashtable (replicate n [])>"
  apply (unfold ht_new_sz_def)
  apply (simp del: replicate.simps)
  apply (rule bind_rule)
  apply (rule of_list_rule)
  apply (rule return_cons_rule)
  apply (simp add: is_hashtable_def)
  done

lemma complete_ht_new:
  shows
  "<emp>
     ht_new::('k\<Colon>{heap,hashable}, 'v\<Colon>heap) hashtable Heap
   <is_hashtable (replicate (def_hashmap_size TYPE('k)) [])>"
  unfolding ht_new_def
  by (simp add: complete_ht_new_sz[OF def_hashmap_size])

subsection {* Lookup *}

subsubsection {* Definition *}

fun ls_lookup :: "'k \<Rightarrow> ('k \<times> 'v) list \<Rightarrow> 'v option" where
  "ls_lookup x [] = None" |
  "ls_lookup x ((k, v) # l) = (if x = k then Some v else ls_lookup x l)"

definition ht_lookup
  :: "'k \<Rightarrow> ('k\<Colon>{heap,hashable}, 'v\<Colon>heap) hashtable \<Rightarrow> 'v option Heap"
  where
  "ht_lookup x ht = do {
    m \<leftarrow> Array.len (the_array ht);
    let i = bounded_hashcode_nat m x;
    l \<leftarrow> Array.nth (the_array ht) i;
    return (ls_lookup x l)
  }"

subsubsection {* Complete Correctness *}

lemma complete_ht_lookup:
  "<is_hashtable l ht> ht_lookup x ht
     <\<lambda>r. is_hashtable l ht *
        \<up>(r = ls_lookup x (l!(bounded_hashcode_nat (length l) x))) >"
  apply (cases ht)
  apply (clarsimp simp: is_hashtable_def)
  apply (simp add: ht_lookup_def)
  apply (rule bind_rule)
  apply (rule length_rule)
  apply (rule norm_pre_pure_rule)
  apply (rule bind_rule)
  apply (rule nth_rule)
  apply (simp add: bounded_hashcode_nat_bounds)
  apply (rule norm_pre_pure_rule)
  apply (rule return_cons_rule)
  by simp

text {* Alternative, more automatic proof *}
lemma complete_ht_lookup_alt_proof:
  "<is_hashtable l ht> ht_lookup x ht
    <\<lambda>r. is_hashtable l ht *
      \<up>(r = ls_lookup x (l!(bounded_hashcode_nat (length l) x)))>"
  unfolding is_hashtable_def ht_lookup_def
  apply (cases ht)
  apply (sep_auto simp: bounded_hashcode_nat_bounds)
  done

subsection {* Update *}

subsubsection {* Definition *}

fun ls_update :: "'k \<Rightarrow> 'v \<Rightarrow> ('k \<times> 'v) list \<Rightarrow> (('k \<times> 'v) list \<times> bool)" where
  "ls_update k v [] = ([(k, v)], False)" |
  "ls_update k v ((l, w) # ls) = (
    if k = l then
      ((k, v) # ls, True)
    else
      (let r = ls_update k v ls in ((l, w) # fst r, snd r))
  )"

definition abs_update
  :: "'k\<Colon>hashable \<Rightarrow> 'v \<Rightarrow> ('k \<times> 'v) list list \<Rightarrow> ('k \<times> 'v) list list"
  where
  "abs_update k v l =
    l[bounded_hashcode_nat (length l) k
      := fst (ls_update k v (l ! bounded_hashcode_nat (length l) k))]"

lemma ls_update_snd_set:
  "snd (ls_update k v l) \<longleftrightarrow> k \<in> set (map fst l)"
  by (induct l rule: ls_update.induct) simp_all

lemma ls_update_fst_set:
  "set (fst (ls_update k v l)) \<subseteq> insert (k, v) (set l)"
  apply (induct l rule: ls_update.induct)
  apply simp
  by (auto simp add: Let_def)

lemma ls_update_fst_map_set:
  "set (map fst (fst (ls_update k v l))) = insert k (set (map fst l))"
  apply (induct l rule: ls_update.induct)
  apply simp
  by (auto simp add: Let_def)

lemma ls_update_distinct: "distinct (map fst l)
  \<Longrightarrow> distinct (map fst (fst (ls_update k v l)))"
proof (induct l rule: ls_update.induct)
  case goal1 thus ?case by simp
next
  case goal2 show ?case
  proof (cases "k = l")
    case True
    with goal2 show ?thesis by simp
  next
    case False
    with goal2 have d: "distinct (map fst (fst (ls_update k v ls)))"
      by simp
    from goal2(2) have "l \<notin> set (map fst ls)" by simp
    with False have "l \<notin> set (map fst (fst (ls_update k v ls)))"
      apply (simp only: ls_update_fst_map_set) by simp
    with d False show ?thesis by (simp add: Let_def)
  qed
qed

lemma ls_update_length: "length (fst (ls_update k v l))
  = (if (k \<in> set (map fst l)) then length l else Suc (length l))"
  apply (induct l rule: ls_update.induct)
  by (auto simp add: Let_def)

lemma ls_update_length_snd_True:
  "snd (ls_update k v l) \<Longrightarrow> length (fst (ls_update k v l)) = length l"
  by (simp add: ls_update_length ls_update_snd_set)

lemma ls_update_length_snd_False:
  "\<not> snd (ls_update k v l)
  \<Longrightarrow> length (fst (ls_update k v l)) = Suc (length l)"
  by (simp add: ls_update_length ls_update_snd_set)

definition ht_upd
  :: "'k \<Rightarrow> 'v
    \<Rightarrow> ('k\<Colon>{heap,hashable}, 'v\<Colon>heap) hashtable
    \<Rightarrow> ('k, 'v) hashtable Heap"
  where
  "ht_upd k v ht = do {
      m \<leftarrow> Array.len (the_array ht);
      let i = bounded_hashcode_nat m k;
      l \<leftarrow> Array.nth (the_array ht) i;
      let l = ls_update k v l;
      Array.upd i (fst l) (the_array ht);
      let n = (if (snd l) then the_size ht else Suc (the_size ht));
      return (HashTable (the_array ht) n)
    }"

subsubsection {* Complete Correctness *}
lemma ht_hash_update:
  assumes "ht_hash ls"
  shows "ht_hash (abs_update k v ls)"
  unfolding ht_hash_def abs_update_def
proof (intro allI ballI impI, simp)
  case goal1 show ?case
    proof (cases "i = bounded_hashcode_nat (length ls) k")
      case True
      note i = True
      show ?thesis
      proof (cases "fst x = k")
        case True
        with i show ?thesis by simp
      next
        case False
        with goal1 i
        have
          "x \<in> set (fst (ls_update k v
                           (ls ! bounded_hashcode_nat (length ls) k)))"
          by auto
        with
          ls_update_fst_set[
            of k v "ls ! bounded_hashcode_nat (length ls) k"]
          False
        have "x \<in> insert (k, v)
                    (set (ls ! bounded_hashcode_nat (length ls) k))"
          by auto
        with False have "x \<in> set (ls ! bounded_hashcode_nat (length ls) k)"
          by auto
        with i goal1 assms[unfolded ht_hash_def] show ?thesis by simp
      qed
    next
      case False
      with goal1 have "x \<in> set (ls ! i)" by simp
      with goal1 assms[unfolded ht_hash_def] show ?thesis by simp
    qed
qed

lemma ht_distinct_update:
  assumes "ht_distinct l"
  shows "ht_distinct (abs_update k v l)"
  unfolding ht_distinct_def abs_update_def
proof (intro allI impI, simp)
  case goal1 show ?case
  proof (cases "i = bounded_hashcode_nat (length l) k")
    case True
    with goal1 assms[unfolded ht_distinct_def]
    have "distinct (map fst (l ! bounded_hashcode_nat (length l) k))"
      by simp
    from ls_update_distinct[OF this, of k v] True goal1
    show ?thesis by simp
  next
    case False
    with goal1 assms[unfolded ht_distinct_def] show ?thesis by simp
  qed
qed

lemma length_update:
  assumes "1 < length l"
  shows "1 < length (abs_update k v l)"
  using assms
  by (simp add: abs_update_def)

lemma ht_size_update1:
  assumes size: "ht_size l n"
  assumes i: "i < length l"
  assumes snd: "snd (ls_update k v (l ! i))"
  shows "ht_size (l[i := fst (ls_update k v (l!i))]) n"
proof -
  have "(map length (l[i := fst (ls_update k v (l ! i))]))
    = map length l[i := length (fst (ls_update k v (l ! i)))]"
    by (simp add: map_update) also
  from listsum_update_nat[of i "map length l", simplified, OF i,
    of "length (fst (ls_update k v (l ! i)))"]
    ls_update_length_snd_True[OF snd]
  have
    "listsum (map length l[i := length (fst (ls_update k v (l ! i)))])
    = listsum (map length l)" by simp
  finally show ?thesis using assms by (simp add: ht_size_def assms)
qed

lemma ht_size_update2:
  assumes size: "ht_size l n"
  assumes i: "i < length l"
  assumes snd: "\<not> snd (ls_update k v (l ! i))"
  shows "ht_size (l[i := fst (ls_update k v (l!i))]) (Suc n)"
proof -
  have "(map length (l[i := fst (ls_update k v (l ! i))]))
    = map length l[i := length (fst (ls_update k v (l ! i)))]"
    by (simp add: map_update) also
  from listsum_update_nat[of i "map length l", simplified, OF i,
    of "length (fst (ls_update k v (l ! i)))"]
    ls_update_length_snd_False[OF snd]
  have
    "listsum (map length l[i := length (fst (ls_update k v (l ! i)))])
    = Suc (listsum (map length l))" by simp
  finally show ?thesis using assms by (simp add: ht_size_def assms)
qed

lemma complete_ht_upd: "<is_hashtable l ht> ht_upd k v ht
  <is_hashtable (abs_update k v l)>"
  unfolding ht_upd_def is_hashtable_def
  apply (rule norm_pre_pure_rule)
  apply (rule bind_rule)
  apply (rule length_rule)
  apply (rule norm_pre_pure_rule)
  apply (simp add: Let_def)
  apply (rule bind_rule)
  apply (rule nth_rule)
  apply (simp add: bounded_hashcode_nat_bounds)
  apply (rule norm_pre_pure_rule)
  apply (rule bind_rule)
  apply (rule upd_rule)
  apply (simp add: bounded_hashcode_nat_bounds)
  apply (rule return_cons_rule)

  apply (auto
    simp add: ht_size_update1 ht_size_update2 bounded_hashcode_nat_bounds
              is_hashtable_def ht_hash_update[unfolded abs_update_def]
              ht_distinct_update[unfolded abs_update_def] abs_update_def
  )
  done

text {* Alternative, more automatic proof *}
lemma complete_ht_upd_alt_proof:
  "<is_hashtable l ht> ht_upd k v ht <is_hashtable (abs_update k v l)>"
  unfolding ht_upd_def is_hashtable_def Let_def
  (* TODO: Is this huge simp-step really necessary? *)
  apply (sep_auto
    simp: ht_size_update1 ht_size_update2 bounded_hashcode_nat_bounds
              is_hashtable_def ht_hash_update[unfolded abs_update_def]
              ht_distinct_update[unfolded abs_update_def] abs_update_def
    )
  done

subsection {* Delete *}

subsubsection {* Definition *}

fun ls_delete :: "'k \<Rightarrow> ('k \<times> 'v) list \<Rightarrow> (('k \<times> 'v) list \<times> bool)" where
  "ls_delete k [] = ([], False)" |
  "ls_delete k ((l, w) # ls) = (
    if k = l then
      (ls, True)
    else
      (let r = ls_delete k ls in ((l, w) # fst r, snd r)))"

lemma ls_delete_snd_set:
  "snd (ls_delete k l) \<longleftrightarrow> k \<in> set (map fst l)"
  by (induct l rule: ls_delete.induct) simp_all

lemma ls_delete_fst_set:
  "set (fst (ls_delete k l)) \<subseteq> set l"
  apply (induct l rule: ls_delete.induct)
  apply simp
  by (auto simp add: Let_def)

lemma ls_delete_fst_map_set:
  "distinct (map fst l) \<Longrightarrow>
  set (map fst (fst (ls_delete k l))) = (set (map fst l)) - {k}"
  apply (induct l rule: ls_delete.induct)
  apply simp
  by (auto simp add: Let_def)

lemma ls_delete_distinct: "distinct (map fst l)
  \<Longrightarrow> distinct (map fst (fst (ls_delete k l)))"
proof (induct l rule: ls_delete.induct)
  case goal1 thus ?case by simp
next
  case goal2 show ?case
  proof (cases "k = l")
    case True
    with goal2 show ?thesis by simp
  next
    case False
    with goal2 have d: "distinct (map fst (fst (ls_delete k ls)))"
      by simp
    from goal2 have d2: "distinct (map fst ls)" by simp
    from goal2(2) have "l \<notin> set (map fst ls)" by simp
    with False goal2 ls_delete_fst_map_set[OF d2, of k]
    have "l \<notin> set (map fst (fst (ls_delete k ls)))"
      apply (simp only:) by simp
    with d False show ?thesis by (simp add: Let_def)
  qed
qed

lemma ls_delete_length:
  "length (fst (ls_delete k l)) = (
    if (k \<in> set (map fst l)) then
      (length l - 1)
    else
      length l)"
  apply (induct l rule: ls_delete.induct)
  apply (auto simp add: Let_def)
  apply (case_tac ls)
  by simp_all

lemma ls_delete_length_snd_True:
  "snd (ls_delete k l) \<Longrightarrow> length (fst (ls_delete k l)) = length l - 1"
  by (simp add: ls_delete_length ls_delete_snd_set)

lemma ls_delete_length_snd_False:
  "\<not> snd (ls_delete k l) \<Longrightarrow> length (fst (ls_delete k l)) = length l"
  by (simp add: ls_delete_length ls_delete_snd_set)

definition ht_delete
  :: "'k
    \<Rightarrow> ('k\<Colon>{heap,hashable}, 'v\<Colon>heap) hashtable
    \<Rightarrow> ('k, 'v) hashtable Heap"
  where
  "ht_delete k ht = do {
      m \<leftarrow> Array.len (the_array ht);
      let i = bounded_hashcode_nat m k;
      l \<leftarrow> Array.nth (the_array ht) i;
      let l = ls_delete k l;
      Array.upd i (fst l) (the_array ht);
      let n = (if (snd l) then (the_size ht - 1) else the_size ht);
      return (HashTable (the_array ht) n)
    }"

subsubsection {* Complete Correctness *}

lemma ht_hash_delete:
  assumes "ht_hash ls"
  shows "ht_hash (
    ls[bounded_hashcode_nat (length ls) k
      := fst (ls_delete k
               (ls ! bounded_hashcode_nat (length ls) k)
             )
      ]
  )"
  unfolding ht_hash_def
proof (intro allI ballI impI, simp)
  case goal1 show ?case
    proof (cases "i = bounded_hashcode_nat (length ls) k")
      case True
      note i = True
      show ?thesis
      proof (cases "fst x = k")
        case True
        with i show ?thesis by simp
      next
        case False
        with goal1 i
        have
          "x \<in> set (fst (ls_delete k
                          (ls ! bounded_hashcode_nat (length ls) k)))"
          by auto
        with
          ls_delete_fst_set[
            of k "ls ! bounded_hashcode_nat (length ls) k"]
          False
        have "x \<in> (set (ls ! bounded_hashcode_nat (length ls) k))" by auto
        with i goal1 assms[unfolded ht_hash_def] show ?thesis by simp
      qed
    next
      case False
      with goal1 have "x \<in> set (ls ! i)" by simp
      with goal1 assms[unfolded ht_hash_def] show ?thesis by simp
    qed
qed

lemma ht_distinct_delete:
  assumes "ht_distinct l"
  shows "ht_distinct (
    l[bounded_hashcode_nat (length l) k
      := fst (ls_delete k (l ! bounded_hashcode_nat (length l) k))])"
  unfolding ht_distinct_def
proof (intro allI impI, simp)
  case goal1 show ?case
  proof (cases "i = bounded_hashcode_nat (length l) k")
    case True
    with goal1 assms[unfolded ht_distinct_def]
    have "distinct (map fst (l ! bounded_hashcode_nat (length l) k))"
      by simp
    from ls_delete_distinct[OF this, of k] True goal1
    show ?thesis by simp
  next
    case False
    with goal1 assms[unfolded ht_distinct_def] show ?thesis by simp
  qed
qed

lemma ht_size_delete1:
  assumes size: "ht_size l n"
  assumes i: "i < length l"
  assumes snd: "snd (ls_delete k (l ! i))"
  shows "ht_size (l[i := fst (ls_delete k (l!i))]) (n - 1)"
proof -
  have "(map length (l[i := fst (ls_delete k (l ! i))]))
    = map length l[i := length (fst (ls_delete k (l ! i)))]"
    by (simp add: map_update) also
  from listsum_update_nat[of i "map length l", simplified, OF i,
    of "length (fst (ls_delete k (l ! i)))"]
    ls_delete_length_snd_True[OF snd] snd
  have "listsum (map length l[i := length (fst (ls_delete k (l ! i)))])
    = listsum (map length l) - 1"
    by (cases "length (l ! i)") (simp_all add: ls_delete_snd_set)
  finally show ?thesis using assms by (simp add: ht_size_def assms)
qed

lemma ht_size_delete2:
  assumes size: "ht_size l n"
  assumes i: "i < length l"
  assumes snd: "\<not> snd (ls_delete k (l ! i))"
  shows "ht_size (l[i := fst (ls_delete k (l!i))]) n"
proof -
  have "(map length (l[i := fst (ls_delete k (l ! i))]))
    = map length l[i := length (fst (ls_delete k (l ! i)))]"
    by (simp add: map_update) also
  from listsum_update_nat[of i "map length l", simplified, OF i,
    of "length (fst (ls_delete k (l ! i)))"]
    ls_delete_length_snd_False[OF snd]
  have "listsum (map length l[i := length (fst (ls_delete k (l ! i)))])
    = listsum (map length l)" by simp
  finally show ?thesis using assms by (simp add: ht_size_def assms)
qed

lemma complete_ht_delete: "<is_hashtable l ht> ht_delete k ht
  <is_hashtable (l[bounded_hashcode_nat (length l) k
    := fst (ls_delete k (l ! bounded_hashcode_nat (length l) k))])>"
  unfolding ht_delete_def is_hashtable_def
  apply (rule norm_pre_pure_rule)
  apply (rule bind_rule)
  apply (rule length_rule)
  apply (rule norm_pre_pure_rule)
  apply (simp add: Let_def)
  apply (rule bind_rule)
  apply (rule nth_rule)
  apply (simp add: bounded_hashcode_nat_bounds)
  apply (rule norm_pre_pure_rule)
  apply (rule bind_rule)
  apply (rule upd_rule)
  apply (simp add: bounded_hashcode_nat_bounds)
  apply (rule return_cons_rule)

  apply (auto
    simp add: ht_size_delete1 ht_size_delete2 bounded_hashcode_nat_bounds
              is_hashtable_def ht_hash_delete ht_distinct_delete
              )

  using ht_size_delete1[OF _ bounded_hashcode_nat_bounds[of "length l" k],
    of "the_size ht"]
  by simp

text {* Alternative, more automatic proof *}
lemma "<is_hashtable l ht> ht_delete k ht
  <is_hashtable (l[bounded_hashcode_nat (length l)
    k := fst (ls_delete k (l ! bounded_hashcode_nat (length l) k))])>"
  unfolding ht_delete_def is_hashtable_def Let_def
  using ht_size_delete1[OF _ bounded_hashcode_nat_bounds[of "length l" k],
    of "the_size ht"]
  apply (sep_auto simp:
    ht_size_delete1 ht_size_delete2 bounded_hashcode_nat_bounds
    is_hashtable_def ht_hash_delete ht_distinct_delete
    )
  done

subsection {* Re-Hashing *}
subsubsection {* Auxiliary Functions *}

text {* \paragraph{Insert List} *}
fun ht_insls
  :: "('k \<times> 'v) list
    \<Rightarrow> ('k\<Colon>{heap,hashable}, 'v\<Colon>heap) hashtable
    \<Rightarrow> ('k, 'v\<Colon>heap) hashtable Heap"
  where
  "ht_insls [] ht = return ht" |
  "ht_insls ((k, v) # l) ht = do { h \<leftarrow> ht_upd k v ht; ht_insls l h }"

text "Abstract version"
fun ls_insls :: "('k\<Colon>hashable \<times> 'v) list
  \<Rightarrow> ('k \<times> 'v) list list \<Rightarrow> ('k \<times> 'v) list list" where
  "ls_insls [] l = l" |
  "ls_insls ((k, v) # ls) l =
    ls_insls ls (abs_update k v l)"

lemma ht_hash_ls_insls:
  assumes "ht_hash l"
  shows "ht_hash (ls_insls ls l)"
  using assms
  apply (induct l rule: ls_insls.induct)
  apply simp
  by (simp add: ht_hash_update)

lemma ht_distinct_ls_insls:
  assumes "ht_distinct l"
  shows "ht_distinct (ls_insls ls l)"
  using assms
  apply (induct l rule: ls_insls.induct)
  apply simp
  by (simp add: ht_distinct_update)

lemma length_ls_insls:
  assumes "1 < length l"
  shows "1 < length (ls_insls ls l)"
  using assms
  apply (induct l rule: ls_insls.induct)
  apply simp
proof -
  case goal1
  from goal1(1)[OF length_update[OF goal1(2), of k v]] show ?case
    by simp
qed

lemma complete_ht_insls:
  "<is_hashtable ls ht> ht_insls xs ht <is_hashtable (ls_insls xs ls)>"
proof (induct xs arbitrary: ls ht)
  case goal1 show ?case by (auto intro: return_cons_rule)[]
next
  case (goal2 x xs ls ht)
  note IV = goal2
  show ?case
  proof (cases x)
    case (goal1 k v)
    thus ?case
      apply simp
      apply (rule bind_rule)
      apply (rule complete_ht_upd)
      by (simp add: IV)
  qed
qed

text {* \paragraph{Copy} *}
fun ht_copy :: "nat \<Rightarrow> ('k\<Colon>{heap,hashable}, 'v\<Colon>heap) hashtable
  \<Rightarrow> ('k, 'v) hashtable \<Rightarrow> ('k, 'v) hashtable Heap"
  where
  "ht_copy 0 src dst = return dst" |
  "ht_copy (Suc n) src dst = do {
    l \<leftarrow> Array.nth (the_array src) n;
    ht \<leftarrow> ht_insls l dst;
    ht_copy n src ht
  }"

text "Abstract version"
fun ls_copy :: "nat \<Rightarrow> ('k\<Colon>hashable \<times> 'v) list list
  \<Rightarrow> ('k \<times> 'v) list list \<Rightarrow> ('k \<times> 'v) list list"
  where
  "ls_copy 0 ss ds = ds" |
  "ls_copy (Suc n) ss ds = ls_copy n ss (ls_insls (ss ! n) ds)"

lemma ht_hash_ls_copy:
  assumes "ht_hash l"
  shows "ht_hash (ls_copy n ss l)"
  using assms
  apply (induct n arbitrary: l)
  apply simp
  by (simp add: ht_hash_ls_insls)

lemma ht_distinct_ls_copy:
  assumes "ht_distinct l"
  shows "ht_distinct (ls_copy n ss l)"
  using assms
  apply (induct n arbitrary: l)
  apply simp
  by (simp add: ht_distinct_ls_insls)

lemma length_ls_copy:
  assumes "1 < length l"
  shows "1 < length (ls_copy n ss l)"
  using assms
  apply (induct n arbitrary: l)
  apply simp
proof -
  case goal1
  from goal1(1)[OF length_ls_insls[OF goal1(2)]] show ?case by simp
qed

lemma complete_ht_copy: "n \<le> List.length ss \<Longrightarrow>
  <is_hashtable ss src * is_hashtable ds dst>
  ht_copy n src dst
  <\<lambda>r. is_hashtable ss src * is_hashtable (ls_copy n ss ds) r>"
proof (induct n arbitrary: ds dst)
  case goal1
  show ?case by (auto intro!: return_cons_rule)
next
  case goal2
  from goal2 have n: "n < length ss" by simp
  hence "n \<le> length ss" by simp
  note IV = goal2(1)[OF this]
  show ?case
    apply simp
    apply (rule bind_rule)
    apply (rule frame_rule)
    apply (subgoal_tac "<is_hashtable ss src>
      Array.nth (the_array src) n
      <\<lambda>r. is_hashtable ss src * \<up>(r = ss ! n)>")
    apply simp
    apply (simp add: is_hashtable_def)
    apply (auto intro!: nth_rule simp add: n)[]
    apply (clarsimp simp: norm_assertion_simps)
    apply (rule bind_rule)
    apply (rule frame_rule_left)
    apply (rule complete_ht_insls)
    apply (simp add: IV)
    done
qed

text {* Alternative, more automatic proof *}
lemma complete_ht_copy_alt_proof: "n \<le> List.length ss \<Longrightarrow>
  <is_hashtable ss src * is_hashtable ds dst>
  ht_copy n src dst
  <\<lambda>r. is_hashtable ss src * is_hashtable (ls_copy n ss ds) r>"
proof (induct n arbitrary: ds dst)
  case goal1
  show ?case by (sep_auto)
next
  case goal2
  from goal2 have N_LESS: "n < length ss" by simp
  hence N_LE: "n \<le> length ss" by simp
  note IV = goal2(1)[OF this]
  show ?case
    by (sep_auto
      simp: N_LESS N_LE
      heap: complete_ht_insls IV)
qed

definition ht_rehash
  :: "('k\<Colon>{heap,hashable}, 'v\<Colon>heap) hashtable \<Rightarrow> ('k, 'v) hashtable Heap"
  where
  "ht_rehash ht = do {
    n \<leftarrow> Array.len (the_array ht);
    h \<leftarrow> ht_new_sz (2 * n);
    ht_copy n ht h
  }"

text "Operation on Abstraction"
definition ls_rehash
  :: "('k\<Colon>hashable \<times> 'v) list list \<Rightarrow> ('k \<times> 'v) list list"
  where "ls_rehash l
  = ls_copy (List.length l) l (replicate (2 * length l) [])"

lemma ht_hash_ls_rehash:
  shows "ht_hash (ls_rehash l)"
  by (simp add: ht_hash_ls_copy ls_rehash_def)

lemma ht_distinct_ls_rehash:
  shows "ht_distinct (ls_rehash l)"
  by (simp add: ht_distinct_ls_copy ls_rehash_def)

lemma length_ls_rehash:
  assumes "1 < length l"
  shows "1 < length (ls_rehash l)"
  using assms
proof -
  case goal1
  hence "1 < length (replicate (2 * length l) [])" by simp
  from length_ls_copy[OF this, of "length l" l] show ?case
    by (simp add: ls_rehash_def)
qed

lemma ht_imp_len:
  "is_hashtable l ht \<Longrightarrow>\<^sub>A is_hashtable l ht * \<up>(length l > 0)"
  unfolding is_hashtable_def
  by sep_auto

lemma complete_ht_rehash:
  "<is_hashtable l ht> ht_rehash ht
  <\<lambda>r. is_hashtable l ht * is_hashtable (ls_rehash l) r>"
  apply (rule cons_pre_rule[OF ht_imp_len])
  unfolding ht_rehash_def
  apply (sep_auto
    heap: complete_ht_new_sz
  )
  apply (cases l, simp_all) []
  apply (sep_auto heap: complete_ht_copy simp: ls_rehash_def)
  done

definition load_factor :: nat -- "in percent"
  where "load_factor = 75"

definition ht_update
  :: "'k\<Colon>{heap,hashable} \<Rightarrow> 'v\<Colon>heap \<Rightarrow> ('k, 'v) hashtable
  \<Rightarrow> ('k, 'v) hashtable Heap"
  where
  "ht_update k v ht = do {
    m \<leftarrow> Array.len (the_array ht);
    ht \<leftarrow> (if m * load_factor \<le> (the_size ht) * 100 then
        ht_rehash ht
      else return ht);
    ht_upd k v ht
  }"

lemma complete_ht_update_normal:
  "\<not> length l * load_factor \<le> (the_size ht)* 100 \<Longrightarrow>
  <is_hashtable l ht>
  ht_update k v ht
  <is_hashtable (abs_update k v l)>"
  unfolding ht_update_def
  apply (sep_auto simp: is_hashtable_def)
  apply (rule cons_pre_rule[where P' = "is_hashtable l ht"])
  apply (simp add: is_hashtable_def)
  apply (simp add: complete_ht_upd)
  done

lemma complete_ht_update_rehash:
  "length l * load_factor \<le> (the_size ht)* 100 \<Longrightarrow>
  <is_hashtable l ht>
  ht_update k v ht
  <\<lambda>r. is_hashtable l ht
    * is_hashtable (abs_update k v (ls_rehash l)) r>"
  unfolding ht_update_def
  by (sep_auto heap: complete_ht_rehash complete_ht_upd)

subsection {* Conversion to List *}
definition ht_to_list ::
  "('k\<Colon>heap, 'v\<Colon>heap) hashtable \<Rightarrow> ('k \<times> 'v) list Heap" where
  "ht_to_list ht = do {
    l \<leftarrow> (Array.freeze (the_array ht));
    return (concat l)
  }"

lemma complete_ht_to_list: "<is_hashtable l ht> ht_to_list ht
  <\<lambda>r. is_hashtable l ht * \<up>(r = concat l)>"
  unfolding ht_to_list_def is_hashtable_def
  by sep_auto

end


section\<open>Names and generic extensions\<close>

theory Names
  imports
    Forcing_Data
    Interface
    Recursion_Thms
    Synthetic_Definition
begin

definition
  SepReplace :: "[i, i\<Rightarrow>i, i\<Rightarrow> o] \<Rightarrow> i" where
  "SepReplace(A,b,Q) \<equiv> {y . x\<in>A, y=b(x) \<and> Q(x)}"

syntax
  "_SepReplace"  :: "[i, pttrn, i, o] \<Rightarrow> i"  ("(1{_ ../ _ \<in> _, _})")
translations
  "{b .. x\<in>A, Q}" => "CONST SepReplace(A, \<lambda>x. b, \<lambda>x. Q)"

lemma Sep_and_Replace: "{b(x) .. x\<in>A, P(x) } = {b(x) . x\<in>{y\<in>A. P(y)}}"
  by (auto simp add:SepReplace_def)

lemma SepReplace_subset : "A\<subseteq>A'\<Longrightarrow> {b .. x\<in>A, Q}\<subseteq>{b .. x\<in>A', Q}"
  by (auto simp add:SepReplace_def)

lemma SepReplace_iff [simp]: "y\<in>{b(x) .. x\<in>A, P(x)} \<longleftrightarrow> (\<exists>x\<in>A. y=b(x) & P(x))"
  by (auto simp add:SepReplace_def)

lemma SepReplace_dom_implies :
  "(\<And> x . x \<in>A \<Longrightarrow> b(x) = b'(x))\<Longrightarrow> {b(x) .. x\<in>A, Q(x)}={b'(x) .. x\<in>A, Q(x)}"
  by  (simp add:SepReplace_def)

lemma SepReplace_pred_implies :
  "\<forall>x. Q(x)\<longrightarrow> b(x) = b'(x)\<Longrightarrow> {b(x) .. x\<in>A, Q(x)}={b'(x) .. x\<in>A, Q(x)}"
  by  (force simp add:SepReplace_def)

subsection\<open>The well-founded relation \<^term>\<open>ed\<close>\<close>

lemma eclose_sing : "x \<in> eclose(a) \<Longrightarrow> x \<in> eclose({a})"
  by(rule subsetD[OF mem_eclose_subset],simp+)

lemma ecloseE :
  assumes  "x \<in> eclose(A)"
  shows  "x \<in> A \<or> (\<exists> B \<in> A . x \<in> eclose(B))"
  using assms
proof (induct rule:eclose_induct_down)
  case (1 y)
  then
  show ?case
    using arg_into_eclose by auto
next
  case (2 y z)
  from \<open>y \<in> A \<or> (\<exists>B\<in>A. y \<in> eclose(B))\<close>
  consider (inA) "y \<in> A" | (exB) "(\<exists>B\<in>A. y \<in> eclose(B))"
    by auto
  then show ?case
  proof (cases)
    case inA
    then
    show ?thesis using 2 arg_into_eclose by auto
  next
    case exB
    then obtain B where "y \<in> eclose(B)" "B\<in>A"
      by auto
    then
    show ?thesis using 2 ecloseD[of y B z] by auto
  qed
qed

lemma eclose_singE : "x \<in> eclose({a}) \<Longrightarrow> x = a \<or> x \<in> eclose(a)"
  by(blast dest: ecloseE)

lemma in_eclose_sing :
  assumes "x \<in> eclose({a})" "a \<in> eclose(z)"
  shows "x \<in> eclose({z})"
proof -
  from \<open>x\<in>eclose({a})\<close>
  consider (eq) "x=a" | (lt) "x\<in>eclose(a)"
    using eclose_singE by auto
  then
  show ?thesis
    using eclose_sing mem_eclose_trans assms
    by (cases, auto)
qed

lemma in_dom_in_eclose :
  assumes "x \<in> domain(z)"
  shows "x \<in> eclose(z)"
proof -
  from assms
  obtain y where "\<langle>x,y\<rangle> \<in> z"
    unfolding domain_def by auto
  then
  show ?thesis
    unfolding Pair_def
    using ecloseD[of "{x,x}"] ecloseD[of "{{x,x},{x,y}}"] arg_into_eclose
    by auto
qed

text\<open>term\<open>ed\<close> is the well-founded relation on which \<^term>\<open>val\<close> is defined.\<close>
definition
  ed :: "[i,i] \<Rightarrow> o" where
  "ed(x,y) \<equiv> x \<in> domain(y)"

definition
  edrel :: "i \<Rightarrow> i" where
  "edrel(A) \<equiv> Rrel(ed,A)"

lemma edI[intro!]: "t\<in>domain(x) \<Longrightarrow> ed(t,x)"
  unfolding ed_def .

lemma edD[dest!]: "ed(t,x) \<Longrightarrow> t\<in>domain(x)"
  unfolding ed_def .

lemma rank_ed:
  assumes "ed(y,x)"
  shows "succ(rank(y)) \<le> rank(x)"
proof
  from assms
  obtain p where "\<langle>y,p\<rangle>\<in>x" by auto
  moreover
  obtain s where "y\<in>s" "s\<in>\<langle>y,p\<rangle>" unfolding Pair_def by auto
  ultimately
  have "rank(y) < rank(s)" "rank(s) < rank(\<langle>y,p\<rangle>)" "rank(\<langle>y,p\<rangle>) < rank(x)"
    using rank_lt by blast+
  then
  show "rank(y) < rank(x)"
    using lt_trans by blast
qed

lemma edrel_dest [dest]: "x \<in> edrel(A) \<Longrightarrow> \<exists> a\<in> A. \<exists> b \<in> A. x =\<langle>a,b\<rangle>"
  by(auto simp add:ed_def edrel_def Rrel_def)

lemma edrelD : "x \<in> edrel(A) \<Longrightarrow> \<exists> a\<in> A. \<exists> b \<in> A. x =\<langle>a,b\<rangle> \<and> a \<in> domain(b)"
  by(auto simp add:ed_def edrel_def Rrel_def)

lemma edrelI [intro!]: "x\<in>A \<Longrightarrow> y\<in>A \<Longrightarrow> x \<in> domain(y) \<Longrightarrow> \<langle>x,y\<rangle>\<in>edrel(A)"
  by (simp add:ed_def edrel_def Rrel_def)

lemma edrel_trans: "Transset(A) \<Longrightarrow> y\<in>A \<Longrightarrow> x \<in> domain(y) \<Longrightarrow> \<langle>x,y\<rangle>\<in>edrel(A)"
  by (rule edrelI, auto simp add:Transset_def domain_def Pair_def)

lemma domain_trans: "Transset(A) \<Longrightarrow> y\<in>A \<Longrightarrow> x \<in> domain(y) \<Longrightarrow> x\<in>A"
  by (auto simp add: Transset_def domain_def Pair_def)

lemma relation_edrel : "relation(edrel(A))"
  by(auto simp add: relation_def)

lemma field_edrel : "field(edrel(A))\<subseteq>A"
  by blast

lemma edrel_sub_memrel: "edrel(A) \<subseteq> trancl(Memrel(eclose(A)))"
proof
  fix z
  assume
    "z\<in>edrel(A)"
  then obtain x y where
    Eq1:   "x\<in>A" "y\<in>A" "z=\<langle>x,y\<rangle>" "x\<in>domain(y)"
    using edrelD
    by blast
  then obtain u v where
    Eq2:   "x\<in>u" "u\<in>v" "v\<in>y"
    unfolding domain_def Pair_def by auto
  with Eq1 have
    Eq3:   "x\<in>eclose(A)" "y\<in>eclose(A)" "u\<in>eclose(A)" "v\<in>eclose(A)"
    by (auto, rule_tac [3-4] ecloseD, rule_tac [3] ecloseD, simp_all add:arg_into_eclose)
  let
    ?r="trancl(Memrel(eclose(A)))"
  from Eq2 and Eq3 have
    "\<langle>x,u\<rangle>\<in>?r" "\<langle>u,v\<rangle>\<in>?r" "\<langle>v,y\<rangle>\<in>?r"
    by (auto simp add: r_into_trancl)
  then  have
    "\<langle>x,y\<rangle>\<in>?r"
    by (rule_tac trancl_trans, rule_tac [2] trancl_trans, simp)
  with Eq1 show "z\<in>?r" by simp
qed

lemma wf_edrel : "wf(edrel(A))"
  using wf_subset [of "trancl(Memrel(eclose(A)))"] edrel_sub_memrel
    wf_trancl wf_Memrel
  by auto

lemma ed_induction:
  assumes "\<And>x. \<lbrakk>\<And>y.  ed(y,x) \<Longrightarrow> Q(y) \<rbrakk> \<Longrightarrow> Q(x)"
  shows "Q(a)"
proof(induct rule: wf_induct2[OF wf_edrel[of "eclose({a})"] ,of a "eclose({a})"])
  case 1
  then show ?case using arg_into_eclose by simp
next
  case 2
  then show ?case using field_edrel .
next
  case (3 x)
  then
  show ?case
    using assms[of x] edrelI domain_trans[OF Transset_eclose 3(1)] by blast
qed

lemma dom_under_edrel_eclose: "edrel(eclose({x})) -`` {x} = domain(x)"
proof
  show "edrel(eclose({x})) -`` {x} \<subseteq> domain(x)"
    unfolding edrel_def Rrel_def ed_def
    by auto
next
  show "domain(x) \<subseteq> edrel(eclose({x})) -`` {x}"
    unfolding edrel_def Rrel_def
    using in_dom_in_eclose eclose_sing arg_into_eclose
    by blast
qed

lemma ed_eclose : "\<langle>y,z\<rangle> \<in> edrel(A) \<Longrightarrow> y \<in> eclose(z)"
  by(drule edrelD,auto simp add:domain_def in_dom_in_eclose)

lemma tr_edrel_eclose : "\<langle>y,z\<rangle> \<in> edrel(eclose({x}))^+ \<Longrightarrow> y \<in> eclose(z)"
  by(rule trancl_induct,(simp add: ed_eclose mem_eclose_trans)+)

lemma restrict_edrel_eq :
  assumes "z \<in> domain(x)"
  shows "edrel(eclose({x})) \<inter> eclose({z})\<times>eclose({z}) = edrel(eclose({z}))"
proof(intro equalityI subsetI)
  let ?ec="\<lambda> y . edrel(eclose({y}))"
  let ?ez="eclose({z})"
  let ?rr="?ec(x) \<inter> ?ez \<times> ?ez"
  fix y
  assume yr:"y \<in> ?rr"
  with yr obtain a b where 1:"\<langle>a,b\<rangle> \<in> ?rr" "a \<in> ?ez" "b \<in> ?ez" "\<langle>a,b\<rangle> \<in> ?ec(x)" "y=\<langle>a,b\<rangle>"
    by blast
  moreover
  from this
  have "a \<in> domain(b)" using edrelD by blast
  ultimately
  show "y \<in> edrel(eclose({z}))" by blast
next
  let ?ec="\<lambda> y . edrel(eclose({y}))"
  let ?ez="eclose({z})"
  let ?rr="?ec(x) \<inter> ?ez \<times> ?ez"
  fix y
  assume yr:"y \<in> edrel(?ez)"
  then obtain a b where "a \<in> ?ez" "b \<in> ?ez" "y=\<langle>a,b\<rangle>" "a \<in> domain(b)"
    using edrelD by blast
  moreover
  from this assms
  have "z \<in> eclose(x)" using in_dom_in_eclose by simp
  moreover
  from assms calculation
  have "a \<in> eclose({x})" "b \<in> eclose({x})" using in_eclose_sing by simp_all
  moreover
  from this \<open>a\<in>domain(b)\<close>
  have "\<langle>a,b\<rangle> \<in> edrel(eclose({x}))" by blast
  ultimately
  show "y \<in> ?rr" by simp
qed

lemma tr_edrel_subset :
  assumes "z \<in> domain(x)"
  shows   "tr_down(edrel(eclose({x})),z) \<subseteq> eclose({z})"
proof(intro subsetI)
  let ?r="\<lambda> x . edrel(eclose({x}))"
  fix y
  assume  "y \<in> tr_down(?r(x),z)"
  then
  have "\<langle>y,z\<rangle> \<in> ?r(x)^+" using tr_downD by simp
  with assms
  show "y \<in> eclose({z})" using tr_edrel_eclose eclose_sing by simp
qed

context M_ctm
begin

lemma upairM : "x \<in> M \<Longrightarrow> y \<in> M \<Longrightarrow> {x,y} \<in> M"
  by (simp flip: setclass_iff)

lemma singletonM : "a \<in> M \<Longrightarrow> {a} \<in> M"
  by (simp flip: setclass_iff)

lemma Rep_simp : "Replace(u,\<lambda> y z . z = f(y)) = { f(y) . y \<in> u}"
  by(auto)

end (* M_ctm *)

subsection\<open>Values and check-names\<close>
context forcing_data
begin

definition
  Hcheck :: "[i,i] \<Rightarrow> i" where
  "Hcheck(z,f)  \<equiv> { \<langle>f`y,one\<rangle> . y \<in> z}"

definition
  check :: "i \<Rightarrow> i" where
  "check(x) \<equiv> transrec(x , Hcheck)"

lemma checkD:
  "check(x) =  wfrec(Memrel(eclose({x})), x, Hcheck)"
  unfolding check_def transrec_def ..

definition
  rcheck :: "i \<Rightarrow> i" where
  "rcheck(x) \<equiv> Memrel(eclose({x}))^+"

lemma Hcheck_trancl:"Hcheck(y, restrict(f,Memrel(eclose({x}))-``{y}))
                   = Hcheck(y, restrict(f,(Memrel(eclose({x}))^+)-``{y}))"
  unfolding Hcheck_def
  using restrict_trans_eq by simp

lemma check_trancl: "check(x) = wfrec(rcheck(x), x, Hcheck)"
  using checkD wf_eq_trancl Hcheck_trancl unfolding rcheck_def by simp

(* relation of check is in M *)
lemma rcheck_in_M :
  "x \<in> M \<Longrightarrow> rcheck(x) \<in> M"
  unfolding rcheck_def by (simp flip: setclass_iff)

lemma  aux_def_check: "x \<in> y \<Longrightarrow>
  wfrec(Memrel(eclose({y})), x, Hcheck) =
  wfrec(Memrel(eclose({x})), x, Hcheck)"
  by (rule wfrec_eclose_eq,auto simp add: arg_into_eclose eclose_sing)

lemma def_check : "check(y) = { \<langle>check(w),one\<rangle> . w \<in> y}"
proof -
  let
    ?r="\<lambda>y. Memrel(eclose({y}))"
  have wfr:   "\<forall>w . wf(?r(w))"
    using wf_Memrel ..
  then
  have "check(y)= Hcheck( y, \<lambda>x\<in>?r(y) -`` {y}. wfrec(?r(y), x, Hcheck))"
    using wfrec[of "?r(y)" y "Hcheck"] checkD by simp
  also
  have " ... = Hcheck( y, \<lambda>x\<in>y. wfrec(?r(y), x, Hcheck))"
    using under_Memrel_eclose arg_into_eclose by simp
  also
  have " ... = Hcheck( y, \<lambda>x\<in>y. check(x))"
    using aux_def_check checkD by simp
  finally show ?thesis using Hcheck_def by simp
qed

lemma def_checkS :
  fixes n
  assumes "n \<in> nat"
  shows "check(succ(n)) = check(n) \<union> {\<langle>check(n),one\<rangle>}"
proof -
  have "check(succ(n)) = {\<langle>check(i),one\<rangle> . i \<in> succ(n)} "
    using def_check by blast
  also have "... = {\<langle>check(i),one\<rangle> . i \<in> n} \<union> {\<langle>check(n),one\<rangle>}"
    by blast
  also have "... = check(n) \<union> {\<langle>check(n),one\<rangle>}"
    using def_check[of n,symmetric] by simp
  finally show ?thesis .
qed

lemma field_Memrel2 :
  assumes "x \<in> M"
  shows "field(Memrel(eclose({x}))) \<subseteq> M"
proof -
  have "field(Memrel(eclose({x}))) \<subseteq> eclose({x})" "eclose({x}) \<subseteq> M"
    using Ordinal.Memrel_type field_rel_subset assms eclose_least[OF trans_M] by auto
  then
  show ?thesis using subset_trans by simp
qed

definition
  Hv :: "i\<Rightarrow>i\<Rightarrow>i\<Rightarrow>i" where
  "Hv(G,x,f) \<equiv> { f`y .. y\<in> domain(x), \<exists>p\<in>P. \<langle>y,p\<rangle> \<in> x \<and> p \<in> G }"

text\<open>The funcion \<^term>\<open>val\<close> interprets a name in \<^term>\<open>M\<close>
according to a (generic) filter \<^term>\<open>G\<close>. Note the definition
in terms of the well-founded recursor.\<close>

definition
  val :: "i\<Rightarrow>i\<Rightarrow>i" where
  "val(G,\<tau>) \<equiv> wfrec(edrel(eclose({\<tau>})), \<tau> ,Hv(G))"

lemma aux_def_val:
  assumes "z \<in> domain(x)"
  shows "wfrec(edrel(eclose({x})),z,Hv(G)) = wfrec(edrel(eclose({z})),z,Hv(G))"
proof -
  let ?r="\<lambda>x . edrel(eclose({x}))"
  have "z\<in>eclose({z})" using arg_in_eclose_sing .
  moreover
  have "relation(?r(x))" using relation_edrel .
  moreover
  have "wf(?r(x))" using wf_edrel .
  moreover from assms
  have "tr_down(?r(x),z) \<subseteq> eclose({z})" using tr_edrel_subset by simp
  ultimately
  have "wfrec(?r(x),z,Hv(G)) = wfrec[eclose({z})](?r(x),z,Hv(G))"
    using wfrec_restr by simp
  also from \<open>z\<in>domain(x)\<close>
  have "... = wfrec(?r(z),z,Hv(G))"
    using restrict_edrel_eq wfrec_restr_eq by simp
  finally show ?thesis .
qed

text\<open>The next lemma provides the usual recursive expresion for the definition of term\<open>val\<close>.\<close>

lemma def_val:  "val(G,x) = {val(G,t) .. t\<in>domain(x) , \<exists>p\<in>P .  \<langle>t,p\<rangle>\<in>x \<and> p \<in> G }"
proof -
  let
    ?r="\<lambda>\<tau> . edrel(eclose({\<tau>}))"
  let
    ?f="\<lambda>z\<in>?r(x)-``{x}. wfrec(?r(x),z,Hv(G))"
  have "\<forall>\<tau>. wf(?r(\<tau>))" using wf_edrel by simp
  with wfrec [of _ x]
  have "val(G,x) = Hv(G,x,?f)" using val_def by simp
  also
  have " ... = Hv(G,x,\<lambda>z\<in>domain(x). wfrec(?r(x),z,Hv(G)))"
    using dom_under_edrel_eclose by simp
  also
  have " ... = Hv(G,x,\<lambda>z\<in>domain(x). val(G,z))"
    using aux_def_val val_def by simp
  finally
  show ?thesis using Hv_def SepReplace_def by simp
qed

lemma val_mono : "x\<subseteq>y \<Longrightarrow> val(G,x) \<subseteq> val(G,y)"
  by (subst (1 2) def_val, force)

text\<open>Check-names are the canonical names for elements of the
ground model. Here we show that this is the case.\<close>

lemma valcheck : "one \<in> G \<Longrightarrow>  one \<in> P \<Longrightarrow> val(G,check(y))  = y"
proof (induct rule:eps_induct)
  case (1 y)
  then show ?case
  proof -
    have "check(y) = { \<langle>check(w), one\<rangle> . w \<in> y}"  (is "_ = ?C")
      using def_check .
    then
    have "val(G,check(y)) = val(G, {\<langle>check(w), one\<rangle> . w \<in> y})"
      by simp
    also
    have " ...  = {val(G,t) .. t\<in>domain(?C) , \<exists>p\<in>P .  \<langle>t, p\<rangle>\<in>?C \<and> p \<in> G }"
      using def_val by blast
    also
    have " ... =  {val(G,t) .. t\<in>domain(?C) , \<exists>w\<in>y. t=check(w) }"
      using 1 by simp
    also
    have " ... = {val(G,check(w)) . w\<in>y }"
      by force
    finally
    show "val(G,check(y)) = y"
      using 1 by simp
  qed
qed

lemma val_of_name :
  "val(G,{x\<in>A\<times>P. Q(x)}) = {val(G,t) .. t\<in>A , \<exists>p\<in>P .  Q(\<langle>t,p\<rangle>) \<and> p \<in> G }"
proof -
  let
    ?n="{x\<in>A\<times>P. Q(x)}" and
    ?r="\<lambda>\<tau> . edrel(eclose({\<tau>}))"
  let
    ?f="\<lambda>z\<in>?r(?n)-``{?n}. val(G,z)"
  have
    wfR : "wf(?r(\<tau>))" for \<tau>
    by (simp add: wf_edrel)
  have "domain(?n) \<subseteq> A" by auto
  { fix t
    assume H:"t \<in> domain({x \<in> A \<times> P . Q(x)})"
    then have "?f ` t = (if t \<in> ?r(?n)-``{?n} then val(G,t) else 0)"
      by simp
    moreover have "... = val(G,t)"
      using dom_under_edrel_eclose H if_P by auto
  }
  then
  have Eq1: "t \<in> domain({x \<in> A \<times> P . Q(x)}) \<Longrightarrow> val(G,t) = ?f` t"  for t
    by simp
  have "val(G,?n) = {val(G,t) .. t\<in>domain(?n), \<exists>p \<in> P . \<langle>t,p\<rangle> \<in> ?n \<and> p \<in> G}"
    by (subst def_val,simp)
  also
  have "... = {?f`t .. t\<in>domain(?n), \<exists>p\<in>P . \<langle>t,p\<rangle>\<in>?n \<and> p\<in>G}"
    unfolding Hv_def
    by (subst SepReplace_dom_implies,auto simp add:Eq1)
  also
  have  "... = { (if t\<in>?r(?n)-``{?n} then val(G,t) else 0) .. t\<in>domain(?n), \<exists>p\<in>P . \<langle>t,p\<rangle>\<in>?n \<and> p\<in>G}"
    by (simp)
  also
  have Eq2:  "... = { val(G,t) .. t\<in>domain(?n), \<exists>p\<in>P . \<langle>t,p\<rangle>\<in>?n \<and> p\<in>G}"
  proof -
    have "domain(?n) \<subseteq> ?r(?n)-``{?n}"
      using dom_under_edrel_eclose by simp
    then
    have "\<forall>t\<in>domain(?n). (if t\<in>?r(?n)-``{?n} then val(G,t) else 0) = val(G,t)"
      by auto
    then
    show "{ (if t\<in>?r(?n)-``{?n} then val(G,t) else 0) .. t\<in>domain(?n), \<exists>p\<in>P . \<langle>t,p\<rangle>\<in>?n \<and> p\<in>G} =
          { val(G,t) .. t\<in>domain(?n), \<exists>p\<in>P . \<langle>t,p\<rangle>\<in>?n \<and> p\<in>G}"
      by auto
  qed
  also
  have " ... = { val(G,t) .. t\<in>A, \<exists>p\<in>P . \<langle>t,p\<rangle>\<in>?n \<and> p\<in>G}"
    by force
  finally
  show " val(G,?n)  = { val(G,t) .. t\<in>A, \<exists>p\<in>P . Q(\<langle>t,p\<rangle>) \<and> p\<in>G}"
    by auto
qed

lemma val_of_name_alt :
  "val(G,{x\<in>A\<times>P. Q(x)}) = {val(G,t) .. t\<in>A , \<exists>p\<in>P\<inter>G .  Q(\<langle>t,p\<rangle>) }"
  using val_of_name by force

lemma val_only_names: "val(F,\<tau>) = val(F,{x\<in>\<tau>. \<exists>t\<in>domain(\<tau>). \<exists>p\<in>P. x=\<langle>t,p\<rangle>})"
  (is "_ = val(F,?name)")
proof -
  have "val(F,?name) = {val(F, t).. t\<in>domain(?name), \<exists>p\<in>P. \<langle>t, p\<rangle> \<in> ?name \<and> p \<in> F}"
    using def_val by blast
  also
  have " ... = {val(F, t). t\<in>{y\<in>domain(?name). \<exists>p\<in>P. \<langle>y, p\<rangle> \<in> ?name \<and> p \<in> F}}"
    using Sep_and_Replace by simp
  also
  have " ... = {val(F, t). t\<in>{y\<in>domain(\<tau>). \<exists>p\<in>P. \<langle>y, p\<rangle> \<in> \<tau> \<and> p \<in> F}}"
    by blast
  also
  have " ... = {val(F, t).. t\<in>domain(\<tau>), \<exists>p\<in>P. \<langle>t, p\<rangle> \<in> \<tau> \<and> p \<in> F}"
    using Sep_and_Replace by simp
  also
  have " ... = val(F, \<tau>)"
    using def_val[symmetric] by blast
  finally
  show ?thesis ..
qed

lemma val_only_pairs: "val(F,\<tau>) = val(F,{x\<in>\<tau>. \<exists>t p. x=\<langle>t,p\<rangle>})"
proof
  have "val(F,\<tau>) = val(F,{x\<in>\<tau>. \<exists>t\<in>domain(\<tau>). \<exists>p\<in>P. x=\<langle>t,p\<rangle>})"
    (is "_ = val(F,?name)")
    using val_only_names .
  also
  have "... \<subseteq> val(F,{x\<in>\<tau>. \<exists>t p. x=\<langle>t,p\<rangle>})"
    using val_mono[of ?name "{x\<in>\<tau>. \<exists>t p. x=\<langle>t,p\<rangle>}"] by auto
  finally
  show "val(F,\<tau>) \<subseteq> val(F,{x\<in>\<tau>. \<exists>t p. x=\<langle>t,p\<rangle>})" by simp
next
  show "val(F,{x\<in>\<tau>. \<exists>t p. x=\<langle>t,p\<rangle>}) \<subseteq> val(F,\<tau>)"
    using val_mono[of "{x\<in>\<tau>. \<exists>t p. x=\<langle>t,p\<rangle>}"] by auto
qed

lemma val_subset_domain_times_range: "val(F,\<tau>) \<subseteq> val(F,domain(\<tau>)\<times>range(\<tau>))"
  using val_only_pairs[THEN equalityD1]
    val_mono[of "{x \<in> \<tau> . \<exists>t p. x = \<langle>t, p\<rangle>}" "domain(\<tau>)\<times>range(\<tau>)"] by blast

lemma val_subset_domain_times_P: "val(F,\<tau>) \<subseteq> val(F,domain(\<tau>)\<times>P)"
  using val_only_names[of F \<tau>] val_mono[of "{x\<in>\<tau>. \<exists>t\<in>domain(\<tau>). \<exists>p\<in>P. x=\<langle>t,p\<rangle>}" "domain(\<tau>)\<times>P" F]
  by auto

definition
  GenExt :: "i\<Rightarrow>i"     ("M[_]")
  where "GenExt(G)\<equiv> {val(G,\<tau>). \<tau> \<in> M}"

lemma val_of_elem: "\<langle>\<theta>,p\<rangle> \<in> \<pi> \<Longrightarrow> p\<in>G \<Longrightarrow> p\<in>P \<Longrightarrow> val(G,\<theta>) \<in> val(G,\<pi>)"
proof -
  assume
    "\<langle>\<theta>,p\<rangle> \<in> \<pi>"
  then
  have "\<theta>\<in>domain(\<pi>)" by auto
  assume "p\<in>G" "p\<in>P"
  with \<open>\<theta>\<in>domain(\<pi>)\<close> \<open>\<langle>\<theta>,p\<rangle> \<in> \<pi>\<close>
  have "val(G,\<theta>) \<in> {val(G,t) .. t\<in>domain(\<pi>) , \<exists>p\<in>P .  \<langle>t, p\<rangle>\<in>\<pi> \<and> p \<in> G }"
    by auto
  then
  show ?thesis by (subst def_val)
qed

lemma elem_of_val: "x\<in>val(G,\<pi>) \<Longrightarrow> \<exists>\<theta>\<in>domain(\<pi>). val(G,\<theta>) = x"
  by (subst (asm) def_val,auto)

lemma elem_of_val_pair: "x\<in>val(G,\<pi>) \<Longrightarrow> \<exists>\<theta>. \<exists>p\<in>G.  \<langle>\<theta>,p\<rangle>\<in>\<pi> \<and> val(G,\<theta>) = x"
  by (subst (asm) def_val,auto)

lemma elem_of_val_pair':
  assumes "\<pi>\<in>M" "x\<in>val(G,\<pi>)"
  shows "\<exists>\<theta>\<in>M. \<exists>p\<in>G.  \<langle>\<theta>,p\<rangle>\<in>\<pi> \<and> val(G,\<theta>) = x"
proof -
  from assms
  obtain \<theta> p where "p\<in>G" "\<langle>\<theta>,p\<rangle>\<in>\<pi>" "val(G,\<theta>) = x"
    using elem_of_val_pair by blast
  moreover from this \<open>\<pi>\<in>M\<close>
  have "\<theta>\<in>M"
    using pair_in_M_iff[THEN iffD1, THEN conjunct1, simplified]
      transitivity by blast
  ultimately
  show ?thesis by blast
qed

lemma GenExtD:
  "x \<in> M[G] \<Longrightarrow> \<exists>\<tau>\<in>M. x = val(G,\<tau>)"
  by (simp add:GenExt_def)

lemma GenExtI:
  "x \<in> M \<Longrightarrow> val(G,x) \<in> M[G]"
  by (auto simp add: GenExt_def)

lemma Transset_MG : "Transset(M[G])"
proof -
  { fix vc y
    assume "vc \<in> M[G]" and "y \<in> vc"
    then obtain c where "c\<in>M" "val(G,c)\<in>M[G]" "y \<in> val(G,c)"
      using GenExtD by auto
    from \<open>y \<in> val(G,c)\<close>
    obtain \<theta> where "\<theta>\<in>domain(c)" "val(G,\<theta>) = y"
      using elem_of_val by blast
    with trans_M \<open>c\<in>M\<close>
    have "y \<in> M[G]"
      using domain_trans GenExtI by blast
  }
  then
  show ?thesis using Transset_def by auto
qed

lemmas transitivity_MG = Transset_intf[OF Transset_MG]

lemma check_n_M :
  fixes n
  assumes "n \<in> nat"
  shows "check(n) \<in> M"
  using \<open>n\<in>nat\<close>
proof (induct n)
  case 0
  then show ?case using zero_in_M by (subst def_check,simp)
next
  case (succ x)
  have "one \<in> M" using one_in_P P_sub_M subsetD by simp
  with \<open>check(x)\<in>M\<close>
  have "\<langle>check(x),one\<rangle> \<in> M"
    using tuples_in_M by simp
  then
  have "{\<langle>check(x),one\<rangle>} \<in> M"
    using singletonM by simp
  with \<open>check(x)\<in>M\<close>
  have "check(x) \<union> {\<langle>check(x),one\<rangle>} \<in> M"
    using Un_closed by simp
  then show ?case using \<open>x\<in>nat\<close> def_checkS by simp
qed

definition
  PHcheck :: "[i,i,i,i] \<Rightarrow> o" where
  "PHcheck(o,f,y,p) \<equiv> p\<in>M \<and> (\<exists>fy[##M]. fun_apply(##M,f,y,fy) \<and> pair(##M,fy,o,p))"

definition
  is_Hcheck :: "[i,i,i,i] \<Rightarrow> o" where
  "is_Hcheck(o,z,f,hc)  \<equiv> is_Replace(##M,z,PHcheck(o,f),hc)"

lemma one_in_M: "one \<in> M"
  by (insert one_in_P P_in_M, simp add: transitivity)

lemma def_PHcheck:
  assumes
    "z\<in>M" "f\<in>M"
  shows
    "Hcheck(z,f) = Replace(z,PHcheck(one,f))"
proof -
  from assms
  have "\<langle>f`x,one\<rangle> \<in> M" "f`x\<in>M" if "x\<in>z" for x
    using tuples_in_M one_in_M transitivity that apply_closed by simp_all
  then
  have "{y . x \<in> z, y = \<langle>f ` x, one\<rangle>} =  {y . x \<in> z, y = \<langle>f ` x, one\<rangle> \<and> y\<in>M \<and> f`x\<in>M}"
    by simp
  then
  show ?thesis
    using \<open>z\<in>M\<close> \<open>f\<in>M\<close> transitivity
    unfolding Hcheck_def PHcheck_def RepFun_def
    by auto
qed

(*
  "PHcheck(o,f,y,p) \<equiv> \<exists>fy[##M]. fun_apply(##M,f,y,fy) \<and> pair(##M,fy,o,p)"
*)
definition
  PHcheck_fm :: "[i,i,i,i] \<Rightarrow> i" where
  "PHcheck_fm(o,f,y,p) \<equiv> Exists(And(fun_apply_fm(succ(f),succ(y),0)
                                 ,pair_fm(0,succ(o),succ(p))))"

lemma PHcheck_type [TC]:
  "\<lbrakk> x \<in> nat; y \<in> nat; z \<in> nat; u \<in> nat \<rbrakk> \<Longrightarrow> PHcheck_fm(x,y,z,u) \<in> formula"
  by (simp add:PHcheck_fm_def)

lemma sats_PHcheck_fm [simp]:
  "\<lbrakk> x \<in> nat; y \<in> nat; z \<in> nat; u \<in> nat ; env \<in> list(M)\<rbrakk>
    \<Longrightarrow> sats(M,PHcheck_fm(x,y,z,u),env) \<longleftrightarrow>
        PHcheck(nth(x,env),nth(y,env),nth(z,env),nth(u,env))"
  using zero_in_M Internalizations.nth_closed by (simp add: PHcheck_def PHcheck_fm_def)

(*
  "is_Hcheck(o,z,f,hc)  \<equiv> is_Replace(##M,z,PHcheck(o,f),hc)"
*)
definition
  is_Hcheck_fm :: "[i,i,i,i] \<Rightarrow> i" where
  "is_Hcheck_fm(o,z,f,hc) \<equiv> Replace_fm(z,PHcheck_fm(succ(succ(o)),succ(succ(f)),0,1),hc)"

lemma is_Hcheck_type [TC]:
  "\<lbrakk> x \<in> nat; y \<in> nat; z \<in> nat; u \<in> nat \<rbrakk> \<Longrightarrow> is_Hcheck_fm(x,y,z,u) \<in> formula"
  by (simp add:is_Hcheck_fm_def)

lemma sats_is_Hcheck_fm [simp]:
  "\<lbrakk> x \<in> nat; y \<in> nat; z \<in> nat; u \<in> nat ; env \<in> list(M)\<rbrakk>
    \<Longrightarrow> sats(M,is_Hcheck_fm(x,y,z,u),env) \<longleftrightarrow>
        is_Hcheck(nth(x,env),nth(y,env),nth(z,env),nth(u,env))"
  using sats_Replace_fm unfolding is_Hcheck_def is_Hcheck_fm_def
  by simp

(* instance of replacement for hcheck *)
lemma wfrec_Hcheck :
  assumes
    "X\<in>M"
  shows
    "wfrec_replacement(##M,is_Hcheck(one),rcheck(X))"
proof -
  have "is_Hcheck(one,a,b,c) \<longleftrightarrow>
        sats(M,is_Hcheck_fm(8,2,1,0),[c,b,a,d,e,y,x,z,one,rcheck(x)])"
    if "a\<in>M" "b\<in>M" "c\<in>M" "d\<in>M" "e\<in>M" "y\<in>M" "x\<in>M" "z\<in>M"
    for a b c d e y x z
    using that one_in_M \<open>X\<in>M\<close> rcheck_in_M by simp
  then have 1:"sats(M,is_wfrec_fm(is_Hcheck_fm(8,2,1,0),4,1,0),
                    [y,x,z,one,rcheck(X)]) \<longleftrightarrow>
            is_wfrec(##M, is_Hcheck(one),rcheck(X), x, y)"
    if "x\<in>M" "y\<in>M" "z\<in>M" for x y z
    using  that sats_is_wfrec_fm \<open>X\<in>M\<close> rcheck_in_M one_in_M by simp
  let
    ?f="Exists(And(pair_fm(1,0,2),
               is_wfrec_fm(is_Hcheck_fm(8,2,1,0),4,1,0)))"
  have satsf:"sats(M, ?f, [x,z,one,rcheck(X)]) \<longleftrightarrow>
              (\<exists>y\<in>M. pair(##M,x,y,z) & is_wfrec(##M, is_Hcheck(one),rcheck(X), x, y))"
    if "x\<in>M" "z\<in>M" for x z
    using that 1 \<open>X\<in>M\<close> rcheck_in_M one_in_M by (simp del:pair_abs)
  have artyf:"arity(?f) = 4"
    unfolding is_wfrec_fm_def is_Hcheck_fm_def Replace_fm_def PHcheck_fm_def
      pair_fm_def upair_fm_def is_recfun_fm_def fun_apply_fm_def big_union_fm_def
      pre_image_fm_def restriction_fm_def image_fm_def
    by (simp add:nat_simp_union)
  then
  have "strong_replacement(##M,\<lambda>x z. sats(M,?f,[x,z,one,rcheck(X)]))"
    using replacement_ax 1 artyf \<open>X\<in>M\<close> rcheck_in_M one_in_M by simp
  then
  have "strong_replacement(##M,\<lambda>x z.
          \<exists>y\<in>M. pair(##M,x,y,z) & is_wfrec(##M, is_Hcheck(one),rcheck(X), x, y))"
    using repl_sats[of M ?f "[one,rcheck(X)]"] satsf by (simp del:pair_abs)
  then
  show ?thesis unfolding wfrec_replacement_def by simp
qed

lemma repl_PHcheck :
  assumes
    "f\<in>M"
  shows
    "strong_replacement(##M,PHcheck(one,f))"
proof -
  have "arity(PHcheck_fm(2,3,0,1)) = 4"
    unfolding PHcheck_fm_def fun_apply_fm_def big_union_fm_def pair_fm_def image_fm_def
      upair_fm_def
    by (simp add:nat_simp_union)
  with \<open>f\<in>M\<close>
  have "strong_replacement(##M,\<lambda>x y. sats(M,PHcheck_fm(2,3,0,1),[x,y,one,f]))"
    using replacement_ax one_in_M by simp
  with \<open>f\<in>M\<close>
  show ?thesis using one_in_M unfolding strong_replacement_def univalent_def by simp
qed

lemma univ_PHcheck : "\<lbrakk> z\<in>M ; f\<in>M \<rbrakk> \<Longrightarrow> univalent(##M,z,PHcheck(one,f))"
  unfolding univalent_def PHcheck_def by simp

lemma relation2_Hcheck :
  "relation2(##M,is_Hcheck(one),Hcheck)"
proof -
  have 1:"\<lbrakk>x\<in>z; PHcheck(one,f,x,y) \<rbrakk> \<Longrightarrow> (##M)(y)"
    if "z\<in>M" "f\<in>M" for z f x y
    using that unfolding PHcheck_def by simp
  have "is_Replace(##M,z,PHcheck(one,f),hc) \<longleftrightarrow> hc = Replace(z,PHcheck(one,f))"
    if "z\<in>M" "f\<in>M" "hc\<in>M" for z f hc
    using that Replace_abs[OF _ _ univ_PHcheck 1] by simp
  with def_PHcheck
  show ?thesis
    unfolding relation2_def is_Hcheck_def Hcheck_def by simp
qed

lemma PHcheck_closed :
  "\<lbrakk>z\<in>M ; f\<in>M ; x\<in>z; PHcheck(one,f,x,y) \<rbrakk> \<Longrightarrow> (##M)(y)"
  unfolding PHcheck_def by simp

lemma Hcheck_closed :
  "\<forall>y\<in>M. \<forall>g\<in>M. function(g) \<longrightarrow> Hcheck(y,g)\<in>M"
proof -
  have "Replace(y,PHcheck(one,f))\<in>M" if "f\<in>M" "y\<in>M" for f y
    using that repl_PHcheck  PHcheck_closed[of y f] univ_PHcheck
      strong_replacement_closed
    by (simp flip: setclass_iff)
  then show ?thesis using def_PHcheck by auto
qed

lemma wf_rcheck : "x\<in>M \<Longrightarrow> wf(rcheck(x))"
  unfolding rcheck_def using wf_trancl[OF wf_Memrel] .

lemma trans_rcheck : "x\<in>M \<Longrightarrow> trans(rcheck(x))"
  unfolding rcheck_def using trans_trancl .

lemma relation_rcheck : "x\<in>M \<Longrightarrow> relation(rcheck(x))"
  unfolding rcheck_def using relation_trancl .

lemma check_in_M : "x\<in>M \<Longrightarrow> check(x) \<in> M"
  unfolding transrec_def
  using wfrec_Hcheck[of x] check_trancl wf_rcheck trans_rcheck relation_rcheck rcheck_in_M
    Hcheck_closed relation2_Hcheck trans_wfrec_closed[of "rcheck(x)" x "is_Hcheck(one)" Hcheck]
  by (simp flip: setclass_iff)

end (* forcing_data *)

(* check if this should go to Relative! *)
definition
  is_singleton :: "[i\<Rightarrow>o,i,i] \<Rightarrow> o" where
  "is_singleton(A,x,z) \<equiv> \<exists>c[A]. empty(A,c) \<and> is_cons(A,x,c,z)"

lemma (in M_trivial) singleton_abs[simp] : "\<lbrakk> M(x) ; M(s) \<rbrakk> \<Longrightarrow> is_singleton(M,x,s) \<longleftrightarrow> s = {x}"
  unfolding is_singleton_def using nonempty by simp

definition
  singleton_fm :: "[i,i] \<Rightarrow> i" where
  "singleton_fm(i,j) \<equiv> Exists(And(empty_fm(0), cons_fm(succ(i),0,succ(j))))"

lemma singleton_type[TC] : "\<lbrakk> x \<in> nat; y \<in> nat \<rbrakk> \<Longrightarrow> singleton_fm(x,y) \<in> formula"
  unfolding singleton_fm_def by simp

lemma is_singleton_iff_sats:
  "\<lbrakk> nth(i,env) = x; nth(j,env) = y;
          i \<in> nat; j\<in>nat ; env \<in> list(A)\<rbrakk>
       \<Longrightarrow> is_singleton(##A,x,y) \<longleftrightarrow> sats(A, singleton_fm(i,j), env)"
  unfolding is_singleton_def singleton_fm_def by simp

context forcing_data begin

(* Internalization and absoluteness of rcheck *)
definition
  is_rcheck :: "[i,i] \<Rightarrow> o" where
  "is_rcheck(x,z) \<equiv> \<exists>r\<in>M. tran_closure(##M,r,z) \<and> (\<exists>ec\<in>M. membership(##M,ec,r) \<and>
                           (\<exists>s\<in>M. is_singleton(##M,x,s) \<and>  is_eclose(##M,s,ec)))"

lemma rcheck_abs :
  "\<lbrakk> x\<in>M ; r\<in>M \<rbrakk> \<Longrightarrow> is_rcheck(x,r) \<longleftrightarrow> r = rcheck(x)"
  unfolding rcheck_def is_rcheck_def
  using singletonM trancl_closed Memrel_closed eclose_closed by simp

schematic_goal rcheck_fm_auto:
  assumes
    "i \<in> nat" "j \<in> nat" "env \<in> list(M)"
  shows
    "is_rcheck(nth(i,env),nth(j,env)) \<longleftrightarrow> sats(M,?rch(i,j),env)"
  unfolding is_rcheck_def
  by (insert assms ; (rule sep_rules is_singleton_iff_sats is_eclose_iff_sats
        trans_closure_fm_iff_sats | simp)+)

synthesize "rcheck_fm" from_schematic rcheck_fm_auto

definition
  is_check :: "[i,i] \<Rightarrow> o" where
  "is_check(x,z) \<equiv> \<exists>rch\<in>M. is_rcheck(x,rch) \<and> is_wfrec(##M,is_Hcheck(one),rch,x,z)"

lemma check_abs :
  assumes
    "x\<in>M" "z\<in>M"
  shows
    "is_check(x,z) \<longleftrightarrow> z = check(x)"
proof -
  have
    "is_check(x,z) \<longleftrightarrow> is_wfrec(##M,is_Hcheck(one),rcheck(x),x,z)"
    unfolding is_check_def using assms rcheck_abs rcheck_in_M
    unfolding check_trancl is_check_def by simp
  then show ?thesis
    unfolding check_trancl
    using assms wfrec_Hcheck[of x] wf_rcheck trans_rcheck relation_rcheck rcheck_in_M
      Hcheck_closed relation2_Hcheck trans_wfrec_abs[of "rcheck(x)" x z "is_Hcheck(one)" Hcheck]
    by (simp flip: setclass_iff)
qed

(* \<exists>rch\<in>M. is_rcheck(x,rch) \<and> is_wfrec(##M,is_Hcheck(one),rch,x,z) *)
definition
  check_fm :: "[i,i,i] \<Rightarrow> i" where
  "check_fm(x,o,z) \<equiv> Exists(And(rcheck_fm(1#+x,0),
                      is_wfrec_fm(is_Hcheck_fm(6#+o,2,1,0),0,1#+x,1#+z)))"

lemma check_fm_type[TC] :
  "\<lbrakk>x\<in>nat;o\<in>nat;z\<in>nat\<rbrakk> \<Longrightarrow> check_fm(x,o,z)\<in>formula"
  unfolding check_fm_def by simp

lemma sats_check_fm :
  assumes
    "nth(o,env) = one" "x\<in>nat" "z\<in>nat" "o\<in>nat" "env\<in>list(M)" "x < length(env)" "z < length(env)"
  shows
    "sats(M, check_fm(x,o,z), env) \<longleftrightarrow> is_check(nth(x,env),nth(z,env))"
proof -
  have sats_is_Hcheck_fm:
    "\<And>a0 a1 a2 a3 a4. \<lbrakk> a0\<in>M; a1\<in>M; a2\<in>M; a3\<in>M; a4\<in>M \<rbrakk> \<Longrightarrow>
         is_Hcheck(one,a2, a1, a0) \<longleftrightarrow>
         sats(M, is_Hcheck_fm(6#+o,2,1,0), [a0,a1,a2,a3,a4,r]@env)" if "r\<in>M" for r
    using that one_in_M assms  by simp
  then
  have "sats(M, is_wfrec_fm(is_Hcheck_fm(6#+o,2,1,0),0,1#+x,1#+z),Cons(r,env))
        \<longleftrightarrow> is_wfrec(##M,is_Hcheck(one),r,nth(x,env),nth(z,env))" if "r\<in>M" for r
    using that assms one_in_M sats_is_wfrec_fm by simp
  then
  show ?thesis unfolding is_check_def check_fm_def
    using assms rcheck_in_M one_in_M rcheck_fm_iff_sats[symmetric] by simp
qed

lemma check_replacement:
  "{check(x). x\<in>P} \<in> M"
proof -
  have "arity(check_fm(0,2,1)) = 3"
    unfolding check_fm_def rcheck_fm_def trans_closure_fm_def is_eclose_fm_def mem_eclose_fm_def
      is_Hcheck_fm_def Replace_fm_def PHcheck_fm_def finite_ordinal_fm_def is_iterates_fm_def
      is_wfrec_fm_def is_recfun_fm_def restriction_fm_def pre_image_fm_def eclose_n_fm_def
      is_nat_case_fm_def quasinat_fm_def Memrel_fm_def singleton_fm_def fm_defs iterates_MH_fm_def
    by (simp add:nat_simp_union)
  moreover
  have "check(x)\<in>M" if "x\<in>P" for x
    using that Transset_intf[of M x P] trans_M check_in_M P_in_M by simp
  ultimately
  show ?thesis using sats_check_fm check_abs P_in_M check_in_M one_in_M
      Repl_in_M[of "check_fm(0,2,1)" "[one]" is_check check] by simp
qed

lemma pair_check : "\<lbrakk> p\<in>M ; y\<in>M \<rbrakk>  \<Longrightarrow> (\<exists>c\<in>M. is_check(p,c) \<and> pair(##M,c,p,y)) \<longleftrightarrow> y = \<langle>check(p),p\<rangle>"
  using check_abs check_in_M tuples_in_M by simp

lemma M_subset_MG :  "one \<in> G \<Longrightarrow> M \<subseteq> M[G]"
  using check_in_M one_in_P GenExtI
  by (intro subsetI, subst valcheck [of G,symmetric], auto)

text\<open>The name for the generic filter\<close>
definition
  G_dot :: "i" where
  "G_dot \<equiv> {\<langle>check(p),p\<rangle> . p\<in>P}"

lemma G_dot_in_M :
  "G_dot \<in> M"
proof -
  let ?is_pcheck = "\<lambda>x y. \<exists>ch\<in>M. is_check(x,ch) \<and> pair(##M,ch,x,y)"
  let ?pcheck_fm = "Exists(And(check_fm(1,3,0),pair_fm(0,1,2)))"
  have "sats(M,?pcheck_fm,[x,y,one]) \<longleftrightarrow> ?is_pcheck(x,y)" if "x\<in>M" "y\<in>M" for x y
    using sats_check_fm that one_in_M by simp
  moreover
  have "?is_pcheck(x,y) \<longleftrightarrow> y = \<langle>check(x),x\<rangle>" if "x\<in>M" "y\<in>M" for x y
    using that check_abs check_in_M by simp
  moreover
  have "?pcheck_fm\<in>formula" by simp
  moreover
  have "arity(?pcheck_fm)=3"
    unfolding check_fm_def rcheck_fm_def trans_closure_fm_def is_eclose_fm_def mem_eclose_fm_def
      is_Hcheck_fm_def Replace_fm_def PHcheck_fm_def finite_ordinal_fm_def is_iterates_fm_def
      is_wfrec_fm_def is_recfun_fm_def restriction_fm_def pre_image_fm_def eclose_n_fm_def
      is_nat_case_fm_def quasinat_fm_def Memrel_fm_def singleton_fm_def fm_defs iterates_MH_fm_def
    by (simp add:nat_simp_union)
  moreover
  from P_in_M check_in_M tuples_in_M P_sub_M
  have "\<langle>check(p),p\<rangle> \<in> M" if "p\<in>P" for p
    using that by auto
  ultimately
  show ?thesis
    unfolding G_dot_def
    using one_in_M P_in_M Repl_in_M[of ?pcheck_fm "[one]"]
    by simp
qed

lemma val_G_dot :
  assumes "G \<subseteq> P"
    "one \<in> G"
  shows "val(G,G_dot) = G"
proof (intro equalityI subsetI)
  fix x
  assume "x\<in>val(G,G_dot)"
  then obtain \<theta> p where "p\<in>G" "\<langle>\<theta>,p\<rangle> \<in> G_dot" "val(G,\<theta>) = x" "\<theta> = check(p)"
    unfolding G_dot_def using elem_of_val_pair G_dot_in_M
    by force
  with \<open>one\<in>G\<close> \<open>G\<subseteq>P\<close> show
    "x \<in> G"
    using valcheck P_sub_M by auto
next
  fix p
  assume "p\<in>G"
  have "\<langle>check(q),q\<rangle> \<in> G_dot" if "q\<in>P" for q
    unfolding G_dot_def using that by simp
  with \<open>p\<in>G\<close> \<open>G\<subseteq>P\<close>
  have "val(G,check(p)) \<in> val(G,G_dot)"
    using val_of_elem G_dot_in_M by blast
  with \<open>p\<in>G\<close> \<open>G\<subseteq>P\<close> \<open>one\<in>G\<close>
  show "p \<in> val(G,G_dot)"
    using P_sub_M valcheck by auto
qed

lemma G_in_Gen_Ext :
  assumes "G \<subseteq> P" and "one \<in> G"
  shows   "G \<in> M[G]"
  using assms val_G_dot GenExtI[of _ G] G_dot_in_M
  by force

(* Move this to M_trivial *)
lemma fst_snd_closed: "p\<in>M \<Longrightarrow> fst(p) \<in> M \<and> snd(p)\<in> M"
proof (cases "\<exists>a. \<exists>b. p = \<langle>a, b\<rangle>")
  case False
  then
  show "fst(p) \<in> M \<and> snd(p) \<in> M" unfolding fst_def snd_def using zero_in_M by auto
next
  case True
  then
  obtain a b where "p = \<langle>a, b\<rangle>" by blast
  with True
  have "fst(p) = a" "snd(p) = b" unfolding fst_def snd_def by simp_all
  moreover
  assume "p\<in>M"
  moreover from this
  have "a\<in>M"
    unfolding \<open>p = _\<close> Pair_def by (force intro:Transset_M[OF trans_M])
  moreover from  \<open>p\<in>M\<close>
  have "b\<in>M"
    using Transset_M[OF trans_M, of "{a,b}" p] Transset_M[OF trans_M, of "b" "{a,b}"]
    unfolding \<open>p = _\<close> Pair_def by (simp)
  ultimately
  show ?thesis by simp
qed

end (* forcing_data *)

locale G_generic = forcing_data +
  fixes G :: "i"
  assumes generic : "M_generic(G)"
begin

lemma zero_in_MG :
  "0 \<in> M[G]"
proof -
  have "0 = val(G,0)"
    using zero_in_M elem_of_val by auto
  also
  have "... \<in> M[G]"
    using GenExtI zero_in_M by simp
  finally show ?thesis .
qed

lemma G_nonempty: "G\<noteq>0"
proof -
  have "P\<subseteq>P" ..
  with P_in_M P_dense \<open>P\<subseteq>P\<close>
  show "G \<noteq> 0"
    using generic unfolding M_generic_def by auto
qed

end (* context G_generic *)
end


subsection\<open>Simplified Variant with Axiom T2 (Fig.~7 in \<^cite>\<open>"C85"\<close>)\<close>

theory SimpleVariantPG imports
  HOML
  MFilter
  BaseDefs
begin
text\<open>Axiom's of simplified variant with A3 replaced.\<close>
axiomatization where
  A1': "\<lfloor>\<^bold>\<not>(\<P>(\<lambda>x.(x\<^bold>\<noteq>x)))\<rfloor>" and
  A2': "\<lfloor>\<^bold>\<forall>X Y.(((\<P> X) \<^bold>\<and> ((X\<^bold>\<sqsubseteq>Y)\<^bold>\<or>(X\<Rrightarrow>Y))) \<^bold>\<rightarrow> (\<P> Y))\<rfloor>" and
  T2:  "\<lfloor>\<P> \<G>\<rfloor>"

text\<open>Necessary existence of a Godlike entity.\<close>
theorem T6:  "\<lfloor>\<^bold>\<box>(\<^bold>\<exists>\<^sup>E \<G>)\<rfloor>"  \<comment>\<open>Proof found by sledgehammer\<close>
proof -
  have T1: "\<lfloor>\<^bold>\<forall>X.((\<P> X) \<^bold>\<rightarrow> \<^bold>\<diamond>(\<^bold>\<exists>\<^sup>E X))\<rfloor>" by (metis A1' A2')
  have T3: "\<lfloor>\<^bold>\<diamond>(\<^bold>\<exists>\<^sup>E \<G>)\<rfloor>" using T1 T2 by simp
  have T5: "\<lfloor>(\<^bold>\<diamond>(\<^bold>\<exists>\<^sup>E \<G>)) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<exists>\<^sup>E \<G>)\<rfloor>" by (metis A1' A2' T2)
  thus ?thesis using T3 by blast qed

lemma True nitpick[satisfy] oops  \<comment>\<open>Consistency: model found\<close>

text\<open>Modal collapse and Monotheism: not implied.\<close>
lemma MC: "\<lfloor>\<^bold>\<forall>\<Phi>.(\<Phi> \<^bold>\<rightarrow> \<^bold>\<box>\<Phi>)\<rfloor>" nitpick oops  \<comment>\<open>Countermodel\<close>
lemma MT: "\<lfloor>\<^bold>\<forall>x y.(((\<G> x)\<^bold>\<and>(\<G> y))\<^bold>\<rightarrow>(x\<^bold>=y))\<rfloor>" nitpick oops  \<comment>\<open>Countermodel\<close>
end


theory topo_operators_derivative
  imports topo_operators_basic
begin
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format=3] (*default Nitpick settings*)

subsection \<open>Derivative and coherence\<close>

text\<open>\noindent{In this section we investigate two related operators, namely the `derivative' (or `derived set')
and the (Cantorian) `coherence' of a set. The derivative of a set is the set of its accumulation (aka. limit)
points. The coherence of a set A is the set formed by those limit points of A belonging to A.
For the derivative operator we draw upon the works by Kuratowski \<^cite>\<open>Kuratowski1\<close> and
(in more detail) by Zarycki \<^cite>\<open>Zarycki3\<close>; cf.~also McKinsey \& Tarski \<^cite>\<open>AOT\<close>.
For the (Cantorian) coherence operator we follow the treatment given by Zarycki in \<^cite>\<open>Zarycki2\<close>.}\<close>

subsubsection \<open>Derivative conditions\<close>

text\<open>\noindent{The derivative conditions overlap partly with Kuratowski closure conditions \<^cite>\<open>Kuratowski1\<close>.
We try to make both notations coincide when possible.}\<close>

abbreviation "Der_1 \<phi>  \<equiv> Cl_1 \<phi>"
abbreviation "Der_1a \<phi> \<equiv> Cl_1a \<phi>"
abbreviation "Der_1b \<phi> \<equiv> Cl_1b \<phi>"
abbreviation "Der_2 \<phi>  \<equiv> Cl_5 \<phi>" \<comment>\<open> follows from Cl-2 \<close>
abbreviation "Der_3 \<phi>  \<equiv> Cl_3 \<phi>"
abbreviation "Der_4 \<phi>  \<equiv> Cl_4' \<phi>"
definition   "Der_4e \<phi> \<equiv> \<forall>A. \<phi>(\<phi> A) \<^bold>\<preceq> (\<phi> A \<^bold>\<or> A)"
definition   "Der_5 \<phi> \<equiv> \<forall>A. (\<phi> A \<^bold>\<preceq> A) \<and> (A \<^bold>\<preceq> \<phi>\<^sup>d A) \<longrightarrow> (A \<^bold>\<approx> \<^bold>\<bottom> \<or> A \<^bold>\<approx> \<^bold>\<top>)"

text\<open>\noindent{Some remarks:
Condition Der-2 basically says (when assuming other derivative axioms) that the space is dense-in-itself,
i.e. that all points are accumulation points (no point is isolated) w.r.t the whole space.
Der-4 is a weakened (left-to-right) variant of Cl-4.
Condition Der-4e corresponds to a (weaker) condition than Der-4 and is used in more recent literature
(in particular in the works of Leo Esakia \<^cite>\<open>Esakia\<close>).
When other derivative axioms are assumed, Der-5 above as used by Zarycki \<^cite>\<open>Zarycki3\<close> says that
the only clopen sets in the space are the top and bottom elements (empty set and universe, resp.).
We verify some properties:}\<close>

lemma Der4e_rel: "Der_4 \<phi> \<Longrightarrow> Der_4e \<phi>" by (simp add: IDEMb_def Der_4e_def conn)
lemma PD1: "Der_1b \<phi> \<Longrightarrow> \<forall>A B. A \<^bold>\<preceq> B \<longrightarrow> \<phi> A \<^bold>\<preceq> \<phi> B" using MONO_def MONO_ADDIb by auto
lemma PD2: "Der_1b \<phi> \<Longrightarrow> \<forall>A B. A \<^bold>\<preceq> B \<longrightarrow> \<phi>\<^sup>d A \<^bold>\<preceq> \<phi>\<^sup>d B" using CI1b MONO_def MONO_MULTa dual_def by fastforce
lemma PD3: "Der_1b \<phi> \<Longrightarrow> \<forall>A B. \<phi>(A \<^bold>\<and> B) \<^bold>\<preceq> \<phi> A \<^bold>\<and> \<phi> B" unfolding conn by (metis (no_types, lifting) PD1)
lemma PD4: "Der_1 \<phi> \<Longrightarrow> \<forall>A B. (\<phi> A \<^bold>\<leftharpoonup> \<phi> B) \<^bold>\<preceq> \<phi>(A \<^bold>\<leftharpoonup> B)" using Cl_6_def PC6 by metis
lemma PD5: "Der_4 \<phi> \<Longrightarrow> \<forall>A. \<phi>(\<phi>(\<^bold>\<midarrow>(\<phi> A))) \<^bold>\<preceq> \<phi>(\<^bold>\<midarrow>(\<phi> A))" unfolding IDEMb_def by blast
text\<open>\noindent{Observe that the lemmas below require Der-2 as premise:}\<close>
lemma PD6: "Der_1 \<phi> \<Longrightarrow> Der_2 \<phi> \<Longrightarrow> \<forall>A. \<phi>\<^sup>d A \<^bold>\<preceq> \<phi> A" unfolding ADDI_def dNOR_def dual_def conn by fastforce
lemma PD7: "Der_1 \<phi> \<Longrightarrow> Der_2 \<phi> \<Longrightarrow> \<forall>A. \<phi>(\<phi>\<^sup>d A) \<^bold>\<preceq> \<phi>(\<phi> A)" by (metis (mono_tags, lifting) PC1 PD1 PD6)
lemma PD8: "Der_1 \<phi> \<Longrightarrow> Der_2 \<phi> \<Longrightarrow> Der_4 \<phi> \<Longrightarrow> \<forall>A. \<phi>(\<phi>\<^sup>d A) \<^bold>\<preceq> \<phi> A" by (meson IDEMb_def PD7)
lemma PD9: "Der_1 \<phi> \<Longrightarrow> Der_2 \<phi> \<Longrightarrow> Der_4 \<phi> \<Longrightarrow> \<forall>A. \<phi>\<^sup>d A \<^bold>\<preceq> \<phi>\<^sup>d(\<phi> A)" by (metis CI4' IDEMa_def PC1 PD2 PD6)
lemma PD10: "Der_1 \<phi> \<Longrightarrow> Der_2 \<phi> \<Longrightarrow> Der_4 \<phi> \<Longrightarrow> \<forall>A. \<phi>\<^sup>d A \<^bold>\<preceq> \<phi>(\<phi>\<^sup>d A)" using CI4' IDEMa_def PD6 by metis
lemma PD11: "Der_1 \<phi> \<Longrightarrow> Der_2 \<phi> \<Longrightarrow> Der_4 \<phi> \<Longrightarrow> \<forall>A. \<^bold>\<midarrow>(\<phi> A) \<^bold>\<preceq> \<phi>(\<^bold>\<midarrow>(\<phi> A))" using IDEMb_def PD6 dual_def unfolding conn by metis
lemma PD12: "Der_1 \<phi> \<Longrightarrow> Der_2 \<phi> \<Longrightarrow> Der_4 \<phi> \<Longrightarrow> \<forall>A. (\<phi>\<^sup>d A) \<^bold>\<and> (\<phi> A) \<^bold>\<approx> \<phi>\<^sup>d(A \<^bold>\<and> (\<phi> A))" proof -
 assume der1: "Der_1 \<phi>" and der2: "Der_2 \<phi>" and der4: "Der_4 \<phi>"
  { fix A
    from der1 have "let M=\<^bold>\<midarrow>A ; N=\<^bold>\<midarrow>(\<phi> A) in \<phi>(M \<^bold>\<or> N) \<^bold>\<approx> (\<phi> M) \<^bold>\<or> (\<phi> N)" unfolding ADDI_def by simp
    hence aux: "\<^bold>\<midarrow>(\<phi>(\<^bold>\<midarrow>A) \<^bold>\<or> \<phi>(\<^bold>\<midarrow>(\<phi> A))) \<^bold>\<approx> \<^bold>\<midarrow>(\<phi> (\<^bold>\<midarrow>A \<^bold>\<or> \<^bold>\<midarrow>(\<phi> A)))" unfolding dual_def conn by simp
    have "(\<phi>\<^sup>d A \<^bold>\<and> \<phi> A) = (\<phi>\<^sup>d A \<^bold>\<and> \<phi>\<^sup>d(\<phi> A))" using PD6 PD9 der1 der2 der4 unfolding conn by metis
    also have "... = \<^bold>\<midarrow>(\<phi>(\<^bold>\<midarrow>A) \<^bold>\<or> \<phi>(\<^bold>\<midarrow>(\<phi> A)))" unfolding dual_def conn by simp
    also from aux have "... = \<^bold>\<midarrow>(\<phi> (\<^bold>\<midarrow>A \<^bold>\<or> \<^bold>\<midarrow>(\<phi> A)))" unfolding dual_def by blast
    also have "... = \<phi>\<^sup>d(A \<^bold>\<and> (\<phi> A))" unfolding dual_def conn by simp
    finally have "(\<phi>\<^sup>d A) \<^bold>\<and> (\<phi> A) \<^bold>\<approx> \<phi>\<^sup>d(A \<^bold>\<and> (\<phi> A))" by simp
 } thus ?thesis by simp
qed

text\<open>\noindent{The conditions below can serve to axiomatize a derivative operator. Different authors consider different
sets of conditions. We define below some corresponding to Zarycki \<^cite>\<open>Zarycki3\<close>, Kuratowski \<^cite>\<open>Kuratowski1\<close>
\<^cite>\<open>Zarycki2\<close>, McKinsey \& Tarski \<^cite>\<open>AOT\<close>, and Esakia \<^cite>\<open>Esakia\<close>, respectively.}\<close>
abbreviation "\
z \<phi>  \<equiv> Der_1 \<phi> \<and> Der_2 \<phi> \<and> Der_3 \<phi> \<and> Der_4 \<phi> \<and> Der_5 \<phi>"
abbreviation "\
k \<phi>  \<equiv> Der_1 \<phi> \<and> Der_2 \<phi> \<and> Der_3 \<phi> \<and> Der_4 \<phi>"
abbreviation "\
mt \<phi> \<equiv> Der_1 \<phi>           \<and> Der_3 \<phi> \<and> Der_4 \<phi>"
abbreviation "\
e \<phi>  \<equiv> Der_1 \<phi>           \<and> Der_3 \<phi> \<and> Der_4e \<phi>"

text\<open>\noindent{Our `default' derivative operator will coincide with @{text "\
k"} from Kuratowski (also Zarycki).
However, for proving theorems we will employ the weaker variant Der-4e instead of Der-4 whenever possible.
We start by defining a dual operator and verifying some dualities; we then define conversion operators.
Observe that conditions Der-2 and  Der-5 are not used in the rest of this subsection.
Der-2 will be required later when working with the coherence operator.}\<close>
abbreviation "\
 \<phi> \<equiv> \
k \<phi>"
abbreviation "\<Sigma> \<phi> \<equiv> Int_1 \<phi> \<and> Int_3 \<phi> \<and> Int_4' \<phi> \<and> Int_5 \<phi>" \<comment>\<open> 'dual-derivative' operator \<close>

lemma SD_dual1: "\<Sigma>(\<phi>) \<Longrightarrow> \
(\<phi>\<^sup>d)" using IC1 IC4' IC3 IC5 by simp
lemma SD_dual2: "\<Sigma>(\<phi>\<^sup>d) \<Longrightarrow> \
(\<phi>)" using IC1 IC4' IC3 IC5 dual_symm by metis
lemma DS_dual1: "\
(\<phi>) \<Longrightarrow> \<Sigma>(\<phi>\<^sup>d)" using CI1 CI4' CI3 CI5 by simp
lemma DS_dual2: "\
(\<phi>\<^sup>d) \<Longrightarrow> \<Sigma>(\<phi>)" using CI1 CI4' CI3 CI5 dual_symm by metis
lemma DS_dual: "\
(\<phi>) = \<Sigma>(\<phi>\<^sup>d)"  using SD_dual2 DS_dual1 by smt

text\<open>\noindent{Closure operator as derived from derivative.}\<close>
definition Cl_der::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("\<C>\<^sub>D") where  "\<C>\<^sub>D \<D> \<equiv> \<lambda>A. A \<^bold>\<or> \<D>(A)"
text\<open>\noindent{Verify properties:}\<close>
lemma CD1a: "Der_1a \<D> \<Longrightarrow> Cl_1a (\<C>\<^sub>D \<D>)" unfolding Cl_der_def ADDI_a_def conn by auto

text\<open>\noindent{Interior operator as derived from (dual) derivative.}\<close>
definition Int_der::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("\\<^sub>D") where "\\<^sub>D \<D> \<equiv> \<lambda>A. A \<^bold>\<and> \<D>\<^sup>d(A)"
text\<open>\noindent{Verify definition:}\<close>
lemma Int_der_def2: "\\<^sub>D \<D> = (\<lambda>\<phi>. \<phi> \<^bold>\<leftharpoonup> \<D>(\<^bold>\<midarrow>\<phi>))" unfolding Int_der_def dual_def conn by simp
lemma dual_der1: "\<C>\<^sub>D \<D> \<equiv> (\\<^sub>D \<D>)\<^sup>d" unfolding Cl_der_def Int_der_def dual_def conn by simp
lemma dual_der2: "\\<^sub>D \<D> \<equiv> (\<C>\<^sub>D \<D>)\<^sup>d" unfolding Cl_der_def Int_der_def dual_def conn by simp
text\<open>\noindent{Verify properties:}\<close>
lemma ID1: "Der_1 \<D> \<Longrightarrow> Int_1 (\\<^sub>D \<D>)" using Int_der_def MULT_def ADDI_def CI1 unfolding conn by auto
lemma ID1a: "Der_1a \<D> \<Longrightarrow> Int_1b (\\<^sub>D \<D>)" by (simp add: CI1a dual_der2 CD1a)
lemma ID1b: "Der_1b \<D> \<Longrightarrow> Int_1a (\\<^sub>D \<D>)" by (simp add: CI1b dual_der2 CD1b)
lemma ID2: "Int_2 (\\<^sub>D \<D>)" unfolding Int_der_def dEXP_def conn by simp
lemma ID3: "Der_3 \<D> \<Longrightarrow> Int_3 (\\<^sub>D \<D>)" by (simp add: CI3 CD3 dual_der2)
lemma ID4: "Der_1 \<D> \<Longrightarrow> Der_4e \<D> \<Longrightarrow> Int_4 (\\<^sub>D \<D>)" using CI4 CD4 dual_der2 by simp
lemma ID4a: "Der_1a \<D> \<Longrightarrow> Der_4e \<D> \<Longrightarrow> Int_4 (\\<^sub>D \<D>)" by (simp add: CI4 dual_der2 CD4a)
lemma "Der_1b \<D> \<Longrightarrow> Der_4 \<D> \<Longrightarrow> Int_4 (\\<^sub>D \<D>)" nitpick oops (*countermodel*)

text\<open>\noindent{Border operator as derived from (dual) derivative.}\<close>
definition Br_der::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("\\<^sub>D") where "\\<^sub>D \<D> \<equiv> \<lambda>A. A \<^bold>\<leftharpoonup> \<D>\<^sup>d(A)"
text\<open>\noindent{Verify definition:}\<close>
lemma Br_der_def2: "\\<^sub>D \<D> = (\<lambda>A. A \<^bold>\<and> \<D>(\<^bold>\<midarrow>A))" unfolding Br_der_def dual_def conn by simp
text\<open>\noindent{Verify properties:}\<close>
lemma BD1: "Der_1 \<D> \<Longrightarrow> Br_1 (\\<^sub>D \<D>)" using Br_der_def Br_1_def CI1 MULT_def conn by auto
lemma BD2: "Der_3 \<D> \<Longrightarrow> Br_2 (\\<^sub>D \<D>)" using Br_der_def Br_2_def CI3 dNOR_def unfolding conn by auto
lemma BD3: "Der_1b \<D> \<Longrightarrow> Der_4e \<D> \<Longrightarrow> Br_3 (\\<^sub>D \<D>)" using dual_def Der_4e_def MONO_ADDIb MONO_def  unfolding Br_der_def Br_3_def conn by smt

text\<open>\noindent{Frontier operator as derived from derivative.}\<close>
definition Fr_der::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("\<F>\<^sub>D") where "\<F>\<^sub>D \<D> \<equiv> \<lambda>A. (A \<^bold>\<leftharpoonup> \<D>\<^sup>d(A)) \<^bold>\<or> (\<D>(A) \<^bold>\<leftharpoonup> A)"
text\<open>\noindent{Verify definition:}\<close>
lemma Fr_der_def2: "\<F>\<^sub>D \<D> = (\<lambda>A. (A \<^bold>\<or> \<D>(A)) \<^bold>\<and> (\<^bold>\<midarrow>A \<^bold>\<or> \<D>(\<^bold>\<midarrow>A)))" unfolding Fr_der_def dual_def conn by auto
text\<open>\noindent{Verify properties:}\<close>
lemma FD1a: "Der_1a \<D> \<Longrightarrow> Fr_1a(\<F>\<^sub>D \<D>)" unfolding Fr_1a_def Fr_der_def using CI1a MULT_b_def conn by auto
lemma FD1b: "Der_1b \<D> \<Longrightarrow> Fr_1b(\<F>\<^sub>D \<D>)" unfolding Fr_1b_def Fr_der_def using CI1b MULT_a_def conn by smt
lemma FD1: "Der_1 \<D> \<Longrightarrow> Fr_1(\<F>\<^sub>D \<D>)" unfolding Fr_1_def Fr_der_def using CI1 MULT_def conn by auto
lemma FD2: "Fr_2(\<F>\<^sub>D \<D>)" using dual_def dual_symm unfolding Fr_2_def Fr_der_def conn by metis
lemma FD3: "Der_3 \<D> \<Longrightarrow> Fr_3(\<F>\<^sub>D \<D>)" by (simp add: NOR_def Fr_der_def conn)
lemma FD4: "Der_1 \<D> \<Longrightarrow> Der_4e \<D> \<Longrightarrow> Fr_4(\<F>\<^sub>D \<D>)" by (metis CD1b CD2 CD4 Cl_8_def Cl_der_def Fr_4_def Fr_der_def2 PC1 PC8 meet_def)

text\<open>\noindent{Note that the derivative operation cannot be obtained from interior, closure, border, nor frontier.
In this respect the derivative is a fundamental operation.}\<close>

subsubsection \<open>Infinitary conditions\<close>

text\<open>\noindent{The corresponding infinitary condition on derivative operators is inherited from the one for closure.}\<close>
abbreviation "Der_inf \<phi> \<equiv> Cl_inf(\<phi>)"

lemma CD_inf: "Der_inf \<phi> \<Longrightarrow> Cl_inf(\<C>\<^sub>D \<phi>)" unfolding iADDI_a_def by (smt Cl_der_def Fr_2_def Ra_restr_ex compl_def dom_compl_def2 iDM_b join_def meet_def supremum_def)
lemma ID_inf: "Der_inf \<phi> \<Longrightarrow> Int_inf(\\<^sub>D \<phi>)" by (simp add: CD_inf dual_der2 iADDI_MULT_dual1)

text\<open>\noindent{This condition is indeed strong enough as to entail closure of some fixed-point predicates under infimum/supremum.}\<close>
lemma fp_ID_inf_closed: "Der_inf \<phi> \<Longrightarrow> infimum_closed (fp (\\<^sub>D \<phi>))" by (metis (full_types) ID2 ID_inf Ra_restr_all dEXP_def iMULT_b_def inf_char)
lemma fp_CD_sup_closed: "Der_inf \<phi> \<Longrightarrow> supremum_closed (fp (\<C>\<^sub>D \<phi>))" by (metis (full_types) CD_inf Cl_der_def Ra_restr_ex iADDI_a_def join_def supremum_def)

subsubsection \<open>Coherence conditions\<close>
text\<open>\noindent{We finish this section by introducing the `coherence' operator (Cantor's `Koherenz') as discussed
by Zarycki in \<^cite>\<open>Zarycki2\<close>. As happens with the derivative operator, the coherence operator cannot
be derived from interior, closure, border, nor frontier.}\<close>

definition "Kh_1 \<phi> \<equiv> ADDI_b \<phi>"
definition "Kh_2 \<phi> \<equiv> dEXP \<phi>"
definition "Kh_3 \<phi> \<equiv> \<forall>A. \<phi>(\<phi>\<^sup>d A) \<^bold>\<approx> \<phi>\<^sup>d(\<phi> A)"

lemma PK1: "Kh_1 \<phi> \<equiv> MONO \<phi>" using ADDI_b_def Kh_1_def MONO_ADDIb by auto
lemma PK2: "Kh_1 \<phi> \<equiv> \<forall>A B. \<phi>(A \<^bold>\<and> B) \<^bold>\<preceq> (\<phi> A) \<^bold>\<and> (\<phi> B)" using MULT_a_def MONO_MULTa PK1 by auto
lemma PK3: "Kh_2 \<phi> \<Longrightarrow> \<phi> \<^bold>\<bottom> \<^bold>\<approx> \<^bold>\<bottom>" using Kh_2_def dEXP_def unfolding conn by auto
lemma PK4: "Kh_1 \<phi> \<Longrightarrow>  Kh_3 \<phi> \<Longrightarrow> \<phi> \<^bold>\<top> \<^bold>\<approx> \<^bold>\<top>" using MONO_def PK1 dual_def unfolding Kh_3_def conn by metis
lemma PK5: "Kh_2 \<phi> \<Longrightarrow>  \<forall>A. \<phi>(\<^bold>\<midarrow>A) \<^bold>\<preceq> \<^bold>\<midarrow>(\<phi> A)" unfolding Kh_2_def dEXP_def conn by metis
lemma PK6: "Kh_1 \<phi> \<Longrightarrow> Kh_2 \<phi> \<Longrightarrow>  \<forall>A B. \<phi>(A \<^bold>\<leftharpoonup> B) \<^bold>\<preceq> (\<phi> A) \<^bold>\<leftharpoonup> (\<phi> B)" unfolding conn by (metis (no_types, lifting) Kh_2_def dEXP_def MONO_def PK1)

text\<open>\noindent{Coherence operator as derived from derivative (requires conditions Der-2 and Der-4).}\<close>
definition Kh_der::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("\<K>\<^sub>D") where "\<K>\<^sub>D \<D> \<equiv> \<lambda>A. A \<^bold>\<and> (\<D> A)"
text\<open>\noindent{Verify properties:}\<close>
lemma KD1: "Der_1 \<phi> \<Longrightarrow> Kh_1 (\<K>\<^sub>D \<phi>)" using PC1 PD3 PK2 ADDI_def Kh_der_def unfolding conn by (metis (full_types))
lemma KD2: "Kh_2 (\<K>\<^sub>D \<phi>)" by (simp add: Kh_2_def dEXP_def Kh_der_def conn)
lemma KD3: "Der_1 \<phi> \<Longrightarrow> Der_2 \<phi> \<Longrightarrow> Der_4 \<phi>  \<Longrightarrow> Kh_3 (\<K>\<^sub>D \<phi>)" proof -
 assume der1: "Der_1 \<phi>" and der2: "Der_2 \<phi>" and der4: "Der_4 \<phi>"
  { fix A
    from der1 have aux1: "let M=A ; N=(\<phi>\<^sup>d A) in \<phi>(M \<^bold>\<or> N) \<^bold>\<approx> (\<phi> M \<^bold>\<or> \<phi> N)" unfolding ADDI_def by simp
    from der1 der2 der4 have aux2: "(\<phi>\<^sup>d A) \<^bold>\<and> (\<phi> A) \<^bold>\<approx> \<phi>\<^sup>d(A \<^bold>\<and> \<phi> A)" using PD12 by simp
    have "(\<K>\<^sub>D \<phi>)((\<K>\<^sub>D \<phi>)\<^sup>d A) = (\<^bold>\<midarrow>(\<^bold>\<midarrow>A \<^bold>\<and> \<phi> (\<^bold>\<midarrow>A)) \<^bold>\<and> \<phi> (\<^bold>\<midarrow>(\<^bold>\<midarrow>A \<^bold>\<and> \<phi> (\<^bold>\<midarrow>A))))" unfolding Kh_der_def dual_def by simp
    also have "... = (A \<^bold>\<or> \<phi>\<^sup>d A) \<^bold>\<and> \<phi>(A \<^bold>\<or> \<phi>\<^sup>d A)" unfolding dual_def conn by simp
    also from aux1 have "... = (A \<^bold>\<or> \<phi>\<^sup>d A) \<^bold>\<and> (\<phi> A \<^bold>\<or> \<phi>(\<phi>\<^sup>d A))" unfolding conn by meson
    also have "... = (A \<^bold>\<and> \<phi> A) \<^bold>\<or> \<phi>\<^sup>d A" using PD6 PD8 der1 der2 der4 unfolding conn by blast
    also have "... = (A \<^bold>\<and> \<phi> A) \<^bold>\<or> (\<phi>\<^sup>d A \<^bold>\<and> \<phi> A)" using PD6 der1 der2 unfolding conn by blast
    also have "... = (A \<^bold>\<or> \<phi>\<^sup>d A) \<^bold>\<and> (\<phi> A)" unfolding conn by auto
    also from aux2 have "... = (A \<^bold>\<and> \<phi> A) \<^bold>\<or> \<phi>\<^sup>d(A \<^bold>\<and> \<phi> A)" unfolding dual_def conn by meson
    also have "... = \<^bold>\<midarrow>(\<^bold>\<midarrow>(A \<^bold>\<and> \<phi> A) \<^bold>\<and> \<phi> (\<^bold>\<midarrow>(A \<^bold>\<and> \<phi> A)))" unfolding dual_def conn by simp
    also have "... = (\<K>\<^sub>D \<phi>)\<^sup>d((\<K>\<^sub>D \<phi>) A)" unfolding Kh_der_def dual_def by simp
    finally have "(\<K>\<^sub>D \<phi>)((\<K>\<^sub>D \<phi>)\<^sup>d A) \<^bold>\<approx> (\<K>\<^sub>D \<phi>)\<^sup>d((\<K>\<^sub>D \<phi>) A)" by simp
 } thus ?thesis unfolding Kh_3_def by simp
qed

end


section "Small-Step Semantics of Commands"

theory Small_Step imports "~~/src/HOL/IMP/Star" "./Big_Step" begin

subsection "The transition relation"

inductive
  small_step :: "com \<times> state \<Rightarrow> com \<times> state \<Rightarrow> bool" (infix "\<rightarrow>" 55)
where
Assign:  "(x ::= a, s) \<rightarrow> (SKIP, s(x := aval a s))" |

Seq1:    "(SKIP;;c\<^sub>2,s) \<rightarrow> (c\<^sub>2,s)" |
Seq2:    "(THROW;; c\<^sub>2, s) \<rightarrow> (THROW, s)" |
Seq3:    "(c\<^sub>1,s) \<rightarrow> (c\<^sub>1',s') \<Longrightarrow> (c\<^sub>1;;c\<^sub>2,s) \<rightarrow> (c\<^sub>1';;c\<^sub>2,s')" |

IfTrue:  "bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2,s) \<rightarrow> (c\<^sub>1,s)" |
IfFalse: "\<not>bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2,s) \<rightarrow> (c\<^sub>2,s)" |

While:   "(WHILE b DO c,s) \<rightarrow>
            (IF b THEN c;; WHILE b DO c ELSE SKIP,s)" |

TryStep: "(c, s) \<rightarrow> (c', t) \<Longrightarrow> (TRY c CATCH c2, s) \<rightarrow> (TRY c' CATCH c2, t)" |
TryGood: "(TRY SKIP CATCH c2, s) \<rightarrow> (SKIP, s)" |
TryBad: "(TRY THROW CATCH c2, s) \<rightarrow> (c2, s)"

abbreviation
  small_steps :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>*" 55)
where "x \<rightarrow>* y == star small_step x y"

subsection{* Executability *}

code_pred small_step .

values "{(c',map t [''x'',''y'',''z'']) |c' t.
   (''x'' ::= V ''z'';; ''y'' ::= V ''x'',
    <''x'' := 3, ''y'' := 7, ''z'' := 5>) \<rightarrow>* (c',t)}"

values "{(c', map t [''x'']) |c' t. (TRY ''x'' ::= N 2;;
THROW;; ''x'' ::= N 4 CATCH ''x'' ::= N 3, <>) \<rightarrow>* (c', t)}"

subsection{* Proof infrastructure *}

subsubsection{* Induction rules *}

text{* The default induction rule @{thm[source] small_step.induct} only works
for lemmas of the form @{text"a \<rightarrow> b \<Longrightarrow> \<dots>"} where @{text a} and @{text b} are
not already pairs @{text"(DUMMY,DUMMY)"}. We can generate a suitable variant
of @{thm[source] small_step.induct} for pairs by ``splitting'' the arguments
@{text"\<rightarrow>"} into pairs: *}
lemmas small_step_induct = small_step.induct[split_format(complete)]

subsubsection{* Proof automation *}

declare small_step.intros[simp,intro]

text{* Rule inversion: *}

inductive_cases SkipE[elim!]: "(SKIP,s) \<rightarrow> ct"
inductive_cases ThrowE[elim!]: "(THROW,s) \<rightarrow> ct"
thm SkipE
inductive_cases AssignE[elim!]: "(x::=a,s) \<rightarrow> ct"
thm AssignE
inductive_cases SeqE[elim!]: "(c1;;c2,s) \<rightarrow> ct"
thm SeqE
inductive_cases IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<rightarrow> ct"
inductive_cases WhileE[elim]: "(WHILE b DO c, s) \<rightarrow> ct"
inductive_cases TryE[elim!]: "(TRY c CATCH c2, s) \<rightarrow> ct"

text{* A simple property: *}
lemma deterministic:
  "(cs, s) \<rightarrow> t1 \<Longrightarrow> (cs, s) \<rightarrow> t2 \<Longrightarrow> t1 = t2"
by (induction arbitrary: t2 rule: small_step.induct) blast+

subsection "Equivalence with big-step semantics"

lemma star_seq2: "(c1,s) \<rightarrow>* (c1',s') \<Longrightarrow> (c1;;c2,s) \<rightarrow>* (c1';;c2,s')"
proof(induction rule: star_induct)
  case refl thus ?case by simp
next
  case step
  thus ?case by (metis Seq3 star.step)
qed

lemma seq_comp:
  "\<lbrakk> (c1,s1) \<rightarrow>* (SKIP,s2); (c2,s2) \<rightarrow>* (c3,s3) \<rbrakk>
   \<Longrightarrow> (c1;;c2, s1) \<rightarrow>* (c3,s3)"
by(blast intro: star.step star_seq2 star_trans)

lemma seq_comp2:
  "\<lbrakk> (c1,s1) \<rightarrow>* (THROW,s2); (c2,s2) \<rightarrow>* (c3,s3) \<rbrakk>
   \<Longrightarrow> (c1;;c2, s1) \<rightarrow>* (THROW,s2)"
by(blast intro: star.step star_seq2 star_trans)

lemma always_execute_inner:
assumes "(c, s) \<rightarrow>* (c', s')"
shows "(TRY c CATCH c2, s) \<rightarrow>* (TRY c' CATCH c2, s')"
using assms
proof (induction rule: star_induct)
  case refl show ?case by simp
next
  case step thus ?case by (meson TryStep star.step)
qed

text{* Each case of the induction can be proved automatically: *}
lemma big_to_small: "cs \<Rightarrow> t \<Longrightarrow> cs \<rightarrow>* t"
proof (induction rule: big_step.induct)
  case Seq1 thus ?case using seq_comp by (meson star.refl star_trans)
next
  case Seq2 thus ?case using seq_comp2 by blast
next
  case IfTrue thus ?case by (blast intro: star.step)
next
  case IfFalse thus ?case by (blast intro: star.step)
next
  case WhileFalse thus ?case
    by (metis star.step star_step1 small_step.IfFalse small_step.While)
next
  case WhileTrue1
  thus ?case using seq_comp
    by (meson While small_step.IfTrue star.refl star_step1 star_trans)
next
  case WhileTrue2
  thus ?case using seq_comp2
    by (meson While small_step.IfTrue star.refl star_step1 star_trans)
next
  case (TryOk c s t c2)
  from `(c, s) \<rightarrow>* (SKIP, t)` have "(TRY c CATCH c2, s) \<rightarrow>* (TRY SKIP CATCH c2, t)"
    using always_execute_inner by auto
  moreover have "(TRY SKIP CATCH c2, t) \<rightarrow>* (SKIP, t)" using TryGood by auto
  ultimately show ?case using star_trans by fastforce
next
  case (TryBad c s t c2 ct)
  thus ?case by (meson always_execute_inner star_step1 star_trans  small_step.TryBad)
qed blast+

lemma small1_big_continue:
  "cs \<rightarrow> cs' \<Longrightarrow> cs' \<Rightarrow> t \<Longrightarrow> cs \<Rightarrow> t"
apply (induction arbitrary: t rule: small_step.induct)
apply auto
done

lemma small_to_big_skip:
  "cs \<rightarrow>* (SKIP, t) \<Longrightarrow> cs \<Rightarrow> (SKIP, t)"
apply (induction cs "(SKIP, t)" rule: star.induct)
apply (auto intro: small1_big_continue)
done

lemma small_to_big_throw:
  "cs \<rightarrow>* (THROW, t) \<Longrightarrow> cs \<Rightarrow> (THROW, t)"
apply (induction cs "(THROW, t)" rule: star.induct)
apply (auto intro: small1_big_continue)
done

text {*
  Finally, the equivalence theorem:
*}

lemma big_iff_small_skip:
  "cs \<Rightarrow> (SKIP, t) = cs \<rightarrow>* (SKIP, t)"
by(metis big_to_small small_to_big_skip)

lemma big_iff_small_throw:
  "cs \<Rightarrow> (THROW, t) = cs \<rightarrow>* (THROW, t)"
by(metis big_to_small small_to_big_throw)

subsection "Final configurations and infinite reductions"

definition "final cs \<longleftrightarrow> \<not>(EX cs'. cs \<rightarrow> cs')"

lemma finalD: "final (c,s) \<Longrightarrow> c = SKIP \<or> c = THROW"
apply(simp add: final_def)
apply(induction c)
apply blast+
done

lemma final_iff_SKIP_or_THROW: "final (c,s) = (c = SKIP \<or> c = THROW)"
using finalD final_def by blast

lemma big_is_final:
  "cs \<Rightarrow> t \<Longrightarrow> final t"
by (induction rule: big_step.induct, auto simp add: final_iff_SKIP_or_THROW)

lemma big_iff_small_termination:
assumes "cs \<rightarrow>* t" and "final t"
shows "cs \<Rightarrow> t"
proof -
  from `cs \<rightarrow>* t` obtain c' t' where 1: "t = (c', t')" by fastforce
  from `final t` have 2: "t = (THROW, t') \<or> t = (SKIP, t')"
    using final_iff_SKIP_or_THROW 1 by auto
  moreover have "t = (THROW, t') \<Longrightarrow> cs \<Rightarrow> t" proof -
    assume "t = (THROW, t')"
    then show "cs \<Rightarrow> t" using `cs \<rightarrow>* t` small_to_big_throw by auto
  qed
  moreover have "t = (SKIP, t') \<Longrightarrow> cs \<Rightarrow> t" proof -
    assume "t = (SKIP, t')"
    then show "cs \<Rightarrow> t" using `cs \<rightarrow>* t` small_to_big_skip by auto
  qed
  ultimately show "cs \<Rightarrow> t" using 2 by auto
qed

text{* Now we can show that @{text"\<Rightarrow>"} yields a final state iff @{text"\<rightarrow>"}
terminates: *}

lemma big_iff_small_termination_weird_exists_form:
  "(EX t. cs \<Rightarrow> t) \<longleftrightarrow> (EX cs'. cs \<rightarrow>* cs' \<and> final cs')"
by (meson big_is_final big_iff_small_termination final_iff_SKIP_or_THROW big_to_small)

text{* This is the same as saying that the absence of a big step result is
equivalent with absence of a terminating small step sequence, i.e.\ with
nontermination.  Since @{text"\<rightarrow>"} is determininistic, there is no difference
between may and must terminate. *}

end