(*  Title:      HOL/Library/Mapping.thy
    Author:     Florian Haftmann and Ondrej Kuncar
*)

section {* An abstract view on maps for code generation. *}

theory Mapping
imports Main
begin

subsection {* Parametricity transfer rules *}

lemma map_of_foldr: -- {* FIXME move *}
  "map_of xs = foldr (\<lambda>(k, v) m. m(k \<mapsto> v)) xs Map.empty"
  using map_add_map_of_foldr [of Map.empty] by auto

context
begin

interpretation lifting_syntax .

lemma empty_parametric:
  "(A ===> rel_option B) Map.empty Map.empty"
  by transfer_prover

lemma lookup_parametric: "((A ===> B) ===> A ===> B) (\<lambda>m k. m k) (\<lambda>m k. m k)"
  by transfer_prover

lemma update_parametric:
  assumes [transfer_rule]: "bi_unique A"
  shows "(A ===> B ===> (A ===> rel_option B) ===> A ===> rel_option B)
    (\<lambda>k v m. m(k \<mapsto> v)) (\<lambda>k v m. m(k \<mapsto> v))"
  by transfer_prover

lemma delete_parametric:
  assumes [transfer_rule]: "bi_unique A"
  shows "(A ===> (A ===> rel_option B) ===> A ===> rel_option B)
    (\<lambda>k m. m(k := None)) (\<lambda>k m. m(k := None))"
  by transfer_prover

lemma is_none_parametric [transfer_rule]:
  "(rel_option A ===> HOL.eq) Option.is_none Option.is_none"
  by (auto simp add: is_none_def rel_fun_def rel_option_iff split: option.split)

lemma dom_parametric:
  assumes [transfer_rule]: "bi_total A"
  shows "((A ===> rel_option B) ===> rel_set A) dom dom"
  unfolding dom_def [abs_def] is_none_def [symmetric] by transfer_prover

lemma map_of_parametric [transfer_rule]:
  assumes [transfer_rule]: "bi_unique R1"
  shows "(list_all2 (rel_prod R1 R2) ===> R1 ===> rel_option R2) map_of map_of"
  unfolding map_of_def by transfer_prover

lemma map_entry_parametric [transfer_rule]:
  assumes [transfer_rule]: "bi_unique A"
  shows "(A ===> (B ===> B) ===> (A ===> rel_option B) ===> A ===> rel_option B)
    (\<lambda>k f m. (case m k of None \<Rightarrow> m
      | Some v \<Rightarrow> m (k \<mapsto> (f v)))) (\<lambda>k f m. (case m k of None \<Rightarrow> m
      | Some v \<Rightarrow> m (k \<mapsto> (f v))))"
  by transfer_prover

lemma tabulate_parametric:
  assumes [transfer_rule]: "bi_unique A"
  shows "(list_all2 A ===> (A ===> B) ===> A ===> rel_option B)
    (\<lambda>ks f. (map_of (map (\<lambda>k. (k, f k)) ks))) (\<lambda>ks f. (map_of (map (\<lambda>k. (k, f k)) ks)))"
  by transfer_prover

lemma bulkload_parametric:
  "(list_all2 A ===> HOL.eq ===> rel_option A)
    (\<lambda>xs k. if k < length xs then Some (xs ! k) else None) (\<lambda>xs k. if k < length xs then Some (xs ! k) else None)"
proof
  fix xs ys
  assume "list_all2 A xs ys"
  then show "(HOL.eq ===> rel_option A)
    (\<lambda>k. if k < length xs then Some (xs ! k) else None)
    (\<lambda>k. if k < length ys then Some (ys ! k) else None)"
    apply induct
    apply auto
    unfolding rel_fun_def
    apply clarsimp
    apply (case_tac xa)
    apply (auto dest: list_all2_lengthD list_all2_nthD)
    done
qed

lemma map_parametric:
  "((A ===> B) ===> (C ===> D) ===> (B ===> rel_option C) ===> A ===> rel_option D)
     (\<lambda>f g m. (map_option g \<circ> m \<circ> f)) (\<lambda>f g m. (map_option g \<circ> m \<circ> f))"
  by transfer_prover

end

subsection {* Type definition and primitive operations *}

typedef ('a, 'b) mapping = "UNIV :: ('a \<rightharpoonup> 'b) set"
  morphisms rep Mapping
  ..

setup_lifting (no_code) type_definition_mapping

lift_definition empty :: "('a, 'b) mapping"
  is Map.empty parametric empty_parametric .

lift_definition lookup :: "('a, 'b) mapping \<Rightarrow> 'a \<Rightarrow> 'b option"
  is "\<lambda>m k. m k" parametric lookup_parametric .

lift_definition update :: "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) mapping \<Rightarrow> ('a, 'b) mapping"
  is "\<lambda>k v m. m(k \<mapsto> v)" parametric update_parametric .

lift_definition delete :: "'a \<Rightarrow> ('a, 'b) mapping \<Rightarrow> ('a, 'b) mapping"
  is "\<lambda>k m. m(k := None)" parametric delete_parametric .

lift_definition keys :: "('a, 'b) mapping \<Rightarrow> 'a set"
  is dom parametric dom_parametric .

lift_definition tabulate :: "'a list \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a, 'b) mapping"
  is "\<lambda>ks f. (map_of (List.map (\<lambda>k. (k, f k)) ks))" parametric tabulate_parametric .

lift_definition bulkload :: "'a list \<Rightarrow> (nat, 'a) mapping"
  is "\<lambda>xs k. if k < length xs then Some (xs ! k) else None" parametric bulkload_parametric .

lift_definition map :: "('c \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> 'd) \<Rightarrow> ('a, 'b) mapping \<Rightarrow> ('c, 'd) mapping"
  is "\<lambda>f g m. (map_option g \<circ> m \<circ> f)" parametric map_parametric .

subsection {* Functorial structure *}

functor map: map
  by (transfer, auto simp add: fun_eq_iff option.map_comp option.map_id)+

subsection {* Derived operations *}

definition ordered_keys :: "('a\<Colon>linorder, 'b) mapping \<Rightarrow> 'a list"
where
  "ordered_keys m = (if finite (keys m) then sorted_list_of_set (keys m) else [])"

definition is_empty :: "('a, 'b) mapping \<Rightarrow> bool"
where
  "is_empty m \<longleftrightarrow> keys m = {}"

definition size :: "('a, 'b) mapping \<Rightarrow> nat"
where
  "size m = (if finite (keys m) then card (keys m) else 0)"

definition replace :: "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) mapping \<Rightarrow> ('a, 'b) mapping"
where
  "replace k v m = (if k \<in> keys m then update k v m else m)"

definition default :: "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) mapping \<Rightarrow> ('a, 'b) mapping"
where
  "default k v m = (if k \<in> keys m then m else update k v m)"

text {* Manual derivation of transfer rule is non-trivial *}

lift_definition map_entry :: "'a \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> ('a, 'b) mapping \<Rightarrow> ('a, 'b) mapping" is
  "\<lambda>k f m. (case m k of None \<Rightarrow> m
    | Some v \<Rightarrow> m (k \<mapsto> (f v)))" parametric map_entry_parametric .

lemma map_entry_code [code]:
  "map_entry k f m = (case lookup m k of None \<Rightarrow> m
    | Some v \<Rightarrow> update k (f v) m)"
  by transfer rule

definition map_default :: "'a \<Rightarrow> 'b \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> ('a, 'b) mapping \<Rightarrow> ('a, 'b) mapping"
where
  "map_default k v f m = map_entry k f (default k v m)"

definition of_alist :: "('k \<times> 'v) list \<Rightarrow> ('k, 'v) mapping"
where
  "of_alist xs = foldr (\<lambda>(k, v) m. update k v m) xs empty"

instantiation mapping :: (type, type) equal
begin

definition
  "HOL.equal m1 m2 \<longleftrightarrow> (\<forall>k. lookup m1 k = lookup m2 k)"

instance proof
qed (unfold equal_mapping_def, transfer, auto)

end

context
begin

interpretation lifting_syntax .

lemma of_alist_transfer [transfer_rule]:
  assumes [transfer_rule]: "bi_unique R1"
  shows "(list_all2 (rel_prod R1 R2) ===> pcr_mapping R1 R2) map_of of_alist"
  unfolding of_alist_def [abs_def] map_of_foldr [abs_def] by transfer_prover

end

subsection {* Properties *}

lemma lookup_update:
  "lookup (update k v m) k = Some v"
  by transfer simp

lemma lookup_update_neq:
  "k \<noteq> k' \<Longrightarrow> lookup (update k v m) k' = lookup m k'"
  by transfer simp

lemma lookup_empty:
  "lookup empty k = None"
  by transfer simp

lemma keys_is_none_rep [code_unfold]:
  "k \<in> keys m \<longleftrightarrow> \<not> (Option.is_none (lookup m k))"
  by transfer (auto simp add: is_none_def)

lemma update_update:
  "update k v (update k w m) = update k v m"
  "k \<noteq> l \<Longrightarrow> update k v (update l w m) = update l w (update k v m)"
  by (transfer, simp add: fun_upd_twist)+

lemma update_delete [simp]:
  "update k v (delete k m) = update k v m"
  by transfer simp

lemma delete_update:
  "delete k (update k v m) = delete k m"
  "k \<noteq> l \<Longrightarrow> delete k (update l v m) = update l v (delete k m)"
  by (transfer, simp add: fun_upd_twist)+

lemma delete_empty [simp]:
  "delete k empty = empty"
  by transfer simp

lemma replace_update:
  "k \<notin> keys m \<Longrightarrow> replace k v m = m"
  "k \<in> keys m \<Longrightarrow> replace k v m = update k v m"
  by (transfer, auto simp add: replace_def fun_upd_twist)+

lemma size_empty [simp]:
  "size empty = 0"
  unfolding size_def by transfer simp

lemma size_update:
  "finite (keys m) \<Longrightarrow> size (update k v m) =
    (if k \<in> keys m then size m else Suc (size m))"
  unfolding size_def by transfer (auto simp add: insert_dom)

lemma size_delete:
  "size (delete k m) = (if k \<in> keys m then size m - 1 else size m)"
  unfolding size_def by transfer simp

lemma size_tabulate [simp]:
  "size (tabulate ks f) = length (remdups ks)"
  unfolding size_def by transfer (auto simp add: map_of_map_restrict  card_set comp_def)

lemma bulkload_tabulate:
  "bulkload xs = tabulate [0..<length xs] (nth xs)"
  by transfer (auto simp add: map_of_map_restrict)

lemma is_empty_empty [simp]:
  "is_empty empty"
  unfolding is_empty_def by transfer simp

lemma is_empty_update [simp]:
  "\<not> is_empty (update k v m)"
  unfolding is_empty_def by transfer simp

lemma is_empty_delete:
  "is_empty (delete k m) \<longleftrightarrow> is_empty m \<or> keys m = {k}"
  unfolding is_empty_def by transfer (auto simp del: dom_eq_empty_conv)

lemma is_empty_replace [simp]:
  "is_empty (replace k v m) \<longleftrightarrow> is_empty m"
  unfolding is_empty_def replace_def by transfer auto

lemma is_empty_default [simp]:
  "\<not> is_empty (default k v m)"
  unfolding is_empty_def default_def by transfer auto

lemma is_empty_map_entry [simp]:
  "is_empty (map_entry k f m) \<longleftrightarrow> is_empty m"
  unfolding is_empty_def by transfer (auto split: option.split)

lemma is_empty_map_default [simp]:
  "\<not> is_empty (map_default k v f m)"
  by (simp add: map_default_def)

lemma keys_dom_lookup:
  "keys m = dom (Mapping.lookup m)"
  by transfer rule

lemma keys_empty [simp]:
  "keys empty = {}"
  by transfer simp

lemma keys_update [simp]:
  "keys (update k v m) = insert k (keys m)"
  by transfer simp

lemma keys_delete [simp]:
  "keys (delete k m) = keys m - {k}"
  by transfer simp

lemma keys_replace [simp]:
  "keys (replace k v m) = keys m"
  unfolding replace_def by transfer (simp add: insert_absorb)

lemma keys_default [simp]:
  "keys (default k v m) = insert k (keys m)"
  unfolding default_def by transfer (simp add: insert_absorb)

lemma keys_map_entry [simp]:
  "keys (map_entry k f m) = keys m"
  by transfer (auto split: option.split)

lemma keys_map_default [simp]:
  "keys (map_default k v f m) = insert k (keys m)"
  by (simp add: map_default_def)

lemma keys_tabulate [simp]:
  "keys (tabulate ks f) = set ks"
  by transfer (simp add: map_of_map_restrict o_def)

lemma keys_bulkload [simp]:
  "keys (bulkload xs) = {0..<length xs}"
  by (simp add: bulkload_tabulate)

lemma distinct_ordered_keys [simp]:
  "distinct (ordered_keys m)"
  by (simp add: ordered_keys_def)

lemma ordered_keys_infinite [simp]:
  "\<not> finite (keys m) \<Longrightarrow> ordered_keys m = []"
  by (simp add: ordered_keys_def)

lemma ordered_keys_empty [simp]:
  "ordered_keys empty = []"
  by (simp add: ordered_keys_def)

lemma ordered_keys_update [simp]:
  "k \<in> keys m \<Longrightarrow> ordered_keys (update k v m) = ordered_keys m"
  "finite (keys m) \<Longrightarrow> k \<notin> keys m \<Longrightarrow> ordered_keys (update k v m) = insort k (ordered_keys m)"
  by (simp_all add: ordered_keys_def) (auto simp only: sorted_list_of_set_insert [symmetric] insert_absorb)

lemma ordered_keys_delete [simp]:
  "ordered_keys (delete k m) = remove1 k (ordered_keys m)"
proof (cases "finite (keys m)")
  case False then show ?thesis by simp
next
  case True note fin = True
  show ?thesis
  proof (cases "k \<in> keys m")
    case False with fin have "k \<notin> set (sorted_list_of_set (keys m))" by simp
    with False show ?thesis by (simp add: ordered_keys_def remove1_idem)
  next
    case True with fin show ?thesis by (simp add: ordered_keys_def sorted_list_of_set_remove)
  qed
qed

lemma ordered_keys_replace [simp]:
  "ordered_keys (replace k v m) = ordered_keys m"
  by (simp add: replace_def)

lemma ordered_keys_default [simp]:
  "k \<in> keys m \<Longrightarrow> ordered_keys (default k v m) = ordered_keys m"
  "finite (keys m) \<Longrightarrow> k \<notin> keys m \<Longrightarrow> ordered_keys (default k v m) = insort k (ordered_keys m)"
  by (simp_all add: default_def)

lemma ordered_keys_map_entry [simp]:
  "ordered_keys (map_entry k f m) = ordered_keys m"
  by (simp add: ordered_keys_def)

