theory SINVAR_NonInterference
imports "../TopoS_Helper"
begin

subsection \<open>SecurityInvariant NonInterference\<close>

datatype node_config = Interfering | Unrelated

definition default_node_properties :: "node_config"
  where  "default_node_properties = Interfering"

definition undirected_reachable :: "'v graph \<Rightarrow> 'v => 'v set" where
  "undirected_reachable G v = (succ_tran (undirected G) v) - {v}"

lemma undirected_reachable_mono:
  "E' \<subseteq> E \<Longrightarrow> undirected_reachable \<lparr>nodes = N, edges = E'\<rparr> n \<subseteq> undirected_reachable \<lparr>nodes = N, edges = E\<rparr> n"
unfolding undirected_reachable_def undirected_def succ_tran_def
by (fastforce intro: trancl_mono)

fun sinvar :: "'v graph \<Rightarrow> ('v \<Rightarrow> node_config) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> n \<in> (nodes G). (nP n) = Interfering \<longrightarrow> (nP ` (undirected_reachable G n)) \<subseteq> {Unrelated})"

lemma "sinvar G nP \<longleftrightarrow>
  (\<forall> n \<in> {v' \<in> (nodes G). (nP v') = Interfering}. {nP v' | v'. v' \<in> undirected_reachable G n} \<subseteq> {Unrelated})"
by auto

definition receiver_violation :: "bool" where
  "receiver_violation = True"

text\<open>simplifications for sets we need in the uniqueness proof\<close>
  lemma tmp1: "{(b, a). a = vertex_1 \<and> b = vertex_2} = {(vertex_2, vertex_1)}" by auto
  lemma tmp6: "{(vertex_1, vertex_2), (vertex_2, vertex_1)}\<^sup>+ =
    {(vertex_1, vertex_1), (vertex_2, vertex_2), (vertex_1, vertex_2), (vertex_2, vertex_1)}"
    apply(rule)
     apply(rule)
     apply(case_tac x, simp)
     apply(erule_tac r="{(vertex_1, vertex_2), (vertex_2, vertex_1)}" in trancl_induct)
      apply(auto)
     apply (metis (mono_tags) insertCI r_r_into_trancl)+
  done
  lemma tmp2: "(insert (vertex_1, vertex_2) {(b, a). a = vertex_1 \<and> b = vertex_2})\<^sup>+ =
    {(vertex_1, vertex_1), (vertex_2, vertex_2), (vertex_1, vertex_2), (vertex_2, vertex_1)}"
    apply(subst tmp1)
    apply(fact tmp6)
    done
  lemma tmp4: "{(e1, e2). e1 = vertex_1 \<and> e2 = vertex_2 \<and> (e1 = vertex_1 \<longrightarrow> e2 \<noteq> vertex_2)} = {}" by blast
  lemma tmp5: "{(b, a). a = vertex_1 \<and> b = vertex_2 \<or> a = vertex_1 \<and> b = vertex_2 \<and> (a = vertex_1 \<longrightarrow> b \<noteq> vertex_2)} =
    {(vertex_2, vertex_1)}" by fastforce
  lemma unique_default_example: "undirected_reachable \<lparr>nodes = {vertex_1, vertex_2}, edges = {(vertex_1, vertex_2)}\<rparr> vertex_1 = {vertex_2}"
    by(auto simp add: undirected_def undirected_reachable_def succ_tran_def tmp2)
  lemma unique_default_example_hlp1: "delete_edges \<lparr>nodes = {vertex_1, vertex_2}, edges = {(vertex_1, vertex_2)}\<rparr> {(vertex_1, vertex_2)} =
    \<lparr>nodes = {vertex_1, vertex_2}, edges = {}\<rparr>"
    by(simp add: delete_edges_def)
  lemma unique_default_example_2:
    "undirected_reachable (delete_edges \<lparr>nodes = {vertex_1, vertex_2}, edges = {(vertex_1, vertex_2)}\<rparr> {(vertex_1,vertex_2 )}) vertex_1 = {}"
    by(simp add: undirected_def undirected_reachable_def succ_tran_def unique_default_example_hlp1)
  lemma unique_default_example_3:
    "undirected_reachable (delete_edges \<lparr>nodes = {vertex_1, vertex_2}, edges = {(vertex_1, vertex_2)}\<rparr> {(vertex_1,vertex_2 )}) vertex_2 = {}"
    by(simp add: undirected_def undirected_reachable_def succ_tran_def unique_default_example_hlp1)
  lemma unique_default_example_4:
    "(undirected_reachable (add_edge vertex_1 vertex_2 (delete_edges \<lparr>nodes = {vertex_1, vertex_2},
    edges = {(vertex_1, vertex_2)}\<rparr> {(vertex_1, vertex_2)})) vertex_1) = {vertex_2}"
    apply(simp add: delete_edges_def add_edge_def undirected_def undirected_reachable_def succ_tran_def)
    apply(subst tmp4)
    apply(subst tmp5)
    apply(simp)
    apply(subst tmp6)
    by force
  lemma unique_default_example_5:
    "(undirected_reachable (add_edge vertex_1 vertex_2 (delete_edges \<lparr>nodes = {vertex_1, vertex_2},
    edges = {(vertex_1, vertex_2)}\<rparr> {(vertex_1, vertex_2)})) vertex_2) = {vertex_1}"
    apply(simp add: delete_edges_def add_edge_def undirected_def undirected_reachable_def succ_tran_def)
    apply(subst tmp4)
    apply(subst tmp5)
    apply(simp)
    apply(subst tmp6)
    by force

  (*lemma empty_undirected_reachable_false: "xb \<in> undirected_reachable \<lparr>nodes = nodes G, edges = {(e1, e2). False}\<rparr> na \<longleftrightarrow> False"
    apply(simp add: undirected_reachable_def succ_tran_def undirected_def)
    apply(subst tmp3)
    by fastforce*)

  lemma empty_undirected_reachable_false: "xb \<in> undirected_reachable (delete_edges G (edges G)) na \<longleftrightarrow> False"
    by(simp add: undirected_reachable_def succ_tran_def undirected_def delete_edges_edges_empty)

subsubsection\<open>monotonic and preliminaries\<close>

interpretation NonInterference: SecurityInvariant_IFS
where default_node_properties = SINVAR_NonInterference.default_node_properties
and sinvar = SINVAR_NonInterference.sinvar
  unfolding SINVAR_NonInterference.default_node_properties_def
  apply unfold_locales
   apply(rule ballI)
   apply(drule SINVAR_NonInterference.offending_notevalD)
   apply(simp)
   apply clarify
   apply(rename_tac xa)
   apply(case_tac "nP xa")
    (*case Interfering*)
    apply simp
    apply(erule_tac x=n and A="nodes G" in ballE)
     prefer 2
     apply fast
    apply(simp)
    apply(thin_tac "wf_graph G")
    apply(thin_tac "(a,b) \<in> f")
    apply(thin_tac "n \<in> nodes G")
    apply(thin_tac "nP n = Interfering")
    apply(erule disjE)
     apply fastforce
     apply fastforce
   (*case Unrelated*)
   apply simp
  (*unique: *)
  apply(erule default_uniqueness_by_counterexample_IFS)
  apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_def)
  apply (simp add:delete_edges_set_nodes)
  apply (simp split: prod.split_asm prod.split)
  apply(rule_tac x="\<lparr> nodes={vertex_1,vertex_2}, edges = {(vertex_1,vertex_2)} \<rparr>" in exI, simp)
  apply(rule conjI)
   apply(simp add: wf_graph_def)
  apply(rule_tac x="(\<lambda> x. default_node_properties)(vertex_1 := Interfering, vertex_2 := Interfering)" in exI, simp)
  apply(rule conjI)
   apply(simp add: unique_default_example)
  apply(rule_tac x="vertex_2" in exI, simp)
  apply(rule_tac x="{(vertex_1,vertex_2)}" in exI, simp)
  apply(simp add: unique_default_example)
  apply(simp add: unique_default_example_2)
  apply(simp add: unique_default_example_3)
  apply(simp add: unique_default_example_4)
  apply(simp add: unique_default_example_5)
  apply(case_tac otherbot)
   apply simp
  apply(simp add:graph_ops)
  done

  lemma TopoS_NonInterference: "SecurityInvariant sinvar default_node_properties receiver_violation"
  unfolding receiver_violation_def by unfold_locales

hide_const (open) sinvar receiver_violation default_node_properties

\<comment> \<open>Hide all the helper lemmas.\<close>
hide_fact tmp1 tmp2 tmp4 tmp5 tmp6 unique_default_example
          unique_default_example_2 unique_default_example_3 unique_default_example_4
          unique_default_example_5 empty_undirected_reachable_false

end


theory IndividualMorphisms
  imports Individuals
begin

lemma set_comp_eq_iff_1: "{F x | x . x \<in> A} = {G x | x . x \<in> B} \<longleftrightarrow>
       (\<forall>x \<in> A. \<exists>y \<in> B. F x = G y) \<and>
       (\<forall>x \<in> B. \<exists>y \<in> A. G x = F y)"
  by blast

