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

section \<open>An abstract view on maps for code generation.\<close>

theory Mapping
imports Main
begin

subsection \<open>Parametricity transfer rules\<close>

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

context includes lifting_syntax
begin

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

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

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

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

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

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

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

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

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

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

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

lemma combine_with_key_parametric:
  "((A ===> B ===> B ===> B) ===> (A ===> rel_option B) ===> (A ===> rel_option B) ===>
    (A ===> rel_option B)) (\<lambda>f m1 m2 x. combine_options (f x) (m1 x) (m2 x))
    (\<lambda>f m1 m2 x. combine_options (f x) (m1 x) (m2 x))"
  unfolding combine_options_def by transfer_prover

lemma combine_parametric:
  "((B ===> B ===> B) ===> (A ===> rel_option B) ===> (A ===> rel_option B) ===>
    (A ===> rel_option B)) (\<lambda>f m1 m2 x. combine_options f (m1 x) (m2 x))
    (\<lambda>f m1 m2 x. combine_options f (m1 x) (m2 x))"
  unfolding combine_options_def by transfer_prover

end

subsection \<open>Type definition and primitive operations\<close>

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

setup_lifting type_definition_mapping

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

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

definition "lookup_default d m k = (case Mapping.lookup m k of None \<Rightarrow> d | Some v \<Rightarrow> v)"

declare [[code drop: Mapping.lookup]]
setup \<open>Code.add_eqn (Code.Equation, true) @{thm Mapping.lookup.abs_eq}\<close>  (* FIXME lifting *)

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

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

lift_definition filter :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a, 'b) mapping \<Rightarrow> ('a, 'b) mapping"
  is "\<lambda>P m k. case m k of None \<Rightarrow> None | Some v \<Rightarrow> if P k v then Some v else None" .

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

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

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

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

lift_definition map_values :: "('c \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> ('c, 'a) mapping \<Rightarrow> ('c, 'b) mapping"
  is "\<lambda>f m x. map_option (f x) (m x)" .

lift_definition combine_with_key ::
  "('a \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a,'b) mapping \<Rightarrow> ('a,'b) mapping \<Rightarrow> ('a,'b) mapping"
  is "\<lambda>f m1 m2 x. combine_options (f x) (m1 x) (m2 x)" parametric combine_with_key_parametric .

lift_definition combine ::
  "('b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a,'b) mapping \<Rightarrow> ('a,'b) mapping \<Rightarrow> ('a,'b) mapping"
  is "\<lambda>f m1 m2 x. combine_options f (m1 x) (m2 x)" parametric combine_parametric .

definition "All_mapping m P \<longleftrightarrow>
  (\<forall>x. case Mapping.lookup m x of None \<Rightarrow> True | Some y \<Rightarrow> P x y)"

declare [[code drop: map]]

subsection \<open>Functorial structure\<close>

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

subsection \<open>Derived operations\<close>

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

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

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

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

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

text \<open>Manual derivation of transfer rule is non-trivial\<close>

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

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

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

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

instantiation mapping :: (type, type) equal
begin

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

instance
  apply standard
  unfolding equal_mapping_def
  apply transfer
  apply auto
  done

end

context includes lifting_syntax
begin

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

end

subsection \<open>Properties\<close>

lemma mapping_eqI: "(\<And>x. lookup m x = lookup m' x) \<Longrightarrow> m = m'"
  by transfer (simp add: fun_eq_iff)

lemma mapping_eqI':
  assumes "\<And>x. x \<in> Mapping.keys m \<Longrightarrow> Mapping.lookup_default d m x = Mapping.lookup_default d m' x"
    and "Mapping.keys m = Mapping.keys m'"
  shows "m = m'"
proof (intro mapping_eqI)
  show "Mapping.lookup m x = Mapping.lookup m' x" for x
  proof (cases "Mapping.lookup m x")
    case None
    then have "x \<notin> Mapping.keys m"
      by transfer (simp add: dom_def)
    then have "x \<notin> Mapping.keys m'"
      by (simp add: assms)
    then have "Mapping.lookup m' x = None"
      by transfer (simp add: dom_def)
    with None show ?thesis
      by simp
  next
    case (Some y)
    then have A: "x \<in> Mapping.keys m"
      by transfer (simp add: dom_def)
    then have "x \<in> Mapping.keys m'"
      by (simp add: assms)
    then have "\<exists>y'. Mapping.lookup m' x = Some y'"
      by transfer (simp add: dom_def)
    with Some assms(1)[OF A] show ?thesis
      by (auto simp add: lookup_default_def)
  qed
qed

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

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

lemma lookup_update': "Mapping.lookup (update k v m) k' = (if k = k' then Some v else lookup m k')"
  by (auto simp: lookup_update lookup_update_neq)

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

lemma lookup_filter:
  "lookup (filter P m) k =
    (case lookup m k of
      None \<Rightarrow> None
    | Some v \<Rightarrow> if P k v then Some v else None)"
  by transfer simp_all

lemma lookup_map_values: "lookup (map_values f m) k = map_option (f k) (lookup m k)"
  by transfer simp_all

lemma lookup_default_empty: "lookup_default d empty k = d"
  by (simp add: lookup_default_def lookup_empty)

lemma lookup_default_update: "lookup_default d (update k v m) k = v"
  by (simp add: lookup_default_def lookup_update)

lemma lookup_default_update_neq:
  "k \<noteq> k' \<Longrightarrow> lookup_default d (update k v m) k' = lookup_default d m k'"
  by (simp add: lookup_default_def lookup_update_neq)

lemma lookup_default_update':
  "lookup_default d (update k v m) k' = (if k = k' then v else lookup_default d m k')"
  by (auto simp: lookup_default_update lookup_default_update_neq)

lemma lookup_default_filter:
  "lookup_default d (filter P m) k =
     (if P k (lookup_default d m k) then lookup_default d m k else d)"
  by (simp add: lookup_default_def lookup_filter split: option.splits)

lemma lookup_default_map_values:
  "lookup_default (f k d) (map_values f m) k = f k (lookup_default d m k)"
  by (simp add: lookup_default_def lookup_map_values split: option.splits)

lemma lookup_combine_with_key:
  "Mapping.lookup (combine_with_key f m1 m2) x =
    combine_options (f x) (Mapping.lookup m1 x) (Mapping.lookup m2 x)"
  by transfer (auto split: option.splits)

lemma combine_altdef: "combine f m1 m2 = combine_with_key (\<lambda>_. f) m1 m2"
  by transfer' (rule refl)

lemma lookup_combine:
  "Mapping.lookup (combine f m1 m2) x =
     combine_options f (Mapping.lookup m1 x) (Mapping.lookup m2 x)"
  by transfer (auto split: option.splits)

lemma lookup_default_neutral_combine_with_key:
  assumes "\<And>x. f k d x = x" "\<And>x. f k x d = x"
  shows "Mapping.lookup_default d (combine_with_key f m1 m2) k =
    f k (Mapping.lookup_default d m1 k) (Mapping.lookup_default d m2 k)"
  by (auto simp: lookup_default_def lookup_combine_with_key assms split: option.splits)

lemma lookup_default_neutral_combine:
  assumes "\<And>x. f d x = x" "\<And>x. f x d = x"
  shows "Mapping.lookup_default d (combine f m1 m2) x =
    f (Mapping.lookup_default d m1 x) (Mapping.lookup_default d m2 x)"
  by (auto simp: lookup_default_def lookup_combine assms split: option.splits)

lemma lookup_map_entry: "lookup (map_entry x f m) x = map_option f (lookup m x)"
  by transfer (auto split: option.splits)

lemma lookup_map_entry_neq: "x \<noteq> y \<Longrightarrow> lookup (map_entry x f m) y = lookup m y"
  by transfer (auto split: option.splits)

lemma lookup_map_entry':
  "lookup (map_entry x f m) y =
     (if x = y then map_option f (lookup m y) else lookup m y)"
  by transfer (auto split: option.splits)

lemma lookup_default: "lookup (default x d m) x = Some (lookup_default d m x)"
  unfolding lookup_default_def default_def
  by transfer (auto split: option.splits)

lemma lookup_default_neq: "x \<noteq> y \<Longrightarrow> lookup (default x d m) y = lookup m y"
  unfolding lookup_default_def default_def
  by transfer (auto split: option.splits)

lemma lookup_default':
  "lookup (default x d m) y =
    (if x = y then Some (lookup_default d m x) else lookup m y)"
  unfolding lookup_default_def default_def
  by transfer (auto split: option.splits)

lemma lookup_map_default: "lookup (map_default x d f m) x = Some (f (lookup_default d m x))"
  unfolding lookup_default_def default_def
  by (simp add: map_default_def lookup_map_entry lookup_default lookup_default_def)

lemma lookup_map_default_neq: "x \<noteq> y \<Longrightarrow> lookup (map_default x d f m) y = lookup m y"
  unfolding lookup_default_def default_def
  by (simp add: map_default_def lookup_map_entry_neq lookup_default_neq)

lemma lookup_map_default':
  "lookup (map_default x d f m) y =
    (if x = y then Some (f (lookup_default d m x)) else lookup m y)"
  unfolding lookup_default_def default_def
  by (simp add: map_default_def lookup_map_entry' lookup_default' lookup_default_def)

lemma lookup_tabulate:
  assumes "distinct xs"
  shows "Mapping.lookup (Mapping.tabulate xs f) x = (if x \<in> set xs then Some (f x) else None)"
  using assms by transfer (auto simp: map_of_eq_None_iff o_def dest!: map_of_SomeD)

lemma lookup_of_alist: "Mapping.lookup (Mapping.of_alist xs) k = map_of xs k"
  by transfer simp_all

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

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

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

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

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

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

lemma map_values_update: "map_values f (update k v m) = update k (f k v) (map_values f m)"
  by transfer (simp_all add: fun_eq_iff)

