theory Resource imports
  More_CryptHOL
begin

section \<open>Resources\<close>

subsection \<open>Type definition\<close>

codatatype ('a, 'b) resource
  = Resource (run_resource: "'a \<Rightarrow> ('b \<times> ('a, 'b) resource) spmf")
  for map: map_resource'
    rel: rel_resource'

lemma case_resource_conv_run_resource: "case_resource f res = f (run_resource res)"
  by(fact resource.case_eq_if)

subsection \<open>Functor\<close>

context
  fixes a :: "'a \<Rightarrow> 'a'"
    and b :: "'b \<Rightarrow> 'b'"
begin

primcorec map_resource :: "('a', 'b) resource \<Rightarrow> ('a, 'b') resource" where
  "run_resource (map_resource res) = map_spmf (map_prod b map_resource) \<circ> (run_resource res) \<circ> a"

lemma map_resource_sel [simp]:
  "run_resource (map_resource res) a' = map_spmf (map_prod b map_resource) (run_resource res (a a'))"
  by simp

declare map_resource.sel [simp del]

lemma map_resource_ctr [simp, code]:
  "map_resource (Resource f) = Resource (map_spmf (map_prod b map_resource) \<circ> f \<circ> a)"
  by(rule resource.expand; simp add: fun_eq_iff)

end

lemma map_resource_id1: "map_resource id f res = map_resource' f res"
  by(coinduction arbitrary: res)(auto simp add: rel_fun_def spmf_rel_map resource.map_sel intro!: rel_spmf_reflI)

lemma map_resource_id [simp]: "map_resource id id res = res"
  by(simp add: map_resource_id1 resource.map_id)

lemma map_resource_compose [simp]:
  "map_resource a b (map_resource a' b' res) = map_resource (a' \<circ> a) (b \<circ> b') res"
  by(coinduction arbitrary: res)(auto 4 3 intro!: rel_funI rel_spmf_reflI simp add: spmf_rel_map)

functor resource: map_resource by(simp_all add: o_def fun_eq_iff)

subsection \<open>Relator\<close>

coinductive rel_resource :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow> ('a, 'c) resource \<Rightarrow> ('b, 'd) resource \<Rightarrow> bool"
  for A B where
    rel_resourceI:
    "rel_fun A (rel_spmf (rel_prod B (rel_resource A B))) (run_resource res1) (run_resource res2)
  \<Longrightarrow> rel_resource A B res1 res2"

lemma rel_resource_coinduct [consumes 1, case_names rel_resource, coinduct pred: rel_resource]:
  assumes "X res1 res2"
    and "\<And>res1 res2. X res1 res2 \<Longrightarrow>
         rel_fun A (rel_spmf (rel_prod B (\<lambda>res1 res2. X res1 res2 \<or> rel_resource A B res1 res2)))
            (run_resource res1) (run_resource res2)"
  shows "rel_resource A B res1 res2"
  using assms(1) by(rule rel_resource.coinduct)(simp add: assms(2))

lemma rel_resource_simps [simp, code]:
  "rel_resource A B (Resource f) (Resource g) \<longleftrightarrow> rel_fun A (rel_spmf (rel_prod B (rel_resource A B))) f g"
  by(subst rel_resource.simps) simp

lemma rel_resourceD:
  "rel_resource A B res1 res2 \<Longrightarrow> rel_fun A (rel_spmf (rel_prod B (rel_resource A B))) (run_resource res1) (run_resource res2)"
  by(blast elim: rel_resource.cases)

lemma rel_resource_eq1: "rel_resource (=) = rel_resource'"
proof(intro ext iffI)
  show "rel_resource' B res1 res2" if "rel_resource (=) B res1 res2" for B res1 res2 using that
    by(coinduction arbitrary: res1 res2)(auto elim: rel_resource.cases)
  show "rel_resource (=) B res1 res2" if "rel_resource' B res1 res2" for B res1 res2 using that
    by(coinduction arbitrary: res1 res2)(auto 4 4 elim: resource.rel_cases intro: spmf_rel_mono_strong simp add: rel_fun_def)
qed

lemma rel_resource_eq: (* [relator_eq] *) "rel_resource (=) (=) = (=)"
  by(simp add: rel_resource_eq1 resource.rel_eq)

lemma rel_resource_mono:
  assumes "A' \<le> A" "B \<le> B'"
  shows "rel_resource A B \<le> rel_resource A' B'"
proof
  show "rel_resource A' B' res1 res2" if "rel_resource A B res1 res2" for res1 res2 using that
    by(coinduct)(auto dest: rel_resourceD elim!: rel_spmf_mono prod.rel_mono_strong rel_fun_mono intro: assms[THEN predicate2D])
qed

lemma rel_resource_conversep: "rel_resource A\<inverse>\<inverse> B\<inverse>\<inverse> = (rel_resource A B)\<inverse>\<inverse>"
proof(intro ext iffI; simp)
  show "rel_resource A B res1 res2" if "rel_resource A\<inverse>\<inverse> B\<inverse>\<inverse> res2 res1"
    for A :: "'a1 \<Rightarrow> 'a2 \<Rightarrow> bool" and B :: "'c1 \<Rightarrow> 'c2 \<Rightarrow> bool" and res1 res2
    using that by(coinduct)
      (drule rel_resourceD, rewrite in \<hole> conversep_iff[symmetric]
        , subst rel_fun_conversep[symmetric], subst spmf_rel_conversep[symmetric], erule rel_fun_mono
        , auto simp add: prod.rel_conversep[symmetric] rel_fun_def conversep_iff[abs_def]  elim:rel_spmf_mono prod.rel_mono_strong)

  from this[of "A\<inverse>\<inverse>" "B\<inverse>\<inverse>"]
  show "rel_resource A\<inverse>\<inverse> B\<inverse>\<inverse> res2 res1" if "rel_resource A B res1 res2" for res1 res2 using that by simp
qed

lemma rel_resource_map_resource'1:
  "rel_resource A B (map_resource' f res1) res2 = rel_resource A (\<lambda>x. B (f x)) res1 res2"
  (is "?lhs = ?rhs")
proof
  show ?rhs if ?lhs using that
    by(coinduction arbitrary: res1 res2)
      (drule rel_resourceD, auto simp add: map_resource.sel map_resource_id1[symmetric] rel_fun_comp spmf_rel_map prod.rel_map[abs_def]
        elim!: rel_fun_mono rel_spmf_mono prod.rel_mono[THEN predicate2D, rotated -1])

  show ?lhs if ?rhs using that
    by(coinduction arbitrary: res1 res2)
      (drule rel_resourceD, auto simp add: map_resource.sel map_resource_id1[symmetric] rel_fun_comp spmf_rel_map prod.rel_map[abs_def]
        elim!: rel_fun_mono rel_spmf_mono prod.rel_mono[THEN predicate2D, rotated -1])
qed

lemma rel_resource_map_resource'2:
  "rel_resource A B res1 (map_resource' f res2) = rel_resource A (\<lambda>x y. B x (f y)) res1 res2"
  using rel_resource_map_resource'1[of "conversep A" "conversep B" f res2 res1]
  by(rewrite in "\<hole> = _" conversep_iff[symmetric]
      , rewrite in "_ = \<hole>" conversep_iff[symmetric])
    (simp only: rel_resource_conversep[symmetric]
      , simp only: conversep_iff[abs_def])

lemmas resource_rel_map' = rel_resource_map_resource'1[abs_def] rel_resource_map_resource'2

lemma rel_resource_pos_distr:
  "rel_resource A B OO rel_resource A' B' \<le> rel_resource (A OO A') (B OO B')"
proof(rule predicate2I)
  show "rel_resource (A OO A') (B OO B') res1 res3"
    if "(rel_resource A B OO rel_resource A' B') res1 res3"
    for res1 res3 using that
    apply(coinduction arbitrary: res1 res3)
    apply(erule relcomppE)
    apply(drule rel_resourceD)+
    apply(rule rel_fun_mono)
      apply(rule pos_fun_distr[THEN predicate2D])
      apply(erule (1) relcomppI)
     apply simp
    apply(rule rel_spmf_mono)
     apply(erule rel_spmf_pos_distr[THEN predicate2D])
    apply(auto simp add: prod.rel_compp[symmetric] elim: prod.rel_mono[THEN predicate2D, rotated -1])
    done
qed

lemma left_unique_rel_resource:
  "\<lbrakk> left_total A; left_unique B \<rbrakk> \<Longrightarrow> left_unique (rel_resource A B)"
  unfolding left_unique_alt_def left_total_alt_def rel_resource_conversep[symmetric]
  apply(subst rel_resource_eq[symmetric])
  apply(rule order_trans[OF rel_resource_pos_distr])
  apply(erule (1) rel_resource_mono)
  done

lemma right_unique_rel_resource:
  "\<lbrakk> right_total A; right_unique B \<rbrakk> \<Longrightarrow> right_unique (rel_resource A B)"
  unfolding right_unique_alt_def right_total_alt_def rel_resource_conversep[symmetric]
  apply(subst rel_resource_eq[symmetric])
  apply(rule order_trans[OF rel_resource_pos_distr])
  apply(erule (1) rel_resource_mono)
  done

lemma bi_unique_rel_resource [transfer_rule]:
  "\<lbrakk> bi_total A; bi_unique B \<rbrakk> \<Longrightarrow> bi_unique (rel_resource A B)"
  unfolding bi_unique_alt_def bi_total_alt_def by(blast intro: left_unique_rel_resource right_unique_rel_resource)

