(* Title: Examples/SML_Relativization/Lattices/SML_Complete_Lattices.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section\<open>Relativization of the results about complete lattices\<close>
theory SML_Complete_Lattices
  imports SML_Lattices
begin

subsection\<open>Simple complete lattices\<close>

subsubsection\<open>Definitions and common properties\<close>

locale Inf_ow =
  fixes U :: "'al set" and Inf (\<open>\<Sqinter>\<^sub>o\<^sub>w\<close>)
  assumes Inf_closed[simp]: "\<Sqinter>\<^sub>o\<^sub>w ` Pow U \<subseteq> U"
begin

notation Inf (\<open>\<Sqinter>\<^sub>o\<^sub>w\<close>)

lemma Inf_closed'[simp]: "\<forall>x\<subseteq>U. \<Sqinter>\<^sub>o\<^sub>w x \<in> U" using Inf_closed by blast

end

locale Inf_pair_ow = Inf\<^sub>1: Inf_ow U\<^sub>1 Inf\<^sub>1 + Inf\<^sub>2: Inf_ow U\<^sub>2 Inf\<^sub>2
  for U\<^sub>1 :: "'al set" and Inf\<^sub>1 and U\<^sub>2 :: "'bl set" and Inf\<^sub>2
begin

notation Inf\<^sub>1 (\<open>\<Sqinter>\<^sub>o\<^sub>w\<^sub>.\<^sub>1\<close>)
notation Inf\<^sub>2 (\<open>\<Sqinter>\<^sub>o\<^sub>w\<^sub>.\<^sub>2\<close>)

end

locale Sup_ow =
  fixes U :: "'al set" and Sup (\<open>\<Squnion>\<^sub>o\<^sub>w\<close>)
  assumes Sup_closed[simp]: "\<Squnion>\<^sub>o\<^sub>w ` Pow U \<subseteq> U"
begin

notation Sup (\<open>\<Squnion>\<^sub>o\<^sub>w\<close>)

lemma Sup_closed'[simp]: "\<forall>x\<subseteq>U. \<Squnion>\<^sub>o\<^sub>w x \<in> U" using Sup_closed by blast

end

locale Sup_pair_ow = Sup\<^sub>1: Sup_ow U\<^sub>1 Sup\<^sub>1 + Sup\<^sub>2: Sup_ow U\<^sub>2 Sup\<^sub>2
  for U\<^sub>1 :: "'al set" and Sup\<^sub>1 and U\<^sub>2 :: "'bl set" and Sup\<^sub>2
begin

notation Sup\<^sub>1 (\<open>\<Squnion>\<^sub>o\<^sub>w\<^sub>.\<^sub>1\<close>)
notation Sup\<^sub>2 (\<open>\<Squnion>\<^sub>o\<^sub>w\<^sub>.\<^sub>2\<close>)

end

locale complete_lattice_ow =
  lattice_ow U inf le ls sup +
  Inf_ow U Inf +
  Sup_ow U Sup +
  bot_ow U bot +
  top_ow U top
  for U :: "'al set" and Inf  Sup inf le ls sup bot top +
  assumes Inf_lower: "\<lbrakk> A \<subseteq> U; x \<in> A \<rbrakk> \<Longrightarrow> \<Sqinter>\<^sub>o\<^sub>w A \<le>\<^sub>o\<^sub>w x"
    and Inf_greatest:
      "\<lbrakk> A \<subseteq> U; z \<in> U; (\<And>x. x \<in> A \<Longrightarrow> z \<le>\<^sub>o\<^sub>w x) \<rbrakk> \<Longrightarrow> z \<le>\<^sub>o\<^sub>w \<Sqinter>\<^sub>o\<^sub>w A"
    and Sup_upper: "\<lbrakk> x \<in> A; A \<subseteq> U \<rbrakk> \<Longrightarrow> x \<le>\<^sub>o\<^sub>w \<Squnion>\<^sub>o\<^sub>w A"
    and Sup_least:
      "\<lbrakk> A \<subseteq> U; z \<in> U; (\<And>x. x \<in> A \<Longrightarrow> x \<le>\<^sub>o\<^sub>w z) \<rbrakk> \<Longrightarrow> \<Squnion>\<^sub>o\<^sub>w A \<le>\<^sub>o\<^sub>w z"
    and Inf_empty[simp]: "\<Sqinter>\<^sub>o\<^sub>w {} = \<top>\<^sub>o\<^sub>w"
    and Sup_empty[simp]: "\<Squnion>\<^sub>o\<^sub>w {} = \<bottom>\<^sub>o\<^sub>w"
begin

sublocale bounded_lattice_ow U \<open>(\<sqinter>\<^sub>o\<^sub>w)\<close> \<open>(\<le>\<^sub>o\<^sub>w)\<close> \<open>(<\<^sub>o\<^sub>w)\<close> \<open>(\<squnion>\<^sub>o\<^sub>w)\<close> \<open>\<bottom>\<^sub>o\<^sub>w\<close> \<open>\<top>\<^sub>o\<^sub>w\<close>
  apply standard
  subgoal using Sup_least by force
  subgoal using Inf_greatest by fastforce
  done

tts_register_sbts \<open>\<bottom>\<^sub>o\<^sub>w\<close> | U
proof-
  assume ALA: "Domainp ALA = (\<lambda>x. x \<in> U)"
  have "Domainp ALA \<bottom>\<^sub>o\<^sub>w" unfolding ALA by simp
  then obtain bot' where "ALA \<bottom>\<^sub>o\<^sub>w bot'" by blast
  then show "\<exists>bot'. ALA \<bottom>\<^sub>o\<^sub>w bot'" by auto
qed

tts_register_sbts \<open>\<top>\<^sub>o\<^sub>w\<close> | U
proof-
  assume ALA: "Domainp ALA = (\<lambda>x. x \<in> U)"
  have "Domainp ALA \<top>\<^sub>o\<^sub>w" unfolding ALA by simp
  then obtain top' where "ALA \<top>\<^sub>o\<^sub>w top'" by blast
  then show "\<exists>top'. ALA \<top>\<^sub>o\<^sub>w top'" by auto
qed

end

locale complete_lattice_pair_ow =
  cl\<^sub>1: complete_lattice_ow U\<^sub>1 Inf\<^sub>1 Sup\<^sub>1 inf\<^sub>1 le\<^sub>1 ls\<^sub>1 sup\<^sub>1 bot\<^sub>1 top\<^sub>1 +
  cl\<^sub>2: complete_lattice_ow U\<^sub>2 Inf\<^sub>2 Sup\<^sub>2 inf\<^sub>2 le\<^sub>2 ls\<^sub>2 sup\<^sub>2 bot\<^sub>2 top\<^sub>2
  for U\<^sub>1 :: "'al set" and Inf\<^sub>1 Sup\<^sub>1 inf\<^sub>1 le\<^sub>1 ls\<^sub>1 sup\<^sub>1 bot\<^sub>1 top\<^sub>1
    and U\<^sub>2 :: "'bl set" and Inf\<^sub>2 Sup\<^sub>2 inf\<^sub>2 le\<^sub>2 ls\<^sub>2 sup\<^sub>2 bot\<^sub>2 top\<^sub>2
begin

sublocale bounded_lattice_pair_ow ..
sublocale Inf_pair_ow ..
sublocale Sup_pair_ow ..

end

subsubsection\<open>Transfer rules\<close>

context
  includes lifting_syntax
begin

lemma complete_lattice_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "(
      (rel_set A ===> A) ===>
      (rel_set A ===> A) ===>
      (A ===> A ===> A) ===>
      (A ===> A ===> (=)) ===>
      (A ===> A ===> (=)) ===>
      (A ===> A ===> A) ===>
      A ===> A ===>
      (=)
    )
    (complete_lattice_ow (Collect (Domainp A))) class.complete_lattice"
proof-
  let ?P =
    "(
      (rel_set A ===> A) ===>
      (rel_set A ===> A) ===>
      (A ===> A ===> A) ===>
      (A ===> A ===> (=)) ===>
      (A ===> A ===> (=)) ===>
      (A ===> A ===> A) ===>
      A ===> A ===>
      (=)
    )"
  let ?complete_lattice_ow = "(complete_lattice_ow (Collect (Domainp A)))"
  let ?Inf_Sup_UNIV =
    "(\<lambda>F'::'b set \<Rightarrow> 'b. (F' ` Pow UNIV \<subseteq> UNIV))"
  have rrng:
    "((A2 \<and> A3 \<and> A4 \<and> A5 \<and> A1 \<and> A6 \<and> A7 \<and> A8 \<and> A9 \<and> A10 \<and> A11) = F') \<Longrightarrow>
    ((A1 \<and> A2 \<and> A3 \<and> A4 \<and> A5 \<and> A6 \<and> A7 \<and> A8 \<and> A9 \<and> A10 \<and> A11) = F')"
    for A1 A2 A3 A4 A5 A6 A7 A8 A9 A10 A11 F'
    by auto
  have
    "?P
      ?complete_lattice_ow
      (
        \<lambda>Inf Sup inf le ls sup bot top.
          ?Inf_Sup_UNIV Inf \<and> ?Inf_Sup_UNIV Sup \<and> bot \<in> UNIV \<and> top \<in> UNIV \<and>
          class.complete_lattice Inf Sup inf le ls sup bot top
      )"
    unfolding
      complete_lattice_ow_def class.complete_lattice_def
      complete_lattice_ow_axioms_def class.complete_lattice_axioms_def
      Inf_ow_def Sup_ow_def bot_ow_def top_ow_def
    apply transfer_prover_start
    apply transfer_step+
    apply(simp, intro ext, rule rrng, intro arg_cong2[where f="(\<and>)"])
    subgoal unfolding Ball_Collect by simp
    subgoal unfolding Ball_Collect by simp
    subgoal by simp
    subgoal by simp
    subgoal by simp
    subgoal unfolding Ball_Collect[symmetric] by auto
    subgoal unfolding Ball_Collect[symmetric] by metis
    subgoal unfolding Ball_Collect[symmetric] by auto
    subgoal unfolding Ball_Collect[symmetric] by metis
    subgoal by simp
    subgoal by simp
    done
  then show ?thesis by simp
qed

end

subsubsection\<open>Relativization\<close>

context complete_lattice_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting complete_lattice_ow_axioms and sup_bot.sl_neut.not_empty
  eliminating \<open>?a \<in> ?A\<close> and \<open>?A \<subseteq> ?B\<close> through auto
  applying [OF Inf_closed' Sup_closed' inf_closed' sup_closed']
begin

tts_lemma Inf_atLeast:
  assumes "x \<in> U"
  shows "\<Sqinter>\<^sub>o\<^sub>w {x..\<^sub>o\<^sub>w} = x"
  is complete_lattice_class.Inf_atLeast.

tts_lemma Inf_atMost:
  assumes "x \<in> U"
  shows "\<Sqinter>\<^sub>o\<^sub>w {..\<^sub>o\<^sub>wx} = \<bottom>\<^sub>o\<^sub>w"
    is complete_lattice_class.Inf_atMost.

tts_lemma Sup_atLeast:
  assumes "x \<in> U"
  shows "\<Squnion>\<^sub>o\<^sub>w {x..\<^sub>o\<^sub>w} = \<top>\<^sub>o\<^sub>w"
  is complete_lattice_class.Sup_atLeast.

tts_lemma Sup_atMost:
  assumes "y \<in> U"
  shows "\<Squnion>\<^sub>o\<^sub>w {..\<^sub>o\<^sub>wy} = y"
    is complete_lattice_class.Sup_atMost.

tts_lemma Inf_insert:
  assumes "a \<in> U" and "A \<subseteq> U"
  shows "\<Sqinter>\<^sub>o\<^sub>w (insert a A) = a \<sqinter>\<^sub>o\<^sub>w \<Sqinter>\<^sub>o\<^sub>w A"
    is complete_lattice_class.Inf_insert.

tts_lemma Sup_insert:
  assumes "a \<in> U" and "A \<subseteq> U"
  shows "\<Squnion>\<^sub>o\<^sub>w (insert a A) = a \<squnion>\<^sub>o\<^sub>w \<Squnion>\<^sub>o\<^sub>w A"
    is complete_lattice_class.Sup_insert.

tts_lemma Inf_atMostLessThan:
  assumes "x \<in> U" and "\<top>\<^sub>o\<^sub>w <\<^sub>o\<^sub>w x"
  shows "\<Sqinter>\<^sub>o\<^sub>w {..<\<^sub>o\<^sub>wx} = \<bottom>\<^sub>o\<^sub>w"
    is complete_lattice_class.Inf_atMostLessThan.

tts_lemma Sup_greaterThanAtLeast:
  assumes "x \<in> U" and "x <\<^sub>o\<^sub>w \<top>\<^sub>o\<^sub>w"
  shows "\<Squnion>\<^sub>o\<^sub>w {x<\<^sub>o\<^sub>w..} = \<top>\<^sub>o\<^sub>w"
    is complete_lattice_class.Sup_greaterThanAtLeast.

tts_lemma le_Inf_iff:
  assumes "b \<in> U" and "A \<subseteq> U"
  shows "(b \<le>\<^sub>o\<^sub>w \<Sqinter>\<^sub>o\<^sub>w A) = Ball A ((\<le>\<^sub>o\<^sub>w) b)"
    is complete_lattice_class.le_Inf_iff.

tts_lemma Sup_le_iff:
  assumes "A \<subseteq> U" and "b \<in> U"
  shows "(\<Squnion>\<^sub>o\<^sub>w A \<le>\<^sub>o\<^sub>w b) = (\<forall>x\<in>A. x \<le>\<^sub>o\<^sub>w b)"
    is complete_lattice_class.Sup_le_iff.

tts_lemma Inf_atLeastLessThan:
  assumes "x \<in> U" and "y \<in> U" and "x <\<^sub>o\<^sub>w y"
  shows "\<Sqinter>\<^sub>o\<^sub>w (on U with (\<le>\<^sub>o\<^sub>w) (<\<^sub>o\<^sub>w) : {x..<y}) = x"
    is complete_lattice_class.Inf_atLeastLessThan.

tts_lemma Sup_greaterThanAtMost:
  assumes "x \<in> U" and "y \<in> U" and "x <\<^sub>o\<^sub>w y"
  shows "\<Squnion>\<^sub>o\<^sub>w {x<\<^sub>o\<^sub>w..y} = y"
    is complete_lattice_class.Sup_greaterThanAtMost.

tts_lemma Inf_atLeastAtMost:
  assumes "x \<in> U" and "y \<in> U" and "x \<le>\<^sub>o\<^sub>w y"
  shows "\<Sqinter>\<^sub>o\<^sub>w {x..\<^sub>o\<^sub>wy} = x"
is complete_lattice_class.Inf_atLeastAtMost.

tts_lemma Sup_atLeastAtMost:
  assumes "x \<in> U" and "y \<in> U" and "x \<le>\<^sub>o\<^sub>w y"
  shows "\<Squnion>\<^sub>o\<^sub>w {x..\<^sub>o\<^sub>wy} = y"
    is complete_lattice_class.Sup_atLeastAtMost.

tts_lemma Inf_lower2:
  assumes "A \<subseteq> U" and "v \<in> U" and "u \<in> A" and "u \<le>\<^sub>o\<^sub>w v"
  shows "\<Sqinter>\<^sub>o\<^sub>w A \<le>\<^sub>o\<^sub>w v"
  is complete_lattice_class.Inf_lower2.

tts_lemma Sup_upper2:
  assumes "A \<subseteq> U" and "v \<in> U" and "u \<in> A" and "v \<le>\<^sub>o\<^sub>w u"
  shows "v \<le>\<^sub>o\<^sub>w \<Squnion>\<^sub>o\<^sub>w A"
    is complete_lattice_class.Sup_upper2.

tts_lemma Inf_less_eq:
  assumes "A \<subseteq> U" and "u \<in> U" and "\<And>v. v \<in> A \<Longrightarrow> v \<le>\<^sub>o\<^sub>w u" and "A \<noteq> {}"
  shows "\<Sqinter>\<^sub>o\<^sub>w A \<le>\<^sub>o\<^sub>w u"
  given complete_lattice_class.Inf_less_eq by auto

tts_lemma less_eq_Sup:
  assumes "A \<subseteq> U" and "u \<in> U" and "\<And>v. v \<in> A \<Longrightarrow> u \<le>\<^sub>o\<^sub>w v" and "A \<noteq> {}"
  shows "u \<le>\<^sub>o\<^sub>w \<Squnion>\<^sub>o\<^sub>w A"
  given complete_lattice_class.less_eq_Sup by auto

tts_lemma Sup_eqI:
  assumes "A \<subseteq> U"
    and "x \<in> U"
    and "\<And>y. y \<in> A \<Longrightarrow> y \<le>\<^sub>o\<^sub>w x"
    and "\<And>y. \<lbrakk>y \<in> U; \<And>z. z \<in> A \<Longrightarrow> z \<le>\<^sub>o\<^sub>w y\<rbrakk> \<Longrightarrow> x \<le>\<^sub>o\<^sub>w y"
  shows "\<Squnion>\<^sub>o\<^sub>w A = x"
    given complete_lattice_class.Sup_eqI
    by (simp add: Sup_least Sup_upper order.antisym)

tts_lemma Inf_eqI:
  assumes "A \<subseteq> U"
    and "x \<in> U"
    and "\<And>i. i \<in> A \<Longrightarrow> x \<le>\<^sub>o\<^sub>w i"
    and "\<And>y. \<lbrakk>y \<in> U; \<And>i. i \<in> A \<Longrightarrow> y \<le>\<^sub>o\<^sub>w i\<rbrakk> \<Longrightarrow> y \<le>\<^sub>o\<^sub>w x"
  shows "\<Sqinter>\<^sub>o\<^sub>w A = x"
    given complete_lattice_class.Inf_eqI
  by (simp add: subset_eq)

tts_lemma Inf_union_distrib:
  assumes "A \<subseteq> U" and "B \<subseteq> U"
  shows "\<Sqinter>\<^sub>o\<^sub>w (A \<union> B) = \<Sqinter>\<^sub>o\<^sub>w A \<sqinter>\<^sub>o\<^sub>w \<Sqinter>\<^sub>o\<^sub>w B"
    is complete_lattice_class.Inf_union_distrib.

tts_lemma Sup_union_distrib:
  assumes "A \<subseteq> U" and "B \<subseteq> U"
  shows "\<Squnion>\<^sub>o\<^sub>w (A \<union> B) = \<Squnion>\<^sub>o\<^sub>w A \<squnion>\<^sub>o\<^sub>w \<Squnion>\<^sub>o\<^sub>w B"
    is complete_lattice_class.Sup_union_distrib.

tts_lemma Sup_inter_less_eq:
  assumes "A \<subseteq> U" and "B \<subseteq> U"
  shows "\<Squnion>\<^sub>o\<^sub>w (A \<inter> B) \<le>\<^sub>o\<^sub>w \<Squnion>\<^sub>o\<^sub>w A \<sqinter>\<^sub>o\<^sub>w \<Squnion>\<^sub>o\<^sub>w B"
    is complete_lattice_class.Sup_inter_less_eq.

tts_lemma less_eq_Inf_inter:
  assumes "A \<subseteq> U" and "B \<subseteq> U"
  shows "\<Sqinter>\<^sub>o\<^sub>w A \<squnion>\<^sub>o\<^sub>w \<Sqinter>\<^sub>o\<^sub>w B \<le>\<^sub>o\<^sub>w \<Sqinter>\<^sub>o\<^sub>w (A \<inter> B)"
    is complete_lattice_class.less_eq_Inf_inter.

tts_lemma Sup_subset_mono:
  assumes "B \<subseteq> U" and "A \<subseteq> B"
  shows "\<Squnion>\<^sub>o\<^sub>w A \<le>\<^sub>o\<^sub>w \<Squnion>\<^sub>o\<^sub>w B"
    is complete_lattice_class.Sup_subset_mono.

tts_lemma Inf_superset_mono:
  assumes "A \<subseteq> U" and "B \<subseteq> A"
  shows "\<Sqinter>\<^sub>o\<^sub>w A \<le>\<^sub>o\<^sub>w \<Sqinter>\<^sub>o\<^sub>w B"
    is complete_lattice_class.Inf_superset_mono.

tts_lemma Sup_bot_conv:
  assumes "A \<subseteq> U"
  shows
    "(\<Squnion>\<^sub>o\<^sub>w A = \<bottom>\<^sub>o\<^sub>w) = (\<forall>x\<in>A. x = \<bottom>\<^sub>o\<^sub>w)"
    "(\<bottom>\<^sub>o\<^sub>w = \<Squnion>\<^sub>o\<^sub>w A) = (\<forall>x\<in>A. x = \<bottom>\<^sub>o\<^sub>w)"
    is complete_lattice_class.Sup_bot_conv.

tts_lemma Inf_top_conv:
  assumes "A \<subseteq> U"
  shows
    "(\<Sqinter>\<^sub>o\<^sub>w A = \<top>\<^sub>o\<^sub>w) = (\<forall>x\<in>A. x = \<top>\<^sub>o\<^sub>w)"
    "(\<top>\<^sub>o\<^sub>w = \<Sqinter>\<^sub>o\<^sub>w A) = (\<forall>x\<in>A. x = \<top>\<^sub>o\<^sub>w)"
    is complete_lattice_class.Inf_top_conv.

tts_lemma Inf_le_Sup:
  assumes "A \<subseteq> U" and "A \<noteq> {}"
  shows "\<Sqinter>\<^sub>o\<^sub>w A \<le>\<^sub>o\<^sub>w \<Squnion>\<^sub>o\<^sub>w A"
    is complete_lattice_class.Inf_le_Sup.

tts_lemma INF_UNIV_bool_expand:
  assumes "range A \<subseteq> U"
  shows "\<Sqinter>\<^sub>o\<^sub>w (range A) = A True \<sqinter>\<^sub>o\<^sub>w A False"
    is complete_lattice_class.INF_UNIV_bool_expand.

tts_lemma SUP_UNIV_bool_expand:
  assumes "range A \<subseteq> U"
  shows "\<Squnion>\<^sub>o\<^sub>w (range A) = A True \<squnion>\<^sub>o\<^sub>w A False"
    is complete_lattice_class.SUP_UNIV_bool_expand.

tts_lemma Sup_mono:
  assumes "A \<subseteq> U" and "B \<subseteq> U" and "\<And>a. a \<in> A \<Longrightarrow> Bex B ((\<le>\<^sub>o\<^sub>w) a)"
  shows "\<Squnion>\<^sub>o\<^sub>w A \<le>\<^sub>o\<^sub>w \<Squnion>\<^sub>o\<^sub>w B"
    given complete_lattice_class.Sup_mono by simp

tts_lemma Inf_mono:
  assumes "B \<subseteq> U"
    and "A \<subseteq> U"
    and "\<And>b. b \<in> B \<Longrightarrow> \<exists>x\<in>A. x \<le>\<^sub>o\<^sub>w b"
  shows "\<Sqinter>\<^sub>o\<^sub>w A \<le>\<^sub>o\<^sub>w \<Sqinter>\<^sub>o\<^sub>w B"
    given complete_lattice_class.Inf_mono by simp

tts_lemma Sup_Inf_le:
  assumes "A \<subseteq> Pow U"
  shows "\<Squnion>\<^sub>o\<^sub>w
    (
      \<Sqinter>\<^sub>o\<^sub>w ` {x. x \<subseteq> U \<and> (\<exists>f\<in>{f. f ` Pow U \<subseteq> U}. x = f ` A \<and> (\<forall>Y\<in>A. f Y \<in> Y))}
    ) \<le>\<^sub>o\<^sub>w \<Sqinter>\<^sub>o\<^sub>w (\<Squnion>\<^sub>o\<^sub>w ` A)"
    is complete_lattice_class.Sup_Inf_le.