lemma size_mono: "finite (keys m') \<Longrightarrow> keys m \<subseteq> keys m' \<Longrightarrow> size m \<le> size m'"
  unfolding size_def by (auto intro: card_mono)

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

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

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

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

lemma keys_filter: "keys (filter P m) \<subseteq> keys m"
  by transfer (auto split: option.splits)

lemma size_filter: "finite (keys m) \<Longrightarrow> size (filter P m) \<le> size m"
  by (intro size_mono keys_filter)

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

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

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

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

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

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

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

lemma is_empty_map_values [simp]: "is_empty (map_values f m) \<longleftrightarrow> is_empty m"
  unfolding is_empty_def by transfer (auto simp: fun_eq_iff)

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

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

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

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

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

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

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

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

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

lemma keys_map_values [simp]: "keys (map_values f m) = keys m"
  by transfer (simp_all add: dom_def)

lemma keys_combine_with_key [simp]:
  "Mapping.keys (combine_with_key f m1 m2) = Mapping.keys m1 \<union> Mapping.keys m2"
  by transfer (auto simp: dom_def combine_options_def split: option.splits)

lemma keys_combine [simp]: "Mapping.keys (combine f m1 m2) = Mapping.keys m1 \<union> Mapping.keys m2"
  by (simp add: combine_altdef)

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

lemma keys_of_alist [simp]: "keys (of_alist xs) = set (List.map fst xs)"
  by transfer (simp_all add: dom_map_of_conv_image_fst)

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

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

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

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

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

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

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

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

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

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

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

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

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

lemma All_mapping_mono:
  "(\<And>k v. k \<in> keys m \<Longrightarrow> P k v \<Longrightarrow> Q k v) \<Longrightarrow> All_mapping m P \<Longrightarrow> All_mapping m Q"
  unfolding All_mapping_def by transfer (auto simp: All_mapping_def dom_def split: option.splits)

lemma All_mapping_empty [simp]: "All_mapping Mapping.empty P"
  by (auto simp: All_mapping_def lookup_empty)

lemma All_mapping_update_iff:
  "All_mapping (Mapping.update k v m) P \<longleftrightarrow> P k v \<and> All_mapping m (\<lambda>k' v'. k = k' \<or> P k' v')"
  unfolding All_mapping_def