lemma ordered_keys_map_default [simp]:
  "k \<in> keys m \<Longrightarrow> ordered_keys (map_default k v f m) = ordered_keys m"
  "finite (keys m) \<Longrightarrow> k \<notin> keys m \<Longrightarrow> ordered_keys (map_default k v f m) = insort k (ordered_keys m)"
  by (simp_all add: map_default_def)

lemma ordered_keys_tabulate [simp]:
  "ordered_keys (tabulate ks f) = sort (remdups ks)"
  by (simp add: ordered_keys_def sorted_list_of_set_sort_remdups)

lemma ordered_keys_bulkload [simp]:
  "ordered_keys (bulkload ks) = [0..<length ks]"
  by (simp add: ordered_keys_def)

lemma tabulate_fold:
  "tabulate xs f = fold (\<lambda>k m. update k (f k) m) xs empty"
proof transfer
  fix f :: "'a \<Rightarrow> 'b" and xs
  have "map_of (List.map (\<lambda>k. (k, f k)) xs) = foldr (\<lambda>k m. m(k \<mapsto> f k)) xs Map.empty"
    by (simp add: foldr_map comp_def map_of_foldr)
  also have "foldr (\<lambda>k m. m(k \<mapsto> f k)) xs = fold (\<lambda>k m. m(k \<mapsto> f k)) xs"
    by (rule foldr_fold) (simp add: fun_eq_iff)
  ultimately show "map_of (List.map (\<lambda>k. (k, f k)) xs) = fold (\<lambda>k m. m(k \<mapsto> f k)) xs Map.empty"
    by simp
qed

subsection {* Code generator setup *}

code_datatype empty update

hide_const (open) empty is_empty rep lookup update delete ordered_keys keys size
  replace default map_entry map_default tabulate bulkload map of_alist

end


theory ref_crdt_proofs
imports ref_crdt
begin

lemma findMinimal_depends:
  assumes same: "\<And>x y. \<lbrakk>x\<in>set xs; y\<in> set xs\<rbrakk> \<Longrightarrow> (x,y)\<in>R1 \<longleftrightarrow>(x,y)\<in>R2"
  shows "findMinimal R1 xs = findMinimal R2 xs"
  using assms
  by (auto simp add: findMinimal_def  split: option.splits cong: find_cong)

lemma topSort_depends:
  assumes "\<And>x y. \<lbrakk>x\<in>set xs; y\<in> set xs\<rbrakk> \<Longrightarrow> (x,y)\<in>R1 \<longleftrightarrow>(x,y)\<in>R2"
  shows "topSort R1 xs = topSort R2 xs"
  using assms  apply (induct R1 xs rule: topSort.induct)
   apply simp
  by (metis findMinimal_depends notin_set_remove1 topSort.simps(2))

lemma topSortRest: "topSort (Restr R (set xs)) xs = topSort R xs"
  by (rule topSort_depends, auto)

lemma topSortRest2: "set xs \<subseteq> S \<Longrightarrow> topSort (Restr R S) xs = topSort R xs"
  by (smt Int_iff mem_Sigma_iff subset_iff topSort_depends)

lemma topSort_set[simp]: "set (topSort R xs) = set xs"
  apply (induct R xs rule: topSort.induct)
   apply (auto simp add: Let_def )
  by (metis findMinimal_termination2 length_remove1 nat_neq_iff)

lemma topSort_length: "length (topSort R xs) = length xs"
  apply (induct R xs rule: topSort.induct)
   apply (auto simp add: Let_def )
  by (metis One_nat_def Suc_pred findMinimal_termination2 length_greater_0_conv length_remove1 nat_neq_iff remove1.simps(1))

lemma nth_inset: "\<lbrakk>xs!i = x; i<length xs\<rbrakk> \<Longrightarrow> x\<in>set xs"
  by auto

lemma exists_minimal_partial_order:
  assumes "finite S"
and "S \<noteq> {}"
and po1: "antisym R"
and po2: "trans R"
shows "\<exists>x\<in>S. \<forall>y\<in>S. y=x \<or> (y,x)\<notin>R"

  using `finite S` `S \<noteq> {}` proof (induct rule: finite_induct)
  case empty
  then show ?case by simp
next
  case (insert a F)

  show ?case
  proof (cases "F={}")
    case True
    then show ?thesis
      by auto
  next
    case False

    obtain min where "min\<in>F" and "\<forall>y\<in>F. y = min \<or> (y, min) \<notin> R"
      using False insert.hyps(3) by blast

    show ?thesis
    proof (cases "(a,min)\<in>R")
      case True

      have "\<forall>y\<in>F. y = a \<or> (y, a) \<notin> R"
        apply auto
        by (metis True \<open>\<forall>y\<in>F. y = min \<or> (y, min) \<notin> R\<close> antisymD po1 po2 transE)

      then show ?thesis
        by blast
    next
      case False
      then show ?thesis
        using \<open>\<forall>y\<in>F. y = min \<or> (y, min) \<notin> R\<close> \<open>min \<in> F\<close> by auto

    qed
  qed
qed

lemma findMinimal_min1:
  assumes in_set: "a\<in>set xs"
and not_min: "a\<noteq>findMinimal R xs"
and nonempty: "xs \<noteq> []"
and po1: "antisym R"
and po2: "trans R"
shows "(a, findMinimal R xs) \<notin> R"
  using in_set not_min nonempty apply (auto simp add: findMinimal_def  split: option.splits)
   apply (auto simp add: find_None_iff find_Some_iff)
  by (meson List.finite_set exists_minimal_partial_order po1 po2 set_empty)

lemma findMinimal_min2:
  fixes R :: "'a rel"
  assumes in_set: "a\<in>set xs"
and not_min: "a\<noteq>findMinimal R xs"
and nonempty: "xs \<noteq> []"
and po1: "antisym R"
and po2: "trans R"
shows "(findMinimal R xs, a) \<notin> R"
  oops

lemma findMinimal_min3:
  assumes "(x, findMinimal R xs) \<in> R"
and "x\<in>set xs"
and nonempty: "xs \<noteq> []"
and po1: "antisym R"
and po2: "trans R"
shows "x = findMinimal R xs"
  by (meson assms(1) assms(2) findMinimal_min1 nonempty po1 po2)

lemma notin_remove1: "distinct xs \<Longrightarrow> x \<notin> set (remove1 x xs)"
  by simp

lemma topSort_sorted:
  assumes "True" (*"partial_order_on (set xs) R" *)
    and "distinct xs"
and po1: "antisym R"
and po2: "trans R"
  shows "sorted_partial (topSort R xs) R"