end

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting complete_lattice_ow_axioms and sup_bot.sl_neut.not_empty
  applying [
    OF Inf_closed' Sup_closed' inf_closed' sup_closed' bot_closed top_closed
    ]
begin

tts_lemma Inf_UNIV: "\<Sqinter>\<^sub>o\<^sub>w U = \<bottom>\<^sub>o\<^sub>w"
    is complete_lattice_class.Inf_UNIV.

tts_lemma Sup_UNIV: "\<Squnion>\<^sub>o\<^sub>w U = \<top>\<^sub>o\<^sub>w"
    is complete_lattice_class.Sup_UNIV.

end

context
  fixes U\<^sub>2 :: "'b set"
begin

lemmas [transfer_rule] =
  image_transfer[where ?'a='b]

tts_context
  tts: (?'a to U) and (?'b to \<open>U\<^sub>2::'b set\<close>)
  rewriting ctr_simps
  substituting complete_lattice_ow_axioms and sup_bot.sl_neut.not_empty
  eliminating through (insert Sup_least, auto)
begin

tts_lemma SUP_upper2:
  assumes "A \<subseteq> U\<^sub>2"
    and "u \<in> U"
    and "\<forall>x\<in>U\<^sub>2. f x \<in> U"
    and "i \<in> A"
    and "u \<le>\<^sub>o\<^sub>w f i"
  shows "u \<le>\<^sub>o\<^sub>w \<Squnion>\<^sub>o\<^sub>w (f ` A)"
  is complete_lattice_class.SUP_upper2.

tts_lemma INF_lower2:
  assumes "A \<subseteq> U\<^sub>2"
    and "\<forall>x\<in>U\<^sub>2. f x \<in> U"
    and "u \<in> U"
    and "i \<in> A"
    and "f i \<le>\<^sub>o\<^sub>w u"
  shows "\<Sqinter>\<^sub>o\<^sub>w (f ` A) \<le>\<^sub>o\<^sub>w u"
  is complete_lattice_class.INF_lower2.

tts_lemma less_INF_D:
  assumes "y \<in> U"
    and "\<forall>x\<in>U\<^sub>2. f x \<in> U"
    and "A \<subseteq> U\<^sub>2"
    and "y <\<^sub>o\<^sub>w \<Sqinter>\<^sub>o\<^sub>w (f ` A)"
    and "i \<in> A"
  shows "y <\<^sub>o\<^sub>w f i"
  is complete_lattice_class.less_INF_D.

tts_lemma SUP_lessD:
  assumes "\<forall>x\<in>U\<^sub>2. f x \<in> U"
    and "A \<subseteq> U\<^sub>2"
    and "y \<in> U"
    and "\<Squnion>\<^sub>o\<^sub>w (f ` A) <\<^sub>o\<^sub>w y"
    and "i \<in> A"
  shows "f i <\<^sub>o\<^sub>w y"
  is complete_lattice_class.SUP_lessD.

tts_lemma SUP_le_iff:
  assumes "\<forall>x\<in>U\<^sub>2. f x \<in> U" and "A \<subseteq> U\<^sub>2" and "u \<in> U"
  shows "(\<Squnion>\<^sub>o\<^sub>w (f ` A) \<le>\<^sub>o\<^sub>w u) = (\<forall>x\<in>A. f x \<le>\<^sub>o\<^sub>w u)"
    is complete_lattice_class.SUP_le_iff.

end

end

tts_context
  tts: (?'a to U) and (?'b to \<open>U\<^sub>2::'b set\<close>)
  rewriting ctr_simps
  substituting complete_lattice_ow_axioms and sup_bot.sl_neut.not_empty
  eliminating through (auto dest: top_le)
begin

tts_lemma INF_eqI:
  assumes "A \<subseteq> U\<^sub>2"
    and "x \<in> U"
    and "\<forall>x\<in>U\<^sub>2. f x \<in> U"
    and "\<And>i. \<lbrakk>i \<in> U\<^sub>2; i \<in> A\<rbrakk> \<Longrightarrow> x \<le>\<^sub>o\<^sub>w f i"
    and "\<And>y. \<lbrakk>y \<in> U; \<And>i. \<lbrakk>i \<in> U\<^sub>2; i \<in> A\<rbrakk> \<Longrightarrow> y \<le>\<^sub>o\<^sub>w f i\<rbrakk> \<Longrightarrow> y \<le>\<^sub>o\<^sub>w x"
  shows "\<Sqinter>\<^sub>o\<^sub>w (f ` A) = x"
  is complete_lattice_class.INF_eqI.

end

tts_context
  tts: (?'a to U) and (?'b to \<open>U\<^sub>2::'b set\<close>)
  rewriting ctr_simps
  substituting complete_lattice_ow_axioms and sup_bot.sl_neut.not_empty
  eliminating through (auto simp: order.eq_iff)
begin

tts_lemma SUP_eqI:
  assumes "A \<subseteq> U\<^sub>2"
    and "\<forall>x\<in>U\<^sub>2. f x \<in> U"
    and "x \<in> U"
    and "\<And>i. \<lbrakk>i \<in> U\<^sub>2; i \<in> A\<rbrakk> \<Longrightarrow> f i \<le>\<^sub>o\<^sub>w x"
    and "\<And>y. \<lbrakk>y \<in> U; \<And>i. \<lbrakk>i \<in> U\<^sub>2; i \<in> A\<rbrakk> \<Longrightarrow> f i \<le>\<^sub>o\<^sub>w y\<rbrakk> \<Longrightarrow> x \<le>\<^sub>o\<^sub>w y"
  shows "\<Squnion>\<^sub>o\<^sub>w (f ` A) = x"
    is complete_lattice_class.SUP_eqI.

end

tts_context
  tts: (?'a to U) and (?'b to \<open>U\<^sub>2::'b set\<close>)
  rewriting ctr_simps
  substituting complete_lattice_ow_axioms and sup_bot.sl_neut.not_empty
  eliminating through simp
begin

tts_lemma INF_le_SUP:
  assumes "A \<subseteq> U\<^sub>2" and "\<forall>x\<in>U\<^sub>2. f x \<in> U" and "A \<noteq> {}"
  shows "\<Sqinter>\<^sub>o\<^sub>w (f ` A) \<le>\<^sub>o\<^sub>w \<Squnion>\<^sub>o\<^sub>w (f ` A)"
  is complete_lattice_class.INF_le_SUP.

tts_lemma INF_inf_const1:
  assumes "I \<subseteq> U\<^sub>2" and "x \<in> U" and "\<forall>x\<in>U\<^sub>2. f x \<in> U" and "I \<noteq> {}"
  shows "\<Sqinter>\<^sub>o\<^sub>w ((\<lambda>i. x \<sqinter>\<^sub>o\<^sub>w f i) ` I) = x \<sqinter>\<^sub>o\<^sub>w \<Sqinter>\<^sub>o\<^sub>w (f ` I)"
    is complete_lattice_class.INF_inf_const1.

tts_lemma INF_inf_const2:
  assumes "I \<subseteq> U\<^sub>2" and "\<forall>x\<in>U\<^sub>2. f x \<in> U" and "x \<in> U" and "I \<noteq> {}"
  shows "\<Sqinter>\<^sub>o\<^sub>w ((\<lambda>i. f i \<sqinter>\<^sub>o\<^sub>w x) ` I) = \<Sqinter>\<^sub>o\<^sub>w (f ` I) \<sqinter>\<^sub>o\<^sub>w x"
    is complete_lattice_class.INF_inf_const2.

end

tts_context
  tts: (?'a to U) and (?'b to \<open>U\<^sub>2::'b set\<close>)
  rewriting ctr_simps
  substituting complete_lattice_ow_axioms and sup_bot.sl_neut.not_empty
  eliminating through auto
begin

tts_lemma INF_eq_const:
  assumes "I \<subseteq> U\<^sub>2"
    and "\<forall>x\<in>U\<^sub>2. f x \<in> U"
    and "I \<noteq> {}"
    and "\<And>i. i \<in> I \<Longrightarrow> f i = x"
  shows "\<Sqinter>\<^sub>o\<^sub>w (f ` I) = x"
    given complete_lattice_class.INF_eq_const
proof-
  assume
    "\<lbrakk>I \<subseteq> U\<^sub>2; \<forall>x\<in>U\<^sub>2. f x \<in> U; I \<noteq> {}; \<And>i. \<lbrakk>i \<in> U\<^sub>2; i \<in> I\<rbrakk> \<Longrightarrow> f i = x\<rbrakk> \<Longrightarrow>
      \<Sqinter>\<^sub>o\<^sub>w (f ` I) = x"
    for I :: "'a set" and U\<^sub>2 f x
  then have
    "\<lbrakk>I \<subseteq> U\<^sub>2; \<forall>x\<in>U\<^sub>2. f x \<in> U; I \<noteq> {}; \<And>i. i \<in> I \<Longrightarrow> f i = x\<rbrakk> \<Longrightarrow>
      \<Sqinter>\<^sub>o\<^sub>w (f ` I) = x"
    by presburger
  then show "\<Sqinter>\<^sub>o\<^sub>w (f ` I) = x" using assms by simp
qed

tts_lemma SUP_eq_const:
  assumes "I \<subseteq> U\<^sub>2"
    and "\<forall>x\<in>U\<^sub>2. f x \<in> U"
    and "I \<noteq> {}"
    and "\<And>i. i \<in> I \<Longrightarrow> f i = x"
  shows "\<Squnion>\<^sub>o\<^sub>w (f ` I) = x"
    given complete_lattice_class.SUP_eq_const
proof-
  assume
    "\<lbrakk>I \<subseteq> U\<^sub>2; \<forall>x\<in>U\<^sub>2. f x \<in> U; I \<noteq> {}; \<And>i. \<lbrakk>i \<in> U\<^sub>2; i \<in> I\<rbrakk> \<Longrightarrow> f i = x\<rbrakk> \<Longrightarrow>
      \<Squnion>\<^sub>o\<^sub>w (f ` I) = x"
    for I :: "'a set" and U\<^sub>2 f x
  then have
    "\<lbrakk>I \<subseteq> U\<^sub>2; \<forall>x\<in>U\<^sub>2. f x \<in> U; I \<noteq> {}; \<And>i. i \<in> I \<Longrightarrow> f i = x\<rbrakk> \<Longrightarrow>
      \<Squnion>\<^sub>o\<^sub>w (f ` I) = x"
    by presburger
  then show "\<Squnion>\<^sub>o\<^sub>w (f ` I) = x" using assms by simp
qed

tts_lemma SUP_eq_iff:
  assumes "I \<subseteq> U\<^sub>2"
    and "c \<in> U"
    and "\<forall>x\<in>U\<^sub>2. f x \<in> U"
    and "I \<noteq> {}"
    and "\<And>i. i \<in> I \<Longrightarrow> c \<le>\<^sub>o\<^sub>w f i"
  shows "(\<Squnion>\<^sub>o\<^sub>w (f ` I) = c) = (\<forall>x\<in>I. f x = c)"
    given complete_lattice_class.SUP_eq_iff
proof-
  assume
    "\<lbrakk>
      I \<subseteq> U\<^sub>2;
      c \<in> U; \<forall>x\<in>U\<^sub>2. f x \<in> U;
      I \<noteq> {};
      \<And>i. \<lbrakk>i \<in> U\<^sub>2; i \<in> I\<rbrakk> \<Longrightarrow> c \<le>\<^sub>o\<^sub>w f i
    \<rbrakk> \<Longrightarrow>  (\<Squnion>\<^sub>o\<^sub>w (f ` I) = c) = (\<forall>x\<in>I. f x = c)"
    for I :: "'a set" and U\<^sub>2 c f
  then have
    "\<lbrakk>
      I \<subseteq> U\<^sub>2;
      c \<in> U; \<forall>x\<in>U\<^sub>2. f x \<in> U;
      I \<noteq> {};
      \<And>i. i \<in> I \<Longrightarrow> c \<le>\<^sub>o\<^sub>w f i
    \<rbrakk> \<Longrightarrow> (\<Squnion>\<^sub>o\<^sub>w (f ` I) = c) = (\<forall>x\<in>I. f x = c)"
    by presburger
  then show "(\<Squnion>\<^sub>o\<^sub>w (f ` I) = c) = (\<forall>x\<in>I. f x = c)" using assms by auto
qed

tts_lemma INF_eq_iff:
  assumes "I \<subseteq> U\<^sub>2"
    and "\<forall>x\<in>U\<^sub>2. f x \<in> U"
    and "c \<in> U"
    and "I \<noteq> {}"
    and "\<And>i. i \<in> I \<Longrightarrow> f i \<le>\<^sub>o\<^sub>w c"
  shows "(\<Sqinter>\<^sub>o\<^sub>w (f ` I) = c) = (\<forall>x\<in>I. f x = c)"
    given complete_lattice_class.INF_eq_iff
proof-
  assume
    "\<lbrakk>
      I \<subseteq> U\<^sub>2;
      \<forall>x\<in>U\<^sub>2. f x \<in> U; c \<in> U;
      I \<noteq> {};
      \<And>i. \<lbrakk>i \<in> U\<^sub>2; i \<in> I\<rbrakk> \<Longrightarrow> f i \<le>\<^sub>o\<^sub>w c
    \<rbrakk> \<Longrightarrow> (\<Sqinter>\<^sub>o\<^sub>w (f ` I) = c) = (\<forall>x\<in>I. f x = c)"
    for I :: "'a set" and U\<^sub>2 f c
  then have
    "\<lbrakk>
      I \<subseteq> U\<^sub>2;
      \<forall>x\<in>U\<^sub>2. f x \<in> U; c \<in> U;
      I \<noteq> {};
      \<And>i. i \<in> I \<Longrightarrow> f i \<le>\<^sub>o\<^sub>w c
    \<rbrakk> \<Longrightarrow> (\<Sqinter>\<^sub>o\<^sub>w (f ` I) = c) = (\<forall>x\<in>I. f x = c)"
    by presburger
  then show "(\<Sqinter>\<^sub>o\<^sub>w (f ` I) = c) = (\<forall>x\<in>I. f x = c)" using assms by auto
qed

end

context
  fixes U\<^sub>2 :: "'b set"
begin

lemmas [transfer_rule] =
  image_transfer[where ?'a='b]

tts_context
  tts: (?'a to U) and (?'b to \<open>U\<^sub>2::'b set\<close>)
  rewriting ctr_simps
  substituting complete_lattice_ow_axioms and sup_bot.sl_neut.not_empty
  eliminating through (auto simp: sup_bot.top_unique top_le intro: Sup_least)
begin

tts_lemma INF_insert:
  assumes "\<forall>x\<in>U\<^sub>2. f x \<in> U" and "a \<in> U\<^sub>2" and "A \<subseteq> U\<^sub>2"
  shows "\<Sqinter>\<^sub>o\<^sub>w (f ` insert a A) = f a \<sqinter>\<^sub>o\<^sub>w \<Sqinter>\<^sub>o\<^sub>w (f ` A)"
  is complete_lattice_class.INF_insert.

tts_lemma SUP_insert:
  assumes "\<forall>x\<in>U\<^sub>2. f x \<in> U" and "a \<in> U\<^sub>2" and "A \<subseteq> U\<^sub>2"
  shows "\<Squnion>\<^sub>o\<^sub>w (f ` insert a A) = f a \<squnion>\<^sub>o\<^sub>w \<Squnion>\<^sub>o\<^sub>w (f ` A)"
    is complete_lattice_class.SUP_insert.

tts_lemma le_INF_iff:
  assumes "u \<in> U" and "\<forall>x\<in>U\<^sub>2. f x \<in> U" and "A \<subseteq> U\<^sub>2"
  shows "(u \<le>\<^sub>o\<^sub>w \<Sqinter>\<^sub>o\<^sub>w (f ` A)) = (\<forall>x\<in>A. u \<le>\<^sub>o\<^sub>w f x)"
  is complete_lattice_class.le_INF_iff.

tts_lemma INF_union:
  assumes "\<forall>x\<in>U\<^sub>2. M x \<in> U" and "A \<subseteq> U\<^sub>2" and "B \<subseteq> U\<^sub>2"
  shows "\<Sqinter>\<^sub>o\<^sub>w (M ` (A \<union> B)) = \<Sqinter>\<^sub>o\<^sub>w (M ` A) \<sqinter>\<^sub>o\<^sub>w \<Sqinter>\<^sub>o\<^sub>w (M ` B)"
    is complete_lattice_class.INF_union.

tts_lemma SUP_union:
  assumes "\<forall>x\<in>U\<^sub>2. M x \<in> U" and "A \<subseteq> U\<^sub>2" and "B \<subseteq> U\<^sub>2"
  shows "\<Squnion>\<^sub>o\<^sub>w (M ` (A \<union> B)) = \<Squnion>\<^sub>o\<^sub>w (M ` A) \<squnion>\<^sub>o\<^sub>w \<Squnion>\<^sub>o\<^sub>w (M ` B)"
  is complete_lattice_class.SUP_union.

tts_lemma SUP_bot_conv:
  assumes "\<forall>x\<in>U\<^sub>2. B x \<in> U" and "A \<subseteq> U\<^sub>2"
  shows
    "(\<Squnion>\<^sub>o\<^sub>w (B ` A) = \<bottom>\<^sub>o\<^sub>w) = (\<forall>x\<in>A. B x = \<bottom>\<^sub>o\<^sub>w)"
    "(\<bottom>\<^sub>o\<^sub>w = \<Squnion>\<^sub>o\<^sub>w (B ` A)) = (\<forall>x\<in>A. B x = \<bottom>\<^sub>o\<^sub>w)"
  is complete_lattice_class.SUP_bot_conv.

tts_lemma INF_top_conv:
  assumes "\<forall>x\<in>U\<^sub>2. B x \<in> U" and "A \<subseteq> U\<^sub>2"
  shows
    "(\<Sqinter>\<^sub>o\<^sub>w (B ` A) = \<top>\<^sub>o\<^sub>w) = (\<forall>x\<in>A. B x = \<top>\<^sub>o\<^sub>w)"
    "(\<top>\<^sub>o\<^sub>w = \<Sqinter>\<^sub>o\<^sub>w (B ` A)) = (\<forall>x\<in>A. B x = \<top>\<^sub>o\<^sub>w)"
  is complete_lattice_class.INF_top_conv.

tts_lemma SUP_upper:
  assumes "A \<subseteq> U\<^sub>2" and "\<forall>x\<in>U\<^sub>2. f x \<in> U" and "i \<in> A"
  shows "f i \<le>\<^sub>o\<^sub>w \<Squnion>\<^sub>o\<^sub>w (f ` A)"
  is complete_lattice_class.SUP_upper.

tts_lemma INF_lower:
  assumes "A \<subseteq> U\<^sub>2" and "\<forall>x\<in>U\<^sub>2. f x \<in> U" and "i \<in> A"
  shows "\<Sqinter>\<^sub>o\<^sub>w (f ` A) \<le>\<^sub>o\<^sub>w f i"
  is complete_lattice_class.INF_lower.

tts_lemma INF_inf_distrib:
  assumes "\<forall>x\<in>U\<^sub>2. f x \<in> U" and "A \<subseteq> U\<^sub>2" and "\<forall>x\<in>U\<^sub>2. g x \<in> U"
  shows "\<Sqinter>\<^sub>o\<^sub>w (f ` A) \<sqinter>\<^sub>o\<^sub>w \<Sqinter>\<^sub>o\<^sub>w (g ` A) = \<Sqinter>\<^sub>o\<^sub>w ((\<lambda>a. f a \<sqinter>\<^sub>o\<^sub>w g a) ` A)"
    is complete_lattice_class.INF_inf_distrib.

tts_lemma SUP_sup_distrib:
  assumes "\<forall>x\<in>U\<^sub>2. f x \<in> U" and "A \<subseteq> U\<^sub>2" and "\<forall>x\<in>U\<^sub>2. g x \<in> U"
  shows "\<Squnion>\<^sub>o\<^sub>w (f ` A) \<squnion>\<^sub>o\<^sub>w \<Squnion>\<^sub>o\<^sub>w (g ` A) = \<Squnion>\<^sub>o\<^sub>w ((\<lambda>a. f a \<squnion>\<^sub>o\<^sub>w g a) ` A)"
    is complete_lattice_class.SUP_sup_distrib.

tts_lemma SUP_subset_mono:
  assumes "B \<subseteq> U\<^sub>2"
    and "\<forall>x\<in>U\<^sub>2. f x \<in> U"
    and "\<forall>x\<in>U\<^sub>2. g x \<in> U"
    and "A \<subseteq> B"
    and "\<And>x. x \<in> A \<Longrightarrow> f x \<le>\<^sub>o\<^sub>w g x"
  shows "\<Squnion>\<^sub>o\<^sub>w (f ` A) \<le>\<^sub>o\<^sub>w \<Squnion>\<^sub>o\<^sub>w (g ` B)"
    given complete_lattice_class.SUP_subset_mono
proof-
  assume
    "\<lbrakk>
      B \<subseteq> U\<^sub>2;
      \<forall>x\<in>U\<^sub>2. f x \<in> U;
      \<forall>x\<in>U\<^sub>2. g x \<in> U;
      A \<subseteq> B;
      \<And>x. \<lbrakk>x \<in> U\<^sub>2; x \<in> A\<rbrakk> \<Longrightarrow> f x \<le>\<^sub>o\<^sub>w g x
    \<rbrakk> \<Longrightarrow> \<Squnion>\<^sub>o\<^sub>w (f ` A) \<le>\<^sub>o\<^sub>w \<Squnion>\<^sub>o\<^sub>w (g ` B)"
    for B :: "'b set" and f g A
  then have
    "\<lbrakk>
      B \<subseteq> U\<^sub>2;
      \<forall>x\<in>U\<^sub>2. f x \<in> U;
      \<forall>x\<in>U\<^sub>2. g x \<in> U;
      A \<subseteq> B;
      \<And>x. x \<in> A \<Longrightarrow> f x \<le>\<^sub>o\<^sub>w g x
    \<rbrakk> \<Longrightarrow> \<Squnion>\<^sub>o\<^sub>w (f ` A) \<le>\<^sub>o\<^sub>w \<Squnion>\<^sub>o\<^sub>w (g ` B)"
    by auto
  then show "\<Squnion>\<^sub>o\<^sub>w (f ` A) \<le>\<^sub>o\<^sub>w \<Squnion>\<^sub>o\<^sub>w (g ` B)" using assms by blast
qed

tts_lemma INF_superset_mono:
  assumes "A \<subseteq> U\<^sub>2"
    and "\<forall>x\<in>U\<^sub>2. f x \<in> U"
    and "\<forall>x\<in>U\<^sub>2. g x \<in> U"
    and "B \<subseteq> A"
    and "\<And>x. \<lbrakk>x \<in> U\<^sub>2; x \<in> B\<rbrakk> \<Longrightarrow> f x \<le>\<^sub>o\<^sub>w g x"
  shows "\<Sqinter>\<^sub>o\<^sub>w (f ` A) \<le>\<^sub>o\<^sub>w \<Sqinter>\<^sub>o\<^sub>w (g ` B)"
    given complete_lattice_class.INF_superset_mono
proof-
  assume
    "\<lbrakk>
      A \<subseteq> U\<^sub>2;
      \<forall>x\<in>U\<^sub>2. f x \<in> U;
      \<forall>x\<in>U\<^sub>2. g x \<in> U;
      B \<subseteq> A;
      \<And>x. \<lbrakk>x \<in> U\<^sub>2; x \<in> B\<rbrakk> \<Longrightarrow> f x \<le>\<^sub>o\<^sub>w g x
    \<rbrakk> \<Longrightarrow> \<Sqinter>\<^sub>o\<^sub>w (f ` A) \<le>\<^sub>o\<^sub>w \<Sqinter>\<^sub>o\<^sub>w (g ` B)"
    for A :: "'b set" and f g B
  then have
    "\<lbrakk>
      A \<subseteq> U\<^sub>2;
      \<forall>x\<in>U\<^sub>2. f x \<in> U;
      \<forall>x\<in>U\<^sub>2. g x \<in> U;
      B \<subseteq> A;
      \<And>x. x \<in> B \<Longrightarrow> f x \<le>\<^sub>o\<^sub>w g x
    \<rbrakk> \<Longrightarrow> \<Sqinter>\<^sub>o\<^sub>w (f ` A) \<le>\<^sub>o\<^sub>w \<Sqinter>\<^sub>o\<^sub>w (g ` B)"
    by auto
  then show "\<Sqinter>\<^sub>o\<^sub>w (f ` A) \<le>\<^sub>o\<^sub>w \<Sqinter>\<^sub>o\<^sub>w (g ` B)" using assms by blast
qed

tts_lemma INF_absorb:
  assumes "I \<subseteq> U\<^sub>2" and "\<forall>x\<in>U\<^sub>2. A x \<in> U" and "k \<in> I"
  shows "A k \<sqinter>\<^sub>o\<^sub>w \<Sqinter>\<^sub>o\<^sub>w (A ` I) = \<Sqinter>\<^sub>o\<^sub>w (A ` I)"
    is complete_lattice_class.INF_absorb.

tts_lemma SUP_absorb:
  assumes "I \<subseteq> U\<^sub>2" and "\<forall>x\<in>U\<^sub>2. A x \<in> U" and "k \<in> I"
  shows "A k \<squnion>\<^sub>o\<^sub>w \<Squnion>\<^sub>o\<^sub>w (A ` I) = \<Squnion>\<^sub>o\<^sub>w (A ` I)"
    is complete_lattice_class.SUP_absorb.

end

end

context
  fixes f :: "'b \<Rightarrow> 'al" and U\<^sub>2 :: "'b set"
  assumes f[transfer_rule]: "\<forall>x \<in> U\<^sub>2. f x = \<bottom>\<^sub>o\<^sub>w"
begin

tts_context
  tts: (?'a to U) and (?'b to \<open>U\<^sub>2::'b set\<close>)
  sbterms: (\<open>Orderings.bot::?'a::complete_lattice\<close> to \<open>\<bottom>\<^sub>o\<^sub>w\<close>)
  rewriting ctr_simps
  substituting complete_lattice_ow_axioms and sup_bot.sl_neut.not_empty
  eliminating through simp
begin

tts_lemma SUP_bot:
  assumes "A \<subseteq> U\<^sub>2"
  shows "\<Squnion>\<^sub>o\<^sub>w (f ` A) = \<bottom>\<^sub>o\<^sub>w"
    is complete_lattice_class.SUP_bot[folded const_fun_def].

end

end

context
  fixes f :: "'b \<Rightarrow> 'al" and U\<^sub>2 :: "'b set"
  assumes f[transfer_rule]: "\<forall>x \<in> U\<^sub>2. f x = \<top>\<^sub>o\<^sub>w"
begin

tts_context
  tts: (?'a to U) and (?'b to \<open>U\<^sub>2::'b set\<close>)
  sbterms: (\<open>Orderings.top::?'a::complete_lattice\<close> to \<open>\<top>\<^sub>o\<^sub>w\<close>)
  rewriting ctr_simps
  substituting complete_lattice_ow_axioms and sup_bot.sl_neut.not_empty
  eliminating through simp
begin

tts_lemma INF_top:
  assumes "A \<subseteq> U\<^sub>2"
  shows "\<Sqinter>\<^sub>o\<^sub>w (f ` A) = \<top>\<^sub>o\<^sub>w"
  is complete_lattice_class.INF_top[folded const_fun_def].

end

end

context
  fixes f :: "'b \<Rightarrow> 'al" and c and F and U\<^sub>2 :: "'b set"
  assumes c_closed[transfer_rule]: "c \<in> U"
  assumes f[transfer_rule]: "\<forall>x \<in> U\<^sub>2. f x = c"
begin

tts_register_sbts \<open>c\<close> | U
proof-
  assume ALC: "Domainp ALC = (\<lambda>x. x \<in> U)"
  have "Domainp ALC c" unfolding ALC by (simp add: c_closed)
  then obtain c' where "ALC c c'" by blast
  then show "\<exists>c'. ALC c c'" by auto
qed

tts_context
  tts: (?'a to U) and (?'b to \<open>U\<^sub>2::'b set\<close>)
  sbterms: (\<open>?c::?'a::complete_lattice\<close> to \<open>c\<close>)
  rewriting ctr_simps
  substituting complete_lattice_ow_axioms and sup_bot.sl_neut.not_empty
  eliminating through simp
begin

tts_lemma INF_constant:
  assumes "A \<subseteq> U\<^sub>2"
  shows "\<Sqinter>\<^sub>o\<^sub>w (f ` A) = (if A = {} then \<top>\<^sub>o\<^sub>w else c)"
    is complete_lattice_class.INF_constant[folded const_fun_def].

tts_lemma SUP_constant:
  assumes "A \<subseteq> U\<^sub>2"
  shows "\<Squnion>\<^sub>o\<^sub>w (f ` A) = (if A = {} then \<bottom>\<^sub>o\<^sub>w else c)"
    is complete_lattice_class.SUP_constant[folded const_fun_def].

end

tts_context
  tts: (?'a to U) and (?'b to \<open>U\<^sub>2::'b set\<close>)
  sbterms: (\<open>?f::?'a::complete_lattice\<close> to \<open>c\<close>)
  rewriting ctr_simps
  substituting complete_lattice_ow_axioms and sup_bot.sl_neut.not_empty
  eliminating through simp
begin

tts_lemma INF_const:
  assumes "A \<subseteq> U\<^sub>2" and "A \<noteq> {}"
  shows "\<Sqinter>\<^sub>o\<^sub>w ((\<lambda>i. c) ` A) = c"
    is complete_lattice_class.INF_const.

tts_lemma SUP_const:
  assumes "A \<subseteq> U\<^sub>2" and "A \<noteq> {}"
  shows "\<Squnion>\<^sub>o\<^sub>w ((\<lambda>i. c) ` A) = c"
    is complete_lattice_class.SUP_const.

end

end

end

context complete_lattice_ow
begin

tts_context
  tts: (?'a to U) and (?'b to \<open>U\<^sub>2::'b set\<close>) and (?'c to \<open>U\<^sub>3::'c set\<close>)
  rewriting ctr_simps
  substituting complete_lattice_ow_axioms and sup_bot.sl_neut.not_empty
  eliminating \<open>?U \<noteq> {}\<close> through (force simp: subset_iff INF_top equals0D)
  applying [
    OF Inf_closed' Sup_closed' inf_closed' sup_closed' bot_closed top_closed
    ]
begin

tts_lemma SUP_eq:
  assumes "A \<subseteq> U\<^sub>2"
    and "B \<subseteq> U\<^sub>3"
    and "\<forall>x\<in>U\<^sub>2. f (x::'a) \<in> U"
    and "\<forall>x\<in>U\<^sub>3. g x \<in> U"
    and "\<And>i. i \<in> A \<Longrightarrow> \<exists>x\<in>B. f i \<le>\<^sub>o\<^sub>w g x"
    and "\<And>j. j \<in> B \<Longrightarrow> \<exists>x\<in>A. g j \<le>\<^sub>o\<^sub>w f x"
  shows "\<Squnion>\<^sub>o\<^sub>w (f ` A) = \<Squnion>\<^sub>o\<^sub>w (g ` B)"
    given complete_lattice_class.SUP_eq
proof-
  assume
    "\<lbrakk>
      A \<subseteq> U\<^sub>2;
      B \<subseteq> U\<^sub>3;
      \<forall>x\<in>U\<^sub>2. f x \<in> U;
      \<forall>x\<in>U\<^sub>3. g x \<in> U;
      \<And>i. \<lbrakk>i \<in> U\<^sub>2; i \<in> A\<rbrakk> \<Longrightarrow> \<exists>x\<in>B. f i \<le>\<^sub>o\<^sub>w g x;
      \<And>j. \<lbrakk>j \<in> U\<^sub>3; j \<in> B\<rbrakk> \<Longrightarrow> \<exists>x\<in>A. g j \<le>\<^sub>o\<^sub>w f x
    \<rbrakk> \<Longrightarrow> \<Squnion>\<^sub>o\<^sub>w (f ` A) = \<Squnion>\<^sub>o\<^sub>w (g ` B)"
    for A :: "'a set" and U\<^sub>2 and B :: "'b set" and U\<^sub>3 f g
  then have
    "\<lbrakk>
      A \<subseteq> U\<^sub>2;
      B \<subseteq> U\<^sub>3;
      \<forall>x\<in>U\<^sub>2. f x \<in> U;
      \<forall>x\<in>U\<^sub>3. g x \<in> U;
      \<And>i. i \<in> A \<Longrightarrow> \<exists>x\<in>B. f i \<le>\<^sub>o\<^sub>w g x;
      \<And>j. j \<in> B \<Longrightarrow> \<exists>x\<in>A. g j \<le>\<^sub>o\<^sub>w f x
    \<rbrakk> \<Longrightarrow> \<Squnion>\<^sub>o\<^sub>w (f ` A) = \<Squnion>\<^sub>o\<^sub>w (g ` B)"
    by simp
  then show "\<Squnion>\<^sub>o\<^sub>w (f ` A) = \<Squnion>\<^sub>o\<^sub>w (g ` B)" using assms by simp
qed

tts_lemma INF_eq:
  assumes "A \<subseteq> U\<^sub>2"
    and "B \<subseteq> U\<^sub>3"
    and "\<forall>x\<in>U\<^sub>3. g x \<in> U"
    and "\<forall>x\<in>U\<^sub>2. f (x::'a) \<in> U"
    and "\<And>i. i \<in> A \<Longrightarrow> \<exists>x\<in>B. g x \<le>\<^sub>o\<^sub>w f i"
    and "\<And>j. j \<in> B \<Longrightarrow> \<exists>x\<in>A. f x \<le>\<^sub>o\<^sub>w g j"
  shows "\<Sqinter>\<^sub>o\<^sub>w (f ` A) = \<Sqinter>\<^sub>o\<^sub>w (g ` B)"
    given complete_lattice_class.INF_eq
proof-
  assume
    "\<lbrakk>
      A \<subseteq> U\<^sub>2;
      B \<subseteq> U\<^sub>3;
      \<forall>x\<in>U\<^sub>3. g x \<in> U;
      \<forall>x\<in>U\<^sub>2. f x \<in> U;
      \<And>i. \<lbrakk>i \<in> U\<^sub>2; i \<in> A\<rbrakk> \<Longrightarrow> \<exists>x\<in>B. g x \<le>\<^sub>o\<^sub>w f i;
      \<And>j. \<lbrakk>j \<in> U\<^sub>3; j \<in> B\<rbrakk> \<Longrightarrow> \<exists>x\<in>A. f x \<le>\<^sub>o\<^sub>w g j
    \<rbrakk> \<Longrightarrow> \<Sqinter>\<^sub>o\<^sub>w (f ` A) = \<Sqinter>\<^sub>o\<^sub>w (g ` B)"
    for A :: "'a set" and U\<^sub>2 and B :: "'b set" and U\<^sub>3 g f
  then have
    "\<lbrakk>
      A \<subseteq> U\<^sub>2;
      B \<subseteq> U\<^sub>3;
      \<forall>x\<in>U\<^sub>3. g x \<in> U;
      \<forall>x\<in>U\<^sub>2. f x \<in> U;
      \<And>i. i \<in> A \<Longrightarrow> \<exists>x\<in>B. g x \<le>\<^sub>o\<^sub>w f i;
      \<And>j. j \<in> B \<Longrightarrow> \<exists>x\<in>A. f x \<le>\<^sub>o\<^sub>w g j
    \<rbrakk> \<Longrightarrow> \<Sqinter>\<^sub>o\<^sub>w (f ` A) = \<Sqinter>\<^sub>o\<^sub>w (g ` B)"
    by simp
  then show "\<Sqinter>\<^sub>o\<^sub>w (f ` A) = \<Sqinter>\<^sub>o\<^sub>w (g ` B)" using assms by simp
qed

end

end

context complete_lattice_ow
begin

context
  fixes U\<^sub>2 :: "'b set" and U\<^sub>3 :: "'c set"
begin

lemmas [transfer_rule] =
  image_transfer[where ?'a='b]
  image_transfer[where ?'a='c]

tts_context
  tts: (?'a to U) and (?'b to \<open>U\<^sub>2::'b set\<close>) and (?'c to \<open>U\<^sub>3::'c set\<close>)
  rewriting ctr_simps
  substituting complete_lattice_ow_axioms and sup_bot.sl_neut.not_empty
  applying [
    OF _ _ Inf_closed' Sup_closed' inf_closed' sup_closed' bot_closed top_closed
    ]
begin

tts_lemma ne_INF_commute:
  assumes "U\<^sub>2 \<noteq> {}"
    and "U\<^sub>3 \<noteq> {}"
    and "\<forall>x\<in>U\<^sub>2. \<forall>y\<in>U\<^sub>3. f (x::'b) y \<in> U"
    and "B \<subseteq> U\<^sub>3"
    and "A \<subseteq> U\<^sub>2"
  shows "\<Sqinter>\<^sub>o\<^sub>w ((\<lambda>i. \<Sqinter>\<^sub>o\<^sub>w (f i ` B)) ` A) = \<Sqinter>\<^sub>o\<^sub>w ((\<lambda>j. \<Sqinter>\<^sub>o\<^sub>w ((\<lambda>i. f i j) ` A)) ` B)"
    is complete_lattice_class.INF_commute.

tts_lemma ne_SUP_commute:
  assumes "U\<^sub>2 \<noteq> {}"
    and "U\<^sub>3 \<noteq> {}"
    and "\<forall>x\<in>U\<^sub>2. \<forall>y\<in>U\<^sub>3. f (x::'b) y \<in> U"
    and "B \<subseteq> U\<^sub>3"
    and "A \<subseteq> U\<^sub>2"
  shows "\<Squnion>\<^sub>o\<^sub>w ((\<lambda>i. \<Squnion>\<^sub>o\<^sub>w (f i ` B)) ` A) = \<Squnion>\<^sub>o\<^sub>w ((\<lambda>j. \<Squnion>\<^sub>o\<^sub>w ((\<lambda>i. f i j) ` A)) ` B)"
    is complete_lattice_class.SUP_commute.

tts_lemma ne_SUP_mono:
  assumes "U\<^sub>2 \<noteq> {}"
    and "U\<^sub>3 \<noteq> {}"
    and "A \<subseteq> U\<^sub>2"
    and "B \<subseteq> U\<^sub>3"
    and "\<forall>x\<in>U\<^sub>2. f (x::'b) \<in> U"
    and "\<forall>x\<in>U\<^sub>3. g x \<in> U"
    and "\<And>n. \<lbrakk>n \<in> U\<^sub>2; n \<in> A\<rbrakk> \<Longrightarrow> \<exists>x\<in>B. f n \<le>\<^sub>o\<^sub>w g x"
  shows "\<Squnion>\<^sub>o\<^sub>w (f ` A) \<le>\<^sub>o\<^sub>w \<Squnion>\<^sub>o\<^sub>w (g ` B)"
    is complete_lattice_class.SUP_mono.

tts_lemma ne_INF_mono:
  assumes "U\<^sub>2 \<noteq> {}"
    and "U\<^sub>3 \<noteq> {}"
    and "B \<subseteq> U\<^sub>2"
    and "A \<subseteq> U\<^sub>3"
    and "\<forall>x\<in>U\<^sub>3. f x \<in> U"
    and "\<forall>x\<in>U\<^sub>2. g (x::'b) \<in> U"
    and "\<And>m. \<lbrakk>m \<in> U\<^sub>2; m \<in> B\<rbrakk> \<Longrightarrow> \<exists>x\<in>A. f x \<le>\<^sub>o\<^sub>w g m"
  shows "\<Sqinter>\<^sub>o\<^sub>w (f ` A) \<le>\<^sub>o\<^sub>w \<Sqinter>\<^sub>o\<^sub>w (g ` B)"
    is complete_lattice_class.INF_mono.

end

end

lemma INF_commute:
  assumes "\<forall>x\<in>U\<^sub>2. \<forall>y\<in>U\<^sub>3. f x y \<in> U" and "B \<subseteq> U\<^sub>3" and "A \<subseteq> U\<^sub>2"
  shows
    "\<Sqinter>\<^sub>o\<^sub>w ((\<lambda>x. \<Sqinter>\<^sub>o\<^sub>w (f x ` B)) ` A) = \<Sqinter>\<^sub>o\<^sub>w ((\<lambda>j. \<Sqinter>\<^sub>o\<^sub>w ((\<lambda>i. f i j) ` A)) ` B)"
proof(cases \<open>U\<^sub>2 = {}\<close>)
  case True then show ?thesis
    using assms by (simp add: inf_top.sl_neut.neutral_map Inf_top_conv(2))
next
  case ne_U\<^sub>2: False show ?thesis
  proof(cases \<open>U\<^sub>3 = {}\<close>)
    case True show ?thesis
    proof-
      from assms(2) have "B = {}" unfolding True by simp
      from assms(1) show ?thesis
        unfolding \<open>B = {}\<close> by (force intro: INF_top)
    qed
  next
    case False
    from ne_U\<^sub>2 False assms show ?thesis by (rule ne_INF_commute)
  qed
qed

lemma SUP_commute:
  assumes "\<forall>x\<in>U\<^sub>2. \<forall>y\<in>U\<^sub>3. f x y \<in> U" and "B \<subseteq> U\<^sub>3" and "A \<subseteq> U\<^sub>2"
  shows
    "\<Squnion>\<^sub>o\<^sub>w ((\<lambda>x. \<Squnion>\<^sub>o\<^sub>w (f x ` B)) ` A) = \<Squnion>\<^sub>o\<^sub>w ((\<lambda>j. \<Squnion>\<^sub>o\<^sub>w ((\<lambda>i. f i j) ` A)) ` B)"
proof(cases \<open>U\<^sub>2 = {}\<close>)
  case True show ?thesis
  proof-
    from assms(3) have "A = {}" unfolding True by simp
    from assms(2) show ?thesis
      unfolding \<open>A = {}\<close>
      by (simp add: sup_bot.sl_neut.neutral_map inf_absorb1 SUP_bot)
  qed
next
  case ne_U\<^sub>2: False show ?thesis
  proof(cases \<open>U\<^sub>3 = {}\<close>)
    case True show ?thesis
    proof-
      from assms(2) have "B = {}" unfolding True by simp
      from assms(1) show ?thesis
        unfolding \<open>B = {}\<close>
        by (simp add: sup_bot.sl_neut.neutral_map Sup_bot_conv(1))
    qed
  next
    case False
    from ne_U\<^sub>2 False assms show ?thesis by (rule ne_SUP_commute)
  qed
qed

lemma SUP_mono:
  assumes "A \<subseteq> U\<^sub>2"
    and "B \<subseteq> U\<^sub>3"
    and "\<forall>x\<in>U\<^sub>2. f x \<in> U"
    and "\<forall>x\<in>U\<^sub>3. g x \<in> U"
    and "\<And>n. n \<in> A \<Longrightarrow> \<exists>m\<in>B. f n \<le>\<^sub>o\<^sub>w g m"
  shows "\<Squnion>\<^sub>o\<^sub>w (f ` A) \<le>\<^sub>o\<^sub>w \<Squnion>\<^sub>o\<^sub>w (g ` B)"
proof(cases \<open>U\<^sub>2 = {}\<close>)
  case True show ?thesis
  proof-
    from assms(1) have "A = {}" unfolding True by simp
    have "f ` A = {}" unfolding \<open>A = {}\<close> by simp
    from assms(2,4) show ?thesis
      unfolding \<open>f ` A = {}\<close> by (simp add: image_subset_iff in_mono)
  qed
next
  case ne_U\<^sub>2: False show ?thesis
  proof(cases \<open>U\<^sub>3 = {}\<close>)
    case True show ?thesis
    proof-
      from assms(2) have "B = {}" unfolding True by simp
      have "g ` B = {}" unfolding \<open>B = {}\<close> by simp
      from assms(1,3,5) show ?thesis
        unfolding \<open>g ` B = {}\<close> \<open>B = {}\<close> by (force simp: subset_iff)
    qed
  next
    case False
    from ne_U\<^sub>2 False assms show ?thesis by (rule ne_SUP_mono)
  qed
qed

lemma INF_mono:
  assumes "B \<subseteq> U\<^sub>2"
    and "A \<subseteq> U\<^sub>3"
    and "\<forall>x\<in>U\<^sub>3. f x \<in> U"
    and "\<forall>x\<in>U\<^sub>2. g x \<in> U"
    and "\<And>m. m \<in> B \<Longrightarrow> \<exists>n\<in>A. f n \<le>\<^sub>o\<^sub>w g m"
  shows "\<Sqinter>\<^sub>o\<^sub>w (f ` A) \<le>\<^sub>o\<^sub>w \<Sqinter>\<^sub>o\<^sub>w (g ` B)"
proof(cases \<open>U\<^sub>2 = {}\<close>)
  case True show ?thesis
  proof-
    from assms(1) have "B = {}" unfolding True by simp
    have "g ` B = {}" unfolding \<open>B = {}\<close> by simp
    from assms(2,3) show ?thesis
      unfolding \<open>g ` B = {}\<close> by (simp add: image_subset_iff in_mono)
  qed
next
  case ne_U\<^sub>2: False show ?thesis
  proof(cases \<open>U\<^sub>3 = {}\<close>)
    case True show ?thesis
    proof-
      from assms(2) have "A = {}" unfolding True by simp
      have "f ` A = {}" unfolding \<open>A = {}\<close> by simp
      from assms show ?thesis
        unfolding \<open>f ` A = {}\<close> \<open>A = {}\<close> by (auto simp: subset_iff) fastforce
    qed
  next
    case False from ne_U\<^sub>2 False assms show ?thesis by (rule ne_INF_mono)
  qed
qed

end

context complete_lattice_pair_ow
begin

context
  fixes U\<^sub>3 :: "'c set"
begin

lemmas [transfer_rule] =
  image_transfer[where ?'a='c]

end

end

text\<open>\newpage\<close>

end


(*
  File: Rect_Intersect.thy
  Author: Bohua Zhan
*)

section \<open>Rectangle intersection\<close>

theory Rect_Intersect
  imports Interval_Tree
begin

text \<open>
  Functional version of algorithm for detecting rectangle intersection.
  See \cite[Exercise 14.3-7]{cormen2009introduction} for a reference.
\<close>

subsection \<open>Definition of rectangles\<close>

datatype 'a rectangle = Rectangle (xint: "'a interval") (yint: "'a interval")
setup \<open>add_simple_datatype "rectangle"\<close>

definition is_rect :: "('a::linorder) rectangle \<Rightarrow> bool" where [rewrite]:
  "is_rect rect \<longleftrightarrow> is_interval (xint rect) \<and> is_interval (yint rect)"

definition is_rect_list :: "('a::linorder) rectangle list \<Rightarrow> bool" where [rewrite]:
  "is_rect_list rects \<longleftrightarrow> (\<forall>i<length rects. is_rect (rects ! i))"

lemma is_rect_listD: "is_rect_list rects \<Longrightarrow> i < length rects \<Longrightarrow> is_rect (rects ! i)" by auto2
setup \<open>add_forward_prfstep_cond @{thm is_rect_listD} [with_term "?rects ! ?i"]\<close>

setup \<open>del_prfstep_thm_eqforward @{thm is_rect_list_def}\<close>

definition is_rect_overlap :: "('a::linorder) rectangle \<Rightarrow> ('a::linorder) rectangle \<Rightarrow> bool" where [rewrite]:
  "is_rect_overlap A B \<longleftrightarrow> (is_overlap (xint A) (xint B) \<and> is_overlap (yint A) (yint B))"

definition has_rect_overlap :: "('a::linorder) rectangle list \<Rightarrow> bool" where [rewrite]:
  "has_rect_overlap As \<longleftrightarrow> (\<exists>i<length As. \<exists>j<length As. i \<noteq> j \<and> is_rect_overlap (As ! i) (As ! j))"

subsection \<open>INS / DEL operations\<close>

datatype 'a operation =
  INS (pos: 'a) (op_idx: nat) (op_int: "'a interval")
| DEL (pos: 'a) (op_idx: nat) (op_int: "'a interval")
setup \<open>fold add_rewrite_rule_back @{thms operation.collapse}\<close>
setup \<open>fold add_rewrite_rule @{thms operation.sel}\<close>
setup \<open>fold add_rewrite_rule @{thms operation.case}\<close>
setup \<open>add_resolve_prfstep @{thm operation.distinct(1)}\<close>
setup \<open>add_forward_prfstep_cond @{thm operation.disc(1)} [with_term "INS ?x11.0 ?x12.0 ?x13.0"]\<close>
setup \<open>add_forward_prfstep_cond @{thm operation.disc(2)} [with_term "DEL ?x21.0 ?x22.0 ?x23.0"]\<close>

instantiation operation :: (linorder) linorder begin

definition less: "(a < b) = (if pos a \<noteq> pos b then pos a < pos b else
                             if is_INS a \<noteq> is_INS b then is_INS a \<and> \<not>is_INS b
                             else if op_idx a \<noteq> op_idx b then op_idx a < op_idx b else op_int a < op_int b)"
definition less_eq: "(a \<le> b) = (if pos a \<noteq> pos b then pos a < pos b else
                              if is_INS a \<noteq> is_INS b then is_INS a \<and> \<not>is_INS b
                              else if op_idx a \<noteq> op_idx b then op_idx a < op_idx b else op_int a \<le> op_int b)"

instance proof
  fix x y z :: "'a operation"
  show a: "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
    by (smt Rect_Intersect.less Rect_Intersect.less_eq leD le_cases3 not_less_iff_gr_or_eq)
  show b: "x \<le> x"
    by (simp add: local.less_eq)
  show c: "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
    by (smt Rect_Intersect.less Rect_Intersect.less_eq a dual_order.trans less_trans)
  show d: "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
    by (metis Rect_Intersect.less Rect_Intersect.less_eq a le_imp_less_or_eq operation.expand)
  show e: "x \<le> y \<or> y \<le> x"
    using local.less_eq by fastforce
qed end

setup \<open>fold add_rewrite_rule [@{thm less_eq}, @{thm less}]\<close>

lemma operation_leD [forward]:
  "(a::('a::linorder operation)) \<le> b \<Longrightarrow> pos a \<le> pos b" by auto2

lemma operation_lessI [backward]:
  "p1 \<le> p2 \<Longrightarrow> INS p1 n1 i1 < DEL p2 n2 i2"
@proof
  @have "is_INS (INS p1 n1 i1) = True"
  @have "is_INS (DEL p2 n2 i2) = False"
@qed

setup \<open>fold del_prfstep_thm [@{thm less_eq}, @{thm less}]\<close>

subsection \<open>Set of operations corresponding to a list of rectangles\<close>

fun ins_op :: "'a rectangle list \<Rightarrow> nat \<Rightarrow> ('a::linorder) operation" where
  "ins_op rects i = INS (low (yint (rects ! i))) i (xint (rects ! i))"
setup \<open>add_rewrite_rule @{thm ins_op.simps}\<close>

fun del_op :: "'a rectangle list \<Rightarrow> nat \<Rightarrow> ('a::linorder) operation" where
  "del_op rects i = DEL (high (yint (rects ! i))) i (xint (rects ! i))"
setup \<open>add_rewrite_rule @{thm del_op.simps}\<close>

definition ins_ops :: "'a rectangle list \<Rightarrow> ('a::linorder) operation list" where [rewrite]:
  "ins_ops rects = list (\<lambda>i. ins_op rects i) (length rects)"

definition del_ops :: "'a rectangle list \<Rightarrow> ('a::linorder) operation list" where [rewrite]:
  "del_ops rects = list (\<lambda>i. del_op rects i) (length rects)"

lemma ins_ops_distinct [forward]: "distinct (ins_ops rects)"
@proof
  @let "xs = ins_ops rects"
  @have "\<forall>i<length xs. \<forall>j<length xs. i \<noteq> j \<longrightarrow> xs ! i \<noteq> xs ! j"
@qed

lemma del_ops_distinct [forward]: "distinct (del_ops rects)"
@proof
  @let "xs = del_ops rects"
  @have "\<forall>i<length xs. \<forall>j<length xs. i \<noteq> j \<longrightarrow> xs ! i \<noteq> xs ! j"
@qed

lemma set_ins_ops [rewrite]:
  "oper \<in> set (ins_ops rects) \<longleftrightarrow> op_idx oper < length rects \<and> oper = ins_op rects (op_idx oper)"
@proof
  @case "oper \<in> set (ins_ops rects)" @with
    @obtain i where "i < length rects" "ins_ops rects ! i = oper" @end
  @case "op_idx oper < length rects \<and> oper = ins_op rects (op_idx oper)" @with
    @have "oper = (ins_ops rects) ! (op_idx oper)" @end
@qed

lemma set_del_ops [rewrite]:
  "oper \<in> set (del_ops rects) \<longleftrightarrow> op_idx oper < length rects \<and> oper = del_op rects (op_idx oper)"
@proof
  @case "oper \<in> set (del_ops rects)" @with
    @obtain i where "i < length rects" "del_ops rects ! i = oper" @end
  @case "op_idx oper < length rects \<and> oper = del_op rects (op_idx oper)" @with
    @have "oper = (del_ops rects) ! (op_idx oper)" @end
@qed

definition all_ops :: "'a rectangle list \<Rightarrow> ('a::linorder) operation list" where [rewrite]:
  "all_ops rects = sort (ins_ops rects @ del_ops rects)"

lemma all_ops_distinct [forward]: "distinct (all_ops rects)"
@proof @have "distinct (ins_ops rects @ del_ops rects)" @qed

lemma set_all_ops_idx [forward]:
  "oper \<in> set (all_ops rects) \<Longrightarrow> op_idx oper < length rects" by auto2

lemma set_all_ops_ins [forward]:
  "INS p n i \<in> set (all_ops rects) \<Longrightarrow> INS p n i = ins_op rects n" by auto2

lemma set_all_ops_del [forward]:
  "DEL p n i \<in> set (all_ops rects) \<Longrightarrow> DEL p n i = del_op rects n" by auto2

lemma ins_in_set_all_ops:
  "i < length rects \<Longrightarrow> ins_op rects i \<in> set (all_ops rects)" by auto2
setup \<open>add_forward_prfstep_cond @{thm ins_in_set_all_ops} [with_term "ins_op ?rects ?i"]\<close>

lemma del_in_set_all_ops:
  "i < length rects \<Longrightarrow> del_op rects i \<in> set (all_ops rects)" by auto2
setup \<open>add_forward_prfstep_cond @{thm del_in_set_all_ops} [with_term "del_op ?rects ?i"]\<close>

lemma all_ops_sorted [forward]: "sorted (all_ops rects)" by auto2

lemma all_ops_nonempty [backward]: "rects \<noteq> [] \<Longrightarrow> all_ops rects \<noteq> []"
@proof @have "length (all_ops rects) > 0" @qed

setup \<open>del_prfstep_thm @{thm all_ops_def}\<close>

subsection \<open>Applying a set of operations\<close>

definition apply_ops_k :: "('a::linorder) rectangle list \<Rightarrow> nat \<Rightarrow> nat set" where [rewrite]:
  "apply_ops_k rects k = (let ops = all_ops rects in
     {i. i < length rects \<and> (\<exists>j<k. ins_op rects i = ops ! j) \<and> \<not>(\<exists>j<k. del_op rects i = ops ! j)})"
setup \<open>register_wellform_data ("apply_ops_k rects k", ["k < length (all_ops rects)"])\<close>

lemma apply_ops_set_mem [rewrite]:
  "ops = all_ops rects \<Longrightarrow>
   i \<in> apply_ops_k rects k \<longleftrightarrow> (i < length rects \<and> (\<exists>j<k. ins_op rects i = ops ! j) \<and> \<not>(\<exists>j<k. del_op rects i = ops ! j))"
  by auto2
setup \<open>del_prfstep_thm @{thm apply_ops_k_def}\<close>

definition xints_of :: "'a rectangle list \<Rightarrow> nat set \<Rightarrow> (('a::linorder) idx_interval) set" where [rewrite]:
  "xints_of rect is = (\<lambda>i. IdxInterval (xint (rect ! i)) i) ` is"

lemma xints_of_mem [rewrite]:
  "IdxInterval it i \<in> xints_of rect is \<longleftrightarrow> (i \<in> is \<and> xint (rect ! i) = it)" using xints_of_def by auto

lemma xints_diff [rewrite]:
  "xints_of rects (A - B) = xints_of rects A - xints_of rects B"
@proof @have "inj (\<lambda>i. IdxInterval (xint (rects ! i)) i)" @qed

definition has_overlap_at_k :: "('a::linorder) rectangle list \<Rightarrow> nat \<Rightarrow> bool" where [rewrite]:
  "has_overlap_at_k rects k \<longleftrightarrow> (
    let S = apply_ops_k rects k; ops = all_ops rects in
      is_INS (ops ! k) \<and> has_overlap (xints_of rects S) (op_int (ops ! k)))"
setup \<open>register_wellform_data ("has_overlap_at_k rects k", ["k < length (all_ops rects)"])\<close>

lemma has_overlap_at_k_equiv [forward]:
  "is_rect_list rects \<Longrightarrow> ops = all_ops rects \<Longrightarrow> k < length ops \<Longrightarrow>
   has_overlap_at_k rects k \<Longrightarrow> has_rect_overlap rects"
@proof
  @let "S = apply_ops_k rects k"
  @have "has_overlap (xints_of rects S) (op_int (ops ! k))"
  @obtain "xs' \<in> xints_of rects S" where "is_overlap (int xs') (op_int (ops ! k))"
  @let "xs = int xs'" "i = idx xs'"
  @let "j = op_idx (ops ! k)"
  @have "ops ! k = ins_op rects j"
  @have "i \<noteq> j" @with @contradiction
    @obtain k' where "k' < k" "ops ! k' = ins_op rects i"
    @have "ops ! k = ops ! k'"
  @end
  @have "low (yint (rects ! i)) \<le> pos (ops ! k)" @with
    @obtain k' where "k' < k" "ops ! k' = ins_op rects i"
    @have "ops ! k' \<le> ops ! k"
  @end
  @have "high (yint (rects ! i)) \<ge> pos (ops ! k)" @with
    @obtain k' where "k' < length ops" "ops ! k' = del_op rects i"
    @have "ops ! k' \<ge> ops ! k"
  @end
  @have "is_rect_overlap (rects ! i) (rects ! j)"
@qed

lemma has_overlap_at_k_equiv2 [resolve]:
  "is_rect_list rects \<Longrightarrow> ops = all_ops rects \<Longrightarrow> has_rect_overlap rects \<Longrightarrow>
   \<exists>k<length ops. has_overlap_at_k rects k"
@proof
  @obtain i j where "i < length rects" "j < length rects" "i \<noteq> j"
                    "is_rect_overlap (rects ! i) (rects ! j)"
  @have "is_rect_overlap (rects ! j) (rects ! i)"
  @obtain i1 where "i1 < length ops" "ops ! i1 = ins_op rects i"
  @obtain j1 where "j1 < length ops" "ops ! j1 = ins_op rects j"
  @obtain i2 where "i2 < length ops" "ops ! i2 = del_op rects i"
  @obtain j2 where "j2 < length ops" "ops ! j2 = del_op rects j"
  @case "ins_op rects i < ins_op rects j" @with
    @have "i1 < j1"
    @have "j1 < i2" @with @have "ops ! j1 < ops ! i2" @end
    @have "is_overlap (int (IdxInterval (xint (rects ! i)) i)) (xint (rects ! j))"
    @have "has_overlap_at_k rects j1"
  @end
  @case "ins_op rects j < ins_op rects i" @with
    @have "j1 < i1"
    @have "i1 < j2" @with @have "ops ! i1 < ops ! j2" @end
    @have "is_overlap (int (IdxInterval (xint (rects ! j)) j)) (xint (rects ! i))"
    @have "has_overlap_at_k rects i1"
  @end
@qed

definition has_overlap_lst :: "('a::linorder) rectangle list \<Rightarrow> bool" where [rewrite]:
  "has_overlap_lst rects = (let ops = all_ops rects in (\<exists>k<length ops. has_overlap_at_k rects k))"

lemma has_overlap_equiv [rewrite]:
  "is_rect_list rects \<Longrightarrow> has_overlap_lst rects \<longleftrightarrow> has_rect_overlap rects" by auto2

subsection \<open>Implementation of apply\_ops\_k\<close>

lemma apply_ops_k_next1 [rewrite]:
  "is_rect_list rects \<Longrightarrow> ops = all_ops rects \<Longrightarrow> n < length ops \<Longrightarrow> is_INS (ops ! n) \<Longrightarrow>
   apply_ops_k rects (n + 1) = apply_ops_k rects n \<union> {op_idx (ops ! n)}"
@proof
  @have "\<forall>i. i\<in>apply_ops_k rects (n + 1) \<longleftrightarrow> i\<in>apply_ops_k rects n \<union> {op_idx (ops ! n)}" @with
    @case "i \<in> apply_ops_k rects n \<union> {op_idx (ops ! n)}" @with
      @case "i = op_idx (ops ! n)" @with
        @have "ins_op rects i < del_op rects i"
      @end
    @end
  @end
@qed

lemma apply_ops_k_next2 [rewrite]:
  "is_rect_list rects \<Longrightarrow> ops = all_ops rects \<Longrightarrow> n < length ops \<Longrightarrow> \<not>is_INS (ops ! n) \<Longrightarrow>
   apply_ops_k rects (n + 1) = apply_ops_k rects n - {op_idx (ops ! n)}" by auto2

definition apply_ops_k_next :: "('a::linorder) rectangle list \<Rightarrow> 'a idx_interval set \<Rightarrow> nat \<Rightarrow> 'a idx_interval set" where
  "apply_ops_k_next rects S k = (let ops = all_ops rects in
   (case ops ! k of
      INS p n i \<Rightarrow> S \<union> {IdxInterval i n}
    | DEL p n i \<Rightarrow> S - {IdxInterval i n}))"
setup \<open>add_rewrite_rule @{thm apply_ops_k_next_def}\<close>

lemma apply_ops_k_next_is_correct [rewrite]:
  "is_rect_list rects \<Longrightarrow> ops = all_ops rects \<Longrightarrow> n < length ops \<Longrightarrow>
   S = xints_of rects (apply_ops_k rects n) \<Longrightarrow>
   xints_of rects (apply_ops_k rects (n + 1)) = apply_ops_k_next rects S n"
@proof @case "is_INS (ops ! n)" @qed

function rect_inter :: "nat rectangle list \<Rightarrow> nat idx_interval set \<Rightarrow> nat \<Rightarrow> bool" where
  "rect_inter rects S k = (let ops = all_ops rects in
    if k \<ge> length ops then False
    else if is_INS (ops ! k) then
      if has_overlap S (op_int (ops ! k)) then True
      else if k = length ops - 1 then False
      else rect_inter rects (apply_ops_k_next rects S k) (k + 1)
    else if k = length ops - 1 then False
      else rect_inter rects (apply_ops_k_next rects S k) (k + 1))"
  by auto
  termination by (relation "measure (\<lambda>(rects,S,k). length (all_ops rects) - k)") auto

lemma rect_inter_correct_ind [rewrite]:
  "is_rect_list rects \<Longrightarrow> ops = all_ops rects \<Longrightarrow> n < length ops \<Longrightarrow>
   rect_inter rects (xints_of rects (apply_ops_k rects n)) n \<longleftrightarrow>
   (\<exists>k<length ops. k \<ge> n \<and> has_overlap_at_k rects k)"
@proof
  @let "ints = xints_of rects (apply_ops_k rects n)"
  @fun_induct "rect_inter rects ints n"
  @unfold "rect_inter rects ints n"
  @case "n \<ge> length ops"
  @case "is_INS (ops ! n) \<and> has_overlap ints (op_int (ops ! n))"
  @case "n = length ops - 1"
@qed

text \<open>Correctness of functional algorithm.\<close>
theorem rect_inter_correct [rewrite]:
  "is_rect_list rects \<Longrightarrow> rect_inter rects {} 0 \<longleftrightarrow> has_rect_overlap rects"
@proof
  @have "{} = xints_of rects (apply_ops_k rects 0)"
  @have "rect_inter rects {} 0 = has_overlap_lst rects" @with
    @unfold "rect_inter rects {} 0"
  @end
@qed

end


text\<open>
Formal Languages and Automata Theory (FLAT)
according to the book with same name (2nd version) by Zongli Jiang
created by Yongwang Zhao (zhaoyw@buaa.edu.cn)
School of Computer Science and Engineering, Beihang University, Beijing, China
\<close>

section\<open>3. Finite Automaton\<close>

subsection\<open>3.3: nondeterministic finite automaton\<close>

theory DFA_NFA_eq
  imports DFA NFAe
begin

subsubsection\<open>equivalence of DFA and NFA\<close>
definition
 nfa2dfa :: "('a,'s)nfa \<Rightarrow> ('a,'s set)dfa" where
"nfa2dfa A \<equiv> ({q0 A}, \<lambda>a Q. \<Union>((\<delta> A) a ` Q), {Q. \<exists>q\<in>Q. q \<in> F A})"

(*** Equivalence of NA and DA ***)

lemma DFA_delta_is_lift_NFA_delta:
 "DFA.\<delta>' (nfa2dfa A) w Q = \<Union>(NFA.\<delta>' A w ` Q)"
  by (induct w arbitrary:Q)(auto simp:nfa2dfa_def)

lemma NFA_DFA_equiv:
  "NFA.accepts A w = DFA.accepts (nfa2dfa A) w"
  apply (simp add: DFA.accepts_def NFA.accepts_def DFA_delta_is_lift_NFA_delta)
  apply (simp add: nfa2dfa_def)
  done

end


(* Title: Examples/SML_Relativization/Algebra/SML_Monoids.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section\<open>Relativization of the results about monoids\<close>
theory SML_Monoids
  imports
    SML_Semigroups
    "../Foundations/Product_Type_Ext"
    "../Foundations/Transfer_Ext"
begin

subsection\<open>Simple monoids\<close>

subsubsection\<open>Definitions and common properties\<close>

locale neutral_ow =
  fixes U :: "'ag set" and z :: "'ag" (\<open>\<^bold>1\<^sub>o\<^sub>w\<close>)
  assumes z_closed[simp]: "\<^bold>1\<^sub>o\<^sub>w \<in> U"
begin

notation z (\<open>\<^bold>1\<^sub>o\<^sub>w\<close>)

tts_register_sbts \<open>\<^bold>1\<^sub>o\<^sub>w\<close> | U by (meson Domainp.cases z_closed)

lemma not_empty[simp]: "U \<noteq> {}" using z_closed by blast

lemma neutral_map: "(\<lambda>y. \<^bold>1\<^sub>o\<^sub>w) ` A \<subseteq> U" using z_closed by auto

end

locale monoid_ow = semigroup_ow U f + neutral_ow U z
  for U :: "'ag set" and f z +
  assumes left_neutral_mow[simp]: "a \<in> U \<Longrightarrow> (\<^bold>1\<^sub>o\<^sub>w \<^bold>*\<^sub>o\<^sub>w a) = a"
    and right_neutral_mow[simp]: "a \<in> U \<Longrightarrow> (a \<^bold>*\<^sub>o\<^sub>w \<^bold>1\<^sub>o\<^sub>w) = a"

locale zero_ow = zero: neutral_ow U zero
  for U :: "'ag set" and zero :: "'ag" (\<open>0\<^sub>o\<^sub>w\<close>)
begin

notation zero (\<open>0\<^sub>o\<^sub>w\<close>)

lemma zero_closed: "0\<^sub>o\<^sub>w \<in> U" by (rule zero.z_closed)

end

lemma monoid_ow: "monoid = monoid_ow UNIV"
  unfolding
    monoid_def monoid_ow_def monoid_axioms_def monoid_ow_axioms_def
    neutral_ow_def
    semigroup_ow
  by simp

locale one_ow = one: neutral_ow U one
  for U :: "'ag set" and one :: "'ag" (\<open>1\<^sub>o\<^sub>w\<close>)
begin

notation one (\<open>1\<^sub>o\<^sub>w\<close>)

lemma one_closed: "1\<^sub>o\<^sub>w \<in> U" by (rule one.z_closed)

end

locale power_ow = one_ow U one + times_ow U times
  for U :: "'ag set" and one :: "'ag" (\<open>1\<^sub>o\<^sub>w\<close>) and times (infixl \<open>*\<^sub>o\<^sub>w\<close> 70)

primrec power_with :: "['a, ['a, 'a] \<Rightarrow> 'a, 'a, nat] \<Rightarrow> 'a"
  (\<open>'(/with _ _ : _ ^\<^sub>o\<^sub>w _/')\<close> [1000, 999, 1000, 1000] 10)
  where
    power_0: "power_with one times a 0 = one" for one times
  | power_Suc: "power_with one times a (Suc n) =
      times a (power_with one times a n)" for one times

lemma power_with[ud_with]: "power = power_with 1 (*)"
  apply(intro ext)
  subgoal for x n by (induction n) auto
  done

context power_ow
begin

abbreviation power (\<open>(_ ^\<^sub>o\<^sub>w _)\<close> [81, 80] 80) where
  "power \<equiv> power_with 1\<^sub>o\<^sub>w (*\<^sub>o\<^sub>w)"

end

locale monoid_add_ow =
  semigroup_add_ow U plus + zero_ow U zero for U :: "'ag set" and plus zero +
  assumes add_0_left: "a \<in> U \<Longrightarrow> (0\<^sub>o\<^sub>w +\<^sub>o\<^sub>w a) = a"
  assumes add_0_right: "a \<in> U \<Longrightarrow> (a +\<^sub>o\<^sub>w 0\<^sub>o\<^sub>w) = a"
begin

sublocale add: monoid_ow U \<open>(+\<^sub>o\<^sub>w)\<close> \<open>0\<^sub>o\<^sub>w\<close>
  by unfold_locales (simp add: add_0_left add_0_right)+

end

lemma monoid_add_ow: "class.monoid_add = monoid_add_ow UNIV"
  unfolding
    class.monoid_add_def monoid_add_ow_def
    class.monoid_add_axioms_def monoid_add_ow_axioms_def
    zero_ow_def neutral_ow_def
    semigroup_add_ow
  by simp

locale monoid_mult_ow = semigroup_mult_ow U times + one_ow U one
  for U :: "'ag set" and one times  +
  assumes mult_1_left: "a \<in> U \<Longrightarrow> (1\<^sub>o\<^sub>w *\<^sub>o\<^sub>w a) = a"
  assumes mult_1_right: "a \<in> U \<Longrightarrow> (a *\<^sub>o\<^sub>w 1\<^sub>o\<^sub>w) = a"
begin

sublocale mult: monoid_ow U \<open>(*\<^sub>o\<^sub>w)\<close> \<open>1\<^sub>o\<^sub>w\<close>
  by unfold_locales (simp add: mult_1_left mult_1_right)+

sublocale power_ow ..

end

lemma monoid_mult_ow: "class.monoid_mult = monoid_mult_ow UNIV"
  unfolding
    class.monoid_mult_def monoid_mult_ow_def
    class.monoid_mult_axioms_def monoid_mult_ow_axioms_def
    one_ow_def neutral_ow_def
    semigroup_mult_ow
  by simp

subsubsection\<open>Transfer rules\<close>

context
  includes lifting_syntax
begin

lemma monoid_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "((A ===> A ===> A) ===> A ===> (=))
      (monoid_ow (Collect (Domainp A))) monoid"
proof-
  let ?P = "((A ===> A ===> A) ===> A ===> (=))"
  let ?monoid_ow = "monoid_ow (Collect (Domainp A))"
  have "?P ?monoid_ow (\<lambda>f z. z \<in> UNIV \<and> monoid f z)"
    unfolding
      monoid_def monoid_ow_def
      monoid_axioms_def monoid_ow_axioms_def
      neutral_ow_def
    apply transfer_prover_start
    apply transfer_step+
    unfolding Ball_def by blast
  thus ?thesis by simp
qed

lemma monoid_add_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "((A ===> A ===> A) ===> A ===> (=))
      (monoid_add_ow (Collect (Domainp A))) class.monoid_add"
proof-
  let ?P = "((A ===> A ===> A) ===> A ===> (=))"
  let ?monoid_add_ow = "monoid_add_ow (Collect (Domainp A))"
  have "?P ?monoid_add_ow (\<lambda>f z. z \<in> UNIV \<and> class.monoid_add f z)"
    unfolding
      class.monoid_add_def monoid_add_ow_def
      class.monoid_add_axioms_def monoid_add_ow_axioms_def
      zero_ow_def neutral_ow_def
    apply transfer_prover_start
    apply transfer_step+
    unfolding Ball_def by blast
  thus ?thesis by simp
qed

lemma monoid_mult_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "(A ===> (A ===> A ===> A) ===> (=))
      (monoid_mult_ow (Collect (Domainp A))) class.monoid_mult"
proof-
  let ?P = "(A ===> (A ===> A ===> A) ===> (=))"
  let ?monoid_mult_ow = "monoid_mult_ow (Collect (Domainp A))"
  have "?P ?monoid_mult_ow (\<lambda>z f. z \<in> UNIV \<and> class.monoid_mult z f)"
    unfolding
      class.monoid_mult_def monoid_mult_ow_def
      class.monoid_mult_axioms_def monoid_mult_ow_axioms_def
      one_ow_def neutral_ow_def
    apply transfer_prover_start
    apply transfer_step+
    unfolding Ball_def by blast
  thus ?thesis by simp
qed

lemma power_with_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "(A ===> (A ===> A ===> A) ===> A ===> (=) ===> A) power_with power_with"
proof(intro rel_funI, elim subst)
  fix i i' m m' a a' n
  assume ii': "A i i'" and mm': "(A ===> A ===> A) m m'" and aa': "A a a'"
  show "A (power_with i m a n) (power_with i' m' a' n)"
    apply(induction n)
    subgoal by (simp add: ii')
    subgoal using mm' aa' by (auto elim: rel_funE)
    done
qed

end

subsubsection\<open>Relativization\<close>

context power_ow
begin

tts_context
  tts: (?'a to U)
  sbterms: (\<open>(*)::[?'a::power,?'a::power] \<Rightarrow> ?'a::power\<close> to \<open>(*\<^sub>o\<^sub>w)\<close>)
    and (\<open>1::?'a::power\<close> to \<open>1\<^sub>o\<^sub>w\<close>)
  rewriting ctr_simps
  substituting power_ow_axioms and one.not_empty
begin

tts_lemma power_Suc:
  assumes "a \<in> U"
  shows "a ^\<^sub>o\<^sub>w Suc n = a *\<^sub>o\<^sub>w a ^\<^sub>o\<^sub>w n"
    is power_class.power.power_Suc.

tts_lemma power_0:
  assumes "a \<in> U"
  shows "a ^\<^sub>o\<^sub>w 0 = 1\<^sub>o\<^sub>w"
  is power_class.power.power_0.

tts_lemma power_eq_if:
  assumes "p \<in> U"
  shows "p ^\<^sub>o\<^sub>w m = (if m = 0 then 1\<^sub>o\<^sub>w else p *\<^sub>o\<^sub>w p ^\<^sub>o\<^sub>w (m - 1))"
    is power_class.power_eq_if.

tts_lemma simps:
  assumes "a \<in> U"
  shows "a ^\<^sub>o\<^sub>w 0 = 1\<^sub>o\<^sub>w"
    is power_class.power.simps(1)
    and "a ^\<^sub>o\<^sub>w Suc n = a *\<^sub>o\<^sub>w a ^\<^sub>o\<^sub>w n"
    is power_class.power.simps(2).

end

end

context monoid_mult_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting monoid_mult_ow_axioms and one.not_empty
  applying [OF one_closed mult.f_closed']
begin

tts_lemma power_commuting_commutes:
  assumes "x \<in> U" and "y \<in> U" and "x *\<^sub>o\<^sub>w y = y *\<^sub>o\<^sub>w x"
  shows "x ^\<^sub>o\<^sub>w n *\<^sub>o\<^sub>w y = y *\<^sub>o\<^sub>w x ^\<^sub>o\<^sub>w n"
    is monoid_mult_class.power_commuting_commutes.

tts_lemma left_right_inverse_power:
  assumes "x \<in> U" and "y \<in> U" and "x *\<^sub>o\<^sub>w y = 1\<^sub>o\<^sub>w"
  shows "x ^\<^sub>o\<^sub>w n *\<^sub>o\<^sub>w y ^\<^sub>o\<^sub>w n = 1\<^sub>o\<^sub>w"
    is monoid_mult_class.left_right_inverse_power.

tts_lemma power_numeral_even:
  assumes "z \<in> U"
  shows "z ^\<^sub>o\<^sub>w numeral (num.Bit0 w) = (let w = z ^\<^sub>o\<^sub>w numeral w in w *\<^sub>o\<^sub>w w)"
    is monoid_mult_class.power_numeral_even.

tts_lemma power_numeral_odd:
  assumes "z \<in> U"
  shows "z ^\<^sub>o\<^sub>w numeral (num.Bit1 w) = (let w = z ^\<^sub>o\<^sub>w numeral w in z *\<^sub>o\<^sub>w w *\<^sub>o\<^sub>w w)"
    is monoid_mult_class.power_numeral_odd.

tts_lemma power_minus_mult:
  assumes "a \<in> U" and "0 < n"
  shows "a ^\<^sub>o\<^sub>w (n - 1) *\<^sub>o\<^sub>w a = a ^\<^sub>o\<^sub>w n"
    is monoid_mult_class.power_minus_mult.

tts_lemma power_Suc0_right:
  assumes "a \<in> U"
  shows "a ^\<^sub>o\<^sub>w Suc 0 = a"
    is monoid_mult_class.power_Suc0_right.

tts_lemma power2_eq_square:
  assumes "a \<in> U"
  shows "a ^\<^sub>o\<^sub>w 2 = a *\<^sub>o\<^sub>w a"
    is monoid_mult_class.power2_eq_square.

tts_lemma power_one_right:
  assumes "a \<in> U"
  shows "a ^\<^sub>o\<^sub>w 1 = a"
    is monoid_mult_class.power_one_right.

tts_lemma power_commutes:
  assumes "a \<in> U"
  shows "a ^\<^sub>o\<^sub>w n *\<^sub>o\<^sub>w a = a *\<^sub>o\<^sub>w a ^\<^sub>o\<^sub>w n"
    is monoid_mult_class.power_commutes.

tts_lemma power3_eq_cube:
  assumes "a \<in> U"
  shows "a ^\<^sub>o\<^sub>w 3 = a *\<^sub>o\<^sub>w a *\<^sub>o\<^sub>w a"
    is monoid_mult_class.power3_eq_cube.

tts_lemma power_even_eq:
  assumes "a \<in> U"
  shows "a ^\<^sub>o\<^sub>w (2 * n) = (a ^\<^sub>o\<^sub>w n) ^\<^sub>o\<^sub>w 2"
    is monoid_mult_class.power_even_eq.

tts_lemma power_odd_eq:
  assumes "a \<in> U"
  shows "a ^\<^sub>o\<^sub>w Suc (2 * n) = a *\<^sub>o\<^sub>w (a ^\<^sub>o\<^sub>w n) ^\<^sub>o\<^sub>w 2"
    is monoid_mult_class.power_odd_eq.

tts_lemma power_mult:
  assumes "a \<in> U"
  shows "a ^\<^sub>o\<^sub>w (m * n) = (a ^\<^sub>o\<^sub>w m) ^\<^sub>o\<^sub>w n"
    is monoid_mult_class.power_mult.

tts_lemma power_Suc2:
  assumes "a \<in> U"
  shows "a ^\<^sub>o\<^sub>w Suc n = a ^\<^sub>o\<^sub>w n *\<^sub>o\<^sub>w a"
    is monoid_mult_class.power_Suc2.

tts_lemma power_one: "1\<^sub>o\<^sub>w ^\<^sub>o\<^sub>w n = 1\<^sub>o\<^sub>w"
  is monoid_mult_class.power_one.

tts_lemma power_add:
  assumes "a \<in> U"
  shows "a ^\<^sub>o\<^sub>w (m + n) = a ^\<^sub>o\<^sub>w m *\<^sub>o\<^sub>w a ^\<^sub>o\<^sub>w n"
    is monoid_mult_class.power_add.

tts_lemma power_mult_numeral:
  assumes "a \<in> U"
  shows "(a ^\<^sub>o\<^sub>w numeral m) ^\<^sub>o\<^sub>w numeral n = a ^\<^sub>o\<^sub>w numeral (m * n)"
    is Power.power_mult_numeral.

tts_lemma power_add_numeral2:
  assumes "a \<in> U" and "b \<in> U"
  shows
    "a ^\<^sub>o\<^sub>w numeral m *\<^sub>o\<^sub>w (a ^\<^sub>o\<^sub>w numeral n *\<^sub>o\<^sub>w b) = a ^\<^sub>o\<^sub>w numeral (m + n) *\<^sub>o\<^sub>w b"
    is Power.power_add_numeral2.

tts_lemma power_add_numeral:
  assumes "a \<in> U"
  shows "a ^\<^sub>o\<^sub>w numeral m *\<^sub>o\<^sub>w a ^\<^sub>o\<^sub>w numeral n = a ^\<^sub>o\<^sub>w numeral (m + n)"
    is Power.power_add_numeral.

end

end

subsection\<open>Commutative monoids\<close>

subsubsection\<open>Definitions and common properties\<close>

locale comm_monoid_ow =
  abel_semigroup_ow U f + neutral_ow U z for U :: "'ag set" and f z +
  assumes comm_neutral: "a \<in> U \<Longrightarrow> (a \<^bold>*\<^sub>o\<^sub>w \<^bold>1\<^sub>o\<^sub>w) = a"
begin

sublocale monoid_ow U \<open>(\<^bold>*\<^sub>o\<^sub>w)\<close> \<open>\<^bold>1\<^sub>o\<^sub>w\<close>
  apply unfold_locales
  subgoal by (simp add: comm_neutral commute)
  subgoal using commute by (simp add: comm_neutral)
  done

end

lemma comm_monoid_ow: "comm_monoid = comm_monoid_ow UNIV"
  unfolding
    comm_monoid_def comm_monoid_ow_def
    comm_monoid_axioms_def comm_monoid_ow_axioms_def
    neutral_ow_def
    abel_semigroup_ow
  by simp

locale comm_monoid_set_ow = comm_monoid_ow U f z for U :: "'ag set" and f z
begin

tts_register_sbts \<open>(\<^bold>*\<^sub>o\<^sub>w)\<close> | U by (rule tts_AA_A_transfer[OF f_closed])

end

lemma comm_monoid_set_ow: "comm_monoid_set = comm_monoid_set_ow UNIV"
  unfolding comm_monoid_set_def comm_monoid_set_ow_def comm_monoid_ow by simp

locale comm_monoid_add_ow =
  ab_semigroup_add_ow U plus + zero_ow U zero
  for U :: "'ag set" and plus zero +
  assumes add_0[simp]: "a \<in> U \<Longrightarrow> 0\<^sub>o\<^sub>w +\<^sub>o\<^sub>w a = a"
begin

sublocale add: comm_monoid_ow U \<open>(+\<^sub>o\<^sub>w)\<close> \<open>0\<^sub>o\<^sub>w\<close>
  by unfold_locales (use add.commute in force)

sublocale monoid_add_ow U \<open>(+\<^sub>o\<^sub>w)\<close> \<open>0\<^sub>o\<^sub>w\<close> by unfold_locales simp+

sublocale sum: comm_monoid_set_ow U \<open>(+\<^sub>o\<^sub>w)\<close> \<open>0\<^sub>o\<^sub>w\<close> ..

notation sum.F (\<open>\<guillemotleft>sum\<guillemotright>\<close>)

abbreviation Sum (\<open>\<Sum>\<^sub>o\<^sub>w/ _\<close> [1000] 1000)
  where "\<Sum>\<^sub>o\<^sub>w A \<equiv> (\<guillemotleft>sum\<guillemotright> (\<lambda>x. x) A)"

notation Sum (\<open>\<Sum>\<^sub>o\<^sub>w/ _\<close> [1000] 1000)

end

lemma comm_monoid_add_ow: "class.comm_monoid_add = comm_monoid_add_ow UNIV"
  unfolding
    class.comm_monoid_add_def comm_monoid_add_ow_def
    class.comm_monoid_add_axioms_def comm_monoid_add_ow_axioms_def
    zero_ow_def neutral_ow_def
    ab_semigroup_add_ow
  by simp

locale dvd_ow = times_ow U times
  for U :: "'ag set" and times

ud \<open>dvd.dvd\<close>
ud dvd' \<open>dvd_class.dvd\<close>

ctr relativization
  synthesis ctr_simps
  assumes [transfer_domain_rule, transfer_rule]: "Domainp A = (\<lambda>x. x \<in> U)"
    and [transfer_rule]: "bi_unique A" "right_total A"
  trp (?'a A)
  in dvd_ow': dvd.with_def
    (\<open>(on _ with _: _ \<guillemotleft>dvd\<guillemotright> _)\<close> [1000, 1000, 1000, 1000] 50)

ctr parametricity
  in dvd_ow'': dvd_ow'_def

context dvd_ow
begin

abbreviation dvd (infixr \<open>\<guillemotleft>dvd\<guillemotright>\<close> 50) where "a \<guillemotleft>dvd\<guillemotright> b \<equiv> dvd_ow' U (*\<^sub>o\<^sub>w) a b"
notation dvd (infixr \<open>\<guillemotleft>dvd\<guillemotright>\<close> 50)

end

locale comm_monoid_mult_ow =
  ab_semigroup_mult_ow U times + one_ow U one
  for U :: "'ag set" and times one +
  assumes mult_1[simp]: "a \<in> U \<Longrightarrow> 1\<^sub>o\<^sub>w *\<^sub>o\<^sub>w a = a"
begin

sublocale dvd_ow ..

sublocale mult: comm_monoid_ow U \<open>(*\<^sub>o\<^sub>w)\<close> \<open>1\<^sub>o\<^sub>w\<close>
  by unfold_locales (use mult.commute in force)

sublocale monoid_mult_ow U \<open>1\<^sub>o\<^sub>w\<close> \<open>(*\<^sub>o\<^sub>w)\<close> by unfold_locales simp+

sublocale prod: comm_monoid_set_ow U \<open>(*\<^sub>o\<^sub>w)\<close> \<open>1\<^sub>o\<^sub>w\<close> ..

notation prod.F (\<open>\<guillemotleft>prod\<guillemotright>\<close>)

abbreviation Prod (\<open>\<Prod>\<^sub>o\<^sub>w _\<close> [1000] 1000)
  where "\<Prod>\<^sub>o\<^sub>w A \<equiv> (\<guillemotleft>prod\<guillemotright> (\<lambda>x. x) A)"

notation Prod (\<open>\<Prod>\<^sub>o\<^sub>w _\<close> [1000] 1000)

end

lemma comm_monoid_mult_ow: "class.comm_monoid_mult = comm_monoid_mult_ow UNIV"
  unfolding
    class.comm_monoid_mult_def comm_monoid_mult_ow_def
    class.comm_monoid_mult_axioms_def comm_monoid_mult_ow_axioms_def
    one_ow_def neutral_ow_def
    ab_semigroup_mult_ow
  by simp

subsubsection\<open>Transfer rules\<close>

context
  includes lifting_syntax
begin

lemma bij_betw_transfer[transfer_rule]:
  assumes [transfer_rule]:
    "bi_unique A" "right_total A" "bi_unique B" "right_total B"
  shows
    "((A ===> B) ===> rel_set A ===> rel_set B ===> (=)) bij_betw bij_betw"
  unfolding bij_betw_def inj_on_def
  apply transfer_prover_start
  apply transfer_step+
  by simp

lemma comm_monoid_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "((A ===> A ===> A) ===> A ===> (=))
      (comm_monoid_ow (Collect (Domainp A))) comm_monoid"
proof -
  let ?P = "((A ===> A ===> A) ===> A ===> (=))"
  let ?comm_monoid_ow = "comm_monoid_ow (Collect (Domainp A))"
  have "?P ?comm_monoid_ow
    (\<lambda>f z. z \<in> UNIV \<and> comm_monoid f z)"
    unfolding
      comm_monoid_ow_def comm_monoid_def
      comm_monoid_ow_axioms_def comm_monoid_axioms_def
      neutral_ow_def
    apply transfer_prover_start
    apply transfer_step+
    by auto
  thus ?thesis by simp
qed

lemma comm_monoid_set_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "((A ===> A ===> A) ===> A ===> (=))
      (comm_monoid_set_ow (Collect (Domainp A))) comm_monoid_set"
  unfolding comm_monoid_set_ow_def comm_monoid_set_def
  apply transfer_prover_start
  apply transfer_step+
  by simp

lemma comm_monoid_add_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "((A ===> A ===> A) ===> A ===> (=))
      (comm_monoid_add_ow (Collect (Domainp A))) class.comm_monoid_add"
proof -
  let ?P = "((A ===> A ===> A) ===> A ===> (=))"
  let ?comm_monoid_add_ow = "comm_monoid_add_ow (Collect (Domainp A))"
  have "?P ?comm_monoid_add_ow (\<lambda>f z. z \<in> UNIV \<and> class.comm_monoid_add f z)"
    unfolding
      comm_monoid_add_ow_def class.comm_monoid_add_def
      zero_ow_def neutral_ow_def
      comm_monoid_add_ow_axioms_def class.comm_monoid_add_axioms_def
    apply transfer_prover_start
    apply transfer_step+
    by auto
  thus ?thesis by simp
qed

lemma comm_monoid_mult_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "((A ===> A ===> A) ===> A ===> (=))
      (comm_monoid_mult_ow (Collect (Domainp A))) class.comm_monoid_mult"
proof -
  let ?P = "((A ===> A ===> A) ===> A ===> (=))"
  let ?comm_monoid_mult_ow = "comm_monoid_mult_ow (Collect (Domainp A))"
  have "?P ?comm_monoid_mult_ow (\<lambda>f z. z \<in> UNIV \<and> class.comm_monoid_mult f z)"
    unfolding
      comm_monoid_mult_ow_def class.comm_monoid_mult_def
      one_ow_def neutral_ow_def
      comm_monoid_mult_ow_axioms_def class.comm_monoid_mult_axioms_def
    apply transfer_prover_start
    apply transfer_step+
    by auto
  thus ?thesis by simp
qed

lemma dvd_with_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "((A ===> A ===> A) ===> A ===> A ===> (=))
      (dvd_ow' (Collect (Domainp A))) dvd.with"
  unfolding dvd_ow'_def dvd.with_def by transfer_prover

end

subsubsection\<open>Relativization\<close>

context dvd_ow
begin

tts_context
  tts: (?'a to U)
  sbterms: (\<open>(*)::[?'a::times, ?'a::times] \<Rightarrow> ?'a::times\<close> to \<open>(*\<^sub>o\<^sub>w)\<close>)
  rewriting ctr_simps
  substituting dvd_ow_axioms
  eliminating through simp
begin

tts_lemma dvdI:
  assumes "b \<in> U" and "k \<in> U" and "a = b *\<^sub>o\<^sub>w k"
  shows "b \<guillemotleft>dvd\<guillemotright> a"
    is dvd_class.dvdI.

tts_lemma dvdE:
  assumes "b \<in> U"
    and "a \<in> U"
    and "b \<guillemotleft>dvd\<guillemotright> a"
    and "\<And>k. \<lbrakk>k \<in> U; a = b *\<^sub>o\<^sub>w k\<rbrakk> \<Longrightarrow> P"
  shows P
    is dvd_class.dvdE.

end

end

context comm_monoid_mult_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting comm_monoid_mult_ow_axioms and one.not_empty
  applying [OF mult.f_closed' one_closed]
begin

tts_lemma strict_subset_divisors_dvd:
  assumes "a \<in> U" and "b \<in> U"
  shows
    "({x \<in> U. x \<guillemotleft>dvd\<guillemotright> a} \<subset> {x \<in> U. x \<guillemotleft>dvd\<guillemotright> b}) = (a \<guillemotleft>dvd\<guillemotright> b \<and> \<not> b \<guillemotleft>dvd\<guillemotright> a)"
    is comm_monoid_mult_class.strict_subset_divisors_dvd.

tts_lemma subset_divisors_dvd:
  assumes "a \<in> U" and "b \<in> U"
  shows "({x \<in> U. x \<guillemotleft>dvd\<guillemotright> a} \<subseteq> {x \<in> U. x \<guillemotleft>dvd\<guillemotright> b}) = (a \<guillemotleft>dvd\<guillemotright> b)"
    is comm_monoid_mult_class.subset_divisors_dvd.

tts_lemma power_mult_distrib:
  assumes "a \<in> U" and "b \<in> U"
  shows "(a *\<^sub>o\<^sub>w b) ^\<^sub>o\<^sub>w n = a ^\<^sub>o\<^sub>w n *\<^sub>o\<^sub>w b ^\<^sub>o\<^sub>w n"
    is Power.comm_monoid_mult_class.power_mult_distrib.

tts_lemma dvd_triv_right:
  assumes "a \<in> U" and "b \<in> U"
  shows "a \<guillemotleft>dvd\<guillemotright> b *\<^sub>o\<^sub>w a"
    is comm_monoid_mult_class.dvd_triv_right.

tts_lemma dvd_mult_right:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U" and "a *\<^sub>o\<^sub>w b \<guillemotleft>dvd\<guillemotright> c"
  shows "b \<guillemotleft>dvd\<guillemotright> c"
    is comm_monoid_mult_class.dvd_mult_right.

tts_lemma mult_dvd_mono:
  assumes "a \<in> U"
    and "b \<in> U"
    and "c \<in> U"
    and "d \<in> U"
    and "a \<guillemotleft>dvd\<guillemotright> b"
    and "c \<guillemotleft>dvd\<guillemotright> d"
  shows "a *\<^sub>o\<^sub>w c \<guillemotleft>dvd\<guillemotright> b *\<^sub>o\<^sub>w d"
    is comm_monoid_mult_class.mult_dvd_mono.

tts_lemma dvd_triv_left:
  assumes "a \<in> U" and "b \<in> U"
  shows "a \<guillemotleft>dvd\<guillemotright> a *\<^sub>o\<^sub>w b"
    is comm_monoid_mult_class.dvd_triv_left.

tts_lemma dvd_mult_left:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U" and "a *\<^sub>o\<^sub>w b \<guillemotleft>dvd\<guillemotright> c"
  shows "a \<guillemotleft>dvd\<guillemotright> c"
    is comm_monoid_mult_class.dvd_mult_left.

tts_lemma dvd_trans:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U" and "a \<guillemotleft>dvd\<guillemotright> b" and "b \<guillemotleft>dvd\<guillemotright> c"
  shows "a \<guillemotleft>dvd\<guillemotright> c"
    is comm_monoid_mult_class.dvd_trans.

tts_lemma dvd_mult2:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U" and "a \<guillemotleft>dvd\<guillemotright> b"
  shows "a \<guillemotleft>dvd\<guillemotright> b *\<^sub>o\<^sub>w c"
    is comm_monoid_mult_class.dvd_mult2.

tts_lemma dvd_refl:
  assumes "a \<in> U"
  shows "a \<guillemotleft>dvd\<guillemotright> a"
    is comm_monoid_mult_class.dvd_refl.

tts_lemma dvd_mult:
  assumes "a \<in> U" and "c \<in> U" and "b \<in> U" and "a \<guillemotleft>dvd\<guillemotright> c"
  shows "a \<guillemotleft>dvd\<guillemotright> b *\<^sub>o\<^sub>w c"
    is comm_monoid_mult_class.dvd_mult.

tts_lemma one_dvd:
  assumes "a \<in> U"
  shows "1\<^sub>o\<^sub>w \<guillemotleft>dvd\<guillemotright> a"
    is comm_monoid_mult_class.one_dvd.

end

end

subsection\<open>Cancellative commutative monoids\<close>

subsubsection\<open>Definitions and common properties\<close>

locale cancel_comm_monoid_add_ow =
  cancel_ab_semigroup_add_ow U plus minus +
  comm_monoid_add_ow U plus zero
  for U :: "'ag set" and plus minus zero

lemma cancel_comm_monoid_add_ow:
  "class.cancel_comm_monoid_add = cancel_comm_monoid_add_ow UNIV"
  unfolding
    class.cancel_comm_monoid_add_def cancel_comm_monoid_add_ow_def
    cancel_ab_semigroup_add_ow comm_monoid_add_ow
  by simp

subsubsection\<open>Transfer rules\<close>

context
  includes lifting_syntax
begin

lemma cancel_comm_monoid_add_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "((A ===> A ===> A) ===> (A ===> A ===> A) ===> A ===> (=))
      (cancel_comm_monoid_add_ow (Collect (Domainp A)))
      class.cancel_comm_monoid_add"
  unfolding cancel_comm_monoid_add_ow_def class.cancel_comm_monoid_add_def
  by transfer_prover

end

subsubsection\<open>Relativization\<close>

context cancel_comm_monoid_add_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting cancel_comm_monoid_add_ow_axioms and zero.not_empty
  applying [OF add.f_closed' minus_closed' zero_closed]
begin

tts_lemma add_cancel_right_right:
  assumes "a \<in> U" and "b \<in> U"
  shows "(a = a +\<^sub>o\<^sub>w b) = (b = 0\<^sub>o\<^sub>w)"
    is cancel_comm_monoid_add_class.add_cancel_right_right.

tts_lemma add_cancel_right_left:
  assumes "a \<in> U" and "b \<in> U"
  shows "(a = b +\<^sub>o\<^sub>w a) = (b = 0\<^sub>o\<^sub>w)"
    is cancel_comm_monoid_add_class.add_cancel_right_left.

tts_lemma add_cancel_left_right:
  assumes "a \<in> U" and "b \<in> U"
  shows "(a +\<^sub>o\<^sub>w b = a) = (b = 0\<^sub>o\<^sub>w)"
    is cancel_comm_monoid_add_class.add_cancel_left_right.

tts_lemma add_cancel_left_left:
  assumes "b \<in> U" and "a \<in> U"
  shows "(b +\<^sub>o\<^sub>w a = a) = (b = 0\<^sub>o\<^sub>w)"
    is cancel_comm_monoid_add_class.add_cancel_left_left.

tts_lemma add_implies_diff:
  assumes "c \<in> U" and "b \<in> U" and "a \<in> U" and "c +\<^sub>o\<^sub>w b = a"
  shows "c = a -\<^sub>o\<^sub>w b"
    is cancel_comm_monoid_add_class.add_implies_diff.

tts_lemma diff_cancel:
  assumes "a \<in> U"
  shows "a -\<^sub>o\<^sub>w a = 0\<^sub>o\<^sub>w"
    is cancel_comm_monoid_add_class.diff_cancel.

tts_lemma diff_zero:
  assumes "a \<in> U"
  shows "a -\<^sub>o\<^sub>w 0\<^sub>o\<^sub>w = a"
    is cancel_comm_monoid_add_class.diff_zero.

end

end

text\<open>\newpage\<close>

end


(*  Title:       Verification components with relational MKA
    Author:      Jonathan Julián Huerta y Munive, 2020
    Maintainer:  Jonathan Julián Huerta y Munive <jonjulian23@gmail.com>
*)

subsection \<open> Relational model \<close> (* by Victor Gomes, Georg Struth *)

text \<open> In this subsection, we follow Gomes and Struth~\cite{afp:vericomp} and show that relations
form Kleene algebras.  \<close>

theory HS_VC_KA_rel
  imports Kleene_Algebra.Kleene_Algebra

begin

context dioid_one_zero
begin

lemma power_inductl: "z + x \<cdot> y \<le> y \<Longrightarrow> (x ^ n) \<cdot> z \<le> y"
  by(induct n, auto, metis mult.assoc mult_isol order_trans)

lemma power_inductr: "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> (x ^ n) \<le> y"
proof (induct n)
  case 0 show ?case
    using "0.prems" by auto
  case Suc
  {fix n
    assume "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x ^ n \<le> y"
      and "z + y \<cdot> x \<le> y"
    hence "z \<cdot> x ^ n \<le> y"
      by auto
    also have "z \<cdot> x ^ Suc n = z \<cdot> x \<cdot> x ^ n"
      by (metis mult.assoc power_Suc)
    moreover have "... = (z \<cdot> x ^ n) \<cdot> x"
      by (metis mult.assoc power_commutes)
    moreover have "... \<le> y \<cdot> x"
      by (metis calculation(1) mult_isor)
    moreover have "... \<le> y"
      using \<open>z + y \<cdot> x \<le> y\<close> by auto
    ultimately have "z \<cdot> x ^ Suc n \<le> y" by auto}
  thus ?case
    by (metis Suc)
qed

end

interpretation rel_dioid: dioid_one_zero "(\<union>)" "(O)" Id "{}" "(\<subseteq>)" "(\<subset>)"
  by (unfold_locales, auto)

lemma power_is_relpow: "rel_dioid.power X n = X ^^ n"
proof (induct n)
  case 0 show ?case
    by (metis rel_dioid.power_0 relpow.simps(1))
  case Suc thus ?case
    by (metis rel_dioid.power_Suc2 relpow.simps(2))
qed

lemma rel_star_def: "X^* = (\<Union>n. rel_dioid.power X n)"
  by (simp add: power_is_relpow rtrancl_is_UN_relpow)

lemma rel_star_contl: "X O Y^* = (\<Union>n. X O rel_dioid.power Y n)"
  by (metis rel_star_def relcomp_UNION_distrib)

lemma rel_star_contr: "X^* O Y = (\<Union>n. (rel_dioid.power X n) O Y)"
  by (metis rel_star_def relcomp_UNION_distrib2)

interpretation rel_ka: kleene_algebra "(\<union>)" "(O)" Id "{}" "(\<subseteq>)" "(\<subset>)" rtrancl
proof
  fix x y z :: "'a rel"
  show "Id \<union> x O x\<^sup>* \<subseteq> x\<^sup>*"
    by (metis order_refl r_comp_rtrancl_eq rtrancl_unfold)
next
  fix x y z :: "'a rel"
  assume "z \<union> x O y \<subseteq> y"
  thus "x\<^sup>* O z \<subseteq> y"
    by (simp only: rel_star_contr, metis (lifting) SUP_le_iff rel_dioid.power_inductl)
next
  fix x y z :: "'a rel"
  assume "z \<union> y O x \<subseteq> y"
  thus "z O x\<^sup>* \<subseteq> y"
    by (simp only: rel_star_contl, metis (lifting) SUP_le_iff rel_dioid.power_inductr)
qed

end