proof safe
  assume "\<forall>x. case Mapping.lookup (Mapping.update k v m) x of None \<Rightarrow> True | Some y \<Rightarrow> P x y"
  then have *: "case Mapping.lookup (Mapping.update k v m) x of None \<Rightarrow> True | Some y \<Rightarrow> P x y" for x
    by blast
  from *[of k] show "P k v"
    by (simp add: lookup_update)
  show "case Mapping.lookup m x of None \<Rightarrow> True | Some v' \<Rightarrow> k = x \<or> P x v'" for x
    using *[of x] by (auto simp add: lookup_update' split: if_splits option.splits)
next
  assume "P k v"
  assume "\<forall>x. case Mapping.lookup m x of None \<Rightarrow> True | Some v' \<Rightarrow> k = x \<or> P x v'"
  then have A: "case Mapping.lookup m x of None \<Rightarrow> True | Some v' \<Rightarrow> k = x \<or> P x v'" for x
    by blast
  show "case Mapping.lookup (Mapping.update k v m) x of None \<Rightarrow> True | Some xa \<Rightarrow> P x xa" for x
    using \<open>P k v\<close> A[of x] by (auto simp: lookup_update' split: option.splits)
qed

lemma All_mapping_update:
  "P k v \<Longrightarrow> All_mapping m (\<lambda>k' v'. k = k' \<or> P k' v') \<Longrightarrow> All_mapping (Mapping.update k v m) P"
  by (simp add: All_mapping_update_iff)

lemma All_mapping_filter_iff: "All_mapping (filter P m) Q \<longleftrightarrow> All_mapping m (\<lambda>k v. P k v \<longrightarrow> Q k v)"
  by (auto simp: All_mapping_def lookup_filter split: option.splits)

lemma All_mapping_filter: "All_mapping m Q \<Longrightarrow> All_mapping (filter P m) Q"
  by (auto simp: All_mapping_filter_iff intro: All_mapping_mono)

lemma All_mapping_map_values: "All_mapping (map_values f m) P \<longleftrightarrow> All_mapping m (\<lambda>k v. P k (f k v))"
  by (auto simp: All_mapping_def lookup_map_values split: option.splits)

lemma All_mapping_tabulate: "(\<forall>x\<in>set xs. P x (f x)) \<Longrightarrow> All_mapping (Mapping.tabulate xs f) P"
  unfolding All_mapping_def
  apply (intro allI)
  apply transfer
  apply (auto split: option.split dest!: map_of_SomeD)
  done

lemma All_mapping_alist:
  "(\<And>k v. (k, v) \<in> set xs \<Longrightarrow> P k v) \<Longrightarrow> All_mapping (Mapping.of_alist xs) P"
  by (auto simp: All_mapping_def lookup_of_alist dest!: map_of_SomeD split: option.splits)

lemma combine_empty [simp]: "combine f Mapping.empty y = y" "combine f y Mapping.empty = y"
  by (transfer; force)+

lemma (in abel_semigroup) comm_monoid_set_combine: "comm_monoid_set (combine f) Mapping.empty"
  by standard (transfer fixing: f, simp add: combine_options_ac[of f] ac_simps)+

locale combine_mapping_abel_semigroup = abel_semigroup
begin

sublocale combine: comm_monoid_set "combine f" Mapping.empty
  by (rule comm_monoid_set_combine)

lemma fold_combine_code:
  "combine.F g (set xs) = foldr (\<lambda>x. combine f (g x)) (remdups xs) Mapping.empty"
proof -
  have "combine.F g (set xs) = foldr (\<lambda>x. combine f (g x)) xs Mapping.empty"
    if "distinct xs" for xs
    using that by (induction xs) simp_all
  from this[of "remdups xs"] show ?thesis by simp
qed

lemma keys_fold_combine: "finite A \<Longrightarrow> Mapping.keys (combine.F g A) = (\<Union>x\<in>A. Mapping.keys (g x))"
  by (induct A rule: finite_induct) simp_all

end

subsection \<open>Code generator setup\<close>

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

end


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

(******** Structural Congruence **********)

lemma weakBisimStructCong:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<equiv>\<^sub>s Q"

  shows "P \<approx> Q"
using assms
by(metis earlyBisimStructCong strongBisimWeakBisim)

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

  shows "[a\<frown>a]P \<approx> P"
proof -
  have "[a\<frown>a]P \<sim>\<^sub>e P" by(rule Strong_Early_Bisim_SC.matchId)
  thus ?thesis by(rule strongBisimWeakBisim)
qed

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

  assumes "a \<noteq> b"

  shows "[a\<noteq>b]P \<approx> P"
proof -
  from \<open>a \<noteq> b\<close> have "[a\<noteq>b]P \<sim>\<^sub>e P" by(rule Strong_Early_Bisim_SC.mismatchId)
  thus ?thesis by(rule strongBisimWeakBisim)
qed

  shows "[a\<noteq>a]P \<approx> \<zero>"
proof -
  have "[a\<noteq>a]P \<sim>\<^sub>e \<zero>" by(rule Strong_Early_Bisim_SC.mismatchNil)
  thus ?thesis by(rule strongBisimWeakBisim)
qed

(******** The \<nu>-operator *****************)

lemma resComm:
  fixes P :: pi

  shows "<\<nu>a><\<nu>b>P \<approx> <\<nu>b><\<nu>a>P"
proof -
  have "<\<nu>a><\<nu>b>P \<sim>\<^sub>e <\<nu>b><\<nu>a>P" by(rule Strong_Early_Bisim_SC.resComm)
  thus ?thesis by(rule strongBisimWeakBisim)
qed

(******** The +-operator *********)

lemma sumSym:
  fixes P :: pi
  and   Q :: pi

  shows "P \<oplus> Q \<approx> Q \<oplus> P"
proof -
  have "P \<oplus> Q \<sim>\<^sub>e Q \<oplus> P" by(rule Strong_Early_Bisim_SC.sumSym)
  thus ?thesis by(rule strongBisimWeakBisim)
qed

(******** The |-operator *********)

lemma parZero:
  fixes P :: pi

  shows "P \<parallel> \<zero> \<approx> P"
proof -
  have "P \<parallel> \<zero> \<sim>\<^sub>e P" by(rule Strong_Early_Bisim_SC.parZero)
  thus ?thesis by(rule strongBisimWeakBisim)
qed

lemma parSym:
  fixes P :: pi
  and   Q :: pi

  shows "P \<parallel> Q \<approx> Q \<parallel> P"
proof -
  have "P \<parallel> Q \<sim>\<^sub>e Q \<parallel> P" by(rule Strong_Early_Bisim_SC.parSym)
  thus ?thesis by(rule strongBisimWeakBisim)
qed

  assumes "x \<sharp> P"

  shows "<\<nu>x>(P \<parallel> Q) \<approx> P \<parallel> <\<nu>x>Q"
proof -
  from \<open>x \<sharp> P\<close> have "<\<nu>x>(P \<parallel> Q) \<sim>\<^sub>e P \<parallel> <\<nu>x>Q" by(rule Strong_Early_Bisim_SC.scopeExtPar)
  thus ?thesis by(rule strongBisimWeakBisim)
qed

lemma scopeExtPar':
  fixes P :: pi
  and   Q :: pi
  and   x :: name

  assumes "x \<sharp> Q"

  shows "<\<nu>x>(P \<parallel> Q) \<approx> (<\<nu>x>P) \<parallel> Q"
proof -
  from \<open>x \<sharp> Q\<close> have "<\<nu>x>(P \<parallel> Q) \<sim>\<^sub>e (<\<nu>x>P) \<parallel> Q" by(rule Strong_Early_Bisim_SC.scopeExtPar')
  thus ?thesis by(rule strongBisimWeakBisim)
qed

  shows "(P \<parallel> Q) \<parallel> R \<approx> P \<parallel> (Q \<parallel> R)"
proof -
  have "(P \<parallel> Q) \<parallel> R \<sim>\<^sub>e P \<parallel> (Q \<parallel> R)" by(rule Strong_Early_Bisim_SC.parAssoc)
  thus ?thesis by(rule strongBisimWeakBisim)
qed

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

  assumes "a \<sharp> P"

  shows "<\<nu>a>P \<approx> P"
proof -
  from \<open>a \<sharp> P\<close> have "<\<nu>a>P \<sim>\<^sub>e P" by(rule Strong_Early_Bisim_SC.freshRes)
  thus ?thesis by(rule strongBisimWeakBisim)
qed

lemma scopeExtSum:
  fixes P :: pi
  and   Q :: pi
  and   x :: name

  assumes "x \<sharp> P"

  shows "<\<nu>x>(P \<oplus> Q) \<approx> P \<oplus> <\<nu>x>Q"
proof -
  from \<open>x \<sharp> P\<close> have "<\<nu>x>(P \<oplus> Q) \<sim>\<^sub>e P \<oplus> <\<nu>x>Q" by(rule Strong_Early_Bisim_SC.scopeExtSum)
  thus ?thesis by(rule strongBisimWeakBisim)
qed

lemma bangSC:
  fixes P

  shows "!P \<approx> P \<parallel> !P"
proof -
  have "!P \<sim>\<^sub>e P \<parallel> !P" by(rule Strong_Early_Bisim_SC.bangSC)
  thus ?thesis by(rule strongBisimWeakBisim)
qed

end


theory "DistinctVars-Nominal"
imports DistinctVars "Nominal-Utils"
begin

subsubsection {* Freshness lemmas related to associative lists *}

lemma heapVars_not_fresh:
  "x \<in> heapVars \<Gamma> \<Longrightarrow> \<not>(atom x \<sharp> \<Gamma>)"
  by (induct \<Gamma>, auto simp add: fresh_Cons fresh_Pair)

lemma fresh_delete:
  assumes "atom x \<sharp> \<Gamma>"
  shows "atom x \<sharp> (delete v \<Gamma>)"
using assms
by(induct \<Gamma>)(auto simp add: fresh_Cons)

lemma fresh_heap_expr:
  assumes "a \<sharp> \<Gamma>"
  and "(x,e) \<in> set \<Gamma>"
  shows "a \<sharp> e"
  using assms
  by (metis fresh_list_elem fresh_Pair)

lemma fresh_heap_expr':
  assumes "a \<sharp> \<Gamma>"
  and "e \<in> snd ` set \<Gamma>"
  shows "a \<sharp> e"
  using assms
  by (induct \<Gamma>, auto simp add: fresh_Cons fresh_Pair)

lemma fresh_star_heap_expr':
  assumes "S \<sharp>* \<Gamma>"
  and "e \<in> snd ` set \<Gamma>"
  shows "S \<sharp>* e"
  using assms
  by (metis fresh_star_def fresh_heap_expr')

subsubsection {* Equivariance lemmas *}

lemma heapVars[eqvt]:
  "\<pi> \<bullet> heapVars \<Gamma> = heapVars (\<pi> \<bullet> \<Gamma>)"
  by (simp add: heapVars_def)

lemma distinctVars_eqvt[eqvt]:
  "distinctVars \<Gamma> \<Longrightarrow> distinctVars (\<pi> \<bullet> \<Gamma>)"
  apply (induct \<Gamma> rule:distinctVars.induct)
  apply simp
  apply (simp add: distinctVars_Cons)
  by (metis (full_types) heapVars mem_permute_iff)

subsubsection {* Freshness and distinctness *}

lemma fresh_heapVars_distinct:
 assumes "atom ` heapVars \<Delta> \<sharp>* \<Gamma>"
 shows "heapVars \<Delta> \<inter> heapVars \<Gamma> = {}"
proof-
  { fix x
    assume "x \<in> heapVars \<Delta>"
    moreover
    assume "x \<in> heapVars \<Gamma>"
    hence "atom x \<in> supp \<Gamma>"
      by (induct \<Gamma>)(auto simp add: supp_Cons heapVars_def supp_Pair supp_at_base)
    ultimately
    have False
      using assms
      by (simp add: fresh_star_def fresh_def)
  }
  thus "heapVars \<Delta> \<inter> heapVars \<Gamma> = {}" by auto
qed
end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               December 2004               |
            |                   June 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                  April 2006  (modified)   |
            |                  March 2007  (modified)   |
            |                 August 2007  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2009         |
            |                   June 2009  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_F_law_decompo
imports CSP_F_domain CSP_T.CSP_T_law_decompo
begin

(*------------------------------------------------*
 |                                                |
 |      laws for monotonicity and congruence      |
 |                                                |
 *------------------------------------------------*)

(*********************************************************
                        Act_prefix mono
 *********************************************************)

(*------------------*
 |      csp law     |
 *------------------*)

lemma cspF_Act_prefix_mono:
  "[| a = b ; P <=F[M1,M2] Q |] ==> a -> P <=F[M1,M2] b -> Q"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Act_prefix_mono)
apply (simp add: subsetF_iff)
apply (intro allI impI)
apply (simp add: in_failures)
apply (fast)
done

lemma cspF_Act_prefix_cong:
  "[| a = b ; P =F[M1,M2] Q |] ==> a -> P =F[M1,M2] b -> Q"
apply (simp add: cspF_eq_ref_iff)
apply (simp add: cspF_Act_prefix_mono)
done

(*********************************************************
                   Ext_pre_choice mono
 *********************************************************)

(*------------------*
 |      csp law     |
 *------------------*)

lemma cspF_Ext_pre_choice_mono:
  "[| X = Y ; !! a. a:Y ==> Pf a <=F[M1,M2] Qf a |]
    ==> ? :X -> Pf <=F[M1,M2] ? :Y -> Qf"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Ext_pre_choice_mono)
apply (simp add: subsetF_iff)
apply (intro allI impI)
apply (simp add: in_failures)
apply (fast)
done

lemma cspF_Ext_pre_choice_cong:
  "[| X = Y ; !! a. a:Y ==> Pf a =F[M1,M2] Qf a |]
    ==> ? :X -> Pf =F[M1,M2] ? :Y -> Qf"
by (simp add: cspF_eq_ref_iff cspF_Ext_pre_choice_mono)

(*********************************************************
                      Ext choice mono
 *********************************************************)

(*------------------*
 |      csp law     |
 *------------------*)

lemma cspF_Ext_choice_mono:
  "[| P1 <=F[M1,M2] Q1 ; P2 <=F[M1,M2] Q2 |] ==> P1 [+] P2 <=F[M1,M2] Q1 [+] Q2"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Ext_choice_mono)
apply (simp add: cspT_semantics)
apply (simp add: subdomT_iff)
apply (simp add: subsetF_iff)
apply (intro allI impI)
apply (simp add: in_failures)
apply (elim conjE disjE)
apply (force)+
done

lemma cspF_Ext_choice_cong:
  "[| P1 =F[M1,M2] Q1 ; P2 =F[M1,M2] Q2 |] ==> P1 [+] P2 =F[M1,M2] Q1 [+] Q2"
by (simp add: cspF_eq_ref_iff cspF_Ext_choice_mono)

(*********************************************************
                      Int choice mono
 *********************************************************)

(*------------------*
 |      csp law     |
 *------------------*)

lemma cspF_Int_choice_mono:
  "[| P1 <=F[M1,M2] Q1 ; P2 <=F[M1,M2] Q2 |] ==> P1 |~| P2 <=F[M1,M2] Q1 |~| Q2"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Int_choice_mono)
apply (simp add: subsetF_iff)
apply (intro allI impI)
apply (simp add: in_failures)
apply (fast)
done

lemma cspF_Int_choice_cong:
  "[| P1 =F[M1,M2] Q1 ; P2 =F[M1,M2] Q2 |] ==> P1 |~| P2 =F[M1,M2] Q1 |~| Q2"
by (simp add: cspF_eq_ref_iff cspF_Int_choice_mono)

(*********************************************************
               replicated internal choice
 *********************************************************)

(*------------------*
 |      csp law     |
 *------------------*)

(* mono *)

lemma cspF_Rep_int_choice_mono_sum:
  "[| C1 = C2 ; !! c. c: sumset C1 ==> Pf c <=F[M1,M2] Qf c |]
      ==> !! :C1 .. Pf <=F[M1,M2] !! :C2 .. Qf"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Rep_int_choice_mono_sum)
apply (simp add: subsetF_iff)
apply (intro allI impI)
apply (simp add: in_failures)
apply (fast)
done

lemma cspF_Rep_int_choice_mono_nat:
  "[| N1 = N2 ; !! n. n:N2 ==> Pf n <=F[M1,M2] Qf n |]
      ==> !nat :N1 .. Pf <=F[M1,M2] !nat :N2 .. Qf"
apply (simp add: Rep_int_choice_ss_def)
by (rule cspF_Rep_int_choice_mono_sum, auto)

lemma cspF_Rep_int_choice_mono_set:
  "[| Xs1 = Xs2 ; !! X. X:Xs2 ==> Pf X <=F[M1,M2] Qf X |]
      ==> !set :Xs1 .. Pf <=F[M1,M2] !set :Xs2 .. Qf"
apply (simp add: Rep_int_choice_ss_def)
by (rule cspF_Rep_int_choice_mono_sum, auto)

lemma cspF_Rep_int_choice_mono_com:
  "[| X1 = X2 ; !! x. x:X2 ==> Pf x <=F[M1,M2] Qf x |]
      ==> ! :X1 .. Pf <=F[M1,M2] ! :X2 .. Qf"
apply (simp add: Rep_int_choice_com_def)
by (rule cspF_Rep_int_choice_mono_set, auto)

lemma cspF_Rep_int_choice_mono_f:
  "[| inj f ; X1 = X2 ; !! x. x:X2 ==> Pf x <=F[M1,M2] Qf x |]
      ==> !<f> :X1 .. Pf <=F[M1,M2] !<f> :X2 .. Qf"
apply (simp add: Rep_int_choice_f_def)
by (rule cspF_Rep_int_choice_mono_com, auto)

lemmas cspF_Rep_int_choice_mono = cspF_Rep_int_choice_mono_sum
                                  cspF_Rep_int_choice_mono_nat
                                  cspF_Rep_int_choice_mono_set
                                  cspF_Rep_int_choice_mono_com
                                  cspF_Rep_int_choice_mono_f

(* cong *)

lemma cspF_Rep_int_choice_cong_sum:
  "[| C1 = C2 ; !! c. c: sumset C1 ==> Pf c =F[M1,M2] Qf c |]
      ==> !! :C1 .. Pf =F[M1,M2] !! :C2 .. Qf"
by (simp add: cspF_eq_ref_iff cspF_Rep_int_choice_mono)

lemma cspF_Rep_int_choice_cong_nat:
  "[| N1 = N2 ; !! n. n:N2 ==> Pf n =F[M1,M2] Qf n |]
      ==> !nat :N1 .. Pf =F[M1,M2] !nat :N2 .. Qf"
by (simp add: cspF_eq_ref_iff cspF_Rep_int_choice_mono)

lemma cspF_Rep_int_choice_cong_set:
  "[| Xs1 = Xs2 ; !! X. X:Xs2 ==> Pf X =F[M1,M2] Qf X |]
      ==> !set :Xs1 .. Pf =F[M1,M2] !set :Xs2 .. Qf"
by (simp add: cspF_eq_ref_iff cspF_Rep_int_choice_mono)

lemma cspF_Rep_int_choice_cong_com:
  "[| X1 = X2 ; !! x. x:X2 ==> Pf x =F[M1,M2] Qf x |]
      ==> ! :X1 .. Pf =F[M1,M2] ! :X2 .. Qf"
by (simp add: cspF_eq_ref_iff cspF_Rep_int_choice_mono)

lemma cspF_Rep_int_choice_cong_f:
  "[| inj f ; X1 = X2 ; !! x. x:X2 ==> Pf x =F[M1,M2] Qf x |]
      ==> !<f> :X1 .. Pf =F[M1,M2] !<f> :X2 .. Qf"
by (simp add: cspF_eq_ref_iff cspF_Rep_int_choice_mono)

lemmas cspF_Rep_int_choice_cong = cspF_Rep_int_choice_cong_sum
                                  cspF_Rep_int_choice_cong_nat
                                  cspF_Rep_int_choice_cong_set
                                  cspF_Rep_int_choice_cong_com
                                  cspF_Rep_int_choice_cong_f

(*********************************************************
                   IF mono
 *********************************************************)

(*------------------*
 |      csp law     |
 *------------------*)

lemma cspF_IF_mono:
  "[| b1 = b2 ; P1 <=F[M1,M2] Q1 ; P2 <=F[M1,M2] Q2 |]
           ==> IF b1 THEN P1 ELSE P2 <=F[M1,M2]
               IF b2 THEN Q1 ELSE Q2"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_IF_mono)
apply (simp add: subsetF_iff)
apply (intro allI impI)
apply (simp add: in_failures)
done

lemma cspF_IF_cong:
  "[| b1 = b2 ; P1 =F[M1,M2] Q1 ;  P2 =F[M1,M2] Q2 |]
           ==> IF b1 THEN P1 ELSE P2 =F[M1,M2]
               IF b2 THEN Q1 ELSE Q2"
by (simp add: cspF_eq_ref_iff cspF_IF_mono)

(*********************************************************
                     Parallel mono
 *********************************************************)

(*------------------*
 |      csp law     |
 *------------------*)

lemma cspF_Parallel_mono:
  "[| X = Y ; P1 <=F[M1,M2] Q1 ; P2 <=F[M1,M2] Q2 |]
           ==> P1 |[X]| P2 <=F[M1,M2] Q1 |[Y]| Q2"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Parallel_mono)
apply (simp add: subsetF_iff)
apply (intro allI impI)
apply (simp add: in_failures)
apply (fast)
done

lemma cspF_Parallel_cong:
  "[| X = Y ; P1 =F[M1,M2] Q1 ; P2 =F[M1,M2] Q2 |]
           ==> P1 |[X]| P2 =F[M1,M2] Q1 |[Y]| Q2"
by (simp add: cspF_eq_ref_iff cspF_Parallel_mono)

(*********************************************************
                        Hiding mono
 *********************************************************)

(*------------------*
 |      csp law     |
 *------------------*)

lemma cspF_Hiding_mono:
  "[| X = Y ; P <=F[M1,M2] Q |] ==> P -- X <=F[M1,M2] Q -- Y"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Hiding_mono)