lemma morphism_worlds_axiom_iff: "{ w \<inter> m ` \<I>\<^bsub>src\<^esub> | w . w \<in> \<W>\<^bsub>tgt\<^esub>} = { m ` w | w . w \<in> \<W>\<^bsub>src\<^esub>} \<longleftrightarrow>
       (\<forall>w \<in> \<W>\<^bsub>src\<^esub>. \<exists>w' \<in> \<W>\<^bsub>tgt\<^esub>. m ` w = w' \<inter> (m ` \<I>\<^bsub>src\<^esub>)) \<and>
       (\<forall>w' \<in> \<W>\<^bsub>tgt\<^esub>. \<exists>w \<in> \<W>\<^bsub>src\<^esub>. m ` w = w' \<inter> (m ` \<I>\<^bsub>src\<^esub>))"
      (is "?X = ?Y \<longleftrightarrow> ?C \<and> ?D")
proof -
  let ?X = "{w \<inter> m ` \<I>\<^bsub>src\<^esub> |w. w \<in> \<W>\<^bsub>tgt\<^esub>}"
    and ?Y = "{m ` w |w. w \<in> \<W>\<^bsub>src\<^esub>}"
  let "{?F w | w . w \<in> ?A }" = "?X" and
      "{?G w | w . w \<in> ?B }" = "?Y"
  note A = set_comp_eq_iff_1[of ?F ?A ?G ?B]
  show ?thesis
    by (simp only: A ; intro iffI ; (elim conjE) ; intro conjI
          ; simp? ; metis)
qed

(* UNUSED lemma morphism_worlds_axiomI:
  assumes "\<And>w. w \<in> \<W>\<^bsub>src\<^esub> \<Longrightarrow> \<exists>w' \<in> \<W>\<^bsub>tgt\<^esub>. m ` w = w' \<inter> (m ` \<I>\<^bsub>src\<^esub>)"
       "\<And>w'. w' \<in> \<W>\<^bsub>tgt\<^esub> \<Longrightarrow> \<exists>w \<in> \<W>\<^bsub>src\<^esub>. m ` w = w' \<inter> (m ` \<I>\<^bsub>src\<^esub>)"
  shows "{ w \<inter> m ` \<I>\<^bsub>src\<^esub> | w . w \<in> \<W>\<^bsub>tgt\<^esub>} = { m ` w | w . w \<in> \<W>\<^bsub>src\<^esub>}"
  apply (intro morphism_worlds_axiom_iff[THEN iffD2,OF conjI,OF ballI ballI])
  using assms by metis+ *)

locale individual_structure_morphism_defs =
  src: individual_structure_defs src +
  tgt: individual_structure_defs tgt for
    src :: "'i1 individual_structure" and
    tgt :: "'i2 individual_structure" +
  fixes \<Omega> :: "'i1 \<Rightarrow> 'i2" ("m")
begin

definition "tws w \<equiv> SOME w'. w' \<in> \<W>\<^bsub>tgt\<^esub> \<and> m ` w = w' \<inter> m ` \<I>\<^bsub>src\<^esub>"

definition "sws w \<equiv> SOME w'. w' \<in> \<W>\<^bsub>src\<^esub> \<and> m ` w' = w \<inter> m ` \<I>\<^bsub>src\<^esub>"

end

locale individual_structure_morphism =
  individual_structure_morphism_defs src tgt \<Omega> +
  src: individual_structure src +
  tgt: individual_structure tgt for src tgt and \<Omega> ("m") +
  assumes
    m_scope: "x \<in> \<S>\<^bsub>src\<^esub> \<and> m x \<in> \<S>\<^bsub>tgt\<^esub> \<or> x \<in> \<M>\<^bsub>src\<^esub> \<and> m x \<in> \<M>\<^bsub>tgt\<^esub> \<or> x \<notin> \<I>\<^bsub>src\<^esub> \<and> m x \<notin> \<I>\<^bsub>tgt\<^esub>" and
    m_preserve_inherence[simp]: "m x \<triangleleft>\<^bsub>tgt\<^esub> m y \<longleftrightarrow> x \<triangleleft>\<^bsub>src\<^esub> y" and
    m_preserve_exact_similarity[simp]: "m x\<^sub>1 \<simeq>\<^bsub>tgt\<^esub> m x\<^sub>2 \<longleftrightarrow> x\<^sub>1 \<simeq>\<^bsub>src\<^esub> x\<^sub>2" and
    m_preserve_refers_to[simp]: "m x \<hookrightarrow>\<^bsub>tgt\<^esub> y\<^sub>t \<longleftrightarrow> (\<exists>y\<^sub>s. x \<hookrightarrow>\<^bsub>src\<^esub> y\<^sub>s \<and> y\<^sub>t = m y\<^sub>s)" and
    m_preserve_ed: "ed\<^bsub>tgt\<^esub> (m x) (m y) \<Longrightarrow> ed\<^bsub>src\<^esub> x y" and
    m_preserve_worlds[simp]: "{ w \<inter> m ` \<I>\<^bsub>src\<^esub> | w . w \<in> \<W>\<^bsub>tgt\<^esub>} = { m ` w | w . w \<in> \<W>\<^bsub>src\<^esub>}"
begin

lemma m_exhaust:
  assumes "m x = y"
  obtains (substantials) "x \<in> \<S>\<^bsub>src\<^esub>" "m x \<in> \<S>\<^bsub>tgt\<^esub>" |
          (moments) "x \<in> \<M>\<^bsub>src\<^esub>" "m x \<in> \<M>\<^bsub>tgt\<^esub>" |
          (undefined) "x \<notin> \<I>\<^bsub>src\<^esub>" "m x \<notin> \<I>\<^bsub>tgt\<^esub>"
  using m_scope by metis

lemma m_substantials[iff]: "m x \<in> \<S>\<^bsub>tgt\<^esub> \<longleftrightarrow> x \<in> \<S>\<^bsub>src\<^esub>"
  using m_scope[of x]
  by blast

lemma m_moments[iff]: "m x \<in> \<M>\<^bsub>tgt\<^esub> \<longleftrightarrow> x \<in> \<M>\<^bsub>src\<^esub>"
  using m_scope[of x]
  by blast

lemma m_individuals[iff]: "m x \<in> \<I>\<^bsub>tgt\<^esub> \<longleftrightarrow> x \<in> \<I>\<^bsub>src\<^esub>"
  using m_scope[of x] src.individuals_moments_substantials tgt.individuals_moments_substantials
  by blast

lemmas m_not_substantials = neg_iff_D[OF m_substantials]

lemmas m_not_moments = neg_iff_D[OF m_moments]

lemmas m_not_individuals = neg_iff_D[OF m_individuals]

lemma m_undefined[iff]: "m undefined \<notin> \<I>\<^bsub>tgt\<^esub>"
  using m_scope src.undefined_not_in_individuals
  by auto

lemma m_undefined_1: "m x = undefined \<Longrightarrow> x \<notin> \<I>\<^bsub>src\<^esub>"
                     "x \<notin> \<I>\<^bsub>src\<^esub> \<Longrightarrow> m x \<notin> \<I>\<^bsub>tgt\<^esub>"
  subgoal by (rule m_exhaust[of x undefined] ; simp)
  using m_scope src.individuals_moments_substantials by blast

declare m_undefined_1(1)[dest!]

lemma twsE:
  assumes "w \<in> \<W>\<^bsub>src\<^esub>"
  obtains "tws w \<in> \<W>\<^bsub>tgt\<^esub>" "m ` w = tws w \<inter> m ` \<I>\<^bsub>src\<^esub>"
  using someI_bex[of "\<W>\<^bsub>tgt\<^esub>" "\<lambda>w'. m ` w = w' \<inter> m ` \<I>\<^bsub>src\<^esub>",
        simplified tws_def[symmetric]]
      morphism_worlds_axiom_iff[of m src tgt] assms
  by force

lemma twsD:
  assumes "w \<in> \<W>\<^bsub>src\<^esub>"
  shows "tws w \<in> \<W>\<^bsub>tgt\<^esub>" "m ` w = tws w \<inter> m ` \<I>\<^bsub>src\<^esub>"
  using twsE[OF assms] by metis+

lemma swsE:
  assumes "w \<in> \<W>\<^bsub>tgt\<^esub>"
  obtains "sws w \<in> \<W>\<^bsub>src\<^esub>" "m ` sws w = w \<inter> m ` \<I>\<^bsub>src\<^esub>"
  using someI_bex[of "\<W>\<^bsub>src\<^esub>"  "\<lambda>w'. m ` w' = w \<inter> m ` \<I>\<^bsub>src\<^esub>",
        simplified sws_def[symmetric]]
      morphism_worlds_axiom_iff[of m src tgt] assms
  by force

lemma swsD:
  assumes "w \<in> \<W>\<^bsub>tgt\<^esub>"
  shows "sws w \<in> \<W>\<^bsub>src\<^esub>" "m ` sws w = w \<inter> m ` \<I>\<^bsub>src\<^esub>"
  using swsE[OF assms] by metis+

lemma m_preserve_worlds_D:
  "\<And>w. w \<in> \<W>\<^bsub>src\<^esub> \<Longrightarrow> \<exists>w' \<in> \<W>\<^bsub>tgt\<^esub>. m ` w = w' \<inter> (m ` \<I>\<^bsub>src\<^esub>)"
  "\<And>w'. w' \<in> \<W>\<^bsub>tgt\<^esub> \<Longrightarrow> \<exists>w \<in> \<W>\<^bsub>src\<^esub>. m ` w = w' \<inter> (m ` \<I>\<^bsub>src\<^esub>)"
  using m_preserve_worlds[simplified morphism_worlds_axiom_iff]
  by auto

lemma worlds2: "{\<Omega> ` w |w. w \<in> \<W>\<^bsub>src\<^esub>} = (`) \<Omega> ` \<W>\<^bsub>src\<^esub>"
  using Setcompr_eq_image by metis

end

context individual_structure_morphism_defs
begin

definition \<Theta> ("m'_inv") where m_inv_def:"\<Theta> x \<equiv> if x \<in> \<Omega> ` \<I>\<^bsub>src\<^esub> then  inv_into \<I>\<^bsub>src\<^esub> \<Omega> x else undefined"

end

locale individual_structure_injective_morphism =
  individual_structure_morphism  +
  assumes
    m_injective[intro!,simp]: "inj_on m \<I>\<^bsub>src\<^esub>"
begin

lemma m_injective_on_moments[intro!,simp]: "inj_on m \<M>\<^bsub>src\<^esub>"
  using m_injective moments_subset_individuals
        inj_on_subset
  by auto

lemma m_injective_on_substantials: "inj_on m \<S>\<^bsub>src\<^esub>"
  using m_injective substantials_subset_individuals
        inj_on_subset
  by auto

lemma m_inv_individuals: "x \<in> \<I>\<^bsub>src\<^esub> \<Longrightarrow> m_inv (m x) = x"
  using inv_into_f_f m_injective m_inv_def by simp

lemma m_inv_substantials: "x \<in> \<S>\<^bsub>src\<^esub> \<Longrightarrow> m_inv (m x) = x"
  using substantials_subset_individuals m_inv_individuals by auto

lemma m_inv_moments: "x \<in> \<M>\<^bsub>src\<^esub> \<Longrightarrow> m_inv (m x) = x"
  using moments_subset_individuals[of src] m_inv_individuals[of x]
  by (simp add: src.moments_are_individuals)

lemma m_inv_inv_individuals_iff[simp]:
  assumes "x \<in> \<I>\<^bsub>tgt\<^esub>"
  shows "m (m_inv x) = x \<longleftrightarrow> x \<in> m ` \<I>\<^bsub>src\<^esub>"
  using assms by (cases "x \<in> m ` \<I>\<^bsub>src\<^esub>" ; simp add: m_inv_def ; (elim imageE)?
      ; (intro notI)? ; (elim notE)? ; simp ; blast)

lemmas m_inv_inv_individuals = m_inv_inv_individuals_iff[THEN iffD1] m_inv_inv_individuals_iff[THEN iffD2]

lemma subst_image_subset: "x \<in> m ` \<S>\<^bsub>src\<^esub> \<Longrightarrow> x \<in> m ` \<I>\<^bsub>src\<^esub>"
  by auto

lemma m_inv_inv_moments_iff[simp]:
  assumes "x \<in> \<M>\<^bsub>tgt\<^esub>"
  shows "m (m_inv x) = x \<longleftrightarrow> x \<in> m ` \<M>\<^bsub>src\<^esub>"
  using assms apply (cases "x \<in> m ` \<M>\<^bsub>src\<^esub>" ; simp add: m_inv_def ; (elim imageE)?
      ; (intro notI conjI impI)? ; (elim notE imageE)? ; simp? ; hypsubst_thin?
      ; (intro imageI)?)
  subgoal premises P for a b
    using P(1,2,3,4) apply (simp only: P(1)[symmetric])
    apply (thin_tac "m b = m b")
    using P(1) by auto
  by blast+

lemma m_inv_inv_substantials_iff[simp]:
  assumes "x \<in> \<S>\<^bsub>tgt\<^esub>"
  shows "x \<in> m ` \<S>\<^bsub>src\<^esub> \<longleftrightarrow> m (m_inv x) = x"
  using assms by (auto simp: m_inv_def ; intro imageI ; simp)

lemma moment_image_subset: "x \<in> m ` \<M>\<^bsub>src\<^esub> \<Longrightarrow> x \<in> m ` \<I>\<^bsub>src\<^esub>"
  using src.individuals_moments_substantials by force

lemma individuals_image_iff: "x \<in> m ` \<I>\<^bsub>src\<^esub> \<longleftrightarrow> x \<in> m ` \<S>\<^bsub>src\<^esub> \<or> x \<in> m ` \<M>\<^bsub>src\<^esub>"
  using subst_image_subset moment_image_subset
  by (metis imageE imageI src.individuals_cases)

lemma m_inv_scope_substantials[simp]: "m_inv x \<in> \<S>\<^bsub>src\<^esub> \<longleftrightarrow> x \<in> m ` \<S>\<^bsub>src\<^esub>"
  apply (simp add: m_inv_def cong: if_cong ; intro conjI impI ; safe ; hypsubst_thin? ; simp? ; intro imageI)
  by auto

lemma m_inv_scope_moments[simp]: "m_inv x \<in> \<M>\<^bsub>src\<^esub> \<longleftrightarrow> x \<in> m ` \<M>\<^bsub>src\<^esub>"
  apply (simp add: individuals_image_iff m_inv_def  cong: if_cong ; intro conjI impI ; safe ; hypsubst_thin ; simp?)
  subgoal by (metis m_substantials src.substantials_moments_disj_2 substantialsI)
  by (simp add: src.moments_are_individuals)

lemma m_inv_scope_individuals[simp]: "m_inv x \<in> \<I>\<^bsub>src\<^esub> \<longleftrightarrow> x \<in> m ` \<I>\<^bsub>src\<^esub>"
  by (metis inv_into_into m_individuals m_inv_def m_undefined)

lemma sws_unique:
  assumes "w \<in> \<W>\<^bsub>tgt\<^esub>"
  shows "\<exists>!w'. w' \<in> \<W>\<^bsub>src\<^esub> \<and> m ` w' = w \<inter> m ` \<I>\<^bsub>src\<^esub>"
  supply aux = morphism_worlds_axiom_iff[of m src tgt,THEN iffD1,
        OF m_preserve_worlds,
        THEN conjunct2,rule_format,OF assms]
proof (intro ex_ex1I , metis aux ;  intro set_eqI ; clarify ; rename_tac w\<^sub>1 w\<^sub>2 x)
  fix w\<^sub>1 w\<^sub>2 x
  assume A1: "w\<^sub>1 \<in> \<W>\<^bsub>src\<^esub>" "m ` w\<^sub>1 = w \<inter> m ` \<I>\<^bsub>src\<^esub>" and
         A2: "w\<^sub>2 \<in> \<W>\<^bsub>src\<^esub>" "m ` w\<^sub>2 = w \<inter> m ` \<I>\<^bsub>src\<^esub>"
  have B[simp]: "m ` w\<^sub>1 = m ` w\<^sub>2" using A1(2) A2(2) by simp
  obtain D: "w \<in> \<W>\<^bsub>src\<^esub> \<Longrightarrow> w \<subseteq> \<I>\<^bsub>src\<^esub>" for w
    using src.worlds_are_made_of_individuals by auto
  have E: "x \<in> w" if "w \<in> \<W>\<^bsub>src\<^esub>" "x \<in> \<I>\<^bsub>src\<^esub>" "m x \<in> m ` w" for w x
    using inj_on_image_mem_iff
           m_injective D that
    by metis
  note F = E[where ?x = x and ?w=w\<^sub>1,OF A1(1)]
           E[where ?x = x and ?w=w\<^sub>2,OF A2(1)]
  show "x \<in> w\<^sub>1 \<longleftrightarrow> x \<in> w\<^sub>2"
    apply (intro iffI F)
    using A1 A2 src.worlds_are_made_of_individuals by blast+
qed

lemma sws_equality:
  assumes "w \<in> \<W>\<^bsub>tgt\<^esub>" "w' \<in> \<W>\<^bsub>src\<^esub>" "m ` w' = w \<inter> m ` \<I>\<^bsub>src\<^esub>"
  shows "sws w = w'"
  using some1_equality[OF sws_unique,simplified sws_def[symmetric],
      of w w'] assms by metis

(* UNUSED lemma sws_tws_eq_id[simp]:
  assumes "w \<in> \<W>\<^bsub>src\<^esub>"
  shows "sws (tws w) = w"
  using assms apply (elim twsE)
  by (intro sws_equality assms ; simp) *)

lemma image_negE:
  fixes x  :: "'b" and f :: "'a \<Rightarrow> 'b" and A
  assumes "x \<notin> f ` A"
  obtains "\<And>y. y \<in> A \<Longrightarrow> f y \<noteq> x"
  using assms by blast

(* UNUSED lemma m_inv_aux_1: "m_inv ` (A \<inter> m ` \<I>\<^bsub>src\<^esub>) = m_inv ` A \<inter> \<I>\<^bsub>src\<^esub>"
  supply individuals_image_iff[simp]
  apply (intro inv_into_aux_2[
    where ?g=m_inv and ?f=m and ?X="\<I>\<^bsub>src\<^esub>" and ?b=undefined,
      of A] src.undefined_not_in_individuals)
  apply (simp add: m_inv_def)
  subgoal for Y
    apply (intro set_eqI)
    subgoal for x
      apply (simp only: image_iff[of x m_inv])
      apply (cases "x \<in> \<I>\<^bsub>src\<^esub>" ; clarsimp simp: m_inv_def
          ; intro iffI ; (elim exE bexE conjE impCE disjE imageE)?
          ; hypsubst_thin? ; simp?
          ; (elim exE bexE conjE impCE disjE imageE image_negE)?
          ; hypsubst_thin? ; simp?)
      subgoal G1 by blast
      subgoal G1 by blast
      subgoal G1 by blast
      subgoal G1 using moment_image_subset by fastforce
      subgoal G5 by fastforce
      subgoal G6 by fastforce
      subgoal G7 by blast
      subgoal G8 by blast
      by (metis imageE)
    done
  done *)

(* UNUSED lemma m_inv_aux_2:
  assumes "A \<subseteq> m ` \<I>\<^bsub>src\<^esub>"
  shows "m_inv ` (A \<inter> m ` \<I>\<^bsub>src\<^esub>) = inv_into \<I>\<^bsub>src\<^esub> m  ` (A \<inter> m ` \<I>\<^bsub>src\<^esub>)"
proof -
  have A: "(\<exists>xa. P xa  \<and> (\<exists>x. Q x xa) \<and> R xa) \<longleftrightarrow>
        (\<exists>xa x. P xa  \<and> Q x xa \<and> R xa)" for Q :: "'a \<Rightarrow> 'a \<Rightarrow> bool" and P R
    by blast
  have B: "m x \<in> m ` \<S>\<^bsub>src\<^esub> \<longleftrightarrow> x \<in> \<S>\<^bsub>src\<^esub>" for x
    by (metis imageE imageI m_substantials)
  have C: "m x \<in> m ` \<M>\<^bsub>src\<^esub> \<longleftrightarrow> x \<in> \<M>\<^bsub>src\<^esub>" for x
    by (metis imageE imageI m_moments)
  have D: "xa \<in> \<I>\<^bsub>src\<^esub> \<Longrightarrow> xa \<notin> \<S>\<^bsub>src\<^esub> \<Longrightarrow> (xa \<in> \<M>\<^bsub>src\<^esub> \<Longrightarrow> P) \<Longrightarrow> P" for xa P
    using src.individuals_moments_substantials by blast
  show ?thesis
    apply (intro set_eqI)
    subgoal for x
      apply (cases "x \<in> \<I>\<^bsub>src\<^esub>" ; (simp add: image_iff Bex_def)?
          ; intro iffI ; elim exE conjE ; hypsubst_thin ; simp?
          ; (elim conjE disjE)?
          ; (simp add: B C)?
          )
      subgoal G1 using m_inv_def by auto
      using m_inv_individuals by auto
    done
qed *)

(* UNUSED lemma m_inv_subset_img:
  assumes "A \<subseteq> m ` \<I>\<^bsub>src\<^esub>"
  shows "m_inv ` A = inv_into \<I>\<^bsub>src\<^esub> m ` A"
  apply (intro set_eqI iffI ; (elim imageE)? ; hypsubst_thin
      ; simp add: image_iff )
  subgoal for x
    by (intro bexI[of _ x] ; simp only: m_inv_def
            ; intro if_P assms[THEN subsetD] ; simp)
  subgoal for x
    by (intro bexI[of _ x] ; simp only: m_inv_def
            ; intro if_P[symmetric] assms[THEN subsetD] ; simp)
  done *)

lemma m_image_injective_on_subsets_of_I[intro!,simp]:
  "inj_on ((`) m) (Pow \<I>\<^bsub>src\<^esub>)"
  apply (intro Complete_Lattices.inj_on_image
      inj_on_subset[where ?B="\<Union>(Pow \<I>\<^bsub>src\<^esub>)" and ?A="\<I>\<^bsub>src\<^esub>"]
      m_injective)
   by blast

(* UNUSED lemma worlds_in_Pow_I: "\<W>\<^bsub>src\<^esub> \<subseteq> Pow \<I>\<^bsub>src\<^esub>"
  using src.worlds_are_made_of_individuals by blast *)

lemma m_image_injective_on_worlds[intro!,simp]:
  "inj_on ((`) m) \<W>\<^bsub>src\<^esub>"
  using m_image_injective_on_subsets_of_I
      inj_on_subset src.worlds_are_made_of_individuals
  by blast

(* UNUSED lemma m_unique_image:
  assumes "w\<^sub>1 \<in> \<W>\<^bsub>src\<^esub>" "w\<^sub>2 \<in> \<W>\<^bsub>src\<^esub>" "m ` w\<^sub>1 = m ` w\<^sub>2"
  shows "w\<^sub>1 = w\<^sub>2"
  using inj_onD[OF m_image_injective_on_worlds] assms by metis *)

(* UNUSED lemma sws_eq_inv_into:
  assumes "w \<in> \<W>\<^bsub>tgt\<^esub>"
  shows "sws w =  inv_into \<W>\<^bsub>src\<^esub> (\<lambda>w'. m ` w' \<union> (w - m ` \<I>\<^bsub>src\<^esub>)) w"
proof -
  have AA: "m ` w' \<union> (w - m ` \<I>\<^bsub>src\<^esub>) = w \<longleftrightarrow> m ` w' = w \<inter> m ` \<I>\<^bsub>src\<^esub>"
    if as1: "w' \<in> \<W>\<^bsub>src\<^esub>" for w'
  proof -
    have aux1: "(A \<or> B) \<and> C \<longleftrightarrow> A \<and> C \<or> B \<and> C" for A B C by blast
    have aux2: "m ` A \<inter> m ` B = m ` (A \<inter> B)" if "A \<subseteq> B" for m :: "'r \<Rightarrow> 'w" and A B
      using that by blast
    have BB: "w' \<subseteq> \<I>\<^bsub>src\<^esub>" using as1    by (simp add: src.worlds_are_made_of_individuals)
    have CC: "w' \<inter> \<I>\<^bsub>src\<^esub> = w'" using BB by auto
    have DD: "(A - B) \<inter> B = {}" for A B :: "'z set" by blast
    have EE: "(A \<inter> B) \<union> (A - B) = A" for A B :: "'z set" by blast
    show ?thesis
    proof
      assume as2: "m ` w' \<union> (w - m ` \<I>\<^bsub>src\<^esub>) = w"
      show "m ` w' = w \<inter> m ` \<I>\<^bsub>src\<^esub>"
        apply (subst as2[symmetric] ; subst Int_Un_distrib2)
        by (subst aux2[OF BB] ; subst CC ; subst DD ; simp)
    next
      assume as2: "m ` w' = w \<inter> m ` \<I>\<^bsub>src\<^esub>"
      show "m ` w' \<union> (w - m ` \<I>\<^bsub>src\<^esub>) = w"
        by (subst as2 ; subst EE ; simp)
    qed
  qed
  have BB: "(\<lambda>w'. w' \<in> \<W>\<^bsub>src\<^esub> \<and> m ` w' = w \<inter> m ` \<I>\<^bsub>src\<^esub>) =
        (\<lambda>y. y \<in> \<W>\<^bsub>src\<^esub> \<and> m ` y \<union> (w - m ` \<I>\<^bsub>src\<^esub>) = w)"
    apply (intro ext)
    subgoal for w
      apply (cases "w \<in> \<W>\<^bsub>src\<^esub>" ; simp)
      using AA by metis
    done
  have CC: "(SOME x. P x) = (SOME y. Q y)" if "\<And>x. P x = Q x" for P Q :: "'z \<Rightarrow> bool"
    by (simp add: that)
  note sws_def[of w] inv_into_def[of "\<W>\<^bsub>src\<^esub>",THEN fun_cong,of _ w,
        of "\<lambda>w'. m ` w' \<union> (w - m ` \<I>\<^bsub>src\<^esub>)", simplified,
          simplified ]
  have DD: "(A \<Longrightarrow> B \<longleftrightarrow> C) \<Longrightarrow> A \<and> B \<longleftrightarrow> A \<and> C" for A B C
    by blast
  show ?thesis
    apply (simp add: sws_def[of w] inv_into_def[of "\<W>\<^bsub>src\<^esub>",THEN fun_cong,of _ w,
        of "\<lambda>w'. m ` w' \<union> (w - m ` \<I>\<^bsub>src\<^esub>)", simplified,
          simplified ])
    by (intro CC DD ; simp add: AA)
qed *)

(* UNUSED lemma m_inj_worlds: "w \<in> \<W>\<^bsub>tgt\<^esub> \<Longrightarrow> \<exists>!w'. w' \<in> \<W>\<^bsub>src\<^esub> \<and> w \<inter> m ` \<I>\<^bsub>src\<^esub> = m ` w'"
  by (metis sws_unique) *)

lemma m_inv_comp_m_eq'[simp]:
  fixes y
  shows "\<Theta> (\<Omega> y) = (if y \<in> \<I>\<^bsub>src\<^esub> then y else undefined)"
  apply (cases "y \<in> \<I>\<^bsub>src\<^esub>" ; simp add: m_inv_individuals m_inv_def)
  by (metis imageE m_individuals)

(* UNUSED lemma m_inv_comp_m_image':
  fixes X
  shows "\<Theta> ` \<Omega> ` X = X \<inter> \<I>\<^bsub>src\<^esub> \<union> { undefined | x .  x \<in> X \<and> x \<notin> \<I>\<^bsub>src\<^esub> }"
  apply (intro set_eqI ; simp add: image_iff)
  by metis *)

lemma m_inv_comp_m_I_image'[simp]:
  fixes X assumes "X \<subseteq> \<I>\<^bsub>src\<^esub>"
  shows "\<Theta> ` \<Omega> ` X = X"
  using assms[THEN subsetD] by (intro set_eqI ; simp add: image_iff)

lemma m_inv_comp_m_I2_image'[simp]:
  fixes X assumes "X \<in> \<W>\<^bsub>src\<^esub>"
  shows "\<Theta> ` \<Omega> ` X = X"
  using m_inv_comp_m_I_image' src.worlds_are_made_of_individuals assms by metis

(* UNUSED lemma m_inv_inj_worlds_1:
  assumes "w \<in> \<W>\<^bsub>tgt\<^esub>"
  shows "m_inv ` ( w \<inter> m ` \<I>\<^bsub>src\<^esub> ) \<in> \<W>\<^bsub>src\<^esub>"
proof -
  obtain w' where A: "w' \<in> \<W>\<^bsub>src\<^esub>" "m ` w' = w \<inter> m ` \<I>\<^bsub>src\<^esub>"
    using m_preserve_worlds_D(2)[OF assms] by metis
  have B: "w' \<subseteq> \<I>\<^bsub>src\<^esub>" using A(1)
    by (simp add: src.worlds_are_made_of_individuals)
  have C: "m_inv ` m ` w' = m_inv ` (w \<inter> m ` \<I>\<^bsub>src\<^esub>)" using A(2) by simp
  then have "w' = m_inv ` (w \<inter> m ` \<I>\<^bsub>src\<^esub>)" using B
    by auto
  then show ?thesis using A(1) by simp
qed *)

end

locale individual_structure_surjective_morphism =
  individual_structure_morphism  +
  assumes
    m_surjective[simp]: "m ` \<I>\<^bsub>src\<^esub> = \<I>\<^bsub>tgt\<^esub>"
begin

lemma m_surjective_on_moments[simp]: "m ` \<M>\<^bsub>src\<^esub> = \<M>\<^bsub>tgt\<^esub>"
  apply (intro set_eqI)
  subgoal for x
    using m_surjective moments_subset_individuals[of src] moments_subset_individuals[of tgt]
      imageE[of x m "\<M>\<^bsub>src\<^esub>"] rev_image_eqI[of _ "\<M>\<^bsub>src\<^esub>" x m]
      src.individuals_moments_substantials
    by (metis (mono_tags, hide_lams) image_iff m_moments tgt.inheres_in_scope tgt.momentsE)
  done

lemma m_surjective_on_substantials[simp]: "m ` \<S>\<^bsub>src\<^esub> = \<S>\<^bsub>tgt\<^esub>"
  apply (intro set_eqI)
  subgoal for x
    using m_surjective substantials_subset_individuals[of src] substantials_subset_individuals[of tgt]
      imageE[of x m "\<S>\<^bsub>src\<^esub>"] rev_image_eqI[of _ "\<S>\<^bsub>src\<^esub>" x m]
      src.individuals_moments_substantials
      by (metis (mono_tags, lifting) f_inv_into_f m_substantials subset_image_iff)
    done

lemma tgt_worlds[simp]: "w \<in> \<W>\<^bsub>tgt\<^esub> \<longleftrightarrow> w \<in> ((`) m) ` \<W>\<^bsub>src\<^esub>"
proof -
  note m_preserve_worlds
  have AA: "w \<subseteq> m ` \<I>\<^bsub>src\<^esub>" if "w \<in> \<W>\<^bsub>tgt\<^esub>" for w
    using that tgt.worlds_are_made_of_individuals by auto
  have BB: "\<W>\<^bsub>tgt\<^esub> = { w . w \<in> \<W>\<^bsub>tgt\<^esub> }" by auto
  then have CC: "\<W>\<^bsub>tgt\<^esub> = { w \<inter>  m ` \<I>\<^bsub>src\<^esub> | w . w \<in> \<W>\<^bsub>tgt\<^esub> }"
    apply auto
    subgoal for x
    proof -
      assume "x \<in> \<W>\<^bsub>tgt\<^esub>"
      then have "x \<in> {I \<inter> m ` \<I>\<^bsub>src\<^esub> |I. I \<in> \<W>\<^bsub>tgt\<^esub>}"
        using individual_structure.worlds_are_made_of_individuals tgt.individual_structure_axioms by fastforce
      then show ?thesis
        by simp
    qed
    subgoal for w  by (metis AA inf_absorb2 inf_sup_aci(1) m_surjective)
    done
  have DD[simp]: "((`) m) ` \<W>\<^bsub>src\<^esub> = {m ` w |w. w \<in> \<W>\<^bsub>src\<^esub>}"
    by auto
  show ?thesis
    using AA BB CC DD m_surjective src.worlds_are_made_of_individuals
      tgt.worlds_are_made_of_individuals
    using m_preserve_worlds by auto
qed

lemma m_surj_worlds: "w \<in> \<W>\<^bsub>src\<^esub> \<Longrightarrow> m ` w \<in> \<W>\<^bsub>tgt\<^esub>"
  by simp

lemma worlds1': "{w \<inter> m ` \<I>\<^bsub>src\<^esub> |w. w \<in> \<W>\<^bsub>tgt\<^esub>} = \<W>\<^bsub>tgt\<^esub>" for w
  apply (simp ; intro set_eqI ; simp ; intro iffI ; (elim exE conjE imageE)? ; hypsubst_thin? ; simp?)
  subgoal for w
    by (metis m_surj_worlds m_surjective swsE tgt_worlds)
  subgoal for w
    using m_preserve_worlds_D(1)
    by (metis m_surjective tgt_worlds)
  done

end

locale individual_structure_bijective_morphism =
  individual_structure_injective_morphism  +
  individual_structure_surjective_morphism
begin

lemma m_bijective: "bij_betw m \<I>\<^bsub>src\<^esub> \<I>\<^bsub>tgt\<^esub>"
  using m_injective m_surjective bij_betw_def by metis

(* UNUSED lemma m_bijective_on_substantials: "bij_betw m \<S>\<^bsub>src\<^esub> \<S>\<^bsub>tgt\<^esub>"
  using m_injective_on_substantials m_surjective_on_substantials bij_betw_def by metis *)

(* UNUSED lemma m_bijective_on_moments: "bij_betw m \<M>\<^bsub>src\<^esub> \<M>\<^bsub>tgt\<^esub>"
  using m_injective_on_moments m_surjective_on_moments bij_betw_def by metis *)

lemma  m_preserce_refers_to_1[simp]:"m x \<hookrightarrow>\<^bsub>tgt\<^esub> m y \<longleftrightarrow> x \<hookrightarrow>\<^bsub>src\<^esub> y"
  by (metis m_inv_substantials m_preserve_refers_to m_substantials src.refers_to_scope)

lemma  m_inv_simps[simp]:
  "\<And>x y. m_inv x \<triangleleft>\<^bsub>src\<^esub> m_inv y \<longleftrightarrow> x \<triangleleft>\<^bsub>tgt\<^esub> y"
  "\<And>x y. m_inv x \<simeq>\<^bsub>src\<^esub> m_inv y \<longleftrightarrow> x \<simeq>\<^bsub>tgt\<^esub> y"
  "\<And>x y. m_inv x \<hookrightarrow>\<^bsub>src\<^esub> m_inv y \<longleftrightarrow> x \<hookrightarrow>\<^bsub>tgt\<^esub> y"
  "\<And>x. m_inv x \<in> \<S>\<^bsub>src\<^esub> \<longleftrightarrow> x \<in> \<S>\<^bsub>tgt\<^esub>"
  "\<And>x. m_inv x \<in> \<M>\<^bsub>src\<^esub> \<longleftrightarrow> x \<in> \<M>\<^bsub>tgt\<^esub>"
  "\<And>x. m_inv x \<in> \<I>\<^bsub>src\<^esub> \<longleftrightarrow> x \<in> \<I>\<^bsub>tgt\<^esub>"
       apply standard
        apply simp_all
  subgoal for x y by (metis individual_structure_injective_morphism.m_inv_scope_substantials individual_structure_injective_morphism_axioms m_inv_inv_individuals_iff m_inv_inv_substantials_iff m_inv_scope_moments m_preserve_inherence m_surjective m_surjective_on_moments m_surjective_on_substantials src.inheres_in_out_scope(1) src.inheres_in_out_scope(2) tgt.moments_are_individuals)
  subgoal for x y by (metis m_inv_inv_individuals(2) m_preserve_inherence m_surjective tgt.inheres_in_scope)
  subgoal for x y by (metis UnI2 m_inv_inv_individuals_iff m_inv_scope_moments m_preserve_exact_similarity m_surjective moment_image_subset src.exactly_similar_scope tgt.exactly_similar_scope tgt.individuals_moments_substantials)
  subgoal for x y
    apply (cases "x \<in> \<I>\<^bsub>tgt\<^esub>" ; simp?)
    subgoal premises P
      using P apply auto
      subgoal by (metis individual_structure_injective_morphism.m_inv_scope_individuals individual_structure_injective_morphism_axioms m_inv_inv_individuals_iff m_preserve_refers_to m_surjective src.ed_scope src.refers_to_imp_ed)
      by (metis individual_structure.refers_to_scope m_inv_inv_moments_iff m_inv_inv_substantials_iff m_preserce_refers_to_1 m_surjective_on_moments m_surjective_on_substantials tgt.individual_structure_axioms)
    subgoal premises P
      using P apply (simp add: m_inv_def ; safe ; simp?)
      using tgt.refers_to_scope by blast
    done
  done

lemma m_inv_image[simp]: "m_inv ` \<I>\<^bsub>tgt\<^esub> = \<I>\<^bsub>src\<^esub>"
  apply (intro set_eqI iffI impI ; (elim imageE)? ; simp?)
  by (metis m_individuals m_inv_individuals rev_image_eqI)

lemma src_world_Int_indiv[simp]: "w \<in> \<W>\<^bsub>src\<^esub> \<Longrightarrow> w \<inter> \<I>\<^bsub>src\<^esub> = w"
  by (simp add: inf.absorb1 src.worlds_are_made_of_individuals)

lemma src_world_inv_m[simp]: "w \<in> \<W>\<^bsub>src\<^esub> \<Longrightarrow> w = m_inv ` m ` w"
  by auto

lemma tgt_world_m_inv[simp]: "w \<in> \<W>\<^bsub>tgt\<^esub> \<Longrightarrow> w = m ` m_inv ` w"
  apply auto
  using image_iff m_inv_individuals src.individuals_iff by fastforce

lemma m_inv_individual_structure_morphism[simp,intro!]: "individual_structure_morphism tgt src m_inv"
  apply (unfold_locales)
  subgoal for x
    apply (intro disjCI ; simp ; elim conjE disjE)
    by blast
  subgoal for x y by simp
  subgoal for x y by simp
  subgoal for x y
    apply (intro iffI ; simp? ; (elim exE conjE ; hypsubst_thin ; simp)?)
    apply (intro exI[of _ "m y"] ; intro conjI)
    subgoal using m_preserve_refers_to m_inv_inv_individuals m_inv_individuals
      by (metis m_inv_simps(3) m_inv_substantials src.refers_to_scope)
    using m_preserve_refers_to m_inv_inv_individuals m_inv_individuals
    by (metis m_inv_substantials src.refers_to_scope)
  subgoal for x y
    apply (rule ccontr ; elim ed_E ; simp ; elim notE ; intro ed_I ; simp ; intro allI impI ; elim conjE)
    subgoal premises P for w
      supply A = P(1,2) P(3)[rule_format,OF conjI] P(4)[simplified image_iff] P(5)
      using A(4) A(1,2,3,5) apply (elim bexE ; simp ; elim imageE ; hypsubst_thin ; simp)
      subgoal premises Q for w\<^sub>1 z
        apply (intro rev_image_eqI[of "m_inv y" w\<^sub>1 y m, OF Q(5)] Q(1))
        subgoal using Q(2,3) by (simp add: m_inv_individuals)
        using Q(8) by (simp add: m_inv_inv_individuals)
      done
    done
  subgoal
    apply (intro set_eqI iffI CollectI ; (elim CollectE exE conjE ; hypsubst_thin)? ; simp ; (elim imageE ; hypsubst_thin ; rename_tac r t)?)
    subgoal premises P for w
      apply (simp add: image_iff)
      by (intro exI[of _ "m ` w"] ; simp add: P ; intro bexI[of _ w] P ; simp)
    subgoal premises P for r t
      using P by (intro exI[of _ t] ; simp flip: src_world_inv_m)
    done
  done

interpretation m_inv: individual_structure_morphism tgt src m_inv by simp

lemma m_inv_bijective[simp,intro!]: "bij_betw m_inv \<I>\<^bsub>tgt\<^esub> \<I>\<^bsub>src\<^esub>"
  apply (simp add: bij_betw_def ; intro inj_onI ; simp add: m_inv_def)
  using bij_betw_inv_into m_bijective bij_betw_imp_inj_on inj_onD by metis

lemma m_inv_injective[simp,intro!]: "inj_on m_inv \<I>\<^bsub>tgt\<^esub>"
  using bij_betw_imp_inj_on m_inv_bijective by metis

(* UNUSED lemma m_inv_individual_structure_injective_morphism[intro!,simp]: "individual_structure_injective_morphism tgt src m_inv"
  by (unfold_locales ; simp) *)

(* UNUSED lemma m_inv_individual_structure_surjective_morphism[intro!,simp]: "individual_structure_surjective_morphism tgt src m_inv"
  by (unfold_locales ; simp) *)

lemma m_inv_individual_structure_bijective_morphism[intro!,simp]: "individual_structure_bijective_morphism tgt src m_inv"
  by (unfold_locales ; simp)

(* UNUSED lemma worlds1': "{w \<inter> m ` \<I>\<^bsub>src\<^esub> |w. w \<in> \<W>\<^bsub>tgt\<^esub>} = \<W>\<^bsub>tgt\<^esub>" for w
  apply (simp ; intro set_eqI ; simp ; intro iffI ; (elim exE conjE imageE)? ; hypsubst_thin? ; simp?)
  subgoal for w
    by (metis m_surj_worlds m_surjective swsE tgt_worlds)
  subgoal for w
    using m_preserve_worlds_D(1)
    by (metis m_surjective tgt_worlds)
  done *)

(* UNUSED lemma m_preserve_worlds2'[simp]: "(`) m ` \<W>\<^bsub>src\<^esub> = \<W>\<^bsub>tgt\<^esub>"
  using m_preserve_worlds[simplified worlds1' worlds2] by simp *)

lemma m_comp_m_inv_eq'[simp]:
  fixes y
  assumes "y \<in> \<I>\<^bsub>tgt\<^esub>"
  shows "\<Omega> (\<Theta> y) =  y"
  using assms apply (auto simp add: m_inv_def)
  using m_inv_def m_inv_inv_individuals_iff by auto

(* lemma m_comp_m_inv_image':
  fixes X
  shows "\<Omega> ` \<Theta> ` X = X \<inter> \<I>\<^bsub>tgt\<^esub> \<union> { undefined | x .  x \<in> X \<and> x \<notin> \<I>\<^bsub>tgt\<^esub> }"
    by (intro set_eqI ; simp add: image_iff ; metis)
*)
lemma m_comp_m_inv_I_image'[simp]:
  fixes X assumes "X \<subseteq> \<I>\<^bsub>tgt\<^esub>"
  shows "\<Omega> ` \<Theta> ` X = X"
  using assms[THEN subsetD] by (intro set_eqI ; simp add: image_iff)

lemma m_comp_m_inv_I2_image'[simp]:
  fixes X assumes "X \<in> \<W>\<^bsub>tgt\<^esub>"
  shows "\<Omega> ` \<Theta> ` X = X"
  using m_comp_m_inv_I_image' src.worlds_are_made_of_individuals assms
  using tgt_world_m_inv by presburger

end

locale individual_structure_permutation_morphism_defs =
   individual_structure_defs IS +
   individual_structure_morphism_defs IS IS \<Omega>
   for IS (structure) and \<Omega>
begin

end

locale individual_structure_permutation_morphism =
  individual_structure_permutation_morphism_defs IS \<Omega> +
  individual_structure IS +
  individual_structure_bijective_morphism IS IS \<Omega>
  for IS (structure) and \<Omega> +
  assumes
    m_strong_preserve_similarity[intro!]: "x \<in> \<M> \<Longrightarrow> x \<simeq> \<Omega> x"
begin

(* UNUSED lemmas m_strong_preserve_similarity_2[intro!] =  m_strong_preserve_similarity[symmetric] *)

declare tgt_worlds[simp del]

(* UNUSED lemmas tgt_worlds_2[simp] = tgt_worlds[symmetric] *)

lemma m_inv_individual_structure_permutation_morphism[simp,intro!]: "individual_structure_permutation_morphism IS \<Theta>"
proof -
  interpret m_inv: individual_structure_bijective_morphism IS IS \<Theta> by simp
  show ?thesis
    apply (intro_locales)
  proof (unfold_locales)
    fix x
    assume as: "x \<in> \<M>"
    note inv_simps[simp] =  m_inv_moments[OF as]
    show "x \<simeq> \<Theta> x"
      using m_preserve_exact_similarity[of "x" "\<Theta> x",simplified]
            m_strong_preserve_similarity[OF as]
      using inv_simps(1)
      by (metis as m_inv.m_inv_moments m_inv.m_inv_simps(2) m_inv.m_not_moments(2) exactly_similar_sym)
  qed
qed

(* UNUSED lemmas worlds1 = worlds1'[simplified] *)

(* UNUSED declare m_preserve_worlds2'[simp del] *)
(* UNUSED lemmas m_preserve_worlds2[simp] = m_preserve_worlds2'[simplified] *)

declare m_surjective[simp del]

lemmas m_surjective'[simp] = m_surjective[simplified]

lemma m_w_W[simp]: "\<Omega> ` w \<in> \<W> \<longleftrightarrow> w \<in> \<W>" for w
proof -
  have A: "w' \<in> \<W> \<and> w = w' \<inter>  \<I> \<longleftrightarrow> w' \<in> \<W> \<and> w = w'" for w w'
    using worlds_are_made_of_individuals by blast
  have B: "{w \<inter> \<Omega> ` \<I> |w. w \<in> \<W>} = \<W>"  using worlds1' m_surjective[simplified] by simp
  have "w \<in> \<W> \<longleftrightarrow> w \<in> {w \<inter> \<Omega> ` \<I> |w. w \<in> \<W>}"
    by (simp add: worlds1'[symmetric,THEN eqset_imp_iff,of w])
  also have "... \<longleftrightarrow> (\<exists>w'. w' \<in> \<W> \<and> w = w' \<inter>  \<Omega> ` \<I>)"
    by blast
  also have "... \<longleftrightarrow> (\<exists>w'. w' \<in> \<W> \<and> w = w' \<inter>  \<I>)" by auto
  also have "... \<longleftrightarrow> (\<exists>w'. w' \<in> \<W> \<and> w = w')" using A by simp
  show ?thesis
    apply (simp add: m_preserve_worlds[simplified B,THEN eqset_imp_iff,of "\<Omega> ` w",simplified])
    apply (intro iffI ; (elim exE conjE)? ; simp? ; (intro exI[of _ w])? ; simp?)
  proof -
    fix w'
    assume P: "\<Omega> ` w = \<Omega> ` w'" "w' \<in> \<W>"
    note ex_ex = P(1)[THEN eqset_imp_iff,simplified image_def,simplified,simplified Bex_def]
    have w_w': "x \<in> w'" if as: "x \<in> w" for x
    proof -
      obtain y where AA: "y \<in> w'" "\<Omega> x = \<Omega> y"
        using  ex_ex[THEN iffD1,OF exI[of _ x],of "\<Omega> x",simplified,OF as] by blast
      have BB: "y \<in> \<I>" using AA(1) P(2) individuals_iff by blast
      have BB1: "\<Omega> y \<in> \<I>" using BB by simp
      have BB2: "\<Omega> x \<in> \<I>" using BB1 AA(2) by simp
      then have CC: "x \<in> \<I>" by simp
      have DD: "x = y"  using m_injective inj_onD AA(2) CC BB by metis
      then show "x \<in> w'" using AA by simp
    qed

    have w'_w: "x \<in> w" if as: "x \<in> w'" for x
    proof -
      obtain y where AA: "y \<in> w" "\<Omega> x = \<Omega> y"
        using  ex_ex[THEN iffD2] exI[of _ x] as by blast
      have BB: "y \<in> \<I>" using AA(1) by (metis AA(2) P(2) m_not_individuals(1) m_undefined_1(2) individuals_iff that)
      have BB1: "\<Omega> y \<in> \<I>" using BB by simp
      have BB2: "\<Omega> x \<in> \<I>" using BB1 AA(2) by simp
      then have CC: "x \<in> \<I>" by simp
      have DD: "x = y"  using m_injective inj_onD AA(2) CC BB by metis
      then show "x \<in> w" using AA by simp
    qed
    have w_eq_w': "w = w'" using w'_w w_w' by blast
    then show "w \<in> \<W>" using P(2) by simp
  qed
qed

lemma m_inv_w_W[simp]: "w \<subseteq> \<I> \<Longrightarrow> \<Theta> ` w \<in> \<W> \<longleftrightarrow> w \<in> \<W>" for w
  apply (subst m_w_W[symmetric])
  by (cases "w \<in> \<W>" ; simp?)

end

context individual_structure_defs
begin

definition Perms where "Perms \<equiv> { m . individual_structure_permutation_morphism IS m }"

definition perm_invariant where
  "perm_invariant x \<equiv> \<forall>m \<in> Perms. m x = x"

lemma PermI[intro!]:
  assumes "individual_structure_permutation_morphism IS m"
  shows "m \<in> Perms"
  using assms by (auto simp: Perms_def)

lemma PermD[dest!]:
  assumes "m \<in> Perms"
  shows "individual_structure_permutation_morphism IS m"
  using assms by (auto simp: Perms_def)

lemma Perm_iff[simp]: "m \<in> Perms \<longleftrightarrow> individual_structure_permutation_morphism IS m"
  by auto

end

context individual_structure
begin

(* UNUSED lemma inv_perm_in_perm[intro!,simp]:
  assumes "m \<in> Perms"
  shows "individual_structure_morphism_defs.\<Theta> IS m \<in> Perms" (is "?m' \<in> Perms")
  using individual_structure_permutation_morphism.m_inv_individual_structure_permutation_morphism[of IS m]
    assms Perms_def
  by simp *)

lemma id_on_perm: "id \<in> Perms"
proof -
  have A[simp]: "id ` X = X" for X :: "'z set" by auto
  show ?thesis
  apply (auto ; unfold_locales ; (simp only: inj_on_id A)?
        ; simp ; (intro set_eqI iffI conjI disjCI)?
        ; (elim CollectE)? ; simp? ; (elim conjE exE)? ; hypsubst_thin? ; simp?)
    subgoal by blast
    subgoal by (simp add: inf_absorb1 worlds_are_made_of_individuals)
    subgoal using worlds_are_made_of_individuals by auto
    by (simp add: exactly_similar_refl)
qed

end

(* UNUSED context individual_structure_permutation_morphism
begin

 lemma omega_in_perms[intro!,simp]: "\<Omega> \<in> Perms"
  by (simp add: Perms_def  individual_structure_permutation_morphism_axioms)

end *)

end


theory HealthyOrIll
  imports Main

begin

lemma healthy_or_ill: "(healthy \<or> ill) \<and> (healthy \<longrightarrow> travel) \<and> \<not>ill \<longrightarrow> travel"
  apply (rule impI)
  apply (erule conjE)
  apply (erule disjE)
   apply (erule conjE)
   apply (erule impE)
    apply assumption
   apply assumption
  apply (erule conjE)
  apply (erule notE)
  apply assumption
  done

end


theory AbstractMultiPaxosR2
imports  AbstractMultiPaxosR1 "~~/src/HOL/Library/FinFun"
begin

text {* An executable version of R1 using finfun. *}

unbundle finfun_syntax

section {* A finfun-friendly definition of @{term acc_max} *}

definition acc_max_2 where
  "acc_max_2 (bound::nat) votes \<equiv>
    if (\<exists> b < bound . votes b \<noteq> None)
    then Some (the_elem (max_by_key {(v,b) . b < bound \<and> votes b = Some v} snd))
    else None"

lemma acc_max_2_code[code]:
  "acc_max_2 bound votes = (
    if (\<exists> b < bound . votes b \<noteq> None)
    then let votes = ((\<lambda> b . votes b \<bind> (\<lambda> v . Some (v,b))) ` {0..<bound}) \<bind> option_as_set in
      Some (the_elem (max_by_key votes snd))
    else None)" sorry

lemma "acc_max_2 b (vote s i a) = acc_max (vote s i) a b"
  by (auto simp add:acc_max_2_def acc_max_def distributed_safe_at.acc_max_def)

lift_definition finfun_acc_max_2 :: "nat \<Rightarrow> (nat \<Rightarrow>f 'c option) \<Rightarrow> ('c \<times> nat) option"
  is acc_max_2 .
  -- {* Takes the ballot bound, and the votes per ballot. *}

experiment
begin

text {* The restriction operator is not executable, so does not work.
TODO: could have used filter. *}

lemma acc_max_2_code_2:
  "acc_max_2 bound votes = (
    if (\<exists> b \<in> {0..<bound} . votes b \<noteq> None)
    then let votes = ran ((\<lambda> b . votes b \<bind> (\<lambda> v . Some (v,b))) |` {0..<bound}) in
      Some (the_elem (max_by_key votes snd))
    else None)" oops

end

section {* The IOA *}

record ('v,'a,'l) ampr2_state =
  propCmd :: "'v set"
  ballot :: "'a \<Rightarrow>f bal"
  vote :: "inst \<Rightarrow>f bal \<Rightarrow>f 'a \<Rightarrow>f 'v option"
  suggestion :: "inst \<Rightarrow>f bal \<Rightarrow>f 'v option"
  onebs :: "'a \<Rightarrow>f bal \<Rightarrow>f (inst \<Rightarrow>f ('v\<times>bal) option) option"
  learned :: "'l \<Rightarrow>f inst \<Rightarrow>f 'v option"
  leader :: "'a \<Rightarrow>f bool"

locale ampr2_ioa =
  fixes quorums :: "'a set set" and leader :: "bal \<Rightarrow> 'a"
begin

definition start where
  -- {* The initial state *}
  "start \<equiv> {\<lparr>propCmd = {}, ballot = K$ 0, vote = K$ K$ K$ None,
    suggestion = K$ K$ None, onebs = K$ K$ None, learned = K$ K$ None,
    leader = (K$ False)(leader 0 $:= True)\<rparr>}"

subsection {* propose and @{text join_ballot} *}

definition propose where
  "propose c r r' \<equiv> (r' = r\<lparr>propCmd := (propCmd r) \<union> {c}\<rparr>)"

notepad begin
  fix vote::"inst \<Rightarrow>f bal \<Rightarrow>f 'a \<Rightarrow>f 'v option"
  fix b :: bal
  fix a :: 'a
  define x1 where "x1 \<equiv> (op o$ (flip op$ a)) o$ vote"
end

definition join_ballot where
  "join_ballot a b s s' \<equiv>
    let onebs'  = (finfun_acc_max_2 b) o$ ((op o$ (flip op$ a)) o$ (vote s))
    in
      b > (ballot s $ a)
      \<and> s' = s\<lparr>ballot := (ballot s)(a $:= b),
        onebs := (onebs s)(a $:= (onebs s $ a)(b $:= Some onebs')),
        leader := (ampr2_state.leader s)(a $:= False)\<rparr>"
end

subsection {* Implementing the @{text acquire_leadership} action*}

locale acquire_leadership =
  fixes onebs :: "'a \<Rightarrow>f bal \<Rightarrow>f (inst \<Rightarrow>f ('v\<times>bal) option) option"
  fixes b :: bal
begin

definition onebs' where "onebs' \<equiv> (\<lambda> ff1 . (\<lambda> off2 . the off2) o$ ff1) o$ onebs"

definition votes_at_b where "votes_at_b \<equiv> ((flip finfun_apply) b) o$ onebs'"

definition fold_fun where "fold_fun a ff \<equiv>
  (case_prod union) o$ ($ option_as_set o$ (votes_at_b $ a), ff $)"

definition inst_votes where "inst_votes q \<equiv>
  Finite_Set.fold fold_fun (K$ {}) q"

lemma inst_votes_code[code]:"inst_votes (set xs) = fold fold_fun xs (K$ {})"
proof (induct xs)
  case Nil
  then show ?case by (auto simp add:inst_votes_def)
next
  case (Cons a xs)
  interpret folding_idem "fold_fun" "K$ {}"
    apply (unfold_locales)
    by (auto simp add:fun_eq_iff expand_finfun_eq fold_fun_def)
  show ?case using insert_idem
    by (metis (mono_tags, lifting) Cons.hyps List.finite_set comp_fun_commute eq_fold fold_commute_apply fold_simps(2) list.simps(15) inst_votes_def)
qed

definition maxs where "maxs q \<equiv> (flip max_by_key snd) o$ inst_votes q"

definition the_suggestion :: "('v\<times>bal) set \<Rightarrow> 'v option" where "the_suggestion m \<equiv>
  if m = {} then None else Some (fst (the_elem m))"

definition suggestion :: "nat \<Rightarrow>f nat \<Rightarrow>f 'v option \<Rightarrow> 'a set \<Rightarrow> nat \<Rightarrow>f nat \<Rightarrow>f 'v option"
  where "suggestion old q \<equiv> (\<lambda> (m, ff) . ff(b $:= the_suggestion m))
    o$ ($ maxs q, old $)"

end

global_interpretation al:acquire_leadership onebs b
  for onebs b .

context ampr2_ioa
begin

definition acquire_leadership where
  "acquire_leadership a q (s::('v,'a,'l) ampr2_state) s' \<equiv> let b = ballot s $ a in
    leader b = a
    \<and> q \<in> quorums
    \<and> \<not> ampr2_state.leader s $ a
    \<and> (\<forall> a \<in> q . ampr2_state.onebs s $ a $ b \<noteq> None)
    \<and> s' = s\<lparr>leader := (ampr2_state.leader s)(a $:= True),
        suggestion := al.suggestion (onebs s) b (suggestion s) q\<rparr>"

subsection {* suggest and @{text do_vote}. *}

definition suggest where "suggest a i b v s s' \<equiv>
          v \<in> propCmd s
        \<and> ballot s $ a = b
        \<and> ampr2_state.leader s $ a
        \<and> (suggestion s $ i) $ b = None
        \<and> s' = s\<lparr>suggestion := (suggestion s)(i $:= (suggestion s $ i)(b $:= Some v))\<rparr>"

definition do_vote where
  "do_vote a i v s s' \<equiv> let b = ballot s $ a in
          vote s $ i $ b $ a = None
        \<and> (suggestion s $ i) $ b = Some v
        \<and> s' = s\<lparr>vote := (vote s)(i $:= (vote s $ i)(b $:= (vote s $ i $ b)(a $:= Some v)))\<rparr>"

end

experiment begin

text {* Proving a code equation for that seems tough... *}

definition flip_binary_finfun :: "'a \<Rightarrow>f 'b \<Rightarrow>f 'c \<Rightarrow> 'b \<Rightarrow>f 'a \<Rightarrow>f 'c" where
  "flip_binary_finfun ff \<equiv> Abs_finfun (\<lambda> b . Abs_finfun (\<lambda> a . (ff $ a $ b)))"

lift_definition flip_binary_finfun_2 :: "'a \<Rightarrow>f 'b \<Rightarrow>f 'c \<Rightarrow> 'b \<Rightarrow>f 'a \<Rightarrow>f 'c"
  is "\<lambda> f . \<lambda> x y . f y x" oops

end

subsection {* The learn action. *}

locale chosen_imp =
  fixes vote :: "inst \<Rightarrow>f bal \<Rightarrow>f 'a \<Rightarrow>f 'v option"
  and i :: inst
  (* and q :: "'a set" *)
  and v :: 'v
begin

definition at_i :: "bal \<Rightarrow>f 'a \<Rightarrow>f 'v option" where
  "at_i \<equiv> vote $ i"

definition decision_at_bal where "decision_at_bal \<equiv>
  (finfun_All o (op o$ (op= (Some v)))) o$ at_i"
  -- {* TODO: forall in quorum! *}

definition chosen where "chosen \<equiv> finfun_Ex decision_at_bal"

end

global_interpretation ci:chosen_imp vote i v for vote::"inst \<Rightarrow>f bal \<Rightarrow>f 'a \<Rightarrow>f 'v option"
  and i and v::'v .
term ci.chosen
  -- {* TODO: How to get rid of the type parameters? *}

context ampr2_ioa
begin

definition learn where
  "learn l i v s s' \<equiv> ci.chosen TYPE('a) TYPE('b) (vote s) i v
    \<and> s' = s\<lparr>learned := (learned s)(l $:= (learned s $ l)(i $:= Some v))\<rparr>"

subsection {* catch_up and the full transition relation. *}

definition catch_up where
  "catch_up l1 l2 i v s s' \<equiv> learned s $ l2 $ i = Some v
    \<and> s' = s\<lparr>learned := (learned s)(l1 $:= (learned s $ l1)(i $:= Some v))\<rparr>"

fun trans_rel where
  "trans_rel r (Propose c) r' = propose c r r'"
| "trans_rel r Internal r' = (
    (\<exists> a b . join_ballot a b r r')
    \<or> (\<exists> a i v . do_vote a i v r r')
    \<or> (\<exists> a i b v . suggest a i b v r r')
    \<or> (\<exists> l1 l2 i v . catch_up l1 l2 i v r r')
    \<or> (\<exists> a q . acquire_leadership a q r r'))"
  | "trans_rel r (Learn i v) r' = (\<exists> l . learn l i v r r')"

lemma trans_cases[consumes 1]:
  assumes "trans_rel r a r'"
  obtains
  (propose) c where "propose c r r'"
| (learn) l i v where "learn l i v r r'"
| (join_ballot) a b where "join_ballot a b r r'"
| (do_vote) a i v where "do_vote a i v r r'"
| (suggest) a i b v where "suggest a i b v r r'"
| (catch_up) l1 l2 i v where "catch_up l1 l2 i v r r'"
| (acquire) a q where "acquire_leadership a q r r'"
  using assms apply induct apply (simp add:learn_def)
  by (metis assms learn paxos_action.exhaust trans_rel.simps(1) trans_rel.simps(2) trans_rel.simps(3))

lemma trans_cases_2[consumes 1]:
  assumes "trans_rel r aa r'"
  obtains
  (propose) c where "propose c r r'" and "aa = Propose c"
| (learn) l i v where "learn l i v r r'" and "aa = Learn i v"
| (join_ballot) a b where "join_ballot a b r r'" and "aa = Internal"
| (do_vote) a i v where "do_vote a i v r r'" and "aa = Internal"
| (suggest) a i b v where "suggest a i b v r r'" and "aa = Internal"
| (catch_up) l1 l2 i v where "catch_up l1 l2 i v r r'" and "aa = Internal"
| (acquire) a q where "acquire_leadership a q r r'" and "aa = Internal"
  using assms apply induct apply (simp add:learn_def)
  by (metis assms learn paxos_action.exhaust trans_rel.simps(1) trans_rel.simps(2) trans_rel.simps(3))

definition trans where
  "trans \<equiv> { (r,a,r') . trans_rel r a r'}"

subsection {* The I/O-automaton *}

definition ioa where
  "ioa \<equiv> \<lparr>ioa.asig = paxos_asig, start = start, trans = trans\<rparr>"

lemmas simps = ioa_def asig_def start_def trans_def propose_def join_ballot_def
  do_vote_def learn_def suggest_def catch_up_def acquire_leadership_def

end

end


(*<*)
 header {* Modal Kleene Algebras *}

theory Modal_Kleene_Algebra
  imports Domain_Semiring Range_Semiring
begin

class modal_kleene_algebra = fmodal_kleene_algebra + bmodal_kleene_algebra +
assumes domrange: "d(r(x))=r(x)"
and rangedom: "r(d(x))=d(x)"

begin

text {* These axioms force that the domain algebra and the range algebra conicide *}

lemma domrangefix: "d(x)=x \<longleftrightarrow> r(x)=x"
  by (metis domrange rangedom)

lemma box_diamond_galois_1: "p=d(p) \<and> q=d(q) \<longrightarrow> (\<langle>x\<bar>p \<le> q \<longleftrightarrow> p \<le> \<bar>x]q)"
  by (metis domrangefix fbox_demodalisation3 rdemodalisation3)

lemma box_diamond_galois_2: "p=d(p) \<and> q=d(q) \<longrightarrow> (\<bar>x\<rangle>p \<le> q \<longleftrightarrow> p \<le> [x\<bar>q)"
  by (metis domrangefix bbox_demodalisation3 fdemodalisation3)

lemma diamond_conjugation_var_1: "p = d(p) \<and> q = d(q) \<longrightarrow> (\<bar>x\<rangle>q \<le> a(p) \<longleftrightarrow> \<langle>x\<bar>p \<le> a(q))"
  by (smt a_closure a_export antidomain_semiring_domain_def box_diamond_galois_1 domain_1 fbox_def fdia_fbox less_eq_def)

lemma diamond_conjugation: "p = d(p) \<and> q = d(q)  \<longrightarrow> (p\<cdot>(\<bar>x\<rangle>q) = 0 \<longleftrightarrow> q\<cdot>(\<langle>x\<bar>p) = 0)"
  by (metis diamond_conjugation_var_1 fdia_simp_2 bdia_simp_2 domrange d_d_zero dom_el_comm)

lemma box_conjugation:  "p = d(p) \<and> q = d(q) \<longrightarrow> (p \<le> [x\<bar>a(q) \<longleftrightarrow> q \<le> \<bar>x]a(p))"
  by (metis box_diamond_galois_2 a_closure diamond_conjugation_var_1  box_diamond_galois_1 antidomain_semiring_domain_def)

lemma box_diamond_cancellation_1:  "p=d(p)  \<longrightarrow>  p \<le> \<bar>x](\<langle>x\<bar>p)"
  by (metis bdiamond_def box_diamond_galois_1 domrange order_refl)

lemma box_diamond_cancellation_2:  "p=d(p)  \<longrightarrow>  p \<le> [x\<bar>(\<bar>x\<rangle>p)"
  by (metis box_diamond_galois_2 domain_invol fdiamond_def order_refl)

lemma box_diamond_cancellation_3:  "q=d(q) \<longrightarrow> \<bar>x\<rangle>([x\<bar>q) \<le> q"
  by (metis ar_closure box_diamond_galois_2 domrangefix dual.fbox_fdia order_refl)

lemma box_diamond_cancellation_4:  "q=d(q) \<longrightarrow> \<langle>x\<bar>(\<bar>x]q) \<le> q"
  by (metis a_closure box_diamond_galois_1 fbox_def order_refl)

end

end
(*>*)


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_62
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun last :: "Nat list => Nat" where
  "last (nil2) = Z"
| "last (cons2 y (nil2)) = y"
| "last (cons2 y (cons2 x2 x3)) = last (cons2 x2 x3)"

theorem property0 :
  "((case xs of
         nil2 => True
         | cons2 y z => False) ==>
      ((last (cons2 x xs)) = (last xs)))"
  oops

end


(* Title:  ZF/ex/Ring.thy

*)

section \<open>Rings\<close>

theory Ring imports Group begin

no_notation
  cadd  (infixl "\<oplus>" 65) and
  cmult  (infixl "\<otimes>" 70)

(*First, we must simulate a record declaration:
record ring = monoid +
  add :: "[i, i] => i" (infixl "\<oplus>\<index>" 65)
  zero :: i ("\<zero>\<index>")
*)

definition
  add_field :: "i => i" where
  "add_field(M) = fst(snd(snd(snd(M))))"

definition
  ring_add :: "[i, i, i] => i" (infixl "\<oplus>\<index>" 65) where
  "ring_add(M,x,y) = add_field(M) ` <x,y>"

definition
  zero :: "i => i" ("\<zero>\<index>") where
  "zero(M) = fst(snd(snd(snd(snd(M)))))"

lemma add_field_eq [simp]: "add_field(<C,M,I,A,z>) = A"
  by (simp add: add_field_def)

lemma add_eq [simp]: "ring_add(<C,M,I,A,z>, x, y) = A ` <x,y>"
  by (simp add: ring_add_def)

lemma zero_eq [simp]: "zero(<C,M,I,A,Z,z>) = Z"
  by (simp add: zero_def)

text \<open>Derived operations.\<close>

definition
  a_inv :: "[i,i] => i" ("\<ominus>\<index> _" [81] 80) where
  "a_inv(R) == m_inv (<carrier(R), add_field(R), zero(R), 0>)"

definition
  minus :: "[i,i,i] => i" (infixl "\<ominus>\<index>" 65) where
  "\<lbrakk>x \<in> carrier(R); y \<in> carrier(R)\<rbrakk> \<Longrightarrow> x \<ominus>\<^bsub>R\<^esub> y = x \<oplus>\<^bsub>R\<^esub> (\<ominus>\<^bsub>R\<^esub> y)"

locale abelian_monoid = fixes G (structure)
  assumes a_comm_monoid:
    "comm_monoid (<carrier(G), add_field(G), zero(G), 0>)"

text \<open>
  The following definition is redundant but simple to use.
\<close>

locale abelian_group = abelian_monoid +
  assumes a_comm_group:
    "comm_group (<carrier(G), add_field(G), zero(G), 0>)"

locale ring = abelian_group R + monoid R for R (structure) +
  assumes l_distr: "\<lbrakk>x \<in> carrier(R); y \<in> carrier(R); z \<in> carrier(R)\<rbrakk>
      \<Longrightarrow> (x \<oplus> y) \<cdot> z = x \<cdot> z \<oplus> y \<cdot> z"
    and r_distr: "\<lbrakk>x \<in> carrier(R); y \<in> carrier(R); z \<in> carrier(R)\<rbrakk>
      \<Longrightarrow> z \<cdot> (x \<oplus> y) = z \<cdot> x \<oplus> z \<cdot> y"

locale cring = ring + comm_monoid R

locale "domain" = cring +
  assumes one_not_zero [simp]: "\<one> \<noteq> \<zero>"
    and integral: "\<lbrakk>a \<cdot> b = \<zero>; a \<in> carrier(R); b \<in> carrier(R)\<rbrakk> \<Longrightarrow>
                  a = \<zero> | b = \<zero>"

subsection \<open>Basic Properties\<close>

lemma (in abelian_monoid) a_monoid:
     "monoid (<carrier(G), add_field(G), zero(G), 0>)"
apply (insert a_comm_monoid)
apply (simp add: comm_monoid_def)
done

lemma (in abelian_group) a_group:
     "group (<carrier(G), add_field(G), zero(G), 0>)"
apply (insert a_comm_group)
apply (simp add: comm_group_def group_def)
done

lemma (in abelian_monoid) l_zero [simp]:
     "x \<in> carrier(G) \<Longrightarrow> \<zero> \<oplus> x = x"
apply (insert monoid.l_one [OF a_monoid])
apply (simp add: ring_add_def)
done

lemma (in abelian_monoid) zero_closed [intro, simp]:
     "\<zero> \<in> carrier(G)"
by (rule monoid.one_closed [OF a_monoid, simplified])

lemma (in abelian_group) a_inv_closed [intro, simp]:
     "x \<in> carrier(G) \<Longrightarrow> \<ominus> x \<in> carrier(G)"
by (simp add: a_inv_def  group.inv_closed [OF a_group, simplified])

lemma (in abelian_monoid) a_closed [intro, simp]:
     "[| x \<in> carrier(G); y \<in> carrier(G) |] ==> x \<oplus> y \<in> carrier(G)"
by (rule monoid.m_closed [OF a_monoid,
                  simplified, simplified ring_add_def [symmetric]])

lemma (in abelian_group) minus_closed [intro, simp]:
     "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk> \<Longrightarrow> x \<ominus> y \<in> carrier(G)"
by (simp add: minus_def)

lemma (in abelian_group) a_l_cancel [simp]:
     "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G); z \<in> carrier(G)\<rbrakk>
      \<Longrightarrow> (x \<oplus> y = x \<oplus> z) \<longleftrightarrow> (y = z)"
by (rule group.l_cancel [OF a_group,
             simplified, simplified ring_add_def [symmetric]])

lemma (in abelian_group) a_r_cancel [simp]:
     "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G); z \<in> carrier(G)\<rbrakk>
      \<Longrightarrow> (y \<oplus> x = z \<oplus> x) \<longleftrightarrow> (y = z)"
by (rule group.r_cancel [OF a_group, simplified, simplified ring_add_def [symmetric]])

lemma (in abelian_monoid) a_assoc:
  "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G); z \<in> carrier(G)\<rbrakk>
   \<Longrightarrow> (x \<oplus> y) \<oplus> z = x \<oplus> (y \<oplus> z)"
by (rule monoid.m_assoc [OF a_monoid, simplified, simplified ring_add_def [symmetric]])

lemma (in abelian_group) l_neg:
     "x \<in> carrier(G) \<Longrightarrow> \<ominus> x \<oplus> x = \<zero>"
by (simp add: a_inv_def
     group.l_inv [OF a_group, simplified, simplified ring_add_def [symmetric]])

lemma (in abelian_monoid) a_comm:
     "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk> \<Longrightarrow> x \<oplus> y = y \<oplus> x"
by (rule comm_monoid.m_comm [OF a_comm_monoid,
    simplified, simplified ring_add_def [symmetric]])

lemma (in abelian_monoid) a_lcomm:
     "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G); z \<in> carrier(G)\<rbrakk>
      \<Longrightarrow> x \<oplus> (y \<oplus> z) = y \<oplus> (x \<oplus> z)"
by (rule comm_monoid.m_lcomm [OF a_comm_monoid,
    simplified, simplified ring_add_def [symmetric]])

lemma (in abelian_monoid) r_zero [simp]:
     "x \<in> carrier(G) \<Longrightarrow> x \<oplus> \<zero> = x"
  using monoid.r_one [OF a_monoid]
  by (simp add: ring_add_def [symmetric])

lemma (in abelian_group) r_neg:
     "x \<in> carrier(G) \<Longrightarrow> x \<oplus> (\<ominus> x) = \<zero>"
  using group.r_inv [OF a_group]
  by (simp add: a_inv_def ring_add_def [symmetric])

lemma (in abelian_group) minus_zero [simp]:
     "\<ominus> \<zero> = \<zero>"
  by (simp add: a_inv_def
    group.inv_one [OF a_group, simplified ])

lemma (in abelian_group) minus_minus [simp]:
     "x \<in> carrier(G) \<Longrightarrow> \<ominus> (\<ominus> x) = x"
  using group.inv_inv [OF a_group, simplified]
  by (simp add: a_inv_def)

lemma (in abelian_group) minus_add:
     "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk> \<Longrightarrow> \<ominus> (x \<oplus> y) = \<ominus> x \<oplus> \<ominus> y"
  using comm_group.inv_mult [OF a_comm_group]
  by (simp add: a_inv_def ring_add_def [symmetric])

lemmas (in abelian_monoid) a_ac = a_assoc a_comm a_lcomm

text \<open>
  The following proofs are from Jacobson, Basic Algebra I, pp.~88--89
\<close>

context ring
begin

lemma l_null [simp]: "x \<in> carrier(R) \<Longrightarrow> \<zero> \<cdot> x = \<zero>"
proof -
  assume R: "x \<in> carrier(R)"
  then have "\<zero> \<cdot> x \<oplus> \<zero> \<cdot> x = (\<zero> \<oplus> \<zero>) \<cdot> x"
    by (blast intro: l_distr [THEN sym])
  also from R have "... = \<zero> \<cdot> x \<oplus> \<zero>" by simp
  finally have "\<zero> \<cdot> x \<oplus> \<zero> \<cdot> x = \<zero> \<cdot> x \<oplus> \<zero>" .
  with R show ?thesis by (simp del: r_zero)
qed

lemma r_null [simp]: "x \<in> carrier(R) \<Longrightarrow> x \<cdot> \<zero> = \<zero>"
proof -
  assume R: "x \<in> carrier(R)"
  then have "x \<cdot> \<zero> \<oplus> x \<cdot> \<zero> = x \<cdot> (\<zero> \<oplus> \<zero>)"
    by (simp add: r_distr del: l_zero r_zero)
  also from R have "... = x \<cdot> \<zero> \<oplus> \<zero>" by simp
  finally have "x \<cdot> \<zero> \<oplus> x \<cdot> \<zero> = x \<cdot> \<zero> \<oplus> \<zero>" .
  with R show ?thesis by (simp del: r_zero)
qed

lemma l_minus:
  "\<lbrakk>x \<in> carrier(R); y \<in> carrier(R)\<rbrakk> \<Longrightarrow> \<ominus> x \<cdot> y = \<ominus> (x \<cdot> y)"
proof -
  assume R: "x \<in> carrier(R)" "y \<in> carrier(R)"
  then have "(\<ominus> x) \<cdot> y \<oplus> x \<cdot> y = (\<ominus> x \<oplus> x) \<cdot> y" by (simp add: l_distr)
  also from R have "... = \<zero>" by (simp add: l_neg)
  finally have "(\<ominus> x) \<cdot> y \<oplus> x \<cdot> y = \<zero>" .
  with R have "(\<ominus> x) \<cdot> y \<oplus> x \<cdot> y \<oplus> \<ominus> (x \<cdot> y) = \<zero> \<oplus> \<ominus> (x \<cdot> y)" by simp
  with R show ?thesis by (simp add: a_assoc r_neg)
qed

lemma r_minus:
  "\<lbrakk>x \<in> carrier(R); y \<in> carrier(R)\<rbrakk> \<Longrightarrow> x \<cdot> \<ominus> y = \<ominus> (x \<cdot> y)"
proof -
  assume R: "x \<in> carrier(R)" "y \<in> carrier(R)"
  then have "x \<cdot> (\<ominus> y) \<oplus> x \<cdot> y = x \<cdot> (\<ominus> y \<oplus> y)" by (simp add: r_distr)
  also from R have "... = \<zero>" by (simp add: l_neg)
  finally have "x \<cdot> (\<ominus> y) \<oplus> x \<cdot> y = \<zero>" .
  with R have "x \<cdot> (\<ominus> y) \<oplus> x \<cdot> y \<oplus> \<ominus> (x \<cdot> y) = \<zero> \<oplus> \<ominus> (x \<cdot> y)" by simp
  with R show ?thesis by (simp add: a_assoc r_neg)
qed

lemma minus_eq:
  "\<lbrakk>x \<in> carrier(R); y \<in> carrier(R)\<rbrakk> \<Longrightarrow> x \<ominus> y = x \<oplus> \<ominus> y"
  by (simp only: minus_def)

end

subsection \<open>Morphisms\<close>

definition
  ring_hom :: "[i,i] => i" where
  "ring_hom(R,S) ==
    {h \<in> carrier(R) -> carrier(S).
      (\<forall>x y. x \<in> carrier(R) & y \<in> carrier(R) \<longrightarrow>
        h ` (x \<cdot>\<^bsub>R\<^esub> y) = (h ` x) \<cdot>\<^bsub>S\<^esub> (h ` y) &
        h ` (x \<oplus>\<^bsub>R\<^esub> y) = (h ` x) \<oplus>\<^bsub>S\<^esub> (h ` y)) &
      h ` \<one>\<^bsub>R\<^esub> = \<one>\<^bsub>S\<^esub>}"

lemma ring_hom_memI:
  assumes hom_type: "h \<in> carrier(R) \<rightarrow> carrier(S)"
    and hom_mult: "\<And>x y. \<lbrakk>x \<in> carrier(R); y \<in> carrier(R)\<rbrakk> \<Longrightarrow>
      h ` (x \<cdot>\<^bsub>R\<^esub> y) = (h ` x) \<cdot>\<^bsub>S\<^esub> (h ` y)"
    and hom_add: "\<And>x y. \<lbrakk>x \<in> carrier(R); y \<in> carrier(R)\<rbrakk> \<Longrightarrow>
      h ` (x \<oplus>\<^bsub>R\<^esub> y) = (h ` x) \<oplus>\<^bsub>S\<^esub> (h ` y)"
    and hom_one: "h ` \<one>\<^bsub>R\<^esub> = \<one>\<^bsub>S\<^esub>"
  shows "h \<in> ring_hom(R,S)"
by (auto simp add: ring_hom_def assms)

lemma ring_hom_closed:
     "\<lbrakk>h \<in> ring_hom(R,S); x \<in> carrier(R)\<rbrakk> \<Longrightarrow> h ` x \<in> carrier(S)"
by (auto simp add: ring_hom_def)

lemma ring_hom_mult:
     "\<lbrakk>h \<in> ring_hom(R,S); x \<in> carrier(R); y \<in> carrier(R)\<rbrakk>
      \<Longrightarrow> h ` (x \<cdot>\<^bsub>R\<^esub> y) = (h ` x) \<cdot>\<^bsub>S\<^esub> (h ` y)"
by (simp add: ring_hom_def)

lemma ring_hom_add:
     "\<lbrakk>h \<in> ring_hom(R,S); x \<in> carrier(R); y \<in> carrier(R)\<rbrakk>
      \<Longrightarrow> h ` (x \<oplus>\<^bsub>R\<^esub> y) = (h ` x) \<oplus>\<^bsub>S\<^esub> (h ` y)"
by (simp add: ring_hom_def)

lemma ring_hom_one: "h \<in> ring_hom(R,S) \<Longrightarrow> h ` \<one>\<^bsub>R\<^esub> = \<one>\<^bsub>S\<^esub>"
by (simp add: ring_hom_def)

locale ring_hom_cring = R: cring R + S: cring S
  for R (structure) and S (structure) and h +
  assumes homh [simp, intro]: "h \<in> ring_hom(R,S)"
  notes hom_closed [simp, intro] = ring_hom_closed [OF homh]
    and hom_mult [simp] = ring_hom_mult [OF homh]
    and hom_add [simp] = ring_hom_add [OF homh]
    and hom_one [simp] = ring_hom_one [OF homh]

lemma (in ring_hom_cring) hom_zero [simp]:
     "h ` \<zero>\<^bsub>R\<^esub> = \<zero>\<^bsub>S\<^esub>"
proof -
  have "h ` \<zero>\<^bsub>R\<^esub> \<oplus>\<^bsub>S\<^esub> h ` \<zero> = h ` \<zero>\<^bsub>R\<^esub> \<oplus>\<^bsub>S\<^esub> \<zero>\<^bsub>S\<^esub>"
    by (simp add: hom_add [symmetric] del: hom_add)
  then show ?thesis by (simp del: S.r_zero)
qed

lemma (in ring_hom_cring) hom_a_inv [simp]:
     "x \<in> carrier(R) \<Longrightarrow> h ` (\<ominus>\<^bsub>R\<^esub> x) = \<ominus>\<^bsub>S\<^esub> h ` x"
proof -
  assume R: "x \<in> carrier(R)"
  then have "h ` x \<oplus>\<^bsub>S\<^esub> h ` (\<ominus> x) = h ` x \<oplus>\<^bsub>S\<^esub> (\<ominus>\<^bsub>S\<^esub> (h ` x))"
    by (simp add: hom_add [symmetric] R.r_neg S.r_neg del: hom_add)
  with R show ?thesis by simp
qed

lemma (in ring) id_ring_hom [simp]: "id(carrier(R)) \<in> ring_hom(R,R)"
apply (rule ring_hom_memI)
apply (auto simp add: id_type)
done

end


theory Hidden
imports "List-Index.List_Index"
begin

definition hidden :: "'a list \<Rightarrow> nat \<Rightarrow> bool" where
"hidden xs i  \<equiv>  i < size xs \<and> xs!i \<in> set(drop (i+1) xs)"

lemma hidden_last_index: "x \<in> set xs \<Longrightarrow> hidden (xs @ [x]) (last_index xs x)"
by(auto simp add: hidden_def nth_append rev_nth[symmetric]
        dest: last_index_less[OF _ le_refl])

lemma hidden_inacc: "hidden xs i \<Longrightarrow> last_index xs x \<noteq> i"
by(auto simp add: hidden_def last_index_drop last_index_less_size_conv)

lemma fun_upds_apply:
 "(m(xs[\<mapsto>]ys)) x =
  (let xs' = take (size ys) xs
   in if x \<in> set xs' then Some(ys ! last_index xs' x) else m x)"
proof(induct xs arbitrary: m ys)
  case Nil then show ?case by(simp add: Let_def)
next
  case Cons show ?case
  proof(cases ys)
    case Nil
    then show ?thesis by(simp add:Let_def)
  next
    case Cons': Cons
    then show ?thesis using Cons by(simp add: Let_def last_index_Cons)
  qed
qed

lemma map_upds_apply_eq_Some:
  "((m(xs[\<mapsto>]ys)) x = Some y) =
  (let xs' = take (size ys) xs
   in if x \<in> set xs' then ys ! last_index xs' x = y else m x = Some y)"
by(simp add:fun_upds_apply Let_def)

lemma map_upds_upd_conv_last_index:
  "\<lbrakk>x \<in> set xs; size xs \<le> size ys \<rbrakk>
  \<Longrightarrow> m(xs[\<mapsto>]ys, x\<mapsto>y) = m(xs[\<mapsto>]ys[last_index xs x := y])"
by(rule ext) (simp add:fun_upds_apply eq_sym_conv Let_def)

end


(*  Title:       Mathematical Preliminaries
    Author:      Jonathan Julián Huerta y Munive, 2020
    Maintainer:  Jonathan Julián Huerta y Munive <jjhuertaymunive1@sheffield.ac.uk>
*)

section \<open> Mathematical Preliminaries \<close>

text \<open>This section adds useful syntax, abbreviations and theorems to the Isabelle distribution. \<close>

theory MTX_Preliminaries
  imports "Hybrid_Systems_VCs.HS_Preliminaries"

begin

subsection \<open> Syntax \<close>

abbreviation "\<e> k \<equiv> axis k 1"

syntax
  "_ivl_integral" :: "real \<Rightarrow> real \<Rightarrow> 'a \<Rightarrow> pttrn \<Rightarrow> bool" ("(3\<integral>\<^sub>_\<^sup>_ (_)\<partial>/_)" [0, 0, 10] 10)

translations
  "\<integral>\<^sub>a\<^sup>b f \<partial>x" \<rightleftharpoons> "CONST ivl_integral a b (\<lambda>x. f)"

notation matrix_inv ("_\<^sup>-\<^sup>1" [90])

abbreviation "entries (A::'a^'n^'m) \<equiv> {A $ i $ j | i j. i \<in> UNIV \<and> j \<in> UNIV}"

subsection \<open> Topology and sets \<close>

lemmas compact_imp_bdd_above = compact_imp_bounded[THEN bounded_imp_bdd_above]

lemma comp_cont_image_spec: "continuous_on T f \<Longrightarrow> compact T \<Longrightarrow> compact {f t |t. t \<in> T}"
  using compact_continuous_image by (simp add: Setcompr_eq_image)

lemmas bdd_above_cont_comp_spec = compact_imp_bdd_above[OF comp_cont_image_spec]

lemmas bdd_above_norm_cont_comp = continuous_on_norm[THEN bdd_above_cont_comp_spec]

lemma open_cballE: "t\<^sub>0 \<in> T \<Longrightarrow> open T \<Longrightarrow> \<exists>e>0. cball t\<^sub>0 e \<subseteq> T"
  using open_contains_cball by blast

lemma open_ballE: "t\<^sub>0 \<in> T \<Longrightarrow> open T \<Longrightarrow> \<exists>e>0. ball t\<^sub>0 e \<subseteq> T"
  using open_contains_ball by blast

lemma funcset_UNIV: "f \<in> A \<rightarrow> UNIV"
  by auto

lemma finite_image_of_finite[simp]:
  fixes f::"'a::finite \<Rightarrow> 'b"
  shows "finite {x. \<exists>i. x = f i}"
  using finite_Atleast_Atmost_nat by force

lemma finite_image_of_finite2:
  fixes f :: "'a::finite \<Rightarrow> 'b::finite \<Rightarrow> 'c"
  shows "finite {f x y |x y. P x y}"
proof-
  have "finite (\<Union>x. {f x y|y. P x y})"
    by simp
  moreover have "{f x y|x y. P x y} = (\<Union>x. {f x y|y. P x y})"
    by auto
  ultimately show ?thesis
    by simp
qed

subsection \<open> Functions \<close>

lemma finite_sum_univ_singleton: "(sum g UNIV) = sum g {i::'a::finite} + sum g (UNIV - {i})"
  by (metis add.commute finite_class.finite_UNIV sum.subset_diff top_greatest)

lemma suminfI:
  fixes f :: "nat \<Rightarrow> 'a::{t2_space,comm_monoid_add}"
  shows "f sums k \<Longrightarrow> suminf f = k"
  unfolding sums_iff by simp

lemma suminf_eq_sum:
  fixes f :: "nat \<Rightarrow> ('a::real_normed_vector)"
  assumes "\<And>n. n > m \<Longrightarrow> f n = 0"
  shows "(\<Sum>n. f n) = (\<Sum>n \<le> m. f n)"
  using assms by (meson atMost_iff finite_atMost not_le suminf_finite)

lemma suminf_multr: "summable f \<Longrightarrow> (\<Sum>n. f n * c) = (\<Sum>n. f n) * c" for c::"'a::real_normed_algebra"
  by (rule bounded_linear.suminf [OF bounded_linear_mult_left, symmetric])

lemma sum_if_then_else_simps[simp]:
  fixes q :: "('a::semiring_0)" and i :: "'n::finite"
  shows "(\<Sum>j\<in>UNIV. f j * (if j = i then q else 0)) = f i * q"
    and "(\<Sum>j\<in>UNIV. f j * (if i = j then q else 0)) = f i * q"
    and "(\<Sum>j\<in>UNIV. (if i = j then q else 0) * f j) = q * f i"
    and "(\<Sum>j\<in>UNIV. (if j = i then q else 0) * f j) = q * f i"
  by (auto simp: finite_sum_univ_singleton[of _ i])

subsection \<open> Suprema \<close>

lemma le_max_image_of_finite[simp]:
  fixes f::"'a::finite \<Rightarrow> 'b::linorder"
  shows "(f i) \<le> Max {x. \<exists>i. x = f i}"
  by (rule Max.coboundedI, simp_all) (rule_tac x=i in exI, simp)

lemma cSup_eq:
  fixes c::"'a::conditionally_complete_lattice"
  assumes "\<forall>x \<in> X. x \<le> c" and "\<exists>x \<in> X. c \<le> x"
  shows "Sup X = c"
  by (metis assms cSup_eq_maximum order_class.order.antisym)

lemma cSup_mem_eq:
  "c \<in> X \<Longrightarrow> \<forall>x \<in> X. x \<le> c \<Longrightarrow> Sup X = c" for c::"'a::conditionally_complete_lattice"
  by (rule cSup_eq, auto)

lemma cSup_finite_ex:
  "finite X \<Longrightarrow> X \<noteq> {} \<Longrightarrow> \<exists>x\<in>X. Sup X = x" for X::"'a::conditionally_complete_linorder set"
  by (metis (full_types) bdd_finite(1) cSup_upper finite_Sup_less_iff order_less_le)

lemma cMax_finite_ex:
  "finite X \<Longrightarrow> X \<noteq> {} \<Longrightarrow> \<exists>x\<in>X. Max X = x" for X::"'a::conditionally_complete_linorder set"
  apply(subst cSup_eq_Max[symmetric])
  using cSup_finite_ex by auto

lemma finite_nat_minimal_witness:
  fixes P :: "('a::finite) \<Rightarrow> nat \<Rightarrow> bool"
  assumes "\<forall>i. \<exists>N::nat. \<forall>n \<ge> N. P i n"
  shows "\<exists>N. \<forall>i. \<forall>n \<ge> N. P i n"
proof-
  let "?bound i" = "(LEAST N. \<forall>n \<ge> N. P i n)"
  let ?N = "Max {?bound i |i. i \<in> UNIV}"
  {fix n::nat and i::'a
    assume "n \<ge> ?N"
    obtain M where "\<forall>n \<ge> M. P i n"
      using assms by blast
    hence obs: "\<forall> m \<ge> ?bound i. P i m"
      using LeastI[of "\<lambda>N. \<forall>n \<ge> N. P i n"] by blast
    have "finite {?bound i |i. i \<in> UNIV}"
      by simp
    hence "?N \<ge> ?bound i"
      using Max_ge by blast
    hence "n \<ge> ?bound i"
      using \<open>n \<ge> ?N\<close> by linarith
    hence "P i n"
      using obs by blast}
  thus "\<exists>N. \<forall>i n. N \<le> n \<longrightarrow> P i n"
    by blast
qed

subsection \<open> Real numbers \<close>

named_theorems field_power_simps "simplification rules for powers to the nth"

declare semiring_normalization_rules(18) [field_power_simps]
    and semiring_normalization_rules(26) [field_power_simps]
    and semiring_normalization_rules(27) [field_power_simps]
    and semiring_normalization_rules(28) [field_power_simps]
    and semiring_normalization_rules(29) [field_power_simps]

text \<open>WARNING: Adding @{thm semiring_normalization_rules(27)} to our tactic makes
its combination with simp to loop infinitely in some proofs.\<close>

lemma sq_le_cancel:
  shows "(a::real) \<ge> 0 \<Longrightarrow> b \<ge> 0 \<Longrightarrow> a^2 \<le> b * a \<Longrightarrow> a \<le> b"
  and "(a::real) \<ge> 0 \<Longrightarrow> b \<ge> 0 \<Longrightarrow> a^2 \<le> a * b \<Longrightarrow> a \<le> b"
   apply (metis less_eq_real_def mult.commute mult_le_cancel_left semiring_normalization_rules(29))
  by (metis less_eq_real_def mult_le_cancel_left semiring_normalization_rules(29))

lemma frac_diff_eq1: "a \<noteq> b \<Longrightarrow> a / (a - b) - b / (a - b) = 1" for a::real
  by (metis (no_types, hide_lams) ab_left_minus add.commute add_left_cancel
      diff_divide_distrib diff_minus_eq_add div_self)

lemma exp_add: "x * y - y * x = 0 \<Longrightarrow> exp (x + y) = exp x * exp y"
  by (rule exp_add_commuting) (simp add: ac_simps)

lemmas mult_exp_exp = exp_add[symmetric]

subsection \<open> Vectors and matrices \<close>

lemma sum_axis[simp]:
  fixes q :: "('a::semiring_0)"
  shows "(\<Sum>j\<in>UNIV. f j * axis i q $ j) = f i * q"
    and "(\<Sum>j\<in>UNIV. axis i q $ j * f j) = q * f i"
  unfolding axis_def by(auto simp: vec_eq_iff)

lemma sum_scalar_nth_axis: "sum (\<lambda>i. (x $ i) *s \<e> i) UNIV = x" for x :: "('a::semiring_1)^'n"
  unfolding vec_eq_iff axis_def by simp

lemma scalar_eq_scaleR[simp]: "c *s x = c *\<^sub>R x"
  unfolding vec_eq_iff by simp

lemma matrix_add_rdistrib: "((B + C) ** A) = (B ** A) + (C ** A)"
  by (vector matrix_matrix_mult_def sum.distrib[symmetric] field_simps)

lemma vec_mult_inner: "(A *v v) \<bullet> w = v \<bullet> (transpose A *v w)" for A :: "real ^'n^'n"
  unfolding matrix_vector_mult_def transpose_def inner_vec_def
  apply(simp add: sum_distrib_right sum_distrib_left)
  apply(subst sum.swap)
  apply(subgoal_tac "\<forall>i j. A $ i $ j * v $ j * w $ i = v $ j * (A $ i $ j * w $ i)")
  by presburger simp

lemma uminus_axis_eq[simp]: "- axis i k = axis i (-k)" for k :: "'a::ring"
  unfolding axis_def by(simp add: vec_eq_iff)

lemma norm_axis_eq[simp]: "\<parallel>axis i k\<parallel> = \<parallel>k\<parallel>"
proof(simp add: axis_def norm_vec_def L2_set_def)
  let "?\<delta>\<^sub>K" = "\<lambda>i j k. if i = j then k else 0"
  have "(\<Sum>j\<in>UNIV. (\<parallel>(?\<delta>\<^sub>K j i k)\<parallel>)\<^sup>2) = (\<Sum>j\<in>{i}. (\<parallel>(?\<delta>\<^sub>K j i k)\<parallel>)\<^sup>2) + (\<Sum>j\<in>(UNIV-{i}). (\<parallel>(?\<delta>\<^sub>K j i k)\<parallel>)\<^sup>2)"
    using finite_sum_univ_singleton by blast
  also have "... = (\<parallel>k\<parallel>)\<^sup>2"
    by simp
  finally show "sqrt (\<Sum>j\<in>UNIV. (norm (if j = i then k else 0))\<^sup>2) = norm k"
    by simp
qed

lemma matrix_axis_0:
  fixes A :: "('a::idom)^'n^'m"
  assumes "k \<noteq> 0 " and h:"\<forall>i. (A *v (axis i k)) = 0"
  shows "A = 0"
proof-
  {fix i::'n
    have "0 = (\<Sum>j\<in>UNIV. (axis i k) $ j *s column j A)"
      using h matrix_mult_sum[of A "axis i k"] by simp
    also have "... = k *s column i A"
      by (simp add: axis_def vector_scalar_mult_def column_def vec_eq_iff mult.commute)
    finally have "k *s column i A = 0"
      unfolding axis_def by simp
    hence "column i A = 0"
      using vector_mul_eq_0 \<open>k \<noteq> 0\<close> by blast}
  thus "A = 0"
    unfolding column_def vec_eq_iff by simp
qed

lemma scaleR_norm_sgn_eq: "(\<parallel>x\<parallel>) *\<^sub>R sgn x = x"
  by (metis divideR_right norm_eq_zero scale_eq_0_iff sgn_div_norm)

lemma vector_scaleR_commute: "A *v c *\<^sub>R x = c *\<^sub>R (A *v x)" for x :: "('a::real_normed_algebra_1)^'n"
  unfolding scaleR_vec_def matrix_vector_mult_def by(auto simp: vec_eq_iff scaleR_right.sum)

lemma scaleR_vector_assoc: "c *\<^sub>R (A *v x) = (c *\<^sub>R A) *v x" for x :: "('a::real_normed_algebra_1)^'n"
  unfolding matrix_vector_mult_def by(auto simp: vec_eq_iff scaleR_right.sum)

lemma mult_norm_matrix_sgn_eq:
  fixes x :: "('a::real_normed_algebra_1)^'n"
  shows "(\<parallel>A *v sgn x\<parallel>) * (\<parallel>x\<parallel>) = \<parallel>A *v x\<parallel>"
proof-
  have "\<parallel>A *v x\<parallel> = \<parallel>A *v ((\<parallel>x\<parallel>) *\<^sub>R sgn x)\<parallel>"
    by(simp add: scaleR_norm_sgn_eq)
  also have "... = (\<parallel>A *v sgn x\<parallel>) * (\<parallel>x\<parallel>)"
    by(simp add: vector_scaleR_commute)
  finally show ?thesis ..
qed

subsection\<open> Diagonalization \<close>

lemma invertibleI: "A ** B = mat 1 \<Longrightarrow> B ** A = mat 1 \<Longrightarrow> invertible A"
  unfolding invertible_def by auto

lemma invertibleD[simp]:
  assumes "invertible A"
  shows "A\<^sup>-\<^sup>1 ** A = mat 1" and "A ** A\<^sup>-\<^sup>1 = mat 1"
  using assms unfolding matrix_inv_def invertible_def
  by (simp_all add: verit_sko_ex')

lemma matrix_inv_unique:
  assumes "A ** B = mat 1" and "B ** A = mat 1"
  shows "A\<^sup>-\<^sup>1 = B"
  by (metis assms invertibleD(2) invertibleI matrix_mul_assoc matrix_mul_lid)

lemma invertible_matrix_inv: "invertible A \<Longrightarrow> invertible (A\<^sup>-\<^sup>1)"
  using invertibleD invertibleI by blast

lemma matrix_inv_idempotent[simp]: "invertible A \<Longrightarrow> A\<^sup>-\<^sup>1\<^sup>-\<^sup>1 = A"
  using invertibleD matrix_inv_unique by blast

lemma matrix_inv_matrix_mul:
  assumes "invertible A" and "invertible B"
  shows "(A ** B)\<^sup>-\<^sup>1 = B\<^sup>-\<^sup>1 ** A\<^sup>-\<^sup>1"
proof(rule matrix_inv_unique)
  have "A ** B ** (B\<^sup>-\<^sup>1 ** A\<^sup>-\<^sup>1) = A ** (B ** B\<^sup>-\<^sup>1) ** A\<^sup>-\<^sup>1"
    by (simp add: matrix_mul_assoc)
  also have "... = mat 1"
    using assms by simp
  finally show "A ** B ** (B\<^sup>-\<^sup>1 ** A\<^sup>-\<^sup>1) = mat 1" .
next
  have "B\<^sup>-\<^sup>1 ** A\<^sup>-\<^sup>1 ** (A ** B) = B\<^sup>-\<^sup>1 ** (A\<^sup>-\<^sup>1 ** A) ** B"
    by (simp add: matrix_mul_assoc)
  also have "... = mat 1"
    using assms by simp
  finally show "B\<^sup>-\<^sup>1 ** A\<^sup>-\<^sup>1 ** (A ** B) = mat 1" .
qed

lemma mat_inverse_simps[simp]:
  fixes c :: "'a::division_ring"
  assumes "c \<noteq> 0"
  shows "mat (inverse c) ** mat c = mat 1"
    and "mat c ** mat (inverse c) = mat 1"
  unfolding matrix_matrix_mult_def mat_def by (auto simp: vec_eq_iff assms)

lemma matrix_inv_mat[simp]: "c \<noteq> 0 \<Longrightarrow> (mat c)\<^sup>-\<^sup>1 = mat (inverse c)" for c :: "'a::division_ring"
  by (simp add: matrix_inv_unique)

lemma invertible_mat[simp]: "c \<noteq> 0 \<Longrightarrow> invertible (mat c)" for c :: "'a::division_ring"
  using invertibleI mat_inverse_simps(1) mat_inverse_simps(2) by blast

lemma matrix_inv_mat_1: "(mat (1::'a::division_ring))\<^sup>-\<^sup>1 = mat 1"
  by simp

lemma invertible_mat_1: "invertible (mat (1::'a::division_ring))"
  by simp

definition similar_matrix :: "('a::semiring_1)^'m^'m \<Rightarrow> ('a::semiring_1)^'n^'n \<Rightarrow> bool" (infixr "\<sim>" 25)
  where "similar_matrix A B \<longleftrightarrow> (\<exists> P. invertible P \<and> A = P\<^sup>-\<^sup>1 ** B ** P)"

lemma similar_matrix_refl[simp]: "A \<sim> A" for A :: "'a::division_ring^'n^'n"
  by (unfold similar_matrix_def, rule_tac x="mat 1" in exI, simp)

lemma similar_matrix_simm: "A \<sim> B \<Longrightarrow> B \<sim> A" for A B :: "('a::semiring_1)^'n^'n"
  apply(unfold similar_matrix_def, clarsimp)
  apply(rule_tac x="P\<^sup>-\<^sup>1" in exI, simp add: invertible_matrix_inv)
  by (metis invertible_def matrix_inv_unique matrix_mul_assoc matrix_mul_lid matrix_mul_rid)

lemma similar_matrix_trans: "A \<sim> B \<Longrightarrow> B \<sim> C \<Longrightarrow> A \<sim> C" for A B C :: "('a::semiring_1)^'n^'n"
proof(unfold similar_matrix_def, clarsimp)
  fix P Q
  assume "A = P\<^sup>-\<^sup>1 ** (Q\<^sup>-\<^sup>1 ** C ** Q) ** P" and "B = Q\<^sup>-\<^sup>1 ** C ** Q"
  let ?R = "Q ** P"
  assume inverts: "invertible Q" "invertible P"
  hence "?R\<^sup>-\<^sup>1 = P\<^sup>-\<^sup>1 ** Q\<^sup>-\<^sup>1"
    by (rule matrix_inv_matrix_mul)
  also have "invertible ?R"
    using inverts invertible_mult by blast
  ultimately show "\<exists>R. invertible R \<and> P\<^sup>-\<^sup>1 ** (Q\<^sup>-\<^sup>1 ** C ** Q) ** P = R\<^sup>-\<^sup>1 ** C ** R"
    by (metis matrix_mul_assoc)
qed

lemma mat_vec_nth_simps[simp]:
  "i = j \<Longrightarrow> mat c $ i $ j = c"
  "i \<noteq> j \<Longrightarrow> mat c $ i $ j = 0"
  by (simp_all add: mat_def)

definition "diag_mat f = (\<chi> i j. if i = j then f i else 0)"

lemma diag_mat_vec_nth_simps[simp]:
  "i = j \<Longrightarrow> diag_mat f $ i $ j = f i"
  "i \<noteq> j \<Longrightarrow> diag_mat f $ i $ j = 0"
  unfolding diag_mat_def by simp_all

lemma diag_mat_const_eq[simp]: "diag_mat (\<lambda>i. c) = mat c"
  unfolding mat_def diag_mat_def by simp

lemma matrix_vector_mul_diag_mat: "diag_mat f *v s = (\<chi> i. f i * s$i)"
  unfolding diag_mat_def matrix_vector_mult_def by simp

lemma matrix_vector_mul_diag_axis[simp]: "diag_mat f *v (axis i k) = axis i (f i * k)"
  by (simp add: matrix_vector_mul_diag_mat axis_def fun_eq_iff)

lemma matrix_mul_diag_matl: "diag_mat f ** A = (\<chi> i j. f i * A$i$j)"
  unfolding diag_mat_def matrix_matrix_mult_def by simp

lemma matrix_matrix_mul_diag_matr: "A ** diag_mat f = (\<chi> i j. A$i$j * f j)"
  unfolding diag_mat_def matrix_matrix_mult_def apply(clarsimp simp: fun_eq_iff)
  subgoal for i j
    by (auto simp: finite_sum_univ_singleton[of _ j])
  done

lemma matrix_mul_diag_diag: "diag_mat f ** diag_mat g = diag_mat (\<lambda>i. f i * g i)"
  unfolding diag_mat_def matrix_matrix_mult_def vec_eq_iff by simp

lemma compow_matrix_mul_diag_mat_eq: "((**) (diag_mat f) ^^ n) (mat 1) = diag_mat (\<lambda>i. f i^n)"
  apply(induct n, simp_all add: matrix_mul_diag_matl)
  by (auto simp: vec_eq_iff diag_mat_def)

lemma compow_similar_diag_mat_eq:
  assumes "invertible P"
      and "A = P\<^sup>-\<^sup>1 ** (diag_mat f) ** P"
    shows "((**) A ^^ n) (mat 1) = P\<^sup>-\<^sup>1 ** (diag_mat (\<lambda>i. f i^n)) ** P"
proof(induct n, simp_all add: assms)
  fix n::nat
  have "P\<^sup>-\<^sup>1 ** diag_mat f ** P ** (P\<^sup>-\<^sup>1 ** diag_mat (\<lambda>i. f i ^ n) ** P) =
  P\<^sup>-\<^sup>1 ** diag_mat f ** diag_mat (\<lambda>i. f i ^ n) ** P" (is "?lhs = _")
    by (metis (no_types, lifting) assms(1) invertibleD(2) matrix_mul_rid matrix_mul_assoc)
  also have "... = P\<^sup>-\<^sup>1 ** diag_mat (\<lambda>i. f i * f i ^ n) ** P" (is "_ = ?rhs")
    by (metis (full_types) matrix_mul_assoc matrix_mul_diag_diag)
  finally show "?lhs = ?rhs" .
qed

lemma compow_similar_diag_mat:
  assumes "A \<sim> (diag_mat f)"
  shows "((**) A ^^ n) (mat 1) \<sim> diag_mat (\<lambda>i. f i^n)"
proof(unfold similar_matrix_def)
  obtain P where "invertible P" and "A = P\<^sup>-\<^sup>1 ** (diag_mat f) ** P"
    using assms unfolding similar_matrix_def by blast
  thus "\<exists>P. invertible P \<and> ((**) A ^^ n) (mat 1) = P\<^sup>-\<^sup>1 ** diag_mat (\<lambda>i. f i ^ n) ** P"
    using compow_similar_diag_mat_eq by blast
qed

no_notation matrix_inv ("_\<^sup>-\<^sup>1" [90])
        and similar_matrix (infixr "\<sim>" 25)

end


section \<open>Introduction\<close>

text\<open>Poincar\'e disc is a model of hyperbolic geometry. That fact has been
a mathematical folklore for more than 100 years. However, up to the
best of our knowledge, fully precise, formal proofs of this fact are
lacking. In this paper we present a formalization of the Poincar\'e disc model
in Isabelle/HOL, introduce its basic notions (h-points, h-lines,
h-congruence, h-isometries, h-betweenness) and prove that it models
Tarski's axioms except for Euclid's axiom. We shown that is satisfies
the negation of Euclid's axiom, and, moreover, the existence of
limiting parallels axiom. The model is defined within the extended
complex plane, which has been described quite precisely by
Schwerdfeger~\cite{schwerdtfeger} and formalized in the previous work
of the first two authors~\cite{amai-complexplane}.\<close>

paragraph \<open>Related work.\<close>

text\<open>In 1840 Lobachevsky~\cite{lobachevsky1840geometrische} published developments
about non-Euclidean geometry. Hyperbolic
geometry is studied through many of its models. The concept of a
projective disc model was introduced by Klein while Poincar\'e
investigated the half-plane model proposed by Liouville and Beltrami
and primarily studied the isometries of the hyperbolic plane that
preserve orientation. In this paper, we focus on the formalization of
the latter.

Regarding non-Euclidean geometry, Makarios showed the
independence of Euclid's axiom~\cite{makarios}. He did so by
formalizing that the Klein--Beltrami model is a model of Tarski's
axioms at the exception of Euclid's axiom. Latter Coghetto formalized
the Klein-Beltrami model within Mizar~\cite{coghetto2018klein1,coghetto2018klein2}.
\<close>

section \<open>Background theories\<close>

subsection\<open>Hyperbolic Functions\<close>

text \<open>In this section hyperbolic cosine and hyperbolic sine functions are introduced and some of their
properties needed for further development are proved.\<close>

theory Hyperbolic_Functions
  imports Complex_Main Complex_Geometry.More_Complex
begin

lemma cosh_arcosh [simp]:
  fixes x :: real
  assumes "x \<ge> 1"
  shows "cosh (arcosh x) = x"
proof-
  from assms
  have  **: "x + sqrt(x\<^sup>2 - 1) \<ge> 1"
    by (smt one_le_power real_sqrt_ge_zero)
  hence *: "x + sqrt(x\<^sup>2 - 1) \<noteq> 0"
    by simp
  moreover
  have "sqrt (x\<^sup>2 - 1) + 1 / (x + sqrt (x\<^sup>2 - 1)) = x" (is "?lhs = x")
  proof-
    have "?lhs = (x*sqrt(x\<^sup>2 - 1) + x\<^sup>2) / (x + sqrt(x\<^sup>2 - 1))"
      using * \<open>x \<ge> 1\<close>
      by (subst add_divide_eq_iff, simp, simp add: field_simps)
    also have "... = x * (sqrt(x\<^sup>2 - 1) + x) / (x + sqrt(x\<^sup>2 - 1))"
      by (simp add: field_simps power2_eq_square)
    finally
    show ?thesis
      using nonzero_mult_div_cancel_right[OF *, of x]
      by (simp add: field_simps)
  qed
  thus ?thesis
    using arcosh_real_def[OF assms(1)]
    unfolding cosh_def
    using ln_div[of 1, symmetric] **
    by auto
qed

lemma arcosh_ge_0 [simp]:
  fixes x::real
  assumes "x \<ge> 1"
  shows "arcosh x \<ge> 0"
  by (smt arcosh_def assms ln_ge_zero powr_ge_pzero)

lemma arcosh_eq_0_iff:
  fixes x::real
  assumes "x \<ge> 1"
  shows "arcosh x = 0 \<longleftrightarrow> x = 1"
  using assms
  using cosh_arcosh by fastforce

lemma arcosh_eq_iff:
  fixes x y::real
  assumes "x \<ge> 1" "y \<ge> 1"
  shows "arcosh x = arcosh y \<longleftrightarrow> x = y"
  using assms
  using cosh_arcosh by fastforce

lemma cosh_gt_1 [simp]:
  fixes x ::real
  assumes "x > 0"
  shows "cosh x > 1"
  using assms cosh_real_strict_mono by force

lemma cosh_eq_iff:
  fixes x y::real
  assumes "x \<ge> 0" "y \<ge> 0"
  shows "cosh x = cosh y \<longleftrightarrow> x = y"
  by (simp add: assms(1) assms(2))

lemma arcosh_mono:
  fixes x y::real
  assumes "x \<ge> 1" "y \<ge> 1"
  shows "arcosh x \<ge> arcosh y \<longleftrightarrow> x \<ge> y"
  using assms
  by (smt arcosh_ge_0 cosh_arcosh cosh_real_nonneg_less_iff)

lemma arcosh_add:
  fixes x y::real
  assumes "x \<ge> 1" "y \<ge> 1"
  shows "arcosh x + arcosh y = arcosh (x*y + sqrt((x\<^sup>2 - 1)*(y\<^sup>2 - 1)))"
proof-
  have "sqrt ((x\<^sup>2 - 1) * (y\<^sup>2 - 1)) \<ge> 0"
    using assms
    by simp
  moreover
  have "x * y \<ge> 1"
    using assms
    by (smt mult_le_cancel_left1)
  ultimately
  have **: "x * y + sqrt ((x\<^sup>2 - 1) * (y\<^sup>2 - 1)) \<ge> 1"
    by linarith
  hence 1: "0 \<le> (x * y + sqrt ((x\<^sup>2 - 1) * (y\<^sup>2 - 1)))\<^sup>2 - 1"
      by simp

  have 2: "x * sqrt (y\<^sup>2 - 1) + y * sqrt (x\<^sup>2 - 1) \<ge> 0"
    using assms
    by simp

  have "(x*sqrt(y\<^sup>2 - 1)+y*sqrt(x\<^sup>2 -1))\<^sup>2 = (sqrt((x*y+sqrt((x\<^sup>2-1)*(y\<^sup>2-1)))\<^sup>2 - 1))\<^sup>2"
    using assms
  proof (subst real_sqrt_pow2)
    show "0 \<le> (x * y + sqrt ((x\<^sup>2 - 1) * (y\<^sup>2 - 1)))\<^sup>2 - 1"
      by fact
  next
    have "(x * sqrt (y\<^sup>2 - 1))\<^sup>2 = x\<^sup>2 * (y\<^sup>2 - 1)"
      using assms
      apply (subst power_mult_distrib)
      apply (subst real_sqrt_pow2, simp_all)
      done
    moreover
    have "(y * sqrt (x\<^sup>2 - 1))\<^sup>2 = y\<^sup>2 * (x\<^sup>2 - 1)"
      using assms
      apply (subst power_mult_distrib)
      apply (subst real_sqrt_pow2, simp_all)
      done
    ultimately show "(x * sqrt (y\<^sup>2 - 1) + y * sqrt (x\<^sup>2 - 1))\<^sup>2 = (x * y + sqrt ((x\<^sup>2 - 1) * (y\<^sup>2 - 1)))\<^sup>2 - 1"
      using assms
      unfolding power2_sum
      apply (simp add: real_sqrt_mult power_mult_distrib)
      apply (simp add: field_simps)
      done
  qed
  hence "sqrt ((x * y + sqrt ((x\<^sup>2 - 1) * (y\<^sup>2 - 1)))\<^sup>2 - 1) = x * sqrt (y\<^sup>2 - 1) + y * sqrt (x\<^sup>2 - 1)"
    using power2_eq_iff_nonneg[OF 2 real_sqrt_ge_zero[OF 1]]
    by simp
  thus ?thesis
    using assms
    apply (subst arcosh_real_def[OF assms(1)])
    apply (subst arcosh_real_def[OF assms(2)])
    apply (subst arcosh_real_def[OF **])
    apply (subst ln_mult[symmetric])
    apply (smt one_le_power real_sqrt_ge_zero)
    apply (smt one_le_power real_sqrt_ge_zero)
    apply (simp add: real_sqrt_mult)
    apply (simp add: field_simps)
    done
qed

lemma arcosh_double:
  fixes x :: real
  assumes "x \<ge> 1"
  shows "2 * arcosh x = arcosh (2*x\<^sup>2 - 1)"
  by (smt arcosh_add arcosh_mono assms one_power2 power2_eq_square real_sqrt_abs)

end