theory Canton_Transaction_Tree imports
  Inclusion_Proof_Construction
begin

section \<open>Canton's hierarchical transaction trees\<close>

typedecl view_data
typedecl view_metadata
typedecl common_metadata
typedecl participant_metadata

datatype view = View view_metadata view_data (subviews: "view list")

datatype transaction = Transaction common_metadata participant_metadata (views: "view list")

subsection \<open>Views as authenticated data structures\<close>

type_synonym view_metadata\<^sub>h = "view_metadata blindable\<^sub>h"
type_synonym view_data\<^sub>h = "view_data blindable\<^sub>h"

datatype view\<^sub>h = View\<^sub>h "((view_metadata\<^sub>h \<times>\<^sub>h view_data\<^sub>h) \<times>\<^sub>h view\<^sub>h list\<^sub>h) blindable\<^sub>h"

type_synonym view_metadata\<^sub>m = "(view_metadata, view_metadata) blindable\<^sub>m"
type_synonym view_data\<^sub>m = "(view_data, view_data) blindable\<^sub>m"

datatype view\<^sub>m = View\<^sub>m
  "((view_metadata\<^sub>m \<times>\<^sub>m view_data\<^sub>m) \<times>\<^sub>m view\<^sub>m list\<^sub>m,
    (view_metadata\<^sub>h \<times>\<^sub>h view_data\<^sub>h) \<times>\<^sub>h view\<^sub>h list\<^sub>h) blindable\<^sub>m"

abbreviation (input) hash_view_data :: "(view_data\<^sub>m, view_data\<^sub>h) hash" where
  "hash_view_data \<equiv> hash_blindable id"
abbreviation (input) blinding_of_view_data :: "view_data\<^sub>m blinding_of" where
  "blinding_of_view_data \<equiv> blinding_of_blindable id (=)"
abbreviation (input) merge_view_data :: "view_data\<^sub>m merge" where
  "merge_view_data \<equiv> merge_blindable id merge_discrete"

lemma merkle_view_data:
  "merkle_interface hash_view_data blinding_of_view_data merge_view_data"
  by unfold_locales

abbreviation (input) hash_view_metadata :: "(view_metadata\<^sub>m, view_metadata\<^sub>h) hash" where
  "hash_view_metadata \<equiv> hash_blindable id"
abbreviation (input) blinding_of_view_metadata :: "view_metadata\<^sub>m blinding_of" where
  "blinding_of_view_metadata \<equiv> blinding_of_blindable id (=)"
abbreviation (input) merge_view_metadata :: "view_metadata\<^sub>m merge" where
  "merge_view_metadata \<equiv> merge_blindable id merge_discrete"

lemma merkle_view_metadata:
  "merkle_interface hash_view_metadata blinding_of_view_metadata merge_view_metadata"
  by unfold_locales

type_synonym view_content = "view_metadata \<times> view_data"
type_synonym view_content\<^sub>h = "view_metadata\<^sub>h \<times>\<^sub>h view_data\<^sub>h"
type_synonym view_content\<^sub>m = "view_metadata\<^sub>m \<times>\<^sub>m view_data\<^sub>m"

locale view_merkle begin

type_synonym view\<^sub>h' = "view_content\<^sub>h rose_tree\<^sub>h"

primrec from_view\<^sub>h :: "view\<^sub>h \<Rightarrow> view\<^sub>h'" where
  "from_view\<^sub>h (View\<^sub>h x) = Tree\<^sub>h (map_blindable\<^sub>h (map_prod id (map from_view\<^sub>h)) x)"

primrec to_view\<^sub>h :: "view\<^sub>h' \<Rightarrow> view\<^sub>h" where
  "to_view\<^sub>h (Tree\<^sub>h x) = View\<^sub>h (map_blindable\<^sub>h (map_prod id (map to_view\<^sub>h)) x)"

lemma from_to_view\<^sub>h [simp]: "from_view\<^sub>h (to_view\<^sub>h x) = x"
  apply(induction x)
  apply(simp add: blindable\<^sub>h.map_comp o_def prod.map_comp)
  apply(simp cong: blindable\<^sub>h.map_cong prod.map_cong list.map_cong add: blindable\<^sub>h.map_id[unfolded id_def])
  done

lemma to_from_view\<^sub>h [simp]: "to_view\<^sub>h (from_view\<^sub>h x) = x"
  apply(induction x)
  apply(simp add: blindable\<^sub>h.map_comp o_def prod.map_comp)
  apply(simp cong: blindable\<^sub>h.map_cong prod.map_cong list.map_cong add: blindable\<^sub>h.map_id[unfolded id_def])
  done

lemma iso_view\<^sub>h: "type_definition from_view\<^sub>h to_view\<^sub>h UNIV"
  by unfold_locales simp_all

setup_lifting iso_view\<^sub>h

lemma cr_view\<^sub>h_Grp: "cr_view\<^sub>h = Grp UNIV to_view\<^sub>h"
  by(simp add: cr_view\<^sub>h_def Grp_def fun_eq_iff)(transfer, auto)

lemma View\<^sub>h_transfer [transfer_rule]: includes lifting_syntax shows
  "(rel_blindable\<^sub>h (rel_prod (=) (list_all2 pcr_view\<^sub>h)) ===> pcr_view\<^sub>h) Tree\<^sub>h View\<^sub>h"
  by(simp add: rel_fun_def view\<^sub>h.pcr_cr_eq cr_view\<^sub>h_Grp list.rel_Grp eq_alt prod.rel_Grp blindable\<^sub>h.rel_Grp)
    (simp add: Grp_def)

type_synonym view\<^sub>m' = "(view_content\<^sub>m, view_content\<^sub>h) rose_tree\<^sub>m"

primrec from_view\<^sub>m :: "view\<^sub>m \<Rightarrow> view\<^sub>m'" where
  "from_view\<^sub>m (View\<^sub>m x) = Tree\<^sub>m (map_blindable\<^sub>m (map_prod id (map from_view\<^sub>m)) (map_prod id (map from_view\<^sub>h)) x)"

primrec to_view\<^sub>m :: "view\<^sub>m' \<Rightarrow> view\<^sub>m" where
  "to_view\<^sub>m (Tree\<^sub>m x) = View\<^sub>m (map_blindable\<^sub>m (map_prod id (map to_view\<^sub>m)) (map_prod id (map to_view\<^sub>h)) x)"

lemma from_to_view\<^sub>m [simp]: "from_view\<^sub>m (to_view\<^sub>m x) = x"
  apply(induction x)
  apply(simp add: blindable\<^sub>m.map_comp o_def prod.map_comp)
  apply(simp cong: blindable\<^sub>m.map_cong prod.map_cong list.map_cong add: blindable\<^sub>m.map_id[unfolded id_def])
  done

lemma to_from_view\<^sub>m [simp]: "to_view\<^sub>m (from_view\<^sub>m x) = x"
  apply(induction x)
  apply(simp add: blindable\<^sub>m.map_comp o_def prod.map_comp)
  apply(simp cong: blindable\<^sub>m.map_cong prod.map_cong list.map_cong add: blindable\<^sub>m.map_id[unfolded id_def])
  done

lemma iso_view\<^sub>m: "type_definition from_view\<^sub>m to_view\<^sub>m UNIV"
  by unfold_locales simp_all

setup_lifting iso_view\<^sub>m

lemma cr_view\<^sub>m_Grp: "cr_view\<^sub>m = Grp UNIV to_view\<^sub>m"
  by(simp add: cr_view\<^sub>m_def Grp_def fun_eq_iff)(transfer, auto)

lemma View\<^sub>m_transfer [transfer_rule]: includes lifting_syntax shows
  "(rel_blindable\<^sub>m (rel_prod (=) (list_all2 pcr_view\<^sub>m)) (rel_prod (=) (list_all2 pcr_view\<^sub>h)) ===> pcr_view\<^sub>m) Tree\<^sub>m View\<^sub>m"
  by(simp add: rel_fun_def view\<^sub>h.pcr_cr_eq view\<^sub>m.pcr_cr_eq cr_view\<^sub>h_Grp cr_view\<^sub>m_Grp list.rel_Grp eq_alt prod.rel_Grp blindable\<^sub>m.rel_Grp)
    (simp add: Grp_def)

end

code_datatype View\<^sub>h
code_datatype View\<^sub>m

context begin
interpretation view_merkle .

abbreviation (input) hash_view_content :: "(view_content\<^sub>m, view_content\<^sub>h) hash" where
  "hash_view_content \<equiv> hash_prod hash_view_metadata hash_view_data"

abbreviation (input) blinding_of_view_content :: "view_content\<^sub>m blinding_of" where
  "blinding_of_view_content \<equiv> blinding_of_prod blinding_of_view_metadata blinding_of_view_data"

abbreviation (input) merge_view_content :: "view_content\<^sub>m merge" where
  "merge_view_content \<equiv> merge_prod merge_view_metadata merge_view_data"

lift_definition hash_view :: "(view\<^sub>m, view\<^sub>h) hash" is
  "hash_tree hash_view_content" .

lift_definition blinding_of_view :: "view\<^sub>m blinding_of" is
  "blinding_of_tree hash_view_content blinding_of_view_content" .

lift_definition merge_view :: "view\<^sub>m merge" is
  "merge_tree hash_view_content merge_view_content" .

lemma merkle_view [locale_witness]: "merkle_interface hash_view blinding_of_view merge_view"
  by transfer unfold_locales

lemma hash_view_simps [simp]:
  "hash_view (View\<^sub>m x) =
   View\<^sub>h (hash_blindable (hash_prod hash_view_content (hash_list hash_view)) x)"
  by transfer(simp add: hash_rt_F\<^sub>m_def prod.map_comp hash_blindable_def blindable\<^sub>m.map_id)

lemma blinding_of_view_iff [simp]:
  "blinding_of_view (View\<^sub>m x) (View\<^sub>m y) \<longleftrightarrow>
   blinding_of_blindable (hash_prod hash_view_content (hash_list hash_view))
     (blinding_of_prod blinding_of_view_content (blinding_of_list blinding_of_view)) x y"
  by transfer simp

lemma blinding_of_view_induct [consumes 1, induct pred: blinding_of_view]:
  assumes "blinding_of_view x y"
    and "\<And>x y. blinding_of_blindable (hash_prod hash_view_content (hash_list hash_view))
             (blinding_of_prod blinding_of_view_content (blinding_of_list (\<lambda>x y. blinding_of_view x y \<and> P x y))) x y
         \<Longrightarrow> P (View\<^sub>m x) (View\<^sub>m y)"
  shows "P x y"
  using assms by transfer(rule blinding_of_tree.induct)

lemma merge_view_simps [simp]:
  "merge_view (View\<^sub>m x) (View\<^sub>m y) =
   map_option View\<^sub>m (merge_rt_F\<^sub>m hash_view_content merge_view_content hash_view merge_view x y)"
  by transfer simp

end

subsection \<open>Transaction trees as authenticated data structures\<close>

type_synonym common_metadata\<^sub>h = "common_metadata blindable\<^sub>h"
type_synonym common_metadata\<^sub>m = "(common_metadata, common_metadata) blindable\<^sub>m"

type_synonym participant_metadata\<^sub>h = "participant_metadata blindable\<^sub>h"
type_synonym participant_metadata\<^sub>m = "(participant_metadata, participant_metadata) blindable\<^sub>m"

datatype transaction\<^sub>h = Transaction\<^sub>h
  (the_Transaction\<^sub>h: "((common_metadata\<^sub>h \<times>\<^sub>h participant_metadata\<^sub>h) \<times>\<^sub>h view\<^sub>h list\<^sub>h) blindable\<^sub>h")

datatype transaction\<^sub>m = Transaction\<^sub>m
  (the_Transaction\<^sub>m: "((common_metadata\<^sub>m \<times>\<^sub>m participant_metadata\<^sub>m) \<times>\<^sub>m view\<^sub>m list\<^sub>m,
    (common_metadata\<^sub>h \<times>\<^sub>h participant_metadata\<^sub>h) \<times>\<^sub>h view\<^sub>h list\<^sub>h) blindable\<^sub>m")

abbreviation (input) hash_common_metadata :: "(common_metadata\<^sub>m, common_metadata\<^sub>h) hash" where
  "hash_common_metadata \<equiv> hash_blindable id"
abbreviation (input) blinding_of_common_metadata :: "common_metadata\<^sub>m blinding_of" where
  "blinding_of_common_metadata \<equiv> blinding_of_blindable id (=)"
abbreviation (input) merge_common_metadata :: "common_metadata\<^sub>m merge" where
  "merge_common_metadata \<equiv> merge_blindable id merge_discrete"