apply (simp add: subsetF_iff)
apply (intro allI impI)
apply (simp add: in_failures)
apply (fast)
done

lemma cspF_Hiding_cong:
  "[| X = Y ; P =F[M1,M2] Q |] ==> P -- X =F[M1,M2] Q -- Y"
by (simp add: cspF_eq_ref_iff cspF_Hiding_mono)

(*********************************************************
                        Renaming mono
 *********************************************************)

(*------------------*
 |      csp law     |
 *------------------*)

lemma cspF_Renaming_mono:
  "[| r1 = r2 ; P <=F[M1,M2] Q |] ==> P [[r1]] <=F[M1,M2] Q [[r2]]"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Renaming_mono)
apply (simp add: subsetF_iff)
apply (intro allI impI)
apply (simp add: in_failures)
apply (fast)
done

lemma cspF_Renaming_cong:
  "[| r1 = r2 ; P =F[M1,M2] Q |] ==> P [[r1]] =F[M1,M2] Q [[r2]]"
by (simp add: cspF_eq_ref_iff cspF_Renaming_mono)

(*********************************************************
               Sequential composition mono
 *********************************************************)

(*------------------*
 |      csp law     |
 *------------------*)

lemma cspF_Seq_compo_mono:
  "[| P1 <=F[M1,M2] Q1 ; P2 <=F[M1,M2] Q2 |]
           ==> P1 ;; P2 <=F[M1,M2] Q1 ;; Q2"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Seq_compo_mono)
apply (simp add: cspT_semantics)
apply (simp add: subdomT_iff)
apply (simp add: subsetF_iff)
apply (intro allI impI)
apply (simp add: in_failures)
apply (fast)
done

lemma cspF_Seq_compo_cong:
  "[| P1 =F[M1,M2] Q1 ; P2 =F[M1,M2] Q2 |] ==> P1 ;; P2 =F[M1,M2] Q1 ;; Q2"
by (simp add: cspF_eq_ref_iff cspF_Seq_compo_mono)

(*********************************************************
                       Depth_rest mono
 *********************************************************)

(*------------------*
 |      csp law     |
 *------------------*)

lemma cspF_Depth_rest_mono:
  "[| n1 = n2 ; P <=F[M1,M2] Q |] ==> P |. n1 <=F[M1,M2] Q |. n2"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Depth_rest_mono)
apply (simp add: subsetF_iff)
apply (intro allI impI)
apply (simp add: in_failures)
done

lemma cspF_Depth_rest_cong:
  "[| n1 = n2 ; P =F[M1,M2] Q |] ==> P |. n1 =F[M1,M2] Q |. n2"
by (simp add: cspF_eq_ref_iff cspF_Depth_rest_mono)

(*********************************************************
                        Timeout mono
 *********************************************************)

(*------------------*
 |      csp law     |
 *------------------*)

