(*  Title:      HOL/Library/RBT.thy
    Author:     Lukas Bulwahn and Ondrej Kuncar
*)

section \<open>Abstract type of RBT trees\<close>

theory RBT
imports MainRLT RBT_Impl
begin

subsection \<open>Type definition\<close>

typedef (overloaded) ('a, 'b) rbt = "{t :: ('a::linorder, 'b) RBT_Impl.rbt. is_rbt t}"
  morphisms impl_of RBT
proof -
  have "RBT_Impl.Empty \<in> ?rbt" by simp
  then show ?thesis ..
qed

lemma rbt_eq_iff:
  "t1 = t2 \<longleftrightarrow> impl_of t1 = impl_of t2"
  by (simp add: impl_of_inject)

lemma rbt_eqI:
  "impl_of t1 = impl_of t2 \<Longrightarrow> t1 = t2"
  by (simp add: rbt_eq_iff)

lemma RBT_impl_of [simp, code abstype]:
  "RBT (impl_of t) = t"
  by (simp add: impl_of_inverse)

subsection \<open>Primitive operations\<close>

setup_lifting type_definition_rbt

lift_definition lookup :: "('a::linorder, 'b) rbt \<Rightarrow> 'a \<rightharpoonup> 'b" is "rbt_lookup" .

lift_definition empty :: "('a::linorder, 'b) rbt" is RBT_Impl.Empty
by (simp add: empty_def)

lift_definition insert :: "'a::linorder \<Rightarrow> 'b \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt" is "rbt_insert"
by simp

lift_definition delete :: "'a::linorder \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt" is "rbt_delete"
by simp

lift_definition entries :: "('a::linorder, 'b) rbt \<Rightarrow> ('a \<times> 'b) list" is RBT_Impl.entries .

lift_definition keys :: "('a::linorder, 'b) rbt \<Rightarrow> 'a list" is RBT_Impl.keys .

lift_definition bulkload :: "('a::linorder \<times> 'b) list \<Rightarrow> ('a, 'b) rbt" is "rbt_bulkload" ..

lift_definition map_entry :: "'a \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> ('a::linorder, 'b) rbt \<Rightarrow> ('a, 'b) rbt" is rbt_map_entry
by simp

lift_definition map :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('a::linorder, 'b) rbt \<Rightarrow> ('a, 'c) rbt" is RBT_Impl.map
by simp

lift_definition fold :: "('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'c) \<Rightarrow> ('a::linorder, 'b) rbt \<Rightarrow> 'c \<Rightarrow> 'c"  is RBT_Impl.fold .

lift_definition union :: "('a::linorder, 'b) rbt \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt" is "rbt_union"
by (simp add: rbt_union_is_rbt)

lift_definition foldi :: "('c \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'c) \<Rightarrow> ('a :: linorder, 'b) rbt \<Rightarrow> 'c \<Rightarrow> 'c"
  is RBT_Impl.foldi .

lift_definition combine_with_key :: "('a \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a::linorder, 'b) rbt \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt"
  is RBT_Impl.rbt_union_with_key by (rule is_rbt_rbt_unionwk)

lift_definition combine :: "('b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a::linorder, 'b) rbt \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt"
  is RBT_Impl.rbt_union_with by (rule rbt_unionw_is_rbt)

subsection \<open>Derived operations\<close>

definition is_empty :: "('a::linorder, 'b) rbt \<Rightarrow> bool" where
  [code]: "is_empty t = (case impl_of t of RBT_Impl.Empty \<Rightarrow> True | _ \<Rightarrow> False)"

(* TODO: Is deleting more efficient than re-building the tree?
   (Probably more difficult to prove though *)
definition filter :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a::linorder, 'b) rbt \<Rightarrow> ('a, 'b) rbt" where
  [code]: "filter P t = fold (\<lambda>k v t. if P k v then insert k v t else t) t empty"

subsection \<open>Abstract lookup properties\<close>

lemma lookup_RBT:
  "is_rbt t \<Longrightarrow> lookup (RBT t) = rbt_lookup t"
  by (simp add: lookup_def RBT_inverse)

lemma lookup_impl_of:
  "rbt_lookup (impl_of t) = lookup t"
  by transfer (rule refl)

lemma entries_impl_of:
  "RBT_Impl.entries (impl_of t) = entries t"
  by transfer (rule refl)

lemma keys_impl_of:
  "RBT_Impl.keys (impl_of t) = keys t"
  by transfer (rule refl)

lemma lookup_keys:
  "dom (lookup t) = set (keys t)"
  by transfer (simp add: rbt_lookup_keys)

lemma lookup_empty [simp]:
  "lookup empty = Map.empty"
  by (simp add: empty_def lookup_RBT fun_eq_iff)

lemma lookup_insert [simp]:
  "lookup (insert k v t) = (lookup t)(k \<mapsto> v)"
  by transfer (rule rbt_lookup_rbt_insert)

lemma lookup_delete [simp]:
  "lookup (delete k t) = (lookup t)(k := None)"
  by transfer (simp add: rbt_lookup_rbt_delete restrict_complement_singleton_eq)

lemma map_of_entries [simp]:
  "map_of (entries t) = lookup t"
  by transfer (simp add: map_of_entries)

lemma entries_lookup:
  "entries t1 = entries t2 \<longleftrightarrow> lookup t1 = lookup t2"
  by transfer (simp add: entries_rbt_lookup)

lemma lookup_bulkload [simp]:
  "lookup (bulkload xs) = map_of xs"
  by transfer (rule rbt_lookup_rbt_bulkload)

lemma lookup_map_entry [simp]:
  "lookup (map_entry k f t) = (lookup t)(k := map_option f (lookup t k))"
  by transfer (rule rbt_lookup_rbt_map_entry)

lemma lookup_map [simp]:
  "lookup (map f t) k = map_option (f k) (lookup t k)"
  by transfer (rule rbt_lookup_map)

lemma lookup_combine_with_key [simp]:
  "lookup (combine_with_key f t1 t2) k = combine_options (f k) (lookup t1 k) (lookup t2 k)"
  by transfer (simp_all add: combine_options_def rbt_lookup_rbt_unionwk)

lemma combine_altdef: "combine f t1 t2 = combine_with_key (\<lambda>_. f) t1 t2"
  by transfer (simp add: rbt_union_with_def)

lemma lookup_combine [simp]:
  "lookup (combine f t1 t2) k = combine_options f (lookup t1 k) (lookup t2 k)"
  by (simp add: combine_altdef)

lemma fold_fold:
  "fold f t = List.fold (case_prod f) (entries t)"
  by transfer (rule RBT_Impl.fold_def)

lemma impl_of_empty:
  "impl_of empty = RBT_Impl.Empty"
  by transfer (rule refl)

lemma is_empty_empty [simp]:
  "is_empty t \<longleftrightarrow> t = empty"
  unfolding is_empty_def by transfer (simp split: rbt.split)

lemma RBT_lookup_empty [simp]: (*FIXME*)
  "rbt_lookup t = Map.empty \<longleftrightarrow> t = RBT_Impl.Empty"
  by (cases t) (auto simp add: fun_eq_iff)

lemma lookup_empty_empty [simp]:
  "lookup t = Map.empty \<longleftrightarrow> t = empty"
  by transfer (rule RBT_lookup_empty)

lemma sorted_keys [iff]:
  "sorted (keys t)"
  by transfer (simp add: RBT_Impl.keys_def rbt_sorted_entries)

lemma distinct_keys [iff]:
  "distinct (keys t)"
  by transfer (simp add: RBT_Impl.keys_def distinct_entries)

lemma finite_dom_lookup [simp, intro!]: "finite (dom (lookup t))"
  by transfer simp

lemma lookup_union: "lookup (union s t) = lookup s ++ lookup t"
  by transfer (simp add: rbt_lookup_rbt_union)

lemma lookup_in_tree: "(lookup t k = Some v) = ((k, v) \<in> set (entries t))"
  by transfer (simp add: rbt_lookup_in_tree)

lemma keys_entries: "(k \<in> set (keys t)) = (\<exists>v. (k, v) \<in> set (entries t))"
  by transfer (simp add: keys_entries)

lemma fold_def_alt:
  "fold f t = List.fold (case_prod f) (entries t)"
  by transfer (auto simp: RBT_Impl.fold_def)

lemma distinct_entries: "distinct (List.map fst (entries t))"
  by transfer (simp add: distinct_entries)

lemma sorted_entries: "sorted (List.map fst (entries t))"
  by (transfer) (simp add: rbt_sorted_entries)

lemma non_empty_keys: "t \<noteq> empty \<Longrightarrow> keys t \<noteq> []"
  by transfer (simp add: non_empty_rbt_keys)

lemma keys_def_alt:
  "keys t = List.map fst (entries t)"
  by transfer (simp add: RBT_Impl.keys_def)

context
begin

private lemma lookup_filter_aux:
  assumes "distinct (List.map fst xs)"
  shows   "lookup (List.fold (\<lambda>(k, v) t. if P k v then insert k v t else t) xs t) k =
             (case map_of xs k of
                None \<Rightarrow> lookup t k
              | Some v \<Rightarrow> if P k v then Some v else lookup t k)"
  using assms by (induction xs arbitrary: t) (force split: option.splits)+

lemma lookup_filter:
  "lookup (filter P t) k =
     (case lookup t k of None \<Rightarrow> None | Some v \<Rightarrow> if P k v then Some v else None)"
  unfolding filter_def using lookup_filter_aux[of "entries t" P empty k]
  by (simp add: fold_fold distinct_entries split: option.splits)

end

subsection \<open>Quickcheck generators\<close>

quickcheck_generator rbt predicate: is_rbt constructors: empty, insert

subsection \<open>Hide implementation details\<close>

lifting_update rbt.lifting
lifting_forget rbt.lifting

hide_const (open) impl_of empty lookup keys entries bulkload delete map fold union insert map_entry foldi
  is_empty filter
hide_fact (open) empty_def lookup_def keys_def entries_def bulkload_def delete_def map_def fold_def
  union_def insert_def map_entry_def foldi_def is_empty_def filter_def

end


(* Author: Andreas Lochbihler, Digital Asset
   Author: Ognjen Maric, Digital Asset *)

theory Generic_ADS_Construction imports
  "Merkle_Interface"
  "HOL-Library.BNF_Axiomatization"
begin

section \<open>Generic construction of authenticated data structures\<close>

subsection \<open>Functors\<close>

subsubsection \<open>Source functor\<close>

text \<open>

We want to allow ADSs of arbitrary ADTs, which we call "source trees". The ADTs we are interested in can
in general be represented as the least fixpoints of some bounded natural (bi-)functor (BNF) \<open>('a, 'b) F\<close>, where
@{typ 'a} is the type of "source" data, and @{typ 'b} is a recursion "handle".
However, Isabelle's type system does not support higher kinds, necessary to parameterize our definitions
over functors.
Instead, we first develop a general theory of ADSs over an arbitrary, but fixed functor,
and its least fixpoint. We show that the theory is compositional, in that the functor's least fixed point
can then be reused as the "source" data of another functor.

We start by defining the arbitrary fixed functor, its fixpoints, and showing how composition can be
done. A higher-level explanation is found in the paper.
\<close>

bnf_axiomatization ('a, 'b) F [wits: "'a \<Rightarrow> ('a, 'b) F"]

context notes [[typedef_overloaded]] begin
datatype 'a T = T "('a, 'a T) F"
end

subsubsection \<open>Base Merkle functor\<close>

text \<open>
This type captures the ADS hashes.
\<close>

bnf_axiomatization ('a, 'b) F\<^sub>h [wits: "'a \<Rightarrow> ('a, 'b) F\<^sub>h"]

text \<open>
It intuitively contains mixed garbage and source values.
The functor's recursive handle @{typ 'b} might contain partial garbage.
\<close>