using assms proof (induct "length xs" arbitrary: xs rule: less_induct)
  case less
  show ?case
  proof (cases xs)
    case Nil
    then show ?thesis
      by (simp add: sorted_partial_def)
  next
    case (Cons y ys)
    hence [simp]: "xs = y # ys" .

    have "distinct ys"
      using less.prems(2) by auto

    show ?thesis
      apply (subst `xs = y # ys`)
      apply (subst topSort.simps)
      apply (auto simp add: sorted_partial_def Let_def nth_Cons' topSort_length length_remove1 simp del: topSort.simps)
      using `distinct xs` apply auto[1]
      using `distinct xs` apply auto[1]
           apply (frule findMinimal_min3)
      apply (smt Suc_less_eq Suc_pred diff_Suc_1 length_Cons length_pos_if_in_set length_remove1 n_not_Suc_n nth_inset remove1.simps(2) remove1_commute remove1_idem topSort_length topSort_set)
      apply simp
      using po1 apply simp
      using po2 apply simp
           apply (drule nth_inset)
            apply (simp add: topSort_length length_remove1 del: topSort.simps)
           apply (simp add:  del: topSort.simps)
      using \<open>distinct ys\<close> apply auto[1]
      apply (smt One_nat_def Suc_less_SucD Suc_pred distinct.simps(2) distinct_remove1 in_set_remove1 length_Cons length_pos_if_in_set length_remove1 less.hyps less.prems(2) lessI less_trans local.Cons po1 po2 sorted_partial_def topSort_length)
      apply (metis Suc_less_eq Suc_pred findMinimal_min1 insert_iff list.discI list.set(2) nth_inset po1 po2 topSort_length topSort_set)
      apply (metis Suc_less_SucD Suc_pred \<open>distinct ys\<close> length_Cons less.hyps lessI less_trans local.Cons po1 po2 sorted_partial_def topSort_length)
      apply (meson findMinimalIn list.simps(3) set_ConsD)
      by (meson findMinimalIn list.simps(3) set_ConsD)
  qed
qed

lemma valid_event_sequence_topSort:
  assumes "finite S"
and po1: "antisym hb"
and po2: "trans hb"
shows "valid_event_sequence (topSort hb (sorted_list_of_set S)) S hb"
proof (auto simp add: valid_event_sequence_def `finite S`)
  show "distinct (topSort hb (sorted_list_of_set S))"
    by (simp add: card_distinct distinct_card distinct_sorted_list_of_set topSort_length)

  show "sorted_partial (topSort hb (sorted_list_of_set S)) hb"
    by (simp add: distinct_sorted_list_of_set po1 po2 topSort_sorted)
qed

end


section "Proof Terms and proof checker"

theory ProofTerm
  imports Term Logic Term_Subst SortConstants EqualityProof
begin

(* Move *)
type_synonym tyinst = "(variable \<times> sort) \<times> typ"
type_synonym tinst = "(variable \<times> typ) \<times> term"

datatype proofterm = PAxm "term" "tyinst list"
  | PBound nat
  | Abst "typ" proofterm
  | AbsP "term" proofterm
  | Appt proofterm "term"
  | AppP proofterm proofterm
  | OfClass "typ" "class"
  | Hyp "term"

(* For debbuging, move to code gen or seperate theory? *)
fun depth :: "proofterm \<Rightarrow> nat" where
  "depth (Abst _ P) = Suc (depth P)"
| "depth (AbsP _ P) = Suc (depth P)"
| "depth (Appt P _) = Suc (depth P)"
| "depth (AppP P1 P2) = Suc (max (depth P1) (depth P2))"
| "depth _ = 1"
fun size :: "proofterm \<Rightarrow> nat" where
  "size (Abst _ P) = Suc (size P)"
| "size (AbsP _ P) = Suc (size P)"
| "size (Appt P _) = Suc (size P)"
| "size (AppP P1 P2) = Suc (size P1 + size P2)"
| "size _ = 1"

lemma "depth P > 0"
  by (induction P) auto
lemma "size P > 0"
  by (induction P) auto
lemma "size P \<ge> depth P"
  by (induction P) auto

fun partial_nth :: "'a list \<Rightarrow> nat \<Rightarrow> 'a option" where
  "partial_nth [] _ = None"
| "partial_nth (x#xs) 0 = Some x"
| "partial_nth (x#xs) (Suc n) = partial_nth xs n"

definition [simp]: "partial_nth' xs n \<equiv> if n < length xs then Some (nth xs n) else None"

lemma "partial_nth xs n \<equiv> partial_nth' xs n"
  by (induction rule: partial_nth.induct) auto

lemma partial_nth_Some_imp_elem: "partial_nth l n = Some x \<Longrightarrow> x\<in>set l"
  by (induction rule: partial_nth.induct) auto

text\<open>The core of the proof checker\<close>

fun replay' :: "theory \<Rightarrow> (variable \<times> typ) list \<Rightarrow> variable set
  \<Rightarrow> term list \<Rightarrow> proofterm \<Rightarrow> term option" where
  "replay' thy _ _ Hs (PAxm t Tis) = (if inst_ok thy Tis \<and> term_ok thy t
    then if t \<in> axioms thy
      then Some (forall_intro_vars (subst_typ' Tis t) [])
    else None else None)"
| "replay' thy _ _ Hs (PBound n) = partial_nth Hs n"
| "replay' thy vs ns Hs (Abst T p) = (if typ_ok thy T
    then (let (s',ns') = variant_variable (Free STR ''default'') ns in
      map_option (mk_all s' T) (replay' thy ((s', T) # vs) ns' Hs p))
    else None)"
| "replay' thy vs ns Hs (Appt p t) =
    (let rep = replay' thy vs ns Hs p in
    let t' = subst_bvs (map (\<lambda>(x,y) . Fv x y) vs) t in
      case (rep, typ_of t') of
        (Some (Ct s (Ty fun1 [Ty fun2 [\<tau>, Ty propT1 Nil], Ty propT2 Nil]) $ b), Some \<tau>') \<Rightarrow>
          if s = STR ''Pure.all'' \<and> fun1 = STR ''fun'' \<and> fun2 = STR ''fun''
            \<and> propT1 = STR ''prop'' \<and> propT2 = STR ''prop''
             \<and> \<tau>=\<tau>' \<and> term_ok thy t'
            then Some (b \<bullet> t') else None
      | _ \<Rightarrow> None)"
| "replay' thy vs ns Hs (AbsP t p) =
    (let t' = subst_bvs (map (\<lambda>(x,y) . Fv x y) vs) t in
    let rep = replay' thy vs ns (t'#Hs) p in
      (if typ_of t' = Some propT \<and> term_ok thy t' then map_option (mk_imp t') rep else None))"
| "replay' thy vs ns Hs (AppP p1 p2) =
    (let rep1 = Option.bind (replay' thy vs ns Hs p1) beta_eta_norm in
    let rep2 = Option.bind (replay' thy vs ns Hs p2) beta_eta_norm in
      (case (rep1, rep2) of (
        Some (Ct imp (Ty fn1 [Ty prp1 [], Ty fn2 [Ty prp2 [], Ty prp3 []]]) $ A $ B),
        Some A') \<Rightarrow>
          if imp = STR ''Pure.imp'' \<and> fn1 = STR ''fun'' \<and> fn2 = STR ''fun''
            \<and> prp1 = STR ''prop'' \<and> prp2 = STR ''prop'' \<and> prp3 = STR ''prop'' \<and> A=A'
          then Some B else None
        | _ \<Rightarrow> None))"
| "replay' thy vs ns Hs (OfClass ty c) = (if has_sort (osig (sig thy)) ty {c}
    \<and> typ_ok thy ty
    then (case const_type (sig thy) (const_of_class c) of
      Some (Ty fun [Ty it [ity], Ty prop []]) \<Rightarrow>
        if ity = tvariable STR '''a'' \<and> fun = STR ''fun'' \<and> prop = STR ''prop'' \<and> it = STR ''itself''
          then Some (mk_of_class ty c) else None | _ \<Rightarrow> None) else None)"
| "replay' thy vs ns Hs (Hyp t) = (if t\<in>set Hs then Some t else None)"

lemma fv_subst_bv1:
  "fv (subst_bv1 t lev u) = fv t \<union> (if loose_bvar1 t lev then fv u else {})"
  by (induction t lev u rule: subst_bv1.induct) (auto simp add: incr_boundvars_def)

(* Needs precondition, doable but diverges from previous checker*)
corollary fv_subst_bvs_upper_bound:
  assumes "is_closed t"
  shows "fv (subst_bvs us t) \<subseteq> fv t \<union> (\<Union>x\<in>set us . (fv x))"
  unfolding subst_bvs_def
  using assms by (simp add: is_open_def no_loose_bvar_imp_no_subst_bvs1)

lemma fv_subst_bvs1_upper_bound:
  "fv (subst_bvs1 t lev us) \<subseteq> fv t \<union> (\<Union>x\<in>set us . (fv x))"
proof (induction t lev us rule: subst_bvs1.induct)
  case (1 n lev args)
  then show ?case
  proof (induction args arbitrary: n lev)
    case Nil
    then show ?case
      by simp
  next
    case (Cons a args)
    then show ?case
      by simp (metis SUP_upper le_supI1 le_supI2 length_Suc_conv nth_mem set_ConsD set_eq_subset)
  qed
qed (auto simp add: incr_boundvars_def)

lemma typ_of_axiom: "wf_theory thy \<Longrightarrow> t \<in> axioms thy \<Longrightarrow> typ_of t = Some propT"
  by (cases thy rule: theory_full_exhaust) simp

fun fv_Proof :: "proofterm \<Rightarrow> (variable \<times> typ) set" where
  "fv_Proof (PAxm t _) = fv t"
| "fv_Proof (PBound _) = empty"
| "fv_Proof (Abst _ p) = fv_Proof p"
| "fv_Proof (AbsP t p) = fv t \<union> fv_Proof p"
| "fv_Proof (Appt p t) = fv_Proof p \<union> fv t"
| "fv_Proof (AppP p1 p2) = fv_Proof p1 \<union> fv_Proof p2"
| "fv_Proof (OfClass _ _) = empty"
| "fv_Proof (Hyp t) = fv t"

lemma typ_ok_Tv[simp]: "typ_ok thy (Tv idn S) = wf_sort (subclass (osig (sig thy))) S"
  by simp

lemma typ_ok_contained_tvars_typ_ok: "typ_ok thy ty \<Longrightarrow> (idn, S) \<in> tvsT ty \<Longrightarrow> typ_ok thy (Tv idn S)"
  by (induction ty) (use split_list typ_ok_Ty in \<open>all \<open>fastforce split: option.splits\<close>\<close>)

lemma typ_ok_sig_contained_tvars_typ_ok_sig:
  "typ_ok_sig \<Sigma> ty \<Longrightarrow> (idn, S) \<in> tvsT ty \<Longrightarrow> typ_ok_sig \<Sigma> (Tv idn S)"
  by (induction ty) (use split_list typ_ok_sig_Ty in \<open>all \<open>fastforce split: option.splits\<close>\<close>)

lemma term_ok'_contained_tvars_typ_ok_sig:
  "term_ok' \<Sigma> t \<Longrightarrow> (idn, S) \<in> tvs t \<Longrightarrow> typ_ok_sig \<Sigma> (Tv idn S)"

proof (induction t)
  case (Ct n T)
  hence "typ_ok_sig \<Sigma> T"
    by (auto split: option.splits)
  then show ?case
    using typ_ok_sig_contained_tvars_typ_ok_sig Ct by auto
next
  case (Fv idn T)
  hence "typ_ok_sig \<Sigma> T"
    by (auto split: option.splits)
  then show ?case
    using typ_ok_sig_contained_tvars_typ_ok_sig Fv by auto
next
  case (Bv n)
  then show ?case by auto
next
  case (Abs T t)
  hence "typ_ok_sig \<Sigma> T"
    by (auto split: option.splits)
  then show ?case
    using typ_ok_sig_contained_tvars_typ_ok_sig Abs by fastforce
next
  case (App t1 t2)
  then show ?case
    by auto
qed

lemma term_ok_contained_tvars_typ_ok:
  "term_ok thy t \<Longrightarrow> (idn, S) \<in> tvs t \<Longrightarrow> typ_ok thy (Tv idn S)"
  using wt_term_def typ_ok_def term_ok'_contained_tvars_typ_ok_sig term_ok_def by blast

lemma typ_ok_subst_typ:
  "typ_ok thy T \<Longrightarrow> \<forall>(_, ty) \<in> set insts . typ_ok thy ty \<Longrightarrow> typ_ok thy (subst_typ insts T)"
proof (induction insts T rule: subst_typ.induct)
  case (1 insts n Ts)
  have "typ_ok thy x" if "x\<in>set Ts" for x
    by (metis (full_types) "1.prems"(1) in_set_conv_decomp_first list_all_append list_all_simps(1)
      that typ_ok_Ty)
  hence "typ_ok thy (subst_typ insts x)" if "x\<in>set Ts" for x
    using that 1 by simp
  then show ?case
    using "1.prems"(1) by (auto simp add: list_all_iff split: option.splits)
next
  case (2 insts idn S)
  then show ?case
  proof(cases "(idn, S) \<in> set (map fst insts)")
    case True
    obtain ty where ty: "lookup (\<lambda>k. k=(idn,S)) insts = Some ty"
      by (metis (full_types) True lookup_None_iff not_Some_eq)
    hence "subst_typ insts (Tv idn S) = ty"
      by simp
    then show ?thesis
      using "2.prems"(2) ty case_prodD lookup_present_eq_key' by fastforce
  next
    case False
    hence "subst_typ insts (Tv idn S) = Tv idn S"
      by (metis (mono_tags, lifting) lookup_None_iff subst_typ.simps(2) the_default.simps(1))
    then show ?thesis
      using "2.prems"(1) by simp
  qed
qed

lemma typ_ok_sig_subst_typ:
  "typ_ok_sig \<Sigma> T \<Longrightarrow> \<forall>(_, ty) \<in> set insts . typ_ok_sig \<Sigma> ty \<Longrightarrow> typ_ok_sig \<Sigma> (subst_typ insts T)"
proof (induction insts T rule: subst_typ.induct)
  case (1 insts n Ts)
  have "typ_ok_sig \<Sigma> x" if "x\<in>set Ts" for x
    using "1.prems"(1) split_list that typ_ok_sig_Ty by fastforce
  hence "typ_ok_sig \<Sigma> (subst_typ insts x)" if "x\<in>set Ts" for x
    using that 1 by simp
  then show ?case
    using "1.prems"(1) by (auto simp add: list_all_iff split: option.splits)
next
  case (2 insts idn S)
  then show ?case
  proof(cases "(idn, S) \<in> set (map fst insts)")
    case True
    obtain ty where ty: "lookup (\<lambda>k. k=(idn,S)) insts = Some ty"
      by (metis (full_types) True lookup_None_iff not_Some_eq)
    hence "subst_typ insts (Tv idn S) = ty"
      by simp
    then show ?thesis
      using "2.prems"(2) ty case_prodD lookup_present_eq_key' by fastforce
  next
    case False
    hence "subst_typ insts (Tv idn S) = Tv idn S"
      by (metis (mono_tags, lifting) lookup_None_iff subst_typ.simps(2) the_default.simps(1))
    then show ?thesis
      using "2.prems"(1) by simp
  qed
qed

lemma typ_ok_sig_imp_sortsT_ok_sig: "typ_ok_sig \<Sigma> T \<Longrightarrow> S \<in> SortsT T \<Longrightarrow> wf_sort (subclass (osig \<Sigma>)) S"
  by (induction T) (use split_list in \<open>all \<open>fastforce simp add: wf_sort_def split: option.splits\<close>\<close>)

lemma term_ok'_imp_Sorts_ok_sig: "term_ok' \<Sigma> t \<Longrightarrow> S \<in> Sorts t \<Longrightarrow> wf_sort (subclass (osig \<Sigma>)) S"
  by (induction t) (use typ_ok_sig_imp_sortsT_ok_sig in \<open>(fastforce split: option.splits)+\<close>)

lemma replay'_sound_pre:
  assumes thy: "wf_theory thy"
  (* Assumptions *)
  assumes HS_invs:
    "\<And>x. x\<in>set Hs \<Longrightarrow> term_ok thy x"
    "\<And>x. x\<in>set Hs \<Longrightarrow> typ_of x = Some propT"
  (* Names used *)
  assumes ns_invs:
    "finite ns"
    "fst ` FV (set Hs) \<subseteq> ns"
    "fst ` fv_Proof P \<subseteq> ns"
  (* Fviables used *)
  assumes vs_invs:
    "fst ` set vs \<subseteq> ns"
  (* Checked proof can be replay'ed using proves*)
  assumes "replay' thy vs ns Hs P = Some res"
  shows "thy, (set Hs) \<turnstile> res"
using assms proof(induction thy vs ns Hs P arbitrary: res rule: replay'.induct)
  case (1 thy uu uv Hs t Tis)
  hence
    ax: "t\<in>axioms thy"
    and insts: "inst_ok thy Tis" and t: "term_ok thy t"
    and res: "forall_intro_vars (subst_typ' Tis t) [] = res"
    by (auto split: if_splits)
  hence 1: "thy, {} \<turnstile> res"
    using res "1.prems"(1) proved_terms_well_formed_pre
    using axiom forall_intro_vars inst_ok_imp_wf_inst tsubst_simulates_subst_typ'
    by (metis (no_types, lifting) empty_set)
  show ?case
    using weaken_proves_set[of "set Hs", OF _ 1]
    using "1.prems"(2) "1.prems"(3) by auto
next
  case (2 thy ux uy Hs n)
  hence "res \<in> set Hs" using partial_nth_Some_imp_elem by simp
  then show ?case using proves.assume 2 by (simp add: wt_term_def)
next
  case (3 thy vs ns Hs T p)

  obtain s' ns' where names: "(s',ns') = variant_variable (Free STR ''default'') ns"
    by simp
  from this 3 obtain bres where bres: "replay' thy ((s', T) # vs) ns' Hs p = Some bres"
    by (auto split: if_splits prod.splits)
  have "ns' = insert s' ns" using variant_variable_adds names
    by (metis fst_conv snd_conv)
  have "s' \<notin> ns" using "3.prems" variant_variable_fresh names
    by (metis fst_conv)
  hence "s' \<notin> fst ` FV (set Hs)" using "3.prems" by blast
  hence free: "(s', T) \<notin> FV (set Hs)" by force

  have typ_ok: "wf_type (sig thy) T"
      using names "3.prems" by (auto split: if_splits)
  have I:"thy, set Hs \<turnstile> bres"
    apply (rule "3.IH"[OF _ names])
    using names "3.prems" apply (solves \<open>simp split: if_splits\<close>)+
    using names "3.prems" \<open>ns' = insert s' ns\<close> apply fastforce
    using "3.prems"(7) \<open>ns' = insert s' ns\<close> apply auto[1]
    using "3.prems"(8) \<open>ns' = insert s' ns\<close> apply auto[1]
    using "3.prems"(6) apply fastforce
    using "3.prems"(7) \<open>ns' = insert s' ns\<close> apply auto[1]
    using "3.prems"(8) \<open>ns' = insert s' ns\<close> apply auto[1]
    using bres by fastforce
  have res: "res = mk_all s' T bres" using names bres 3 by (auto split: if_splits prod.splits)
  show ?case using proves.forall_intro[OF \<open>wf_theory thy\<close> I free typ_ok] res by simp
next
  case (4 thy vs ns Hs p t)
  from \<open>replay' thy vs ns Hs (Appt p t) = Some res\<close> obtain rep t' b s fun1 fun2 propT1 propT2 \<tau> \<tau>' where
    conds: "replay' thy vs ns Hs p = Some rep"
    "t' = subst_bvs (map (\<lambda>(x,y) . Fv x y) vs) t"
    "typ_of t' = Some \<tau>'"
    "\<tau> = \<tau>'"
    "term_ok thy t'"
    "s= STR ''Pure.all'' \<and> fun1 = STR ''fun'' \<and> fun2 = STR ''fun'' \<and> propT1 = STR ''prop'' \<and> propT2 = STR ''prop''"
    "rep = Ct s (Ty fun1 [Ty fun2 [\<tau>, Ty propT1 Nil], Ty propT2 Nil]) $ b"
    and res: "res = (b \<bullet> t')"
    (* Takes forever, split up  *)
    by (auto split: term.splits typ.splits list.splits if_splits option.splits simp add: Let_def)

  have ctxt: "finite (set Hs)" "\<forall>A \<in> set Hs . term_ok thy A" "\<forall>A \<in> set Hs . typ_of A = Some propT"
    using 4 by auto

  show ?case
    using conds "4.prems" ctxt
    by (auto simp add: res wt_term_def simp del: FV_def
        intro!: forall_elim'[OF "4.prems"(1) _ _ _ ctxt] "4.IH")
next
  case (5 thy vs ns Hs t p)
  from this obtain t' rep where
    conds: "subst_bvs (map (\<lambda>(x,y) . Fv x y) vs) t = t'"
    "replay' thy vs ns (t'#Hs) p = Some rep"
    "typ_of t' = Some propT" "term_ok thy t'"
    and res: "res = mk_imp t' rep"
    by (auto split: term.splits typ.splits list.splits if_splits option.splits simp add: Let_def)

    show ?case
    proof (cases "t'\<in> set Hs")
      case True
      hence s: "set Hs = set (t' # Hs)" by auto
      hence s': "set Hs = insert t' (set Hs -{t'})" by auto

      have "thy,set (t' # Hs) \<turnstile> rep"
        apply (rule "5.IH")
        using conds(4) "5.prems" True by (auto simp add: conds(1) conds(2)[symmetric] conds(3))
      hence "thy,set Hs - {t'} \<turnstile> t' \<longmapsto> rep"
        using implies_intro "5.prems"(1) "5.prems"(4) conds(3) conds(4) s
        using has_typ_iff_typ_of term_ok'_imp_wf_term term_okD1 by presburger
      then show ?thesis
        apply (subst res)
        apply (subst s')
        apply (rule weaken_proves)
        using conds(3-4) by blast+
  next
    case False
    hence s: "set Hs = insert t' (set Hs) - {t'}" by auto

    have "FV (set (map (\<lambda>(x,y) . Fv x y) vs)) = set vs" by (induction vs) auto
    hence frees_bound: "fv t' \<subseteq> fv t \<union> set vs"
      using fv_subst_bvs1_upper_bound subst_bvs_def by (fastforce simp add: conds(1)[symmetric])

    have pre: "thy,set (t' # Hs) \<turnstile> rep"
      apply (rule "5.IH")
      using "5.prems"(5-8) conds(3-4) frees_bound
      by (auto simp add: "5.prems"(1-4) conds(1) conds(2) image_subset_iff simp del: term_ok_def)

    show ?thesis
      apply (subst res) apply (subst s)
      apply (rule proves.implies_intro; use 5 conds in \<open>(solves \<open>simp add: wt_term_def\<close>)?\<close>)
      using pre by simp
  qed
next
  case (6 thy vs ns Hs p1 p2)
  from \<open>replay' thy vs ns Hs (AppP p1 p2) = Some res\<close> obtain fn1 fn2 prp1 prp2 prp3 A B A' imp
    where
    conds: "Option.bind (replay' thy vs ns Hs p1) beta_eta_norm
      = Some (Ct imp (Ty fn1 [Ty prp1 [], Ty fn2 [Ty prp2 [], Ty prp3 []]]) $ A $ B)"
    "Option.bind (replay' thy vs ns Hs p2) beta_eta_norm = Some A'"
    "imp = STR ''Pure.imp'' \<and> fn1 = STR ''fun'' \<and> fn2 = STR ''fun''
      \<and> prp1 = STR ''prop'' \<and> prp2 = STR ''prop'' \<and> prp3 = STR ''prop'' \<and> A=A'"
    and res: "res = B"
    by (auto split: term.splits typ.splits list.splits if_splits option.splits simp add: Let_def)

  obtain C where C: "Option.bind (replay' thy vs ns Hs p1) beta_eta_norm = Some (C \<longmapsto> res)"
    using conds res by blast
  from this obtain pre pre_C where pre: "replay' thy vs ns Hs p1 = Some pre"
    and pre_C: "replay' thy vs ns Hs p2 = Some pre_C"
    by (meson bind_eq_Some_conv conds(2))

  from pre C have norm_pre: "beta_eta_norm pre = Some (C \<longmapsto> res)" by simp
  from pre_C pre C conds have norm_pre_C: "beta_eta_norm pre_C = Some C" by auto

  have "thy, set Hs \<turnstile> pre_C"
    by (rule "6.IH"(2)) (use "6.prems" conds in \<open>auto simp add: pre pre_C\<close>)
  hence I1: "thy, set Hs \<turnstile> C"
    using beta_eta_norm_preserves_proves norm_pre_C \<open>wf_theory thy\<close>
    using "6.prems"(2) "6.prems"(3) by blast

  have "thy, set Hs \<turnstile> pre"
    by (rule "6.IH"(1)) (use "6.prems" conds in \<open>auto simp add: pre pre_C\<close>)
  hence I2: "thy, set Hs \<turnstile> C \<longmapsto> res"
    using beta_eta_norm_preserves_proves norm_pre \<open>wf_theory thy\<close>
    using "6.prems"(2) "6.prems"(3) by blast

  from I1 I2 have "thy, set Hs \<union> set Hs \<turnstile> res" using proves.implies_elim by blast
  thus ?case by simp
next
  case (7 thy vs ns Hs ty c)
  from this obtain "fun" it ity "prop"  where conds: "has_sort (osig (sig thy)) ty {c}"
    "typ_ok thy ty" "const_type (sig thy) (const_of_class c)
      = Some (Ty fun [Ty it [ity], Ty prop []])" "ity = tvariable STR '''a''"
     "fun = STR ''fun''" "prop = STR ''prop''" "it = STR ''itself''"
    and res: "res = (mk_of_class ty c)"
    by (auto split: term.splits typ.splits list.splits if_splits option.splits)

  from res have "res = mk_of_class ty c" by auto
  moreover have "thy,set Hs \<turnstile> mk_of_class ty c"
    by (rule proves.of_class[where T=ty, OF "7.prems"(1)]) (use conds in auto)

  ultimately show ?case by simp
next
  case (8 thy ux uy Hs n)
  hence "res \<in> set Hs"
    by (metis not_None_eq option.inject replay'.simps(8))
  then show ?case using proves.assume 8 by (simp add: wt_term_def)
qed

lemma finite_fv_Proof: "finite (fv_Proof P)"
  by (induction P) auto

abbreviation "replay'' thy vs ns Hs P \<equiv> Option.bind (replay' thy vs ns Hs P) beta_eta_norm"

lemma replay''_sound:
  assumes "wf_theory thy"
  (* Assumptions *)
  assumes HS_invs:
    "\<And>x. x\<in>set Hs \<Longrightarrow> term_ok thy x"
    "\<And>x. x\<in>set Hs \<Longrightarrow> typ_of x = Some propT"
  (* Names used *)
  assumes ns_invs:
    "finite ns"
    "fst ` FV (set Hs) \<subseteq> ns"
    "fst ` fv_Proof P \<subseteq> ns"
  (* Fviables used *)
  assumes vs_invs:
    "fst ` set vs \<subseteq> ns"
  (* Checked proof can be replayed using proves*)
  assumes "replay'' thy vs ns Hs P = Some res"
  shows "thy, (set Hs) \<turnstile> res"
proof-
  obtain res' where res': "replay' thy vs ns Hs P = Some res'"
    using replay'_sound_pre assms bind_eq_Some_conv by metis
  moreover have "beta_eta_norm res' = Some res"
    using res' assms(8) by auto
  moreover have "thy, set Hs \<turnstile> res'"
    using res' assms replay'_sound_pre  by simp
  ultimately show ?thesis
    using beta_eta_norm_preserves_proves assms(1-3) by blast
qed

lemma
  assumes "wf_theory thy"
  assumes "replay'' thy [] (fst ` fv_Proof P) [] P = Some res"
  shows "thy, set [] \<turnstile> res"
  using assms finite_fv_Proof replay'_sound_pre replay''_sound[where vs="[]"
      and ns="fst ` fv_Proof P" and P=P and Hs="[]"]
  by simp

(* With open hyps, run  *)

fun hyps :: "proofterm \<Rightarrow> term list" where
  "hyps (Abst _ p) = hyps p"
| "hyps (AbsP _ p) = hyps p"
| "hyps (Appt p _) = hyps p"
| "hyps (AppP p1 p2) = List.union (hyps p1) (hyps p2)"
| "hyps (Hyp t) = [t]"
| "hyps _ = []"

lemma replay''_sound_pre_hyps:
  assumes "wf_theory thy"
  (* This can be checked independently before running replay'. Could also check during replay' in Hyp step... *)
  assumes "\<And>x. x \<in> set (hyps P) \<Longrightarrow> term_ok thy x"
  assumes "\<And>x. x \<in> set (hyps P) \<Longrightarrow> typ_of x = Some propT"
  assumes "replay'' thy [] (fst ` (fv_Proof P \<union> FV (set (hyps P)))) (hyps P) P = Some res"
  shows "thy, set (hyps P) \<turnstile> res"
  apply (rule replay''_sound[where vs="[]" and ns="(fst ` (fv_Proof P \<union> FV (set (hyps P))))" and P=P and Hs="hyps P"]
  ; (use assms finite_fv_Proof replay'_sound_pre in \<open>solves simp\<close>)?)
  by blast+

definition [simp]: "replay thy P \<equiv>
  (if \<forall>x\<in>set (hyps P) . term_ok thy x \<and> typ_of x = Some propT then
  replay'' thy [] (fst ` (fv_Proof P \<union> FV (set (hyps P)))) (hyps P) P else None)"

lemma replay_sound_pre_hyps:
  assumes "wf_theory thy"
  assumes "replay thy P = Some res"
  shows "thy, set (hyps P) \<turnstile> res"
  using replay''_sound_pre_hyps assms by (simp split: if_splits)

definition "check_proof thy P res \<equiv> wf_theory thy \<and> replay thy P = Some res"

lemma check_proof_sound:
  shows "check_proof thy P res \<Longrightarrow> thy, set (hyps P) \<turnstile> res"
  using check_proof_def replay_sound_pre_hyps by blast

lemma check_proof_really_sound:
  assumes "check_proof thy P res"
  shows "thy, set (hyps P) \<tturnstile> res"
proof-
  have "wf_theory thy"
    using assms check_proof_def by blast
  moreover have "Some res = replay thy P"
    by (metis assms check_proof_def)
  moreover hence "\<forall>x\<in>set (hyps P) . term_ok thy x \<and> typ_of x = Some propT"
    by (metis not_None_eq replay_def)
  ultimately show ?thesis
    by (meson assms check_proof_sound has_typ_iff_typ_of proved_terms_well_formed(1) proves'_def
        term_ok_def wt_term_def)
qed

end


(*  Title:       The Graceful Basic Knuth-Bendix Order for Lambda-Free Higher-Order Terms
    Author:      Jasmin Blanchette <jasmin.blanchette at inria.fr>, 2016
    Maintainer:  Jasmin Blanchette <jasmin.blanchette at inria.fr>
*)

section \<open>The Graceful Basic Knuth--Bendix Order for Lambda-Free Higher-Order Terms\<close>

theory Lambda_Free_KBO_Basic
imports Lambda_Free_KBO_Std
begin

text \<open>
This theory defines the basic version of the graceful Knuth--Bendix order (KBO) for
\<open>\<lambda>\<close>-free higher-order terms. Basic means that all symbols must have a
positive weight. The results are lifted from the standard KBO.
\<close>

locale kbo_basic = kbo_basic_basis _ _ _ ground_heads_var
  for ground_heads_var :: "'v \<Rightarrow> 's set"
begin

sublocale kbo_std: kbo_std _ _ _ 0 _ "\<lambda>_. \<infinity>" "\<lambda>_. \<infinity>"
  by (simp add: \<epsilon>_gt_0 kbo_std_def kbo_std_basis_axioms)

fun wt :: "('s, 'v) tm \<Rightarrow> nat" where
  "wt (Hd \<zeta>) = (LEAST w. \<exists>f \<in> ground_heads \<zeta>. w = wt_sym f)"
| "wt (App s t) = wt s + wt t"

inductive gt :: "('s, 'v) tm \<Rightarrow> ('s, 'v) tm \<Rightarrow> bool" (infix ">\<^sub>t" 50) where
  gt_wt: "vars_mset t \<supseteq># vars_mset s \<Longrightarrow> wt t > wt s \<Longrightarrow> t >\<^sub>t s"
| gt_diff: "vars_mset t \<supseteq># vars_mset s \<Longrightarrow> wt t = wt s \<Longrightarrow> head t >\<^sub>h\<^sub>d head s \<Longrightarrow> t >\<^sub>t s"
| gt_same: "vars_mset t \<supseteq># vars_mset s \<Longrightarrow> wt t = wt s \<Longrightarrow> head t = head s \<Longrightarrow>
    (\<forall>f \<in> ground_heads (head s). extf f (>\<^sub>t) (args t) (args s)) \<Longrightarrow> t >\<^sub>t s"

lemma arity_hd_eq_inf[simp]: "arity_hd \<zeta> = \<infinity>"
  by (cases \<zeta>) auto

lemma waryI[intro, simp]: "wary s"
  by (simp add: wary_inf_ary)

lemma basic_wt_eq_wt: "wt s = kbo_std.wt s"
  by (induct s) auto

lemma
  basic_gt_and_gt_le_gt: "(\<lambda>t s. t >\<^sub>t s \<and> local.kbo_std.gt t s) \<le> kbo_std.gt" and
  gt_and_basic_gt_le_basic_gt: "(\<lambda>t s. local.kbo_std.gt t s \<and> t >\<^sub>t s) \<le> (>\<^sub>t)"
  by auto

lemma basic_gt_iff_gt: "t >\<^sub>t s \<longleftrightarrow> kbo_std.gt t s"
proof
  assume "t >\<^sub>t s"
  thus "kbo_std.gt t s"
  proof induct
    case gt_wt
    thus ?case
      by (auto intro: kbo_std.gt_wt simp: basic_wt_eq_wt[symmetric])
  next
    case gt_diff
    thus ?case
      by (auto intro: kbo_std.gt_diff simp: basic_wt_eq_wt[symmetric])
  next
    case gt_same
    thus ?case
      using extf_mono[OF basic_gt_and_gt_le_gt]
      by (force simp: basic_wt_eq_wt[symmetric] intro!: kbo_std.gt_same)
  qed
next
  assume "kbo_std.gt t s"
  thus "t >\<^sub>t s"
  proof induct
    case gt_wt_t_s: gt_wt
    thus ?case
      by (auto intro: gt_wt simp: basic_wt_eq_wt[symmetric])
  next
    case gt_unary_t_s: (gt_unary t s)
    have False
      using gt_unary_t_s(4) by (metis less_nat_zero_code wt_sym_gt_0)
    thus ?case
      by satx
  next
    case gt_diff_t_s: gt_diff
    thus ?case
      by (auto intro: gt_diff simp: basic_wt_eq_wt[symmetric])
  next
    case gt_same_t_s: gt_same
    thus ?case
      using extf_mono[OF gt_and_basic_gt_le_basic_gt]
      by (force intro!: gt_same simp: basic_wt_eq_wt[symmetric])
  qed
qed

theorem gt_irrefl: "\<not> s >\<^sub>t s"
  unfolding basic_gt_iff_gt by (rule kbo_std.gt_irrefl[simplified])

theorem gt_trans: "u >\<^sub>t t \<Longrightarrow> t >\<^sub>t s \<Longrightarrow> u >\<^sub>t s"
  unfolding basic_gt_iff_gt by (rule kbo_std.gt_trans[simplified])

theorem gt_proper_sub: "proper_sub s t \<Longrightarrow> t >\<^sub>t s"
  unfolding basic_gt_iff_gt by (rule kbo_std.gt_proper_sub[simplified])

theorem gt_compat_fun: "t' >\<^sub>t t \<Longrightarrow> App s t' >\<^sub>t App s t"
  unfolding basic_gt_iff_gt by (rule kbo_std.gt_compat_fun[simplified])

theorem gt_compat_arg: "s' >\<^sub>t s \<Longrightarrow> App s' t >\<^sub>t App s t"
  unfolding basic_gt_iff_gt by (rule kbo_std.gt_compat_arg[simplified])

lemma wt_subst: "wary_subst \<rho> \<Longrightarrow> wt (subst \<rho> s) = wt s + kbo_std.extra_wt \<rho> s"
  unfolding basic_gt_iff_gt basic_wt_eq_wt by (rule kbo_std.wt_subst[simplified])

theorem gt_subst: "wary_subst \<rho> \<Longrightarrow> t >\<^sub>t s \<Longrightarrow> subst \<rho> t >\<^sub>t subst \<rho> s"
  unfolding basic_gt_iff_gt by (rule kbo_std.gt_subst[simplified])

theorem gt_wf: "wfP (\<lambda>s t. t >\<^sub>t s)"
  unfolding basic_gt_iff_gt[abs_def] by (rule kbo_std.gt_wf[simplified])

end

end


(*
  Authors: Gerwin Klein and Thomas Sewell, NICTA

  Examples demonstrating and testing various word operations.
*)

section "Examples of word operations"

theory WordExamples
imports "../Word" "../WordBitwise"
begin

type_synonym word32 = "32 word"
type_synonym word8 = "8 word"
type_synonym byte = word8

text "modulus"

lemma "(27 :: 4 word) = -5" by simp

lemma "(27 :: 4 word) = 11" by simp

lemma "27 \<noteq> (11 :: 6 word)" by simp

text "signed"

lemma "(127 :: 6 word) = -1" by simp

text "number ring simps"

lemma
  "27 + 11 = (38::'a::len word)"
  "27 + 11 = (6::5 word)"
  "7 * 3 = (21::'a::len word)"
  "11 - 27 = (-16::'a::len word)"
  "- (- 11) = (11::'a::len word)"
  "-40 + 1 = (-39::'a::len word)"
  by simp_all

lemma "word_pred 2 = 1" by simp

lemma "word_succ (- 3) = -2" by simp

lemma "23 < (27::8 word)" by simp
lemma "23 \<le> (27::8 word)" by simp
lemma "\<not> 23 < (27::2 word)" by simp
lemma "0 < (4::3 word)" by simp
lemma "1 < (4::3 word)" by simp
lemma "0 < (1::3 word)" by simp

text "ring operations"

lemma "a + 2 * b + c - b = (b + c) + (a :: 32 word)" by simp

text "casting"

lemma "uint (234567 :: 10 word) = 71" by simp
lemma "uint (-234567 :: 10 word) = 953" by simp
lemma "sint (234567 :: 10 word) = 71" by simp
lemma "sint (-234567 :: 10 word) = -71" by simp
lemma "uint (1 :: 10 word) = 1" by simp

lemma "unat (-234567 :: 10 word) = 953" by simp
lemma "unat (1 :: 10 word) = 1" by simp

lemma "ucast (0b1010 :: 4 word) = (0b10 :: 2 word)" by simp
lemma "ucast (0b1010 :: 4 word) = (0b1010 :: 10 word)" by simp
lemma "scast (0b1010 :: 4 word) = (0b111010 :: 6 word)" by simp
lemma "ucast (1 :: 4 word) = (1 :: 2 word)" by simp

text "reducing goals to nat or int and arith:"
lemma "i < x ==> i < (i + 1 :: 'a :: len word)" by unat_arith
lemma "i < x ==> i < (i + 1 :: 'a :: len word)" by uint_arith

text "bool lists"

lemma "of_bl [True, False, True, True] = (0b1011::'a::len word)" by simp

lemma "to_bl (0b110::4 word) = [False, True, True, False]" by simp

text "this is not exactly fast, but bearable"
lemma "of_bl (replicate 32 True) = (0xFFFFFFFF::32 word)" by simp

text "this works only for replicate n True"
lemma "of_bl (replicate 32 True) = (0xFFFFFFFF::32 word)"
  by (unfold mask_bl [symmetric]) (simp add: mask_def)

text "bit operations"

lemma "0b110 AND 0b101 = (0b100 :: 32 word)" by simp
lemma "0b110 OR 0b011 = (0b111 :: 8 word)" by simp
lemma "0xF0 XOR 0xFF = (0x0F :: byte)" by simp
lemma "NOT (0xF0 :: 16 word) = 0xFF0F" by simp
lemma "0 AND 5 = (0 :: byte)" by simp
lemma "1 AND 1 = (1 :: byte)" by simp
lemma "1 AND 0 = (0 :: byte)" by simp
lemma "1 AND 5 = (1 :: byte)" by simp
lemma "1 OR 6 = (7 :: byte)" by simp
lemma "1 OR 1 = (1 :: byte)" by simp
lemma "1 XOR 7 = (6 :: byte)" by simp
lemma "1 XOR 1 = (0 :: byte)" by simp
lemma "NOT 1 = (254 :: byte)" by simp
lemma "NOT 0 = (255 :: byte)" apply simp oops
(* FIXME: "NOT 0" rewrites to "max_word" instead of "-1" *)

lemma "(-1 :: 32 word) = 0xFFFFFFFF" by simp

lemma "(0b0010 :: 4 word) !! 1" by simp
lemma "\<not> (0b0010 :: 4 word) !! 0" by simp
lemma "\<not> (0b1000 :: 3 word) !! 4" by simp
lemma "\<not> (1 :: 3 word) !! 2" by simp

lemma "(0b11000 :: 10 word) !! n = (n = 4 \<or> n = 3)"
  by (auto simp add: bin_nth_Bit0 bin_nth_Bit1)

lemma "set_bit 55 7 True = (183::'a::len0 word)" by simp
lemma "set_bit 0b0010 7 True = (0b10000010::'a::len0 word)" by simp
lemma "set_bit 0b0010 1 False = (0::'a::len0 word)" by simp
lemma "set_bit 1 3 True = (0b1001::'a::len0 word)" by simp
lemma "set_bit 1 0 False = (0::'a::len0 word)" by simp
lemma "set_bit 0 3 True = (0b1000::'a::len0 word)" by simp
lemma "set_bit 0 3 False = (0::'a::len0 word)" by simp

lemma "lsb (0b0101::'a::len word)" by simp
lemma "\<not> lsb (0b1000::'a::len word)" by simp
lemma "lsb (1::'a::len word)" by simp
lemma "\<not> lsb (0::'a::len word)" by simp

lemma "\<not> msb (0b0101::4 word)" by simp
lemma   "msb (0b1000::4 word)" by simp
lemma "\<not> msb (1::4 word)" by simp
lemma "\<not> msb (0::4 word)" by simp

lemma "word_cat (27::4 word) (27::8 word) = (2843::'a::len word)" by simp
lemma "word_cat (0b0011::4 word) (0b1111::6word) = (0b0011001111 :: 10 word)"
  by simp

lemma "0b1011 << 2 = (0b101100::'a::len0 word)" by simp
lemma "0b1011 >> 2 = (0b10::8 word)" by simp
lemma "0b1011 >>> 2 = (0b10::8 word)" by simp
lemma "1 << 2 = (0b100::'a::len0 word)" apply simp? oops

lemma "slice 3 (0b101111::6 word) = (0b101::3 word)" by simp
lemma "slice 3 (1::6 word) = (0::3 word)" apply simp? oops

lemma "word_rotr 2 0b0110 = (0b1001::4 word)" by simp
lemma "word_rotl 1 0b1110 = (0b1101::4 word)" by simp
lemma "word_roti 2 0b1110 = (0b1011::4 word)" by simp
lemma "word_roti (- 2) 0b0110 = (0b1001::4 word)" by simp
lemma "word_rotr 2 0 = (0::4 word)" by simp
lemma "word_rotr 2 1 = (0b0100::4 word)" apply simp? oops
lemma "word_rotl 2 1 = (0b0100::4 word)" apply simp? oops
lemma "word_roti (- 2) 1 = (0b0100::4 word)" apply simp? oops

lemma "(x AND 0xff00) OR (x AND 0x00ff) = (x::16 word)"
proof -
  have "(x AND 0xff00) OR (x AND 0x00ff) = x AND (0xff00 OR 0x00ff)"
    by (simp only: word_ao_dist2)
  also have "0xff00 OR 0x00ff = (-1::16 word)"
    by simp
  also have "x AND -1 = x"
    by simp
  finally show ?thesis .
qed

text "alternative proof using bitwise expansion"

lemma "(x AND 0xff00) OR (x AND 0x00ff) = (x::16 word)"
  by word_bitwise

text "more proofs using bitwise expansion"

lemma "((x :: 10 word) AND NOT 3) >> 4 << 2 = ((x >> 2) AND NOT 3)"
  by word_bitwise

lemma "(((x :: 12 word) AND -8) >> 3) AND 7 = (x AND 56) >> 3"
  by word_bitwise

text "some problems require further reasoning after bit expansion"

lemma "x \<le> (42 :: 8 word) \<Longrightarrow> x \<le> 89"
  apply word_bitwise
  apply blast
  done

lemma "((x :: word32) AND 1023) = 0 \<Longrightarrow> x \<le> -1024"
  apply word_bitwise
  apply clarsimp
  done

text "operations like shifts by non-numerals will expose some internal list
 representations but may still be easy to solve"

lemma shiftr_overflow:
  "32 \<le> a \<Longrightarrow> (b::word32) >> a = 0"
  apply (word_bitwise)
  apply simp
  done

end


(*  Author:     Tobias Nipkow, 2007  *)

header{* Logic *}

theory Logic
imports Main "~~/src/HOL/Library/FuncSet"
begin

text{* \noindent
We start with a generic formalization of quantified logical formulae
using de Bruijn notation. The syntax is parametric in the type of atoms. *}

declare Let_def[simp]

datatype (atoms: 'a) fm =
  TrueF | FalseF | Atom 'a | And "'a fm" "'a fm" | Or "'a fm" "'a fm" |
  Neg "'a fm" | ExQ "'a fm"

notation map_fm ("map\<^bsub>fm\<^esub>")

abbreviation Imp where "Imp \<phi>\<^sub>1 \<phi>\<^sub>2 \<equiv> Or (Neg \<phi>\<^sub>1) \<phi>\<^sub>2"
abbreviation AllQ where "AllQ \<phi> \<equiv> Neg(ExQ(Neg \<phi>))"

definition neg where
"neg \<phi> = (if \<phi>=TrueF then FalseF else if \<phi>=FalseF then TrueF else Neg \<phi>)"

definition "and" :: "'a fm \<Rightarrow> 'a fm \<Rightarrow> 'a fm" where
"and \<phi>\<^sub>1 \<phi>\<^sub>2 =
 (if \<phi>\<^sub>1=TrueF then \<phi>\<^sub>2 else if \<phi>\<^sub>2=TrueF then \<phi>\<^sub>1 else
  if \<phi>\<^sub>1=FalseF \<or> \<phi>\<^sub>2=FalseF then FalseF else And \<phi>\<^sub>1 \<phi>\<^sub>2)"

definition or :: "'a fm \<Rightarrow> 'a fm \<Rightarrow> 'a fm" where
"or \<phi>\<^sub>1 \<phi>\<^sub>2 =
 (if \<phi>\<^sub>1=FalseF then \<phi>\<^sub>2 else if \<phi>\<^sub>2=FalseF then \<phi>\<^sub>1 else
  if \<phi>\<^sub>1=TrueF \<or> \<phi>\<^sub>2=TrueF then TrueF else Or \<phi>\<^sub>1 \<phi>\<^sub>2)"

definition list_conj :: "'a fm list \<Rightarrow> 'a fm" where
"list_conj fs = foldr and fs TrueF"

definition list_disj :: "'a fm list \<Rightarrow> 'a fm" where
"list_disj fs = foldr or fs FalseF"

abbreviation "Disj is f \<equiv> list_disj (map f is)"

lemmas atoms_map_fm[simp] = fm.set_map

fun amap_fm :: "('a \<Rightarrow> 'b fm) \<Rightarrow> 'a fm \<Rightarrow> 'b fm" ("amap\<^bsub>fm\<^esub>") where
"amap\<^bsub>fm\<^esub> h TrueF = TrueF" |
"amap\<^bsub>fm\<^esub> h FalseF = FalseF" |
"amap\<^bsub>fm\<^esub> h (Atom a) = h a" |
"amap\<^bsub>fm\<^esub> h (And \<phi>\<^sub>1 \<phi>\<^sub>2) = and (amap\<^bsub>fm\<^esub> h \<phi>\<^sub>1) (amap\<^bsub>fm\<^esub> h \<phi>\<^sub>2)" |
"amap\<^bsub>fm\<^esub> h (Or \<phi>\<^sub>1 \<phi>\<^sub>2) = or (amap\<^bsub>fm\<^esub> h \<phi>\<^sub>1) (amap\<^bsub>fm\<^esub> h \<phi>\<^sub>2)" |
"amap\<^bsub>fm\<^esub> h (Neg \<phi>) = neg (amap\<^bsub>fm\<^esub> h \<phi>)"

lemma amap_fm_list_disj:
  "amap\<^bsub>fm\<^esub> h (list_disj fs) = list_disj (map (amap\<^bsub>fm\<^esub> h) fs)"
by(induct fs) (auto simp:list_disj_def or_def)

fun qfree :: "'a fm \<Rightarrow> bool" where
"qfree(ExQ f) = False" |
"qfree(And \<phi>\<^sub>1 \<phi>\<^sub>2) = (qfree \<phi>\<^sub>1 \<and> qfree \<phi>\<^sub>2)" |
"qfree(Or \<phi>\<^sub>1 \<phi>\<^sub>2) = (qfree \<phi>\<^sub>1 \<and> qfree \<phi>\<^sub>2)" |
"qfree(Neg \<phi>) = (qfree \<phi>)" |
"qfree \<phi> = True"

lemma qfree_and[simp]: "\<lbrakk> qfree \<phi>\<^sub>1; qfree \<phi>\<^sub>2 \<rbrakk> \<Longrightarrow> qfree(and \<phi>\<^sub>1 \<phi>\<^sub>2)"
by(simp add:and_def)

lemma qfree_or[simp]: "\<lbrakk> qfree \<phi>\<^sub>1; qfree \<phi>\<^sub>2 \<rbrakk> \<Longrightarrow> qfree(or \<phi>\<^sub>1 \<phi>\<^sub>2)"
by(simp add:or_def)

lemma qfree_neg[simp]: "qfree(neg \<phi>) = qfree \<phi>"
by(simp add:neg_def)

lemma qfree_foldr_Or[simp]:
 "qfree(foldr Or fs \<phi>) = (qfree \<phi> \<and> (\<forall>\<phi> \<in> set fs. qfree \<phi>))"
by (induct fs) auto

lemma qfree_list_conj[simp]:
assumes "\<forall>\<phi> \<in> set fs. qfree \<phi>" shows "qfree(list_conj fs)"
proof -
  { fix fs \<phi>
    have "\<lbrakk> \<forall>\<phi> \<in> set fs. qfree \<phi>; qfree \<phi> \<rbrakk> \<Longrightarrow> qfree(foldr and fs \<phi>)"
      by (induct fs) auto
  } thus ?thesis using assms by (fastforce simp add:list_conj_def)
qed

lemma qfree_list_disj[simp]:
assumes "\<forall>\<phi> \<in> set fs. qfree \<phi>" shows "qfree(list_disj fs)"
proof -
  { fix fs \<phi>
    have "\<lbrakk> \<forall>\<phi> \<in> set fs. qfree \<phi>; qfree \<phi> \<rbrakk> \<Longrightarrow> qfree(foldr or fs \<phi>)"
      by (induct fs) auto
  } thus ?thesis using assms by (fastforce simp add:list_disj_def)
qed

lemma qfree_map_fm: "qfree (map\<^bsub>fm\<^esub> f \<phi>) = qfree \<phi>"
by (induct \<phi>) simp_all

lemma atoms_list_disjE:
  "a : atoms(list_disj fs) \<Longrightarrow> a : (\<Union>\<phi> \<in> set fs. atoms \<phi>)"
apply(induct fs)
 apply (simp add:list_disj_def)
apply (auto simp add:list_disj_def Logic.or_def split:split_if_asm)
done

lemma atoms_list_conjE:
  "a : atoms(list_conj fs) \<Longrightarrow> a : (\<Union>\<phi> \<in> set fs. atoms \<phi>)"
apply(induct fs)
 apply (simp add:list_conj_def)
apply (auto simp add:list_conj_def Logic.and_def split:split_if_asm)
done

fun dnf :: "'a fm \<Rightarrow> 'a list list" where
"dnf TrueF = [[]]" |
"dnf FalseF = []" |
"dnf (Atom \<phi>) = [[\<phi>]]" |
"dnf (And \<phi>\<^sub>1 \<phi>\<^sub>2) = [d1 @ d2. d1 \<leftarrow> dnf \<phi>\<^sub>1, d2 \<leftarrow> dnf \<phi>\<^sub>2]" |
"dnf (Or \<phi>\<^sub>1 \<phi>\<^sub>2) = dnf \<phi>\<^sub>1 @ dnf \<phi>\<^sub>2"

fun nqfree :: "'a fm \<Rightarrow> bool" where
"nqfree(Atom a) = True" |
"nqfree TrueF = True" |
"nqfree FalseF = True" |
"nqfree (And \<phi>\<^sub>1 \<phi>\<^sub>2) = (nqfree \<phi>\<^sub>1 \<and> nqfree \<phi>\<^sub>2)" |
"nqfree (Or \<phi>\<^sub>1 \<phi>\<^sub>2) = (nqfree \<phi>\<^sub>1 \<and> nqfree \<phi>\<^sub>2)" |
"nqfree \<phi> = False"

lemma nqfree_qfree[simp]: "nqfree \<phi> \<Longrightarrow> qfree \<phi>"
by (induct \<phi>) simp_all

lemma nqfree_map_fm: "nqfree (map\<^bsub>fm\<^esub> f \<phi>) = nqfree \<phi>"
by (induct \<phi>) simp_all

fun "interpret" :: "('a \<Rightarrow> 'b list \<Rightarrow> bool) \<Rightarrow> 'a fm \<Rightarrow> 'b list \<Rightarrow> bool" where
"interpret h TrueF xs = True" |
"interpret h FalseF xs = False" |
"interpret h (Atom a) xs = h a xs" |
"interpret h (And \<phi>\<^sub>1 \<phi>\<^sub>2) xs = (interpret h \<phi>\<^sub>1 xs \<and> interpret h \<phi>\<^sub>2 xs)" |
"interpret h (Or \<phi>\<^sub>1 \<phi>\<^sub>2) xs = (interpret h \<phi>\<^sub>1 xs | interpret h \<phi>\<^sub>2 xs)" |
"interpret h (Neg \<phi>) xs = (\<not> interpret h \<phi> xs)" |
"interpret h (ExQ \<phi>) xs = (\<exists>x. interpret h \<phi> (x#xs))"

subsection{*Atoms*}

text{* The locale ATOM of atoms provides a minimal framework for the
generic formulation of theory-independent algorithms, in particular
quantifier elimination. *}

locale ATOM =
fixes aneg :: "'a \<Rightarrow> 'a fm"
fixes anormal :: "'a \<Rightarrow> bool"
assumes nqfree_aneg: "nqfree(aneg a)"
assumes anormal_aneg: "anormal a \<Longrightarrow> \<forall>b\<in>atoms(aneg a). anormal b"

fixes I\<^sub>a :: "'a \<Rightarrow> 'b list \<Rightarrow> bool"
assumes I\<^sub>a_aneg: "interpret I\<^sub>a (aneg a) xs = (\<not> I\<^sub>a a xs)"

fixes depends\<^sub>0 :: "'a \<Rightarrow> bool"
and decr :: "'a \<Rightarrow> 'a"
assumes not_dep_decr: "\<not>depends\<^sub>0 a \<Longrightarrow> I\<^sub>a a (x#xs) = I\<^sub>a (decr a) xs"
assumes anormal_decr: "\<not> depends\<^sub>0 a \<Longrightarrow> anormal a \<Longrightarrow> anormal(decr a)"

begin

fun atoms\<^sub>0 :: "'a fm \<Rightarrow> 'a list" where
"atoms\<^sub>0 TrueF = []" |
"atoms\<^sub>0 FalseF = []" |
"atoms\<^sub>0 (Atom a) = (if depends\<^sub>0 a then [a] else [])" |
"atoms\<^sub>0 (And \<phi>\<^sub>1 \<phi>\<^sub>2) = atoms\<^sub>0 \<phi>\<^sub>1 @ atoms\<^sub>0 \<phi>\<^sub>2" |
"atoms\<^sub>0 (Or \<phi>\<^sub>1 \<phi>\<^sub>2) = atoms\<^sub>0 \<phi>\<^sub>1 @ atoms\<^sub>0 \<phi>\<^sub>2" |
"atoms\<^sub>0 (Neg \<phi>) = atoms\<^sub>0 \<phi>"

abbreviation I where "I \<equiv> interpret I\<^sub>a"

fun nnf :: "'a fm \<Rightarrow> 'a fm" where
"nnf (And \<phi>\<^sub>1 \<phi>\<^sub>2) = And (nnf \<phi>\<^sub>1) (nnf \<phi>\<^sub>2)" |
"nnf (Or \<phi>\<^sub>1 \<phi>\<^sub>2) = Or (nnf \<phi>\<^sub>1) (nnf \<phi>\<^sub>2)" |
"nnf (Neg TrueF) = FalseF" |
"nnf (Neg FalseF) = TrueF" |
"nnf (Neg (Neg \<phi>)) = (nnf \<phi>)" |
"nnf (Neg (And \<phi>\<^sub>1 \<phi>\<^sub>2)) = (Or (nnf (Neg \<phi>\<^sub>1)) (nnf (Neg \<phi>\<^sub>2)))" |
"nnf (Neg (Or \<phi>\<^sub>1 \<phi>\<^sub>2)) = (And (nnf (Neg \<phi>\<^sub>1)) (nnf (Neg \<phi>\<^sub>2)))" |
"nnf (Neg (Atom a)) = aneg a" |
"nnf \<phi> = \<phi>"

lemma nqfree_nnf: "qfree \<phi> \<Longrightarrow> nqfree(nnf \<phi>)"
by(induct \<phi> rule:nnf.induct)
  (simp_all add: nqfree_aneg and_def or_def)

lemma qfree_nnf[simp]: "qfree(nnf \<phi>) = qfree \<phi>"
by (induct \<phi> rule:nnf.induct)(simp_all add: nqfree_aneg)

lemma I_neg[simp]: "I (neg \<phi>) xs = I (Neg \<phi>) xs"
by(simp add:neg_def)

lemma I_and[simp]: "I (and \<phi>\<^sub>1 \<phi>\<^sub>2) xs = I (And \<phi>\<^sub>1 \<phi>\<^sub>2) xs"
by(simp add:and_def)

lemma I_list_conj[simp]:
 "I (list_conj fs) xs = (\<forall>\<phi> \<in> set fs. I \<phi> xs)"
proof -
  { fix fs \<phi>
    have "I (foldr and fs \<phi>) xs = (I \<phi> xs \<and> (\<forall>\<phi> \<in> set fs. I \<phi> xs))"
      by (induct fs) auto
  } thus ?thesis by(simp add:list_conj_def)
qed

lemma I_or[simp]: "I (or \<phi>\<^sub>1 \<phi>\<^sub>2) xs = I (Or \<phi>\<^sub>1 \<phi>\<^sub>2) xs"
by(simp add:or_def)

lemma I_list_disj[simp]:
 "I (list_disj fs) xs = (\<exists>\<phi> \<in> set fs. I \<phi> xs)"
proof -
  { fix fs \<phi>
    have "I (foldr or fs \<phi>) xs = (I \<phi> xs \<or> (\<exists>\<phi> \<in> set fs. I \<phi> xs))"
      by (induct fs) auto
  } thus ?thesis by(simp add:list_disj_def)
qed

lemma I_nnf: "I (nnf \<phi>) xs = I \<phi> xs"
by(induct rule:nnf.induct)(simp_all add: I\<^sub>a_aneg)

lemma I_dnf:
"nqfree \<phi> \<Longrightarrow> (\<exists>as\<in>set (dnf \<phi>). \<forall>a\<in>set as. I\<^sub>a a xs) = I \<phi> xs"
by (induct \<phi>) (fastforce)+

definition "normal \<phi> = (\<forall>a \<in> atoms \<phi>. anormal a)"

lemma normal_simps[simp]:
"normal TrueF"
"normal FalseF"
"normal (Atom a) \<longleftrightarrow> anormal a"
"normal (And \<phi>\<^sub>1 \<phi>\<^sub>2) \<longleftrightarrow> normal \<phi>\<^sub>1 \<and> normal \<phi>\<^sub>2"
"normal (Or \<phi>\<^sub>1 \<phi>\<^sub>2) \<longleftrightarrow> normal \<phi>\<^sub>1 \<and> normal \<phi>\<^sub>2"
"normal (Neg \<phi>) \<longleftrightarrow> normal \<phi>"
"normal (ExQ \<phi>) \<longleftrightarrow> normal \<phi>"
by(auto simp:normal_def)

lemma normal_aneg[simp]: "anormal a \<Longrightarrow> normal (aneg a)"
by (simp add:anormal_aneg normal_def)

lemma normal_and[simp]:
  "normal \<phi>\<^sub>1 \<Longrightarrow> normal \<phi>\<^sub>2 \<Longrightarrow> normal (and \<phi>\<^sub>1 \<phi>\<^sub>2)"
by (simp add:Logic.and_def)

lemma normal_or[simp]:
  "normal \<phi>\<^sub>1 \<Longrightarrow> normal \<phi>\<^sub>2 \<Longrightarrow> normal (or \<phi>\<^sub>1 \<phi>\<^sub>2)"
by (simp add:Logic.or_def)

lemma normal_list_disj[simp]:
  "\<forall>\<phi>\<in>set fs. normal \<phi> \<Longrightarrow> normal (list_disj fs)"
apply(induct fs)
 apply (simp add:list_disj_def)
apply (simp add:list_disj_def)
done

lemma normal_nnf: "normal \<phi> \<Longrightarrow> normal(nnf \<phi>)"
by(induct \<phi> rule:nnf.induct) simp_all

lemma normal_map_fm:
  "\<forall>a. anormal(f a) = anormal(a) \<Longrightarrow> normal (map\<^bsub>fm\<^esub> f \<phi>) = normal \<phi>"
by(induct \<phi>) auto

lemma anormal_nnf:
  "qfree \<phi> \<Longrightarrow> normal \<phi> \<Longrightarrow> \<forall>a\<in>atoms(nnf \<phi>). anormal a"
apply(induct \<phi> rule:nnf.induct)
apply(unfold normal_def)
apply(simp_all)
apply (blast dest:anormal_aneg)+
done

lemma atoms_dnf: "nqfree \<phi> \<Longrightarrow> as : set(dnf \<phi>) \<Longrightarrow> a : set as \<Longrightarrow> a : atoms \<phi>"
by(induct \<phi> arbitrary: as a rule:nqfree.induct)(auto)

lemma anormal_dnf_nnf:
  "as : set(dnf(nnf \<phi>)) \<Longrightarrow> qfree \<phi> \<Longrightarrow> normal \<phi> \<Longrightarrow> a : set as \<Longrightarrow> anormal a"
apply(induct \<phi> arbitrary: a as rule:nnf.induct)
            apply(simp_all add: normal_def)
    apply clarify
    apply (metis UnE set_append)
   apply metis
  apply metis
 apply fastforce
apply (metis anormal_aneg atoms_dnf nqfree_aneg)
done

end

end


(* Victor B. F. Gomes, University of Cambridge
   Martin Kleppmann, University of Cambridge
   Dominic P. Mulligan, University of Cambridge
   Alastair R. Beresford, University of Cambridge
*)

section\<open>Replicated Growable Array\<close>

text\<open>The RGA, introduced by \<^cite>\<open>"Roh:2011dw"\<close>, is a replicated ordered list (sequence) datatype
     that supports \emph{insert} and \emph{delete} operations.\<close>

theory
  Ordered_List
imports
  Util
begin

type_synonym ('id, 'v) elt = "'id \<times> 'v \<times> bool"

subsection\<open>Insert and delete operations\<close>

text\<open>Insertion operations place the new element \emph{after} an existing list element with a given ID, or at the head of the list if no ID is given.
Deletion operations refer to the ID of the list element that is to be deleted.
However, it is not safe for a deletion operation to completely remove a list element, because then a concurrent insertion after the deleted element would not be able to locate the insertion position.
Instead, the list retains so-called \emph{tombstones}: a deletion operation merely sets a flag on a list element to mark it as deleted, but the element actually remains in the list.
A separate garbage collection process can be used to eventually purge tombstones \<^cite>\<open>"Roh:2011dw"\<close>, but we do not consider tombstone removal here.\<close>

hide_const insert

fun insert_body :: "('id::{linorder}, 'v) elt list \<Rightarrow> ('id, 'v) elt \<Rightarrow> ('id, 'v) elt list" where
  "insert_body []     e = [e]" |
  "insert_body (x#xs) e =
     (if fst x < fst e then
        e#x#xs
      else x#insert_body xs e)"

fun insert :: "('id::{linorder}, 'v) elt list \<Rightarrow> ('id, 'v) elt \<Rightarrow> 'id option \<Rightarrow> ('id, 'v) elt list option" where
  "insert xs     e None     = Some (insert_body xs e)" |
  "insert []     e (Some i) = None" |
  "insert (x#xs) e (Some i) =
     (if fst x = i then
        Some (x#insert_body xs e)
      else
        insert xs e (Some i) \<bind> (\<lambda>t. Some (x#t)))"

fun delete :: "('id::{linorder}, 'v) elt list \<Rightarrow> 'id \<Rightarrow> ('id, 'v) elt list option" where
  "delete []                 i = None" |
  "delete ((i', v, flag)#xs) i =
     (if i' = i then
        Some ((i', v, True)#xs)
      else
        delete xs i \<bind> (\<lambda>t. Some ((i',v,flag)#t)))"

subsection\<open>Well-definedness of insert and delete\<close>

lemma insert_no_failure:
  assumes "i = None \<or> (\<exists>i'. i = Some i' \<and> i' \<in> fst ` set xs)"
  shows   "\<exists>xs'. insert xs e i = Some xs'"
using assms by(induction rule: insert.induct; force)

lemma insert_None_index_neq_None [dest]:
  assumes "insert xs e i = None"
  shows   "i \<noteq> None"
using assms by(cases i, auto)

lemma insert_Some_None_index_not_in [dest]:
  assumes "insert xs e (Some i) = None"
  shows   "i \<notin> fst ` set xs"
using assms by(induction xs, auto split: if_split_asm bind_splits)

lemma index_not_in_insert_Some_None [simp]:
  assumes "i \<notin> fst ` set xs"
  shows   "insert xs e (Some i) = None"
using assms by(induction xs, auto)

lemma delete_no_failure:
  assumes "i \<in> fst ` set xs"
  shows   "\<exists>xs'. delete xs i = Some xs'"
using assms by(induction xs; force)

lemma delete_None_index_not_in [dest]:
  assumes "delete xs i = None"
  shows  "i \<notin> fst ` set xs"
using assms by(induction xs, auto split: if_split_asm bind_splits simp add: fst_eq_Domain)

lemma index_not_in_delete_None [simp]:
  assumes "i \<notin> fst ` set xs"
  shows   "delete xs i = None"
using assms by(induction xs, auto)

subsection\<open>Preservation of element indices\<close>

lemma insert_body_preserve_indices [simp]:
  shows  "fst ` set (insert_body xs e) = fst ` set xs \<union> {fst e}"
by(induction xs, auto simp add: insert_commute)

lemma insert_preserve_indices:
  assumes "\<exists>ys. insert xs e i = Some ys"
  shows   "fst ` set (the (insert xs e i)) = fst ` set xs \<union> {fst e}"
using assms by(induction xs; cases i; auto simp add: insert_commute split: bind_splits)

corollary insert_preserve_indices':
  assumes "insert xs e i = Some ys"
  shows   "fst ` set (the (insert xs e i)) = fst ` set xs \<union> {fst e}"
using assms insert_preserve_indices by blast

lemma delete_preserve_indices:
  assumes "delete xs i = Some ys"
  shows   "fst ` set xs = fst ` set ys"
using assms by(induction xs arbitrary: ys, simp) (case_tac a; auto split: if_split_asm bind_splits)

subsection\<open>Commutativity of concurrent operations\<close>

lemma insert_body_commutes:
  assumes "fst e1 \<noteq> fst e2"
  shows   "insert_body (insert_body xs e1) e2 = insert_body (insert_body xs e2) e1"
using assms by(induction xs, auto)

lemma insert_insert_body:
  assumes "fst e1 \<noteq> fst e2"
      and "i2 \<noteq> Some (fst e1)"
  shows   "insert (insert_body xs e1) e2 i2 = insert xs e2 i2 \<bind> (\<lambda>ys. Some (insert_body ys e1))"
using assms by (induction xs; cases i2) (auto split: if_split_asm simp add: insert_body_commutes)

lemma insert_Nil_None:
  assumes "fst e1 \<noteq> fst e2"
      and "i \<noteq> fst e2"
      and "i2 \<noteq> Some (fst e1)"
  shows   "insert [] e2 i2 \<bind> (\<lambda>ys. insert ys e1 (Some i)) = None"
using assms by (cases "i2") clarsimp+

lemma insert_insert_body_commute:
  assumes "i \<noteq> fst e1"
      and "fst e1 \<noteq> fst e2"
  shows   "insert (insert_body xs e1) e2 (Some i) =
             insert xs e2 (Some i) \<bind> (\<lambda>y. Some (insert_body y e1))"
using assms by(induction xs, auto simp add: insert_body_commutes)

lemma insert_commutes:
  assumes "fst e1 \<noteq> fst e2"
          "i1 = None \<or> i1 \<noteq> Some (fst e2)"
          "i2 = None \<or> i2 \<noteq> Some (fst e1)"
  shows   "insert xs e1 i1 \<bind> (\<lambda>ys. insert ys e2 i2) =
           insert xs e2 i2 \<bind> (\<lambda>ys. insert ys e1 i1)"
using assms proof(induction rule: insert.induct)
  fix xs and e :: "('a, 'b) elt"
  assume "i2 = None \<or> i2 \<noteq> Some (fst e)" and "fst e \<noteq> fst e2"
  thus "insert xs e None \<bind> (\<lambda>ys. insert ys e2 i2) = insert xs e2 i2 \<bind> (\<lambda>ys. insert ys e None)"
    by(auto simp add: insert_body_commutes intro: insert_insert_body)
next
  fix i and e :: "('a, 'b) elt"
  assume "fst e \<noteq> fst e2" and "i2 = None \<or> i2 \<noteq> Some (fst e)" and "Some i = None \<or> Some i \<noteq> Some (fst e2)"
  thus "insert [] e (Some i) \<bind> (\<lambda>ys. insert ys e2 i2) = insert [] e2 i2 \<bind> (\<lambda>ys. insert ys e (Some i))"
    by (auto intro: insert_Nil_None[symmetric])
next
  fix xs i and x e :: "('a, 'b) elt"
  assume IH: "(fst x \<noteq> i \<Longrightarrow>
               fst e \<noteq> fst e2 \<Longrightarrow>
               Some i = None \<or> Some i \<noteq> Some (fst e2) \<Longrightarrow>
               i2 = None \<or> i2 \<noteq> Some (fst e) \<Longrightarrow>
               insert xs e (Some i) \<bind> (\<lambda>ys. insert ys e2 i2) = insert xs e2 i2 \<bind> (\<lambda>ys. insert ys e (Some i)))"
     and "fst e \<noteq> fst e2"
     and "Some i = None \<or> Some i \<noteq> Some (fst e2)"
     and "i2 = None \<or> i2 \<noteq> Some (fst e)"
  thus "insert (x # xs) e (Some i) \<bind> (\<lambda>ys. insert ys e2 i2) = insert (x # xs) e2 i2 \<bind> (\<lambda>ys. insert ys e (Some i))"
    apply -
    apply(erule disjE, clarsimp, simp, rule conjI)
     apply(case_tac i2; force simp add: insert_body_commutes insert_insert_body_commute)
    apply(case_tac i2; clarsimp cong: Option.bind_cong simp add: insert_insert_body split: bind_splits)
    apply force
    done
qed

lemma delete_commutes:
  shows "delete xs i1 \<bind> (\<lambda>ys. delete ys i2) = delete xs i2 \<bind> (\<lambda>ys. delete ys i1)"
by(induction xs, auto split: bind_splits if_split_asm)

lemma insert_body_delete_commute:
  assumes "i2 \<noteq> fst e"
  shows   "delete (insert_body xs e) i2 \<bind> (\<lambda>t. Some (x#t)) =
            delete xs i2 \<bind> (\<lambda>y. Some (x#insert_body y e))"
using assms by (induction xs arbitrary: x; cases e, auto split: bind_splits if_split_asm)

lemma insert_delete_commute:
  assumes "i2 \<noteq> fst e"
  shows   "insert xs e i1 \<bind> (\<lambda>ys. delete ys i2) = delete xs i2 \<bind> (\<lambda>ys. insert ys e i1)"
using assms by(induction xs; cases e; cases i1, auto split: bind_splits if_split_asm simp add: insert_body_delete_commute)

subsection\<open>Alternative definition of insert\<close>

fun insert' :: "('id::{linorder}, 'v) elt list \<Rightarrow> ('id, 'v) elt \<Rightarrow> 'id option \<rightharpoonup> ('id::{linorder}, 'v) elt list" where
  "insert' [] e     None     = Some [e]" |
  "insert' [] e     (Some i) = None" |
  "insert' (x#xs) e None     =
     (if fst x < fst e then
        Some (e#x#xs)
      else
        case insert' xs e None of
          None   \<Rightarrow> None
        | Some t \<Rightarrow> Some (x#t))" |
  "insert' (x#xs) e (Some i) =
     (if fst x = i then
        case insert' xs e None of
          None   \<Rightarrow> None
        | Some t \<Rightarrow> Some (x#t)
      else
        case insert' xs e (Some i) of
          None   \<Rightarrow> None
        | Some t \<Rightarrow> Some (x#t))"

lemma [elim!, dest]:
  assumes "insert' xs e None = None"
  shows   "False"
using assms by(induction xs, auto split: if_split_asm option.split_asm)

lemma insert_body_insert':
  shows "insert' xs e None = Some (insert_body xs e)"
by(induction xs, auto)

lemma insert_insert':
  shows "insert xs e i = insert' xs e i"
by(induction xs; cases e; cases i, auto split: option.split simp add: insert_body_insert')

lemma insert_body_stop_iteration:
  assumes "fst e > fst x"
  shows "insert_body (x#xs) e = e#x#xs"
using assms by simp

lemma insert_body_contains_new_elem:
  shows "\<exists>p s. xs = p @ s \<and> insert_body xs e = p @ e # s"
proof (induction xs)
  case Nil thus ?case by force
next
  case (Cons a xs)
  then obtain p s where "xs = p @ s \<and> insert_body xs e = p @ e # s" by force
  thus ?case
    apply clarsimp
    apply (rule conjI; clarsimp)
      apply force
    apply (rule_tac x="a # p" in exI, force)
    done
qed

lemma insert_between_elements:
  assumes "xs = pre@ref#suf"
      and "distinct (map fst xs)"
      and "\<And>i'. i' \<in> fst ` set xs \<Longrightarrow> i' < fst e"
    shows "insert xs e (Some (fst ref)) = Some (pre @ ref # e # suf)"
  using assms by(induction xs arbitrary: pre ref suf, force) (case_tac pre; case_tac suf; force)

lemma insert_position_element_technical:
  assumes "\<forall>x\<in>set as. a \<noteq> fst x"
    and "insert_body (cs @ ds) e = cs @ e # ds"
  shows "insert (as @ (a, aa, b) # cs @ ds) e (Some a) = Some (as @ (a, aa, b) # cs @ e # ds)"
using assms by (induction as arbitrary: cs ds; clarsimp)

lemma split_tuple_list_by_id:
  assumes "(a,b,c) \<in> set xs"
    and "distinct (map fst xs)"
  shows "\<exists>pre suf. xs = pre @ (a,b,c) # suf \<and> (\<forall>y \<in> set pre. fst y \<noteq> a)"
using assms proof(induction xs, clarsimp)
  case (Cons x xs)
  { assume "x \<noteq> (a, b, c)"
    hence "(a, b, c) \<in> set xs" "distinct (map fst xs)"
      using Cons.prems by force+
    then obtain pre suf where "xs = pre @ (a, b, c) # suf \<and> (\<forall>y\<in>set pre. fst y \<noteq> a)"
      using Cons.IH by force
    hence ?case
      apply(rule_tac x="x#pre" in exI)
      using Cons.prems(2) by auto
  } thus ?case
    by force
qed

lemma insert_preserves_order:
  assumes "i = None \<or> (\<exists>i'. i = Some i' \<and> i' \<in> fst ` set xs)"
      and "distinct (map fst xs)"
    shows "\<exists>pre suf. xs = pre@suf \<and> insert xs e i = Some (pre @ e # suf)"
  using assms proof -
  { assume "i = None"
    hence ?thesis
      by clarsimp (metis insert_body_contains_new_elem)
  } moreover {
    assume "\<exists>i'. i = Some i' \<and> i' \<in> fst ` set xs"
    then obtain j v b where "i = Some j" "(j, v, b) \<in> set xs" by force
    moreover then obtain as bs where "xs = as@(j,v,b)#bs" "\<forall>x \<in> set as. fst x \<noteq> j"
      using assms by (metis split_tuple_list_by_id)
    moreover then obtain cs ds where "insert_body bs e = cs@e#ds" "cs@ds = bs"
      by(metis insert_body_contains_new_elem)
    ultimately have ?thesis
      by(rule_tac x="as@(j,v,b)#cs" in exI; clarsimp)(metis insert_position_element_technical)
  } ultimately show ?thesis
    using assms by force
qed
end


(* Title: ETTS/Tests/ETTS_Tests.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins

A test suite for the ETTS.
*)

section\<open>A test suite for ETTS\<close>
theory ETTS_Tests
  imports
    "../ETTS_Auxiliary"
    Conditional_Transfer_Rule.IML_UT
begin

subsection\<open>\<open>amend_ctxt_data\<close>\<close>

ML_file\<open>ETTS_TEST_AMEND_CTXT_DATA.ML\<close>

locale test_amend_ctxt_data =
  fixes UA :: "'ao set" and UB :: "'bo set" and UC :: "'co set"
    and le :: "['ao, 'ao] \<Rightarrow> bool" (infix \<open>\<le>\<^sub>o\<^sub>w\<close> 50)
    and ls :: "['bo, 'bo] \<Rightarrow> bool" (infix \<open><\<^sub>o\<^sub>w\<close> 50)
    and f :: "['ao, 'bo] \<Rightarrow> 'co"
  assumes closed_f: "\<lbrakk> a \<in> UA; b \<in> UB \<rbrakk> \<Longrightarrow> f a b \<in> UC"
begin

notation le (\<open>'(\<le>\<^sub>o\<^sub>w')\<close>)
  and le (infix \<open>\<le>\<^sub>o\<^sub>w\<close> 50)
  and ls (\<open>'(<\<^sub>o\<^sub>w')\<close>)
  and ls (infix \<open><\<^sub>o\<^sub>w\<close> 50)

tts_register_sbts \<open>(\<le>\<^sub>o\<^sub>w)\<close> | UA
proof-
  assume "Domainp AOA = (\<lambda>x. x \<in> UA)" "bi_unique AOA" "right_total AOA"
  from tts_AA_eq_transfer[OF this] show ?thesis by auto
qed

tts_register_sbts \<open>(<\<^sub>o\<^sub>w)\<close> | UB
proof-
  assume "Domainp BOA = (\<lambda>x. x \<in> UB)" "bi_unique BOA" "right_total BOA"
  from tts_AA_eq_transfer[OF this] show ?thesis by auto
qed

tts_register_sbts f | UA and UB and UC
proof-
  assume
    "Domainp AOC = (\<lambda>x. x \<in> UA)" "bi_unique AOC" "right_total AOC"
    "Domainp BOB = (\<lambda>x. x \<in> UB)" "bi_unique BOB" "right_total BOB"
    "Domainp COA = (\<lambda>x. x \<in> UC)" "bi_unique COA" "right_total COA"
  from tts_AB_C_transfer[OF closed_f this] show ?thesis by auto
qed

end

context test_amend_ctxt_data
begin
ML\<open>
Lecker.test_group @{context} () [etts_test_amend_ctxt_data.test_suite]
\<close>
end

subsection\<open>\<open>tts_algorithm\<close>\<close>

text\<open>
Some of the elements of the content of this section are based on the
elements of the content of \<^cite>\<open>"cain_nine_2019"\<close>.
\<close>

(*the following theorem is restated for forward compatibility*)
lemma exI': "P x \<Longrightarrow> \<exists>x. P x" by auto

class tta_mult =
  fixes tta_mult :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "*\<^sub>t\<^sub>t\<^sub>a" 65)

class tta_semigroup = tta_mult +
  assumes tta_assoc[simp]: "(a *\<^sub>t\<^sub>t\<^sub>a b) *\<^sub>t\<^sub>t\<^sub>a c = a *\<^sub>t\<^sub>t\<^sub>a (b *\<^sub>t\<^sub>t\<^sub>a c)"

definition set_mult :: "'a::tta_mult set \<Rightarrow> 'a set \<Rightarrow> 'a set" (infixl "\<^bold>*\<^sub>t\<^sub>t\<^sub>a" 65)
  where "set_mult S T = {s *\<^sub>t\<^sub>t\<^sub>a t | s t. s \<in> S \<and> t \<in> T}"

definition left_ideal :: "'a::tta_mult set \<Rightarrow> bool"
  where "left_ideal T \<longleftrightarrow> (\<forall>s. \<forall>t\<in>T. s *\<^sub>t\<^sub>t\<^sub>a t \<in> T)"

lemma left_idealI[intro]:
  assumes "\<And>s t. t \<in> T \<Longrightarrow> s *\<^sub>t\<^sub>t\<^sub>a t \<in> T"
  shows "left_ideal T"
  using assms unfolding left_ideal_def by simp

lemma left_idealE[elim]:
  assumes "left_ideal T"
  obtains "\<And>s t. t \<in> T \<Longrightarrow> s *\<^sub>t\<^sub>t\<^sub>a t \<in> T"
  using assms unfolding left_ideal_def by simp

lemma left_ideal_set_mult_iff: "left_ideal T \<longleftrightarrow> UNIV \<^bold>*\<^sub>t\<^sub>t\<^sub>a T \<subseteq> T"
  unfolding left_ideal_def set_mult_def by auto

ud \<open>set_mult\<close>
ud \<open>left_ideal\<close>

ctr relativization
  synthesis ctr_simps
  assumes [transfer_domain_rule]: "Domainp A = (\<lambda>x. x \<in> U)"
    and [transfer_rule]: "bi_unique A" "right_total A"
  trp (?'a A)
  in set_mult_ow: set_mult.with_def
    and left_ideal_ow: left_ideal.with_def

locale tta_semigroup_hom =
  fixes f :: "'a::tta_semigroup \<Rightarrow> 'b::tta_semigroup"
  assumes hom: "f (a *\<^sub>t\<^sub>t\<^sub>a b) = f a *\<^sub>t\<^sub>t\<^sub>a f b"

context tta_semigroup_hom
begin

lemma tta_left_ideal_closed:
  assumes "left_ideal T" and "surj f"
  shows "left_ideal (f ` T)"
  unfolding left_ideal_def
proof(intro allI ballI)
  fix fs ft assume prems: "ft \<in> f ` T"
  then obtain t where t: "t \<in> T" and ft_def: "ft = f t" by clarsimp
  from assms(2) obtain s where fs_def: "fs = f s" by auto
  from assms have "t \<in> T \<Longrightarrow> s *\<^sub>t\<^sub>t\<^sub>a t \<in> T" for s t by auto
  with t show "fs *\<^sub>t\<^sub>t\<^sub>a ft \<in> f ` T"
    unfolding ft_def fs_def hom[symmetric] by simp
qed

end

locale semigroup_mult_hom_with =
  dom: tta_semigroup times_a + cod: tta_semigroup times_b
  for times_a (infixl \<open>*\<^sub>o\<^sub>w\<^sub>.\<^sub>a\<close> 70) and times_b (infixl \<open>*\<^sub>o\<^sub>w\<^sub>.\<^sub>b\<close> 70) +
  fixes f :: "'a \<Rightarrow> 'b"
  assumes f_hom: "f (a *\<^sub>o\<^sub>w\<^sub>.\<^sub>a b) = f a *\<^sub>o\<^sub>w\<^sub>.\<^sub>b f b"

lemma semigroup_mult_hom_with[ud_with]:
  "tta_semigroup_hom = semigroup_mult_hom_with (*\<^sub>t\<^sub>t\<^sub>a) (*\<^sub>t\<^sub>t\<^sub>a)"
  unfolding
    semigroup_mult_hom_with_def tta_semigroup_hom_def
    class.tta_semigroup_def semigroup_mult_hom_with_axioms_def
  by auto

locale semigroup_ow =
  fixes U :: "'ag set" and f :: "['ag, 'ag] \<Rightarrow> 'ag" (infixl \<open>\<^bold>*\<^sub>o\<^sub>w\<close> 70)
  assumes f_closed: "\<lbrakk> a \<in> U; b \<in> U \<rbrakk> \<Longrightarrow> a \<^bold>*\<^sub>o\<^sub>w b \<in> U"
    and assoc: "\<lbrakk> a \<in> U; b \<in> U; c \<in> U \<rbrakk> \<Longrightarrow> a \<^bold>*\<^sub>o\<^sub>w b \<^bold>*\<^sub>o\<^sub>w c = a \<^bold>*\<^sub>o\<^sub>w (b \<^bold>*\<^sub>o\<^sub>w c)"
begin

notation f (infixl \<open>\<^bold>*\<^sub>o\<^sub>w\<close> 70)

lemma f_closed'[simp]: "\<forall>x\<in>U. \<forall>y\<in>U. x \<^bold>*\<^sub>o\<^sub>w y \<in> U" by (simp add: f_closed)

tts_register_sbts \<open>(\<^bold>*\<^sub>o\<^sub>w)\<close> | U by (rule tts_AA_A_transfer[OF f_closed])

end

locale times_ow =
  fixes U :: "'ag set" and times :: "['ag, 'ag] \<Rightarrow> 'ag" (infixl \<open>*\<^sub>o\<^sub>w\<close> 70)
  assumes times_closed[simp, intro]: "\<lbrakk> a \<in> U; b \<in> U \<rbrakk> \<Longrightarrow> a *\<^sub>o\<^sub>w b \<in> U"
begin

notation times (infixl \<open>*\<^sub>o\<^sub>w\<close> 70)

lemma times_closed'[simp]: "\<forall>x\<in>U. \<forall>y\<in>U. x *\<^sub>o\<^sub>w y \<in> U" by simp

tts_register_sbts \<open>(*\<^sub>o\<^sub>w)\<close> | U  by (rule tts_AA_A_transfer[OF times_closed])

end

locale semigroup_mult_ow = times_ow U times
  for U :: "'ag set" and times +
  assumes mult_assoc:
    "\<lbrakk> a \<in> U; b \<in> U; c \<in> U \<rbrakk> \<Longrightarrow> a *\<^sub>o\<^sub>w b *\<^sub>o\<^sub>w c = a *\<^sub>o\<^sub>w (b *\<^sub>o\<^sub>w c)"
begin

sublocale mult: semigroup_ow U \<open>(*\<^sub>o\<^sub>w)\<close>
  by unfold_locales (auto simp: times_closed' mult_assoc)

end

locale semigroup_mult_hom_ow =
  dom: semigroup_mult_ow UA times_a +
  cod: semigroup_mult_ow UB times_b
  for UA :: "'a set"
    and UB :: "'b set"
    and times_a (infixl \<open>*\<^sub>o\<^sub>w\<^sub>.\<^sub>a\<close> 70)
    and times_b (infixl \<open>*\<^sub>o\<^sub>w\<^sub>.\<^sub>b\<close> 70) +
  fixes f :: "'a \<Rightarrow> 'b"
  assumes f_closed[simp]: "a \<in> UA \<Longrightarrow> f a \<in> UB"
    and f_hom: "\<lbrakk> a \<in> UA; b \<in> UA \<rbrakk> \<Longrightarrow> f (a *\<^sub>o\<^sub>w\<^sub>.\<^sub>a b) = f a *\<^sub>o\<^sub>w\<^sub>.\<^sub>b f b"
begin

lemma f_closed'[simp]: "f ` UA \<subseteq> UB" by auto

tts_register_sbts f | UA and UB by (rule tts_AB_transfer[OF f_closed'])

end

context semigroup_mult_hom_ow
begin

lemma tta_left_ideal_ow_closed:
  assumes "T \<subseteq> UA"
    and "left_ideal_ow UA (*\<^sub>o\<^sub>w\<^sub>.\<^sub>a) T"
    and "f ` UA = UB"
  shows "left_ideal_ow UB (*\<^sub>o\<^sub>w\<^sub>.\<^sub>b) (f ` T)"
  unfolding left_ideal_ow_def
proof(intro ballI)
  fix fs ft assume ft: "ft \<in> f ` T" and fs: "fs \<in> UB"
  then obtain t where t: "t \<in> T" and ft_def: "ft = f t" by auto
  from assms(3) fs obtain s where fs_def: "fs = f s" and s: "s \<in> UA" by auto
  from assms have "\<lbrakk> s \<in> UA; t \<in> T \<rbrakk> \<Longrightarrow> s *\<^sub>o\<^sub>w\<^sub>.\<^sub>a t \<in> T" for s t
    unfolding left_ideal_ow_def by simp
  with assms(1) s t fs show "fs *\<^sub>o\<^sub>w\<^sub>.\<^sub>b ft \<in> f ` T"
    using f_hom[symmetric, OF s] unfolding ft_def fs_def by auto
qed

end

lemma semigroup_mult_ow: "class.tta_semigroup = semigroup_mult_ow UNIV"
  unfolding
    class.tta_semigroup_def semigroup_mult_ow_def
    semigroup_mult_ow_axioms_def times_ow_def
  by simp

lemma semigroup_mult_hom_ow:
  "tta_semigroup_hom = semigroup_mult_hom_ow UNIV UNIV (*\<^sub>t\<^sub>t\<^sub>a) (*\<^sub>t\<^sub>t\<^sub>a)"
  unfolding
    tta_semigroup_hom_def semigroup_mult_hom_ow_axioms_def
    semigroup_mult_hom_ow_def semigroup_mult_ow_def
    semigroup_mult_ow_axioms_def times_ow_def
  by simp

context
  includes lifting_syntax
begin

lemma semigroup_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "((A ===> A ===> A) ===> (=))
      (semigroup_ow (Collect (Domainp A))) semigroup"
proof-
  let ?P = "((A ===> A ===> A) ===> (=))"
  let ?semigroup_ow = "semigroup_ow (Collect (Domainp A))"
  let ?rf_UNIV =
    "(\<lambda>f::['b, 'b] \<Rightarrow> 'b. (\<forall>x y. x \<in> UNIV \<longrightarrow> y \<in> UNIV \<longrightarrow> f x y \<in> UNIV))"
  have "?P ?semigroup_ow (\<lambda>f. ?rf_UNIV f \<and> semigroup f)"
    unfolding semigroup_ow_def semigroup_def
    apply transfer_prover_start
    apply transfer_step+
    by simp
  thus ?thesis by simp
qed

lemma semigroup_mult_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "((A ===> A ===> A) ===> (=))
      (semigroup_mult_ow (Collect (Domainp A)))
      class.tta_semigroup"
proof -
  let ?P = \<open>((A ===> A ===> A) ===> (=))\<close>
    and ?semigroup_mult_ow =
      \<open>(\<lambda>f. semigroup_mult_ow (Collect (Domainp A)) f)\<close>
    and ?rf_UNIV =
      \<open>(\<lambda>f::['b, 'b] \<Rightarrow> 'b. (\<forall>x y. x \<in> UNIV \<longrightarrow> y \<in> UNIV \<longrightarrow> f x y \<in> UNIV))\<close>
  have "?P ?semigroup_mult_ow (\<lambda>f. ?rf_UNIV f \<and> class.tta_semigroup f)"
    unfolding
      semigroup_mult_ow_def class.tta_semigroup_def
      semigroup_mult_ow_axioms_def times_ow_def
    apply transfer_prover_start
    apply transfer_step+
    by simp
  thus ?thesis by simp
qed

lemma semigroup_mult_hom_transfer[transfer_rule]:
  assumes [transfer_rule]:
    "bi_unique A" "right_total A" "bi_unique B" "right_total B"
  shows
    "((A ===> A ===> A) ===> (B ===> B ===> B) ===> (A ===> B) ===> (=))
      (semigroup_mult_hom_ow (Collect (Domainp A)) (Collect (Domainp B)))
      semigroup_mult_hom_with"
proof-
  let ?PA = "A ===> A ===> A"
    and ?PB = "B ===> B ===> B"
    and ?semigroup_mult_hom_ow =
      \<open>
        \<lambda>times_a times_b f. semigroup_mult_hom_ow
          (Collect (Domainp A)) (Collect (Domainp B)) times_a times_b f
      \<close>
  let ?closed = \<open>\<lambda>f::'b\<Rightarrow>'d . \<forall>a. a \<in> UNIV \<longrightarrow> f a \<in> UNIV\<close>
  have
    "(?PA ===> ?PB ===> (A ===> B) ===> (=))
      ?semigroup_mult_hom_ow
      (
        \<lambda>times_a times_b f.
          ?closed f \<and> semigroup_mult_hom_with times_a times_b f
      )"
    unfolding
      times_ow_def
      semigroup_mult_hom_ow_def
      semigroup_mult_hom_ow_axioms_def
      semigroup_mult_hom_with_def
      semigroup_mult_hom_with_axioms_def
    apply transfer_prover_start
    apply transfer_step+
    by blast
  thus ?thesis by simp
qed

end

context semigroup_mult_hom_ow
begin

ML_file\<open>ETTS_TEST_TTS_ALGORITHM.ML\<close>

named_theorems semigroup_mult_hom_ow_test_simps

lemmas [semigroup_mult_hom_ow_test_simps] =
  ctr_simps_Collect_mem_eq
  ctr_simps_in_iff

tts_context
  tts: (?'a to UA) and (?'b to UB)
  sbterms: (\<open>(*\<^sub>t\<^sub>t\<^sub>a)::[?'a::tta_semigroup, ?'a] \<Rightarrow> ?'a\<close> to \<open>(*\<^sub>o\<^sub>w\<^sub>.\<^sub>a)\<close>)
    and (\<open>(*\<^sub>t\<^sub>t\<^sub>a)::[?'b::tta_semigroup, ?'b] \<Rightarrow> ?'b\<close> to \<open>(*\<^sub>o\<^sub>w\<^sub>.\<^sub>b)\<close>)
    and (\<open>?f::?'a::tta_semigroup \<Rightarrow> ?'b::tta_semigroup\<close> to f)
  rewriting semigroup_mult_hom_ow_test_simps
  substituting semigroup_mult_hom_ow_axioms
    and dom.semigroup_mult_ow_axioms
    and cod.semigroup_mult_ow_axioms
  eliminating \<open>UA \<noteq> {}\<close> and \<open>UB \<noteq> {}\<close>
    through (auto simp only: left_ideal_ow_def)
begin
ML\<open>
Lecker.test_group @{context} () [etts_test_tts_algorithm.test_suite]
\<close>
end

end

subsection\<open>\<open>tts_register_sbts\<close>\<close>

context
  fixes f :: "'a \<Rightarrow> 'b \<Rightarrow> 'c"
    and UA :: "'a set"
begin
ML_file\<open>ETTS_TEST_TTS_REGISTER_SBTS.ML\<close>
ML\<open>
Lecker.test_group @{context} () [etts_test_tts_register_sbts.test_suite]
\<close>
end

end