lemma cspF_Timeout_mono:
  "[| P1 <=F[M1,M2] Q1 ; P2 <=F[M1,M2] Q2 |]
      ==> P1 [> P2 <=F[M1,M2] Q1 [> Q2"
apply (rule cspF_Ext_choice_mono)
apply (rule cspF_Int_choice_mono)
by (simp_all)

lemma cspF_Timeout_cong:
  "[| P1 =F[M1,M2] Q1 ; P2 =F[M1,M2] Q2 |]
      ==> P1 [> P2 =F[M1,M2] Q1 [> Q2"
by (simp add: cspF_eq_ref_iff cspF_Timeout_mono)

(*------------------------------------------------------*
 |                       alias                          |
 *------------------------------------------------------*)

lemmas cspF_free_mono =
   cspF_Ext_choice_mono cspF_Int_choice_mono cspF_Parallel_mono
   cspF_Hiding_mono cspF_Renaming_mono cspF_Seq_compo_mono
   cspF_Depth_rest_mono

lemmas cspF_mono = cspF_free_mono
   cspF_Act_prefix_mono cspF_Ext_pre_choice_mono
   cspF_Rep_int_choice_mono cspF_IF_mono

lemmas cspF_free_cong =
   cspF_Ext_choice_cong cspF_Int_choice_cong cspF_Parallel_cong
   cspF_Hiding_cong cspF_Renaming_cong cspF_Seq_compo_cong
   cspF_Depth_rest_cong

lemmas cspF_cong = cspF_free_cong
   cspF_Act_prefix_cong cspF_Ext_pre_choice_cong
   cspF_Rep_int_choice_cong cspF_IF_cong

lemmas cspF_free_decompo = cspF_free_mono cspF_free_cong
lemmas cspF_decompo = cspF_mono cspF_cong

lemmas cspF_rm_head_mono = cspF_Act_prefix_mono cspF_Ext_pre_choice_mono
lemmas cspF_rm_head_cong = cspF_Act_prefix_cong cspF_Ext_pre_choice_cong
lemmas cspF_rm_head      = cspF_rm_head_mono cspF_rm_head_cong

(*-------------------------------------------------------*
 |            decomposition with ALL and EX              |
 *-------------------------------------------------------*)

(*** Rep_int_choice ***)

lemma cspF_Rep_int_choice_sum_decompo_ALL_EX_ref:
  "ALL c2: sumset C2. EX c1: sumset C1. (Pf c1) <=F[M1,M2] (Qf c2)
   ==> !! :C1 .. Pf <=F[M1,M2] !! :C2 .. Qf"
apply (simp add: cspF_cspT_semantics)
apply (rule conjI)
apply (rule cspT_Rep_int_choice_decompo_ALL_EX)
apply (force)
apply (rule, simp add: in_failures)
apply (erule bexE)
apply (drule_tac x="c" in bspec, simp)
apply (erule bexE)
apply (rule_tac x="c1" in bexI)
apply (force)
apply (simp)
done

lemma cspF_Rep_int_choice_nat_decompo_ALL_EX_ref:
  "ALL n2:N2. EX n1:N1. (Pf n1) <=F[M1,M2] (Qf n2)
   ==> !nat :N1 .. Pf <=F[M1,M2] !nat :N2 .. Qf"
apply (simp add: Rep_int_choice_ss_def)
apply (rule cspF_Rep_int_choice_sum_decompo_ALL_EX_ref)
apply (auto)
apply (drule_tac x="a" in bspec, simp)
apply (auto)
done

lemma cspF_Rep_int_choice_set_decompo_ALL_EX_ref:
  "ALL X2:Xs2. EX X1:Xs1. (Pf X1) <=F[M1,M2] (Qf X2)
   ==> !set :Xs1 .. Pf <=F[M1,M2] !set :Xs2 .. Qf"
apply (simp add: Rep_int_choice_ss_def)
apply (rule cspF_Rep_int_choice_sum_decompo_ALL_EX_ref)
apply (auto)
apply (drule_tac x="a" in bspec, simp)
apply (auto)
done

lemmas cspF_Rep_int_choice_decompo_ALL_EX_ref =
       cspF_Rep_int_choice_sum_decompo_ALL_EX_ref
       cspF_Rep_int_choice_nat_decompo_ALL_EX_ref
       cspF_Rep_int_choice_set_decompo_ALL_EX_ref

lemma cspF_Rep_int_choice_sum_decompo_ALL_EX_eq:
  "[| ALL c1: sumset C1. EX c2: sumset C2. (Pf c1) =F[M1,M2] (Qf c2) ;
      ALL c2: sumset C2. EX c1: sumset C1. (Pf c1) =F[M1,M2] (Qf c2) |]
   ==> !! :C1 .. Pf =F[M1,M2] !! :C2 .. Qf"
apply (simp add: cspF_eq_ref_iff)
apply (rule conjI)
apply (rule cspF_Rep_int_choice_decompo_ALL_EX_ref)
apply (force)
apply (rule cspF_Rep_int_choice_decompo_ALL_EX_ref)
apply (force)
done

lemma cspF_Rep_int_choice_nat_decompo_ALL_EX_eq:
  "[| ALL n1:N1. EX n2:N2. (Pf n1) =F[M1,M2] (Qf n2) ;
      ALL n2:N2. EX n1:N1. (Pf n1) =F[M1,M2] (Qf n2) |]
   ==> !nat :N1 .. Pf =F[M1,M2] !nat :N2 .. Qf"
apply (simp add: cspF_eq_ref_iff)
apply (rule conjI)
apply (rule cspF_Rep_int_choice_decompo_ALL_EX_ref)
apply (force)
apply (rule cspF_Rep_int_choice_decompo_ALL_EX_ref)
apply (force)
done

lemma cspF_Rep_int_choice_set_decompo_ALL_EX_eq:
  "[| ALL X1:Xs1. EX X2:Xs2. (Pf X1) =F[M1,M2] (Qf X2) ;
      ALL X2:Xs2. EX X1:Xs1. (Pf X1) =F[M1,M2] (Qf X2) |]
   ==> !set :Xs1 .. Pf =F[M1,M2] !set :Xs2 .. Qf"
apply (simp add: cspF_eq_ref_iff)
apply (rule conjI)
apply (rule cspF_Rep_int_choice_decompo_ALL_EX_ref)
apply (force)
apply (rule cspF_Rep_int_choice_decompo_ALL_EX_ref)
apply (force)
done

lemmas cspF_Rep_int_choice_decompo_ALL_EX_eq =
       cspF_Rep_int_choice_sum_decompo_ALL_EX_eq
       cspF_Rep_int_choice_nat_decompo_ALL_EX_eq
       cspF_Rep_int_choice_set_decompo_ALL_EX_eq

lemmas cspF_Rep_int_choice_decompo_ALL_EX
     = cspF_Rep_int_choice_decompo_ALL_EX_ref
       cspF_Rep_int_choice_decompo_ALL_EX_eq

(* =================================================== *
 |             addition for CSP-Prover 5               |
 * =================================================== *)

(*********************************************************
                        Act_prefix mono
 *********************************************************)

(*------------------*
 |      csp law     |
 *------------------*)

(** mono **)

lemma cspF_Send_prefix_mono:
  "[| a = b ; P <=F[M1,M2] Q |] ==> a ! v -> P <=F[M1,M2] b ! v -> Q"
apply (simp add: csp_prefix_ss_def)
apply (simp add: cspF_decompo)
done

lemma cspF_Rec_prefix_mono:
  "[| inj a; a = b ; X = Y ;
      !! x. x:Y ==> Pf x <=F[M1,M2] Qf x |]
    ==> a ? x:X -> Pf x <=F[M1,M2] b ? x:Y -> Qf x"
apply (simp add: csp_prefix_ss_def)
apply (rule cspF_Ext_pre_choice_mono)
apply (simp)
apply (simp add: image_iff)
apply (erule bexE)
apply (simp)
done

lemma cspF_Int_pre_choice_mono:
  "[| X = Y ;
      !! x. x:Y ==> Pf x <=F[M1,M2] Qf x |]
    ==> ! :X -> Pf <=F[M1,M2] ! :Y -> Qf"
apply (simp add: csp_prefix_ss_def)
apply (simp add: cspF_decompo)
done

lemma cspF_Nondet_send_prefix_mono:
  "[| inj a; a = b ; X = Y ;
      !! x. x:Y ==> Pf x <=F[M1,M2] Qf x |]
    ==> a !? x:X -> Pf x <=F[M1,M2] b !? x:Y -> Qf x"
apply (simp add: csp_prefix_ss_def)
apply (rule cspF_mono)
apply (simp)
apply (rule cspF_mono)
apply (simp)
apply (simp add: image_iff)
apply (erule bexE)
apply (simp)
done

(** cong **)

lemma cspF_Send_prefix_cong:
  "[| a = b ; P =F[M1,M2] Q |] ==> a ! v -> P =F[M1,M2] b ! v -> Q"
apply (simp add: csp_prefix_ss_def)
apply (simp add: cspF_decompo)
done

lemma cspF_Rec_prefix_cong:
  "[| inj a; a = b ; X = Y ;
      !! x. x:Y ==> Pf x =F[M1,M2] Qf x |]
    ==> a ? x:X -> Pf x =F[M1,M2] b ? x:Y -> Qf x"
by (simp add: cspF_eq_ref_iff cspF_Rec_prefix_mono)

lemma cspF_Int_pre_choice_cong:
  "[| X = Y ;
      !! x. x:Y ==> Pf x =F[M1,M2] Qf x |]
    ==> ! :X -> Pf =F[M1,M2] ! :Y -> Qf"
apply (simp add: csp_prefix_ss_def)
apply (simp add: cspF_decompo)
done

lemma cspF_Nondet_send_prefix_cong:
  "[| inj a; a = b ; X = Y ;
      !! x. x:Y ==> Pf x =F[M1,M2] Qf x |]
    ==> a !? x:X -> Pf x =F[M1,M2] b !? x:Y -> Qf x"
by (simp add: cspF_eq_ref_iff cspF_Nondet_send_prefix_mono)

lemmas cspF_prefix_ss_mono = cspF_Send_prefix_mono
                             cspF_Rec_prefix_mono
                             cspF_Int_pre_choice_mono
                             cspF_Nondet_send_prefix_mono

lemmas cspF_prefx_ss_cong = cspF_Send_prefix_cong
                            cspF_Rec_prefix_cong
                            cspF_Int_pre_choice_cong
                            cspF_Nondet_send_prefix_cong

(* ------------------------------------------------------ *
                 decomposition with ss
 * ------------------------------------------------------ *)

lemmas cspF_mono_ss = cspF_mono  cspF_prefix_ss_mono
lemmas cspF_cong_ss = cspF_cong  cspF_prefx_ss_cong
lemmas cspF_decompo_ss = cspF_mono_ss cspF_cong_ss

(*********************************************************
             Rep_internal_choice for UNIV
              this is useful for tactic
 *********************************************************)

(*------------------*
 |      csp law     |
 *------------------*)

(* mono_UNIV *)

lemma cspF_Rep_int_choice_mono_UNIV_nat:
  "[| !! n. Pf n <=F[M1,M2] Qf n |]
      ==> !nat n .. Pf n <=F[M1,M2] !nat n .. Qf n"
by (simp add: cspF_Rep_int_choice_mono)

lemma cspF_Rep_int_choice_mono_UNIV_set:
  "[| !! X. Pf X <=F[M1,M2] Qf X |]
      ==> !set X .. Pf X <=F[M1,M2] !set X .. Qf X"