text \<open>
This type captures the ADS inclusion proofs.
The functor \<open>('a, 'a', 'b, 'b') F\<^sub>m\<close> has all type variables doubled.
This type represents all values including the information which parts are blinded.
The original type variable @{typ 'a} now represents the source data, which for compositionality can contain blindable positions.
The type @{typ 'b} is a recursive handle to inclusion sub-proofs (which can be partialy blinded).
The type @{typ 'a'} represent "hashes" of the source data in @{typ 'a}, i.e., a mix of source values and garbage.
The type @{typ 'b'} is a recursive handle to ADS hashes of subtrees.

The corresponding type of recursive authenticated trees is then a fixpoint of this functor.
\<close>

bnf_axiomatization ('a\<^sub>m, 'a\<^sub>h, 'b\<^sub>m, 'b\<^sub>h) F\<^sub>m [wits: "'a\<^sub>m \<Rightarrow> 'a\<^sub>h \<Rightarrow> 'b\<^sub>h \<Rightarrow> ('a\<^sub>m, 'a\<^sub>h, 'b\<^sub>m, 'b\<^sub>h) F\<^sub>m"]

subsubsection \<open>Least fixpoint\<close>

context notes [[typedef_overloaded]] begin
datatype 'a\<^sub>h T\<^sub>h = T\<^sub>h "('a\<^sub>h, 'a\<^sub>h T\<^sub>h) F\<^sub>h"
end

context notes [[typedef_overloaded]] begin
datatype ('a\<^sub>m, 'a\<^sub>h) T\<^sub>m = T\<^sub>m (the_T\<^sub>m: "('a\<^sub>m, 'a\<^sub>h, ('a\<^sub>m, 'a\<^sub>h) T\<^sub>m, 'a\<^sub>h T\<^sub>h) F\<^sub>m")
end

subsubsection \<open> Composition \<close>

text \<open>
Finally, we show how to compose two Merkle functors.
For simplicity, we reuse @{typ \<open>('a, 'b) F\<close>} and @{typ \<open>'a T\<close>}.
\<close>

context notes [[typedef_overloaded]] begin

datatype ('a, 'b) G = G "('a T, 'b) F"

datatype ('a\<^sub>h, 'b\<^sub>h) G\<^sub>h = G\<^sub>h (the_G\<^sub>h: "('a\<^sub>h T\<^sub>h, 'b\<^sub>h) F\<^sub>h")

datatype ('a\<^sub>m, 'a\<^sub>h, 'b\<^sub>m, 'b\<^sub>h) G\<^sub>m = G\<^sub>m (the_G\<^sub>m: "(('a\<^sub>m, 'a\<^sub>h) T\<^sub>m, 'a\<^sub>h T\<^sub>h, 'b\<^sub>m, 'b\<^sub>h) F\<^sub>m")

end

subsection \<open>Root hash\<close>

subsubsection \<open>Base functor\<close>

text \<open>
The root hash of an authenticated value is modelled as a blindable value of type @{typ "('a', 'b') F\<^sub>h"}.
(Actually, we want to use an abstract datatype for root hashes, but we omit this distinction here for simplicity.)
\<close>

consts root_hash_F' :: "(('a\<^sub>h, 'a\<^sub>h, 'b\<^sub>h, 'b\<^sub>h) F\<^sub>m, ('a\<^sub>h, 'b\<^sub>h) F\<^sub>h) hash"
  \<comment> \<open>Root hash operation where we assume that all atoms have already been replaced by root hashes.
     This assumption is reflected in the equality of the type parameters of @{type F\<^sub>m} \<close>

type_synonym ('a\<^sub>m, 'a\<^sub>h, 'b\<^sub>m, 'b\<^sub>h) hash_F =
  "('a\<^sub>m, 'a\<^sub>h) hash \<Rightarrow> ('b\<^sub>m, 'b\<^sub>h) hash \<Rightarrow> (('a\<^sub>m, 'a\<^sub>h, 'b\<^sub>m, 'b\<^sub>h) F\<^sub>m, ('a\<^sub>h, 'b\<^sub>h) F\<^sub>h) hash"
definition root_hash_F :: "('a\<^sub>m, 'a\<^sub>h, 'b\<^sub>m, 'b\<^sub>h) hash_F" where
  "root_hash_F rha rhb = root_hash_F' \<circ> map_F\<^sub>m rha id rhb id"

subsubsection \<open>Least fixpoint\<close>

primrec root_hash_T' :: "(('a\<^sub>h, 'a\<^sub>h) T\<^sub>m, 'a\<^sub>h T\<^sub>h) hash" where
  "root_hash_T' (T\<^sub>m x) = T\<^sub>h (root_hash_F' (map_F\<^sub>m id id root_hash_T' id x))"

definition root_hash_T :: "('a\<^sub>m, 'a\<^sub>h) hash \<Rightarrow> (('a\<^sub>m, 'a\<^sub>h) T\<^sub>m, 'a\<^sub>h T\<^sub>h) hash" where
  "root_hash_T rha = root_hash_T' \<circ> map_T\<^sub>m rha id"

lemma root_hash_T_simps [simp]:
  "root_hash_T rha (T\<^sub>m x) = T\<^sub>h (root_hash_F rha (root_hash_T rha) x)"
  by(simp add: root_hash_T_def F\<^sub>m.map_comp root_hash_F_def T\<^sub>h.map_id0)

subsubsection \<open>Composition\<close>

primrec root_hash_G' :: "(('a\<^sub>h, 'a\<^sub>h, 'b\<^sub>h, 'b\<^sub>h) G\<^sub>m, ('a\<^sub>h, 'b\<^sub>h) G\<^sub>h) hash" where
  "root_hash_G' (G\<^sub>m x) = G\<^sub>h (root_hash_F' (map_F\<^sub>m root_hash_T' id id id x))"

definition root_hash_G :: "('a\<^sub>m, 'a\<^sub>h) hash \<Rightarrow> ('b\<^sub>m, 'b\<^sub>h) hash \<Rightarrow> (('a\<^sub>m, 'a\<^sub>h, 'b\<^sub>m, 'b\<^sub>h) G\<^sub>m, ('a\<^sub>h, 'b\<^sub>h) G\<^sub>h) hash" where
  "root_hash_G rha rhb = root_hash_G' \<circ> map_G\<^sub>m rha id rhb id"

lemma root_hash_G_unfold:
  "root_hash_G rha rhb = G\<^sub>h \<circ> root_hash_F (root_hash_T rha) rhb \<circ> the_G\<^sub>m"
  apply(rule ext)
  subgoal for x
    by(cases x)(simp add: root_hash_G_def fun_eq_iff root_hash_F_def root_hash_T_def F\<^sub>m.map_comp T\<^sub>m.map_comp o_def T\<^sub>h.map_id id_def[symmetric])
  done

lemma root_hash_G_simps [simp]:
  "root_hash_G rha rhb (G\<^sub>m x) = G\<^sub>h (root_hash_F (root_hash_T rha) rhb x)"
  by(simp add: root_hash_G_def root_hash_T_def F\<^sub>m.map_comp root_hash_F_def T\<^sub>h.map_id0)

subsection \<open>Blinding relation\<close>

text \<open>
The blinding relation determines whether one ADS value is a blinding of another.
\<close>

subsubsection \<open> Blinding on the base functor (@{type F\<^sub>m}) \<close>

type_synonym ('a\<^sub>m, 'a\<^sub>h, 'b\<^sub>m, 'b\<^sub>h) blinding_of_F =
  "('a\<^sub>m, 'a\<^sub>h) hash \<Rightarrow> 'a\<^sub>m blinding_of \<Rightarrow> ('b\<^sub>m, 'b\<^sub>h) hash \<Rightarrow> 'b\<^sub>m blinding_of \<Rightarrow> ('a\<^sub>m, 'a\<^sub>h, 'b\<^sub>m, 'b\<^sub>h) F\<^sub>m blinding_of"

\<comment> \<open> Computes whether a partially blinded ADS is a blinding of another one \<close>
axiomatization blinding_of_F :: "('a\<^sub>m, 'a\<^sub>h, 'b\<^sub>m, 'b\<^sub>h) blinding_of_F" where
  blinding_of_F_mono: "\<lbrakk> boa \<le> boa'; bob \<le> bob' \<rbrakk>
    \<Longrightarrow> blinding_of_F rha boa rhb bob \<le> blinding_of_F rha boa' rhb bob'"
    \<comment> \<open> Monotonicity must be unconditional (without the assumption @{text "blinding_of_on"})
         such that we can justify the recursive definition for the least fixpoint. \<close>
  and blinding_respects_hashes_F [locale_witness]:
  "\<lbrakk> blinding_respects_hashes rha boa; blinding_respects_hashes rhb bob \<rbrakk>
   \<Longrightarrow> blinding_respects_hashes (root_hash_F rha rhb) (blinding_of_F rha boa rhb bob)"
  and blinding_of_on_F [locale_witness]:
  "\<lbrakk> blinding_of_on A rha boa; blinding_of_on B rhb bob \<rbrakk>
   \<Longrightarrow> blinding_of_on {x. set1_F\<^sub>m x \<subseteq> A \<and> set3_F\<^sub>m x \<subseteq> B} (root_hash_F rha rhb) (blinding_of_F rha boa rhb bob)"

lemma blinding_of_F_mono_inductive:
  assumes a: "\<And>x y. boa x y \<longrightarrow> boa' x y"
    and b: "\<And>x y. bob x y \<longrightarrow> bob' x y"
  shows "blinding_of_F rha boa rhb bob x y \<longrightarrow> blinding_of_F rha boa' rhb bob' x y"
  using assms by(blast intro: blinding_of_F_mono[THEN predicate2D, OF predicate2I predicate2I])

subsubsection \<open> Blinding on least fixpoints \<close>

context
  fixes rh :: "('a\<^sub>m, 'a\<^sub>h) hash"
    and bo :: "'a\<^sub>m blinding_of"
begin

inductive blinding_of_T :: "('a\<^sub>m, 'a\<^sub>h) T\<^sub>m blinding_of" where
  "blinding_of_T (T\<^sub>m x) (T\<^sub>m y)" if
  "blinding_of_F rh bo (root_hash_T rh) blinding_of_T x y"
monos blinding_of_F_mono_inductive

end

lemma blinding_of_T_mono:
  assumes "bo \<le> bo'"
  shows "blinding_of_T rh bo \<le> blinding_of_T rh bo'"
  by(rule predicate2I; erule blinding_of_T.induct)
    (blast intro: blinding_of_T.intros blinding_of_F_mono[THEN predicate2D, OF assms, rotated -1])

lemma blinding_of_T_root_hash:
  assumes "bo \<le> vimage2p rh rh (=)"
  shows "blinding_of_T rh bo \<le> vimage2p (root_hash_T rh) (root_hash_T rh) (=)"
  apply(rule predicate2I vimage2pI)+
  apply(erule blinding_of_T.induct)
  apply simp
  apply(drule blinding_respects_hashes_F[unfolded blinding_respects_hashes_def, THEN predicate2D, rotated -1])
    apply(rule assms)
   apply(blast intro: vimage2pI)
  apply(simp add: vimage2p_def)
  done

lemma blinding_respects_hashes_T [locale_witness]:
  "blinding_respects_hashes rh bo \<Longrightarrow> blinding_respects_hashes (root_hash_T rh) (blinding_of_T rh bo)"
  unfolding blinding_respects_hashes_def by(rule blinding_of_T_root_hash)

lemma blinding_of_on_T [locale_witness]:
  assumes "blinding_of_on A rh bo"
  shows "blinding_of_on {x. set1_T\<^sub>m x \<subseteq> A} (root_hash_T rh) (blinding_of_T rh bo)"
  (is "blinding_of_on ?A ?h ?bo")
proof -
  interpret a: blinding_of_on A rh bo by fact
  show ?thesis
  proof
    have "?bo x x \<and> (?bo x y \<longrightarrow> ?bo y z \<longrightarrow> ?bo x z) \<and> (?bo x y \<longrightarrow> ?bo y x \<longrightarrow> x = y)"
      if "x \<in> ?A" for x y z using that
    proof(induction x arbitrary: y z)
      case (T\<^sub>m x)
      interpret blinding_of_on
        "{a. set1_F\<^sub>m a \<subseteq> A \<and> set3_F\<^sub>m a \<subseteq> set3_F\<^sub>m x}"
        "root_hash_F rh ?h"
        "blinding_of_F rh bo ?h ?bo"
        apply(rule blinding_of_on_F[OF assms])
        apply unfold_locales
        subgoal using T\<^sub>m.IH T\<^sub>m.prems by(force simp add: eq_onp_def)
        subgoal for a b c using T\<^sub>m.IH[of a b c] T\<^sub>m.prems by auto
        subgoal for a b using T\<^sub>m.IH[of a b] T\<^sub>m.prems by auto
        done
      show ?case using T\<^sub>m.prems
        apply(intro conjI)
        subgoal by(auto intro: blinding_of_T.intros refl)
        subgoal by(auto elim!: blinding_of_T.cases trans intro!: blinding_of_T.intros)
        subgoal by(auto elim!: blinding_of_T.cases dest: antisym)
        done
    qed
    then show "x \<in> ?A \<Longrightarrow> ?bo x x"
      and "\<lbrakk> ?bo x y; ?bo y z; x \<in> ?A \<rbrakk> \<Longrightarrow> ?bo x z"
      and "\<lbrakk> ?bo x y; ?bo y x; x \<in> ?A \<rbrakk> \<Longrightarrow> x = y"
      for x y z by blast+
  qed
qed

lemmas blinding_of_T [locale_witness] = blinding_of_on_T[where A=UNIV, simplified]

subsubsection \<open> Blinding on composition \<close>

context
  fixes rha :: "('a\<^sub>m, 'a\<^sub>h) hash"
    and boa :: "'a\<^sub>m blinding_of"
    and rhb :: "('b\<^sub>m, 'b\<^sub>h) hash"
    and bob :: "'b\<^sub>m blinding_of"
begin

inductive blinding_of_G :: "('a\<^sub>m, 'a\<^sub>h, 'b\<^sub>m, 'b\<^sub>h) G\<^sub>m blinding_of" where
  "blinding_of_G (G\<^sub>m x) (G\<^sub>m y)" if
  "blinding_of_F (root_hash_T rha) (blinding_of_T rha boa) rhb bob x y"

lemma blinding_of_G_unfold:
  "blinding_of_G = vimage2p the_G\<^sub>m the_G\<^sub>m (blinding_of_F (root_hash_T rha) (blinding_of_T rha boa) rhb bob)"
  apply(rule ext)+
  subgoal for x y by(cases x; cases y)(simp_all add: blinding_of_G.simps fun_eq_iff vimage2p_def)
  done

end

lemma blinding_of_G_mono:
  assumes "boa \<le> boa'" "bob \<le> bob'"
  shows "blinding_of_G rha boa rhb bob \<le> blinding_of_G rha boa' rhb bob'"
  unfolding blinding_of_G_unfold
  by(rule vimage2p_mono' blinding_of_F_mono blinding_of_T_mono assms)+

lemma blinding_of_G_root_hash:
  assumes "boa \<le> vimage2p rha rha (=)" and "bob \<le> vimage2p rhb rhb (=)"
  shows "blinding_of_G rha boa rhb bob \<le> vimage2p (root_hash_G rha rhb) (root_hash_G rha rhb) (=)"
  unfolding blinding_of_G_unfold root_hash_G_unfold vimage2p_comp o_apply
  apply(rule vimage2p_mono')
  apply(rule order_trans)
   apply(rule blinding_respects_hashes_F[unfolded blinding_respects_hashes_def])
    apply(rule blinding_of_T_root_hash)
    apply(rule assms)+
  apply(rule vimage2p_mono')
  apply(simp add: vimage2p_def)
  done

lemma blinding_of_on_G [locale_witness]:
  assumes "blinding_of_on A rha boa" "blinding_of_on B rhb bob"
  shows "blinding_of_on {x. set1_G\<^sub>m x \<subseteq> A \<and> set3_G\<^sub>m x \<subseteq> B} (root_hash_G rha rhb) (blinding_of_G rha boa rhb bob)"
  (is "blinding_of_on ?A ?h ?bo")
proof -
  interpret a: blinding_of_on A rha boa by fact
  interpret b: blinding_of_on B rhb bob by fact
  interpret FT: blinding_of_on
    "{x. set1_F\<^sub>m x \<subseteq> {x. set1_T\<^sub>m x \<subseteq> A} \<and> set3_F\<^sub>m x \<subseteq> B}"
    "root_hash_F (root_hash_T rha) rhb"
    "blinding_of_F (root_hash_T rha) (blinding_of_T rha boa) rhb bob"
    ..
  show ?thesis
  proof
    show "?bo \<le> vimage2p ?h ?h (=)"
      using a.hash b.hash
      by(rule blinding_of_G_root_hash)
    show "?bo x x" if "x \<in> ?A" for x using that
      by(cases x; hypsubst)(rule blinding_of_G.intros; rule FT.refl; auto)
    show "?bo x z" if "?bo x y" "?bo y z" "x \<in> ?A" for x y z using that
      by(fastforce elim!: blinding_of_G.cases intro!: blinding_of_G.intros elim!: FT.trans)
    show "x = y" if "?bo x y" "?bo y x" "x \<in> ?A" for x y using that
      by(clarsimp elim!: blinding_of_G.cases)(erule (1) FT.antisym; auto)
  qed
qed

lemmas blinding_of_G [locale_witness] = blinding_of_on_G[where A=UNIV and B=UNIV, simplified]

subsection \<open>Merging\<close>

text \<open>Two Merkle values with the same root hash can be merged into a less blinded Merkle value.
The operation is unspecified for trees with different root hashes.
\<close>

subsubsection \<open> Merging on the base functor \<close>

axiomatization merge_F :: "('a\<^sub>m, 'a\<^sub>h) hash \<Rightarrow> 'a\<^sub>m merge \<Rightarrow> ('b\<^sub>m, 'b\<^sub>h) hash \<Rightarrow> 'b\<^sub>m merge
  \<Rightarrow> ('a\<^sub>m, 'a\<^sub>h, 'b\<^sub>m, 'b\<^sub>h) F\<^sub>m merge" where
  merge_F_cong [fundef_cong]:
  "\<lbrakk> \<And>a b. a \<in> set1_F\<^sub>m x \<Longrightarrow> ma a b = ma' a b; \<And>a b. a \<in> set3_F\<^sub>m x \<Longrightarrow> mb a b = mb' a b \<rbrakk>
   \<Longrightarrow> merge_F rha ma rhb mb x y = merge_F rha ma' rhb mb' x y"
  and
  merge_on_F [locale_witness]:
  "\<lbrakk> merge_on A rha boa ma; merge_on B rhb bob mb \<rbrakk>
  \<Longrightarrow> merge_on {x. set1_F\<^sub>m x \<subseteq> A \<and> set3_F\<^sub>m x \<subseteq> B} (root_hash_F rha rhb) (blinding_of_F rha boa rhb bob) (merge_F rha ma rhb mb)"

lemmas merge_F [locale_witness] = merge_on_F[where A=UNIV and B=UNIV, simplified]

subsubsection \<open> Merging on the least fixpoint \<close>

lemma wfP_subterm_T: "wfP (\<lambda>x y. x \<in> set3_F\<^sub>m (the_T\<^sub>m y))"
  apply(rule wfPUNIVI)
  subgoal premises IH[rule_format] for P x
    by(induct x)(auto intro: IH)
  done

context
  fixes rh :: "('a\<^sub>m, 'a\<^sub>h) hash"
  fixes m :: "'a\<^sub>m merge"
begin

function merge_T :: "('a\<^sub>m, 'a\<^sub>h) T\<^sub>m merge" where
  "merge_T (T\<^sub>m x) (T\<^sub>m y) = map_option T\<^sub>m (merge_F rh m (root_hash_T rh) merge_T x y)"
  by pat_completeness auto
termination
  apply(relation "{(x, y). x \<in> set3_F\<^sub>m (the_T\<^sub>m y)} <*lex*> {(x, y). x \<in> set3_F\<^sub>m (the_T\<^sub>m y)}")
   apply(auto simp add: wfP_def[symmetric] wfP_subterm_T)
  done

lemma merge_on_T [locale_witness]:
  assumes "merge_on A rh bo m"
  shows "merge_on {x. set1_T\<^sub>m x \<subseteq> A} (root_hash_T rh) (blinding_of_T rh bo) merge_T"
  (is "merge_on ?A ?h ?bo ?m")
proof -
  interpret a: merge_on A rh bo m by fact
  show ?thesis
  proof
    have "(?h a = ?h b \<longrightarrow> (\<exists>ab. ?m a b = Some ab \<and> ?bo a ab \<and> ?bo b ab \<and> (\<forall>u. ?bo a u \<longrightarrow> ?bo b u \<longrightarrow> ?bo ab u))) \<and>
      (?h a \<noteq> ?h b \<longrightarrow> ?m a b = None)"
      if "a \<in> ?A" for a b using that unfolding mem_Collect_eq
    proof(induction a arbitrary: b)
      case (T\<^sub>m x y)
      interpret merge_on "{y. set1_F\<^sub>m y \<subseteq> A \<and> set3_F\<^sub>m y \<subseteq> set3_F\<^sub>m x}"
        "root_hash_F rh ?h" "blinding_of_F rh bo ?h ?bo" "merge_F rh m ?h ?m"
      proof
        fix a
        assume a: "a \<in> set3_F\<^sub>m x"
        with T\<^sub>m.prems have a': "set1_T\<^sub>m a \<subseteq> A" by auto

        fix b
        from T\<^sub>m.IH[OF a a', rule_format, of b]
        show "root_hash_T rh a = root_hash_T rh b
           \<Longrightarrow> \<exists>ab. merge_T a b = Some ab \<and> blinding_of_T rh bo a ab \<and> blinding_of_T rh bo b ab \<and>
                    (\<forall>u. blinding_of_T rh bo a u \<longrightarrow> blinding_of_T rh bo b u \<longrightarrow> blinding_of_T rh bo ab u)"
          and "root_hash_T rh a \<noteq> root_hash_T rh b \<Longrightarrow> merge_T a b = None"
          by(auto dest: sym)
      qed
      show ?case using T\<^sub>m.prems
        apply(intro conjI strip)
        subgoal by(cases y)(auto dest!: join simp add: blinding_of_T.simps)
        subgoal by(cases y)(auto dest!: undefined)
        done
    qed
    then show
      "?h a = ?h b \<Longrightarrow> \<exists>ab. ?m a b = Some ab \<and> ?bo a ab \<and> ?bo b ab \<and> (\<forall>u. ?bo a u \<longrightarrow> ?bo b u \<longrightarrow> ?bo ab u)"
      "?h a \<noteq> ?h b \<Longrightarrow> ?m a b = None"
      if "a \<in> ?A" for a b using that by blast+
  qed
qed

lemmas merge_T [locale_witness] = merge_on_T[where A=UNIV, simplified]

end

lemma merge_T_cong [fundef_cong]:
  assumes "\<And>a b. a \<in> set1_T\<^sub>m x \<Longrightarrow> m a b = m' a b"
  shows "merge_T rh m x y = merge_T rh m' x y"
  using assms
  apply(induction x y rule: merge_T.induct)
  apply simp
  apply(rule arg_cong[where f="map_option _"])
  apply(blast intro: merge_F_cong)
  done

subsubsection \<open> Merging and composition \<close>

context
  fixes rha :: "('a\<^sub>m, 'a\<^sub>h) hash"
  fixes ma :: "'a\<^sub>m merge"
  fixes rhb :: "('b\<^sub>m, 'b\<^sub>h) hash"
  fixes mb :: "'b\<^sub>m merge"
begin

primrec merge_G :: "('a\<^sub>m, 'a\<^sub>h, 'b\<^sub>m, 'b\<^sub>h) G\<^sub>m merge" where
  "merge_G (G\<^sub>m x) y' = (case y' of G\<^sub>m y \<Rightarrow>
    map_option G\<^sub>m (merge_F (root_hash_T rha) (merge_T rha ma) rhb mb x y))"

lemma merge_G_simps [simp]:
  "merge_G (G\<^sub>m x) (G\<^sub>m y) = map_option G\<^sub>m (merge_F (root_hash_T rha) (merge_T rha ma) rhb mb x y)"
  by(simp)

declare merge_G.simps [simp del]

lemma merge_on_G:
  assumes a: "merge_on A rha boa ma" and b: "merge_on B rhb bob mb"
  shows "merge_on {x. set1_G\<^sub>m x \<subseteq> A \<and> set3_G\<^sub>m x \<subseteq> B} (root_hash_G rha rhb) (blinding_of_G rha boa rhb bob) merge_G"
  (is "merge_on ?A ?h ?bo ?m")
proof -
  interpret a: merge_on A rha boa ma by fact
  interpret b: merge_on B rhb bob mb by fact
  interpret F: merge_on
    "{x. set1_F\<^sub>m x \<subseteq> {x. set1_T\<^sub>m x \<subseteq> A} \<and> set3_F\<^sub>m x \<subseteq> B}"
    "root_hash_F (root_hash_T rha) rhb"
    "blinding_of_F (root_hash_T rha) (blinding_of_T rha boa) rhb bob"
    "merge_F (root_hash_T rha) (merge_T rha ma) rhb mb"
    ..
  show ?thesis
  proof
    show "\<exists>ab. ?m a b = Some ab \<and> ?bo a ab \<and> ?bo b ab \<and> (\<forall>u. ?bo a u \<longrightarrow> ?bo b u \<longrightarrow> ?bo ab u)"
      if "?h a = ?h b" "a \<in> ?A" for a b using that
      by(cases a; cases b)(auto dest!: F.join simp add: blinding_of_G.simps)
    show "?m a b = None" if "?h a \<noteq> ?h b" "a \<in> ?A" for a b using that
      by(cases a; cases b)(auto dest!: F.undefined)
  qed
qed

lemmas merge_G [locale_witness] = merge_on_G[where A=UNIV and B=UNIV, simplified]

end

lemma merge_G_cong [fundef_cong]:
  "\<lbrakk> \<And>a b. a \<in> set1_G\<^sub>m x \<Longrightarrow> ma a b = ma' a b; \<And>a b. a \<in> set3_G\<^sub>m x \<Longrightarrow> mb a b = mb' a b \<rbrakk>
   \<Longrightarrow> merge_G rha ma rhb mb x y = merge_G rha ma' rhb mb' x y"
  apply(cases x; cases y; simp)
  apply(rule arg_cong[where f="map_option _"])
  apply(blast intro: merge_F_cong merge_T_cong)
  done

end


section \<open>Preliminaries\<close>

theory Term_Context
  imports First_Order_Terms.Term
    Knuth_Bendix_Order.Subterm_and_Context
    Polynomial_Factorization.Missing_List
begin

subsection \<open>Additional functionality on @{type term} and @{type ctxt}\<close>
subsubsection \<open>Positions\<close>

type_synonym pos = "nat list"
context
  notes conj_cong [fundef_cong]
begin

fun poss :: "('f, 'v) term \<Rightarrow> pos set" where
  "poss (Var x) = {[]}"
| "poss (Fun f ss) = {[]} \<union> {i # p | i p. i < length ss \<and> p \<in> poss (ss ! i)}"
end

fun hole_pos where
  "hole_pos \<box> = []"
| "hole_pos (More f ss D ts) = length ss # hole_pos D"

definition position_less_eq (infixl "\<le>\<^sub>p" 67) where
  "p \<le>\<^sub>p q \<longleftrightarrow> (\<exists> r. p @ r = q)"

abbreviation position_less (infixl "<\<^sub>p" 67) where
  "p <\<^sub>p q \<equiv> p \<noteq> q \<and> p \<le>\<^sub>p q"

definition position_par  (infixl "\<bottom>" 67) where
  "p \<bottom> q \<longleftrightarrow> \<not> (p \<le>\<^sub>p q) \<and> \<not> (q \<le>\<^sub>p p)"

fun remove_prefix where
  "remove_prefix (x # xs) (y # ys) = (if x = y then remove_prefix xs ys else None)"
| "remove_prefix [] ys = Some ys"
| "remove_prefix xs [] = None"

definition pos_diff  (infixl "-\<^sub>p" 67) where
  "p -\<^sub>p q = the (remove_prefix q p)"

fun subt_at :: "('f, 'v) term \<Rightarrow> pos \<Rightarrow> ('f, 'v) term" (infixl "|'_" 67) where
  "s |_ [] = s"
| "Fun f ss |_ (i # p) = (ss ! i) |_ p"
| "Var x |_ _ = undefined"

fun ctxt_at_pos where
  "ctxt_at_pos s [] = \<box>"
| "ctxt_at_pos (Fun f ss) (i # p) = More f (take i ss) (ctxt_at_pos (ss ! i) p) (drop (Suc i) ss)"
| "ctxt_at_pos (Var x) _ = undefined"

fun replace_term_at ("_[_ \<leftarrow> _]" [1000, 0, 0] 1000) where
  "replace_term_at s [] t = t"
| "replace_term_at (Var x) ps t = (Var x)"
| "replace_term_at (Fun f ts) (i # ps) t =
    (if i < length ts then Fun f (ts[i:=(replace_term_at (ts ! i) ps t)]) else Fun f ts)"

fun fun_at :: "('f, 'v) term \<Rightarrow> pos \<Rightarrow> ('f + 'v) option" where
  "fun_at (Var x) [] = Some (Inr x)"
| "fun_at (Fun f ts) [] = Some (Inl f)"
| "fun_at (Fun f ts) (i # p) = (if i < length ts then fun_at (ts ! i) p else None)"
| "fun_at _ _ = None"

subsubsection \<open>Computing the signature\<close>

fun funas_term where
  "funas_term (Var x) = {}"
| "funas_term (Fun f ts) = insert (f, length ts) (\<Union> (set (map funas_term ts)))"

fun funas_ctxt where
  "funas_ctxt \<box> = {}"
| "funas_ctxt (More f ss C ts) = (\<Union> (set (map funas_term ss))) \<union>
    insert (f, Suc (length ss + length ts)) (funas_ctxt C) \<union> (\<Union> (set (map funas_term ts)))"

subsubsection \<open>Groundness\<close>

fun ground where
  "ground (Var x) = False"
| "ground (Fun f ts) = (\<forall> t \<in> set ts. ground t)"

fun ground_ctxt where
  "ground_ctxt \<box> \<longleftrightarrow> True"
| "ground_ctxt (More f ss C ts) \<longleftrightarrow> (\<forall> t \<in> set ss. ground t) \<and> ground_ctxt C \<and> (\<forall> t \<in> set ts. ground t)"

subsubsection \<open>Depth\<close>
fun depth where
  "depth (Var x) = 0"
| "depth (Fun f []) = 0"
| "depth (Fun f ts) = Suc (Max (depth ` set ts))"

subsubsection \<open>Type conversion\<close>

text \<open>We require a function which adapts the type of variables of a term,
   so that states of the automaton and variables in the term language can be
   chosen independently.\<close>

abbreviation "map_vars_term f \<equiv> map_term (\<lambda> x. x) f"
abbreviation "map_funs_term f \<equiv> map_term f (\<lambda> x. x)"
abbreviation "map_both f \<equiv> map_prod f f"

definition adapt_vars :: "('f, 'q) term \<Rightarrow> ('f,'v)term" where
  [code del]: "adapt_vars \<equiv> map_vars_term (\<lambda>_. undefined)"

abbreviation "map_vars_ctxt f \<equiv> map_ctxt (\<lambda>x. x) f"
definition adapt_vars_ctxt :: "('f,'q)ctxt \<Rightarrow> ('f,'v)ctxt" where
  [code del]: "adapt_vars_ctxt = map_vars_ctxt (\<lambda>_. undefined)"

subsection \<open>Properties of @{type pos}\<close>

lemma position_less_eq_induct [consumes 1]:
  assumes "p \<le>\<^sub>p q" and "\<And> p. P p p"
    and "\<And> p q r. p \<le>\<^sub>p q \<Longrightarrow> P p q \<Longrightarrow> P p (q @ r)"
  shows "P p q" using assms
proof (induct p arbitrary: q)
  case Nil then show ?case
    by (metis append_Nil position_less_eq_def)
next
  case (Cons a p)
  then show ?case
    by (metis append_Nil2 position_less_eq_def)
qed

text \<open>We show the correspondence between the function @{const remove_prefix} and
the order on positions @{const position_less_eq}. Moreover how it can be used to
compute the difference of positions.\<close>

lemma remove_prefix_Nil [simp]:
  "remove_prefix xs xs = Some []"
  by (induct xs) auto

lemma remove_prefix_Some:
  assumes "remove_prefix xs ys = Some zs"
  shows "ys = xs @ zs" using assms
proof (induct xs arbitrary: ys)
  case (Cons x xs)
  show ?case using Cons(1)[of "tl ys"] Cons(2)
    by (cases ys) (auto split: if_splits)
qed auto

lemma remove_prefix_append:
  "remove_prefix xs (xs @ ys) = Some ys"
  by (induct xs) auto

lemma remove_prefix_iff:
  "remove_prefix xs ys = Some zs \<longleftrightarrow> ys = xs @ zs"
  using remove_prefix_Some remove_prefix_append
  by blast

lemma position_less_eq_remove_prefix:
  "p \<le>\<^sub>p q \<Longrightarrow> remove_prefix p q \<noteq> None"
  by (induct rule: position_less_eq_induct) (auto simp: remove_prefix_iff)

text \<open>Simplification rules on @{const position_less_eq}, @{const pos_diff},
  and @{const position_par}.\<close>

lemma position_less_refl [simp]: "p \<le>\<^sub>p p"
  by (auto simp: position_less_eq_def)

lemma position_less_eq_Cons [simp]:
  "(i # ps) \<le>\<^sub>p (j # qs) \<longleftrightarrow> i = j \<and> ps \<le>\<^sub>p qs"
  by (auto simp: position_less_eq_def)

lemma position_less_Nil_is_bot [simp]: "[] \<le>\<^sub>p p"
  by (auto simp: position_less_eq_def)

lemma position_less_Nil_is_bot2 [simp]: "p \<le>\<^sub>p [] \<longleftrightarrow> p = []"
  by (auto simp: position_less_eq_def)

lemma position_diff_Nil [simp]: "q -\<^sub>p [] = q"
  by (auto simp: pos_diff_def)

lemma position_diff_Cons [simp]:
  "(i # ps) -\<^sub>p (i # qs) = ps -\<^sub>p qs"
  by (auto simp: pos_diff_def)

lemma Nil_not_par [simp]:
  "[] \<bottom> p \<longleftrightarrow> False"
  "p \<bottom> [] \<longleftrightarrow> False"
  by (auto simp: position_par_def)

lemma par_not_refl [simp]: "p \<bottom> p \<longleftrightarrow> False"
  by (auto simp: position_par_def)

lemma par_Cons_iff:
  "(i # ps) \<bottom> (j # qs) \<longleftrightarrow> (i \<noteq> j \<or> ps \<bottom> qs)"
  by (auto simp: position_par_def)

text \<open>Simplification rules on @{const poss}.\<close>

lemma Nil_in_poss [simp]: "[] \<in> poss t"
  by (cases t) auto

lemma poss_Cons [simp]:
  "i # p \<in> poss t \<Longrightarrow> [i] \<in> poss t"
  by (cases t) auto

lemma poss_Cons_poss:
  "i # q \<in> poss t \<longleftrightarrow> i < length (args t) \<and> q \<in> poss (args t ! i)"
  by (cases t) auto

lemma poss_append_poss:
  "p @ q \<in> poss t \<longleftrightarrow> p \<in> poss t \<and> q \<in> poss (t |_ p)"
proof (induct p arbitrary: t)
  case (Cons i p)
  from Cons[of "args t ! i"] show ?case
    by (cases t) auto
qed auto

text \<open>Simplification rules on @{const hole_pos}\<close>

lemma hole_pos_map_vars [simp]:
  "hole_pos (map_vars_ctxt f C) = hole_pos C"
  by (induct C) auto

lemma hole_pos_in_ctxt_apply [simp]: "hole_pos C \<in> poss C\<langle>u\<rangle>"
  by (induct C) auto

subsection \<open>Properties of @{const ground} and @{const ground_ctxt}\<close>

lemma ground_vars_term_empty [simp]:
  "ground t \<Longrightarrow> vars_term t = {}"
  by (induct t) auto

lemma ground_map_term [simp]:
  "ground (map_term f h t) = ground t"
  by (induct t) auto

lemma ground_ctxt_apply [simp]:
  "ground C\<langle>t\<rangle> \<longleftrightarrow> ground_ctxt C \<and> ground t"
  by (induct C) auto

lemma ground_ctxt_comp [intro]:
  "ground_ctxt C \<Longrightarrow> ground_ctxt D \<Longrightarrow> ground_ctxt (C \<circ>\<^sub>c D)"
  by (induct C) auto

lemma ctxt_comp_n_pres_ground [intro]:
  "ground_ctxt C \<Longrightarrow> ground_ctxt (C^n)"
  by (induct n arbitrary: C) auto

lemma subterm_eq_pres_ground:
  assumes "ground s" and "s \<unrhd> t"
  shows "ground t" using assms(2,1)
  by (induct) auto

lemma ground_substD:
  "ground (l \<cdot> \<sigma>) \<Longrightarrow> x \<in> vars_term l \<Longrightarrow> ground (\<sigma> x)"
  by (induct l) auto

lemma ground_substI:
  "(\<And> x. x \<in> vars_term s \<Longrightarrow> ground (\<sigma> x)) \<Longrightarrow> ground (s \<cdot> \<sigma>)"
  by (induct s) auto

subsection \<open>Properties on signature induced by a term @{type term}/context @{type ctxt}\<close>

lemma funas_ctxt_apply [simp]:
  "funas_term C\<langle>t\<rangle> = funas_ctxt C \<union> funas_term t"
  by (induct C) auto

lemma funas_term_map [simp]:
  "funas_term (map_term f h t) = (\<lambda> (g, n). (f g, n)) ` funas_term t"
  by (induct t) auto

lemma funas_term_subst:
  "funas_term (l \<cdot> \<sigma>) = funas_term l \<union> (\<Union> (funas_term ` \<sigma> ` vars_term l))"
  by (induct l) auto

lemma funas_ctxt_comp [simp]:
  "funas_ctxt (C \<circ>\<^sub>c D) = funas_ctxt C \<union> funas_ctxt D"
  by (induct C) auto

lemma ctxt_comp_n_funas [simp]:
  "(f, v) \<in> funas_ctxt (C^n) \<Longrightarrow> (f, v) \<in> funas_ctxt C"
  by (induct n arbitrary: C) auto

lemma ctxt_comp_n_pres_funas [intro]:
  "funas_ctxt C \<subseteq> \<F> \<Longrightarrow> funas_ctxt (C^n) \<subseteq> \<F>"
  by (induct n arbitrary: C) auto

subsection \<open>Properties on subterm at given position @{const subt_at}\<close>

lemma subt_at_Cons_comp:
  "i # p \<in> poss s \<Longrightarrow> (s |_ [i]) |_ p = s |_ (i # p)"
  by (cases s) auto

lemma ctxt_at_pos_subt_at_pos:
  "p \<in> poss t \<Longrightarrow> (ctxt_at_pos t p)\<langle>u\<rangle> |_ p = u"
proof (induct p arbitrary: t)
  case (Cons i p)
  then show ?case using id_take_nth_drop
    by (cases t) (auto simp: nth_append)
qed auto

lemma ctxt_at_pos_subt_at_id:
  "p \<in> poss t \<Longrightarrow> (ctxt_at_pos t p)\<langle>t |_ p\<rangle> = t"
proof (induct p arbitrary: t)
  case (Cons i p)
  then show ?case using id_take_nth_drop
    by (cases t) force+
qed auto

lemma subst_at_ctxt_at_eq_termD:
  assumes "s = t" "p \<in> poss t"
  shows "s |_ p = t |_ p \<and> ctxt_at_pos s p = ctxt_at_pos t p" using assms
  by auto

lemma subst_at_ctxt_at_eq_termI:
  assumes "p \<in> poss s" "p \<in> poss t"
    and "s |_p = t |_ p"
    and "ctxt_at_pos s p = ctxt_at_pos t p"
  shows "s = t" using assms
  by (metis ctxt_at_pos_subt_at_id)

lemma subt_at_subterm_eq [intro!]:
  "p \<in> poss t \<Longrightarrow> t \<unrhd> t |_ p"
proof (induct p arbitrary: t)
  case (Cons i p)
  from Cons(1)[of "args t ! i"] Cons(2) show ?case
    by (cases t) force+
qed auto

lemma subt_at_subterm [intro!]:
  "p \<in> poss t \<Longrightarrow> p \<noteq> [] \<Longrightarrow>  t \<rhd> t |_ p"
proof (induct p arbitrary: t)
  case (Cons i p)
  from Cons(1)[of "args t ! i"] Cons(2) show ?case
    by (cases t) force+
qed auto

lemma ctxt_at_pos_hole_pos [simp]: "ctxt_at_pos C\<langle>s\<rangle> (hole_pos C) = C"
  by (induct C) auto

subsection \<open>Properties on replace terms at a given position
  @{const replace_term_at}\<close>

lemma replace_term_at_not_poss [simp]:
  "p \<notin> poss s \<Longrightarrow> s[p \<leftarrow> t] = s"
proof (induct s arbitrary: p)
  case (Var x) then show ?case by (cases p) auto
next
  case (Fun f ts) show ?case using Fun(1)[OF nth_mem] Fun(2)
    by (cases p) (auto simp: min_def intro!: nth_equalityI)
qed

lemma replace_term_at_replace_at_conv:
  "p \<in> poss s \<Longrightarrow> (ctxt_at_pos s p)\<langle>t\<rangle> = s[p \<leftarrow> t]"
  by (induct s arbitrary: p) (auto simp: upd_conv_take_nth_drop)

lemma parallel_replace_term_commute [ac_simps]:
  "p \<bottom> q \<Longrightarrow> s[p \<leftarrow> t][q \<leftarrow> u] = s[q \<leftarrow> u][p \<leftarrow> t]"
proof (induct s arbitrary: p q)
  case (Var x) then show ?case
    by (cases p; cases q) auto
next
  case (Fun f ts)
  from Fun(2) have "p \<noteq> []" "q \<noteq> []" by auto
  then obtain i j ps qs where [simp]: "p = i # ps" "q = j # qs"
    by (cases p; cases q) auto
  have "i \<noteq> j \<Longrightarrow> (Fun f ts)[p \<leftarrow> t][q \<leftarrow> u] = (Fun f ts)[q \<leftarrow> u][p \<leftarrow> t]"
    by (auto simp: list_update_swap)
  then show ?case using Fun(1)[OF nth_mem, of j ps qs] Fun(2)
    by (cases "i = j") (auto simp: par_Cons_iff)
qed

lemma replace_term_at_above [simp]:
  "p \<le>\<^sub>p q \<Longrightarrow> s[q \<leftarrow> t][p \<leftarrow> u] = s[p \<leftarrow> u]"
proof (induct p arbitrary: s q)
  case (Cons i p)
  show ?case using Cons(1)[of "tl q" "args s ! i"] Cons(2)
    by (cases q; cases s) auto
qed auto

lemma replace_term_at_below [simp]:
  "p <\<^sub>p q \<Longrightarrow> s[p \<leftarrow> t][q \<leftarrow> u] = s[p \<leftarrow> t[q -\<^sub>p p \<leftarrow> u]]"
proof (induct p arbitrary: s q)
  case (Cons i p)
  show ?case using Cons(1)[of "tl q" "args s ! i"] Cons(2)
    by (cases q; cases s) auto
qed auto

lemma replace_at_hole_pos [simp]: "C\<langle>s\<rangle>[hole_pos C \<leftarrow> t] = C\<langle>t\<rangle>"
  by (induct C) auto

subsection \<open>Properties on @{const adapt_vars} and @{const adapt_vars_ctxt}\<close>

lemma adapt_vars2:
  "adapt_vars (adapt_vars t) = adapt_vars t"
  by (induct t) (auto simp add: adapt_vars_def)

lemma adapt_vars_simps[code, simp]: "adapt_vars (Fun f ts) = Fun f (map adapt_vars ts)"
  by (induct ts, auto simp: adapt_vars_def)

lemma adapt_vars_reverse: "ground t \<Longrightarrow> adapt_vars t' = t \<Longrightarrow> adapt_vars t = t'"
  unfolding adapt_vars_def
proof (induct t arbitrary: t')
  case (Fun f ts)
  then show ?case by (cases t') (auto simp add: map_idI)
qed auto

lemma ground_adapt_vars [simp]: "ground (adapt_vars t) = ground t"
  by (simp add: adapt_vars_def)
lemma funas_term_adapt_vars[simp]: "funas_term (adapt_vars t) = funas_term t" by (simp add: adapt_vars_def)

lemma adapt_vars_adapt_vars[simp]: fixes t :: "('f,'v)term"
  assumes g: "ground t"
  shows "adapt_vars (adapt_vars t :: ('f,'w)term) = t"
proof -
  let ?t' = "adapt_vars t :: ('f,'w)term"
  have gt': "ground ?t'" using g by auto
  from adapt_vars_reverse[OF gt', of t] show ?thesis by blast
qed

lemma adapt_vars_inj:
  assumes "adapt_vars x = adapt_vars y" "ground x" "ground y"
  shows "x = y"
  using adapt_vars_adapt_vars assms by metis

lemma adapt_vars_ctxt_simps[simp, code]:
  "adapt_vars_ctxt (More f bef C aft) = More f (map adapt_vars bef) (adapt_vars_ctxt C) (map adapt_vars aft)"
  "adapt_vars_ctxt Hole = Hole" unfolding adapt_vars_ctxt_def adapt_vars_def by auto

lemma adapt_vars_ctxt[simp]: "adapt_vars (C \<langle> t \<rangle> ) = (adapt_vars_ctxt C) \<langle> adapt_vars t \<rangle>"
  by (induct C, auto)

lemma adapt_vars_subst[simp]: "adapt_vars (l \<cdot> \<sigma>) = l \<cdot> (\<lambda> x. adapt_vars (\<sigma> x))"
  unfolding adapt_vars_def
  by (induct l) auto

lemma adapt_vars_gr_map_vars [simp]:
  "ground t \<Longrightarrow> map_vars_term f t = adapt_vars t"
  by (induct t) auto

lemma adapt_vars_gr_ctxt_of_map_vars [simp]:
  "ground_ctxt C \<Longrightarrow> map_vars_ctxt f C = adapt_vars_ctxt C"
  by (induct C) auto

subsubsection \<open>Equality on ground terms/contexts by positions and symbols\<close>

lemma fun_at_def':
  "fun_at t p = (if p \<in> poss t then
    (case t |_ p of Var x \<Rightarrow> Some (Inr x) | Fun f ts \<Rightarrow> Some (Inl f)) else None)"
  by (induct t p rule: fun_at.induct) auto

lemma fun_at_None_nposs_iff:
  "fun_at t p = None \<longleftrightarrow> p \<notin> poss t"
  by (auto simp: fun_at_def') (meson term.case_eq_if)

lemma eq_term_by_poss_fun_at:
  assumes "poss s = poss t" "\<And>p. p \<in> poss s \<Longrightarrow> fun_at s p = fun_at t p"
  shows "s = t"
  using assms
proof (induct s arbitrary: t)
  case (Var x) then show ?case
    by (cases t) simp_all
next
  case (Fun f ss) note Fun' = this
  show ?case
  proof (cases t)
    case (Var x) show ?thesis using Fun'(3)[of "[]"] by (simp add: Var)
  next
    case (Fun g ts)
    have *: "length ss = length ts"
      using Fun'(3) arg_cong[OF Fun'(2), of "\<lambda>P. card {i |i p. i # p \<in> P}"]
      by (auto simp: Fun exI[of "\<lambda>x. x \<in> poss _", OF Nil_in_poss])
    then have "i < length ss \<Longrightarrow> poss (ss ! i) = poss (ts ! i)" for i
      using arg_cong[OF Fun'(2), of "\<lambda>P. {p. i # p \<in> P}"] by (auto simp: Fun)
    then show ?thesis using * Fun'(2) Fun'(3)[of "[]"] Fun'(3)[of "_ # _ :: pos"]
      by (auto simp: Fun intro!: nth_equalityI Fun'(1)[OF nth_mem, of n "ts ! n" for n])
  qed
qed

lemma eq_ctxt_at_pos_by_poss:
  assumes "p \<in> poss s" "p \<in> poss t"
    and "\<And> q. \<not> (p \<le>\<^sub>p q) \<Longrightarrow> q \<in> poss s \<longleftrightarrow> q \<in> poss t"
    and "(\<And> q. q \<in> poss s \<Longrightarrow> \<not> (p \<le>\<^sub>p q) \<Longrightarrow> fun_at s q = fun_at t q)"
  shows "ctxt_at_pos s p = ctxt_at_pos t p" using assms
proof (induct p arbitrary: s t)
  case (Cons i p)
  from Cons(2, 3) Cons(4, 5)[of "[]"] obtain f ss ts where [simp]: "s = Fun f ss" "t = Fun f ts"
    by (cases s; cases t) auto
  have flt: "j < i \<Longrightarrow> j # q \<in> poss s \<Longrightarrow> fun_at s (j # q) = fun_at t (j # q)" for j q
    by (intro Cons(5)) auto
  have fgt: "i < j \<Longrightarrow> j # q \<in> poss s \<Longrightarrow> fun_at s (j # q) = fun_at t (j # q)" for j q
    by (intro Cons(5)) auto
  have lt: "j < i \<Longrightarrow> j # q \<in> poss s \<longleftrightarrow> j # q \<in> poss t" for j q by (intro Cons(4)) auto
  have gt: "i < j \<Longrightarrow> j # q \<in> poss s \<longleftrightarrow> j # q \<in> poss t" for j q by (intro Cons(4)) auto
  from this[of _ "[]"] have "i < j \<Longrightarrow> j < length ss \<longleftrightarrow> j < length ts" for j by auto
  from this Cons(2, 3) have l: "length ss = length ts" by auto (meson nat_neq_iff)
  have "ctxt_at_pos (ss ! i) p = ctxt_at_pos (ts ! i) p" using Cons(2, 3) Cons(4-)[of "i # q" for q]
    by (intro Cons(1)[of "ss ! i" "ts ! i"]) auto
  moreover have "take i ss = take i ts" using l lt Cons(2, 3) flt
    by (intro nth_equalityI) (auto intro!: eq_term_by_poss_fun_at)
  moreover have "drop (Suc i) ss = drop (Suc i) ts" using l Cons(2, 3) fgt gt[of "Suc i + j" for j]
    by (intro nth_equalityI) (auto simp: nth_map intro!: eq_term_by_poss_fun_at, fastforce+)
  ultimately show ?case by auto
qed auto

subsection \<open>Misc\<close>

lemma fun_at_hole_pos_ctxt_apply [simp]:
  "fun_at C\<langle>t\<rangle> (hole_pos C) = fun_at t []"
  by (induct C) auto

lemma vars_term_ctxt_apply [simp]:
  "vars_term C\<langle>t\<rangle> = vars_ctxt C \<union> vars_term t"
  by (induct C arbitrary: t) auto

lemma map_vars_term_ctxt_apply:
  "map_vars_term f C\<langle>t\<rangle> = (map_vars_ctxt f C)\<langle>map_vars_term f t\<rangle>"
  by (induct C) auto

lemma map_term_replace_at_dist:
  "p \<in> poss s \<Longrightarrow> (map_term f g s)[p \<leftarrow> (map_term f g t)] = map_term f g (s[p \<leftarrow> t])"
proof (induct p arbitrary: s)
  case (Cons i p) then show ?case
    by (cases s) (auto simp: nth_list_update intro!: nth_equalityI)
qed auto

end