abbreviation (input) hash_participant_metadata :: "(participant_metadata\<^sub>m, participant_metadata\<^sub>h) hash" where
  "hash_participant_metadata \<equiv> hash_blindable id"
abbreviation (input) blinding_of_participant_metadata :: "participant_metadata\<^sub>m blinding_of" where
  "blinding_of_participant_metadata \<equiv> blinding_of_blindable id (=)"
abbreviation (input) merge_participant_metadata :: "participant_metadata\<^sub>m merge" where
  "merge_participant_metadata \<equiv> merge_blindable id merge_discrete"

locale transaction_merkle begin

lemma iso_transaction\<^sub>h: "type_definition the_Transaction\<^sub>h Transaction\<^sub>h UNIV"
  by unfold_locales simp_all

setup_lifting iso_transaction\<^sub>h

lemma Transaction\<^sub>h_transfer [transfer_rule]: includes lifting_syntax shows
  "((=) ===> pcr_transaction\<^sub>h) id Transaction\<^sub>h"
  by(simp add: transaction\<^sub>h.pcr_cr_eq cr_transaction\<^sub>h_def rel_fun_def)

lemma iso_transaction\<^sub>m: "type_definition the_Transaction\<^sub>m Transaction\<^sub>m UNIV"
  by unfold_locales simp_all

setup_lifting iso_transaction\<^sub>m

lemma Transaction\<^sub>m_transfer [transfer_rule]: includes lifting_syntax shows
  "((=) ===> pcr_transaction\<^sub>m) id Transaction\<^sub>m"
  by(simp add: transaction\<^sub>m.pcr_cr_eq cr_transaction\<^sub>m_def rel_fun_def)

end

code_datatype Transaction\<^sub>h
code_datatype Transaction\<^sub>m

context begin
interpretation transaction_merkle .

lift_definition hash_transaction :: "(transaction\<^sub>m, transaction\<^sub>h) hash" is
  "hash_blindable (hash_prod (hash_prod hash_common_metadata hash_participant_metadata) (hash_list hash_view))" .

lift_definition blinding_of_transaction :: "transaction\<^sub>m blinding_of" is
  "blinding_of_blindable
     (hash_prod (hash_prod hash_common_metadata hash_participant_metadata) (hash_list hash_view))
     (blinding_of_prod (blinding_of_prod blinding_of_common_metadata blinding_of_participant_metadata) (blinding_of_list blinding_of_view))" .

lift_definition merge_transaction :: "transaction\<^sub>m merge" is
  "merge_blindable
     (hash_prod (hash_prod hash_common_metadata hash_participant_metadata) (hash_list hash_view))
     (merge_prod (merge_prod merge_common_metadata merge_participant_metadata) (merge_list merge_view))" .

lemma merkle_transaction [locale_witness]:
  "merkle_interface hash_transaction blinding_of_transaction merge_transaction"
  by transfer unfold_locales

lemmas hash_transaction_simps [simp] = hash_transaction.abs_eq
lemmas blinding_of_transaction_iff [simp] = blinding_of_transaction.abs_eq
lemmas merge_transaction_simps [simp] = merge_transaction.abs_eq

end

interpretation transaction:
  merkle_interface hash_transaction blinding_of_transaction merge_transaction
  by(rule merkle_transaction)

subsection \<open>
Constructing authenticated data structures for views
\<close>

context view_merkle begin

type_synonym view' = "(view_metadata \<times> view_data) rose_tree"

primrec from_view :: "view \<Rightarrow> view'" where
  "from_view (View vm vd vs) = Tree ((vm, vd), map from_view vs)"

primrec to_view :: "view' \<Rightarrow> view" where
  "to_view (Tree x) = View (fst (fst x)) (snd (fst x)) (snd (map_prod id (map to_view) x))"

lemma from_to_view [simp]: "from_view (to_view x) = x"
  by(induction x)(clarsimp cong: map_cong)

lemma to_from_view [simp]: "to_view (from_view x) = x"
  by(induction x)(clarsimp cong: map_cong)

lemma iso_view: "type_definition from_view to_view UNIV"
  by unfold_locales simp_all

setup_lifting iso_view

definition View' :: "(view_metadata \<times> view_data) \<times> view list \<Rightarrow> view" where
  "View' = (\<lambda>((vm, vd), vs). View vm vd vs)"