by (simp add: cspF_Rep_int_choice_mono)

lemma cspF_Rep_int_choice_mono_UNIV_com:
  "[| !! x. Pf x <=F[M1,M2] Qf x |]
      ==> ! x .. Pf x <=F[M1,M2] ! x .. Qf x"
by (simp add: cspF_Rep_int_choice_mono)

lemma cspF_Rep_int_choice_mono_UNIV_f:
  "[| inj f ; !! x. Pf x <=F[M1,M2] Qf x |]
      ==> !<f> x .. Pf x <=F[M1,M2] !<f> x .. Qf x"
by (simp add: cspF_Rep_int_choice_mono)

lemmas cspF_Rep_int_choice_mono_UNIV =
      cspF_Rep_int_choice_mono_UNIV_nat
      cspF_Rep_int_choice_mono_UNIV_set
      cspF_Rep_int_choice_mono_UNIV_com
      cspF_Rep_int_choice_mono_UNIV_f

(* cong *)

lemma cspF_Rep_int_choice_cong_UNIV_nat:
  "[| !! n. Pf n =F[M1,M2] Qf n |]
      ==> !nat n .. Pf n =F[M1,M2] !nat n .. Qf n"
by (simp add: cspF_Rep_int_choice_cong)

lemma cspF_Rep_int_choice_cong_UNIV_set:
  "[| !! X. Pf X =F[M1,M2] Qf X |]
      ==> !set X .. Pf X =F[M1,M2] !set X .. Qf X"
by (simp add: cspF_Rep_int_choice_cong)

lemma cspF_Rep_int_choice_cong_UNIV_com:
  "[| !! x. Pf x =F[M1,M2] Qf x |]
      ==> ! x .. Pf x =F[M1,M2] ! x .. Qf x"
by (simp add: cspF_Rep_int_choice_cong)

lemma cspF_Rep_int_choice_cong_UNIV_f:
  "[| inj f ; !! x. Pf x =F[M1,M2] Qf x |]
      ==> !<f> x .. Pf x =F[M1,M2] !<f> x .. Qf x"
by (simp add: cspF_Rep_int_choice_cong)

lemmas cspF_Rep_int_choice_cong_UNIV =
      cspF_Rep_int_choice_cong_UNIV_nat
      cspF_Rep_int_choice_cong_UNIV_set
      cspF_Rep_int_choice_cong_UNIV_com
      cspF_Rep_int_choice_cong_UNIV_f

end


(*  Title:      FOL/ex/Locale_Test/Locale_Test.thy
    Author:     Clemens Ballarin

Test environment for the locale implementation.
*)

theory Locale_Test
imports Locale_Test1 Locale_Test2 Locale_Test3
begin

text {* Result of theory merge with distinct but identical interpretations *}

context mixin_thy_merge
begin
lemmas less_mixin_thy_merge1 = le.less_def
lemmas less_mixin_thy_merge2 = le'.less_def
end

lemma "gless(x, y) <-> gle(x, y) & x ~= y" (* mixin from first interpretation applied *)
  by (rule le1.less_mixin_thy_merge1)
lemma "gless'(x, y) <-> gle'(x, y) & x ~= y" (* mixin from second interpretation applied *)
  by (rule le1.less_mixin_thy_merge2)

end


theory NondetExtensions
imports
  SimpleSimulation
  AutoCorres
begin

definition
  lift_nd :: "('a, 'r) nondet_monad \<Rightarrow> ('a \<times> 'a) set"
where
  "lift_nd m \<equiv> { (s, s'). \<exists>r. (r, s') \<in> fst (m s) }"

definition
  invariant_holds_nd :: "('a, 'b) data_type \<Rightarrow> 'a set \<Rightarrow> ('a, 'r) nondet_monad \<Rightarrow> bool"
where
  "invariant_holds_nd A I m\<^sub>A \<equiv> (\<forall>s. Init A s \<subseteq> I)
    \<and> (Run A = lift_nd m\<^sub>A) \<and> \<lbrace>\<lambda>s. s \<in> I\<rbrace> m\<^sub>A \<lbrace>\<lambda>_ s'. s' \<in> I\<rbrace>"

lemma invariant_nd[dest]: "invariant_holds_nd A I m\<^sub>A \<Longrightarrow> A \<Turnstile> I"
unfolding invariant_holds_nd_def SimpleSimulation.invariant_holds_def lift_nd_def valid_def
by blast

end


theory Lift_Merge
  imports "../Lifter"
begin

(*
 * merge
 *)