definition rel_witness_resource :: "('a \<Rightarrow> 'e \<Rightarrow> bool) \<Rightarrow> ('e \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow> ('a, 'b) resource \<times> ('c, 'd) resource \<Rightarrow> ('e, 'b \<times> 'd) resource" where
  "rel_witness_resource A A' B = corec_resource (\<lambda>(res1, res2).
   map_spmf (map_prod id Inr \<circ> rel_witness_prod) \<circ>
   rel_witness_spmf (rel_prod B (rel_resource (A OO A') B)) \<circ>
   rel_witness_fun A A' (run_resource res1, run_resource res2))"

lemma rel_witness_resource_sel [simp]:
  "run_resource (rel_witness_resource A A' B (res1, res2)) =
   map_spmf (map_prod id (rel_witness_resource A A' B) \<circ> rel_witness_prod) \<circ>
   rel_witness_spmf (rel_prod B (rel_resource (A OO A') B)) \<circ>
   rel_witness_fun A A' (run_resource res1, run_resource res2)"
  by(auto simp add: rel_witness_resource_def o_def fun_eq_iff spmf.map_comp intro!: map_spmf_cong)

lemma assumes "rel_resource (A OO A') B res res'"
  and A: "left_unique A" "right_total A"
  and A': "right_unique A'" "left_total A'"
shows rel_witness_resource1: "rel_resource A (\<lambda>b (b', c). b = b' \<and> B b' c) res (rel_witness_resource A A' B (res, res'))" (is "?thesis1")
  and rel_witness_resource2: "rel_resource A' (\<lambda>(b, c') c. c = c' \<and> B b c') (rel_witness_resource A A' B (res, res')) res'" (is "?thesis2")
proof -
  show ?thesis1 using assms(1)
  proof(coinduction arbitrary: res res')
    case rel_resource
    from this[THEN rel_resourceD] show ?case
      by(simp add: rel_fun_comp)
        (erule rel_fun_mono[OF rel_witness_fun1[OF _ A A']]
          , auto simp add: spmf_rel_map elim!: rel_spmf_mono[OF rel_witness_spmf1])
  qed
  show ?thesis2 using assms(1)
  proof(coinduction arbitrary: res res')
    case rel_resource
    from this[THEN rel_resourceD] show ?case
      by(simp add: rel_fun_comp)
        (erule rel_fun_mono[OF rel_witness_fun2[OF _ A A']]
          , auto simp add: spmf_rel_map elim!: rel_spmf_mono[OF rel_witness_spmf2])
  qed
qed

lemma rel_resource_neg_distr:
  assumes A: "left_unique A" "right_total A"
    and A': "right_unique A'" "left_total A'"
  shows "rel_resource (A OO A') (B OO B') \<le> rel_resource A B OO rel_resource A' B'"
proof(rule predicate2I relcomppI)+
  fix res res''
  assume *: "rel_resource (A OO A') (B OO B') res res''"
  let ?res' = "map_resource' (relcompp_witness B B') (rel_witness_resource A A' (B OO B') (res, res''))"
  show "rel_resource A B res ?res'" using rel_witness_resource1[OF * A A'] unfolding resource_rel_map'
    by(rule rel_resource_mono[THEN predicate2D, rotated -1]; clarify del: relcomppE elim!: relcompp_witness)
  show "rel_resource A' B' ?res' res''" using rel_witness_resource2[OF * A A'] unfolding resource_rel_map'
    by(rule rel_resource_mono[THEN predicate2D, rotated -1]; clarify del: relcomppE elim!: relcompp_witness)
qed

lemma left_total_rel_resource:
  "\<lbrakk> left_unique A; right_total A; left_total B \<rbrakk> \<Longrightarrow> left_total (rel_resource A B)"
  unfolding left_unique_alt_def left_total_alt_def rel_resource_conversep[symmetric]
  apply(subst rel_resource_eq[symmetric])
  apply(rule order_trans[rotated])
   apply(rule rel_resource_neg_distr; simp add: left_unique_alt_def)
  apply(rule rel_resource_mono; assumption)
  done

lemma right_total_rel_resource:
  "\<lbrakk> right_unique A; left_total A; right_total B \<rbrakk> \<Longrightarrow> right_total (rel_resource A B)"
  unfolding right_unique_alt_def right_total_alt_def rel_resource_conversep[symmetric]
  apply(subst rel_resource_eq[symmetric])
  apply(rule order_trans[rotated])
   apply(rule rel_resource_neg_distr; simp add: right_unique_alt_def)
  apply(rule rel_resource_mono; assumption)
  done

lemma bi_total_rel_resource [transfer_rule]:
  "\<lbrakk> bi_total A; bi_unique A; bi_total B \<rbrakk> \<Longrightarrow> bi_total (rel_resource A B)"
  unfolding bi_total_alt_def bi_unique_alt_def
  by(blast intro: left_total_rel_resource right_total_rel_resource)

context includes lifting_syntax begin

lemma Resource_parametric [transfer_rule]:
  "((A ===> rel_spmf (rel_prod B (rel_resource A B))) ===> rel_resource A B) Resource Resource"
  by(rule rel_funI)(simp)

lemma run_resource_parametric [transfer_rule]:
  "(rel_resource A B ===> A ===> rel_spmf (rel_prod B (rel_resource A B))) run_resource run_resource"
  by(rule rel_funI)(auto dest: rel_resourceD)

lemma corec_resource_parametric [transfer_rule]:
  "((S ===> A ===> rel_spmf (rel_prod B (rel_sum (rel_resource A B) S))) ===> S ===> rel_resource A B)
   corec_resource corec_resource"
proof((rule rel_funI)+, goal_cases)
  case (1 f g s1 s2)
  then show ?case using 1(2)
    by (coinduction arbitrary: s1 s2)
      (drule 1(1)[THEN rel_funD], auto 4 4 simp add: rel_fun_comp spmf_rel_map prod.rel_map[abs_def] split: sum.split elim!: rel_fun_mono rel_spmf_mono elim: prod.rel_mono[THEN predicate2D, rotated -1])
qed

lemma map_resource_parametric [transfer_rule]:
  "((A' ===> A) ===> (B ===> B') ===> rel_resource A B ===> rel_resource A' B') map_resource map_resource"
  unfolding map_resource_def by(transfer_prover)

lemma map_resource'_parametric [transfer_rule]:
  "((B ===> B') ===> rel_resource (=) B ===> rel_resource (=) B') map_resource' map_resource'"
  unfolding map_resource_id1[symmetric] by transfer_prover

lemma case_resource_parametric [transfer_rule]:
  "(((A ===> rel_spmf (rel_prod B (rel_resource A B))) ===> C) ===> rel_resource A B ===> C)
  case_resource case_resource"
  unfolding case_resource_conv_run_resource by transfer_prover

end

lemma rel_resource_Grp:
  "rel_resource (conversep (BNF_Def.Grp UNIV f)) (BNF_Def.Grp UNIV g) = BNF_Def.Grp UNIV (map_resource f g)"
proof((rule ext iffI)+, goal_cases)
  case (1 res res')
  have *: "rel_resource (\<lambda>a b. b = f a)\<inverse>\<inverse> (\<lambda>a b. b = g a) res res' \<Longrightarrow> res' = map_resource f g res"
    by(rule sym, subst (3) map_resource_id[symmetric], subst rel_resource_eq[symmetric])
      (erule map_resource_parametric[THEN rel_funD, THEN rel_funD, THEN rel_funD, rotated -1]
        , auto simp add: rel_fun_def)

  from 1 show ?case unfolding Grp_def using * by (clarsimp simp add: * simp del: conversep_iff)
next
  case (2 _ _)
  then show ?case
    by(clarsimp simp add: Grp_iff, subst map_resource_id[symmetric])
      (rule map_resource_parametric[THEN rel_funD, THEN rel_funD, THEN rel_funD, rotated -1]
        , subst rel_resource_eq, auto simp add: Grp_iff rel_fun_def)
qed

subsection \<open>Losslessness\<close>

coinductive lossless_resource :: "('a, 'b) \<I> \<Rightarrow> ('a, 'b) resource \<Rightarrow> bool"
  for \<I> where
    lossless_resourceI: "lossless_resource \<I> res" if
    "\<And>a. a \<in> outs_\<I> \<I> \<Longrightarrow> lossless_spmf (run_resource res a)"
    "\<And>a b res'. \<lbrakk> a \<in> outs_\<I> \<I>; (b, res') \<in> set_spmf (run_resource res a) \<rbrakk> \<Longrightarrow> lossless_resource \<I> res'"

lemma lossless_resource_coinduct [consumes 1, case_names lossless_resource, case_conclusion lossless_resource lossless step, coinduct pred: lossless_resource]:
  assumes "X res"
    and "\<And>res a. \<lbrakk> X res; a \<in> outs_\<I> \<I> \<rbrakk> \<Longrightarrow> lossless_spmf (run_resource res a) \<and>
          (\<forall>(b, res') \<in> set_spmf (run_resource res a). X res' \<or> lossless_resource \<I> res')"
  shows "lossless_resource \<I> res"
  using assms(1) by(rule lossless_resource.coinduct)(auto dest: assms(2))

lemma lossless_resourceD:
  "\<lbrakk> lossless_resource \<I> res; a \<in> outs_\<I> \<I> \<rbrakk>
  \<Longrightarrow> lossless_spmf (run_resource res a) \<and> (\<forall>(x, res')\<in>set_spmf (run_resource res a). lossless_resource \<I> res')"
  by(auto elim: lossless_resource.cases)

lemma lossless_resource_mono:
  assumes "lossless_resource \<I>' res"
    and le: "outs_\<I> \<I> \<subseteq> outs_\<I> \<I>'"
  shows "lossless_resource \<I> res"
  using assms(1)
  by(coinduction arbitrary: res)(auto dest: lossless_resourceD intro: subsetD[OF le])

lemma lossless_resource_mono':
  "\<lbrakk> lossless_resource \<I>' res; \<I> \<le> \<I>' \<rbrakk> \<Longrightarrow> lossless_resource \<I> res"
  by(erule lossless_resource_mono)(simp add: le_\<I>_def)

subsection \<open>Operations\<close>

context fixes "oracle" :: "'s \<Rightarrow> 'a \<Rightarrow> ('b \<times> 's) spmf" begin

primcorec resource_of_oracle :: "'s \<Rightarrow> ('a, 'b) resource" where
  "run_resource (resource_of_oracle s) = (\<lambda>a. map_spmf (map_prod id resource_of_oracle) (oracle s a))"

end

lemma resource_of_oracle_parametric [transfer_rule]: includes lifting_syntax shows
  "((S ===> A ===> rel_spmf (rel_prod B S)) ===> S ===> rel_resource A B) resource_of_oracle resource_of_oracle"
  unfolding resource_of_oracle_def by transfer_prover

lemma map_resource_resource_of_oracle:
  "map_resource f g (resource_of_oracle oracle s) = resource_of_oracle (map_fun id (map_fun f (map_spmf (map_prod g id))) oracle) s"
  for s :: 's
  using resource_of_oracle_parametric[of "BNF_Def.Grp UNIV (id :: 's \<Rightarrow> _)" "conversep (BNF_Def.Grp UNIV f)" "BNF_Def.Grp UNIV g"]
  unfolding prod.rel_Grp option.rel_Grp pmf.rel_Grp rel_fun_Grp rel_resource_Grp
  by simp
    (subst (asm) (1 2) eq_alt[symmetric]
      , subst (asm) (1 2) conversep_eq[symmetric]
      , subst (asm) (1 2) eq_alt
      , unfold rel_fun_Grp, simp add: rel_fun_Grp rel_fun_def Grp_iff)

lemma (in callee_invariant_on) lossless_resource_of_oracle:
  assumes *: "\<And>s x. \<lbrakk> x \<in> outs_\<I> \<I>; I s \<rbrakk> \<Longrightarrow> lossless_spmf (callee s x)"
    and "I s"
  shows "lossless_resource \<I> (resource_of_oracle callee s)"
  using \<open>I s\<close> by(coinduction arbitrary: s)(auto intro: * dest: callee_invariant)

context includes lifting_syntax begin

lemma resource_of_oracle_rprodl: includes lifting_syntax shows
  "resource_of_oracle ((rprodl ---> id ---> map_spmf (map_prod id lprodr)) oracle) ((s1, s2), s3) =
    resource_of_oracle oracle (s1, s2, s3)"
  by(rule resource_of_oracle_parametric[of "BNF_Def.Grp UNIV rprodl" "(=)" "(=)", THEN rel_funD, THEN rel_funD, unfolded rel_resource_eq])
    (auto simp add: Grp_iff rel_fun_def spmf_rel_map intro!: rel_spmf_reflI)

lemma resource_of_oracle_extend_state_oracle [simp]:
  "resource_of_oracle (extend_state_oracle oracle) (s', s) = resource_of_oracle oracle s"
  by(rule resource_of_oracle_parametric[of "conversep (BNF_Def.Grp UNIV (\<lambda>s. (s', s)))" "(=)" "(=)", THEN rel_funD, THEN rel_funD, unfolded rel_resource_eq])
    (auto simp add: Grp_iff rel_fun_def spmf_rel_map intro!: rel_spmf_reflI)

end

lemma exec_gpv_resource_of_oracle:
  "exec_gpv run_resource gpv (resource_of_oracle oracle s) = map_spmf (map_prod id (resource_of_oracle oracle)) (exec_gpv oracle gpv s)"
  by(subst spmf.map_id[symmetric], fold pmf.rel_eq)
    (rule pmf.map_transfer[THEN rel_funD, THEN rel_funD, rotated]
      , rule exec_gpv_parametric[where S="\<lambda>res s. res = resource_of_oracle oracle s" and CALL="(=)" and A="(=)", THEN rel_funD, THEN rel_funD, THEN rel_funD]
      , auto simp add: gpv.rel_eq rel_fun_def spmf_rel_map elim: option.rel_cases intro!: rel_spmf_reflI)

primcorec parallel_resource :: "('a, 'b) resource \<Rightarrow> ('c, 'd) resource \<Rightarrow> ('a + 'c, 'b + 'd) resource" where
  "run_resource (parallel_resource res1 res2) =
   (\<lambda>ac. case ac of Inl a \<Rightarrow> map_spmf (map_prod Inl (\<lambda>res1'. parallel_resource res1' res2)) (run_resource res1 a)
         | Inr c \<Rightarrow> map_spmf (map_prod Inr (\<lambda>res2'. parallel_resource res1 res2')) (run_resource res2 c))"

lemma parallel_resource_parametric [transfer_rule]: includes lifting_syntax shows
  "(rel_resource A B ===> rel_resource C D ===> rel_resource (rel_sum A C) (rel_sum B D))
   parallel_resource parallel_resource"
  unfolding parallel_resource_def by transfer_prover

text \<open>
  We cannot define the analogue of @{term plus_oracle} because we no longer have access to the state,
  so state sharing is not possible!  So we can only compose resources, but we cannot build one
  resource with several interfaces this way!
\<close>

lemma resource_of_parallel_oracle:
  "resource_of_oracle (parallel_oracle oracle1 oracle2) (s1, s2) =
   parallel_resource (resource_of_oracle oracle1 s1) (resource_of_oracle oracle2 s2)"
  by(coinduction arbitrary: s1 s2)
    (auto 4 3 simp add: rel_fun_def spmf_rel_map split: sum.split intro!: rel_spmf_reflI)

lemma parallel_resource_assoc: \<comment> \<open>There's still an ugly map operation in there to rebalance the interface trees, but well...\<close>
  "parallel_resource (parallel_resource res1 res2) res3 =
   map_resource rsuml lsumr (parallel_resource res1 (parallel_resource res2 res3))"
  by(coinduction arbitrary: res1 res2 res3)
    (auto 4 5 intro!: rel_funI rel_spmf_reflI simp add: spmf_rel_map split: sum.split)

lemma lossless_parallel_resource:
  assumes "lossless_resource \<I> res1" "lossless_resource \<I>' res2"
  shows "lossless_resource (\<I> \<oplus>\<^sub>\<I> \<I>') (parallel_resource res1 res2)"
  using assms
  by(coinduction arbitrary: res1 res2)(clarsimp; erule PlusE; simp; frule (1) lossless_resourceD; auto 4 3)

subsection \<open>Well-typing\<close>

coinductive WT_resource :: "('a, 'b) \<I> \<Rightarrow> ('a, 'b) resource \<Rightarrow> bool" ("_ /\<turnstile>res _ \<surd>" [100, 0] 99)
  for \<I> where
    WT_resourceI: "\<I> \<turnstile>res res \<surd>"
  if "\<And>q r res'. \<lbrakk> q \<in> outs_\<I> \<I>; (r, res') \<in> set_spmf (run_resource res q) \<rbrakk> \<Longrightarrow> r \<in> responses_\<I> \<I> q \<and> \<I> \<turnstile>res res' \<surd>"

lemma WT_resource_coinduct [consumes 1, case_names WT_resource, case_conclusion WT_resource response WT_resource, coinduct pred: WT_resource]:
  assumes "X res"
    and "\<And>res q r res'. \<lbrakk> X res; q \<in> outs_\<I> \<I>; (r, res') \<in> set_spmf (run_resource res q) \<rbrakk>
       \<Longrightarrow> r \<in> responses_\<I> \<I> q \<and> (X res' \<or> \<I> \<turnstile>res res' \<surd>)"
  shows "\<I> \<turnstile>res res \<surd>"
  using assms(1) by(rule WT_resource.coinduct)(blast dest: assms(2))

lemma WT_resourceD:
  assumes "\<I> \<turnstile>res res \<surd>" "q \<in> outs_\<I> \<I>" "(r, res') \<in> set_spmf (run_resource res q)"
  shows "r \<in> responses_\<I> \<I> q \<and> \<I> \<turnstile>res res' \<surd>"
  using assms by(auto elim: WT_resource.cases)

lemma WT_resource_of_oracle [simp]:
  assumes "\<And>s. \<I> \<turnstile>c oracle s \<surd>"
  shows "\<I> \<turnstile>res resource_of_oracle oracle s \<surd>"
  by(coinduction arbitrary: s)(auto dest: WT_calleeD[OF assms])

lemma WT_resource_bot [simp]: "bot \<turnstile>res res \<surd>"
  by(rule WT_resource.intros)auto

lemma WT_resource_full: "\<I>_full \<turnstile>res res \<surd>"
  by(coinduction arbitrary: res)(auto)

lemma (in callee_invariant_on) WT_resource_of_oracle:
  "I s \<Longrightarrow> \<I> \<turnstile>res resource_of_oracle callee s \<surd>"
  by(coinduction arbitrary: s)(auto dest: callee_invariant')

named_theorems WT_intro "Interface typing introduction rules"

lemmas [WT_intro] = WT_gpv_map_gpv' WT_gpv_map_gpv

lemma WT_parallel_resource [WT_intro]:
  assumes "\<I>1 \<turnstile>res res1 \<surd>"
    and "\<I>2 \<turnstile>res res2 \<surd>"
  shows "\<I>1 \<oplus>\<^sub>\<I> \<I>2 \<turnstile>res parallel_resource res1 res2 \<surd>"
  using assms
  by(coinduction arbitrary: res1 res2)(auto 4 4 intro!: imageI dest: WT_resourceD)

lemma callee_invariant_run_resource: "callee_invariant_on run_resource (\<lambda>res.  \<I> \<turnstile>res res \<surd>) \<I>"
  by(unfold_locales)(auto dest: WT_resourceD intro: WT_calleeI)

lemma callee_invariant_run_lossless_resource:
  "callee_invariant_on run_resource (\<lambda>res. lossless_resource \<I> res \<and> \<I> \<turnstile>res res \<surd>) \<I>"
  by(unfold_locales)(auto dest: WT_resourceD lossless_resourceD intro: WT_calleeI)

interpretation run_lossless_resource:
  callee_invariant_on run_resource "\<lambda>res. lossless_resource \<I> res \<and> \<I> \<turnstile>res res \<surd>" \<I> for \<I>
  by(rule callee_invariant_run_lossless_resource)

end


theory FL_Transition_System
imports
  Transition_System FS_Set
begin

section \<open>Nominal Transition Systems with Effects and \texorpdfstring{$F/L$}{F/L}-Bisimilarity\<close>

subsection \<open>Nominal transition systems with effects\<close>

text \<open>The paper defines an effect as a finitely supported function from states to states. It then
fixes an equivariant set~@{term \<F>} of effects. In our formalization, we avoid working with such a
(carrier) set, and instead introduce a type of (finitely supported) effects together with an
(equivariant) application operator for effects and states.

Equivariance (of the type of effects) is implicitly guaranteed (by the type of~@{const permute}).

\emph{First} represents the (finitely supported) set of effects that must be observed before
following a transition.\<close>

type_synonym 'eff first = "'eff fs_set"

text \<open>\emph{Later} is a function that represents how the set~$F$ (for \emph{first}) changes
depending on the action of a transition and the chosen effect.\<close>

type_synonym ('a,'eff) later = "'a \<times> 'eff first \<times> 'eff \<Rightarrow> 'eff first"

locale effect_nominal_ts = nominal_ts satisfies transition
  for satisfies :: "'state::fs \<Rightarrow> 'pred::fs \<Rightarrow> bool" (infix "\<turnstile>" 70)
  and transition :: "'state \<Rightarrow> ('act::bn,'state) residual \<Rightarrow> bool" (infix "\<rightarrow>" 70) +
  fixes effect_apply :: "'effect::fs \<Rightarrow> 'state \<Rightarrow> 'state" ("\<langle>_\<rangle>_" [0,101] 100)
    and L :: "('act,'effect) later"
  assumes effect_apply_eqvt: "eqvt effect_apply"  (* using [eqvt] here generates an error message *)
      and L_eqvt: "eqvt L"  \<comment> \<open>@{term L} is assumed to be equivariant.\<close>
                            (* using [eqvt] here generates an error message *)
begin

  lemma effect_apply_eqvt_aux [simp]: "p \<bullet> effect_apply = effect_apply"
  by (metis effect_apply_eqvt eqvt_def)

  lemma effect_apply_eqvt' [eqvt]: "p \<bullet> \<langle>f\<rangle>P = \<langle>p \<bullet> f\<rangle>(p \<bullet> P)"
  by simp

  lemma L_eqvt_aux [simp]: "p \<bullet> L = L"
  by (metis L_eqvt eqvt_def)

  lemma L_eqvt' [eqvt]: "p \<bullet> L (\<alpha>, P, f) = L (p \<bullet> \<alpha>, p \<bullet> P, p \<bullet> f)"
  by simp

end

subsection \<open>\texorpdfstring{$L$}{L}-bisimulations and \texorpdfstring{$F/L$}{F/L}-bisimilarity\<close>

context effect_nominal_ts
begin

  definition is_L_bisimulation:: "('effect first \<Rightarrow> 'state \<Rightarrow> 'state \<Rightarrow> bool) \<Rightarrow> bool" where
    "is_L_bisimulation R \<equiv>
      \<forall>F. symp (R F) \<and>
          (\<forall>P Q. R F P Q \<longrightarrow> (\<forall>f. f \<in>\<^sub>f\<^sub>s F \<longrightarrow> (\<forall>\<phi>. \<langle>f\<rangle>P \<turnstile> \<phi> \<longrightarrow> \<langle>f\<rangle>Q \<turnstile> \<phi>))) \<and>
          (\<forall>P Q. R F P Q \<longrightarrow> (\<forall>f. f \<in>\<^sub>f\<^sub>s F \<longrightarrow> (\<forall>\<alpha> P'. bn \<alpha> \<sharp>* (\<langle>f\<rangle>Q, F, f) \<longrightarrow>
                  \<langle>f\<rangle>P \<rightarrow> \<langle>\<alpha>,P'\<rangle> \<longrightarrow> (\<exists>Q'. \<langle>f\<rangle>Q \<rightarrow> \<langle>\<alpha>,Q'\<rangle> \<and> R (L (\<alpha>,F,f)) P' Q'))))"

  definition FL_bisimilar :: "'effect first \<Rightarrow> 'state \<Rightarrow> 'state \<Rightarrow> bool" where
    "FL_bisimilar F P Q \<equiv> \<exists>R. is_L_bisimulation R \<and> (R F) P Q"

  abbreviation FL_bisimilar' ("_ \<sim>\<cdot>[_] _" [51,0,51] 50) where
    "P \<sim>\<cdot>[F] Q \<equiv> FL_bisimilar F P Q"

  text \<open>@{term "FL_bisimilar"} is an equivariant relation, and (for every~@{term F}) an
    equivalence.\<close>

  lemma is_L_bisimulation_eqvt [eqvt]:
    assumes "is_L_bisimulation R" shows "is_L_bisimulation (p \<bullet> R)"
  unfolding is_L_bisimulation_def
  proof (clarify)
    fix F
    have "symp ((p \<bullet> R) F)" (is ?S)
      using assms unfolding is_L_bisimulation_def by (metis eqvt_lambda symp_eqvt)
    moreover have "\<forall>P Q. (p \<bullet> R) F P Q \<longrightarrow> (\<forall>f. f \<in>\<^sub>f\<^sub>s F \<longrightarrow> (\<forall>\<phi>. \<langle>f\<rangle>P \<turnstile> \<phi> \<longrightarrow> \<langle>f\<rangle>Q \<turnstile> \<phi>))" (is ?T)
      proof (clarify)
        fix P Q f \<phi>
        assume pR: "(p \<bullet> R) F P Q" and effect: "f \<in>\<^sub>f\<^sub>s F" and satisfies: "\<langle>f\<rangle>P \<turnstile> \<phi>"
        from pR have "R (-p \<bullet> F) (-p \<bullet> P) (-p \<bullet> Q)"
          by (simp add: eqvt_lambda permute_bool_def unpermute_def)
        moreover have "(-p \<bullet> f) \<in>\<^sub>f\<^sub>s (-p \<bullet> F)"
          using effect by simp
        moreover have "\<langle>-p \<bullet> f\<rangle>(-p \<bullet> P) \<turnstile> -p \<bullet> \<phi>"
          using satisfies by (metis effect_apply_eqvt' satisfies_eqvt)
        ultimately have "\<langle>-p \<bullet> f\<rangle>(-p \<bullet> Q) \<turnstile> -p \<bullet> \<phi>"
          using assms unfolding is_L_bisimulation_def by auto
        then show "\<langle>f\<rangle>Q \<turnstile> \<phi>"
          by (metis (full_types) effect_apply_eqvt' permute_minus_cancel(1) satisfies_eqvt)
      qed
    moreover have "\<forall>P Q. (p \<bullet> R) F P Q \<longrightarrow> (\<forall>f. f \<in>\<^sub>f\<^sub>s F \<longrightarrow> (\<forall>\<alpha> P'. bn \<alpha> \<sharp>* (\<langle>f\<rangle>Q, F, f) \<longrightarrow>
                                \<langle>f\<rangle>P \<rightarrow> \<langle>\<alpha>,P'\<rangle> \<longrightarrow> (\<exists>Q'. \<langle>f\<rangle>Q \<rightarrow> \<langle>\<alpha>,Q'\<rangle> \<and> (p \<bullet> R) (L (\<alpha>, F, f)) P' Q')))" (is ?U)
      proof (clarify)
        fix P Q f \<alpha> P'
        assume pR: "(p \<bullet> R) F P Q" and effect: "f \<in>\<^sub>f\<^sub>s F" and fresh: "bn \<alpha> \<sharp>* (\<langle>f\<rangle>Q, F, f)" and trans: "\<langle>f\<rangle>P \<rightarrow> \<langle>\<alpha>,P'\<rangle>"
        from pR have "R (-p \<bullet> F) (-p \<bullet> P) (-p \<bullet> Q)"
          by (simp add: eqvt_lambda permute_bool_def unpermute_def)
        moreover have "(-p \<bullet> f) \<in>\<^sub>f\<^sub>s (-p \<bullet> F)"
          using effect by simp
        moreover have "bn (-p \<bullet> \<alpha>) \<sharp>* (\<langle>-p \<bullet> f\<rangle>(-p \<bullet> Q), -p \<bullet> F, -p \<bullet> f)"
          using fresh by (metis (full_types) effect_apply_eqvt' bn_eqvt fresh_star_Pair fresh_star_permute_iff)
        moreover have "\<langle>-p \<bullet> f\<rangle>(-p \<bullet> P) \<rightarrow> \<langle>-p \<bullet> \<alpha>, -p \<bullet> P'\<rangle>"
          using trans by (metis effect_apply_eqvt' transition_eqvt')
        ultimately obtain Q' where T: "\<langle>-p \<bullet> f\<rangle>(-p \<bullet> Q) \<rightarrow> \<langle>-p \<bullet> \<alpha>,Q'\<rangle>" and R: "R (L (-p \<bullet> \<alpha>, -p \<bullet> F, -p \<bullet> f)) (-p \<bullet> P') Q'"
          using assms unfolding is_L_bisimulation_def by meson
        from T have "\<langle>f\<rangle>Q \<rightarrow> \<langle>\<alpha>, p \<bullet> Q'\<rangle>"
          by (metis (no_types, lifting) effect_apply_eqvt' abs_residual_pair_eqvt permute_minus_cancel(1) transition_eqvt)
        moreover from R have "(p \<bullet> R) (p \<bullet> L (-p \<bullet> \<alpha>, -p \<bullet> F, -p \<bullet> f)) (p \<bullet> -p \<bullet> P') (p \<bullet> Q')"
          by (metis permute_boolI permute_fun_def permute_minus_cancel(2))
        then have "(p \<bullet> R) (L (\<alpha>,F,f)) P' (p \<bullet> Q')"
          by (simp add: permute_self)
        ultimately show "\<exists>Q'. \<langle>f\<rangle>Q \<rightarrow> \<langle>\<alpha>,Q'\<rangle> \<and> (p \<bullet> R) (L (\<alpha>,F,f)) P' Q'"
          by metis
      qed
    ultimately show "?S \<and> ?T \<and> ?U" by simp
  qed

  lemma FL_bisimilar_eqvt:
    assumes "P \<sim>\<cdot>[F] Q" shows "(p \<bullet> P) \<sim>\<cdot>[p \<bullet> F] (p \<bullet> Q)"
  using assms
  by (metis eqvt_apply permute_boolI is_L_bisimulation_eqvt FL_bisimilar_def)

  lemma FL_bisimilar_reflp: "reflp (FL_bisimilar F)"
  proof (rule reflpI)
    fix x
    have "is_L_bisimulation (\<lambda>_. (=))"
      unfolding is_L_bisimulation_def by (simp add: symp_def)
    then show "x \<sim>\<cdot>[F] x"
      unfolding FL_bisimilar_def by auto
  qed

  lemma FL_bisimilar_symp: "symp (FL_bisimilar F)"
  proof (rule sympI)
    fix P Q
    assume "P \<sim>\<cdot>[F] Q"
    then obtain R where *: "is_L_bisimulation R \<and> R F P Q"
      unfolding FL_bisimilar_def ..
    then have "R F Q P"
      unfolding is_L_bisimulation_def by (simp add: symp_def)
    with "*" show "Q \<sim>\<cdot>[F] P"
      unfolding FL_bisimilar_def by auto
  qed

  lemma FL_bisimilar_is_L_bisimulation: "is_L_bisimulation FL_bisimilar"
  unfolding is_L_bisimulation_def proof
    fix F
    have "symp (FL_bisimilar F)" (is ?R)
      by (fact FL_bisimilar_symp)
    moreover have "\<forall>P Q. P \<sim>\<cdot>[F] Q \<longrightarrow> (\<forall>f. f \<in>\<^sub>f\<^sub>s F \<longrightarrow> (\<forall>\<phi>. \<langle>f\<rangle>P \<turnstile> \<phi> \<longrightarrow> \<langle>f\<rangle>Q \<turnstile> \<phi>))" (is ?S)
      by (auto simp add: is_L_bisimulation_def FL_bisimilar_def)
    moreover have "\<forall>P Q. P \<sim>\<cdot>[F] Q \<longrightarrow> (\<forall>f. f \<in>\<^sub>f\<^sub>s F \<longrightarrow> (\<forall>\<alpha> P'. bn \<alpha> \<sharp>* (\<langle>f\<rangle>Q, F, f) \<longrightarrow>
          \<langle>f\<rangle>P \<rightarrow> \<langle>\<alpha>,P'\<rangle> \<longrightarrow> (\<exists>Q'. \<langle>f\<rangle>Q \<rightarrow> \<langle>\<alpha>,Q'\<rangle> \<and> P' \<sim>\<cdot>[L (\<alpha>, F, f)] Q')))" (is ?T)
      by (auto simp add: is_L_bisimulation_def FL_bisimilar_def) blast
    ultimately show "?R \<and> ?S \<and> ?T"
      by metis
  qed

  lemma FL_bisimilar_simulation_step:
    assumes "P \<sim>\<cdot>[F] Q" and "f \<in>\<^sub>f\<^sub>s F" and "bn \<alpha> \<sharp>* (\<langle>f\<rangle>Q, F, f)" and "\<langle>f\<rangle>P \<rightarrow> \<langle>\<alpha>,P'\<rangle>"
    obtains Q' where "\<langle>f\<rangle>Q \<rightarrow> \<langle>\<alpha>,Q'\<rangle>" and "P' \<sim>\<cdot>[L (\<alpha>,F,f)] Q'"
  using assms by (metis (poly_guards_query) FL_bisimilar_is_L_bisimulation is_L_bisimulation_def)

  lemma FL_bisimilar_transp: "transp (FL_bisimilar F)"
  proof (rule transpI)
    fix P Q R
    assume PQ: "P \<sim>\<cdot>[F] Q" and QR: "Q \<sim>\<cdot>[F] R"
    let ?FL_bisim = "\<lambda>F. (FL_bisimilar F) OO (FL_bisimilar F)"
    have "\<And>F. symp (?FL_bisim F)"
      proof (rule sympI)
        fix F P R
        assume "?FL_bisim F P R"
        then obtain Q where "P \<sim>\<cdot>[F] Q" and "Q \<sim>\<cdot>[F] R"
          by blast
        then have "R \<sim>\<cdot>[F] Q" and "Q \<sim>\<cdot>[F] P"
          by (metis FL_bisimilar_symp sympE)+
        then show "?FL_bisim F R P"
          by blast
      qed
    moreover have "\<And>F. \<forall>P Q. ?FL_bisim F P Q \<longrightarrow> (\<forall>f. f \<in>\<^sub>f\<^sub>s F \<longrightarrow> (\<forall>\<phi>. \<langle>f\<rangle>P \<turnstile> \<phi> \<longrightarrow> \<langle>f\<rangle>Q \<turnstile> \<phi>))"
      using FL_bisimilar_is_L_bisimulation is_L_bisimulation_def by auto
    moreover have "\<And>F. \<forall>P Q. ?FL_bisim F P Q \<longrightarrow>
           (\<forall>f. f \<in>\<^sub>f\<^sub>s F \<longrightarrow> (\<forall>\<alpha> P'. bn \<alpha> \<sharp>* (\<langle>f\<rangle>Q, F, f) \<longrightarrow>
                     \<langle>f\<rangle>P \<rightarrow> \<langle>\<alpha>,P'\<rangle> \<longrightarrow> (\<exists>Q'. \<langle>f\<rangle>Q \<rightarrow> \<langle>\<alpha>,Q'\<rangle> \<and> ?FL_bisim (L (\<alpha>,F,f)) P' Q')))"
      proof (clarify)
        fix F P R Q f \<alpha> P'
        assume PR: "P \<sim>\<cdot>[F] R" and RQ: "R \<sim>\<cdot>[F] Q" and effect: "f \<in>\<^sub>f\<^sub>s F" and fresh: "bn \<alpha> \<sharp>* (\<langle>f\<rangle>Q, F, f)" and trans: "\<langle>f\<rangle>P \<rightarrow> \<langle>\<alpha>,P'\<rangle>"
        \<comment> \<open>rename~@{term "\<langle>\<alpha>,P'\<rangle>"} to avoid~@{term "(\<langle>f\<rangle>R, F)"}, without touching~@{term "(\<langle>f\<rangle>Q, F, f)"}\<close>
        obtain p where 1: "(p \<bullet> bn \<alpha>) \<sharp>* (\<langle>f\<rangle>R, F, f)" and 2: "supp (\<langle>\<alpha>,P'\<rangle>, (\<langle>f\<rangle>Q, F, f)) \<sharp>* p"
          proof (rule at_set_avoiding2[of "bn \<alpha>" "(\<langle>f\<rangle>R, F, f)" "(\<langle>\<alpha>,P'\<rangle>, (\<langle>f\<rangle>Q, F, f))", THEN exE])
            show "finite (bn \<alpha>)" by (fact bn_finite)
          next
            show "finite (supp (\<langle>f\<rangle>R, F, f))" by (fact finite_supp)
          next
            show "finite (supp (\<langle>\<alpha>,P'\<rangle>, (\<langle>f\<rangle>Q, F, f)))" by (simp add: finite_supp supp_Pair)
          next
            show "bn \<alpha> \<sharp>* (\<langle>\<alpha>,P'\<rangle>, (\<langle>f\<rangle>Q, F, f))"
              using bn_abs_residual_fresh fresh fresh_star_Pair by blast
          qed metis
        from 2 have 3: "supp \<langle>\<alpha>,P'\<rangle> \<sharp>* p" and 4: "supp (\<langle>f\<rangle>Q, F, f) \<sharp>* p"
          by (simp add: fresh_star_Un supp_Pair)+
        from 3 have "\<langle>p \<bullet> \<alpha>, p \<bullet> P'\<rangle> = \<langle>\<alpha>,P'\<rangle>"
          using supp_perm_eq by fastforce
        then obtain pR' where 5: "\<langle>f\<rangle>R \<rightarrow> \<langle>p \<bullet> \<alpha>, pR'\<rangle>" and 6: "(p \<bullet> P') \<sim>\<cdot>[L (p \<bullet> \<alpha>,F,f)] pR'"
          using PR effect trans 1 by (metis FL_bisimilar_simulation_step bn_eqvt)
        from fresh and 4 have "bn (p \<bullet> \<alpha>) \<sharp>* (\<langle>f\<rangle>Q, F, f)"
          by (metis bn_eqvt fresh_star_permute_iff supp_perm_eq)
        then obtain pQ' where 7: "\<langle>f\<rangle>Q \<rightarrow> \<langle>p \<bullet> \<alpha>, pQ'\<rangle>" and 8: "pR' \<sim>\<cdot>[L (p \<bullet> \<alpha>,F,f)] pQ'"
          using RQ effect 5 by (metis FL_bisimilar_simulation_step)
        from 4 have "supp (\<langle>f\<rangle>Q) \<sharp>* p"
          by (simp add: fresh_star_Un supp_Pair)
        with 7 have "\<langle>f\<rangle>Q \<rightarrow> \<langle>\<alpha>, -p \<bullet> pQ'\<rangle>"
          by (metis permute_minus_cancel(2) supp_perm_eq transition_eqvt')
        moreover from 6 and 8 have "?FL_bisim (L (p \<bullet> \<alpha>, F, f)) (p \<bullet> P') pQ'"
          by (metis relcompp.relcompI)
        then have "?FL_bisim (-p \<bullet> L (p \<bullet> \<alpha>, F, f)) (-p \<bullet> p \<bullet> P') (-p \<bullet> pQ')"
          using FL_bisimilar_eqvt by blast
        then have "?FL_bisim (L (\<alpha>, -p \<bullet> F, -p \<bullet> f)) P' (-p \<bullet> pQ')"
          by (simp add: L_eqvt')
        then have "?FL_bisim (L (\<alpha>,F,f)) P' (-p \<bullet> pQ')"
          using 4 by (metis fresh_star_Un permute_minus_cancel(2) supp_Pair supp_perm_eq)
        ultimately show "\<exists>Q'. \<langle>f\<rangle>Q \<rightarrow> \<langle>\<alpha>,Q'\<rangle> \<and> ?FL_bisim (L (\<alpha>,F,f)) P' Q'"
          by metis
      qed
    ultimately have "is_L_bisimulation ?FL_bisim"
      unfolding is_L_bisimulation_def by metis
    moreover have "?FL_bisim F P R"
      using PQ QR by blast
    ultimately show "P \<sim>\<cdot>[F] R"
      unfolding FL_bisimilar_def by meson
  qed

  lemma FL_bisimilar_equivp: "equivp (FL_bisimilar F)"
  by (metis FL_bisimilar_reflp FL_bisimilar_symp FL_bisimilar_transp equivp_reflp_symp_transp)

end

end


(*  Author:  Sébastien Gouëzel   sebastien.gouezel@univ-rennes1.fr
    License: BSD
*)

theory Boundary_Extension
  imports Morse_Gromov_Theorem Gromov_Boundary
begin

section \<open>Extension of quasi-isometries to the boundary\<close>

text \<open>In this section, we show that a quasi-isometry between geodesic Gromov hyperbolic spaces
extends to a homeomorphism between their boundaries.\<close>

text \<open>Applying a quasi-isometry on a geodesic triangle essentially sends it to a geodesic triangle,
in hyperbolic spaces. It follows that, up to an additive constant, the Gromov product, which is the
distance to the center of the triangle, is multiplied by a constant between $\lambda^{-1}$ and
$\lambda$ when one applies a quasi-isometry. This argument is given in the next lemma. This implies
that two points are close in the Gromov completion if and only if their images are also close in the
Gromov completion of the image. Essentially, this lemma implies that a quasi-isometry has a
continuous extension to the Gromov boundary, which is a homeomorphism.\<close>

lemma Gromov_product_at_quasi_isometry:
  fixes f::"'a::Gromov_hyperbolic_space_geodesic \<Rightarrow> 'b::Gromov_hyperbolic_space_geodesic"
  assumes "lambda C-quasi_isometry f"
  shows "Gromov_product_at (f x) (f y) (f z) \<ge> Gromov_product_at x y z / lambda - 187 * lambda^2 * (C + deltaG(TYPE('a)) + deltaG(TYPE('b)))"
        "Gromov_product_at (f x) (f y) (f z) \<le> lambda * Gromov_product_at x y z + 187 * lambda^2 * (C + deltaG(TYPE('a)) + deltaG(TYPE('b)))"
proof -
  have "lambda \<ge> 1" "C \<ge> 0" using quasi_isometry_onD[OF assms(1)] by auto
  define D where "D = 92 * lambda^2 * (C + deltaG(TYPE('b)))"
  have Dxy: "hausdorff_distance (f`{x--y}) {f x--f y} \<le> D"
    unfolding D_def apply (rule geodesic_quasi_isometric_image[OF assms(1)]) by auto
  have Dyz: "hausdorff_distance (f`{y--z}) {f y--f z} \<le> D"
    unfolding D_def apply (rule geodesic_quasi_isometric_image[OF assms(1)]) by auto
  have Dxz: "hausdorff_distance (f`{x--z}) {f x--f z} \<le> D"
    unfolding D_def apply (rule geodesic_quasi_isometric_image[OF assms(1)]) by auto

  define E where "E = (lambda * (4 * deltaG(TYPE('a))) + C) + D"
  have "E \<ge> 0" unfolding E_def D_def using \<open>lambda \<ge> 1\<close> \<open>C \<ge> 0\<close> by auto
  obtain w where w: "infdist w {x--y} \<le> 4 * deltaG(TYPE('a))"
                    "infdist w {x--z} \<le> 4 * deltaG(TYPE('a))"
                    "infdist w {y--z} \<le> 4 * deltaG(TYPE('a))"
                    "dist w x = Gromov_product_at x y z"
    using slim_triangle[of "{x--y}" x y "{x--z}" z "{y--z}"] by auto
  have "infdist (f w) {f x--f y} \<le> infdist (f w) (f`{x--y}) + hausdorff_distance (f`{x--y}) {f x--f y}"
    by (intro mono_intros quasi_isometry_on_bounded[OF quasi_isometry_on_subset[OF assms(1)], of "{x--y}"], auto)
  also have "... \<le> (lambda * infdist w {x--y} + C) + D"
    apply (intro mono_intros) using quasi_isometry_on_infdist[OF assms(1)] Dxy by auto
  also have "... \<le> (lambda * (4 * deltaG(TYPE('a))) + C) + D"
    apply (intro mono_intros) using w \<open>lambda \<ge> 1\<close> by auto
  finally have Exy: "infdist (f w) {f x--f y} \<le> E" unfolding E_def by auto

  have "infdist (f w) {f y--f z} \<le> infdist (f w) (f`{y--z}) + hausdorff_distance (f`{y--z}) {f y--f z}"
    by (intro mono_intros quasi_isometry_on_bounded[OF quasi_isometry_on_subset[OF assms(1)], of "{y--z}"], auto)
  also have "... \<le> (lambda * infdist w {y--z} + C) + D"
    apply (intro mono_intros) using quasi_isometry_on_infdist[OF assms(1)] Dyz by auto
  also have "... \<le> (lambda * (4 * deltaG(TYPE('a))) + C) + D"
    apply (intro mono_intros) using w \<open>lambda \<ge> 1\<close> by auto
  finally have Eyz: "infdist (f w) {f y--f z} \<le> E" unfolding E_def by auto

  have "infdist (f w) {f x--f z} \<le> infdist (f w) (f`{x--z}) + hausdorff_distance (f`{x--z}) {f x--f z}"
    by (intro mono_intros quasi_isometry_on_bounded[OF quasi_isometry_on_subset[OF assms(1)], of "{x--z}"], auto)
  also have "... \<le> (lambda * infdist w {x--z} + C) + D"
    apply (intro mono_intros) using quasi_isometry_on_infdist[OF assms(1)] Dxz by auto
  also have "... \<le> (lambda * (4 * deltaG(TYPE('a))) + C) + D"
    apply (intro mono_intros) using w \<open>lambda \<ge> 1\<close> by auto
  finally have Exz: "infdist (f w) {f x--f z} \<le> E" unfolding E_def by auto

  have "2 * ((1/lambda * dist w x - C)) \<le> 2 * dist (f w) (f x)"
    using quasi_isometry_onD(2)[OF assms(1), of w x] by auto
  also have "... = (dist (f w) (f x) + dist (f w) (f y)) + (dist (f w) (f x) + dist (f w) (f z)) - (dist (f w) (f y) + dist (f w) (f z))"
    by auto
  also have "... \<le> (dist (f x) (f y) + 2 * infdist (f w) {f x--f y}) + (dist (f x) (f z) + 2 * infdist (f w) {f x--f z}) - dist (f y) (f z)"
    by (intro geodesic_segment_distance mono_intros, auto)
  also have "... \<le> 2 * Gromov_product_at (f x) (f y) (f z) + 4 * E"
    unfolding Gromov_product_at_def using Exy Exz by (auto simp add: algebra_simps divide_simps)
  finally have *: "Gromov_product_at x y z / lambda - C - 2 * E \<le> Gromov_product_at (f x) (f y) (f z)"
    unfolding w(4) by simp

  have "2 * Gromov_product_at (f x) (f y) (f z) - 2 * E \<le> 2 * Gromov_product_at (f x) (f y) (f z) - 2 * infdist (f w) {f y--f z}"
    using Eyz by auto
  also have "... = dist (f x) (f y) + dist (f x) (f z) - (dist (f y) (f z) + 2 * infdist (f w) {f y--f z})"
    unfolding Gromov_product_at_def by (auto simp add: algebra_simps divide_simps)
  also have "... \<le> (dist (f w) (f x) + dist (f w) (f y)) + (dist (f w) (f x) + dist (f w) (f z)) - (dist (f w) (f y) + dist (f w) (f z))"
    by (intro geodesic_segment_distance mono_intros, auto)
  also have "... = 2 * dist (f w) (f x)"
    by auto
  also have "... \<le> 2 * (lambda * dist w x + C)"
    using quasi_isometry_onD(1)[OF assms(1), of w x] by auto
  finally have "Gromov_product_at (f x) (f y) (f z) \<le> lambda * dist w x + C + E"
    by auto
  then have **: "Gromov_product_at (f x) (f y) (f z) \<le> lambda * Gromov_product_at x y z + C + 2 * E"
    unfolding w(4) using \<open>E \<ge> 0\<close> by auto

  have "C + 2 * E = 3 * 1 * C + 8 * lambda * deltaG(TYPE('a)) + 184 * lambda^2 * C + 184 * lambda^2 * deltaG(TYPE('b))"
    unfolding E_def D_def by (auto simp add: algebra_simps)
  also have "... \<le> 3 * lambda^2 * C + 187 * lambda^2 * deltaG(TYPE('a)) + 184 * lambda^2 * C + 187 * lambda^2 * deltaG(TYPE('b))"
    apply (intro mono_intros) using \<open>lambda \<ge> 1\<close> \<open>C \<ge> 0\<close> by auto
  finally have I: "C + 2 * E \<le> 187 * lambda^2 * (C + deltaG(TYPE('a)) + deltaG(TYPE('b)))"
    by (auto simp add: algebra_simps)

  show "Gromov_product_at (f x) (f y) (f z) \<ge> Gromov_product_at x y z / lambda - 187 * lambda^2 * (C + deltaG(TYPE('a)) + deltaG(TYPE('b)))"
    using * I by auto
  show "Gromov_product_at (f x) (f y) (f z) \<le> lambda * Gromov_product_at x y z + 187 * lambda^2 * (C + deltaG(TYPE('a)) + deltaG(TYPE('b)))"
    using ** I by auto
qed

lemma Gromov_converging_at_infinity_quasi_isometry:
  fixes f::"'a::Gromov_hyperbolic_space_geodesic \<Rightarrow> 'b::Gromov_hyperbolic_space_geodesic"
  assumes "lambda C-quasi_isometry f"
  shows "Gromov_converging_at_boundary (\<lambda>n. f (u n)) \<longleftrightarrow> Gromov_converging_at_boundary u"
proof
  assume "Gromov_converging_at_boundary u"
  show "Gromov_converging_at_boundary (\<lambda>n. f (u n))"
  proof (rule Gromov_converging_at_boundaryI[of "f (basepoint)"])
    have "lambda \<ge> 1" "C \<ge> 0" using quasi_isometry_onD[OF assms(1)] by auto
    define D where "D = 187 * lambda^2 * (C + deltaG(TYPE('a)) + deltaG(TYPE('b)))"
    fix M::real
    obtain M2::real where M2: "M = M2/lambda - D"
      using \<open>lambda \<ge> 1\<close> by (auto simp add: algebra_simps divide_simps)
    obtain N where N: "\<And>m n. m \<ge> N \<Longrightarrow> n \<ge> N \<Longrightarrow> Gromov_product_at basepoint (u m) (u n) \<ge> M2"
      using \<open>Gromov_converging_at_boundary u\<close> unfolding Gromov_converging_at_boundary_def by blast
    have "Gromov_product_at (f basepoint) (f (u m)) (f (u n)) \<ge> M" if "m \<ge> N" "n \<ge> N" for m n
    proof -
      have "M \<le> Gromov_product_at basepoint (u m) (u n)/lambda - D"
        unfolding M2 using N[OF that] \<open>lambda \<ge> 1\<close> by (auto simp add: divide_simps)
      also have "... \<le> Gromov_product_at (f basepoint) (f (u m)) (f (u n))"
        unfolding D_def by (rule Gromov_product_at_quasi_isometry[OF assms(1)])
      finally show ?thesis by simp
    qed
    then show "\<exists>N. \<forall>n \<ge> N. \<forall>m \<ge> N. M \<le> Gromov_product_at (f basepoint) (f (u m)) (f (u n))"
      unfolding comp_def by auto
  qed
next
  assume "Gromov_converging_at_boundary (\<lambda>n. f (u n))"
  show "Gromov_converging_at_boundary u"
  proof (rule Gromov_converging_at_boundaryI[of "basepoint"])
    have "lambda \<ge> 1" "C \<ge> 0" using quasi_isometry_onD[OF assms(1)] by auto
    define D where "D = 187 * lambda^2 * (C + deltaG(TYPE('a)) + deltaG(TYPE('b)))"
    fix M::real
    define M2 where "M2 = lambda * M + D"
    have M2: "M = (M2 - D)/lambda" unfolding M2_def using \<open>lambda \<ge> 1\<close> by (auto simp add: algebra_simps divide_simps)
    obtain N where N: "\<And>m n. m \<ge> N \<Longrightarrow> n \<ge> N \<Longrightarrow> Gromov_product_at (f basepoint) (f (u m)) (f (u n)) \<ge> M2"
      using \<open>Gromov_converging_at_boundary (\<lambda>n. f (u n))\<close> unfolding Gromov_converging_at_boundary_def by blast
    have "Gromov_product_at basepoint (u m) (u n) \<ge> M" if "m \<ge> N" "n \<ge> N" for m n
    proof -
      have "M2 \<le> Gromov_product_at (f basepoint) (f (u m)) (f (u n))"
        using N[OF that] by auto
      also have "... \<le> lambda * Gromov_product_at basepoint (u m) (u n) + D"
        unfolding D_def by (rule Gromov_product_at_quasi_isometry[OF assms(1)])
      finally show "M \<le> Gromov_product_at basepoint (u m) (u n)"
        unfolding M2 using \<open>lambda \<ge> 1\<close> by (auto simp add: algebra_simps divide_simps)
    qed
    then show "\<exists>N. \<forall>n \<ge> N. \<forall>m \<ge> N. Gromov_product_at basepoint (u m) (u n) \<ge> M"
      by auto
  qed
qed

text \<open>We define the extension to the completion of a function $f: X \to Y$ where $X$ and $Y$
are geodesic Gromov-hyperbolic spaces, as a function from $X \cup \partial X$ to $Y\cup \partial Y$,
as follows. If $x$ is in the space, we just use $f(x)$ (with the suitable coercions for the
definition). Otherwise, we wish to define $f(x)$ as the limit of $f(u_n)$ for all sequences tending
to $x$. For the definition, we use one such sequence chosen arbitrarily (this is the role of
\verb+rep_Gromov_completion x+ below, it is indeed a sequence in the space tending to $x$), and
we use the limit of $f(u_n)$ (if it exists, otherwise the framework will choose some point for us
but it will make no sense whatsoever).

For quasi-isometries, we have indeed that $f(u_n)$ converges if $u_n$ converges to a boundary point,
by \verb+Gromov_converging_at_infinity_quasi_isometry+, so this definition is meaningful. Moreover,
continuity of the extension follows readily from this (modulo a suitable criterion for continuity
based on sequences convergence, established in \verb+continuous_at_extension_sequentially'+).\<close>

definition Gromov_extension::"('a::Gromov_hyperbolic_space \<Rightarrow> 'b::Gromov_hyperbolic_space) \<Rightarrow> ('a Gromov_completion \<Rightarrow> 'b Gromov_completion)"
  where "Gromov_extension f x = (if x \<in> Gromov_boundary then lim (to_Gromov_completion o f o (rep_Gromov_completion x))
                                 else to_Gromov_completion (f (from_Gromov_completion x)))"

lemma Gromov_extension_inside_space [simp]:
  "Gromov_extension f (to_Gromov_completion x) = to_Gromov_completion (f x)"
unfolding Gromov_extension_def by auto

lemma Gromov_extension_id [simp]:
  "Gromov_extension (id::'a::Gromov_hyperbolic_space \<Rightarrow> 'a) = id"
  "Gromov_extension (\<lambda>x::'a. x) = (\<lambda>x. x)"
proof -
  have "Gromov_extension id x = id x" for x::"'a Gromov_completion"
    unfolding Gromov_extension_def comp_def
    using limI rep_Gromov_completion_limit by (auto simp add: to_from_Gromov_completion)
  then show "Gromov_extension (id::'a \<Rightarrow> 'a) = id"
    by auto
  then show "Gromov_extension (\<lambda>x::'a. x) = (\<lambda>x. x)"
    unfolding id_def by auto
qed

text \<open>The Gromov extension of a quasi-isometric map sends the boundary to the boundary.\<close>

lemma Gromov_extension_quasi_isometry_boundary_to_boundary:
  fixes f::"'a::Gromov_hyperbolic_space_geodesic \<Rightarrow> 'b::Gromov_hyperbolic_space_geodesic"
  assumes "lambda C-quasi_isometry f"
          "x \<in> Gromov_boundary"
  shows "(Gromov_extension f) x \<in> Gromov_boundary"
proof -
  have *: "Gromov_converging_at_boundary (\<lambda>n. f (rep_Gromov_completion x n))"
    by (simp add: Gromov_converging_at_infinity_quasi_isometry[OF assms(1)] Gromov_boundary_rep_converging assms(2))
  show ?thesis
    unfolding Gromov_extension_def using assms(2) unfolding comp_def apply auto
    by (metis Gromov_converging_at_boundary_converges * limI)
qed

text \<open>If the original function is continuous somewhere inside the space, then its Gromov extension
is continuous at the corresponding point inside the completion. This is clear as the original space
is open in the Gromov completion, but the proof requires to go back and forth between one space
and the other.\<close>

lemma Gromov_extension_continuous_inside:
  fixes f::"'a::Gromov_hyperbolic_space \<Rightarrow> 'b::Gromov_hyperbolic_space"
  assumes "continuous (at x within S) f"
  shows "continuous (at (to_Gromov_completion x) within (to_Gromov_completion`S)) (Gromov_extension f)"
proof -
  have *: "continuous (at (to_Gromov_completion x) within (to_Gromov_completion`S)) (to_Gromov_completion o f o from_Gromov_completion)"
    apply (intro continuous_within_compose, auto)
    using from_Gromov_completion_continuous(3) continuous_at_imp_continuous_within apply blast
    using assms apply (simp add: continuous_within_topological)
    using continuous_at_imp_continuous_within continuous_on_eq_continuous_within to_Gromov_completion_continuous by blast
  have "(to_Gromov_completion o f o from_Gromov_completion) y = Gromov_extension f y"
    if "y \<in> range to_Gromov_completion" for y
    unfolding comp_def using that by auto
  moreover have "eventually (\<lambda>y. y \<in> range to_Gromov_completion) (at (to_Gromov_completion x) within (to_Gromov_completion`S))"
    using to_Gromov_completion_range_open eventually_at_topological by blast
  ultimately have **: "eventually (\<lambda>y. (to_Gromov_completion o f o from_Gromov_completion) y = Gromov_extension f y)
                        (at (to_Gromov_completion x) within (to_Gromov_completion`S))"
    by (rule eventually_mono[rotated])
  show ?thesis
    by (rule continuous_within_cong[OF * **], auto)
qed

text \<open>The extension to the boundary of a quasi-isometry is continuous. This is a nontrivial
statement, but it follows readily from the fact we have already proved that sequences converging
at the boundary are mapped to sequences converging to the boundary. The proof is expressed using
a convenient continuity criterion for which we only need to control what happens for sequences
inside the space.\<close>

proposition Gromov_extension_continuous:
  fixes f::"'a::Gromov_hyperbolic_space_geodesic \<Rightarrow> 'b::Gromov_hyperbolic_space_geodesic"
  assumes "lambda C-quasi_isometry f"
          "x \<in> Gromov_boundary"
  shows "continuous (at x) (Gromov_extension f)"
proof -
  have "continuous (at x within (range to_Gromov_completion \<union> Gromov_boundary)) (Gromov_extension f)"
  proof (rule continuous_at_extension_sequentially'[OF \<open>x \<in> Gromov_boundary\<close>])
    fix b::"'a Gromov_completion" assume "b \<in> Gromov_boundary"
    show "\<exists>u. (\<forall>n. u n \<in> range to_Gromov_completion) \<and> u \<longlonglongrightarrow> b \<and> (\<lambda>n. Gromov_extension f (u n)) \<longlonglongrightarrow> Gromov_extension f b"
      apply (rule exI[of _ "to_Gromov_completion o (rep_Gromov_completion b)"], auto simp add: comp_def)
      unfolding Gromov_completion_converge_to_boundary[OF \<open>b \<in> Gromov_boundary\<close>]
      using Quotient3_abs_rep[OF Quotient3_Gromov_completion] Quotient3_rep_reflp[OF Quotient3_Gromov_completion] apply auto[1]
      unfolding Gromov_extension_def using \<open>b \<in> Gromov_boundary\<close> unfolding comp_def
      by (auto simp add: convergent_LIMSEQ_iff[symmetric] Gromov_boundary_rep_converging Gromov_converging_at_infinity_quasi_isometry[OF assms(1)]
               intro!: Gromov_converging_at_boundary_converges')
  next
    fix u and b::"'a Gromov_completion"
    assume u: "\<forall>n. u n \<in> range to_Gromov_completion" "b \<in> Gromov_boundary" "u \<longlonglongrightarrow> b"
    define v where "v = (\<lambda>n. from_Gromov_completion (u n))"
    have v: "u n = to_Gromov_completion (v n)" for n
      using u(1) unfolding v_def by (simp add: f_inv_into_f from_Gromov_completion_def)

    show "convergent (\<lambda>n. Gromov_extension f (u n))"
      using u unfolding v
      apply (auto intro!: Gromov_converging_at_boundary_converges' simp add: Gromov_converging_at_infinity_quasi_isometry[OF assms(1)])
      using Gromov_boundary_abs_converging Gromov_completion_converge_to_boundary by blast
  qed
  then show ?thesis by (simp add: Gromov_boundary_def)
qed

text \<open>Combining the two previous statements on continuity inside the space and continuity at the
boundary, we deduce that a continuous quasi-isometry extends to a continuous map everywhere.\<close>

proposition Gromov_extension_continuous_everywhere:
  fixes f::"'a::Gromov_hyperbolic_space_geodesic \<Rightarrow> 'b::Gromov_hyperbolic_space_geodesic"
  assumes "lambda C-quasi_isometry f"
          "continuous_on UNIV f"
  shows "continuous_on UNIV (Gromov_extension f)"
using Gromov_extension_continuous_inside Gromov_extension_continuous[OF assms(1)]
by (metis UNIV_I assms(2) continuous_on_eq_continuous_within continuous_within_open not_in_Gromov_boundary rangeI to_Gromov_completion_range_open)

text \<open>The extension to the boundary is functorial on the category of quasi-isometries, i.e., the
composition of extensions is the extension of the composition. This is clear inside the space, and
it follows from the continuity at boundary points.\<close>

lemma Gromov_extension_composition:
  fixes f::"'a::Gromov_hyperbolic_space_geodesic \<Rightarrow> 'b::Gromov_hyperbolic_space_geodesic"
    and g::"'b::Gromov_hyperbolic_space_geodesic \<Rightarrow> 'c::Gromov_hyperbolic_space_geodesic"
  assumes "lambda C-quasi_isometry f"
          "mu D-quasi_isometry g"
  shows "Gromov_extension (g o f) = Gromov_extension g o Gromov_extension f"
proof -
  have In: "Gromov_extension (g o f) x = (Gromov_extension g o Gromov_extension f) x" if H: "x \<in> range to_Gromov_completion" for x
  proof -
    obtain y where *: "x = to_Gromov_completion y"
      using H by auto
    show ?thesis
      unfolding * comp_def by auto
  qed
  moreover have "Gromov_extension (g o f) x = (Gromov_extension g o Gromov_extension f) x" if H: "x \<in> Gromov_boundary" for x
  proof -
    obtain u where u: "\<And>n. u n \<in> range to_Gromov_completion" "u \<longlonglongrightarrow> x"
      using closure_sequential to_Gromov_completion_range_dense by blast
    have "(\<lambda>n. Gromov_extension (g o f) (u n)) \<longlonglongrightarrow> Gromov_extension (g o f) x"
      using continuous_within_tendsto_compose[OF Gromov_extension_continuous[OF quasi_isometry_on_compose[OF assms(1) assms(2), simplified] H] _ u(2)] by simp
    then have A: "(\<lambda>n. (Gromov_extension g) ((Gromov_extension f) (u n))) \<longlonglongrightarrow> Gromov_extension (g o f) x"
      unfolding In[OF u(1)] unfolding comp_def by auto

    have *: "(\<lambda>n. (Gromov_extension f) (u n)) \<longlonglongrightarrow> (Gromov_extension f) x"
      using continuous_within_tendsto_compose[OF Gromov_extension_continuous[OF assms(1) H] _ u(2)] by simp
    have "(\<lambda>n. (Gromov_extension g) ((Gromov_extension f) (u n))) \<longlonglongrightarrow> Gromov_extension g ((Gromov_extension f) x)"
      using continuous_within_tendsto_compose[OF Gromov_extension_continuous[OF assms(2)] _ *]
      H Gromov_extension_quasi_isometry_boundary_to_boundary assms(1) by auto
    then show ?thesis using LIMSEQ_unique A comp_def by auto
  qed
  ultimately have "Gromov_extension (g o f) x = (Gromov_extension g o Gromov_extension f) x" for x
    using not_in_Gromov_boundary by force
  then show ?thesis by auto
qed

text \<open>Now, we turn to the same kind of statement, but for homeomorphisms. We claim that if a
quasi-isometry $f$ is a homeomorphism on a subset $X$ of the space, then its extension is a
homeomorphism on $X$ union the boundary of the space.
For the proof, we have to show that a sequence $u_n$ tends to a point $x$
if and only if $f(u_n)$ tends to $f(x)$. We separate the cases $x$ in the boundary, and $x$ inside
the space. For $x$ in the boundary, we use a homeomorphism criterion expressed solely in terms
of sequences converging to the boundary, for which we already know everything.
For $x$ in the space, the proof is straightforward, but tedious.
We argue that eventually $u_n$ is in the space for the direct implication, or $f(u_n)$ is in the
space for the second implication, and then we use that $f$ is a homeomorphism inside the space to
conclude.\<close>

lemma Gromov_extension_homeomorphism:
  fixes f::"'a::Gromov_hyperbolic_space_geodesic \<Rightarrow> 'b::Gromov_hyperbolic_space_geodesic"
  assumes "lambda C-quasi_isometry f"
          "homeomorphism_on X f"
  shows "homeomorphism_on (to_Gromov_completion`X \<union> Gromov_boundary) (Gromov_extension f)"
proof (rule homeomorphism_on_sequentially)
  fix x u assume H0: "x \<in> to_Gromov_completion ` X \<union> Gromov_boundary"
                    "\<forall>n::nat. u n \<in> to_Gromov_completion ` X \<union> Gromov_boundary"
  then consider "x \<in> Gromov_boundary" | "x \<in> to_Gromov_completion`X" by auto
  then show "u \<longlonglongrightarrow> x = (\<lambda>n. Gromov_extension f (u n)) \<longlonglongrightarrow> Gromov_extension f x"
  proof (cases)
    text \<open>First, consider the case where the limit point $x$ is in the boundary. We use a good
    criterion expressing everything in terms of sequences inside the space.\<close>
    case 1
    show ?thesis
    proof (rule homeomorphism_on_extension_sequentially_precise[of "range to_Gromov_completion" Gromov_boundary])
      show "x \<in> Gromov_boundary" by fact
      fix n::nat show "u n \<in> range to_Gromov_completion \<union> Gromov_boundary"
        unfolding Gromov_boundary_def by auto
    next
      fix u and b::"'a Gromov_completion"
      assume u: "\<forall>n. u n \<in> range to_Gromov_completion" "b \<in> Gromov_boundary" "u \<longlonglongrightarrow> b"
      define v where "v = (\<lambda>n. from_Gromov_completion (u n))"
      have v: "u n = to_Gromov_completion (v n)" for n
        using u(1) unfolding v_def by (simp add: f_inv_into_f from_Gromov_completion_def)
      show "convergent (\<lambda>n. Gromov_extension f (u n))"
        using u unfolding v apply auto
        apply (rule Gromov_converging_at_boundary_converges')
        by (auto simp add: Gromov_converging_at_infinity_quasi_isometry[OF assms(1)] lim_imp_Gromov_converging_at_boundary)
    next
      fix u c
      assume u: "\<forall>n. u n \<in> range to_Gromov_completion" "c \<in> Gromov_extension f ` Gromov_boundary" "(\<lambda>n. Gromov_extension f (u n)) \<longlonglongrightarrow> c"
      then have "c \<in> Gromov_boundary" using Gromov_extension_quasi_isometry_boundary_to_boundary[OF assms(1)] by auto
      define v where "v = (\<lambda>n. from_Gromov_completion (u n))"
      have v: "u n = to_Gromov_completion (v n)" for n
        using u(1) unfolding v_def by (simp add: f_inv_into_f from_Gromov_completion_def)
      have "Gromov_converging_at_boundary (\<lambda>n. f (v n))"
        apply (rule lim_imp_Gromov_converging_at_boundary[OF _ \<open>c \<in> Gromov_boundary\<close>])
        using u(3) unfolding v by auto
      then show "convergent u"
        using u unfolding v
        by (auto intro!: Gromov_converging_at_boundary_converges' simp add: Gromov_converging_at_infinity_quasi_isometry[OF assms(1), symmetric])
    next
      fix b::"'a Gromov_completion" assume "b \<in> Gromov_boundary"
      show "\<exists>u. (\<forall>n. u n \<in> range to_Gromov_completion) \<and> u \<longlonglongrightarrow> b \<and> (\<lambda>n. Gromov_extension f (u n)) \<longlonglongrightarrow> Gromov_extension f b"
        apply (rule exI[of _ "to_Gromov_completion o (rep_Gromov_completion b)"], auto simp add: comp_def)
        unfolding Gromov_completion_converge_to_boundary[OF \<open>b \<in> Gromov_boundary\<close>]
        using Quotient3_abs_rep[OF Quotient3_Gromov_completion] Quotient3_rep_reflp[OF Quotient3_Gromov_completion] apply auto[1]
        unfolding Gromov_extension_def using \<open>b \<in> Gromov_boundary\<close> unfolding comp_def
        by (auto simp add: convergent_LIMSEQ_iff[symmetric] Gromov_boundary_rep_converging Gromov_converging_at_infinity_quasi_isometry[OF assms(1)]
                 intro!: Gromov_converging_at_boundary_converges')
    qed
  next
    text \<open>Next, consider the case where $x$ is inside the space. Then we show everything by going
    back and forth between the original space and its copy in the completion, and arguing that $f$
    is a homeomorphism on the original space.\<close>
    case 2
    then have fx: "Gromov_extension f x \<in> range to_Gromov_completion"
      using Gromov_extension_inside_space by blast
    have x: "x \<in> range to_Gromov_completion"
      using "2" by blast
    show ?thesis
    proof
      assume H: "(\<lambda>n. Gromov_extension f (u n)) \<longlonglongrightarrow> Gromov_extension f x"
      then have fu_in: "eventually (\<lambda>n. Gromov_extension f (u n) \<in> range to_Gromov_completion) sequentially"
        using fx to_Gromov_completion_range_open H topological_tendstoD by fastforce
      have u_in: "eventually (\<lambda>n. u n \<in> range to_Gromov_completion) sequentially"
        using Gromov_extension_quasi_isometry_boundary_to_boundary[OF assms(1)] eventually_mono[OF fu_in]
        by (metis DiffE DiffI Gromov_boundary_def iso_tuple_UNIV_I)

      have B: "from_Gromov_completion (Gromov_extension f y) = f (from_Gromov_completion y)" if "Gromov_extension f y \<in> range to_Gromov_completion" for y
        by (metis Gromov_extension_quasi_isometry_boundary_to_boundary Gromov_extension_def assms(1) from_to_Gromov_completion not_in_Gromov_boundary' rangeE that)
      have "(\<lambda>n. from_Gromov_completion (Gromov_extension f (u n))) \<longlonglongrightarrow> from_Gromov_completion (Gromov_extension f x)"
        by (rule continuous_on_tendsto_compose[OF from_Gromov_completion_continuous(2) H fx fu_in])
      then have C: "(\<lambda>n. f (from_Gromov_completion (u n))) \<longlonglongrightarrow> f (from_Gromov_completion x)"
        unfolding B[OF fx, symmetric]
        by (force intro: Lim_transform_eventually eventually_mono[OF fu_in B])
      have "(\<lambda>n. from_Gromov_completion (u n)) \<longlonglongrightarrow> from_Gromov_completion x"
        apply (rule iffD2[OF homeomorphism_on_compose[OF assms(2)] C])
        using 2 apply auto
        by (metis (no_types, lifting) eventually_mono[OF u_in] H0(2) Un_iff f_inv_into_f from_to_Gromov_completion inv_into_into not_in_Gromov_boundary')
      then have L: "(\<lambda>n. to_Gromov_completion (from_Gromov_completion (u n))) \<longlonglongrightarrow> to_Gromov_completion (from_Gromov_completion x)"
        using continuous_on_tendsto_compose[OF to_Gromov_completion_continuous] by auto

      have **: "to_Gromov_completion (from_Gromov_completion y) = y" if "y \<in> range to_Gromov_completion" for y::"'a Gromov_completion"
        using Gromov_extension_quasi_isometry_boundary_to_boundary assms(1) that to_from_Gromov_completion by fastforce
      then have "eventually (\<lambda>n. to_Gromov_completion (from_Gromov_completion (u n)) = u n) sequentially"
        using u_in eventually_mono by force
      then have "u \<longlonglongrightarrow> to_Gromov_completion (from_Gromov_completion x)"
        by (rule Lim_transform_eventually[OF L])
      then show "u \<longlonglongrightarrow> x"
        using ** by (simp add: x)
    next
      assume "u \<longlonglongrightarrow> x"
      then have u_in: "eventually (\<lambda>n. u n \<in> range to_Gromov_completion) sequentially"
        using x to_Gromov_completion_range_open topological_tendstoD by fastforce
      define y where "y = from_Gromov_completion x"
      have "y \<in> X" unfolding y_def using 2 by auto
      then have *: "continuous (at y within X) f"
        using homeomorphism_on_continuous[OF assms(2)] continuous_on_eq_continuous_within by blast
      have **: "continuous (at x within to_Gromov_completion`X) (Gromov_extension f)"
        using Gromov_extension_continuous_inside[OF *] y_def 2 by auto

      show "(\<lambda>n. Gromov_extension f (u n)) \<longlonglongrightarrow> Gromov_extension f x"
        apply (rule continuous_within_tendsto_compose[OF ** _ \<open>u \<longlonglongrightarrow> x\<close>])
        using u_in H0(2) by (metis (mono_tags, lifting) UnE eventually_mono f_inv_into_f not_in_Gromov_boundary')
    qed
  qed
qed

text \<open>In particular, it follows that the extension to the boundary of a quasi-isometry is always
a homeomorphism, regardless of the continuity properties of the original map.\<close>

proposition Gromov_extension_boundary_homeomorphism:
  fixes f::"'a::Gromov_hyperbolic_space_geodesic \<Rightarrow> 'b::Gromov_hyperbolic_space_geodesic"
  assumes "lambda C-quasi_isometry f"
  shows "homeomorphism_on Gromov_boundary (Gromov_extension f)"
using Gromov_extension_homeomorphism[OF assms, of "{}"] by auto

text \<open>When the quasi-isometric embedding is a quasi-isometric isomorphism, i.e., it is onto up
to a bounded distance $C$, then its Gromov extension is onto on the boundary. Indeed, a point
in the image boundary is a limit of a sequence inside the space. Perturbing by a bounded distance
(which does not change the asymptotic behavior), it is the limit of a sequence inside the image of
$f$. Then the preimage under $f$ of this sequence does converge, and its limit is sent by the
extension on the original point, proving the surjectivity.\<close>

lemma Gromov_extension_onto:
  fixes f::"'a::Gromov_hyperbolic_space_geodesic \<Rightarrow> 'b::Gromov_hyperbolic_space_geodesic"
  assumes "lambda C-quasi_isometry_between UNIV UNIV f"
          "y \<in> Gromov_boundary"
  shows "\<exists>x \<in> Gromov_boundary. Gromov_extension f x = y"
proof -
  define u where "u = rep_Gromov_completion y"
  have *: "(\<lambda>n. to_Gromov_completion (u n)) \<longlonglongrightarrow> y"
    unfolding u_def using rep_Gromov_completion_limit by fastforce
  have "\<exists>v. \<forall>n. dist (f (v n)) (u n) \<le> C"
    apply (intro choice) using quasi_isometry_betweenD(3)[OF assms(1)] by auto
  then obtain v where v: "\<And>n. dist (f (v n)) (u n) \<le> C" by auto
  have *: "(\<lambda>n. to_Gromov_completion (f (v n))) \<longlonglongrightarrow> y"
    apply (rule Gromov_converging_at_boundary_bounded_perturbation[OF * \<open>y \<in> Gromov_boundary\<close>])
    using v by (simp add: dist_commute)
  then have "Gromov_converging_at_boundary (\<lambda>n. f (v n))"
    using assms(2) lim_imp_Gromov_converging_at_boundary by force
  then have "Gromov_converging_at_boundary v"
    using Gromov_converging_at_infinity_quasi_isometry[OF quasi_isometry_betweenD(1)[OF assms(1)]] by auto
  then obtain x where "x \<in> Gromov_boundary" "(\<lambda>n. to_Gromov_completion (v n)) \<longlonglongrightarrow> x"
    using Gromov_converging_at_boundary_converges by blast
  then have "(\<lambda>n. (Gromov_extension f) (to_Gromov_completion (v n))) \<longlonglongrightarrow> Gromov_extension f x"
    using isCont_tendsto_compose[OF Gromov_extension_continuous[OF quasi_isometry_betweenD(1)[OF assms(1)] \<open>x \<in> Gromov_boundary\<close>]] by fastforce
  then have "y = Gromov_extension f x"
    using * LIMSEQ_unique by auto
  then show ?thesis using \<open>x \<in> Gromov_boundary\<close> by auto
qed

lemma Gromov_extension_onto':
  fixes f::"'a::Gromov_hyperbolic_space_geodesic \<Rightarrow> 'b::Gromov_hyperbolic_space_geodesic"
  assumes "lambda C-quasi_isometry_between UNIV UNIV f"
  shows "(Gromov_extension f)`Gromov_boundary = Gromov_boundary"
using Gromov_extension_onto[OF assms] Gromov_extension_quasi_isometry_boundary_to_boundary[OF quasi_isometry_betweenD(1)[OF assms]] by auto

text \<open>Finally, we obtain that a quasi-isometry between two Gromov hyperbolic spaces induces a
homeomorphism of their boundaries.\<close>

theorem Gromov_boundaries_homeomorphic:
  fixes f::"'a::Gromov_hyperbolic_space_geodesic \<Rightarrow> 'b::Gromov_hyperbolic_space_geodesic"
  assumes "lambda C-quasi_isometry_between UNIV UNIV f"
  shows "(Gromov_boundary::'a Gromov_completion set) homeomorphic (Gromov_boundary::'b Gromov_completion set)"
using Gromov_extension_boundary_homeomorphism[OF quasi_isometry_betweenD(1)[OF assms]] Gromov_extension_onto'[OF assms]
unfolding homeomorphic_def homeomorphism_on_def by auto

section \<open>Extensions of isometries to the boundary\<close>

text \<open>The results of the previous section can be improved for isometries, as there is no need for
geodesicity any more. We follow the same proofs as in the previous section\<close>

text \<open>An isometry preserves the Gromov product.\<close>

lemma Gromov_product_isometry:
  assumes "isometry_on UNIV f"
  shows "Gromov_product_at (f x) (f y) (f z) = Gromov_product_at x y z"
unfolding Gromov_product_at_def by (simp add: isometry_onD[OF assms])

text \<open>An isometry preserves convergence at infinity.\<close>

lemma Gromov_converging_at_infinity_isometry:
  fixes f::"'a::Gromov_hyperbolic_space \<Rightarrow> 'b::Gromov_hyperbolic_space"
  assumes "isometry_on UNIV f"
  shows "Gromov_converging_at_boundary (\<lambda>n. f (u n)) \<longleftrightarrow> Gromov_converging_at_boundary u"
proof
  assume *: "Gromov_converging_at_boundary u"
  show "Gromov_converging_at_boundary (\<lambda>n. f (u n))"
    apply (rule Gromov_converging_at_boundaryI[of "f (basepoint)"])
    using * unfolding Gromov_converging_at_boundary_def Gromov_product_isometry[OF assms] by auto
next
  assume *: "Gromov_converging_at_boundary (\<lambda>n. f (u n))"
  have **: "\<exists>N. \<forall>n \<ge> N. \<forall>m \<ge> N. M \<le> Gromov_product_at (f basepoint) (f (u m)) (f (u n))" for M
    using * unfolding Gromov_converging_at_boundary_def by auto
  show "Gromov_converging_at_boundary u"
    apply (rule Gromov_converging_at_boundaryI[of "basepoint"])
    using ** unfolding Gromov_converging_at_boundary_def Gromov_product_isometry[OF assms] by auto
qed

text \<open>The Gromov extension of an isometry sends the boundary to the boundary.\<close>

lemma Gromov_extension_isometry_boundary_to_boundary:
  fixes f::"'a::Gromov_hyperbolic_space \<Rightarrow> 'b::Gromov_hyperbolic_space"
  assumes "isometry_on UNIV f"
          "x \<in> Gromov_boundary"
  shows "(Gromov_extension f) x \<in> Gromov_boundary"
proof -
  have *: "Gromov_converging_at_boundary (\<lambda>n. f (rep_Gromov_completion x n))"
    by (simp add: Gromov_converging_at_infinity_isometry[OF assms(1)] Gromov_boundary_rep_converging assms(2))
  show ?thesis
    unfolding Gromov_extension_def using assms(2) unfolding comp_def apply auto
    by (metis Gromov_converging_at_boundary_converges * limI)
qed

text \<open>The Gromov extension of an isometry is a homeomorphism. (We copy the proof for
quasi-isometries, with some simplifications.)\<close>

lemma Gromov_extension_isometry_homeomorphism:
  fixes f::"'a::Gromov_hyperbolic_space \<Rightarrow> 'b::Gromov_hyperbolic_space"
  assumes "isometry_on UNIV f"
  shows "homeomorphism_on UNIV (Gromov_extension f)"
proof (rule homeomorphism_on_sequentially)
  fix x u
  show "u \<longlonglongrightarrow> x = (\<lambda>n. Gromov_extension f (u n)) \<longlonglongrightarrow> Gromov_extension f x"
  proof (cases x)
    text \<open>First, consider the case where the limit point $x$ is in the boundary. We use a good
    criterion expressing everything in terms of sequences inside the space.\<close>
    case boundary
    show ?thesis
    proof (rule homeomorphism_on_extension_sequentially_precise[of "range to_Gromov_completion" Gromov_boundary])
      show "x \<in> Gromov_boundary" by fact
      fix n::nat show "u n \<in> range to_Gromov_completion \<union> Gromov_boundary"
        unfolding Gromov_boundary_def by auto
    next
      fix u and b::"'a Gromov_completion"
      assume u: "\<forall>n. u n \<in> range to_Gromov_completion" "b \<in> Gromov_boundary" "u \<longlonglongrightarrow> b"
      define v where "v = (\<lambda>n. from_Gromov_completion (u n))"
      have v: "u n = to_Gromov_completion (v n)" for n
        using u(1) unfolding v_def by (simp add: f_inv_into_f from_Gromov_completion_def)
      show "convergent (\<lambda>n. Gromov_extension f (u n))"
        using u unfolding v apply auto
        apply (rule Gromov_converging_at_boundary_converges')
        by (auto simp add: Gromov_converging_at_infinity_isometry[OF assms(1)] lim_imp_Gromov_converging_at_boundary)
    next
      fix u c
      assume u: "\<forall>n. u n \<in> range to_Gromov_completion" "c \<in> Gromov_extension f ` Gromov_boundary" "(\<lambda>n. Gromov_extension f (u n)) \<longlonglongrightarrow> c"
      then have "c \<in> Gromov_boundary" using Gromov_extension_isometry_boundary_to_boundary[OF assms(1)] by auto
      define v where "v = (\<lambda>n. from_Gromov_completion (u n))"
      have v: "u n = to_Gromov_completion (v n)" for n
        using u(1) unfolding v_def by (simp add: f_inv_into_f from_Gromov_completion_def)
      have "Gromov_converging_at_boundary (\<lambda>n. f (v n))"
        apply (rule lim_imp_Gromov_converging_at_boundary[OF _ \<open>c \<in> Gromov_boundary\<close>])
        using u(3) unfolding v by auto
      then show "convergent u"
        using u unfolding v
        by (auto intro!: Gromov_converging_at_boundary_converges' simp add: Gromov_converging_at_infinity_isometry[OF assms(1), symmetric])
    next
      fix b::"'a Gromov_completion" assume "b \<in> Gromov_boundary"
      show "\<exists>u. (\<forall>n. u n \<in> range to_Gromov_completion) \<and> u \<longlonglongrightarrow> b \<and> (\<lambda>n. Gromov_extension f (u n)) \<longlonglongrightarrow> Gromov_extension f b"
        apply (rule exI[of _ "to_Gromov_completion o (rep_Gromov_completion b)"], auto simp add: comp_def)
        unfolding Gromov_completion_converge_to_boundary[OF \<open>b \<in> Gromov_boundary\<close>]
        using Quotient3_abs_rep[OF Quotient3_Gromov_completion] Quotient3_rep_reflp[OF Quotient3_Gromov_completion] apply auto[1]
        unfolding Gromov_extension_def using \<open>b \<in> Gromov_boundary\<close> unfolding comp_def
        by (auto simp add: convergent_LIMSEQ_iff[symmetric] Gromov_boundary_rep_converging Gromov_converging_at_infinity_isometry[OF assms(1)]
                 intro!: Gromov_converging_at_boundary_converges')
    qed
  next
    text \<open>Next, consider the case where $x$ is inside the space. Then we show everything by going
    back and forth between the original space and its copy in the completion, and arguing that $f$
    is a homeomorphism on the original space.\<close>
    case (to_Gromov_completion xin)
    then have fx: "Gromov_extension f x \<in> range to_Gromov_completion"
      using Gromov_extension_inside_space by blast
    have x: "x \<in> range to_Gromov_completion"
      using to_Gromov_completion by blast
    show ?thesis
    proof
      assume H: "(\<lambda>n. Gromov_extension f (u n)) \<longlonglongrightarrow> Gromov_extension f x"
      then have fu_in: "eventually (\<lambda>n. Gromov_extension f (u n) \<in> range to_Gromov_completion) sequentially"
        using fx to_Gromov_completion_range_open H topological_tendstoD by fastforce
      have u_in: "eventually (\<lambda>n. u n \<in> range to_Gromov_completion) sequentially"
        using Gromov_extension_isometry_boundary_to_boundary[OF assms(1)] eventually_mono[OF fu_in]
        by (metis DiffE DiffI Gromov_boundary_def iso_tuple_UNIV_I)

      have B: "from_Gromov_completion (Gromov_extension f y) = f (from_Gromov_completion y)" if "Gromov_extension f y \<in> range to_Gromov_completion" for y
        by (metis Gromov_extension_isometry_boundary_to_boundary Gromov_extension_def assms(1) from_to_Gromov_completion not_in_Gromov_boundary' rangeE that)
      have "(\<lambda>n. from_Gromov_completion (Gromov_extension f (u n))) \<longlonglongrightarrow> from_Gromov_completion (Gromov_extension f x)"
        by (rule continuous_on_tendsto_compose[OF from_Gromov_completion_continuous(2) H fx fu_in])
      then have C: "(\<lambda>n. f (from_Gromov_completion (u n))) \<longlonglongrightarrow> f (from_Gromov_completion x)"
        unfolding B[OF fx, symmetric]
        by (force intro: Lim_transform_eventually eventually_mono[OF fu_in B])
      have "(\<lambda>n. from_Gromov_completion (u n)) \<longlonglongrightarrow> from_Gromov_completion x"
        apply (rule iffD2[OF homeomorphism_on_compose[OF isometry_on_homeomorphism(2)[OF assms]] C])
        using to_Gromov_completion by auto
      then have L: "(\<lambda>n. to_Gromov_completion (from_Gromov_completion (u n))) \<longlonglongrightarrow> to_Gromov_completion (from_Gromov_completion x)"
        using continuous_on_tendsto_compose[OF to_Gromov_completion_continuous] by auto

      have **: "to_Gromov_completion (from_Gromov_completion y) = y" if "y \<in> range to_Gromov_completion" for y::"'a Gromov_completion"
        using Gromov_extension_isometry_boundary_to_boundary assms(1) that to_from_Gromov_completion by fastforce
      then have "eventually (\<lambda>n. to_Gromov_completion (from_Gromov_completion (u n)) = u n) sequentially"
        using u_in eventually_mono by force
      then have "u \<longlonglongrightarrow> to_Gromov_completion (from_Gromov_completion x)"
        by (rule Lim_transform_eventually[OF L])
      then show "u \<longlonglongrightarrow> x"
        using ** by (simp add: x)
    next
      assume "u \<longlonglongrightarrow> x"
      then have u_in: "eventually (\<lambda>n. u n \<in> range to_Gromov_completion) sequentially"
        using x to_Gromov_completion_range_open topological_tendstoD by fastforce
      define y where "y = from_Gromov_completion x"
      then have *: "continuous (at y) f"
        using homeomorphism_on_continuous[OF isometry_on_homeomorphism(2)[OF assms]] continuous_on_eq_continuous_within by blast
      have **: "continuous (at x within to_Gromov_completion`UNIV) (Gromov_extension f)"
        using Gromov_extension_continuous_inside[OF *] y_def to_Gromov_completion by auto

      show "(\<lambda>n. Gromov_extension f (u n)) \<longlonglongrightarrow> Gromov_extension f x"
        apply (rule continuous_within_tendsto_compose[OF ** _ \<open>u \<longlonglongrightarrow> x\<close>])
        using u_in by auto
    qed
  qed
qed

text \<open>The composition of the Gromov extension of two isometries is the Gromov extension of the
composition.\<close>

lemma Gromov_extension_isometry_on_composition:
  assumes "isometry_on UNIV f"
          "isometry_on UNIV g"
  shows "Gromov_extension (g o f) = Gromov_extension g o Gromov_extension f"
proof -
  have In: "Gromov_extension (g o f) x = (Gromov_extension g o Gromov_extension f) x" if H: "x \<in> range to_Gromov_completion" for x
  proof -
    obtain y where *: "x = to_Gromov_completion y"
      using H by auto
    show ?thesis
      unfolding * comp_def by auto
  qed
  moreover have "Gromov_extension (g o f) x = (Gromov_extension g o Gromov_extension f) x" if H: "x \<in> Gromov_boundary" for x
  proof -
    obtain u where u: "\<And>n. u n \<in> range to_Gromov_completion" "u \<longlonglongrightarrow> x"
      using closure_sequential to_Gromov_completion_range_dense by blast
    have "(\<lambda>n. Gromov_extension (g o f) (u n)) \<longlonglongrightarrow> Gromov_extension (g o f) x"
      apply (rule continuous_within_tendsto_compose[OF _ _ u(2), of UNIV])
      using homeomorphism_on_continuous[OF Gromov_extension_isometry_homeomorphism[OF isometry_on_compose[OF assms(1) isometry_on_subset[OF assms(2)]]]] unfolding comp_def
      by (auto simp add: continuous_on_eq_continuous_within)
    then have A: "(\<lambda>n. (Gromov_extension g) ((Gromov_extension f) (u n))) \<longlonglongrightarrow> Gromov_extension (g o f) x"
      unfolding In[OF u(1)] unfolding comp_def by auto

    have *: "(\<lambda>n. (Gromov_extension f) (u n)) \<longlonglongrightarrow> (Gromov_extension f) x"
      apply (rule continuous_within_tendsto_compose[OF _ _ u(2), of UNIV])
      using homeomorphism_on_continuous[OF Gromov_extension_isometry_homeomorphism[OF assms(1)]] unfolding comp_def
      by (auto simp add: continuous_on_eq_continuous_within)
    have "(\<lambda>n. (Gromov_extension g) ((Gromov_extension f) (u n))) \<longlonglongrightarrow> Gromov_extension g ((Gromov_extension f) x)"
      apply (rule continuous_within_tendsto_compose[OF _ _ *, of UNIV])
      using homeomorphism_on_continuous[OF Gromov_extension_isometry_homeomorphism[OF assms(2)]] unfolding comp_def
      by (auto simp add: continuous_on_eq_continuous_within)
    then show ?thesis using LIMSEQ_unique A comp_def by auto
  qed
  ultimately have "Gromov_extension (g o f) x = (Gromov_extension g o Gromov_extension f) x" for x
    using not_in_Gromov_boundary by force
  then show ?thesis by auto
qed

text \<open>We specialize the previous results to bijective isometries, as this is the setting where they
will be used most of the time.\<close>

lemma Gromov_extension_isometry:
  assumes "isometry f"
  shows "homeomorphism_on UNIV (Gromov_extension f)"
        "continuous_on UNIV (Gromov_extension f)"
        "continuous (at x) (Gromov_extension f)"
using Gromov_extension_isometry_homeomorphism[OF isometryD(1)[OF assms]] homeomorphism_on_continuous apply auto
using \<open>homeomorphism_on UNIV (Gromov_extension f)\<close> continuous_on_eq_continuous_within homeomorphism_on_continuous by blast

lemma Gromov_extension_isometry_composition:
  assumes "isometry f"
          "isometry g"
  shows "Gromov_extension (g o f) = Gromov_extension g o Gromov_extension f"
using Gromov_extension_isometry_on_composition[OF isometryD(1)[OF assms(1)] isometryD(1)[OF assms(2)]] by simp

lemma Gromov_extension_isometry_iterates:
  fixes f::"'a \<Rightarrow> ('a::Gromov_hyperbolic_space)"
  assumes "isometry f"
  shows "Gromov_extension (f^^n) = (Gromov_extension f)^^n"
apply (induction n) using Gromov_extension_isometry_composition[OF isometry_iterates[OF assms] assms] unfolding comp_def by auto

lemma Gromov_extension_isometry_inv:
  assumes "isometry f"
  shows "inv (Gromov_extension f) = Gromov_extension (inv f)"
        "bij (Gromov_extension f)"
proof -
  have *: "(inv f) o f = id"
    using isometry_inverse(2)[OF assms] by (simp add: bij_is_inj)
  have "Gromov_extension ((inv f) o f) = Gromov_extension (inv f) o Gromov_extension f"
    by (rule Gromov_extension_isometry_composition[OF assms isometry_inverse(1)[OF assms]])
  then have A: "Gromov_extension (inv f) o Gromov_extension f = id"
    unfolding * by auto
  have *: "f o (inv f) = id"
    using isometry_inverse(2)[OF assms] by (meson bij_is_surj surj_iff)
  have "Gromov_extension (f o (inv f)) = Gromov_extension f o Gromov_extension (inv f)"
    by (rule Gromov_extension_isometry_composition[OF isometry_inverse(1)[OF assms] assms])
  then have B: "Gromov_extension f o Gromov_extension (inv f) = id"
    unfolding * by auto
  show "bij (Gromov_extension f)"
    using A B unfolding bij_def apply auto
    by (metis inj_on_id inj_on_imageI2, metis B comp_apply id_def rangeI)
  show "inv (Gromov_extension f) = Gromov_extension (inv f)"
    using B \<open>bij (Gromov_extension f)\<close> bij_is_inj inv_o_cancel left_right_inverse_eq by blast
qed

text \<open>We will especially use fixed points on the boundary. We note that if a point is fixed by
(the Gromov extension of) a map, then it is fixed by (the Gromov extension of) its inverse.\<close>

lemma Gromov_extension_inv_fixed_point:
  assumes "isometry (f::'a::Gromov_hyperbolic_space \<Rightarrow> 'a)" "Gromov_extension f xi = xi"
  shows "Gromov_extension (inv f) xi = xi"
by (metis Gromov_extension_isometry_inv(1) Gromov_extension_isometry_inv(2) assms(1) assms(2) bij_betw_def inv_f_f)

text \<open>The extended Gromov product is invariant under isometries. This follows readily from the
definition, but still the proof is not fully automatic, unfortunately.\<close>

lemma Gromov_extension_preserves_extended_Gromov_product:
  assumes "isometry f"
  shows "extended_Gromov_product_at (f x) (Gromov_extension f xi) (Gromov_extension f eta) = extended_Gromov_product_at x xi eta"
proof -
  have "{liminf (\<lambda>n. ereal (Gromov_product_at (f x) (u n) (v n))) |u v.
          (\<lambda>n. to_Gromov_completion (u n)) \<longlonglongrightarrow> Gromov_extension f xi \<and> (\<lambda>n. to_Gromov_completion (v n)) \<longlonglongrightarrow> Gromov_extension f eta} =
        {liminf (\<lambda>n. ereal (Gromov_product_at x (u n) (v n))) |u v.
          (\<lambda>n. to_Gromov_completion (u n)) \<longlonglongrightarrow> xi \<and> (\<lambda>n. to_Gromov_completion (v n)) \<longlonglongrightarrow> eta}"
  proof (auto)
    fix u v assume H: "(\<lambda>n. to_Gromov_completion (u n)) \<longlonglongrightarrow> Gromov_extension f xi"
                      "(\<lambda>n. to_Gromov_completion (v n)) \<longlonglongrightarrow> Gromov_extension f eta"
    define u' where "u' = (\<lambda>n. (inv f) (u n))"
    define v' where "v' = (\<lambda>n. (inv f) (v n))"
    have "(\<lambda>n. to_Gromov_completion (u' n)) \<longlonglongrightarrow> Gromov_extension (inv f) (Gromov_extension f xi)"
      unfolding u'_def Gromov_extension_inside_space[symmetric]
      apply (rule iffD1[OF homeomorphism_on_compose[OF Gromov_extension_isometry_homeomorphism[OF isometryD(1)[OF isometry_inverse(1)[OF assms]]]]])
      using H(1) by auto
    moreover have "Gromov_extension (inv f) (Gromov_extension f xi) = xi"
      using Gromov_extension_isometry_composition[OF assms isometry_inverse(1)[OF assms], symmetric] unfolding comp_def
      using bij_is_inj[OF isometry_inverse(2)[OF assms]]
      by (simp add: \<open>Gromov_extension (inv f) \<circ> Gromov_extension f = Gromov_extension (inv f \<circ> f)\<close> pointfree_idE)
    ultimately have U: "(\<lambda>n. to_Gromov_completion (u' n)) \<longlonglongrightarrow> xi" by simp
    have "(\<lambda>n. to_Gromov_completion (v' n)) \<longlonglongrightarrow> Gromov_extension (inv f) (Gromov_extension f eta)"
      unfolding v'_def Gromov_extension_inside_space[symmetric]
      apply (rule iffD1[OF homeomorphism_on_compose[OF Gromov_extension_isometry_homeomorphism[OF isometryD(1)[OF isometry_inverse(1)[OF assms]]]]])
      using H(2) by auto
    moreover have "Gromov_extension (inv f) (Gromov_extension f eta) = eta"
      using Gromov_extension_isometry_composition[OF assms isometry_inverse(1)[OF assms], symmetric] unfolding comp_def
      using bij_is_inj[OF isometry_inverse(2)[OF assms]]
      by (simp add: \<open>Gromov_extension (inv f) \<circ> Gromov_extension f = Gromov_extension (inv f \<circ> f)\<close> pointfree_idE)
    ultimately have V: "(\<lambda>n. to_Gromov_completion (v' n)) \<longlonglongrightarrow> eta" by simp
    have uv: "u n = f (u' n)" "v n = f (v' n)" for n
      unfolding u'_def v'_def by (auto simp add: assms isometryD(3) surj_f_inv_f)
    have "Gromov_product_at (f x) (u n) (v n) = Gromov_product_at x (u' n) (v' n)" for n
      unfolding uv using assms by (simp add: Gromov_product_isometry isometry_def)
    then have "liminf (\<lambda>n. ereal (Gromov_product_at (f x) (u n) (v n))) = liminf (\<lambda>n. ereal (Gromov_product_at x (u' n) (v' n)))"
      by auto
    then show "\<exists>u' v'.
              liminf (\<lambda>n. ereal (Gromov_product_at (f x) (u n) (v n))) = liminf (\<lambda>n. ereal (Gromov_product_at x (u' n) (v' n))) \<and>
              (\<lambda>n. to_Gromov_completion (u' n)) \<longlonglongrightarrow> xi \<and> (\<lambda>n. to_Gromov_completion (v' n)) \<longlonglongrightarrow> eta"
      using U V by blast
  next
    fix u v assume H: "(\<lambda>n. to_Gromov_completion (u n)) \<longlonglongrightarrow> xi"
                      "(\<lambda>n. to_Gromov_completion (v n)) \<longlonglongrightarrow> eta"
    define u' where "u' = (\<lambda>n. f (u n))"
    define v' where "v' = (\<lambda>n. f (v n))"
    have U: "(\<lambda>n. to_Gromov_completion (u' n)) \<longlonglongrightarrow> Gromov_extension f xi"
      unfolding u'_def Gromov_extension_inside_space[symmetric]
      apply (rule iffD1[OF homeomorphism_on_compose[OF Gromov_extension_isometry_homeomorphism[OF isometryD(1)[OF assms]]]])
      using H(1) by auto
    have V: "(\<lambda>n. to_Gromov_completion (v' n)) \<longlonglongrightarrow> Gromov_extension f eta"
      unfolding v'_def Gromov_extension_inside_space[symmetric]
      apply (rule iffD1[OF homeomorphism_on_compose[OF Gromov_extension_isometry_homeomorphism[OF isometryD(1)[OF assms]]]])
      using H(2) by auto
    have "Gromov_product_at (f x) (u' n) (v' n) = Gromov_product_at x (u n) (v n)" for n
      unfolding u'_def v'_def using assms by (simp add: Gromov_product_isometry isometry_def)
    then have "liminf (\<lambda>n. ereal (Gromov_product_at x (u n) (v n))) = liminf (\<lambda>n. ereal (Gromov_product_at (f x) (u' n) (v' n)))"
      by auto
    then show "\<exists>u' v'.
              liminf (\<lambda>n. ereal (Gromov_product_at x (u n) (v n))) = liminf (\<lambda>n. ereal (Gromov_product_at (f x) (u' n) (v' n))) \<and>
              (\<lambda>n. to_Gromov_completion (u' n)) \<longlonglongrightarrow> Gromov_extension f xi \<and> (\<lambda>n. to_Gromov_completion (v' n)) \<longlonglongrightarrow> Gromov_extension f eta"
      using U V by auto
  qed
  then show ?thesis
    unfolding extended_Gromov_product_at_topological by auto
qed

end (*of theory Boundary_Extension*)