lemma View_View': "View = (\<lambda>vm vd vs. View' ((vm, vd), vs))"
  by(simp add: View'_def)

lemma cr_view_Grp: "cr_view = Grp UNIV to_view"
  by(simp add: cr_view_def Grp_def fun_eq_iff)(transfer, auto)

lemma View'_transfer [transfer_rule]: includes lifting_syntax shows
  "(rel_prod (=) (list_all2 pcr_view) ===> pcr_view) Tree View'"
  by(simp add: view.pcr_cr_eq cr_view_Grp eq_alt prod.rel_Grp rose_tree.rel_Grp list.rel_Grp)
    (auto simp add: Grp_def View'_def)

end

code_datatype View

context begin
interpretation view_merkle .

abbreviation embed_view_content :: "view_metadata \<times> view_data \<Rightarrow> view_metadata\<^sub>m \<times> view_data\<^sub>m" where
  "embed_view_content \<equiv> map_prod Unblinded Unblinded"

lift_definition embed_view :: "view \<Rightarrow> view\<^sub>m" is "embed_source_tree embed_view_content" .

lemma embed_view_simps [simp]:
  "embed_view (View vm vd vs) = View\<^sub>m (Unblinded ((Unblinded vm, Unblinded vd), map embed_view vs))"
  unfolding View_View' by transfer simp

end

context transaction_merkle begin

primrec the_Transaction :: "transaction \<Rightarrow> (common_metadata \<times> participant_metadata) \<times> view list" where
  "the_Transaction (Transaction cm pm views) = ((cm, pm), views)" for views

definition Transaction' :: "(common_metadata \<times> participant_metadata) \<times> view list \<Rightarrow> transaction" where
  "Transaction' = (\<lambda>((cm, pm), views). Transaction cm pm views)"

lemma Transaction_Transaction': "Transaction = (\<lambda>cm pm views. Transaction' ((cm, pm), views))"
  by(simp add: Transaction'_def)

lemma the_Transaction_inverse [simp]: "Transaction' (the_Transaction x) = x"
  by(cases x)(simp add: Transaction'_def)

lemma Transaction'_inverse [simp]: "the_Transaction (Transaction' x) = x"
  by(simp add: Transaction'_def split_def)

lemma iso_transaction: "type_definition the_Transaction Transaction' UNIV"
  by unfold_locales simp_all

setup_lifting iso_transaction

lemma Transaction'_transfer [transfer_rule]: includes lifting_syntax shows
  "((=) ===> pcr_transaction) id Transaction'"
  by(simp add: transaction.pcr_cr_eq cr_transaction_def rel_fun_def)

end

code_datatype Transaction

context begin
interpretation transaction_merkle .

lift_definition embed_transaction :: "transaction \<Rightarrow> transaction\<^sub>m" is
  "Unblinded \<circ> map_prod (map_prod Unblinded Unblinded) (map embed_view)" .

lemma embed_transaction_simps [simp]:
  "embed_transaction (Transaction cm pm views) =
   Transaction\<^sub>m (Unblinded ((Unblinded cm, Unblinded pm), map embed_view views))"
  for views unfolding Transaction_Transaction' by transfer simp

end

subsubsection \<open>Inclusion proof for the mediator\<close>

primrec mediator_view :: "view \<Rightarrow> view\<^sub>m" where
  "mediator_view (View vm vd vs) =
   View\<^sub>m (Unblinded ((Unblinded vm, Blinded (Content vd)), map mediator_view vs))"

primrec mediator_transaction_tree :: "transaction \<Rightarrow> transaction\<^sub>m" where
  "mediator_transaction_tree (Transaction cm pm views) =
   Transaction\<^sub>m (Unblinded ((Unblinded cm, Blinded (Content pm)), map mediator_view views))"
  for views

lemma blinding_of_mediator_view [simp]: "blinding_of_view (mediator_view view) (embed_view view)"
  by(induction view)(auto simp add: list.rel_map intro!: list.rel_refl_strong)

lemma blinding_of_mediator_transaction_tree:
  "blinding_of_transaction (mediator_transaction_tree tt) (embed_transaction tt)"
  by(cases tt)(auto simp add: list.rel_map intro: list.rel_refl_strong)

subsubsection \<open>Inclusion proofs for participants\<close>

text \<open>Next, we define a function for producing all transaction views from a given view,
  and prove its properties.\<close>

type_synonym view_path_elem = "(view_metadata \<times> view_data) blindable \<times> view list \<times> view list"
type_synonym view_path = "view_path_elem list"
type_synonym view_zipper = "view_path \<times> view"

type_synonym view_path_elem\<^sub>m = "(view_metadata\<^sub>m \<times>\<^sub>m view_data\<^sub>m) \<times> view\<^sub>m list\<^sub>m \<times> view\<^sub>m list\<^sub>m"
type_synonym view_path\<^sub>m = "view_path_elem\<^sub>m list"
type_synonym view_zipper\<^sub>m = "view_path\<^sub>m \<times> view\<^sub>m"

context begin
interpretation view_merkle .

lift_definition zipper_of_view :: "view \<Rightarrow> view_zipper" is zipper_of_tree .
lift_definition view_of_zipper :: "view_zipper \<Rightarrow> view" is tree_of_zipper .

lift_definition zipper_of_view\<^sub>m :: "view\<^sub>m \<Rightarrow> view_zipper\<^sub>m" is zipper_of_tree\<^sub>m .
lift_definition view_of_zipper\<^sub>m :: "view_zipper\<^sub>m \<Rightarrow> view\<^sub>m" is tree_of_zipper\<^sub>m .

lemma view_of_zipper\<^sub>m_Nil [simp]: "view_of_zipper\<^sub>m ([], t) = t"
  by transfer simp

lift_definition blind_view_path_elem :: "view_path_elem \<Rightarrow> view_path_elem\<^sub>m" is
  "blind_path_elem embed_view_content hash_view_content" .

lift_definition blind_view_path :: "view_path \<Rightarrow> view_path\<^sub>m" is
  "blind_path embed_view_content hash_view_content" .

lift_definition embed_view_path_elem :: "view_path_elem \<Rightarrow> view_path_elem\<^sub>m" is
  "embed_path_elem embed_view_content" .

lift_definition embed_view_path :: "view_path \<Rightarrow> view_path\<^sub>m" is
  "embed_path embed_view_content" .

lift_definition hash_view_path_elem :: "view_path_elem\<^sub>m \<Rightarrow> (view_content\<^sub>h \<times> view\<^sub>h list \<times> view\<^sub>h list)" is
  "hash_path_elem hash_view_content" .

lift_definition zippers_view :: "view_zipper \<Rightarrow> view_zipper\<^sub>m list" is
  "zippers_rose_tree embed_view_content hash_view_content" .

lemma embed_view_path_Nil [simp]: "embed_view_path [] = []"
  by transfer(simp add: embed_path_def)

lemma zippers_view_same_hash:
  assumes "z \<in> set (zippers_view (p, t))"
  shows "hash_view (view_of_zipper\<^sub>m z) = hash_view (view_of_zipper\<^sub>m (embed_view_path p, embed_view t))"
  using assms by transfer(rule zippers_rose_tree_same_hash')

lemma zippers_view_blinding_of:
  assumes "z \<in> set (zippers_view (p, t))"
  shows "blinding_of_view (view_of_zipper\<^sub>m z) (view_of_zipper\<^sub>m (blind_view_path p, embed_view t))"
  using assms by transfer(rule zippers_rose_tree_blinding_of, unfold_locales)

end

primrec blind_view :: "view \<Rightarrow> view\<^sub>m" where
  "blind_view (View vm vd subviews) =
   View\<^sub>m (Blinded (Content ((Content vm, Content vd), map (hash_view \<circ> embed_view) subviews)))"
  for subviews

lemma hash_blind_view: "hash_view (blind_view view) = hash_view (embed_view view)"
  by(cases view) simp

primrec blind_transaction :: "transaction \<Rightarrow> transaction\<^sub>m" where
  "blind_transaction (Transaction cm pm views) =
   Transaction\<^sub>m (Blinded (Content ((Content cm, Content pm), map (hash_view \<circ> blind_view) views)))"
  for views

lemma hash_blind_transaction:
  "hash_transaction (blind_transaction transaction) = hash_transaction (embed_transaction transaction)"
  by(cases transaction)(simp add: hash_blind_view)

typedecl participant
consts recipients :: "view_metadata \<Rightarrow> participant list"

fun view_recipients :: "view\<^sub>m \<Rightarrow> participant set" where
  "view_recipients (View\<^sub>m (Unblinded ((Unblinded vm, vd), subviews))) = set (recipients vm)" for subviews
| "view_recipients _ = {}" \<comment> \<open>Sane default case\<close>

context fixes participant :: participant begin

definition view_trees_for :: "view \<Rightarrow> view\<^sub>m list" where
  "view_trees_for view =
   map view_of_zipper\<^sub>m
     (filter (\<lambda>(_, t). participant \<in> view_recipients t)
       (zippers_view ([], view)))"

primrec transaction_views_for :: "transaction \<Rightarrow> transaction\<^sub>m list" where
  "transaction_views_for (Transaction cm pm views) =
   map (\<lambda>view\<^sub>m. Transaction\<^sub>m (Unblinded ((Unblinded cm, Unblinded pm), view\<^sub>m)))
  (concat (map (\<lambda>(l, v, r). map (\<lambda>v\<^sub>m. map blind_view l @ [v\<^sub>m] @ map blind_view r) (view_trees_for v)) (splits views)))"
  for views

lemma view_trees_for_same_hash:
  "vt \<in> set (view_trees_for view) \<Longrightarrow> hash_view vt = hash_view (embed_view view)"
  by(auto simp add: view_trees_for_def dest: zippers_view_same_hash)

lemma transaction_views_for_same_hash:
  "t\<^sub>m \<in> set (transaction_views_for t) \<Longrightarrow> hash_transaction t\<^sub>m = hash_transaction (embed_transaction t)"
  by(cases t)(clarsimp simp add: splits_iff hash_blind_view view_trees_for_same_hash)

definition transaction_projection_for :: "transaction \<Rightarrow> transaction\<^sub>m" where
  "transaction_projection_for t =
   (let tvs = transaction_views_for t
    in if tvs = [] then blind_transaction t else the (transaction.Merge (set tvs)))"

lemma transaction_projection_for_same_hash:
  "hash_transaction (transaction_projection_for t) = hash_transaction (embed_transaction t)"
proof(cases "transaction_views_for t = []")
  case True thus ?thesis by(simp add: transaction_projection_for_def Let_def hash_blind_transaction)
next
  case False
  then have "transaction.Merge (set (transaction_views_for t)) \<noteq> None"
    by(intro transaction.Merge_defined)(auto simp add: transaction_views_for_same_hash)
  with False show ?thesis
    apply(clarsimp simp add: transaction_projection_for_def neq_Nil_conv simp del: transaction.Merge_insert)
    apply(drule transaction.Merge_hash[symmetric], blast)
    apply(auto intro: transaction_views_for_same_hash)
    done
qed

lemma transaction_projection_for_upper:
  assumes "t\<^sub>m \<in> set (transaction_views_for t)"
  shows "blinding_of_transaction t\<^sub>m (transaction_projection_for t)"
proof -
  from assms have "transaction.Merge (set (transaction_views_for t)) \<noteq> None"
    by(intro transaction.Merge_defined)(auto simp add: transaction_views_for_same_hash)
  with assms show ?thesis
    by(auto simp add: transaction_projection_for_def Let_def dest: transaction.Merge_upper)
qed

end

end


theory SubstDropEnv
  imports AltFlatLemma SubstExp
begin

fun drop_use_env_ex where
  "drop_use_env_ex r_s OwnPerm = r_s"
| "drop_use_env_ex r_s r = drop_use_env r_s"

definition tau_drop_req where
  "tau_drop_req r tau = (if r = OwnPerm then True else req_type tau \<noteq> Aff)"

lemma wt_sexp_drop_all_ex: "\<lbrakk> well_typed env delta rx e tau rx rx; well_formed_delta env delta; tau_drop_req r tau; is_sexp e \<rbrakk> \<Longrightarrow>
  well_typed env delta (drop_use_env_ex rx r) e tau (drop_use_env_ex rx r) (drop_use_env_ex rx r)"
  apply (simp add: tau_drop_req_def)
  apply (case_tac r)
    apply (auto)
   apply (rule_tac wt_sexp_drop_all)
     apply (auto)
  apply (rule_tac wt_sexp_drop_all)
    apply (auto)
  done

lemma dist_drop_leq_use_env_ex: "\<lbrakk> leq_perm q r \<rbrakk> \<Longrightarrow> leq_use_env (drop_use_env_ex r_s q) (drop_use_env_ex r_s r)"
  apply (case_tac "drop_use_env_ex r_s q = drop_use_env r_s")
   apply (case_tac r)
     apply (auto)
     apply (rule_tac id_leq_use_env)
    apply (rule_tac id_leq_use_env)
   apply (rule_tac self_drop_leq_use_env)
  apply (case_tac q)
    apply (auto)
  apply (case_tac r)
    apply (auto)
  apply (rule_tac id_leq_use_env)
  done

lemma safe_lift_drop_use_env: "\<lbrakk> r \<noteq> NoPerm \<rbrakk> \<Longrightarrow> safe_use_lift (drop_use_env_ex r_s r) r"
  apply (case_tac r)
    apply (auto)
  apply (simp add: drop_use_env_def)
  apply (case_tac "r_s x")
    apply (auto)
  done

end


theory ActionSeqProcess
  imports Main "HOL-Library.Sublist" FactoredSystemLib FactoredSystem FSSublist
begin

section "Action Sequence Process"

text \<open> This section defines the preconditions satisfied predicate for action sequences and shows
relations between the execution of action sequnences and their projections some. The preconditions
satisfied predicate (`sat\_precond\_as`) states that in each recursion step, the given state and the
next action are compatible, i.e. the actions preconditions are met by the state. This is used as
premise to propositions on projections of action sequences to avoid that an invalid unprojected
sequence is suddenly valid after projection. [Abdulaziz et al., p.13] \<close>

\<comment> \<open>NOTE curried.\<close>
\<comment> \<open>NOTE 'fun' because of multiple defining equations.\<close>
fun sat_precond_as where
  "sat_precond_as s [] = True"
| "sat_precond_as s (a # as) = (fst a \<subseteq>\<^sub>f s \<and> sat_precond_as (state_succ s a) as)"

\<comment> \<open>NOTE added lemma.\<close>
lemma sat_precond_as_pair:
  "sat_precond_as s ((p, e) # as) = (p \<subseteq>\<^sub>f s \<and> sat_precond_as (state_succ s (p, e)) as)"
  by simp

\<comment> \<open>NOTE 'fun' because of multiple defining equations.\<close>
fun rem_effectless_act where
  "rem_effectless_act [] = []"
| "rem_effectless_act (a # as) = (if fmdom' (snd a) \<noteq> {}
  then (a # rem_effectless_act as)
  else rem_effectless_act as
)"

\<comment> \<open>NOTE 'fun' because of multiple defining equations.\<close>
fun no_effectless_act where
  "no_effectless_act [] = True"
| "no_effectless_act (a # as) = ((fmdom' (snd a) \<noteq> {}) \<and> no_effectless_act as)"

\<comment> \<open>NOTE curried instead of triples.\<close>
\<comment> \<open>NOTE 'fun' because of multiple defining equations.\<close>
fun rem_condless_act where
  "rem_condless_act s pfx_a [] = pfx_a"
| "rem_condless_act s pfx_a (a # as) = (if fst a \<subseteq>\<^sub>f exec_plan s pfx_a
    then rem_condless_act s (pfx_a @ [a]) as
    else rem_condless_act s pfx_a as
  )"

lemma rem_condless_act_pair: "
    rem_condless_act s pfx_a ((p, e) # as) = (if p \<subseteq>\<^sub>f exec_plan s pfx_a
      then rem_condless_act s (pfx_a @ [(p,e)]) as
      else rem_condless_act s pfx_a as
    )
  "
  "(rem_condless_act s pfx_a [] = pfx_a)"
  by simp+

lemma exec_remcondless_cons:
  fixes s h as pfx
  shows "
    exec_plan s (rem_condless_act s (h # pfx) as)
    = exec_plan (state_succ s h) (rem_condless_act (state_succ s h) pfx as)
  "
  by (induction as arbitrary: s h pfx) auto

lemma rem_condless_valid_1:
  fixes as s
  shows "(exec_plan s as = exec_plan s (rem_condless_act s [] as))"
  by (induction as arbitrary: s)
    (auto simp add: exec_remcondless_cons FDOM_state_succ state_succ_def)

lemma rem_condless_act_cons:
  fixes h' pfx as s
  shows "(rem_condless_act s (h' # pfx) as) = (h' # rem_condless_act (state_succ s h') pfx as)"
  by (induction as arbitrary: h' pfx s) auto

lemma rem_condless_act_cons_prefix:
  fixes h h' as as' s
  assumes "prefix (h' # as') (rem_condless_act s [h] as)"
  shows "(
    (prefix as' (rem_condless_act (state_succ s h) [] as))
    \<and> h' = h
  )"
  using assms
proof (induction as arbitrary: h h' as' s)
  case Nil
  then have "rem_condless_act s [h] [] = [h]"
    by simp
  then have 1: "as' = []"
    using Nil.prems
    by simp
  then have "rem_condless_act (state_succ s h) [] [] = []"
    by simp
  then have 2: "prefix as' (rem_condless_act (state_succ s h) [] [])"
    using 1
    by simp
  then have "h = h'"
    using Nil.prems
    by force
  then show ?case
    using 2
    by blast
next
  case (Cons a as)
  {
    have "rem_condless_act s [h] (a # as) = h # rem_condless_act (state_succ s h) [] (a # as)"
      using rem_condless_act_cons
      by fast
    then have "h = h'"
      using Cons.prems
      by simp
  }
  moreover {
    obtain l where "(h' # as') @ l = (h # rem_condless_act (state_succ s h) [] (a # as))"
      using Cons.prems rem_condless_act_cons prefixE
      by metis
    then have "prefix (as' @ l) (rem_condless_act (state_succ s h) [] (a # as))"
      by simp
    then have "prefix as' (rem_condless_act (state_succ s h) [] (a # as))"
      using append_prefixD
      by blast
  }
  ultimately show ?case
    by fastforce
qed

lemma rem_condless_valid_2:
  fixes as s
  shows "sat_precond_as s (rem_condless_act s [] as)"
  by (induction as arbitrary: s) (auto simp: rem_condless_act_cons)

lemma rem_condless_valid_3:
  fixes as s
  shows "length (rem_condless_act s [] as) \<le> length as"
  by (induction as arbitrary: s)
    (auto simp: rem_condless_act_cons le_SucI)

lemma rem_condless_valid_4:
  fixes as A s
  assumes "(set as \<subseteq> A)"
  shows "(set (rem_condless_act s [] as) \<subseteq> A)"
  using assms
  by (induction as arbitrary: A s) (auto simp: rem_condless_act_cons)

lemma rem_condless_valid_6:
  fixes as s P
  shows "length (filter P (rem_condless_act s [] as)) \<le> length (filter P as)"
proof (induction as arbitrary: P s)
  case (Cons a as)
  then show ?case
    by (simp add: rem_condless_act_cons le_SucI)
qed simp

lemma rem_condless_valid_7:
  fixes s P as as2
  assumes "(list_all P as \<and> list_all P as2)"
  shows "list_all P (rem_condless_act s as2 as)"
  using assms
  by (induction as arbitrary: P s as2) auto

lemma rem_condless_valid_8:
  fixes s as
  shows "subseq (rem_condless_act s [] as) as"
  by (induction as arbitrary: s) (auto simp: sublist_cons_4 rem_condless_act_cons)

lemma rem_condless_valid_10:
  fixes PROB as
  assumes "as \<in> (valid_plans PROB)"
  shows "(rem_condless_act s [] as \<in> valid_plans PROB)"
  using assms valid_plans_def rem_condless_valid_1 rem_condless_valid_4
  by blast

lemma rem_condless_valid:
  fixes as A s
  assumes "(exec_plan s as = exec_plan s (rem_condless_act s [] as))"
    "(sat_precond_as s (rem_condless_act s [] as))"
    "(length (rem_condless_act s [] as) \<le> length as)"
    "((set as \<subseteq> A) \<longrightarrow> (set (rem_condless_act s [] as) \<subseteq> A))"
  shows "(\<forall>P. (length (filter P (rem_condless_act s [] as)) \<le> length (filter P as)))"
  using rem_condless_valid_1  rem_condless_valid_2 rem_condless_valid_3 rem_condless_valid_6
    rem_condless_valid_4
  by fast

\<comment> \<open>NOTE type of `as` had to be fixed for lemma submap\_imp\_state\_succ\_submap.\<close>
lemma submap_sat_precond_submap:
  fixes as :: "'a action list"
  assumes "(s1  \<subseteq>\<^sub>f s2)" "(sat_precond_as s1 as)"
  shows "(sat_precond_as s2 as)"
  using assms
proof (induction as arbitrary: s1 s2)
  case (Cons a as)
  {
    have "fst a \<subseteq>\<^sub>f s1"
      using Cons.prems(2)
      by simp
    then have "fst a \<subseteq>\<^sub>f s2"
      using Cons.prems(1) submap_imp_state_succ_submap_a
      by blast
  }
  note 1 = this
  {
    have 2: "fst a \<subseteq>\<^sub>f s1" "sat_precond_as (state_succ s1 a) as"
      using Cons.prems(2)
      by simp+
    then have "state_succ s1 a \<subseteq>\<^sub>f state_succ s2 a"
      using Cons.prems(1) submap_imp_state_succ_submap
      by blast
    then have 3: "sat_precond_as (state_succ s2 a) as"
      using 2(2) Cons.IH
      by blast
  }
  then show ?case
    using 1
    by auto
qed auto

\<comment> \<open>NOTE added lemma.\<close>
lemma submap_init_submap_exec_i:
  fixes s1 s2
  assumes "(s1 \<subseteq>\<^sub>f s2)" "(sat_precond_as s1 (a # as))"
  shows "state_succ s1 a \<subseteq>\<^sub>f state_succ s2 a"
  using assms
proof (cases "fst a \<subseteq>\<^sub>f s1")
  case true: True
  then show ?thesis
  proof (cases "fst a \<subseteq>\<^sub>f s2")
    case True
    then show ?thesis
      unfolding state_succ_def
      using assms submap_imp_state_succ_submap_b state_succ_def true
      by auto
  next
    case False
    then show ?thesis
      using assms submap_imp_state_succ_submap_a true
      by blast
  qed
next
  case false: False
  then show ?thesis
  proof (cases "fst a \<subseteq>\<^sub>f s2")
    case True
    then show ?thesis
      using assms false
      by auto
  next
    case False
    then show ?thesis
      unfolding state_succ_def
      using false assms
      by simp
  qed
qed

lemma submap_init_submap_exec:
  fixes s1 s2
  assumes "(s1 \<subseteq>\<^sub>f s2)" "(sat_precond_as s1 as)"
  shows "(exec_plan s1 as \<subseteq>\<^sub>f exec_plan s2 as)"
  using assms
proof (induction as arbitrary: s1 s2)
  case (Cons a as)
  have "state_succ s1 a \<subseteq>\<^sub>f state_succ s2 a"
    using Cons.prems submap_init_submap_exec_i
    by blast
  moreover have "sat_precond_as (state_succ s1 a) as"
    using Cons.prems(2)
    by simp
  ultimately have "exec_plan (state_succ s1 a) as \<subseteq>\<^sub>f exec_plan (state_succ s2 a) as"
    using Cons.IH
    by blast
  then show ?case
    by simp
qed simp

\<comment> \<open>NOTE type of `as` had to be fixed for `submap\_sat\_precond\_submap`.\<close>
lemma sat_precond_drest_sat_precond:
  fixes vs s and as :: "'a action list"
  assumes "sat_precond_as (fmrestrict_set vs s) as"
  shows "(sat_precond_as s as)"
proof -
  have "fmrestrict_set vs s \<subseteq>\<^sub>f s"
    by simp
  then show "(sat_precond_as s as)"
    using assms submap_sat_precond_submap
    by blast
qed

\<comment> \<open>NOTE name shortened to 'varset\_action'.\<close>
definition varset_action where
  "varset_action a varset \<equiv> (fmdom' (snd a) \<subseteq> varset)"
for a :: "'a action"

lemma varset_action_pair: "(varset_action (p, e) vs) = (fmdom' e \<subseteq> vs)"
  unfolding varset_action_def
  by auto

lemma eq_effect_eq_vset:
  fixes x y
  assumes "(snd x = snd y)"
  shows "((\<lambda>a. varset_action a vs) x = (\<lambda>a. varset_action a vs) y)"
  unfolding varset_action_def
  using assms
  by presburger

lemma rem_effectless_works_1:
  fixes s as
  shows "(exec_plan s as = exec_plan s (rem_effectless_act as))"
  by (induction as arbitrary: s) (auto simp: empty_eff_exec_eq)

lemma rem_effectless_works_2:
  fixes as s
  assumes "(sat_precond_as s as)"
  shows "(sat_precond_as s (rem_effectless_act as))"
  using assms
  by (induction as arbitrary: s) (auto simp: empty_eff_exec_eq)

lemma rem_effectless_works_3:
  fixes as
  shows "length (rem_effectless_act as) \<le> length as"
  by (induction as) auto

lemma rem_effectless_works_4:
  fixes A as
  assumes "(set as \<subseteq> A)"
  shows "(set (rem_effectless_act as) \<subseteq> A)"
  using assms
  by (induction as arbitrary: A)  auto

lemma rem_effectless_works_4':
  fixes A as
  assumes "(as \<in> valid_plans A)"
  shows "(rem_effectless_act as \<in> valid_plans A)"
  using assms
  by (induction as arbitrary: A) (auto simp: valid_plans_def)

\<comment> \<open>NOTE added lemma.\<close>
lemma rem_effectless_works_5_i:
  shows "subseq (rem_effectless_act as) as"
  by (induction as) auto

lemma rem_effectless_works_5:
  fixes P as
  shows "length (filter P (rem_effectless_act as)) \<le> length (filter P as)"
  using rem_effectless_works_5_i sublist_imp_len_filter_le
  by blast

lemma rem_effectless_works_6:
  fixes as
  shows "no_effectless_act (rem_effectless_act as)"
  by (induction as) auto

lemma rem_effectless_works_7:
  fixes as
  shows "no_effectless_act as =  list_all (\<lambda>a. fmdom' (snd a) \<noteq> {}) as"
  by (induction as) auto

lemma rem_effectless_works_8:
  fixes P as
  assumes "(list_all P as)"
  shows "list_all P (rem_effectless_act as)"
  using assms
  by (induction as arbitrary: P) auto

\<comment> \<open>TODO move and replace `rem\_effectless\_works\_5\_i`.\<close>
lemma rem_effectless_works_9:
  fixes as
  shows "subseq (rem_effectless_act as) as"
  by (induction as) auto

lemma rem_effectless_works_10:
  fixes as P
  assumes "(no_effectless_act as)"
  shows "(no_effectless_act (filter P as))"
  using assms
  by (auto simp: rem_effectless_works_7) (metis Ball_set filter_set member_filter)

lemma rem_effectless_works_11:
  fixes as1 as2
  assumes "subseq as1 (rem_effectless_act as2)"
  shows "(subseq as1 as2)"
  using assms rem_effectless_works_9 sublist_trans
  by blast

lemma rem_effectless_works_12:
  fixes as1 as2
  shows "(no_effectless_act (as1 @ as2)) = (no_effectless_act as1 \<and> no_effectless_act(as2))"
  by (induction as1) auto

\<comment> \<open>TODO refactor into 'List\_Utils.thy'.\<close>
lemma rem_effectless_works_13_i:
  fixes x l
  assumes "ListMem x l" "list_all P l"
  shows "P x"
  using assms proof (induction l)
  case (insert x xs y)
  have 1: "P y"
    using insert.prems list.pred_inject
    by simp
  then have 2: "list_all P l"
    using assms(2) list.pred_inject
    by force
  then show ?case
    using 1
  proof (cases "y = x")
    case False
    then show ?thesis
      using insert 2
      by fastforce
  qed simp
qed simp

lemma rem_effectless_works_13:
  fixes as1 as2
  assumes "(subseq as1 as2)" "(no_effectless_act as2)"
  shows "(no_effectless_act as1)"
  using assms
proof (induction as1 arbitrary: as2)
  case (Cons a as1)
  {
    have "subseq as1 as2"
      using Cons.prems(1) sublist_CONS1_E
      by metis
    then have "no_effectless_act as1"
      using Cons.prems(2) Cons.IH
      by blast
  }
  moreover
  {
    have "list_all (\<lambda>a. fmdom' (snd a) \<noteq> {}) as2"
      using Cons.prems(2) rem_effectless_works_7
      by blast
    moreover have "ListMem a as2"
      using Cons.prems(1) sublist_MEM
      by fast
    ultimately have "fmdom' (snd a) \<noteq> {}"
      using rem_effectless_works_13_i
      by fastforce
  }
  ultimately show ?case
    by simp
qed simp

lemma rem_effectless_works:
  fixes s A as
  assumes "(exec_plan s as = exec_plan s (rem_effectless_act as))"
    "(sat_precond_as s as \<longrightarrow> sat_precond_as s (rem_effectless_act as))"
    "(length (rem_effectless_act as) \<le> length as)"
    "((set as \<subseteq> A) \<longrightarrow> (set (rem_effectless_act as) \<subseteq> A))"
    "(no_effectless_act (rem_effectless_act as))"
  shows "(\<forall>P. length (filter P (rem_effectless_act as)) \<le> length (filter P as))"
  using assms rem_effectless_works_5
  by blast

\<comment> \<open>NOTE name shortened.\<close>
definition rem_effectless_act_set where
  "rem_effectless_act_set A \<equiv> {a \<in> A. fmdom' (snd a) \<noteq> {}}"

lemma rem_effectless_act_subset_rem_effectless_act_set_thm:
  fixes as A
  assumes "(set as \<subseteq> A)"
  shows "(set (rem_effectless_act as) \<subseteq> rem_effectless_act_set A)"
  unfolding rem_effectless_act_set_def
  using assms
  by (induction as) auto

lemma rem_effectless_act_set_no_empty_actions_thm:
  fixes A
  shows "rem_effectless_act_set A \<subseteq> {a. fmdom' (snd a) \<noteq> {}}"
  unfolding rem_effectless_act_set_def
  by blast

\<comment> \<open>NOTE proof required additional lemmas 'rem\_effectless\_works\_7' and 'rem\_condless\_valid\_7'.\<close>
lemma rem_condless_valid_9:
  fixes s as
  assumes "no_effectless_act as"
  shows "no_effectless_act (rem_condless_act s [] as)"
  using assms
proof (induction as arbitrary: s)
  case (Cons a as)
  then show ?case
    using Cons
  proof (cases " fst a \<subseteq>\<^sub>f exec_plan s []")
    case True
    then have "rem_condless_act s [] (a # as) = a # rem_condless_act (state_succ s a) [] as"
      using rem_condless_act_cons
      by fastforce
    moreover
    {
      have "fmdom' (snd a) \<noteq> {}"  "no_effectless_act as"
        using Cons.prems
        by simp+
      then have "no_effectless_act (rem_condless_act (state_succ s a) [] as)"
        using Cons.IH
        by blast
    }
    moreover have "no_effectless_act [a]"
      using Cons.prems
      by simp
    ultimately show ?thesis
      using rem_effectless_works_12
      by force
  qed simp
qed simp

lemma graph_plan_lemma_17:
  fixes as_1 as_2 as s
  assumes "(as_1 @ as_2 = as)" "(sat_precond_as s as)"
  shows "((sat_precond_as s as_1) \<and> sat_precond_as (exec_plan s as_1) as_2)"
  using assms
proof (induction as arbitrary: as_1 as_2 s)
  case (Cons a as)
  then show ?case proof(cases "as_1")
    case Nil
    then show ?thesis
      using Cons.prems(1, 2)
      by auto
  next
    case (Cons a list)
    then show ?thesis
      using Cons.prems(1, 2) Cons.IH hd_append2  list.distinct(1) list.sel(1, 3) tl_append2
      by auto
  qed
qed auto

lemma nempty_eff_every_nempty_act:
  fixes as
  assumes "(no_effectless_act as)" "(\<forall>x. \<not>(fmdom' (snd (f x)) = {}))"
  shows "(list_all (\<lambda>a. \<not>(f a = (fmempty, fmempty))) as)"
  using assms
proof (induction as arbitrary: f)
  case (Cons a as)
  then show ?case using fmdom'_empty snd_conv
    by (metis (mono_tags, lifting) Ball_set)
qed simp

lemma empty_replace_proj_dual7:
  fixes s as as'
  assumes "sat_precond_as s (as @ as')"
  shows "sat_precond_as (exec_plan s as) as'"
  using assms
  by (induction as arbitrary: as' s) auto

lemma not_vset_not_disj_eff_prod_dom_diff:
  fixes PROB a vs
  assumes "(a \<in> PROB)" "(\<not>varset_action a vs)"
  shows "\<not>((fmdom' (snd a) \<inter> ((prob_dom PROB) - vs)) = {})"
proof -
  have 1: "fmdom' (snd a) \<noteq> {}"
    using assms(2) varset_action_def
    by blast
  {
    have "fmdom' (snd a) \<subseteq> prob_dom PROB"
      using assms(1) FDOM_eff_subset_prob_dom_pair
      by metis
    then have "
      fmdom' (snd a) \<inter> (prob_dom PROB - vs)
      = (fmdom' (snd a)) - (fmdom' (snd a) \<inter> vs)"
      using Diff_Int_distrib
      by blast
  }
  note 2 = this
  then show ?thesis
    using 1 2
  proof (cases "fmdom' (snd a) \<inter> vs = {}")
    case False
    {
      have "\<not>(fmdom' (snd a) \<subseteq> vs)"
        using assms(2) varset_action_def
        by fast
      then have "(fmdom' (snd a) \<inter> vs \<noteq> fmdom' (snd a))"
        by auto
      then have "(fmdom' (snd a) \<inter> vs) \<subset> fmdom' (snd a)"
        by blast
    }
    then show ?thesis using 2
      by auto
  qed force
qed

lemma vset_disj_dom_eff_diff:
  fixes PROB a vs
  assumes "(varset_action a vs)"
  shows "(((fmdom' (snd a)) \<inter> (prob_dom PROB - vs)) = {})"
  using assms
  unfolding varset_action_def
  by auto

lemma vset_diff_disj_eff_vs:
  fixes PROB a vs
  assumes "(varset_action a (prob_dom PROB - vs))"
  shows "(((fmdom' (snd a)) \<inter> vs) = {})"
  using assms
  unfolding varset_action_def
  by blast

lemma vset_nempty_efff_not_disj_eff_vs:
  fixes PROB a vs
  assumes "(varset_action a vs)" "(fmdom' (snd a) \<noteq> {})"
  shows "\<not>((fmdom' (snd a) \<inter> vs)) = {}"
  using assms
  unfolding varset_action_def
  by auto

lemma vset_disj_eff_diff:
  fixes s a vs
  assumes "(varset_action a vs)"
  shows "((fmdom' (snd a) \<inter> (s - vs)) = {})"
proof -
  have 1: "fmdom' (snd a) \<subseteq> vs"
    using assms
    by (simp add: varset_action_def)
  moreover {
    have "fmdom' (snd a) \<inter> (s - vs) = (fmdom' (snd a) \<inter> s) - (fmdom' (snd a) \<inter> vs)"
      using Diff_Int_distrib
      by fast
    also have " \<dots> = (fmdom' (snd a) \<inter> s) - (fmdom' (snd a))"
      using 1
      by auto
    finally have "fmdom' (snd a) \<inter> (s - vs) = {}"
      by simp
  }
  ultimately show ?thesis
    by blast
qed

\<comment> \<open>NOTE added lemma.\<close>
lemma list_all_list_mem:
  fixes P and l :: "'a list"
  shows "list_all P l \<longleftrightarrow> (\<forall>e. ListMem e l \<longrightarrow> P e)"
proof -
  {
    assume P1: "list_all P l"
    {
      fix e
      assume P11: "ListMem e l"
      then have "P e"
        using P1 P11
      proof (induction l arbitrary: P)
        case (insert x xs y)
        then show ?case proof (cases "y = x")
          case False
          then have "list_all P xs" "ListMem x xs"
            using insert.prems(1) insert.hyps
            by fastforce+
          then show ?thesis
            using insert.IH
            by blast
        qed simp
      qed simp
    }
  }
  moreover
  {
    assume P2: "(\<forall>e. ListMem e l \<longrightarrow> P e)"
    then have "list_all P l"
    proof(induction l arbitrary: P)
      case (Cons a l)
      {
        have "\<forall>e. ListMem e l \<longrightarrow> P e"
          using Cons.prems insert
          by fast
        then have "list_all P l"
          using Cons.IH
          by blast
      }
      moreover have "P a"
        using Cons.prems elem
        by fast
      ultimately show ?case
        by simp
    qed simp
  }
  ultimately show ?thesis
    by blast
qed

lemma every_vset_imp_drestrict_exec_eq:
  fixes PROB vs as s
  assumes "(list_all (\<lambda>a. varset_action a ((prob_dom PROB) - vs)) as)"
  shows "(fmrestrict_set vs s = fmrestrict_set vs (exec_plan s as))"
proof -
  have 1: "\<forall>e. ListMem e as \<longrightarrow> varset_action e ((prob_dom PROB) - vs)"
    using assms list_all_list_mem
    by metis
  {
    fix a
    assume "ListMem a as"
    then have "varset_action a (prob_dom PROB - vs)"
      using 1
      by blast
    then have "disjnt (fmdom' (snd a)) vs"
      unfolding disjnt_def
      using vset_diff_disj_eff_vs
      by blast
  }
  then have "list_all (\<lambda>a. disjnt (fmdom' (snd a)) vs) as"
    using list_all_list_mem
    by blast
  then have "list_all (\<lambda>a. disjnt (fmdom' (snd a)) vs) (rem_condless_act s [] as)"
    by (simp add: rem_condless_valid_7)
  then have "exec_plan s as = exec_plan s (rem_condless_act s [] as)"
    using rem_condless_valid_1
    by blast
  then have"sat_precond_as s (rem_condless_act s [] as)"
    using rem_condless_valid_2
    by blast
  then have "sat_precond_as s [a\<leftarrow>as . \<not> varset_action a (prob_dom PROB - vs)]"
    by (simp add: 1 ListMem_iff)
  then have "fmrestrict_set vs s = fmrestrict_set vs s" by simp
  then have "
    fmrestrict_set vs (exec_plan s as) =
    fmrestrict_set vs (exec_plan s [a\<leftarrow>as . \<not> varset_action a (prob_dom PROB - vs)])
  "
    using 1 graph_plan_lemma_4[where
        s = s and s' = s and as = "rem_condless_act s [] as" and vs = vs and
        P = "\<lambda>a. varset_action a (prob_dom PROB - vs)"
        ] filter_empty_every_not vset_diff_disj_eff_vs 1disjoint_effects_no_effects
      exec_plan.simps(1) fmdom'_restrict_set_precise list_all_list_mem
    by smt
  then have "list_all (\<lambda>a. varset_action a (prob_dom PROB - vs)) (rem_condless_act s [] as)"
    using assms(1) rem_condless_valid_7 list.pred_inject(1)
    by blast
  then have "filter (\<lambda>a. \<not>(varset_action a (prob_dom PROB - vs))) (rem_condless_act s [] as) = []"
    using filter_empty_every_not
    by fastforce
  then have "
    sat_precond_as s (filter (\<lambda>a. \<not>(varset_action a (prob_dom PROB - vs)))
    (rem_condless_act s []as))
  "
    by fastforce
  then show ?thesis
    using 1 vset_diff_disj_eff_vs disjoint_effects_no_effects fmdom'_restrict_set_precise
    by metis
qed

lemma no_effectless_act_works:
  fixes as
  assumes "(no_effectless_act as)"
  shows "(filter (\<lambda>a. \<not>(fmdom' (snd a) = {})) as = as)"
  using assms
  by (simp add: Ball_set rem_effectless_works_7)

lemma varset_act_diff_un_imp_varset_diff:
  fixes a vs vs' vs''
  assumes "(varset_action a (vs'' -  (vs' \<union> vs)))"
  shows "(varset_action a (vs'' - vs))"
  using assms
  unfolding varset_action_def
  by blast

lemma vset_diff_union_vset_diff:
  fixes s vs vs' a
  assumes "(varset_action a (s - (vs \<union> vs')))"
  shows "(varset_action a (s - vs'))"
  using assms
  unfolding varset_action_def
  by blast

lemma valid_filter_vset_dom_idempot:
  fixes PROB as
  assumes "(as \<in> valid_plans PROB)"
  shows "(filter (\<lambda>a. varset_action a (prob_dom PROB)) as = as)"
  using assms
proof (induction as)
  case (Cons a as)
  {
    have "as \<in> valid_plans PROB"
      using Cons.prems valid_plan_valid_tail
      by fast
    then have "(filter (\<lambda>a. varset_action a (prob_dom PROB)) as = as)"
      using Cons.IH
      by blast
  }
  moreover {
    have "a \<in> PROB"
      using Cons.prems valid_plan_valid_head
      by fast
    then have "varset_action a (prob_dom PROB)"
      unfolding varset_action_def
      using FDOM_eff_subset_prob_dom_pair
      by metis
  }
  ultimately show ?case
    by simp
qed fastforce

lemma n_replace_proj_le_n_as_1:
  fixes a vs vs'
  assumes "(vs \<subseteq> vs')" "(varset_action a vs)"
  shows "(varset_action a vs')"
  using assms
  unfolding varset_action_def
  by simp

lemma sat_precond_as_pfx:
  fixes s
  assumes "(sat_precond_as s (as @ as'))"
  shows "(sat_precond_as s as)"
  using assms
proof (induction as arbitrary: s as')
  case (Cons a as)
  have "fst a \<subseteq>\<^sub>f s"
    using Cons.prems
    by fastforce
  moreover have "sat_precond_as (state_succ s a) (as @ as')"
    using Cons.prems
    by simp
  ultimately show ?case
    using Cons.IH sat_precond_as.simps(2)
    by blast
qed simp

end


theory prop_29
imports Main
        "../../TestTheories/Listi"
        "../../TestTheories/Naturals"
        "$HIPSTER_HOME/IsaHipster"

begin

theorem revZip: "len rs = len ts \<Longrightarrow> rev (zip rs ts) = zip (rev rs) (rev ts)"
oops

end


(*  Title:      HOL/HOLCF/IOA/meta_theory/Asig.thy
    Author:     Olaf Müller, Tobias Nipkow & Konrad Slind
*)

section {* Action signatures *}

theory Asig
imports Main
begin

type_synonym
  'a signature = "('a set * 'a set * 'a set)"

definition
  inputs :: "'action signature => 'action set" where
  asig_inputs_def: "inputs = fst"

definition
  outputs :: "'action signature => 'action set" where
  asig_outputs_def: "outputs = (fst o snd)"

definition
  internals :: "'action signature => 'action set" where
  asig_internals_def: "internals = (snd o snd)"

definition
  actions :: "'action signature => 'action set" where
  "actions(asig) = (inputs(asig) Un outputs(asig) Un internals(asig))"

definition
  externals :: "'action signature => 'action set" where
  "externals(asig) = (inputs(asig) Un outputs(asig))"

definition
  locals :: "'action signature => 'action set" where
  "locals asig = ((internals asig) Un (outputs asig))"

definition
  is_asig :: "'action signature => bool" where
  "is_asig(triple) =
     ((inputs(triple) Int outputs(triple) = {}) &
      (outputs(triple) Int internals(triple) = {}) &
      (inputs(triple) Int internals(triple) = {}))"

definition
  mk_ext_asig :: "'action signature => 'action signature" where
  "mk_ext_asig(triple) = (inputs(triple), outputs(triple), {})"

lemmas asig_projections = asig_inputs_def asig_outputs_def asig_internals_def

lemma asig_triple_proj:
 "(outputs    (a,b,c) = b)   &
  (inputs     (a,b,c) = a) &
  (internals  (a,b,c) = c)"
  apply (simp add: asig_projections)
  done

lemma int_and_ext_is_act: "[| a~:internals(S) ;a~:externals(S)|] ==> a~:actions(S)"
apply (simp add: externals_def actions_def)
done

lemma ext_is_act: "[|a:externals(S)|] ==> a:actions(S)"
apply (simp add: externals_def actions_def)
done

lemma int_is_act: "[|a:internals S|] ==> a:actions S"
apply (simp add: asig_internals_def actions_def)
done

lemma inp_is_act: "[|a:inputs S|] ==> a:actions S"
apply (simp add: asig_inputs_def actions_def)
done

lemma out_is_act: "[|a:outputs S|] ==> a:actions S"
apply (simp add: asig_outputs_def actions_def)
done

lemma ext_and_act: "(x: actions S & x : externals S) = (x: externals S)"
apply (fast intro!: ext_is_act)
done

lemma not_ext_is_int: "[|is_asig S;x: actions S|] ==> (x~:externals S) = (x: internals S)"
apply (simp add: actions_def is_asig_def externals_def)
apply blast
done

lemma not_ext_is_int_or_not_act: "is_asig S ==> (x~:externals S) = (x: internals S | x~:actions S)"
apply (simp add: actions_def is_asig_def externals_def)
apply blast
done

lemma int_is_not_ext:
 "[| is_asig (S); x:internals S |] ==> x~:externals S"
apply (unfold externals_def actions_def is_asig_def)
apply simp
apply blast
done

end


(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Agent
  imports Nominal
begin

lemma pt_id:
  fixes x :: 'a
    and a :: 'x

  assumes pt: "pt TYPE('a) TYPE('x)"
  and     at: "at TYPE('x)"
  shows "[(a, a)] \<bullet> x = x"
proof -
  have "x = ([]::'x prm) \<bullet> x"
    by(simp add: pt1[OF pt])
  also have "[(a, a)] \<bullet> x = ([]::'x prm) \<bullet> x"
    by(simp add: pt3[OF pt] at_ds1[OF at])
  finally show ?thesis by simp
qed

lemma pt_swap:
  fixes x :: 'a
  and a :: 'x
  and b :: 'x

  assumes pt: "pt TYPE('a) TYPE('x)"
  and     at: "at TYPE('x)"

  shows "[(a, b)] \<bullet> x = [(b, a)] \<bullet> x"
proof -
  show ?thesis by(simp add: pt3[OF pt] at_ds5[OF at])
qed

atom_decl name

lemmas name_fresh_abs = fresh_abs_fun_iff[OF pt_name_inst, OF at_name_inst, OF fs_name1]
lemmas name_bij = at_bij[OF at_name_inst]
lemmas name_supp_abs = abs_fun_supp[OF pt_name_inst, OF at_name_inst, OF fs_name1]
lemmas name_abs_eq = abs_fun_eq[OF pt_name_inst, OF at_name_inst]
lemmas name_supp = at_supp[OF at_name_inst]
lemmas name_calc = at_calc[OF at_name_inst]
lemmas name_fresh_fresh = pt_fresh_fresh[OF pt_name_inst, OF at_name_inst]
lemmas name_fresh_left = pt_fresh_left[OF pt_name_inst, OF at_name_inst]
lemmas name_fresh_right = pt_fresh_right[OF pt_name_inst, OF at_name_inst]
lemmas name_id[simp] = pt_id[OF pt_name_inst, OF at_name_inst]
lemmas name_swap_bij[simp] = pt_swap_bij[OF pt_name_inst, OF at_name_inst]
lemmas name_swap = pt_swap[OF pt_name_inst, OF at_name_inst]
lemmas name_rev_per = pt_rev_pi[OF pt_name_inst, OF at_name_inst]
lemmas name_per_rev = pt_pi_rev[OF pt_name_inst, OF at_name_inst]
lemmas name_exists_fresh = at_exists_fresh[OF at_name_inst, OF fs_name1]
lemmas name_perm_compose = pt_perm_compose[OF pt_name_inst, OF at_name_inst]

nominal_datatype pi = PiNil                  ("\<zero>")
                    | Output name name pi    ("_{_}._" [120, 120, 110] 110)
                    | Tau pi                 ("\<tau>._" [120] 110)
                    | Input name "\<guillemotleft>name\<guillemotright> pi" ("_<_>._" [120, 120, 110] 110)
                    | Match name name pi     ("[_\<frown>_]_" [120, 120, 110] 110)
                    | Mismatch name name pi  ("[_\<noteq>_]_" [120, 120, 110] 110)
                    | Sum pi pi              (infixr "\<oplus>" 90)
                    | Par pi pi              (infixr "\<parallel>" 85)
                    | Res "\<guillemotleft>name\<guillemotright> pi"        ("<\<nu>_>_" [100, 100] 100)
                    | Bang pi                ("!_" [110] 110)

lemmas name_fresh[simp] = at_fresh[OF at_name_inst]

lemma alphaInput:
  fixes a :: name
  and   x :: name
  and   P :: pi
  and   c :: name

  assumes A1: "c \<sharp> P"

  shows "a<x>.P = a<c>.([(x, c)] \<bullet> P)"
proof(cases "x = c")
  assume "x=c"
  thus ?thesis by(simp)
next
  assume "x \<noteq> c"
  with A1 show ?thesis
    by(simp add: pi.inject alpha name_fresh_left name_calc)
qed

lemma alphaRes:
  fixes a :: name
  and   P :: pi
  and   c :: name

  assumes A1: "c \<sharp> P"

  shows "<\<nu>a>P = <\<nu>c>([(a, c)] \<bullet> P)"
proof(cases "a=c")
  assume "a=c"
  thus ?thesis by simp
next
  assume "a \<noteq> c"
  with A1 show ?thesis
    by(simp add: pi.inject alpha fresh_left name_calc)
qed

(*Substitution*)

definition subst_name :: "name \<Rightarrow> name \<Rightarrow> name \<Rightarrow> name"   ("_[_::=_]" [110, 110, 110] 110)
where
  "a[b::=c] \<equiv> if (a = b) then c else a"

declare subst_name_def[simp]

lemma subst_name_eqvt[eqvt]:
  fixes p :: "name prm"
  and   a :: name
  and   b :: name
  and   c :: name

  shows "p \<bullet> (a[b::=c]) = (p\<bullet> a)[(p \<bullet> b)::=(p \<bullet> c)]"
by(auto simp add: at_bij[OF at_name_inst])

nominal_primrec (freshness_context: "(c::name, d::name)")
  subs :: "pi \<Rightarrow> name \<Rightarrow> name \<Rightarrow> pi" ("_[_::=_]" [100,100,100] 100)
where
  "\<zero>[c::=d] = \<zero>"
| "\<tau>.(P)[c::=d] = \<tau>.(P[c::=d])"
| "a{b}.P[c::=d] = (a[c::=d]){(b[c::=d])}.(P[c::=d])"
| "\<lbrakk>x \<noteq> a; x \<noteq> c; x \<noteq> d\<rbrakk> \<Longrightarrow> (a<x>.P)[c::=d] = (a[c::=d])<x>.(P[c::=d])"
| "[a\<frown>b]P[c::=d] = [(a[c::=d])\<frown>(b[c::=d])](P[c::=d])"
| "[a\<noteq>b]P[c::=d] = [(a[c::=d])\<noteq>(b[c::=d])](P[c::=d])"
| "(P \<oplus> Q)[c::=d] = (P[c::=d]) \<oplus> (Q[c::=d])"
| "(P \<parallel> Q)[c::=d] = (P[c::=d]) \<parallel> (Q[c::=d])"
| "\<lbrakk>x \<noteq> c; x \<noteq> d\<rbrakk> \<Longrightarrow> (<\<nu>x>P)[c::=d] = <\<nu>x>(P[c::=d])"
| "!P[c::=d] = !(P[c::=d])"
apply(simp_all add: abs_fresh)
apply(finite_guess)+
by(fresh_guess)+

lemma forget:
  fixes a :: name
  and   P :: pi
  and   b :: name

  assumes "a \<sharp> P"

  shows "P[a::=b] = P"
using assms
by(nominal_induct P avoiding: a b rule: pi.strong_induct)
  (auto simp add: name_fresh_abs)

lemma fresh_fact2[rule_format]:
  fixes P :: pi
  and   a :: name
  and   b :: name

  assumes "a \<noteq> b"

  shows "a \<sharp> P[a::=b]"
using assms
by(nominal_induct P avoiding: a b rule: pi.strong_induct)
  (auto simp add: name_fresh_abs)

lemma subst_identity[simp]:
  fixes P :: pi
  and   a :: name

  shows "P[a::=a] = P"
by(nominal_induct P avoiding: a rule: pi.strong_induct) auto

lemma renaming:
  fixes P :: pi
  and   a :: name
  and   b :: name
  and   c :: name

  assumes "c \<sharp> P"

  shows "P[a::=b] = ([(c, a)] \<bullet> P)[c::=b]"
using assms
by(nominal_induct P avoiding: a b c rule: pi.strong_induct)
  (auto simp add: name_calc name_fresh_abs)

lemma fresh_fact1:
  fixes P :: pi
  and   a :: name
  and   b :: name
  and   c :: name

  assumes "a \<sharp> P"
  and     "a \<noteq> c"

  shows "a \<sharp> P[b::=c]"
using assms
by(nominal_induct P avoiding: a b c rule: pi.strong_induct)
  (auto simp add: name_fresh_abs)

lemma eqvt_subs[eqvt]:
  fixes p :: "name prm"
  and   P :: pi
  and   a :: name
  and   b :: name

  shows "p \<bullet> (P[a::=b]) = (p \<bullet> P)[(p \<bullet> a)::=(p \<bullet> b)]"
by(nominal_induct P avoiding: a b rule: pi.strong_induct)
  (auto simp add: name_bij)

lemma substInput[simp]:
  fixes x :: name
  and   b :: name
  and   c :: name
  and   a :: name
  and   P :: pi

  assumes "x \<noteq> b"
  and     "x \<noteq> c"

  shows "(a<x>.P)[b::=c] = (a[b::=c])<x>.(P[b::=c])"
proof -
  obtain y::name where"y \<noteq> a" and "y \<sharp> P" and "y \<noteq> b" and "y \<noteq> c"
    by(generate_fresh "name") (auto simp add: fresh_prod)
  from `y \<sharp> P` have "a<x>.P = a<y>.([(x, y)] \<bullet> P)" by(simp add: alphaInput)
  moreover have "(a[b::=c])<x>.(P[b::=c]) = (a[b::=c])<y>.(([(x, y)] \<bullet> P)[b::=c])" (is "?LHS = ?RHS")
  proof -
    from `y \<sharp> P` `y \<noteq> c` have "y \<sharp> P[b::=c]" by(rule fresh_fact1)
    hence "?LHS = (a[b::=c])<y>.([(x, y)] \<bullet> (P[b::=c]))" by(simp add: alphaInput)
    moreover with `x \<noteq> b` `x \<noteq> c` `y \<noteq> b` `y \<noteq> c` have "\<dots> = ?RHS"
      by(auto simp add: eqvt_subs name_calc)
    ultimately show ?thesis by simp
  qed
  ultimately show ?thesis using `y \<noteq> a` `y \<noteq> b` `y \<noteq> c` by simp
qed

lemma injPermSubst:
  fixes P :: pi
  and   a :: name
  and   b :: name

  assumes "b \<sharp> P"

  shows "[(a, b)] \<bullet> P = P[a::=b]"
using assms
by(nominal_induct P avoiding: a b rule: pi.strong_induct)
  (auto simp add: name_calc name_fresh_abs)

lemma substRes2:
  fixes P :: pi
  and   a :: name
  and   b :: name

  assumes "b \<sharp> P"

  shows "<\<nu>a>P = <\<nu>b>(P[a::=b])"
proof(case_tac "a = b")
  assume "a = b"
  thus ?thesis by auto
next
  assume "a \<noteq> b"
  moreover with `b \<sharp> P` show ?thesis
    apply(simp add: pi.inject abs_fun_eq[OF pt_name_inst, OF at_name_inst])
    apply auto
    apply(simp add: renaming)
    apply(simp add: pt_swap[OF pt_name_inst, OF at_name_inst])
    apply(simp add: renaming)
    apply(simp add: pt_fresh_left[OF pt_name_inst, OF at_name_inst])
    by(force simp add: at_calc[OF at_name_inst])
qed

lemma freshRes:
  fixes P :: pi
  and   a :: name

  shows "a \<sharp> <\<nu>a>P"
by(simp add: name_fresh_abs)

lemma substRes3:
  fixes P :: pi
  and   a :: name
  and   b :: name

  assumes "b \<sharp> P"

  shows "(<\<nu>a>P)[a::=b] = <\<nu>b>(P[a::=b])"
proof -
  have "(<\<nu>a>P)[a::=b] = <\<nu>a>P"
    using freshRes by(simp add: forget)
  thus ?thesis using `b \<sharp> P` by(simp add: substRes2)
qed

lemma suppSubst:
  fixes P :: pi
  and   a :: name
  and   b :: name

  shows "supp(P[a::=b]) \<subseteq> insert b ((supp P) - {a})"
apply(nominal_induct P avoiding: a b rule: pi.strong_induct,
      simp_all add: pi.supp name_supp_abs name_supp supp_prod)
by(blast)+

(******** Sequential substitution *******)

primrec seqSubs :: "pi \<Rightarrow> (name \<times> name) list \<Rightarrow> pi" ("_[<_>]" [100,100] 100) where
  "P[<[]>] = P"
| "P[<(x#\<sigma>)>] = (P[(fst x)::=(snd x)])[<\<sigma>>]"

primrec seq_subst_name :: "name \<Rightarrow> (name \<times> name) list \<Rightarrow> name" where
  "seq_subst_name a [] = a"
| "seq_subst_name a (x#\<sigma>) = seq_subst_name (a[(fst x)::=(snd x)]) \<sigma>"

lemma freshSeqSubstName:
  fixes x :: name
  and   a :: name
  and   s :: "(name \<times> name) list"

  assumes "x \<noteq> a"
  and     "x \<sharp> s"

  shows "x \<noteq> seq_subst_name a s"
using assms
apply(induct s arbitrary: a)
apply simp
apply(case_tac "aa = fst(a)")
by (force simp add: fresh_list_cons fresh_prod)+

lemma seqSubstZero[simp]:
  fixes \<sigma> :: "(name \<times> name) list"

  shows "\<zero>[<\<sigma>>] = \<zero>"
by(induct \<sigma>, auto)

lemma seqSubstTau[simp]:
  fixes P :: pi
  and   \<sigma> :: "(name \<times> name) list"

  shows "(\<tau>.(P))[<\<sigma>>] = \<tau>.(P[<\<sigma>>])"
by(induct \<sigma> arbitrary: P, auto)

lemma seqSubstOutput[simp]:
  fixes a :: name
  and   b :: name
  and   P :: pi
  and   \<sigma> :: "(name \<times> name) list"

  shows "(a{b}.P)[<\<sigma>>] = (seq_subst_name a \<sigma>){(seq_subst_name b \<sigma>)}.(P[<\<sigma>>])"
by(induct \<sigma> arbitrary: a b P, auto)

lemma seqSubstInput[simp]:
  fixes a :: name
  and   x :: name
  and   P :: pi
  and   \<sigma> :: "(name \<times> name) list"

  assumes "x \<sharp> \<sigma>"

  shows "(a<x>.P)[<\<sigma>>] = (seq_subst_name a \<sigma>)<x>.(P[<\<sigma>>])"
using assms
by(induct \<sigma> arbitrary: a x P) (auto simp add: fresh_list_cons fresh_prod)

lemma seqSubstMatch[simp]:
  fixes a :: name
  and   b :: name
  and   P :: pi
  and   \<sigma> :: "(name \<times> name) list"

  shows "([a\<frown>b]P)[<\<sigma>>] = [(seq_subst_name a \<sigma>)\<frown>(seq_subst_name b \<sigma>)](P[<\<sigma>>])"
by(induct \<sigma> arbitrary: a b P, auto)

lemma seqSubstMismatch[simp]:
  fixes a :: name
  and   b :: name
  and   P :: pi
  and   \<sigma> :: "(name \<times> name) list"

  shows "([a\<noteq>b]P)[<\<sigma>>] = [(seq_subst_name a \<sigma>)\<noteq>(seq_subst_name b \<sigma>)](P[<\<sigma>>])"
by(induct \<sigma> arbitrary: a b P, auto)

lemma seqSubstSum[simp]:
  fixes P :: pi
  and   Q :: pi
  and   \<sigma> :: "(name \<times> name) list"

  shows "(P \<oplus> Q)[<\<sigma>>] = (P[<\<sigma>>]) \<oplus> (Q[<\<sigma>>])"
by(induct \<sigma> arbitrary: P Q , auto)

lemma seqSubstPar[simp]:
  fixes P :: pi
  and   Q :: pi
  and   \<sigma> :: "(name \<times> name) list"

  shows "(P \<parallel> Q)[<\<sigma>>] = (P[<\<sigma>>]) \<parallel> (Q[<\<sigma>>])"
by(induct \<sigma> arbitrary: P Q, auto)

lemma seqSubstRes[simp]:
  fixes x :: name
  and   P :: pi
  and   \<sigma> :: "(name \<times> name) list"

  assumes "x \<sharp> \<sigma>"

  shows "(<\<nu>x>P)[<\<sigma>>] = <\<nu>x>(P[<\<sigma>>])"
using assms
by(induct \<sigma> arbitrary: x P) (auto simp add: fresh_list_cons fresh_prod)

lemma seqSubstBang[simp]:
  fixes P :: pi
  and   s :: "(name \<times> name) list"

  shows "(!P)[<\<sigma>>] = !(P[<\<sigma>>])"
by(induct \<sigma> arbitrary: P, auto)

lemma seqSubstEqvt[eqvt, simp]:
  fixes P :: pi
  and   \<sigma> :: "(name \<times> name) list"
  and   p :: "name prm"

  shows "p \<bullet> (P[<\<sigma>>]) = (p \<bullet> P)[<(p \<bullet> \<sigma>)>]"
by(induct \<sigma> arbitrary: P, auto simp add: eqvt_subs)

lemma seqSubstAppend[simp]:
  fixes P  :: pi
  and   \<sigma>  :: "(name \<times> name) list"
  and   \<sigma>' :: "(name \<times> name) list"

  shows "P[<(\<sigma>@\<sigma>')>] = (P[<\<sigma>>])[<\<sigma>'>]"
by(induct \<sigma> arbitrary: P, auto)

lemma freshSubstChain[intro]:
  fixes P :: pi
  and   \<sigma> :: "(name \<times> name) list"
  and   a :: name

  assumes "a \<sharp> P"
  and     "a \<sharp> \<sigma>"

  shows "a \<sharp> P[<\<sigma>>]"
using assms
by(induct \<sigma> arbitrary: a P, auto simp add: fresh_list_cons fresh_prod fresh_fact1)

end


(*  Title:      Containers/RBT_ext.thy
    Author:     Andreas Lochbihler, KIT *)

theory RBT_ext
imports
  "HOL-Library.RBT_Impl"
  Containers_Auxiliary
  List_Fusion
begin

section \<open>More on red-black trees\<close>

subsection \<open>More lemmas\<close>

context linorder begin

lemma is_rbt_fold_rbt_insert_impl:
  "is_rbt t \<Longrightarrow> is_rbt (RBT_Impl.fold rbt_insert t' t)"
by(simp add: rbt_insert_def is_rbt_fold_rbt_insertwk)

lemma rbt_sorted_fold_insert: "rbt_sorted t \<Longrightarrow> rbt_sorted (RBT_Impl.fold rbt_insert t' t)"
by(induct t' arbitrary: t)(simp_all add: rbt_insert_rbt_sorted)

lemma rbt_lookup_rbt_insert': "rbt_sorted t \<Longrightarrow> rbt_lookup (rbt_insert k v t) = (rbt_lookup t)(k \<mapsto> v)"
by(simp add: rbt_insert_def rbt_lookup_rbt_insertwk fun_eq_iff split: option.split)

lemma rbt_lookup_fold_rbt_insert_impl:
  "rbt_sorted t2 \<Longrightarrow>
  rbt_lookup (RBT_Impl.fold rbt_insert t1 t2) = rbt_lookup t2 ++ map_of (rev (RBT_Impl.entries t1))"
proof(induction t1 arbitrary: t2)
  case Empty thus ?case by simp
next
  case (Branch c l x k r)
  show ?case using Branch.prems
    by(simp add: map_add_def Branch.IH rbt_insert_rbt_sorted rbt_sorted_fold_insert rbt_lookup_rbt_insert' fun_eq_iff split: option.split)
qed

end

subsection \<open>Build the cross product of two RBTs\<close>

context fixes f :: "'a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> 'e" begin

definition alist_product :: "('a \<times> 'b) list \<Rightarrow> ('c \<times> 'd) list \<Rightarrow> (('a \<times> 'c) \<times> 'e) list"
where "alist_product xs ys = concat (map (\<lambda>(a, b). map (\<lambda>(c, d). ((a, c), f a b c d)) ys) xs)"

lemma alist_product_simps [simp]:
  "alist_product [] ys = []"
  "alist_product xs [] = []"
  "alist_product ((a, b) # xs) ys = map (\<lambda>(c, d). ((a, c), f a b c d)) ys @ alist_product xs ys"
by(simp_all add: alist_product_def)

lemma append_alist_product_conv_fold:
  "zs @ alist_product xs ys = rev (fold (\<lambda>(a, b). fold (\<lambda>(c, d) rest. ((a, c), f a b c d) # rest) ys) xs (rev zs))"
proof(induction xs arbitrary: zs)
  case Nil thus ?case by simp
next
  case (Cons x xs)
  obtain a b where x: "x = (a, b)" by(cases x)
  have "\<And>zs. fold (\<lambda>(c, d). (#) ((a, c), f a b c d)) ys zs =
    rev (map (\<lambda>(c, d). ((a, c), f a b c d)) ys) @ zs"
    by(induct ys) auto
  with Cons.IH[of "zs @ map (\<lambda>(c, d). ((a, c), f a b c d)) ys"] x
  show ?case by simp
qed

lemma set_alist_product:
  "set (alist_product xs ys) =
  (\<lambda>((a, b), (c, d)). ((a, c), f a b c d)) ` (set xs \<times> set ys)"
by(auto 4 3 simp add: alist_product_def intro: rev_image_eqI rev_bexI)

lemma distinct_alist_product:
  "\<lbrakk> distinct (map fst xs); distinct (map fst ys) \<rbrakk>
  \<Longrightarrow> distinct (map fst (alist_product xs ys))"
proof(induct xs)
  case Nil thus ?case by simp
next
  case (Cons x xs)
  obtain a b where x: "x = (a, b)" by(cases x)
  have "distinct (map (fst \<circ> (\<lambda>(c, d). ((a, c), f a b c d))) ys)"
    using \<open>distinct (map fst ys)\<close> by(induct ys)(auto intro: rev_image_eqI)
  thus ?case using Cons x by(auto simp add: set_alist_product intro: rev_image_eqI)
qed

lemma map_of_alist_product:
  "map_of (alist_product xs ys) (a, c) =
  (case map_of xs a of None \<Rightarrow> None
   | Some b \<Rightarrow> map_option (f a b c) (map_of ys c))"
proof(induction xs)
  case Nil thus ?case by simp
next
  case (Cons x xs)
  obtain a b where x: "x = (a, b)" by (cases x)
  let ?map = "map (\<lambda>(c, d). ((a, c), f a b c d)) ys"
  have "map_of ?map (a, c) = map_option (f a b c) (map_of ys c)"
    by(induct ys) auto
  moreover {
    fix a' assume "a' \<noteq> a"
    hence "map_of ?map (a', c) = None"
      by(induct ys) auto }
  ultimately show ?case using x Cons.IH
    by(auto simp add: map_add_def split: option.split)
qed

definition rbt_product :: "('a, 'b) rbt \<Rightarrow> ('c, 'd) rbt \<Rightarrow> ('a \<times> 'c, 'e) rbt"
where
  "rbt_product rbt1 rbt2 = rbtreeify (alist_product (RBT_Impl.entries rbt1) (RBT_Impl.entries rbt2))"

lemma rbt_product_code [code]:
  "rbt_product rbt1 rbt2 =
   rbtreeify (rev (RBT_Impl.fold (\<lambda>a b. RBT_Impl.fold (\<lambda>c d rest. ((a, c), f a b c d) # rest) rbt2) rbt1 []))"
unfolding rbt_product_def alist_product_code RBT_Impl.fold_def ..

end

context
  fixes leq_a :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubseteq>\<^sub>a" 50)
  and less_a :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubset>\<^sub>a" 50)
  and leq_b :: "'b \<Rightarrow> 'b \<Rightarrow> bool" (infix "\<sqsubseteq>\<^sub>b" 50)
  and less_b :: "'b \<Rightarrow> 'b \<Rightarrow> bool" (infix "\<sqsubset>\<^sub>b" 50)
  assumes lin_a: "class.linorder leq_a less_a"
  and lin_b: "class.linorder leq_b less_b"
begin

abbreviation (input) less_eq_prod' :: "('a \<times> 'b) \<Rightarrow> ('a \<times> 'b) \<Rightarrow> bool" (infix "\<sqsubseteq>" 50)
where "less_eq_prod' \<equiv> less_eq_prod leq_a less_a leq_b"

abbreviation (input) less_prod' :: "('a \<times> 'b) \<Rightarrow> ('a \<times> 'b) \<Rightarrow> bool" (infix "\<sqsubset>" 50)
where "less_prod' \<equiv> less_prod leq_a less_a less_b"

lemmas linorder_prod = linorder_prod[OF lin_a lin_b]

lemma sorted_alist_product:
  assumes xs: "linorder.sorted leq_a (map fst xs)" "distinct (map fst xs)"
  and ys: "linorder.sorted (\<sqsubseteq>\<^sub>b) (map fst ys)"
  shows "linorder.sorted (\<sqsubseteq>) (map fst (alist_product f xs ys))"
proof -
  interpret a: linorder "(\<sqsubseteq>\<^sub>a)" "(\<sqsubset>\<^sub>a)" by(fact lin_a)

  note [simp] =
    linorder.sorted0[OF linorder_prod] linorder.sorted1[OF linorder_prod]
    linorder.sorted_append[OF linorder_prod]
    linorder.sorted1[OF lin_b]

  show ?thesis using xs
  proof(induction xs)
    case Nil show ?case by simp
  next
    case (Cons x xs)
    obtain a b where x: "x = (a, b)" by(cases x)
    have "linorder.sorted (\<sqsubseteq>) (map fst (map (\<lambda>(c, d). ((a, c), f a b c d)) ys))"
      using ys by(induct ys) auto
    thus ?case using x Cons
      by(fastforce simp add: set_alist_product a.not_less dest: bspec a.order_antisym intro: rev_image_eqI)
  qed
qed

lemma is_rbt_rbt_product:
  "\<lbrakk> ord.is_rbt (\<sqsubset>\<^sub>a) rbt1; ord.is_rbt (\<sqsubset>\<^sub>b) rbt2 \<rbrakk>
  \<Longrightarrow> ord.is_rbt (\<sqsubset>) (rbt_product f rbt1 rbt2)"
unfolding rbt_product_def
by(blast intro: linorder.is_rbt_rbtreeify[OF linorder_prod] sorted_alist_product linorder.rbt_sorted_entries[OF lin_a] ord.is_rbt_rbt_sorted linorder.distinct_entries[OF lin_a] linorder.rbt_sorted_entries[OF lin_b] distinct_alist_product linorder.distinct_entries[OF lin_b])

lemma rbt_lookup_rbt_product:
  "\<lbrakk> ord.is_rbt (\<sqsubset>\<^sub>a) rbt1; ord.is_rbt (\<sqsubset>\<^sub>b) rbt2 \<rbrakk>
  \<Longrightarrow> ord.rbt_lookup (\<sqsubset>) (rbt_product f rbt1 rbt2) (a, c) =
     (case ord.rbt_lookup (\<sqsubset>\<^sub>a) rbt1 a of None \<Rightarrow> None
      | Some b \<Rightarrow> map_option (f a b c) (ord.rbt_lookup (\<sqsubset>\<^sub>b) rbt2 c))"
by(simp add: rbt_product_def linorder.rbt_lookup_rbtreeify[OF linorder_prod] linorder.is_rbt_rbtreeify[OF linorder_prod] sorted_alist_product linorder.rbt_sorted_entries[OF lin_a] ord.is_rbt_rbt_sorted linorder.distinct_entries[OF lin_a] linorder.rbt_sorted_entries[OF lin_b] distinct_alist_product linorder.distinct_entries[OF lin_b] map_of_alist_product linorder.map_of_entries[OF lin_a] linorder.map_of_entries[OF lin_b] cong: option.case_cong)

end

hide_const less_eq_prod' less_prod'

subsection \<open>Build an RBT where keys are paired with themselves\<close>

primrec RBT_Impl_diag :: "('a, 'b) rbt \<Rightarrow> ('a \<times> 'a, 'b) rbt"
where
  "RBT_Impl_diag rbt.Empty = rbt.Empty"
| "RBT_Impl_diag (rbt.Branch c l k v r) = rbt.Branch c (RBT_Impl_diag l) (k, k) v (RBT_Impl_diag r)"

lemma entries_RBT_Impl_diag:
  "RBT_Impl.entries (RBT_Impl_diag t) = map (\<lambda>(k, v). ((k, k), v)) (RBT_Impl.entries t)"
by(induct t) simp_all

lemma keys_RBT_Impl_diag:
  "RBT_Impl.keys (RBT_Impl_diag t) = map (\<lambda>k. (k, k)) (RBT_Impl.keys t)"
by(simp add: RBT_Impl.keys_def entries_RBT_Impl_diag split_beta)

lemma rbt_sorted_RBT_Impl_diag:
  "ord.rbt_sorted lt t \<Longrightarrow> ord.rbt_sorted (less_prod leq lt lt) (RBT_Impl_diag t)"
by(induct t)(auto simp add: ord.rbt_sorted.simps ord.rbt_less_prop ord.rbt_greater_prop keys_RBT_Impl_diag)

lemma bheight_RBT_Impl_diag:
  "bheight (RBT_Impl_diag t) = bheight t"
by(induct t) simp_all

lemma inv_RBT_Impl_diag:
  assumes "inv1 t" "inv2 t"
  shows "inv1 (RBT_Impl_diag t)" "inv2 (RBT_Impl_diag t)"
  and "color_of t = color.B \<Longrightarrow> color_of (RBT_Impl_diag t) = color.B"
using assms by(induct t)(auto simp add: bheight_RBT_Impl_diag)

lemma is_rbt_RBT_Impl_diag:
  "ord.is_rbt lt t \<Longrightarrow> ord.is_rbt (less_prod leq lt lt) (RBT_Impl_diag t)"
by(simp add: ord.is_rbt_def rbt_sorted_RBT_Impl_diag inv_RBT_Impl_diag)

lemma (in linorder) rbt_lookup_RBT_Impl_diag:
  "ord.rbt_lookup (less_prod (\<le>) (<) (<)) (RBT_Impl_diag t) =
  (\<lambda>(k, k'). if k = k' then ord.rbt_lookup (<) t k else None)"
by(induct t)(auto simp add: ord.rbt_lookup.simps fun_eq_iff)

subsection \<open>Folding and quantifiers over RBTs\<close>

definition RBT_Impl_fold1 :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('a, unit) RBT_Impl.rbt \<Rightarrow> 'a"
where "RBT_Impl_fold1 f rbt = fold f (tl (RBT_Impl.keys rbt)) (hd (RBT_Impl.keys rbt))"

lemma RBT_Impl_fold1_simps [simp, code]:
  "RBT_Impl_fold1 f rbt.Empty = undefined"
  "RBT_Impl_fold1 f (Branch c rbt.Empty k v r) = RBT_Impl.fold (\<lambda>k v. f k) r k"
  "RBT_Impl_fold1 f (Branch c (Branch c' l' k' v' r') k v r) =
   RBT_Impl.fold (\<lambda>k v. f k) r (f k (RBT_Impl_fold1 f (Branch c' l' k' v' r')))"
by(simp_all add: RBT_Impl_fold1_def RBT_Impl.keys_def fold_map RBT_Impl.fold_def split_def o_def tl_append hd_def split: list.split)

definition RBT_Impl_rbt_all :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a, 'b) rbt \<Rightarrow> bool"
where [code del]: "RBT_Impl_rbt_all P rbt = (\<forall>(k, v) \<in> set (RBT_Impl.entries rbt). P k v)"

lemma RBT_Impl_rbt_all_simps [simp, code]:
  "RBT_Impl_rbt_all P rbt.Empty \<longleftrightarrow> True"
  "RBT_Impl_rbt_all P (Branch c l k v r) \<longleftrightarrow> P k v \<and> RBT_Impl_rbt_all P l \<and> RBT_Impl_rbt_all P r"
by(auto simp add: RBT_Impl_rbt_all_def)

definition RBT_Impl_rbt_ex :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a, 'b) rbt \<Rightarrow> bool"
where [code del]: "RBT_Impl_rbt_ex P rbt = (\<exists>(k, v) \<in> set (RBT_Impl.entries rbt). P k v)"

lemma RBT_Impl_rbt_ex_simps [simp, code]:
  "RBT_Impl_rbt_ex P rbt.Empty \<longleftrightarrow> False"
  "RBT_Impl_rbt_ex P (Branch c l k v r) \<longleftrightarrow> P k v \<or> RBT_Impl_rbt_ex P l \<or> RBT_Impl_rbt_ex P r"
by(auto simp add: RBT_Impl_rbt_ex_def)

subsection \<open>List fusion for RBTs\<close>

type_synonym ('a, 'b, 'c) rbt_generator_state = "('c \<times> ('a, 'b) RBT_Impl.rbt) list \<times> ('a, 'b) RBT_Impl.rbt"

fun rbt_has_next :: "('a, 'b, 'c) rbt_generator_state \<Rightarrow> bool"
where
  "rbt_has_next ([], rbt.Empty) = False"
| "rbt_has_next _ = True"

fun rbt_keys_next :: "('a, 'b, 'a) rbt_generator_state \<Rightarrow> 'a \<times> ('a, 'b, 'a) rbt_generator_state"
where
  "rbt_keys_next ((k, t) # kts, rbt.Empty) = (k, kts, t)"
| "rbt_keys_next (kts, rbt.Branch c l k v r) = rbt_keys_next ((k, r) # kts, l)"

lemma rbt_generator_induct [case_names empty split shuffle]:
  assumes "P ([], rbt.Empty)"
  and "\<And>k t kts. P (kts, t) \<Longrightarrow> P ((k, t) # kts, rbt.Empty)"
  and "\<And>kts c l k v r. P ((f k v, r) # kts, l) \<Longrightarrow> P (kts, Branch c l k v r)"
  shows "P ktst"
using assms
apply(induction_schema)
apply pat_completeness
apply(relation "measure (\<lambda>(kts, t). size_list (\<lambda>(k, t). size_rbt (\<lambda>_. 1) (\<lambda>_. 1) t) kts + size_rbt (\<lambda>_. 1) (\<lambda>_. 1) t)")
apply simp_all
done

lemma terminates_rbt_keys_generator:
  "terminates (rbt_has_next, rbt_keys_next)"
proof
  fix ktst :: "('a \<times> ('a, 'b) rbt) list \<times> ('a, 'b) rbt"
  show "ktst \<in> terminates_on (rbt_has_next, rbt_keys_next)"
    by(induct ktst taking: "\<lambda>k _. k" rule: rbt_generator_induct)(auto 4 3 intro: terminates_on.intros elim: terminates_on.cases)
qed

lift_definition rbt_keys_generator :: "('a, ('a, 'b, 'a) rbt_generator_state) generator"
  is "(rbt_has_next, rbt_keys_next)"
by(rule terminates_rbt_keys_generator)

definition rbt_init :: "('a, 'b) rbt \<Rightarrow> ('a, 'b, 'c) rbt_generator_state"
where "rbt_init = Pair []"

lemma has_next_rbt_keys_generator [simp]:
  "list.has_next rbt_keys_generator = rbt_has_next"
by transfer simp

lemma next_rbt_keys_generator [simp]:
  "list.next rbt_keys_generator = rbt_keys_next"
by transfer simp

lemma unfoldr_rbt_keys_generator_aux:
  "list.unfoldr rbt_keys_generator (kts, t) =
  RBT_Impl.keys t @ concat (map (\<lambda>(k, t). k # RBT_Impl.keys t) kts)"
proof(induct "(kts, t)" arbitrary: kts t taking: "\<lambda>k _. k" rule: rbt_generator_induct)
  case empty thus ?case
    by(simp add: list.unfoldr.simps)
next
  case split thus ?case
    by(subst list.unfoldr.simps) simp
next
  case shuffle thus ?case
    by(subst list.unfoldr.simps)(subst (asm) list.unfoldr.simps, simp)
qed

corollary unfoldr_rbt_keys_generator:
  "list.unfoldr rbt_keys_generator (rbt_init t) = RBT_Impl.keys t"
by(simp add: unfoldr_rbt_keys_generator_aux rbt_init_def)

fun rbt_entries_next ::
  "('a, 'b, 'a \<times> 'b) rbt_generator_state \<Rightarrow> ('a \<times> 'b) \<times> ('a, 'b, 'a \<times> 'b) rbt_generator_state"
where
  "rbt_entries_next ((kv, t) # kts, rbt.Empty) = (kv, kts, t)"
| "rbt_entries_next (kts, rbt.Branch c l k v r) = rbt_entries_next (((k, v), r) # kts, l)"

lemma terminates_rbt_entries_generator:
  "terminates (rbt_has_next, rbt_entries_next)"
proof(rule terminatesI)
  fix ktst :: "('a, 'b, 'a \<times> 'b) rbt_generator_state"
  show "ktst \<in> terminates_on (rbt_has_next, rbt_entries_next)"
    by(induct ktst taking: Pair rule: rbt_generator_induct)(auto 4 3 intro: terminates_on.intros elim: terminates_on.cases)
qed

lift_definition rbt_entries_generator :: "('a \<times> 'b, ('a, 'b, 'a \<times> 'b) rbt_generator_state) generator"
  is "(rbt_has_next, rbt_entries_next)"
by(rule terminates_rbt_entries_generator)

lemma has_next_rbt_entries_generator [simp]:
  "list.has_next rbt_entries_generator = rbt_has_next"
by transfer simp

lemma next_rbt_entries_generator [simp]:
  "list.next rbt_entries_generator = rbt_entries_next"
by transfer simp

lemma unfoldr_rbt_entries_generator_aux:
  "list.unfoldr rbt_entries_generator (kts, t) =
  RBT_Impl.entries t @ concat (map (\<lambda>(k, t). k # RBT_Impl.entries t) kts)"
proof(induct "(kts, t)" arbitrary: kts t taking: Pair rule: rbt_generator_induct)
  case empty thus ?case
    by(simp add: list.unfoldr.simps)
next
  case split thus ?case
    by(subst list.unfoldr.simps) simp
next
  case shuffle thus ?case
    by(subst list.unfoldr.simps)(subst (asm) list.unfoldr.simps, simp)
qed

corollary unfoldr_rbt_entries_generator:
  "list.unfoldr rbt_entries_generator (rbt_init t) = RBT_Impl.entries t"
by(simp add: unfoldr_rbt_entries_generator_aux rbt_init_def)

end