definition merge_l ::
  "('x, 'a1, 'b) lifting \<Rightarrow>
   ('x, 'a2, 'b) lifting \<Rightarrow>
   ('x, 'a1 * 'a2, 'b) lifting" where
"merge_l t1 t2 =
    LMake
      (\<lambda> s a b .
        (case a of (a1, a2) \<Rightarrow>
          LUpd t1 s a1 (LUpd t2 s a2 b )))
      (\<lambda> s b . (LOut t1 s b, LOut t2 s b))
      (\<lambda> s . LBase t1 s)"

locale merge_l_valid_weak' =
  fixes l1 :: "('x, 'a1, 'b) lifting"
  fixes l2 :: "('x, 'a2, 'b) lifting"

locale merge_l_valid_weak =
  merge_l_valid_weak' +
  l_ortho +
  in1 : lifting_valid_weak l1 S1 +
  in2 : lifting_valid_weak l2 S2

sublocale merge_l_valid_weak \<subseteq> out : lifting_valid_weak "merge_l l1 l2" "\<lambda> x . S1 x \<inter> S2 x"
proof
  fix s
  fix a :: "'b * 'd"
  fix b :: "'c"
  obtain a1 a2 where A: "a = (a1, a2)"
    by(cases a; auto)

  have "LUpd l2 s a2 (LUpd l1 s a1 b) \<in> S1 s"
    unfolding sym[OF compat]
    using in1.put_S
    by auto

  then show "LUpd (merge_l l1 l2) s a b \<in> S1 s \<inter> S2 s" using A in2.put_S
    by(simp add: merge_l_def compat)

next
  fix s b
  fix a :: "'b * 'd"

  obtain a1 a2 where A: "a = (a1, a2)"
    by(cases a; auto)

  have "LOut l2 s (LUpd l1 s a1 (LUpd l2 s a2 b)) = a2"
    unfolding compat
    using in2.put_get
    by auto

  then show "LOut (merge_l l1 l2) s (LUpd (merge_l l1 l2) s a b) = a"
    using A in1.put_get
    by(auto simp add: merge_l_def)

next
  fix s
  fix b :: "'c"
  assume "b \<in> S1 s \<inter> S2 s"

  then have B1 : "b \<in> S1 s" and B2 : "b \<in> S2 s"
    by auto

  have Leq1 : "b <[ (LUpd l2 s (LOut l2 s b) b)"
    using in2.get_put_weak[OF B2]
    by auto

  have Eq : "LOut l1 s (LUpd l2 s (LOut l2 s b) b) = LOut l1 s b"
    using put2_get1
    by auto

  have Upd_in : "LUpd l2 s (LOut l2 s b) b \<in> S1 s"
    using put2_S1[OF B1]
    by auto

  have "b <[ LUpd l1 s (LOut l1 s b) b"
    using in1.get_put_weak[OF B1] by auto

  show "b <[ LUpd (merge_l l1 l2) s (LOut (merge_l l1 l2) s b) b"
    using leq_trans[OF Leq1 in1.get_put_weak[OF Upd_in]]
    by(auto simp add: merge_l_def Eq)
qed

lemma (in merge_l_valid_weak) ax :
  shows "lifting_valid_weak (merge_l l1 l2) (\<lambda> x . S1 x \<inter> S2 x)"
  using out.lifting_valid_weak_axioms
  by auto

lemma (in merge_l_valid_weak) ax_g :
  assumes H : "\<And> x . S' x = (\<lambda> x . S1 x \<inter> S2 x) x"
  shows "lifting_valid_weak (merge_l l1 l2) S'"
proof-
  have "S' = (\<lambda> x . S1 x \<inter> S2 x)"
    using assms by auto
  then show ?thesis
    using out.lifting_valid_weak_axioms
    by auto
qed

locale merge_l_valid_ext = merge_l_valid_weak' +
  in1 : lifting_valid_ext l1 +
  in2 : lifting_valid_ext l2

sublocale merge_l_valid_ext \<subseteq> out : lifting_valid_ext "merge_l l1 l2"
proof

  fix s
  fix a :: "'b * 'd"
  fix b :: "'c"

  obtain a1 a2 where A: "a = (a1, a2)"
    by(cases a; auto)

  have Leq1 : "b <[ LUpd l2 s a2 b"
    using in2.get_put by auto

  have Leq2 : "LUpd l2 s a2 b <[ LUpd l1 s a1 (LUpd l2 s a2 b)"
    using in1.get_put by auto

  show "b <[ LUpd (merge_l l1 l2) s a b"
    using A leq_trans[OF Leq1 Leq2]
    by(auto simp add: merge_l_def)
qed

lemma (in merge_l_valid_ext) ax :
  shows "lifting_valid_ext (merge_l l1 l2)"
  using out.lifting_valid_ext_axioms by auto

locale merge_l_valid_base_ext =
  l_ortho_base +
  in1 : lifting_valid_base_ext l1 S1 +
  in2 : lifting_valid_base_ext l2 S2

sublocale merge_l_valid_base_ext \<subseteq> out : lifting_valid_base_ext "merge_l l1 l2" "\<lambda> x . S1 x \<inter> S2 x"
proof
  fix s :: "'a"

  show "LBase (merge_l l1 l2) s = \<bottom>"
    using in1.base
    by(auto simp add: merge_l_def)
qed

lemma (in merge_l_valid_base_ext) ax :
  shows "lifting_valid_base_ext (merge_l l1 l2)"
  using out.lifting_valid_base_ext_axioms
  by auto

locale merge_l_valid_ok_ext = l_ortho_ok +
  in1 : lifting_valid_ok_ext l1 S1 +
  in2 : lifting_valid_ok_ext l2 S2

sublocale merge_l_valid_ok_ext \<subseteq> out : lifting_valid_ok_ext "merge_l l1 l2" "\<lambda> x . S1 x \<inter> S2 x"
proof
  fix s

  show "ok_S \<subseteq> S1 s \<inter> S2 s"
    using in1.ok_S_valid in2.ok_S_valid by auto
next
  fix s
  fix a :: "'b * 'd"
  fix b :: "'c"

  assume B_ok : "b \<in> ok_S"

  obtain a1 a2 where A: "a = (a1, a2)"
    by(cases a; auto)

  show "LUpd (merge_l l1 l2) s a b \<in> ok_S"
    using A in1.ok_S_put in2.ok_S_put B_ok
    by(auto simp add: merge_l_def)
qed

lemma (in merge_l_valid_ok_ext) ax :
  shows "lifting_valid_ok_ext (merge_l l1 l2) (\<lambda> x . S1 x \<inter> S2 x)"
  using out.lifting_valid_ok_ext_axioms
  by auto

lemma (in merge_l_valid_ok_ext) ax_g :
  assumes H : "\<And> x . S' x = (\<lambda> x . S1 x \<inter> S2 x) x"
  shows "lifting_valid_ok_ext (merge_l l1 l2) S'"
proof-
  have "S' = (\<lambda> x . S1 x \<inter> S2 x)"
    using assms by auto
  then show ?thesis
    using out.lifting_valid_ok_ext_axioms
    by auto
qed

(* TODO: make sure we don't actually need this. *)
(*
locale merge_l_valid_pres_ext = merge_l_valid_weak +
  l_ortho_pres +
  in1 : lifting_valid_pres_ext l1 S1 +
  in2 : lifting_valid_pres_ext l2 S2

sublocale merge_l_valid_pres_ext \<subseteq> out: lifting_valid_pres_ext "merge_l l1 l2" "\<lambda> x . S1 x \<inter> S2 x"
proof
  fix v supr :: "'c"
  fix V
  fix f :: "'a \<Rightarrow> 'b * 'd \<Rightarrow> 'b * 'd"
  fix s :: 'a
  assume Vin : "v \<in> V"
  assume Vsub : "V \<subseteq> S1 s \<inter> S2 s"
  then have Vsub1 : "V \<subseteq> S1 s" and Vsub2 : "V \<subseteq> S2 s"
    by auto

  assume Supr : "is_sup V supr"
  assume Supr_in : "supr \<in> S1 s \<inter> S2 s"

  then have Supr_in1 : "supr \<in> S1 s" and Supr_in2 : "supr \<in> S2 s"
    by auto
(*
  obtain f1 f2 where F: "f = (f1, f2)"
    by(cases f; auto)
*)
(*
  show "is_sup (LMap (merge_l l1 l2) f s ` V)
        (LMap (merge_l l1 l2) f s supr)"
    apply(simp add: merge_l_def)
*)

  obtain x1 x2 where X12 : "f s (LOut l1 s supr, LOut l2 s supr) = (x1, x2)"
    by(fastforce)

  have Supr' : "is_sup {LUpd l1 s x1 supr, LUpd l2 s x2 supr} (LUpd l1 s x1 (LUpd l2 s x2 supr))"
    using compat_pres_sup
    by auto

  show "is_sup (LMap (merge_l l1 l2) f s ` V) (LMap (merge_l l1 l2) f s supr)"
(*
    using compat_pres_pair[OF Vin Vsub1 Vsub2 Supr Supr_in, of f]
    by(auto simp add: merge_l_def)
*)
  proof(rule is_supI)
    fix x

    assume X: "x \<in> LMap (merge_l l1 l2) f s ` V"

    then obtain xo where Xo : "xo \<in> V" "LMap (merge_l l1 l2) f s xo = x"
      by auto

    show "x <[ LMap (merge_l l1 l2) f s supr"
      using Xo
      apply(auto simp add: merge_l_def split: prod.splits)

    qed
*)

locale merge_l_valid_pairwise_ext =
  l_ortho +
  in1 : lifting_valid_pairwise_ext S1 +
  in2 : lifting_valid_pairwise_ext S2

sublocale merge_l_valid_pairwise_ext \<subseteq> out : lifting_valid_pairwise_ext "(\<lambda> x . S1 x \<inter> S2 x)"
proof
  show "\<And>x1 x2 x3 s s12 s23 s13 s123.
       x1 \<in> S1 s \<inter> S2 s \<Longrightarrow>
       x2 \<in> S1 s \<inter> S2 s \<Longrightarrow>
       x3 \<in> S1 s \<inter> S2 s \<Longrightarrow>
       is_sup {x1, x2} s12 \<Longrightarrow>
       s12 \<in> S1 s \<inter> S2 s \<Longrightarrow>
       is_sup {x2, x3} s23 \<Longrightarrow>
       s23 \<in> S1 s \<inter> S2 s \<Longrightarrow>
       is_sup {x1, x3} s13 \<Longrightarrow>
       s13 \<in> S1 s \<inter> S2 s \<Longrightarrow>
       is_sup {x1, x2, x3} s123 \<Longrightarrow> s123 \<in> S1 s \<inter> S2 s"
    using in1.pairwise_S in2.pairwise_S
    by blast
qed

lemma (in merge_l_valid_pairwise_ext) ax :
  shows "lifting_valid_pairwise_ext (\<lambda> x . S1 x \<inter> S2 x)"
  using out.lifting_valid_pairwise_ext_axioms
  by auto

lemma (in merge_l_valid_pairwise_ext) ax_g :
  assumes H: "\<And> x . S' x = (\<lambda> x . S1 x \<inter> S2 x) x"
  shows "lifting_valid_pairwise_ext S'"
proof-
  have "S' = (\<lambda> x . S1 x \<inter> S2 x)"
    using assms by auto
  then show ?thesis
    using out.lifting_valid_pairwise_ext_axioms
    by auto
qed

locale merge_l_ortho' =
  fixes l1 :: "('a, 'b1, 'c :: {Mergeable, Pordps}) lifting"
  fixes S1 :: "'a \<Rightarrow> 'c1 set"
  fixes l2 :: "('a, 'b2, 'c) lifting"
  fixes S2 :: "'a \<Rightarrow> 'c2 set"
  fixes l3 :: "('a, 'b3, 'c) lifting"
  fixes S3 :: "'a \<Rightarrow> 'c3 set"

locale merge_l_ortho = merge_l_ortho' +
  orth1_2 : l_ortho l1 S1 l2 S2 +
  orth1_3 : l_ortho l1 S1 l3 S3 +
  orth2_3 : l_ortho l2 S2 l3 S3
  (* + valid3 : lifting_valid_weak_pres l3 S3*)
(* TODO may need more validity assumptions. *)

sublocale merge_l_ortho \<subseteq> out : l_ortho "merge_l l1 l2" "\<lambda> x . S1 x \<inter> S2 x" l3 S3
proof
  fix s

  have Supr : "is_sup {LBase l2 s, LBase l2 s} (LBase l2 s)"
    using sup_singleton[of "LBase l2 s"]
    by auto

  have Supr' : "is_sup {LBase l2 s, LBase l2 s}
     [^ LBase l2 s, LBase l2 s ^]"
    using bsup_sup[OF Supr bsup_spec]
    by auto

  then have "[^ LBase l2 s, LBase l2 s ^] = LBase l2 s"
    using is_sup_unique[OF Supr Supr'] by auto

  then show "LBase (merge_l l1 l2) s = LBase l3 s"
    using orth1_3.eq_base[of s] orth2_3.eq_base[of s]
    by(auto simp add: merge_l_def)

next
  fix b :: 'c
  fix a1_2 :: "'b * 'd"
  fix a3 :: 'e
  fix s

  obtain a1 a2 where A1_2 : "a1_2 = (a1, a2)"
    by(cases a1_2; auto)

  show "LUpd (merge_l l1 l2) s a1_2 (LUpd l3 s a3 b) = LUpd l3 s a3 (LUpd (merge_l l1 l2) s a1_2 b)" using A1_2
    by(auto simp add: merge_l_def orth1_3.compat orth2_3.compat)

next
  fix b :: 'c
  fix a1_2 :: "'b * 'd"
  fix a3 :: 'e
  fix s

  obtain a1 a2 where A1_2 : "a1_2 = (a1, a2)"
    by(cases a1_2; auto)

  show "LOut l3 s (LUpd (merge_l l1 l2) s a1_2 b) = LOut l3 s b" using A1_2
    by(auto simp add: merge_l_def orth1_3.put1_get2 orth2_3.put1_get2)
next

  fix b :: 'c
  fix a1_2 :: "'b * 'd"
  fix a3 :: 'e
  fix s

  obtain a1 a2 where A1_2 : "a1_2 = (a1, a2)"
    by(cases a1_2; auto)

  show "LOut (merge_l l1 l2) s (LUpd l3 s a3 b) = LOut (merge_l l1 l2) s b" using A1_2
    by(auto simp add: merge_l_def orth1_3.put2_get1 orth2_3.put2_get1)
next

  fix b s
  fix a1_2 :: "'b * 'd"
  assume B: "b \<in> S3 s"

  obtain a1 a2 where A1_2 : "a1_2 = (a1, a2)"
    by(cases a1_2; auto)

  have Up2 : "(LUpd l2 s a2 b) \<in> S3 s"
    using orth2_3.put1_S2[OF B] by auto

  have Up1 : "(LUpd l1 s a1 (LUpd l2 s a2 b)) \<in> S3 s"
    using orth1_3.put1_S2[OF Up2]
    by auto

  then show "LUpd (merge_l l1 l2) s a1_2 b \<in> S3 s" using A1_2
    by(auto simp add: merge_l_def)
next

  fix b s
  fix a3 :: 'e

  assume B: "b \<in> S1 s \<inter> S2 s"

  then have B1 : "b \<in> S1 s" and B2 : "b \<in> S2 s"
    by auto

  have Conc1 : "LUpd l3 s a3 b \<in> S1 s"
    using orth1_3.put2_S1[OF B1] by auto

  have Conc2 : "LUpd l3 s a3 b \<in> S2 s"
    using orth2_3.put2_S1[OF B2] by auto

  show "LUpd l3 s a3 b \<in> S1 s \<inter> S2 s"
    using Conc1 Conc2
    by auto
qed

lemma (in merge_l_ortho) ax :
  shows "l_ortho (merge_l l1 l2) (\<lambda> x . S1 x \<inter> S2 x) l3 S3"
  using out.l_ortho_axioms
  by auto

lemma (in merge_l_ortho) ax_g :
  assumes H1_2 : "\<And> x . S1_2' x = S1 x \<inter> S2 x"
  assumes H3 : "\<And> x . S3' x = S3 x"
  shows "l_ortho (merge_l l1 l2) S1_2' l3 S3'"
proof-
  have H1_2' : "S1_2' = (\<lambda> x . S1 x \<inter> S2 x)" using H1_2 by auto
  have H3' : "S3' = S3" using H3 by auto
  show ?thesis
    using ax unfolding H1_2' H3'
    by auto
qed

lemma (in merge_l_ortho) ax_g' :
  assumes H1 : "\<And> x . S1' x = S1 x"
  assumes H2 : "\<And> x . S2' x = S2 x"
  assumes H3 : "\<And> x . S3' x = S3 x"
  shows "l_ortho (merge_l l1 l2) (\<lambda> x . S1' x \<inter> S2' x) l3 S3'"
proof-
  have H1' : "S1' = S1" using H1 by auto
  have H2' : "S2' = S2" using H2 by auto
  have H3' : "S3' = S3" using H3 by auto
  show ?thesis
    using ax unfolding H1' H2' H3'
    by auto
qed

lemma (in merge_l_ortho) ax_comm :
  shows "l_ortho l3 S3 (merge_l l1 l2) (\<lambda> x . S1 x \<inter> S2 x)"
  using out.comm.l_ortho_axioms
  by auto

lemma (in merge_l_ortho) ax_g_comm :
  assumes H1_2 : "\<And> x . S1_2' x = S1 x \<inter> S2 x"
  assumes H3 : "\<And> x . S3' x = S3 x"
  shows "l_ortho l3 S3' (merge_l l1 l2) S1_2' "
proof-
  have H1_2' : "S1_2' = (\<lambda> x . S1 x \<inter> S2 x)" using H1_2 by auto
  have H3' : "S3' = S3" using H3 by auto
  show ?thesis
    using ax_comm unfolding H1_2' H3'
    by auto
qed

lemma (in merge_l_ortho) ax_g'_comm :
  assumes H1 : "\<And> x . S1' x = S1 x"
  assumes H2 : "\<And> x . S2' x = S2 x"
  assumes H3 : "\<And> x . S3' x = S3 x"
  shows "l_ortho l3 S3' (merge_l l1 l2) (\<lambda> x . S1' x \<inter> S2' x) "
proof-
  have H1' : "S1' = S1" using H1 by auto
  have H2' : "S2' = S2" using H2 by auto
  have H3' : "S3' = S3" using H3 by auto
  show ?thesis
    using ax_comm unfolding H1' H2' H3'
    by auto
qed

locale merge_l_ortho_base_ext = merge_l_ortho' +
  orth1_2 : l_ortho_base_ext l1 l2 +
  orth1_3 : l_ortho_base_ext l1 l3 +
  orth2_3 : l_ortho_base_ext l2 l3
(*
locale merge_l_ortho_base = merge_l_ortho +
  orth1_2 : l_ortho_base l1 S1 l2 S2 +
  orth1_3 : l_ortho_base l1 S1 l3 S3 +
  orth2_3 : l_ortho_base l2 S2 l3 S3
*)
sublocale merge_l_ortho_base_ext  \<subseteq> out : l_ortho_base_ext "merge_l l1 l2" l3
proof
  fix s

  show "LBase (merge_l l1 l2) s = \<bottom>"
    using orth1_2.compat_base1
    by(auto simp add: merge_l_def)
next

  fix s

  show "LBase l3 s = \<bottom>"
    using orth1_3.compat_base2
    by(auto)
qed

lemma (in merge_l_ortho_base_ext) ax :
  shows "l_ortho_base_ext (merge_l l1 l2) l3"
  using out.l_ortho_base_ext_axioms by auto

lemma (in merge_l_ortho_base_ext) ax_comm :
  shows "l_ortho_base_ext l3 (merge_l l1 l2)"
  using out.comm.l_ortho_base_ext_axioms by auto

locale merge_l_ortho_ok_ext = merge_l_ortho' +
  orth1_2 : l_ortho_ok_ext l1 l2 +
  orth1_3 : l_ortho_ok_ext l1 l3 +
  orth2_3 : l_ortho_ok_ext l2 l3

sublocale merge_l_ortho_ok_ext \<subseteq> out : l_ortho_ok_ext "merge_l l1 l2" l3 .

(*
locale merge_l_ortho_pres = merge_l_ortho +
  orth1_2 : l_ortho_pres l1 S1 l2 S2 +
  orth1_3 : l_ortho_pres l1 S1 l3 S3 +
  orth2_3 : l_ortho_pres l2 S2 l3 S3 +
  (* see if we can avoid this presonly assumptions - i don't think we can though. *)
  in1 : lifting_valid_pres l1 S1 +
  in2 : lifting_valid_pres l2 S2 +
  in3 : lifting_valid_pres l3 S3

sublocale merge_l_ortho_pres \<subseteq> l_ortho_pres "merge_l l1 l2" "\<lambda> x . S1 x \<inter> S2 x" l3 S3
proof
  fix a1_2 :: "'b * 'd"
  fix a3 s
  fix x :: 'c

  obtain a1 a2 where A1_2 : "a1_2 = (a1, a2)"
    by(cases a1_2; auto)

  have Merge_eq : "LUpd (merge_l l1 l2) s a1_2 (LUpd l3 s a3 x) = LUpd l1 s a1 (LUpd l2 s a2 (LUpd l3 s a3 x))"
    using A1_2
    by(auto simp add: merge_l_def)

  have Sup23 : "is_sup {LUpd l2 s a2 x, LUpd l3 s a3 x} (LUpd l2 s a2 (LUpd l3 s a3 x))"
    using orth2_3.compat_pres_sup
    by auto

  have Sup123 : "is_sup {LUpd l1 s a1 (LUpd l3 s a3 x), LUpd l2 s a2 (LUpd l3 s a3 x)} (LUpd l1 s a1 (LUpd l2 s a2 (LUpd l3 s a3 x)))"
    using orth1_2.compat_pres_sup
    by auto

  have Sup13 : "is_sup {LUpd l1 s a1 x, LUpd l3 s a3 x} (LUpd l1 s a1 (LUpd l3 s a3 x))"
    using orth1_3.compat_pres_sup
    by auto

  have Eq_123 : "({LUpd l1 s a1 x, LUpd l3 s a3 x} \<union> {LUpd l2 s a2 x, LUpd l3 s a3 x}) = {LUpd l1 s a1 x, LUpd l2 s a2 x, LUpd l3 s a3 x}"
    by auto

  have Sup123' : "is_sup ({LUpd l1 s a1 x, LUpd l2 s a2 x, LUpd l3 s a3 x}) (LUpd l1 s a1 (LUpd l2 s a2 (LUpd l3 s a3 x)))"
    using sup_union1[OF Sup13 Sup23 Sup123]
    unfolding Eq_123
    by auto

  have Sup12 : "is_sup {LUpd l1 s a1 x, LUpd l2 s a2 x} (LUpd l1 s a1 (LUpd l2 s a2 x))"
    using orth1_2.compat_pres_sup
    by auto

  have Sup3 : "is_sup {LUpd l3 s a3 x} (LUpd l3 s a3 x)"
    using sup_singleton
    by auto

  have Eq_123' : "{LUpd l1 s a1 x, LUpd l2 s a2 x, LUpd l3 s a3 x} = {LUpd l1 s a1 x, LUpd l2 s a2 x} \<union> {LUpd l3 s a3 x}"
    by auto

  have Sup123'' : "is_sup ({LUpd l1 s a1 x, LUpd l2 s a2 x} \<union> {LUpd l3 s a3 x}) (LUpd l1 s a1 (LUpd l2 s a2 (LUpd l3 s a3 x)))"
    using Sup123' unfolding Eq_123'
    by auto

  have Conc' : "is_sup {(LUpd l1 s a1 (LUpd l2 s a2 x)), LUpd l3 s a3 x} (LUpd l1 s a1 (LUpd l2 s a2 (LUpd l3 s a3 x)))"
    using sup_union2[OF Sup12 Sup3 Sup123'']
    by auto

  have Merge_eq' : "LUpd (merge_l l1 l2) s a1_2 x = LUpd l1 s a1 (LUpd l2 s a2 x)"
    using A1_2
    by(auto simp add: merge_l_def)

  show "is_sup {LUpd (merge_l l1 l2) s a1_2 x, LUpd l3 s a3 x} (LUpd (merge_l l1 l2) s a1_2 (LUpd l3 s a3 x))"
    using Conc' unfolding Merge_eq Merge_eq'
    by simp
qed
*)

end