(* Title: Examples/TTS_Foundations/Orders/Set_Simple_Orders.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section\<open>Abstract orders on explicit sets\<close>
theory Set_Simple_Orders
  imports
    Type_Simple_Orders
    "../Foundations/FNDS_Set_Ext"
begin

subsection\<open>Background\<close>

text\<open>
Some of the results presented in this section were ported
(with amendments and additions) from the theories \<^text>\<open>Orderings\<close>
and \<^text>\<open>Set_Interval\<close> in the main library of Isabelle/HOL.
\<close>

subsection\<open>Order operations\<close>

locale ord_ow =
  fixes U :: "'a set" and le ls :: "['a, 'a] \<Rightarrow> bool"
begin

tts_register_sbts le | U
proof-
  assume "Domainp AB = (\<lambda>x. x \<in> U)" "bi_unique AB" "right_total AB"
  from tts_AA_eq_transfer[OF this] show ?thesis by auto
qed

tts_register_sbts ls | U
proof-
  assume "Domainp AB = (\<lambda>x. x \<in> U)" "bi_unique AB" "right_total AB"
  from tts_AA_eq_transfer[OF this] show ?thesis by auto
qed

end

locale ord_syntax_ow = ord_ow U le ls
  for U :: "'a set" and le ls :: "['a, 'a] \<Rightarrow> bool"
begin

notation
  le ("'(\<le>\<^sub>a')") and
  le (infix "\<le>\<^sub>a" 50) and
  ls ("'(<\<^sub>a')") and
  ls (infix "<\<^sub>a" 50)

abbreviation (input) ge (infix "\<ge>\<^sub>a" 50)
  where "x \<ge>\<^sub>a y \<equiv> y \<le>\<^sub>a x"
abbreviation (input) gt (infix ">\<^sub>a" 50)
  where "x >\<^sub>a y \<equiv> y <\<^sub>a x"

notation
  ge ("'(\<ge>\<^sub>a')") and
  ge (infix "\<ge>\<^sub>a" 50) and
  gt ("'(>\<^sub>a')") and
  gt (infix ">\<^sub>a" 50)

abbreviation Least where "Least \<equiv> Type_Simple_Orders.Least U (\<le>\<^sub>a)"
abbreviation Greatest where "Greatest \<equiv> Type_Simple_Orders.Least U (\<ge>\<^sub>a)"

abbreviation min where "min \<equiv> Type_Simple_Orders.min (\<le>\<^sub>a)"
abbreviation max where "max \<equiv> Type_Simple_Orders.min (\<ge>\<^sub>a)"

abbreviation lessThan (\<open>{..<\<^sub>a_}\<close>) where "{..<\<^sub>au} \<equiv> on U with (<\<^sub>a) : {..\<sqsubset>u}"
abbreviation atMost (\<open>{..\<le>\<^sub>a_}\<close>) where "{..\<le>\<^sub>au} \<equiv> on U with (\<le>\<^sub>a) : {..\<sqsubset>u}"
abbreviation greaterThan (\<open>{_<\<^sub>a..}\<close>) where "{l<\<^sub>a..} \<equiv> on U with (>\<^sub>a) : {..\<sqsubset>l}"
abbreviation atLeast (\<open>{_\<le>\<^sub>a..}\<close>) where "{l\<le>\<^sub>a..} \<equiv> on U with (\<ge>\<^sub>a) : {..\<sqsubset>l}"
abbreviation greaterThanLessThan (\<open>{_<\<^sub>a..<\<^sub>a_}\<close>)
  where "{l<\<^sub>a..<\<^sub>au} \<equiv> on U with (<\<^sub>a) (<\<^sub>a) : {l\<sqsubset>..\<sqsubset>u}"
abbreviation atLeastLessThan (\<open>{_\<le>\<^sub>a..<\<^sub>a_}\<close>)
  where "{l\<le>\<^sub>a..<\<^sub>au} \<equiv> on U with (\<le>\<^sub>a) (<\<^sub>a) : {l\<sqsubset>..\<sqsubset>u}"
abbreviation greaterThanAtMost (\<open>{_<\<^sub>a..\<le>\<^sub>a_}\<close>)
  where "{l<\<^sub>a..\<le>\<^sub>au} \<equiv> on U with (<\<^sub>a) (\<le>\<^sub>a) : {l\<sqsubset>..\<sqsubset>u}"
abbreviation atLeastAtMost (\<open>{_\<le>\<^sub>a..\<le>\<^sub>a_}\<close>)
  where "{l\<le>\<^sub>a..\<le>\<^sub>au} \<equiv> on U with (\<le>\<^sub>a) (\<le>\<^sub>a) : {l\<sqsubset>..\<sqsubset>u}"
abbreviation lessThanGreaterThan (\<open>{_>\<^sub>a..>\<^sub>a_}\<close>)
  where "{l>\<^sub>a..>\<^sub>au} \<equiv> on U with (>\<^sub>a) (>\<^sub>a) : {l\<sqsubset>..\<sqsubset>u}"
abbreviation lessThanAtLeast (\<open>{_\<ge>\<^sub>a..>\<^sub>a_}\<close>)
  where "{l\<ge>\<^sub>a..>\<^sub>au} \<equiv> on U with (\<ge>\<^sub>a) (>\<^sub>a) : {l\<sqsubset>..\<sqsubset>u}"
abbreviation atMostGreaterThan (\<open>{_>\<^sub>a..\<ge>\<^sub>a_}\<close>)
  where "{l>\<^sub>a..\<ge>\<^sub>au} \<equiv> on U with (>\<^sub>a) (\<ge>\<^sub>a) : {l\<sqsubset>..\<sqsubset>u}"
abbreviation atMostAtLeast (\<open>{_\<ge>\<^sub>a..\<ge>\<^sub>a_}\<close>)
  where "{l\<ge>\<^sub>a..\<ge>\<^sub>au} \<equiv> on U with (\<ge>\<^sub>a) (\<ge>\<^sub>a) : {l\<sqsubset>..\<sqsubset>u}"

abbreviation bdd_above where "bdd_above \<equiv> bdd U (\<le>\<^sub>a)"
abbreviation bdd_below where "bdd_below \<equiv> bdd U (\<ge>\<^sub>a)"

end

locale ord_dual_ow = ord_syntax_ow U le ls
  for U :: "'a set" and le ls :: "['a, 'a] \<Rightarrow> bool"
begin

sublocale dual: ord_ow U ge gt .

end

locale ord_pair_ow = ord\<^sub>a: ord_ow U\<^sub>a le\<^sub>a ls\<^sub>a + ord\<^sub>b: ord_ow U\<^sub>b le\<^sub>b ls\<^sub>b
  for U\<^sub>a :: "'a set" and le\<^sub>a ls\<^sub>a and U\<^sub>b :: "'b set" and le\<^sub>b ls\<^sub>b
begin

sublocale rev: ord_pair_ow U\<^sub>b le\<^sub>b ls\<^sub>b U\<^sub>a le\<^sub>a ls\<^sub>a .

end

locale ord_pair_syntax_ow = ord_pair_ow U\<^sub>a le\<^sub>a ls\<^sub>a U\<^sub>b le\<^sub>b ls\<^sub>b
  for U\<^sub>a :: "'a set" and le\<^sub>a ls\<^sub>a and U\<^sub>b :: "'b set" and le\<^sub>b ls\<^sub>b
begin

sublocale ord\<^sub>a: ord_syntax_ow U\<^sub>a le\<^sub>a ls\<^sub>a + ord\<^sub>b: ord_syntax_ow U\<^sub>b le\<^sub>b ls\<^sub>b .

notation le\<^sub>a (\<open>'(\<le>\<^sub>a')\<close>)
  and le\<^sub>a (infix \<open>\<le>\<^sub>a\<close> 50)
  and ls\<^sub>a (\<open>'(<\<^sub>a')\<close>)
  and ls\<^sub>a (infix \<open><\<^sub>a\<close> 50)
  and le\<^sub>b (\<open>'(\<le>\<^sub>b')\<close>)
  and le\<^sub>b (infix \<open>\<le>\<^sub>b\<close> 50)
  and ls\<^sub>b (\<open>'(<\<^sub>b')\<close>)
  and ls\<^sub>b (infix \<open><\<^sub>b\<close> 50)

notation ord\<^sub>a.ge (\<open>'(\<ge>\<^sub>a')\<close>)
  and ord\<^sub>a.ge (infix \<open>\<ge>\<^sub>a\<close> 50)
  and ord\<^sub>a.gt (\<open>'(>\<^sub>a')\<close>)
  and ord\<^sub>a.gt (infix \<open>>\<^sub>a\<close> 50)
  and ord\<^sub>b.ge (\<open>'(\<ge>\<^sub>b')\<close>)
  and ord\<^sub>b.ge (infix \<open>\<ge>\<^sub>b\<close> 50)
  and ord\<^sub>b.gt (\<open>'(>\<^sub>b')\<close>)
  and ord\<^sub>b.gt (infix \<open>>\<^sub>b\<close> 50)

abbreviation mono\<^sub>a\<^sub>b
  where "mono\<^sub>a\<^sub>b \<equiv> Type_Simple_Orders.mono U\<^sub>a (\<le>\<^sub>a) (\<le>\<^sub>b)"
abbreviation mono\<^sub>b\<^sub>a
  where "mono\<^sub>b\<^sub>a \<equiv> Type_Simple_Orders.mono U\<^sub>b (\<le>\<^sub>b) (\<le>\<^sub>a)"
abbreviation antimono\<^sub>a\<^sub>b
  where "antimono\<^sub>a\<^sub>b \<equiv> Type_Simple_Orders.mono U\<^sub>a (\<le>\<^sub>a) (\<ge>\<^sub>b)"
abbreviation antimono\<^sub>b\<^sub>a
  where "antimono\<^sub>b\<^sub>a \<equiv> Type_Simple_Orders.mono U\<^sub>b (\<le>\<^sub>b) (\<ge>\<^sub>a)"
abbreviation strict_mono\<^sub>a\<^sub>b
  where "strict_mono\<^sub>a\<^sub>b \<equiv> Type_Simple_Orders.mono U\<^sub>a (<\<^sub>a) (<\<^sub>b)"
abbreviation strict_mono\<^sub>b\<^sub>a
  where "strict_mono\<^sub>b\<^sub>a \<equiv> Type_Simple_Orders.mono U\<^sub>b (<\<^sub>b) (<\<^sub>a)"
abbreviation strict_antimono\<^sub>a\<^sub>b
  where "strict_antimono\<^sub>a\<^sub>b \<equiv> Type_Simple_Orders.mono U\<^sub>a (<\<^sub>a) (>\<^sub>b)"
abbreviation strict_antimono\<^sub>b\<^sub>a
  where "strict_antimono\<^sub>b\<^sub>a \<equiv> Type_Simple_Orders.mono U\<^sub>b (<\<^sub>b) (>\<^sub>a)"

notation ord\<^sub>a.lessThan (\<open>{..<\<^sub>a_}\<close>)
  and ord\<^sub>a.atMost (\<open>{..\<le>\<^sub>a_}\<close>)
  and ord\<^sub>a.greaterThan (\<open>{_<\<^sub>a..}\<close>)
  and ord\<^sub>a.atLeast (\<open>{_\<le>\<^sub>a..}\<close>)
  and ord\<^sub>a.greaterThanLessThan (\<open>{_<\<^sub>a..<\<^sub>a_}\<close>)
  and ord\<^sub>a.atLeastLessThan (\<open>{_\<le>\<^sub>a..<\<^sub>a_}\<close>)
  and ord\<^sub>a.greaterThanAtMost (\<open>{_<\<^sub>a..\<le>\<^sub>a_}\<close>)
  and ord\<^sub>a.atLeastAtMost (\<open>{_\<le>\<^sub>a..\<le>\<^sub>a_}\<close>)
  and ord\<^sub>a.lessThanGreaterThan (\<open>{_>\<^sub>a..>\<^sub>a_}\<close>)
  and ord\<^sub>a.lessThanAtLeast (\<open>{_\<ge>\<^sub>a..>\<^sub>a_}\<close>)
  and ord\<^sub>a.atMostGreaterThan (\<open>{_>\<^sub>a..\<ge>\<^sub>a_}\<close>)
  and ord\<^sub>a.atMostAtLeast (\<open>{_\<ge>\<^sub>a..\<ge>\<^sub>a_}\<close>)
  and ord\<^sub>b.lessThan (\<open>{..<\<^sub>b_}\<close>)
  and ord\<^sub>b.atMost (\<open>{..\<le>\<^sub>b_}\<close>)
  and ord\<^sub>b.greaterThan (\<open>{_<\<^sub>b..}\<close>)
  and ord\<^sub>b.atLeast (\<open>{_\<le>\<^sub>b..}\<close>)
  and ord\<^sub>b.greaterThanLessThan (\<open>{_<\<^sub>b..<\<^sub>b_}\<close>)
  and ord\<^sub>b.atLeastLessThan (\<open>{_\<le>\<^sub>b..<\<^sub>b_}\<close>)
  and ord\<^sub>b.greaterThanAtMost (\<open>{_<\<^sub>b..\<le>\<^sub>b_}\<close>)
  and ord\<^sub>b.atLeastAtMost (\<open>{_\<le>\<^sub>b..\<le>\<^sub>b_}\<close>)
  and ord\<^sub>b.lessThanGreaterThan (\<open>{_>\<^sub>b..>\<^sub>b_}\<close>)
  and ord\<^sub>b.lessThanAtLeast (\<open>{_\<ge>\<^sub>b..>\<^sub>b_}\<close>)
  and ord\<^sub>b.atMostGreaterThan (\<open>{_>\<^sub>b..\<ge>\<^sub>b_}\<close>)
  and ord\<^sub>b.atMostAtLeast (\<open>{_\<ge>\<^sub>b..\<ge>\<^sub>b_}\<close>)

end

locale ord_pair_dual_ow = ord_pair_syntax_ow U\<^sub>a le\<^sub>a ls\<^sub>a U\<^sub>b le\<^sub>b ls\<^sub>b
  for U\<^sub>a :: "'a set" and le\<^sub>a ls\<^sub>a and U\<^sub>b :: "'b set" and le\<^sub>b ls\<^sub>b

context ord_pair_dual_ow
begin

sublocale ord_dual: ord_pair_ow U\<^sub>a \<open>(\<le>\<^sub>a)\<close> \<open>(<\<^sub>a)\<close> U\<^sub>b \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close> .
sublocale dual_ord: ord_pair_ow U\<^sub>a \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> U\<^sub>b \<open>(\<le>\<^sub>b)\<close> \<open>(<\<^sub>b)\<close> .
sublocale dual_dual: ord_pair_ow U\<^sub>a \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> U\<^sub>b \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close> .

end

subsubsection\<open>Relativization\<close>

context ord_ow
begin

interpretation ord_syntax_ow .

tts_context
  tts: (?'a to U)
  sbterms: (\<open>?ls::?'a \<Rightarrow> ?'a \<Rightarrow> bool\<close> to ls)
  rewriting ctr_simps
  eliminating through auto
begin

tts_lemma lessThan_iff:
  assumes "i \<in> U" and "k \<in> U"
  shows "(i \<in> {..<\<^sub>ak}) = (i <\<^sub>a k)"
    is ord.lessThan_iff.

tts_lemma greaterThanLessThan_iff:
  assumes "i \<in> U" and "l \<in> U" and "u \<in> U"
  shows "(i \<in> {l<\<^sub>a..<\<^sub>au}) = (i <\<^sub>a u \<and> l <\<^sub>a i)"
  is ord.greaterThanLessThan_iff.

tts_lemma greaterThanLessThan_eq:
  assumes "a \<in> U" and "b \<in> U"
  shows "{a<\<^sub>a..<\<^sub>ab} = {a<\<^sub>a..} \<inter> {..<\<^sub>ab}"
    is ord.greaterThanLessThan_eq.

end

tts_context
  tts: (?'a to U)
  sbterms: (\<open>?le::?'a \<Rightarrow> ?'a \<Rightarrow> bool\<close> to le)
  rewriting ctr_simps
  eliminating through auto
begin

tts_lemma min_absorb1:
  assumes "x \<in> U" and "y \<in> U" and "x \<le>\<^sub>a y"
  shows "min x y = x"
  is ord.min_absorb1.

tts_lemma atLeast_iff:
  assumes "i \<in> U" and "k \<in> U"
  shows "(i \<in> {k\<le>\<^sub>a..}) = (k \<le>\<^sub>a i)"
  is ord.atLeast_iff.

tts_lemma atLeastAtMost_iff:
  assumes "i \<in> U" and "l \<in> U" and "u \<in> U"
  shows "(i \<in> {l\<le>\<^sub>a..\<le>\<^sub>au}) = (i \<le>\<^sub>a u \<and> l \<le>\<^sub>a i)"
  is ord.atLeastAtMost_iff.

end

tts_context
  tts: (?'a to U)
  sbterms: (\<open>?le::?'a \<Rightarrow> ?'a \<Rightarrow> bool\<close> to le)
    and (\<open>?ls::?'a \<Rightarrow> ?'a \<Rightarrow> bool\<close> to ls)
   rewriting ctr_simps
 eliminating through auto
begin

tts_lemma atLeastLessThan_iff:
  assumes "i \<in> U" and "l \<in> U" and "u \<in> U"
  shows "(i \<in> {l\<le>\<^sub>a..<\<^sub>au}) = (l \<le>\<^sub>a i \<and> i <\<^sub>a u)"
    is ord.atLeastLessThan_iff.

tts_lemma greaterThanAtMost_iff:
  assumes "i \<in> U" and "l \<in> U" and "u \<in> U"
  shows "(i \<in> {l<\<^sub>a..\<le>\<^sub>au}) = (i \<le>\<^sub>a u \<and> l <\<^sub>a i)"
  is ord.greaterThanAtMost_iff.

end

end

context ord_pair_ow
begin

interpretation ord_pair_syntax_ow .

tts_context
  tts: (?'a to U\<^sub>a) and (?'b to U\<^sub>b)
  sbterms: (\<open>?le\<^sub>a::?'a\<Rightarrow>?'a\<Rightarrow>bool\<close> to le\<^sub>a) and (\<open>?le\<^sub>b::?'b\<Rightarrow>?'b\<Rightarrow>bool\<close> to le\<^sub>b)
  rewriting ctr_simps
  eliminating through (simp add: Type_Simple_Orders.mono_def)
begin

tts_lemma monoD:
  assumes "x \<in> U\<^sub>a" and "y \<in> U\<^sub>a" and "mono\<^sub>a\<^sub>b f" and "x \<le>\<^sub>a y"
  shows "f x \<le>\<^sub>b f y"
  is ord_pair.monoD.

tts_lemma monoI:
  assumes "\<And>x y. \<lbrakk>x \<in> U\<^sub>a; y \<in> U\<^sub>a; x \<le>\<^sub>a y\<rbrakk> \<Longrightarrow> f x \<le>\<^sub>b f y"
  shows "mono\<^sub>a\<^sub>b f"
    is ord_pair.monoI.

tts_lemma monoE:
  assumes "x \<in> U\<^sub>a"
    and "y \<in> U\<^sub>a"
    and "mono\<^sub>a\<^sub>b f"
    and "x \<le>\<^sub>a y"
    and "f x \<le>\<^sub>b f y \<Longrightarrow> thesis"
  shows thesis
    is ord_pair.monoE.

end

tts_context
  tts: (?'a to U\<^sub>a) and (?'b to U\<^sub>b)
  sbterms: (\<open>?ls\<^sub>a::?'a\<Rightarrow>?'a\<Rightarrow>bool\<close> to le\<^sub>a) and (\<open>?ls\<^sub>b::?'b\<Rightarrow>?'b\<Rightarrow>bool\<close> to le\<^sub>b)
  rewriting ctr_simps
  eliminating through (simp add: Type_Simple_Orders.mono_def)
begin

tts_lemma strict_monoD:
  assumes "x \<in> U\<^sub>a"
    and "y \<in> U\<^sub>a"
    and "mono\<^sub>a\<^sub>b f"
    and "x \<le>\<^sub>a y"
  shows "f x \<le>\<^sub>b f y"
    is ord_pair.strict_monoD.

tts_lemma strict_monoI:
  assumes "\<And>x y. \<lbrakk>x \<in> U\<^sub>a; y \<in> U\<^sub>a; x \<le>\<^sub>a y\<rbrakk> \<Longrightarrow> f x \<le>\<^sub>b f y"
  shows "mono\<^sub>a\<^sub>b f"
    is ord_pair.strict_monoI.

tts_lemma strict_monoE:
  assumes "x \<in> U\<^sub>a"
    and "y \<in> U\<^sub>a"
    and "mono\<^sub>a\<^sub>b f"
    and "x \<le>\<^sub>a y"
    and "f x \<le>\<^sub>b f y \<Longrightarrow> thesis"
  shows thesis
    is ord_pair.strict_monoE.

end

end

subsection\<open>Preorders\<close>

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

locale preorder_ow = ord_ow U le ls
  for U :: "'a set" and le ls +
  assumes less_le_not_le: "\<lbrakk> x \<in> U; y \<in> U \<rbrakk> \<Longrightarrow> ls x y \<longleftrightarrow> le x y \<and> \<not> (le y x)"
    and order_refl[iff]: "x \<in> U \<Longrightarrow> le x x"
    and order_trans: "\<lbrakk> x \<in> U; y \<in> U; z \<in> U; le x y; le y z \<rbrakk> \<Longrightarrow> le x z"

locale preorder_dual_ow = preorder_ow U le ls for U :: "'a set" and le ls
begin

sublocale ord_dual_ow .

sublocale dual: preorder_ow U ge gt
  by standard (auto simp: less_le_not_le intro: order_trans)

end

locale ord_preorder_ow =
  ord_pair_ow U\<^sub>a le\<^sub>a ls\<^sub>a U\<^sub>b le\<^sub>b ls\<^sub>b + ord\<^sub>b: preorder_ow U\<^sub>b le\<^sub>b ls\<^sub>b
  for U\<^sub>a :: "'a set" and le\<^sub>a ls\<^sub>a and U\<^sub>b :: "'b set" and le\<^sub>b ls\<^sub>b

locale ord_preorder_dual_ow = ord_preorder_ow U\<^sub>a le\<^sub>a ls\<^sub>a U\<^sub>b le\<^sub>b ls\<^sub>b
  for U\<^sub>a :: "'a set" and le\<^sub>a ls\<^sub>a and U\<^sub>b :: "'b set" and le\<^sub>b ls\<^sub>b
begin

sublocale ord_pair_dual_ow .
sublocale ord_dual: ord_preorder_ow U\<^sub>a \<open>(\<le>\<^sub>a)\<close> \<open>(<\<^sub>a)\<close> U\<^sub>b \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close>
  by unfold_locales (auto simp: ord\<^sub>b.less_le_not_le intro: ord\<^sub>b.order_trans)
sublocale dual_ord: ord_preorder_ow U\<^sub>a \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> U\<^sub>b \<open>(\<le>\<^sub>b)\<close> \<open>(<\<^sub>b)\<close>
  by (rule ord_preorder_ow_axioms)
sublocale dual_dual: ord_preorder_ow U\<^sub>a \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> U\<^sub>b \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close>
  by (rule ord_dual.ord_preorder_ow_axioms)

end

locale preorder_pair_ow =
  ord_preorder_ow U\<^sub>a le\<^sub>a ls\<^sub>a U\<^sub>b le\<^sub>b ls\<^sub>b + ord\<^sub>a: preorder_ow U\<^sub>a le\<^sub>a ls\<^sub>a
  for U\<^sub>a :: "'a set" and le\<^sub>a ls\<^sub>a and U\<^sub>b :: "'b set" and le\<^sub>b ls\<^sub>b
begin

sublocale rev: preorder_pair_ow U\<^sub>b le\<^sub>b ls\<^sub>b U\<^sub>a le\<^sub>a ls\<^sub>a ..

end

locale preorder_pair_dual_ow = preorder_pair_ow U\<^sub>a le\<^sub>a ls\<^sub>a U\<^sub>b le\<^sub>b ls\<^sub>b
  for U\<^sub>a :: "'a set" and le\<^sub>a ls\<^sub>a and U\<^sub>b :: "'b set" and le\<^sub>b ls\<^sub>b
begin

sublocale ord_preorder_dual_ow ..
sublocale ord_dual: preorder_pair_ow U\<^sub>a \<open>(\<le>\<^sub>a)\<close> \<open>(<\<^sub>a)\<close> U\<^sub>b \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close> ..
sublocale dual_ord: preorder_pair_ow U\<^sub>a \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> U\<^sub>b \<open>(\<le>\<^sub>b)\<close> \<open>(<\<^sub>b)\<close>
  by unfold_locales (auto intro: ord\<^sub>a.order_trans simp: ord\<^sub>a.less_le_not_le)
sublocale dual_dual: preorder_pair_ow U\<^sub>a \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> U\<^sub>b \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close> ..

end

subsubsection\<open>Transfer rules\<close>

lemma preorder_ow[ud_with]: "preorder = preorder_ow UNIV"
  unfolding preorder_def preorder_ow_def by simp

lemma ord_preorder_ow[ud_with]: "ord_preorder = ord_preorder_ow UNIV"
  unfolding ord_preorder_def ord_preorder_ow_def ud_with by simp

lemma preorder_pair_ow[ud_with]:
  "preorder_pair =
    (\<lambda>le\<^sub>a ls\<^sub>a le\<^sub>b ls\<^sub>b. preorder_pair_ow UNIV le\<^sub>a ls\<^sub>a UNIV le\<^sub>b ls\<^sub>b)"
  unfolding preorder_pair_def preorder_pair_ow_def ud_with by simp

context
  includes lifting_syntax
begin

lemma preorder_ow_transfer[transfer_rule]:
  assumes [transfer_rule]: "right_total A"
  shows
    "(rel_set A ===> (A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> (=))
      preorder_ow preorder_ow"
  by (ow_locale_transfer locale_defs: preorder_ow_def)

lemma ord_preorder_ow_transfer[transfer_rule]:
  assumes [transfer_rule]: "right_total A"
  shows
    "(rel_set A ===> (A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> (=))
      ord_preorder_ow ord_preorder_ow"
  by (ow_locale_transfer locale_defs: ord_preorder_ow_def)

lemma preorder_pair_ow_transfer[transfer_rule]:
  assumes [transfer_rule]: "right_total A" "right_total B"
  shows
    "(
      rel_set A ===> (A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===>
      rel_set B ===> (B ===> B ===> (=)) ===> (B ===> B ===> (=)) ===>
      (=)
    ) preorder_pair_ow preorder_pair_ow"
  by (ow_locale_transfer locale_defs: preorder_pair_ow_def)

end

subsubsection\<open>Relativization\<close>

context preorder_ow
begin

interpretation ord_syntax_ow .

tts_context
  tts: (?'a to U)
  sbterms: (\<open>?ls::?'a \<Rightarrow> ?'a \<Rightarrow> bool\<close> to ls)
    and (\<open>?le::?'a \<Rightarrow> ?'a \<Rightarrow> bool\<close> to le)
  rewriting ctr_simps
  substituting preorder_ow_axioms
  eliminating through auto
begin

tts_lemma less_irrefl:
  assumes "x \<in> U"
  shows "\<not> x <\<^sub>a x"
    is preorder.less_irrefl.

tts_lemma eq_refl:
  assumes "y \<in> U" and "x = y"
  shows "x \<le>\<^sub>a y"
  is preorder.eq_refl.

tts_lemma less_imp_le:
  assumes "x \<in> U" and "y \<in> U" and "x <\<^sub>a y"
  shows "x \<le>\<^sub>a y"
    is preorder.less_imp_le.

tts_lemma strict_implies_not_eq:
  assumes "b \<in> U" and "a <\<^sub>a b"
  shows "a \<noteq> b"
    is preorder.strict_implies_not_eq.

tts_lemma less_not_sym:
  assumes "x \<in> U" and "y \<in> U" and "x <\<^sub>a y"
  shows "\<not> y <\<^sub>a x"
    is preorder.less_not_sym.

tts_lemma not_empty_eq_Ici_eq_empty:
  assumes "l \<in> U"
  shows "{} \<noteq> {l\<le>\<^sub>a..}"
    is preorder.not_empty_eq_Ici_eq_empty.

tts_lemma not_Ici_eq_empty:
  assumes "l \<in> U"
  shows "{l\<le>\<^sub>a..} \<noteq> {}"
    is preorder.not_Ici_eq_empty.

tts_lemma asym:
  assumes "a \<in> U" and "b \<in> U" and "a <\<^sub>a b" and "b <\<^sub>a a"
  shows False
    is preorder.asym.

tts_lemma less_asym':
  assumes "a \<in> U" and "b \<in> U" and "a <\<^sub>a b" and "b <\<^sub>a a"
  shows P
    is preorder.less_asym'.

tts_lemma less_imp_not_less:
  assumes "x \<in> U" and "y \<in> U" and "x <\<^sub>a y"
  shows "(\<not> y <\<^sub>a x) = True"
    is preorder.less_imp_not_less.

tts_lemma single_Diff_lessThan:
  assumes "k \<in> U"
  shows "{k} - {..<\<^sub>ak} = {k}"
    is preorder.single_Diff_lessThan.

tts_lemma less_imp_triv:
  assumes "x \<in> U" and "y \<in> U" and "x <\<^sub>a y"
  shows "(y <\<^sub>a x \<longrightarrow> P) = True"
    is preorder.less_imp_triv.

tts_lemma ivl_disj_int_one:
  assumes "l \<in> U" and "u \<in> U"
  shows
    "{..\<le>\<^sub>al} \<inter> {l<\<^sub>a..<\<^sub>au} = {}"
    "{..<\<^sub>al} \<inter> {l\<le>\<^sub>a..<\<^sub>au} = {}"
    "{..\<le>\<^sub>al} \<inter> {l<\<^sub>a..\<le>\<^sub>au} = {}"
    "{..<\<^sub>al} \<inter> {l\<le>\<^sub>a..\<le>\<^sub>au} = {}"
    "{l<\<^sub>a..\<le>\<^sub>au} \<inter> {u<\<^sub>a..} = {}"
    "{l<\<^sub>a..<\<^sub>au} \<inter> {u\<le>\<^sub>a..} = {}"
    "{l\<le>\<^sub>a..\<le>\<^sub>au} \<inter> {u<\<^sub>a..} = {}"
    "{l\<le>\<^sub>a..<\<^sub>au} \<inter> {u\<le>\<^sub>a..} = {}"
    is preorder.ivl_disj_int_one.

tts_lemma atLeastatMost_empty_iff2:
  assumes "a \<in> U" and "b \<in> U"
  shows "({} = {a\<le>\<^sub>a..\<le>\<^sub>ab}) = (\<not> a \<le>\<^sub>a b)"
    is preorder.atLeastatMost_empty_iff2.

tts_lemma atLeastLessThan_empty_iff2:
  assumes "a \<in> U" and "b \<in> U"
  shows "({} = {a\<le>\<^sub>a..<\<^sub>ab}) = (\<not> a <\<^sub>a b)"
    is preorder.atLeastLessThan_empty_iff2.

tts_lemma greaterThanAtMost_empty_iff2:
  assumes "k \<in> U" and "l \<in> U"
  shows "({} = {k<\<^sub>a..\<le>\<^sub>al}) = (\<not> k <\<^sub>a l)"
    is preorder.greaterThanAtMost_empty_iff2.

tts_lemma atLeastatMost_empty_iff:
  assumes "a \<in> U" and "b \<in> U"
  shows "({a\<le>\<^sub>a..\<le>\<^sub>ab} = {}) = (\<not> a \<le>\<^sub>a b)"
    is preorder.atLeastatMost_empty_iff.

tts_lemma atLeastLessThan_empty_iff:
  assumes "a \<in> U" and "b \<in> U"
  shows "({a\<le>\<^sub>a..<\<^sub>ab} = {}) = (\<not> a <\<^sub>a b)"
    is preorder.atLeastLessThan_empty_iff.

tts_lemma greaterThanAtMost_empty_iff:
  assumes "k \<in> U" and "l \<in> U"
  shows "({k<\<^sub>a..\<le>\<^sub>al} = {}) = (\<not> k <\<^sub>a l)"
    is preorder.greaterThanAtMost_empty_iff.

tts_lemma atLeastLessThan_empty:
  assumes "b \<in> U" and "a \<in> U" and "b \<le>\<^sub>a a"
  shows "{a\<le>\<^sub>a..<\<^sub>ab} = {}"
    is preorder.atLeastLessThan_empty.

tts_lemma greaterThanAtMost_empty:
  assumes "l \<in> U" and "k \<in> U" and "l \<le>\<^sub>a k"
  shows "{k<\<^sub>a..\<le>\<^sub>al} = {}"
    is preorder.greaterThanAtMost_empty.

tts_lemma greaterThanLessThan_empty:
  assumes "l \<in> U" and "k \<in> U" and "l \<le>\<^sub>a k"
  shows "{k<\<^sub>a..<\<^sub>al} = {}"
    is preorder.greaterThanLessThan_empty.

tts_lemma le_less_trans:
  assumes "x \<in> U" and "y \<in> U" and "z \<in> U" and "x \<le>\<^sub>a y" and "y <\<^sub>a z"
  shows "x <\<^sub>a z"
    is preorder.le_less_trans.

tts_lemma atLeastatMost_empty:
  assumes "b \<in> U" and "a \<in> U" and "b <\<^sub>a a"
  shows "{a\<le>\<^sub>a..\<le>\<^sub>ab} = {}"
    is preorder.atLeastatMost_empty.

tts_lemma less_le_trans:
  assumes "x \<in> U" and "y \<in> U" and "z \<in> U" and "x <\<^sub>a y" and "y \<le>\<^sub>a z"
  shows "x <\<^sub>a z"
    is preorder.less_le_trans.

tts_lemma less_trans:
  assumes "x \<in> U" and "y \<in> U" and "z \<in> U" and "x <\<^sub>a y" and "y <\<^sub>a z"
  shows "x <\<^sub>a z"
    is preorder.less_trans.

tts_lemma ivl_disj_int_two:
  assumes "l \<in> U" and "m \<in> U" and "u \<in> U"
  shows
    "{l<\<^sub>a..<\<^sub>am} \<inter> {m\<le>\<^sub>a..<\<^sub>au} = {}"
    "{l<\<^sub>a..\<le>\<^sub>am} \<inter> {m<\<^sub>a..<\<^sub>au} = {}"
    "{l\<le>\<^sub>a..<\<^sub>am} \<inter> {m\<le>\<^sub>a..<\<^sub>au} = {}"
    "{l\<le>\<^sub>a..\<le>\<^sub>am} \<inter> {m<\<^sub>a..<\<^sub>au} = {}"
    "{l<\<^sub>a..<\<^sub>am} \<inter> {m\<le>\<^sub>a..\<le>\<^sub>au} = {}"
    "{l<\<^sub>a..\<le>\<^sub>am} \<inter> {m<\<^sub>a..\<le>\<^sub>au} = {}"
    "{l\<le>\<^sub>a..<\<^sub>am} \<inter> {m\<le>\<^sub>a..\<le>\<^sub>au} = {}"
    "{l\<le>\<^sub>a..\<le>\<^sub>am} \<inter> {m<\<^sub>a..\<le>\<^sub>au} = {}"
    is preorder.ivl_disj_int_two.

tts_lemma less_asym:
  assumes "x \<in> U" and "y \<in> U" and "x <\<^sub>a y" and "\<not> P \<Longrightarrow> y <\<^sub>a x"
  shows P
    is preorder.less_asym.

tts_lemma Iio_Int_singleton:
  assumes "k \<in> U" and "x \<in> U"
  shows "{..<\<^sub>ak} \<inter> {x} = (if x <\<^sub>a k then {x} else {})"
    is preorder.Iio_Int_singleton.

tts_lemma Ioi_le_Ico:
  assumes "a \<in> U"
  shows "{a<\<^sub>a..} \<subseteq> {a\<le>\<^sub>a..}"
    is preorder.Ioi_le_Ico.

tts_lemma Icc_subset_Iic_iff:
  assumes "l \<in> U" and "h \<in> U" and "h' \<in> U"
  shows "({l\<le>\<^sub>a..\<le>\<^sub>ah} \<subseteq> {..\<le>\<^sub>ah'}) = (\<not> l \<le>\<^sub>a h \<or> h \<le>\<^sub>a h')"
    is preorder.Icc_subset_Iic_iff.

tts_lemma atLeast_subset_iff:
  assumes "x \<in> U" and "y \<in> U"
  shows "({x\<le>\<^sub>a..} \<subseteq> {y\<le>\<^sub>a..}) = (y \<le>\<^sub>a x)"
    is preorder.atLeast_subset_iff.

tts_lemma Icc_subset_Ici_iff:
  assumes "l \<in> U" and "h \<in> U" and "l' \<in> U"
  shows "({l\<le>\<^sub>a..\<le>\<^sub>ah} \<subseteq> {l'\<le>\<^sub>a..}) = (\<not> l \<le>\<^sub>a h \<or> l' \<le>\<^sub>a l)"
    is preorder.Icc_subset_Ici_iff.

tts_lemma atLeastatMost_subset_iff:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U" and "d \<in> U"
  shows "({a\<le>\<^sub>a..\<le>\<^sub>ab} \<subseteq> {c\<le>\<^sub>a..\<le>\<^sub>ad}) = (\<not> a \<le>\<^sub>a b \<or> b \<le>\<^sub>a d \<and> c \<le>\<^sub>a a)"
    is preorder.atLeastatMost_subset_iff.

tts_lemma atLeastatMost_psubset_iff:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U" and "d \<in> U"
  shows "({a\<le>\<^sub>a..\<le>\<^sub>ab} \<subset> {c\<le>\<^sub>a..\<le>\<^sub>ad}) =
    (c \<le>\<^sub>a d \<and> (\<not> a \<le>\<^sub>a b \<or> c \<le>\<^sub>a a \<and> b \<le>\<^sub>a d \<and> (c <\<^sub>a a \<or> b <\<^sub>a d)))"
    is preorder.atLeastatMost_psubset_iff.

tts_lemma bdd_above_empty:
  assumes "U \<noteq> {}"
  shows "bdd_above {}"
    is preorder.bdd_above_empty.

tts_lemma bdd_above_Iic:
  assumes "b \<in> U"
  shows "bdd_above {..\<le>\<^sub>ab}"
    is preorder.bdd_above_Iic.

tts_lemma bdd_above_Iio:
  assumes "b \<in> U"
  shows "bdd_above {..<\<^sub>ab}"
    is preorder.bdd_above_Iio.

tts_lemma bdd_below_empty:
  assumes "U \<noteq> {}"
  shows "bdd_below {}"
    is preorder.bdd_below_empty.

tts_lemma bdd_above_Icc:
  assumes "a \<in> U" and "b \<in> U"
  shows "bdd_above {a\<le>\<^sub>a..\<le>\<^sub>ab}"
    is preorder.bdd_above_Icc.

tts_lemma bdd_above_Ico:
  assumes "a \<in> U" and "b \<in> U"
  shows "bdd_above {a\<le>\<^sub>a..<\<^sub>ab}"
    is preorder.bdd_above_Ico.

tts_lemma bdd_above_Ioc:
  assumes "a \<in> U" and "b \<in> U"
  shows "bdd_above {a<\<^sub>a..\<le>\<^sub>ab}"
    is preorder.bdd_above_Ioc.

tts_lemma bdd_above_Ioo:
  assumes "a \<in> U" and "b \<in> U"
  shows "bdd_above {a<\<^sub>a..<\<^sub>ab}"
    is preorder.bdd_above_Ioo.

tts_lemma bdd_above_Int1:
  assumes "A \<subseteq> U" and "B \<subseteq> U" and "bdd_above A"
  shows "bdd_above (A \<inter> B)"
    is preorder.bdd_above_Int1.

tts_lemma bdd_above_Int2:
  assumes "B \<subseteq> U" and "A \<subseteq> U" and "bdd_above B"
  shows "bdd_above (A \<inter> B)"
    is preorder.bdd_above_Int2.

tts_lemma bdd_below_Icc:
  assumes "a \<in> U" and "b \<in> U"
  shows "bdd_below {a\<le>\<^sub>a..\<le>\<^sub>ab}"
    is preorder.bdd_below_Icc.

tts_lemma bdd_below_Ico:
  assumes "a \<in> U" and "b \<in> U"
  shows "bdd_below {a\<le>\<^sub>a..<\<^sub>ab}"
    is preorder.bdd_below_Ico.

tts_lemma bdd_below_Ioc:
  assumes "a \<in> U" and "b \<in> U"
  shows "bdd_below {a<\<^sub>a..\<le>\<^sub>ab}"
    is preorder.bdd_below_Ioc.

tts_lemma bdd_below_Ioo:
  assumes "a \<in> U" and "b \<in> U"
  shows "bdd_below {a<\<^sub>a..<\<^sub>ab}"
    is preorder.bdd_below_Ioo.

tts_lemma bdd_below_Ici:
  assumes "a \<in> U"
  shows "bdd_below {a\<le>\<^sub>a..}"
    is preorder.bdd_below_Ici.

tts_lemma bdd_below_Ioi:
  assumes "a \<in> U"
  shows "bdd_below {a<\<^sub>a..}"
    is preorder.bdd_below_Ioi.

tts_lemma bdd_above_mono:
  assumes "B \<subseteq> U" and "bdd_above B" and "A \<subseteq> B"
  shows "bdd_above A"
    is preorder.bdd_above_mono.

tts_lemma bdd_aboveI:
  assumes "A \<subseteq> U" and "M \<in> U" and "\<And>x. \<lbrakk>x \<in> U; x \<in> A\<rbrakk> \<Longrightarrow> x \<le>\<^sub>a M"
  shows "bdd_above A"
    is preorder.bdd_aboveI.

tts_lemma bdd_aboveI2:
  assumes "range f \<subseteq> U" and "M \<in> U" and "\<And>x. x \<in> A \<Longrightarrow> f x \<le>\<^sub>a M"
  shows "bdd_above (f ` A)"
    is preorder.bdd_aboveI2.

tts_lemma bdd_below_Int1:
  assumes "A \<subseteq> U" and "B \<subseteq> U" and "bdd_below A"
  shows "bdd_below (A \<inter> B)"
    is preorder.bdd_below_Int1.

tts_lemma bdd_below_Int2:
  assumes "B \<subseteq> U" and "A \<subseteq> U" and "bdd_below B"
  shows "bdd_below (A \<inter> B)"
    is preorder.bdd_below_Int2.

tts_lemma bdd_belowI:
  assumes "A \<subseteq> U" and "m \<in> U" and "\<And>x. \<lbrakk>x \<in> U; x \<in> A\<rbrakk> \<Longrightarrow> m \<le>\<^sub>a x"
  shows "bdd_below A"
    is preorder.bdd_belowI.

tts_lemma bdd_below_mono:
  assumes "B \<subseteq> U" and "bdd_below B" and "A \<subseteq> B"
  shows "bdd_below A"
    is preorder.bdd_below_mono.

tts_lemma bdd_belowI2:
  assumes "m \<in> U" and "range f \<subseteq> U" and "\<And>x. x \<in> A \<Longrightarrow> m \<le>\<^sub>a f x"
  shows "bdd_below (f ` A)"
    is preorder.bdd_belowI2[where 'b='d].

end

end

subsection\<open>Partial orders\<close>

locale order_ow = preorder_ow U le ls
  for U :: "'a set" and le ls +
  assumes antisym: "x \<in> U \<Longrightarrow> y \<in> U \<Longrightarrow> le x y \<Longrightarrow> le y x \<Longrightarrow> x = y"

locale order_dual_ow = order_ow U le ls
  for U :: "'a set" and le ls
begin

sublocale preorder_dual_ow ..

sublocale dual: order_ow U ge gt
  unfolding order_ow_def order_ow_axioms_def
  apply unfold_locales
  apply(rule conjI)
  subgoal by (rule dual.preorder_ow_axioms)
  subgoal by (simp add: antisym)
  done

end

locale ord_order_ow =
  ord_preorder_ow U\<^sub>a le\<^sub>a ls\<^sub>a U\<^sub>b le\<^sub>b ls\<^sub>b + ord\<^sub>b: order_ow U\<^sub>b le\<^sub>b ls\<^sub>b
  for U\<^sub>a :: "'a set" and le\<^sub>a ls\<^sub>a and U\<^sub>b :: "'b set" and le\<^sub>b ls\<^sub>b

locale ord_order_dual_ow = ord_order_ow U\<^sub>a le\<^sub>a ls\<^sub>a U\<^sub>b le\<^sub>b ls\<^sub>b
  for U\<^sub>a :: "'a set" and le\<^sub>a ls\<^sub>a and U\<^sub>b :: "'b set" and le\<^sub>b ls\<^sub>b
begin

sublocale ord_preorder_dual_ow ..
sublocale ord_dual: ord_order_ow U\<^sub>a \<open>(\<le>\<^sub>a)\<close> \<open>(<\<^sub>a)\<close> U\<^sub>b \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close>
  by unfold_locales (simp add: ord\<^sub>b.antisym)
sublocale dual_ord: ord_order_ow U\<^sub>a \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> U\<^sub>b \<open>(\<le>\<^sub>b)\<close> \<open>(<\<^sub>b)\<close>
  by (rule ord_order_ow_axioms)
sublocale dual_dual: ord_order_ow U\<^sub>a \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> U\<^sub>b \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close>
  by (rule ord_dual.ord_order_ow_axioms)

end

locale preorder_order_ow =
  ord_order_ow U\<^sub>a le\<^sub>a ls\<^sub>a U\<^sub>b le\<^sub>b ls\<^sub>b + ord\<^sub>a: preorder_ow U\<^sub>a le\<^sub>a ls\<^sub>a
  for U\<^sub>a :: "'a set" and le\<^sub>a ls\<^sub>a and U\<^sub>b :: "'b set" and le\<^sub>b ls\<^sub>b
begin

sublocale preorder_pair_ow ..

end

locale preorder_order_dual_ow = preorder_order_ow U\<^sub>a le\<^sub>a ls\<^sub>a U\<^sub>b le\<^sub>b ls\<^sub>b
  for U\<^sub>a :: "'a set" and le\<^sub>a ls\<^sub>a and U\<^sub>b :: "'b set" and le\<^sub>b ls\<^sub>b
begin

sublocale ord_order_dual_ow ..
sublocale preorder_pair_dual_ow ..
sublocale ord_dual: preorder_order_ow U\<^sub>a \<open>(\<le>\<^sub>a)\<close> \<open>(<\<^sub>a)\<close> U\<^sub>b \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close> ..
sublocale dual_ord: preorder_order_ow U\<^sub>a \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> U\<^sub>b \<open>(\<le>\<^sub>b)\<close> \<open>(<\<^sub>b)\<close> ..
sublocale dual_dual: preorder_order_ow U\<^sub>a \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> U\<^sub>b \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close> ..

end

locale order_pair_ow =
  preorder_order_ow U\<^sub>a le\<^sub>a ls\<^sub>a U\<^sub>b le\<^sub>b ls\<^sub>b + ord\<^sub>a: order_ow U\<^sub>a le\<^sub>a ls\<^sub>a
  for U\<^sub>a :: "'a set" and le\<^sub>a ls\<^sub>a and U\<^sub>b :: "'b set" and le\<^sub>b ls\<^sub>b
begin

sublocale rev: order_pair_ow U\<^sub>b le\<^sub>b ls\<^sub>b U\<^sub>a le\<^sub>a ls\<^sub>a ..

end

locale order_pair_dual_ow = order_pair_ow U\<^sub>a le\<^sub>a ls\<^sub>a U\<^sub>b le\<^sub>b ls\<^sub>b
  for U\<^sub>a :: "'a set" and le\<^sub>a ls\<^sub>a and U\<^sub>b :: "'b set" and le\<^sub>b ls\<^sub>b
begin

sublocale preorder_order_dual_ow ..
sublocale ord_dual: order_pair_ow U\<^sub>a \<open>(\<le>\<^sub>a)\<close> \<open>(<\<^sub>a)\<close> U\<^sub>b \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close> ..
sublocale dual_ord: order_pair_ow U\<^sub>a \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> U\<^sub>b \<open>(\<le>\<^sub>b)\<close> \<open>(<\<^sub>b)\<close>
  by unfold_locales (simp add: ord\<^sub>a.antisym)
sublocale dual_dual: order_pair_ow U\<^sub>a \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> U\<^sub>b \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close> ..

end

subsubsection\<open>Transfer rules\<close>

lemma order_ow[ud_with]: "order = order_ow UNIV"
  unfolding
    order_def order_ow_def order_axioms_def order_ow_axioms_def ud_with
  by simp

lemma ord_order_ow[ud_with]: "ord_order = ord_order_ow UNIV"
  unfolding ord_order_def ord_order_ow_def ud_with by simp

lemma preorder_order_ow[ud_with]:
  "preorder_order =
    (\<lambda>le\<^sub>a ls\<^sub>a le\<^sub>b ls\<^sub>b. preorder_order_ow UNIV le\<^sub>a ls\<^sub>a UNIV le\<^sub>b ls\<^sub>b)"
  unfolding preorder_order_def preorder_order_ow_def ud_with by simp

lemma order_pair_ow[ud_with]:
  "order_pair = (\<lambda>le\<^sub>a ls\<^sub>a le\<^sub>b ls\<^sub>b. order_pair_ow UNIV le\<^sub>a ls\<^sub>a UNIV le\<^sub>b ls\<^sub>b)"
  unfolding order_pair_def order_pair_ow_def ud_with by simp

context
  includes lifting_syntax
begin

lemma order_ow_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "(rel_set A ===> (A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> (=))
      order_ow order_ow"
  by (ow_locale_transfer locale_defs: order_ow_def order_ow_axioms_def)

lemma ord_order_ow_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "(
      rel_set A ===> (A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===>
      (=)
    ) ord_order_ow ord_order_ow"
  by (ow_locale_transfer locale_defs: ord_order_ow_def)

lemma preorder_order_ow_transfer[transfer_rule]:
  assumes [transfer_rule]: "right_total A" "bi_unique B" "right_total B"
  shows
    "(
      rel_set A ===> (A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===>
      rel_set B ===> (B ===> B ===> (=)) ===> (B ===> B ===> (=)) ===>
      (=)
    ) preorder_order_ow preorder_order_ow"
  by (ow_locale_transfer locale_defs: preorder_order_ow_def)

lemma order_pair_ow_transfer[transfer_rule]:
  assumes [transfer_rule]:
    "bi_unique A" "right_total A" "bi_unique B" "right_total B"
  shows
    "(
      rel_set A ===> (A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===>
      rel_set B ===> (B ===> B ===> (=)) ===> (B ===> B ===> (=)) ===>
      (=)
    ) order_pair_ow order_pair_ow"
  by (ow_locale_transfer locale_defs: order_pair_ow_def)

end

subsubsection\<open>Relativization\<close>

context order_ow
begin

interpretation ord_syntax_ow .

tts_context
  tts: (?'a to U)
  sbterms: (\<open>?ls::?'a \<Rightarrow> ?'a \<Rightarrow> bool\<close> to ls)
    and (\<open>?le::?'a \<Rightarrow> ?'a \<Rightarrow> bool\<close> to le)
  rewriting ctr_simps
  substituting order_ow_axioms
  eliminating through auto
begin

tts_lemma atLeastAtMost_singleton:
  assumes "a \<in> U"
  shows "{a\<le>\<^sub>a..\<le>\<^sub>aa} = {a}"
  is order.atLeastAtMost_singleton.

tts_lemma less_imp_not_eq:
  assumes "y \<in> U" and "x <\<^sub>a y"
  shows "(x = y) = False"
  is order.less_imp_not_eq.

tts_lemma less_imp_not_eq2:
  assumes "y \<in> U" and "x <\<^sub>a y"
  shows "(y = x) = False"
    is order.less_imp_not_eq2.

tts_lemma eq_iff:
  assumes "x \<in> U" and "y \<in> U"
  shows "(x = y) = (x \<le>\<^sub>a y \<and> y \<le>\<^sub>a x)"
    is order.eq_iff.

tts_lemma le_less:
  assumes "x \<in> U" and "y \<in> U"
  shows "(x \<le>\<^sub>a y) = (x <\<^sub>a y \<or> x = y)"
    is order.le_less.

tts_lemma min_absorb2:
  assumes "y \<in> U" and "x \<in> U" and "y \<le>\<^sub>a x"
  shows "min x y = y"
    is order.min_absorb2.

tts_lemma less_le:
  assumes "x \<in> U" and "y \<in> U"
  shows "(x <\<^sub>a y) = (x \<le>\<^sub>a y \<and> x \<noteq> y)"
    is order.less_le.

tts_lemma le_imp_less_or_eq:
  assumes "x \<in> U" and "y \<in> U" and "x \<le>\<^sub>a y"
  shows "x <\<^sub>a y \<or> x = y"
    is order.le_imp_less_or_eq.

tts_lemma antisym_conv:
  assumes "y \<in> U" and "x \<in> U" and "y \<le>\<^sub>a x"
  shows "(x \<le>\<^sub>a y) = (x = y)"
    is order.antisym_conv.

tts_lemma le_neq_trans:
  assumes "a \<in> U" and "b \<in> U" and "a \<le>\<^sub>a b" and "a \<noteq> b"
  shows "a <\<^sub>a b"
    is order.le_neq_trans.

tts_lemma neq_le_trans:
  assumes "a \<in> U" and "b \<in> U" and "a \<noteq> b" and "a \<le>\<^sub>a b"
  shows "a <\<^sub>a b"
    is order.neq_le_trans.

tts_lemma atLeastAtMost_singleton':
  assumes "b \<in> U" and "a = b"
  shows "{a\<le>\<^sub>a..\<le>\<^sub>ab} = {a}"
    is order.atLeastAtMost_singleton'.

tts_lemma atLeastLessThan_eq_atLeastAtMost_diff:
  assumes "a \<in> U" and "b \<in> U"
  shows "{a\<le>\<^sub>a..<\<^sub>ab} = {a\<le>\<^sub>a..\<le>\<^sub>ab} - {b}"
    is order.atLeastLessThan_eq_atLeastAtMost_diff.

tts_lemma greaterThanAtMost_eq_atLeastAtMost_diff:
  assumes "a \<in> U" and "b \<in> U"
  shows "{a<\<^sub>a..\<le>\<^sub>ab} = {a\<le>\<^sub>a..\<le>\<^sub>ab} - {a}"
    is order.greaterThanAtMost_eq_atLeastAtMost_diff.

tts_lemma atMost_Int_atLeast:
  assumes "n \<in> U"
  shows "{..\<le>\<^sub>an} \<inter> {n\<le>\<^sub>a..} = {n}"
    is order.atMost_Int_atLeast.

tts_lemma atLeast_eq_iff:
  assumes "x \<in> U" and "y \<in> U"
  shows "({x\<le>\<^sub>a..} = {y\<le>\<^sub>a..}) = (x = y)"
    is order.atLeast_eq_iff.

tts_lemma Least_equality:
  assumes "x \<in> U" and "P x"
    and "\<And>y. \<lbrakk>y \<in> U; P y\<rbrakk> \<Longrightarrow> x \<le>\<^sub>a y"
  shows "Least P = Some x"
    is order.Least_equality.

tts_lemma Icc_eq_Icc:
  assumes "l \<in> U" and "h \<in> U" and "l' \<in> U" and "h' \<in> U"
  shows "({l\<le>\<^sub>a..\<le>\<^sub>ah} = {l'\<le>\<^sub>a..\<le>\<^sub>ah'}) =
    (h = h' \<and> l = l' \<or> \<not> l' \<le>\<^sub>a h' \<and> \<not> l \<le>\<^sub>a h)"
    is order.Icc_eq_Icc.

tts_lemma LeastI2_order:
  assumes "x \<in> U"
    and "P x"
    and "\<And>y. \<lbrakk>y \<in> U; P y\<rbrakk> \<Longrightarrow> x \<le>\<^sub>a y"
    and "\<And>x. \<lbrakk>x \<in> U; P x; \<forall>y\<in>U. P y \<longrightarrow> x \<le>\<^sub>a y\<rbrakk> \<Longrightarrow> Q x"
    and "\<And>z. \<lbrakk>z \<in> U; Least P = Some z; Q z\<rbrakk> \<Longrightarrow> thesis"
  shows thesis
    is order.LeastI2_order.

tts_lemma mono_image_least:
  assumes "\<forall>x\<in>U. f x \<in> U"
    and "m \<in> U"
    and "n \<in> U"
    and "m' \<in> U"
    and "n' \<in> U"
    and "on U with (\<le>\<^sub>a) (\<le>\<^sub>a) : \<guillemotleft>mono\<guillemotright> f"
    and "f ` {m\<le>\<^sub>a..<\<^sub>an} = {m'\<le>\<^sub>a..<\<^sub>an'}"
    and "m <\<^sub>a n"
  shows "f m = m'"
    is order.mono_image_least.

tts_lemma antisym_conv1:
  assumes "x \<in> U" and "y \<in> U" and "\<not> x <\<^sub>a y"
  shows "(x \<le>\<^sub>a y) = (x = y)"
    is order.antisym_conv1.

tts_lemma antisym_conv2:
  assumes "x \<in> U" and "y \<in> U" and "x \<le>\<^sub>a y"
  shows "(\<not> x <\<^sub>a y) = (x = y)"
    is order.antisym_conv2.

tts_lemma leD:
  assumes "y \<in> U" and "x \<in> U" and "y \<le>\<^sub>a x"
  shows "\<not> x <\<^sub>a y"
    is order.leD.

end

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting order_ow_axioms
  eliminating \<open>?A \<noteq> {}\<close> through auto
begin

tts_lemma atLeastAtMost_singleton_iff:
  assumes "a \<in> U"
    and "b \<in> U"
    and "c \<in> U"
  shows "({a\<le>\<^sub>a..\<le>\<^sub>ab} = {c}) = (a = b \<and> b = c)"
    is order.atLeastAtMost_singleton_iff.

end

tts_context
  tts: (?'a to U)
  sbterms: (\<open>?ls::?'a \<Rightarrow> ?'a \<Rightarrow> bool\<close> to ls)
    and (\<open>?le::?'a \<Rightarrow> ?'a \<Rightarrow> bool\<close> to le)
  rewriting ctr_simps
  substituting order_ow_axioms
  eliminating through auto
begin

tts_lemma Least_ex1:
  assumes "z \<in> U"
    and "\<exists>!x. x \<in> U \<and> P x \<and> (\<forall>y\<in>U. P y \<longrightarrow> x \<le>\<^sub>a y)"
    and "\<And>x. \<lbrakk>x \<in> U; Least P = Some x; P x; P z \<Longrightarrow> x \<le>\<^sub>a z\<rbrakk> \<Longrightarrow> thesis"
  shows thesis
    is order.Least_ex1.

end

end

context order_pair_ow
begin

interpretation ord_pair_syntax_ow .

tts_context
  tts: (?'a to U\<^sub>a) and (?'b to U\<^sub>b)
  sbterms: (\<open>?ls\<^sub>a::?'a \<Rightarrow> ?'a \<Rightarrow> bool\<close> to ls\<^sub>a)
    and (\<open>?le\<^sub>a::?'a \<Rightarrow> ?'a \<Rightarrow> bool\<close> to le\<^sub>a)
    and (\<open>?ls\<^sub>b::?'b \<Rightarrow> ?'b \<Rightarrow> bool\<close> to ls\<^sub>b)
    and (\<open>?le\<^sub>b::?'b \<Rightarrow> ?'b \<Rightarrow> bool\<close> to le\<^sub>b)
  rewriting ctr_simps
  substituting order_pair_ow_axioms
  eliminating through (auto simp: mono_def bdd_def)
begin

tts_lemma strict_mono_mono:
  assumes "\<forall>x\<in>U\<^sub>a. f x \<in> U\<^sub>b" and "strict_mono\<^sub>a\<^sub>b f"
  shows "mono\<^sub>a\<^sub>b f"
    is order_pair.strict_mono_mono.

tts_lemma bdd_above_image_mono:
  assumes "\<forall>x\<in>U\<^sub>a. f x \<in> U\<^sub>b" and "A \<subseteq> U\<^sub>a" and "mono\<^sub>a\<^sub>b f" and "ord\<^sub>a.bdd_above A"
  shows "ord\<^sub>b.bdd_above (f ` A)"
    is order_pair.bdd_above_image_mono.

tts_lemma bdd_below_image_mono:
  assumes "\<forall>x\<in>U\<^sub>a. f x \<in> U\<^sub>b" and "A \<subseteq> U\<^sub>a" and "mono\<^sub>a\<^sub>b f" and "ord\<^sub>a.bdd_below A"
  shows "ord\<^sub>b.bdd_below (f ` A)"
    is order_pair.bdd_below_image_mono.

tts_lemma bdd_below_image_antimono:
  assumes "\<forall>x\<in>U\<^sub>a. f x \<in> U\<^sub>b"
    and "A \<subseteq> U\<^sub>a"
    and "antimono\<^sub>a\<^sub>b f"
    and "ord\<^sub>a.bdd_above A"
  shows "ord\<^sub>b.bdd_below (f ` A)"
    is order_pair.bdd_below_image_antimono.

tts_lemma bdd_above_image_antimono:
  assumes "\<forall>x\<in>U\<^sub>a. f x \<in> U\<^sub>b"
    and "A \<subseteq> U\<^sub>a"
    and "antimono\<^sub>a\<^sub>b f"
    and "ord\<^sub>a.bdd_below A"
  shows "ord\<^sub>b.bdd_above (f ` A)"
    is order_pair.bdd_above_image_antimono.

end

end

subsection\<open>Dense orders\<close>

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

locale dense_order_ow = order_ow U le ls
  for U :: "'a set" and le ls +
  assumes dense: "\<lbrakk> x \<in> U; y \<in> U; ls x y \<rbrakk> \<Longrightarrow> (\<exists>z\<in>U. ls x z \<and> ls z y)"

locale dense_order_dual_ow = dense_order_ow U le ls
  for U :: "'a set" and le ls
begin

interpretation ord_syntax_ow .

sublocale order_dual_ow ..

sublocale dual: dense_order_ow U ge gt
  using dense by unfold_locales auto

end

locale ord_dense_order_ow =
  ord_order_ow U\<^sub>a le\<^sub>a ls\<^sub>a U\<^sub>b le\<^sub>b ls\<^sub>b + ord\<^sub>b: dense_order_ow U\<^sub>b le\<^sub>b ls\<^sub>b
  for U\<^sub>a :: "'a set" and le\<^sub>a ls\<^sub>a and U\<^sub>b :: "'b set" and le\<^sub>b ls\<^sub>b

locale ord_dense_order_dual_ow = ord_dense_order_ow U\<^sub>a le\<^sub>a ls\<^sub>a U\<^sub>b le\<^sub>b ls\<^sub>b
  for U\<^sub>a :: "'a set" and le\<^sub>a ls\<^sub>a and U\<^sub>b :: "'b set" and le\<^sub>b ls\<^sub>b
begin

sublocale ord_order_dual_ow ..
sublocale ord_dual: ord_dense_order_ow U\<^sub>a \<open>(\<le>\<^sub>a)\<close> \<open>(<\<^sub>a)\<close> U\<^sub>b \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close>
  using ord\<^sub>b.dense by unfold_locales blast
sublocale dual_ord: ord_dense_order_ow U\<^sub>a \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> U\<^sub>b \<open>(\<le>\<^sub>b)\<close> \<open>(<\<^sub>b)\<close>
  by (rule ord_dense_order_ow_axioms)
sublocale dual_dual: ord_dense_order_ow U\<^sub>a \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> U\<^sub>b \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close>
  by (rule ord_dual.ord_dense_order_ow_axioms)

end

locale preorder_dense_order_ow =
  ord_dense_order_ow U\<^sub>a le\<^sub>a ls\<^sub>a U\<^sub>b le\<^sub>b ls\<^sub>b + ord\<^sub>a: preorder_ow U\<^sub>a le\<^sub>a ls\<^sub>a
  for U\<^sub>a :: "'a set" and le\<^sub>a ls\<^sub>a and U\<^sub>b :: "'b set" and le\<^sub>b ls\<^sub>b
begin

sublocale preorder_order_ow ..

end

locale preorder_dense_order_dual_ow =
  preorder_dense_order_ow U\<^sub>a le\<^sub>a ls\<^sub>a U\<^sub>b le\<^sub>b ls\<^sub>b
  for U\<^sub>a :: "'a set" and le\<^sub>a ls\<^sub>a and U\<^sub>b :: "'b set" and le\<^sub>b ls\<^sub>b
begin

sublocale ord_dense_order_dual_ow ..
sublocale preorder_order_dual_ow ..
sublocale ord_dual: preorder_dense_order_ow U\<^sub>a \<open>(\<le>\<^sub>a)\<close> \<open>(<\<^sub>a)\<close> U\<^sub>b \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close>
  ..
sublocale dual_ord: preorder_dense_order_ow U\<^sub>a \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> U\<^sub>b \<open>(\<le>\<^sub>b)\<close> \<open>(<\<^sub>b)\<close>
  ..
sublocale dual_dual: preorder_dense_order_ow U\<^sub>a \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> U\<^sub>b \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close>
  ..

end

locale order_dense_order_ow =
  preorder_dense_order_ow U\<^sub>a le\<^sub>a ls\<^sub>a U\<^sub>b le\<^sub>b ls\<^sub>b + ord\<^sub>a: order_ow U\<^sub>a le\<^sub>a ls\<^sub>a
  for U\<^sub>a :: "'a set" and le\<^sub>a ls\<^sub>a and U\<^sub>b :: "'b set" and le\<^sub>b ls\<^sub>b
begin

sublocale order_pair_ow ..

end

locale order_dense_order_dual_ow = order_dense_order_ow U\<^sub>a le\<^sub>a ls\<^sub>a U\<^sub>b le\<^sub>b ls\<^sub>b
  for U\<^sub>a :: "'a set" and le\<^sub>a ls\<^sub>a and U\<^sub>b :: "'b set" and le\<^sub>b ls\<^sub>b
begin

sublocale preorder_dense_order_dual_ow ..
sublocale order_pair_dual_ow ..
sublocale ord_dual: order_dense_order_ow U\<^sub>a \<open>(\<le>\<^sub>a)\<close> \<open>(<\<^sub>a)\<close> U\<^sub>b \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close> ..
sublocale dual_ord: order_dense_order_ow U\<^sub>a \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> U\<^sub>b \<open>(\<le>\<^sub>b)\<close> \<open>(<\<^sub>b)\<close> ..
sublocale dual_dual: order_dense_order_ow U\<^sub>a \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> U\<^sub>b \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close> ..

end

locale dense_order_pair_ow =
  order_dense_order_ow U\<^sub>a le\<^sub>a ls\<^sub>a U\<^sub>b le\<^sub>b ls\<^sub>b + ord\<^sub>a: dense_order_ow U\<^sub>a le\<^sub>a ls\<^sub>a
  for U\<^sub>a :: "'a set" and le\<^sub>a ls\<^sub>a and U\<^sub>b :: "'b set" and le\<^sub>b ls\<^sub>b

locale dense_order_pair_dual_ow = dense_order_pair_ow U\<^sub>a le\<^sub>a ls\<^sub>a U\<^sub>b le\<^sub>b ls\<^sub>b
  for U\<^sub>a :: "'a set" and le\<^sub>a ls\<^sub>a and U\<^sub>b :: "'b set" and le\<^sub>b ls\<^sub>b
begin

sublocale order_dense_order_dual_ow ..
sublocale ord_dual: dense_order_pair_ow U\<^sub>a \<open>(\<le>\<^sub>a)\<close> \<open>(<\<^sub>a)\<close> U\<^sub>b \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close> ..
sublocale dual_ord: dense_order_pair_ow U\<^sub>a \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> U\<^sub>b \<open>(\<le>\<^sub>b)\<close> \<open>(<\<^sub>b)\<close>
  using ord\<^sub>a.dense by unfold_locales auto
sublocale dual_dual: dense_order_pair_ow U\<^sub>a \<open>(\<ge>\<^sub>a)\<close> \<open>(>\<^sub>a)\<close> U\<^sub>b \<open>(\<ge>\<^sub>b)\<close> \<open>(>\<^sub>b)\<close> ..

end

subsubsection\<open>Transfer rules\<close>

lemma dense_order_ow[ud_with]: "dense_order = dense_order_ow UNIV"
  unfolding
    dense_order_def dense_order_ow_def
    dense_order_axioms_def dense_order_ow_axioms_def
    ud_with
  by simp

lemma ord_dense_order_ow[ud_with]: "ord_dense_order = ord_dense_order_ow UNIV"
  unfolding ord_dense_order_def ord_dense_order_ow_def ud_with by simp

lemma preorder_dense_order_ow[ud_with]:
  "preorder_dense_order =
    (\<lambda>le\<^sub>a ls\<^sub>a le\<^sub>b ls\<^sub>b. preorder_dense_order_ow UNIV le\<^sub>a ls\<^sub>a UNIV le\<^sub>b ls\<^sub>b)"
  unfolding preorder_dense_order_def preorder_dense_order_ow_def ud_with
  by simp

lemma order_dense_order_ow[ud_with]:
  "order_dense_order =
    (\<lambda>le\<^sub>a ls\<^sub>a le\<^sub>b ls\<^sub>b. order_dense_order_ow UNIV le\<^sub>a ls\<^sub>a UNIV le\<^sub>b ls\<^sub>b)"
  unfolding order_dense_order_def order_dense_order_ow_def ud_with by simp

lemma dense_order_pair_ow[ud_with]:
  "dense_order_pair =
    (\<lambda>le\<^sub>a ls\<^sub>a le\<^sub>b ls\<^sub>b. dense_order_pair_ow UNIV le\<^sub>a ls\<^sub>a UNIV le\<^sub>b ls\<^sub>b)"
  unfolding dense_order_pair_def dense_order_pair_ow_def ud_with by simp

context
  includes lifting_syntax
begin

lemma desne_order_ow_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "(rel_set A ===> (A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> (=))
      dense_order_ow dense_order_ow"
  by
    (
      ow_locale_transfer locale_defs:
        dense_order_ow_def dense_order_ow_axioms_def
    )

lemma ord_dense_order_ow_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "(
      rel_set A ===> (A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===>
      (=)
    ) ord_dense_order_ow ord_dense_order_ow"
  by (ow_locale_transfer locale_defs: ord_dense_order_ow_def)

lemma preorder_dense_order_ow_transfer[transfer_rule]:
  assumes [transfer_rule]: "right_total A" "bi_unique B" "right_total B"
  shows
    "(
      rel_set A ===> (A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===>
      rel_set B ===> (B ===> B ===> (=)) ===> (B ===> B ===> (=)) ===>
      (=)
    ) preorder_dense_order_ow preorder_dense_order_ow"
  by (ow_locale_transfer locale_defs: preorder_dense_order_ow_def)

lemma order_dense_order_ow_transfer[transfer_rule]:
  assumes [transfer_rule]:
    "bi_unique A" "right_total A" "bi_unique B" "right_total B"
  shows
    "(
      rel_set A ===> (A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===>
      rel_set B ===> (B ===> B ===> (=)) ===> (B ===> B ===> (=)) ===>
      (=)
    ) order_dense_order_ow order_dense_order_ow"
  by (ow_locale_transfer locale_defs: order_dense_order_ow_def)

lemma dense_order_pair_ow_transfer[transfer_rule]:
  assumes [transfer_rule]:
    "bi_unique A" "right_total A" "bi_unique B" "right_total B"
  shows
    "(
      rel_set A ===> (A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===>
      rel_set B ===> (B ===> B ===> (=)) ===> (B ===> B ===> (=)) ===>
      (=)
    ) dense_order_pair_ow dense_order_pair_ow"
  by (ow_locale_transfer locale_defs: dense_order_pair_ow_def)

end

subsection\<open>(Unique) top and bottom elements\<close>

locale extremum_ow =
  fixes U :: "'a set" and extremum
  assumes extremum_closed[simp]: "extremum \<in> U"

locale bot_ow = extremum_ow U bot for U :: "'a set" and bot
begin

notation bot ("\<bottom>")

end

locale top_ow = extremum_ow U top for U :: "'a set" and top
begin

notation top ("\<top>")

end

locale ord_extremum_ow = ord_ow U le ls + extremum_ow U extremum
  for U :: "'a set" and le ls extremum

locale order_extremum_ow = ord_extremum_ow U le ls extremum + order_ow U le ls
  for U :: "'a set" and le ls extremum +
  assumes extremum[simp]: "a \<in> U \<Longrightarrow> le a extremum"

locale order_bot_ow =
  order_dual_ow U le ls + dual: order_extremum_ow U ge gt bot + bot_ow U bot
  for U :: "'a set" and le ls bot

locale order_top =
  order_dual_ow U le ls + order_extremum_ow U le ls top + top_ow U top
  for U :: "'a set" and le ls top

subsubsection\<open>Transfer rules\<close>

lemma order_extremum_ow[ud_with]: "order_extremum = order_extremum_ow UNIV"
  unfolding
    order_extremum_def order_extremum_axioms_def
    order_extremum_ow_def order_extremum_ow_axioms_def
    ord_extremum_ow_def extremum_ow_def
    ud_with
  by simp

context
  includes lifting_syntax
begin

lemma extremum_ow_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A"
  shows "(rel_set A ===> A ===> (=)) extremum_ow extremum_ow"
  by (ow_locale_transfer locale_defs: extremum_ow_def)

lemma ord_extremum_ow_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A"
  shows "(rel_set A ===> A ===> (=)) ord_extremum_ow ord_extremum_ow"
  by (ow_locale_transfer locale_defs: ord_extremum_ow_def)

lemma order_extremum_ow_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "(
      rel_set A ===> (A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> A ===>
      (=)
    ) order_extremum_ow order_extremum_ow"
  by
    (
      ow_locale_transfer locale_defs:
        order_extremum_ow_def order_extremum_ow_axioms_def
    )

end

subsubsection\<open>Relativization\<close>

context order_extremum_ow
begin

interpretation ord_syntax_ow .

tts_context
  tts: (?'a to U)
  sbterms: (\<open>?le::?'a \<Rightarrow> ?'a \<Rightarrow> bool\<close> to le)
    and (\<open>?ls::?'a \<Rightarrow> ?'a \<Rightarrow> bool\<close> to ls)
  rewriting ctr_simps
  substituting order_extremum_ow_axioms
  eliminating through force
begin

tts_lemma extremum_strict:
  assumes "a \<in> U"
  shows "\<not> extremum <\<^sub>a a"
    is order_extremum.extremum_strict.

tts_lemma bdd_above_top:
  assumes "A \<subseteq> U"
  shows "bdd_above A"
    is order_extremum.bdd_above_top.

tts_lemma min_top:
  assumes "x \<in> U"
  shows "min extremum x = x"
  is order_extremum.min_top.

tts_lemma min_top2:
  assumes "x \<in> U"
  shows "min x extremum = x"
  is order_extremum.min_top2.

tts_lemma extremum_unique:
  assumes "a \<in> U"
  shows "(extremum \<le>\<^sub>a a) = (a = extremum)"
is order_extremum.extremum_unique.

tts_lemma not_eq_extremum:
  assumes "a \<in> U"
  shows "(a \<noteq> extremum) = (a <\<^sub>a extremum)"
  is order_extremum.not_eq_extremum.

tts_lemma extremum_uniqueI:
  assumes "a \<in> U" and "extremum \<le>\<^sub>a a"
  shows "a = extremum"
    is order_extremum.extremum_uniqueI.

tts_lemma max_top:
  assumes "x \<in> U"
  shows "max extremum x = extremum"
    is order_extremum.max_top.

tts_lemma max_top2:
  assumes "x \<in> U"
  shows "max x extremum = extremum"
    is order_extremum.max_top2.

tts_lemma atMost_eq_UNIV_iff:
  assumes "x \<in> U"
  shows "({..\<le>\<^sub>ax} = U) = (x = extremum)"
    is order_extremum.atMost_eq_UNIV_iff.

end

end

subsection\<open>Absence of top or bottom elements\<close>

locale no_extremum_ow = order_ow U le ls for U :: "'a set" and le ls +
  assumes gt_ex: "x \<in> U \<Longrightarrow> \<exists>y\<in>U. ls x y"

locale no_top_ow = order_dual_ow U le ls + no_extremum_ow U le ls
  for U :: "'a set" and le ls

locale no_bot_ow = order_dual_ow U le ls + dual: no_extremum_ow U ge gt
  for U :: "'a set" and le ls

subsubsection\<open>Transfer rules\<close>

lemma no_extremum_ow[ud_with]: "no_extremum = no_extremum_ow UNIV"
  unfolding
    no_extremum_def no_extremum_ow_def
    no_extremum_axioms_def no_extremum_ow_axioms_def
    ud_with
  by simp

context
  includes lifting_syntax
begin

lemma no_extremum_ow_axioms_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "(rel_set A ===> (A ===> A ===> (=)) ===> (=))
      no_extremum_ow_axioms no_extremum_ow_axioms"
  by (ow_locale_transfer locale_defs:  no_extremum_ow_axioms_def)

lemma no_extremum_ow_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "(rel_set A ===> (A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> (=))
      no_extremum_ow no_extremum_ow"
  by (ow_locale_transfer locale_defs: no_extremum_ow_def)

end

subsubsection\<open>Relativization\<close>

lemma right_total_UNIV_transfer'[transfer_rule]:
  assumes "right_total A" and "Domainp A = (\<lambda>x. x \<in> U)"
  shows "rel_set A U UNIV"
  using assms right_total_UNIV_transfer by fastforce

context no_extremum_ow
begin

interpretation ord_syntax_ow .

tts_context
  tts: (?'a to U)
  sbterms: (\<open>?le::?'a \<Rightarrow> ?'a \<Rightarrow> bool\<close> to le)
    and (\<open>?ls::?'a \<Rightarrow> ?'a \<Rightarrow> bool\<close> to ls)
  rewriting ctr_simps
  substituting no_extremum_ow_axioms
  eliminating through force
begin

tts_lemma not_UNIV_eq_Iic:
  assumes "h' \<in> U"
  shows "U \<noteq> {..\<le>\<^sub>ah'}"
  is no_extremum.not_UNIV_eq_Iic.

tts_lemma not_Iic_eq_UNIV:
  assumes "h' \<in> U"
  shows "{..\<le>\<^sub>ah'} \<noteq> U"
    is no_extremum.not_Iic_eq_UNIV.

tts_lemma not_UNIV_le_Iic:
  assumes "h \<in> U"
  shows "\<not> U \<subseteq> {..\<le>\<^sub>ah}"
    is no_extremum.not_UNIV_le_Iic.

tts_lemma not_UNIV_eq_Icc:
  assumes "l' \<in> U" and "h' \<in> U"
  shows "U \<noteq> {l'\<le>\<^sub>a..\<le>\<^sub>ah'}"
    is no_extremum.not_UNIV_eq_Icc.

tts_lemma not_Icc_eq_UNIV:
  assumes "l' \<in> U" and "h' \<in> U"
  shows "{l'\<le>\<^sub>a..\<le>\<^sub>ah'} \<noteq> U"
    is no_extremum.not_Icc_eq_UNIV.

tts_lemma not_UNIV_le_Icc:
  assumes "l \<in> U" and "h \<in> U"
  shows "\<not> U \<subseteq> {l\<le>\<^sub>a..\<le>\<^sub>ah}"
    is no_extremum.not_UNIV_le_Icc.

tts_lemma greaterThan_non_empty:
  assumes "x \<in> U"
  shows "{x<\<^sub>a..} \<noteq> {}"
    is no_extremum.greaterThan_non_empty.

tts_lemma not_Iic_eq_Ici:
  assumes "h \<in> U" and "l' \<in> U"
  shows "{..\<le>\<^sub>ah} \<noteq> {l'\<le>\<^sub>a..}"
    is no_extremum.not_Iic_eq_Ici.

tts_lemma not_Ici_eq_Iic:
  assumes "l' \<in> U" and "h \<in> U"
  shows "{l'\<le>\<^sub>a..} \<noteq> {..\<le>\<^sub>ah}"
    is no_extremum.not_Ici_eq_Iic.

tts_lemma not_Ici_le_Iic:
  assumes "l \<in> U" and "h' \<in> U"
  shows "\<not> {l\<le>\<^sub>a..} \<subseteq> {..\<le>\<^sub>ah'}"
    is no_extremum.not_Ici_le_Iic.

tts_lemma not_Icc_eq_Ici:
  assumes "l \<in> U" and "h \<in> U" and "l' \<in> U"
  shows "{l\<le>\<^sub>a..\<le>\<^sub>ah} \<noteq> {l'\<le>\<^sub>a..}"
    is no_extremum.not_Icc_eq_Ici.

tts_lemma not_Ici_eq_Icc:
  assumes "l' \<in> U" and "l \<in> U" and "h \<in> U"
  shows "{l'\<le>\<^sub>a..} \<noteq> {l\<le>\<^sub>a..\<le>\<^sub>ah}"
    is no_extremum.not_Ici_eq_Icc.

tts_lemma not_Ici_le_Icc:
  assumes "l \<in> U" and "l' \<in> U" and "h' \<in> U"
  shows "\<not> {l\<le>\<^sub>a..} \<subseteq> {l'\<le>\<^sub>a..\<le>\<^sub>ah'}"
    is no_extremum.not_Ici_le_Icc.

end

end

declare right_total_UNIV_transfer'[transfer_rule del]

text\<open>\newpage\<close>

end


section \<open>Escape path formulas are Hintikka\<close>

theory EPathHintikka imports Hintikka ProverLemmas begin

text \<open>In this theory, we show that the formulas in the sequents on a saturated escape path in a
  proof tree form a Hintikka set.
  This is a crucial part of our completeness proof.\<close>

subsection \<open>Definitions\<close>
text \<open>In this section we define a few concepts that make the following proofs easier to read.\<close>

text \<open>\<open>pseq\<close> is the sequent in a node.\<close>
definition pseq :: \<open>state \<times> rule \<Rightarrow> sequent\<close> where
  \<open>pseq z = snd (fst z)\<close>

text \<open>\<open>ptms\<close> is the list of terms in a node.\<close>
definition ptms :: \<open>state \<times> rule \<Rightarrow> tm list\<close> where
  \<open>ptms z = fst (fst z)\<close>

subsection \<open>Facts about streams\<close>

text \<open>Escape paths are infinite, so if you drop the first \<open>n\<close> nodes, you are still on the path.\<close>
lemma epath_sdrop: \<open>epath steps \<Longrightarrow> epath (sdrop n steps)\<close>
  by (induct n) (auto elim: epath.cases)

text \<open>Dropping the first \<open>n\<close> elements of a stream can only reduce the set of elements in the stream.\<close>
lemma sset_sdrop: \<open>sset (sdrop n s) \<subseteq> sset s\<close>
proof (induct n arbitrary: s)
  case (Suc n)
  then show ?case
    by (metis in_mono sdrop_simps(2) stl_sset subsetI)
qed simp

subsection  \<open>Transformation of states on an escape path\<close>
text \<open>We need to prove some lemmas about how the states of an escape path are connected.\<close>

text \<open>Since escape paths are well-formed, the eff relation holds between the nodes on the path.\<close>
lemma epath_eff:
  assumes \<open>epath steps\<close> \<open>eff (snd (shd steps)) (fst (shd steps)) ss\<close>
  shows \<open>fst (shd (stl steps)) |\<in>| ss\<close>
  using assms by (metis (mono_tags, lifting) epath.simps eff_def)

text \<open>The list of terms in a state contains the terms of the current sequent and the terms from the
  previous state.\<close>
lemma effect_tms:
  assumes \<open>(B, z') |\<in>| effect r (A, z)\<close>
  shows \<open>B = remdups (A @ subterms z @ subterms z')\<close>
  using assms by (smt (verit, best) effect.simps fempty_iff fimageE prod.simps(1))

text \<open>The two previous lemmas can be combined into a single lemma.\<close>
lemma epath_effect:
  assumes \<open>epath steps\<close> \<open>shd steps = ((A, z), r)\<close>
  shows \<open>\<exists>B z' r'. (B, z') |\<in>| effect r (A, z) \<and> shd (stl steps) = ((B, z'), r') \<and>
          (B = remdups (A @ subterms z @ subterms z'))\<close>
  using assms epath_eff effect_tms
  by (metis (mono_tags, lifting) eff_def fst_conv prod.collapse snd_conv)

text \<open>The list of terms in the next state on an escape path contains the terms in the current state
  plus the terms from the next state.\<close>
lemma epath_stl_ptms:
  assumes \<open>epath steps\<close>
  shows \<open>ptms (shd (stl steps)) = remdups (ptms (shd steps) @
    subterms (pseq (shd steps)) @ subterms (pseq (shd (stl steps))))\<close>
  using assms epath_effect
  by (metis (mono_tags) eff_def effect_tms epath_eff pseq_def ptms_def surjective_pairing)

text \<open>The list of terms never decreases on an escape path.\<close>
lemma epath_sdrop_ptms:
  assumes \<open>epath steps\<close>
  shows \<open>set (ptms (shd steps)) \<subseteq> set (ptms (shd (sdrop n steps)))\<close>
  using assms
proof (induct n)
  case (Suc n)
  then have \<open>epath (sdrop n steps)\<close>
    using epath_sdrop by blast
  then show ?case
    using Suc epath_stl_ptms by fastforce
qed simp

subsection \<open>Preservation of formulas on escape paths\<close>

text \<open>If a property will eventually hold on a path, there is some index from which it begins to
  hold, and before which it does not hold.\<close>
lemma ev_prefix_sdrop:
  assumes \<open>ev (holds P) xs\<close>
  shows \<open>\<exists>n. list_all (not P) (stake n xs) \<and> holds P (sdrop n xs)\<close>
  using assms
proof (induct xs)
  case (base xs)
  then show ?case
    by (metis list.pred_inject(1) sdrop.simps(1) stake.simps(1))
next
  case (step xs)
  then show ?case
    by (metis holds.elims(1) list.pred_inject(2) list_all_simps(2) sdrop.simps(1-2) stake.simps(1-2))
qed

text \<open>More specifically, the path will consists of a prefix and a suffix for which the property
  does not hold and does hold, respectively.\<close>
lemma ev_prefix:
  assumes \<open>ev (holds P) xs\<close>
  shows \<open>\<exists>pre suf. list_all (not P) pre \<and> holds P suf \<and> xs = pre @- suf\<close>
  using assms ev_prefix_sdrop by (metis stake_sdrop)

text \<open>All rules are always enabled, so they are also always enabled at specific steps.\<close>
lemma always_enabledAtStep: \<open>enabledAtStep r xs\<close>
  by (simp add: RuleSystem_Defs.enabled_def eff_def)

text \<open>If a formula is in the sequent in the first state of an escape path and none of the rule
  applications in some prefix of the path affect that formula, the formula will still be in the
  sequent after that prefix.\<close>
lemma epath_preserves_unaffected:
  assumes \<open>p \<in> set (pseq (shd steps))\<close> and \<open>epath steps\<close> and \<open>steps = pre @- suf\<close> and
    \<open>list_all (not (\<lambda>step. affects (snd step) p)) pre\<close>
  shows \<open>p \<in> set (pseq (shd suf))\<close>
  using assms
proof (induct pre arbitrary: steps)
  case Nil
  then show ?case
    by simp
next
  case (Cons q pre)
  from this(3) show ?case
  proof cases
    case (epath sl)
    from this(2-4) show ?thesis
      using Cons(1-2, 4-5) effect_preserves_unaffected unfolding eff_def pseq_def list_all_def
      by (metis (no_types, lifting) list.sel(1) list.set_intros(1-2) prod.exhaust_sel
          shift.simps(2) shift_simps(1) stream.sel(2))
  qed
qed

subsection \<open>Formulas on an escape path form a Hintikka set\<close>

text \<open>This definition captures the set of formulas on an entire path\<close>
definition \<open>tree_fms steps \<equiv> \<Union>ss \<in> sset steps. set (pseq ss)\<close>

text \<open>The sequent at the head of a path is in the set of formulas on that path\<close>
lemma pseq_in_tree_fms: \<open>\<lbrakk>x \<in> sset steps; p \<in> set (pseq x)\<rbrakk> \<Longrightarrow> p \<in> tree_fms steps\<close>
  using pseq_def tree_fms_def by blast

text \<open>If a formula is in the set of formulas on a path, there is some index on the path where that
  formula can be found in the sequent.\<close>
lemma tree_fms_in_pseq: \<open>p \<in> tree_fms steps \<Longrightarrow> \<exists>n. p \<in> set (pseq (steps !! n))\<close>
  unfolding pseq_def tree_fms_def using sset_range[of steps] by simp

text \<open>If a path is saturated, so is any suffix of that path (since saturation is defined in terms of
  the always operator).\<close>
lemma Saturated_sdrop: \<open>Saturated steps \<Longrightarrow> Saturated (sdrop n steps)\<close>
  by (simp add: RuleSystem_Defs.Saturated_def alw_iff_sdrop saturated_def)

text \<open>This is an abbreviation that determines whether a given rule is applied in a given state.\<close>
abbreviation \<open>is_rule r step \<equiv> snd step = r\<close>

text \<open>If a path is saturated, it is always possible to find a state in which a given rule is applied.\<close>
lemma Saturated_ev_rule:
  assumes \<open>Saturated steps\<close>
  shows \<open>ev (holds (is_rule r)) (sdrop n steps)\<close>
proof -
  have \<open>Saturated (sdrop n steps)\<close>
    using \<open>Saturated steps\<close> Saturated_sdrop by fast
  moreover have \<open>r \<in> Prover.R\<close>
    by (metis rules_repeat snth_sset)
  ultimately have \<open>saturated r (sdrop n steps)\<close>
    unfolding Saturated_def by fast
  then show ?thesis
    unfolding saturated_def using always_enabledAtStep holds.elims(3) by blast
qed

text \<open>On an escape path, the sequent is never an axiom (since that would end the branch, and escape
  paths are infinitely long).\<close>
lemma epath_never_branchDone:
  assumes \<open>epath steps\<close>
  shows \<open>alw (holds (not (branchDone o pseq))) steps\<close>
proof (rule ccontr)
  assume \<open>\<not> ?thesis\<close>
  then have \<open>ev (holds (branchDone o pseq)) steps\<close>
    by (simp add: alw_iff_sdrop ev_iff_sdrop)
  then obtain n where n: \<open>holds (branchDone o pseq) (sdrop n steps)\<close>
    using sdrop_wait by blast
  let ?suf = \<open>sdrop n steps\<close>
  have \<open>\<forall>r A. effect r (A, pseq (shd ?suf)) = {||}\<close>
    unfolding effect_def using n by simp
  moreover have \<open>epath ?suf\<close>
    using \<open>epath steps\<close> epath_sdrop by blast
  then have \<open>\<forall>r A. \<exists>z' r'. z' |\<in>| effect r (A, pseq (shd ?suf)) \<and> shd (stl ?suf) = (z', r')\<close>
    using epath_effect by (metis calculation prod.exhaust_sel pseq_def)
  ultimately show False
    by blast
qed

text \<open>Finally we arrive at the main result of this theory:
  The set of formulas on a saturated escape path form a Hintikka set.

  The proof basically says that, given a formula, we can find some index into the path where a rule
  is applied to decompose that formula into the parts needed for the Hintikka set.
  The lemmas above are used to guarantee that the formula does not disappear (and that the branch
  does not end) before the rule is applied, and that the correct formulas are generated by the
  effect function when the rule is finally applied.
  For Beta rules, only one of the constituent formulas need to be on the path, since the path runs
  along only one of the two branches.
  For Gamma and Delta rules, the construction of the list of terms in each state guarantees that
  the formulas are instantiated with terms in the Hintikka set.\<close>
lemma escape_path_Hintikka:
  assumes \<open>epath steps\<close> and \<open>Saturated steps\<close>
  shows \<open>Hintikka (tree_fms steps)\<close>
    (is \<open>Hintikka ?H\<close>)
proof
  fix n ts
  assume pre: \<open>Pre n ts \<in> ?H\<close>
  then obtain m where m: \<open>Pre n ts \<in> set (pseq (shd (sdrop m steps)))\<close>
    using tree_fms_in_pseq by auto

  show \<open>Neg (Pre n ts) \<notin> ?H\<close>
  proof
    assume \<open>Neg (Pre n ts) \<in> ?H\<close>
    then obtain k where k: \<open>Neg (Pre n ts) \<in> set (pseq (shd (sdrop k steps)))\<close>
      using tree_fms_in_pseq by auto

    let ?pre = \<open>stake (m + k) steps\<close>
    let ?suf = \<open>sdrop (m + k) steps\<close>

    have
      1: \<open>\<not> affects r (Pre n ts)\<close> and
      2: \<open>\<not> affects r (Neg (Pre n ts))\<close> for r
      unfolding affects_def by (cases r, simp_all)+

    have \<open>list_all (not (\<lambda>step. affects (snd step) (Pre n ts))) ?pre\<close>
      unfolding list_all_def using 1 by (induct ?pre) simp_all
    then have p: \<open>Pre n ts \<in> set (pseq (shd ?suf))\<close>
      using \<open>epath steps\<close> epath_preserves_unaffected m epath_sdrop
      by (metis (no_types, lifting) list.pred_mono_strong list_all_append
          sdrop_add stake_add stake_sdrop)

    have \<open>list_all (not (\<lambda>step. affects (snd step) (Neg (Pre n ts)))) ?pre\<close>
      unfolding list_all_def using 2 by (induct ?pre) simp_all
    then have np: \<open>Neg (Pre n ts) \<in> set (pseq (shd ?suf))\<close>
      using \<open>epath steps\<close> epath_preserves_unaffected k epath_sdrop
      by (smt (verit, best) add.commute list.pred_mono_strong list_all_append sdrop_add
          stake_add stake_sdrop)

    have \<open>holds (branchDone o pseq) ?suf\<close>
      using p np branchDone_contradiction by auto
    moreover have \<open>\<not> holds (branchDone o pseq) ?suf\<close>
      using \<open>epath steps\<close> epath_never_branchDone by (simp add: alw_iff_sdrop)
    ultimately show False
      by blast
  qed
next
  fix p q
  assume \<open>Dis p q \<in> ?H\<close> (is \<open>?f \<in> ?H\<close>)
  then obtain n where n: \<open>?f \<in> set (pseq (shd (sdrop n steps)))\<close>
    using tree_fms_in_pseq by auto
  let ?steps = \<open>sdrop n steps\<close>
  let ?r = AlphaDis
  have \<open>ev (holds (is_rule ?r)) ?steps\<close>
    using \<open>Saturated steps\<close> Saturated_ev_rule by blast
  then obtain pre suf where
    pre: \<open>list_all (not (is_rule ?r)) pre\<close> and
    suf: \<open>holds (is_rule ?r) suf\<close> and
    ori: \<open>?steps = pre @- suf\<close>
    using ev_prefix by blast

  have \<open>affects r ?f \<longleftrightarrow> r = ?r\<close> for r
    unfolding affects_def by (cases r) simp_all
  then have \<open>list_all (not (\<lambda>step. affects (snd step) ?f)) pre\<close>
    using pre by simp
  moreover have \<open>epath (pre @- suf)\<close>
    using \<open>epath steps\<close> epath_sdrop ori by metis
  ultimately have \<open>?f \<in> set (pseq (shd suf))\<close>
    using epath_preserves_unaffected n ori by metis

  moreover have \<open>epath suf\<close>
    using \<open>epath (pre @- suf)\<close> epath_sdrop by (metis alwD alw_iff_sdrop alw_shift)
  then obtain B z' r' where
    z': \<open>(B, z') |\<in>| effect ?r (ptms (shd suf), pseq (shd suf))\<close> \<open>shd (stl suf) = ((B, z'), r')\<close>
    using suf epath_effect unfolding pseq_def ptms_def
    by (metis (mono_tags, lifting) holds.elims(2) prod.collapse)
  ultimately have \<open>p \<in> set z'\<close> \<open>q \<in> set z'\<close>
    using parts_in_effect unfolding parts_def by fastforce+

  then show \<open>p \<in> ?H \<and> q \<in> ?H\<close>
    using z'(2) ori pseq_in_tree_fms
    by (metis (no_types, opaque_lifting) Un_iff fst_conv pseq_def shd_sset snd_conv sset_sdrop
        sset_shift stl_sset subset_eq)
next
  fix p q
  assume \<open>Imp p q \<in> tree_fms steps\<close> (is \<open>?f \<in> ?H\<close>)
  then obtain n where n: \<open>?f \<in> set (pseq (shd (sdrop n steps)))\<close>
    using tree_fms_in_pseq by auto
  let ?steps = \<open>sdrop n steps\<close>
  let ?r = AlphaImp
  have \<open>ev (holds (is_rule ?r)) ?steps\<close>
    using \<open>Saturated steps\<close> Saturated_ev_rule by blast
  then obtain pre suf where
    pre: \<open>list_all (not (is_rule ?r)) pre\<close> and
    suf: \<open>holds (is_rule ?r) suf\<close> and
    ori: \<open>?steps = pre @- suf\<close>
    using ev_prefix by blast

  have \<open>affects r ?f \<longleftrightarrow> r = ?r\<close> for r
    unfolding affects_def by (cases r) simp_all
  then have \<open>list_all (not (\<lambda>step. affects (snd step) ?f)) pre\<close>
    using pre by simp
  moreover have \<open>epath (pre @- suf)\<close>
    using \<open>epath steps\<close> epath_sdrop ori by metis
  ultimately have \<open>?f \<in> set (pseq (shd suf))\<close>
    using epath_preserves_unaffected n ori by metis

  moreover have \<open>epath suf\<close>
    using \<open>epath (pre @- suf)\<close> epath_sdrop by (metis alwD alw_iff_sdrop alw_shift)
  then obtain B z' r' where
    z': \<open>(B, z') |\<in>| effect ?r (ptms (shd suf), pseq (shd suf))\<close> \<open>shd (stl suf) = ((B, z'), r')\<close>
    using suf epath_effect unfolding pseq_def ptms_def
    by (metis (mono_tags, lifting) holds.elims(2) prod.collapse)
  ultimately have \<open>Neg p \<in> set z'\<close> \<open>q \<in> set z'\<close>
    using parts_in_effect unfolding parts_def by fastforce+

  then show \<open>Neg p \<in> ?H \<and> q \<in> ?H\<close>
    using z'(2) ori pseq_in_tree_fms
    by (metis (no_types, opaque_lifting) Un_iff fst_conv pseq_def shd_sset snd_conv sset_sdrop
        sset_shift stl_sset subset_eq)
next
  fix p q
  assume \<open>Neg (Con p q) \<in> ?H\<close> (is \<open>?f \<in> ?H\<close>)
  then obtain n where n: \<open>?f \<in> set (pseq (shd (sdrop n steps)))\<close>
    using tree_fms_in_pseq by auto
  let ?steps = \<open>sdrop n steps\<close>
  let ?r = AlphaCon
  have \<open>ev (holds (is_rule ?r)) ?steps\<close>
    using \<open>Saturated steps\<close> Saturated_ev_rule by blast
  then obtain pre suf where
    pre: \<open>list_all (not (is_rule ?r)) pre\<close> and
    suf: \<open>holds (is_rule ?r) suf\<close> and
    ori: \<open>?steps = pre @- suf\<close>
    using ev_prefix by blast

  have \<open>affects r ?f \<longleftrightarrow> r = ?r\<close> for r
    unfolding affects_def by (cases r) simp_all
  then have \<open>list_all (not (\<lambda>step. affects (snd step) ?f)) pre\<close>
    using pre by simp
  moreover have \<open>epath (pre @- suf)\<close>
    using \<open>epath steps\<close> epath_sdrop ori by metis
  ultimately have \<open>?f \<in> set (pseq (shd suf))\<close>
    using epath_preserves_unaffected n ori by metis

  moreover have \<open>epath suf\<close>
    using \<open>epath (pre @- suf)\<close> epath_sdrop by (metis alwD alw_iff_sdrop alw_shift)
  then obtain B z' r' where
    z': \<open>(B, z') |\<in>| effect ?r (ptms (shd suf), pseq (shd suf))\<close> \<open>shd (stl suf) = ((B, z'), r')\<close>
    using suf epath_effect unfolding pseq_def ptms_def
    by (metis (mono_tags, lifting) holds.elims(2) prod.collapse)
  ultimately have \<open>Neg p \<in> set z'\<close> \<open>Neg q \<in> set z'\<close>
    using parts_in_effect unfolding parts_def by fastforce+

  then show \<open>Neg p \<in> ?H \<and> Neg q \<in> ?H\<close>
    using z'(2) ori pseq_in_tree_fms
    by (metis (no_types, opaque_lifting) Un_iff fst_conv pseq_def shd_sset snd_conv sset_sdrop
        sset_shift stl_sset subset_eq)
next
  fix p q
  assume \<open>Con p q \<in> ?H\<close> (is \<open>?f \<in> ?H\<close>)
  then obtain n where n: \<open>?f \<in> set (pseq (shd (sdrop n steps)))\<close>
    using tree_fms_in_pseq by auto
  let ?steps = \<open>sdrop n steps\<close>
  let ?r = BetaCon
  have \<open>ev (holds (is_rule ?r)) ?steps\<close>
    using \<open>Saturated steps\<close> Saturated_ev_rule by blast
  then obtain pre suf where
    pre: \<open>list_all (not (is_rule ?r)) pre\<close> and
    suf: \<open>holds (is_rule ?r) suf\<close> and
    ori: \<open>?steps = pre @- suf\<close>
    using ev_prefix by blast

  have \<open>affects r ?f \<longleftrightarrow> r = ?r\<close> for r
    unfolding affects_def by (cases r) simp_all
  then have \<open>list_all (not (\<lambda>step. affects (snd step) ?f)) pre\<close>
    using pre by simp
  moreover have \<open>epath (pre @- suf)\<close>
    using \<open>epath steps\<close> epath_sdrop ori by metis
  ultimately have \<open>?f \<in> set (pseq (shd suf))\<close>
    using epath_preserves_unaffected n ori by metis

  moreover have \<open>epath suf\<close>
    using \<open>epath (pre @- suf)\<close> epath_sdrop by (metis alwD alw_iff_sdrop alw_shift)
  then obtain B z' r' where
    z': \<open>(B, z') |\<in>| effect ?r (ptms (shd suf), pseq (shd suf))\<close> \<open>shd (stl suf) = ((B, z'), r')\<close>
    using suf epath_effect unfolding pseq_def ptms_def
    by (metis (mono_tags, lifting) holds.elims(2) prod.collapse)
  ultimately consider \<open>p \<in> set z'\<close> | \<open>q \<in> set z'\<close>
    using parts_in_effect unfolding parts_def by fastforce

  then show \<open>p \<in> ?H \<or> q \<in> ?H\<close>
    using z'(2) ori pseq_in_tree_fms
    by (metis (no_types, opaque_lifting) Un_iff fst_conv pseq_def shd_sset snd_conv sset_sdrop
        sset_shift stl_sset subset_eq)
next
  fix p q
  assume \<open>Neg (Imp p q) \<in> ?H\<close> (is \<open>?f \<in> ?H\<close>)
  then obtain n where n: \<open>?f \<in> set (pseq (shd (sdrop n steps)))\<close>
    using tree_fms_in_pseq by auto
  let ?steps = \<open>sdrop n steps\<close>
  let ?r = BetaImp
  have \<open>ev (holds (is_rule ?r)) ?steps\<close>
    using \<open>Saturated steps\<close> Saturated_ev_rule by blast
  then obtain pre suf where
    pre: \<open>list_all (not (is_rule ?r)) pre\<close> and
    suf: \<open>holds (is_rule ?r) suf\<close> and
    ori: \<open>?steps = pre @- suf\<close>
    using ev_prefix by blast

  have \<open>affects r ?f \<longleftrightarrow> r = ?r\<close> for r
    unfolding affects_def by (cases r) simp_all
  then have \<open>list_all (not (\<lambda>step. affects (snd step) ?f)) pre\<close>
    using pre by simp
  moreover have \<open>epath (pre @- suf)\<close>
    using \<open>epath steps\<close> epath_sdrop ori by metis
  ultimately have \<open>?f \<in> set (pseq (shd suf))\<close>
    using epath_preserves_unaffected n ori by metis

  moreover have \<open>epath suf\<close>
    using \<open>epath (pre @- suf)\<close> epath_sdrop by (metis alwD alw_iff_sdrop alw_shift)
  then obtain B z' r' where
    z': \<open>(B, z') |\<in>| effect ?r (ptms (shd suf), pseq (shd suf))\<close> \<open>shd (stl suf) = ((B, z'), r')\<close>
    using suf epath_effect unfolding pseq_def ptms_def
    by (metis (mono_tags, lifting) holds.elims(2) prod.collapse)
  ultimately consider \<open>p \<in> set z'\<close> | \<open>Neg q \<in> set z'\<close>
    using parts_in_effect unfolding parts_def by fastforce

  then show \<open>p \<in> ?H \<or> Neg q \<in> ?H\<close>
    using z'(2) ori pseq_in_tree_fms
    by (metis (no_types, opaque_lifting) Un_iff fst_conv pseq_def shd_sset snd_conv sset_sdrop
        sset_shift stl_sset subset_eq)
next
  fix p q
  assume \<open>Neg (Dis p q) \<in> ?H\<close> (is \<open>?f \<in> ?H\<close>)
  then obtain n where n: \<open>?f \<in> set (pseq (shd (sdrop n steps)))\<close>
    using tree_fms_in_pseq by auto
  let ?steps = \<open>sdrop n steps\<close>
  let ?r = BetaDis
  have \<open>ev (holds (is_rule ?r)) ?steps\<close>
    using \<open>Saturated steps\<close> Saturated_ev_rule by blast
  then obtain pre suf where
    pre: \<open>list_all (not (is_rule ?r)) pre\<close> and
    suf: \<open>holds (is_rule ?r) suf\<close> and
    ori: \<open>?steps = pre @- suf\<close>
    using ev_prefix by blast

  have \<open>affects r ?f \<longleftrightarrow> r = ?r\<close> for r
    unfolding affects_def by (cases r) simp_all
  then have \<open>list_all (not (\<lambda>step. affects (snd step) ?f)) pre\<close>
    using pre by simp
  moreover have \<open>epath (pre @- suf)\<close>
    using \<open>epath steps\<close> epath_sdrop ori by metis
  ultimately have \<open>?f \<in> set (pseq (shd suf))\<close>
    using epath_preserves_unaffected n ori by metis

  moreover have \<open>epath suf\<close>
    using \<open>epath (pre @- suf)\<close> epath_sdrop by (metis alwD alw_iff_sdrop alw_shift)
  then obtain B z' r' where
    z': \<open>(B, z') |\<in>| effect ?r (ptms (shd suf), pseq (shd suf))\<close> \<open>shd (stl suf) = ((B, z'), r')\<close>
    using suf epath_effect unfolding pseq_def ptms_def
    by (metis (mono_tags, lifting) holds.elims(2) prod.collapse)
  ultimately consider \<open>Neg p \<in> set z'\<close> | \<open>Neg q \<in> set z'\<close>
    using parts_in_effect unfolding parts_def by fastforce

  then show \<open>Neg p \<in> ?H \<or> Neg q \<in> ?H\<close>
    using z'(2) ori pseq_in_tree_fms
    by (metis (no_types, opaque_lifting) Un_iff fst_conv pseq_def shd_sset snd_conv sset_sdrop
        sset_shift stl_sset subset_eq)
next
  fix p
  assume \<open>Exi p \<in> ?H\<close> (is \<open>?f \<in> ?H\<close>)
  then obtain n where n: \<open>?f \<in> set (pseq (shd (sdrop n steps)))\<close>
    using tree_fms_in_pseq by auto

  let ?r = GammaExi

  show \<open>\<forall>t \<in> terms ?H. sub 0 t p \<in> ?H\<close>
  proof
    fix t
    assume t: \<open>t \<in> terms ?H\<close>
    show \<open>sub 0 t p \<in> ?H\<close>
    proof -
      have \<open>\<exists>m. t \<in> set (subterms (pseq (shd (sdrop m steps))))\<close>
      proof (cases \<open>(\<Union>f \<in> ?H. set (subtermFm f)) = {}\<close>)
        case True
        moreover have \<open>\<forall>p \<in> set (pseq (shd steps)). p \<in> ?H\<close>
          unfolding tree_fms_def by (metis pseq_in_tree_fms shd_sset tree_fms_def)
        ultimately have \<open>\<forall>p \<in> set (pseq (shd steps)). subtermFm p = []\<close>
          by simp
        then have \<open>concat (map subtermFm (pseq (shd steps))) = []\<close>
          by (induct \<open>pseq (shd steps)\<close>) simp_all
        then have \<open>subterms (pseq (shd steps)) = [Fun 0 []]\<close>
          unfolding subterms_def by (metis list.simps(4) remdups_eq_nil_iff)
        then show ?thesis
          using True t unfolding terms_def
          by (metis empty_iff insert_iff list.set_intros(1) sdrop.simps(1))
      next
        case False
        then obtain pt where pt: \<open>t \<in> set (subtermFm pt)\<close> \<open>pt \<in> ?H\<close>
          using t unfolding terms_def by (metis (no_types, lifting) UN_E)
        then obtain m where m: \<open>pt \<in> set (pseq (shd (sdrop m steps)))\<close>
          using tree_fms_in_pseq by auto
        then show ?thesis
          using pt(1) set_subterms by fastforce
      qed
      then obtain m where \<open>t \<in> set (subterms (pseq (shd (sdrop m steps))))\<close>
        by blast
      then have \<open>t \<in> set (ptms (shd (stl (sdrop m steps))))\<close>
        using epath_stl_ptms epath_sdrop \<open>epath steps\<close>
        by (metis (no_types, opaque_lifting) Un_iff set_append set_remdups)
      moreover have \<open>epath (stl (sdrop m steps))\<close>
        using epath_sdrop \<open>epath steps\<close> by (meson epath.cases)
      ultimately have \<open>\<forall>k \<ge> m. t \<in> set (ptms (shd (stl (sdrop k steps))))\<close>
        using epath_sdrop_ptms by (metis (no_types, lifting) le_Suc_ex sdrop_add sdrop_stl subsetD)
      then have above: \<open>\<forall>k > m. t \<in> set (ptms (shd (sdrop k steps)))\<close>
        by (metis Nat.lessE less_irrefl_nat less_trans_Suc linorder_not_less sdrop_simps(2))

      let ?pre = \<open>stake (n + m + 1) steps\<close>
      let ?suf = \<open>sdrop (n + m + 1) steps\<close>

      have *: \<open>\<not> affects r ?f\<close> for r
        unfolding affects_def by (cases r, simp_all)+

      have \<open>ev (holds (is_rule ?r)) ?suf\<close>
        using \<open>Saturated steps\<close> Saturated_ev_rule by blast
      then obtain pre suf k where
        pre: \<open>list_all (not (is_rule ?r)) pre\<close> and
        suf: \<open>holds (is_rule ?r) suf\<close> and
        ori: \<open>pre = stake k ?suf\<close> \<open>suf = sdrop k ?suf\<close>
        using ev_prefix_sdrop by blast

      have k: \<open>\<exists>k > m. suf = sdrop k steps\<close>
        using ori by (meson le_add2 less_add_one order_le_less_trans sdrop_add trans_less_add1)

      have \<open>list_all (not (\<lambda>step. affects (snd step) ?f)) ?pre\<close>
        unfolding list_all_def using * by (induct ?pre) simp_all
      then have \<open>?f \<in> set (pseq (shd ?suf))\<close>
        using \<open>epath steps\<close> epath_preserves_unaffected n epath_sdrop
        by (metis (no_types, lifting) list.pred_mono_strong list_all_append
            sdrop_add stake_add stake_sdrop)
      then have \<open>?f \<in> set (pseq (shd suf))\<close>
        using \<open>epath steps\<close> epath_preserves_unaffected n epath_sdrop * ori
        by (metis (no_types, lifting) list.pred_mono_strong pre stake_sdrop)
      moreover have \<open>epath suf\<close>
        using \<open>epath steps\<close> epath_sdrop ori by blast
      then obtain B z' r' where
        z': \<open>(B, z') |\<in>| effect ?r (ptms (shd suf), pseq (shd suf))\<close>
        \<open>shd (stl suf) = ((B, z'), r')\<close>
        using suf epath_effect unfolding pseq_def ptms_def
        by (metis (mono_tags, lifting) holds.elims(2) prod.collapse)

      moreover have \<open>t \<in> set (ptms (shd suf))\<close>
        using above k by (meson le_add2 less_add_one order_le_less_trans)
      ultimately have \<open>sub 0 t p \<in> set z'\<close>
        using parts_in_effect[where A=\<open>ptms (shd suf)\<close>] unfolding parts_def by fastforce
      then show ?thesis
        using k pseq_in_tree_fms z'(2)
        by (metis Pair_inject in_mono prod.collapse pseq_def shd_sset sset_sdrop stl_sset)
    qed
  qed
next
  fix p
  assume \<open>Neg (Uni p) \<in> ?H\<close> (is \<open>?f \<in> ?H\<close>)
  then obtain n where n: \<open>?f \<in> set (pseq (shd (sdrop n steps)))\<close>
    using tree_fms_in_pseq by auto

  let ?r = GammaUni

  show \<open>\<forall>t \<in> terms ?H. Neg (sub 0 t p) \<in> ?H\<close>
  proof
    fix t
    assume t: \<open>t \<in> terms ?H\<close>
    show \<open>Neg (sub 0 t p) \<in> ?H\<close>
    proof -
      have \<open>\<exists>m. t \<in> set (subterms (pseq (shd (sdrop m steps))))\<close>
      proof (cases \<open>(\<Union>f \<in> ?H. set (subtermFm f)) = {}\<close>)
        case True
        moreover have \<open>\<forall>p \<in> set (pseq (shd steps)). p \<in> ?H\<close>
          unfolding tree_fms_def by (metis pseq_in_tree_fms shd_sset tree_fms_def)
        ultimately have \<open>\<forall>p \<in> set (pseq (shd steps)). subtermFm p = []\<close>
          by simp
        then have \<open>concat (map subtermFm (pseq (shd steps))) = []\<close>
          by (induct \<open>pseq (shd steps)\<close>) simp_all
        then have \<open>subterms (pseq (shd steps)) = [Fun 0 []]\<close>
          unfolding subterms_def by (metis list.simps(4) remdups_eq_nil_iff)
        then show ?thesis
          using True t unfolding terms_def
          by (metis empty_iff insert_iff list.set_intros(1) sdrop.simps(1))
      next
        case False
        then obtain pt where pt: \<open>t \<in> set (subtermFm pt)\<close> \<open>pt \<in> ?H\<close>
          using t unfolding terms_def by (metis (no_types, lifting) UN_E)
        then obtain m where m: \<open>pt \<in> set (pseq (shd (sdrop m steps)))\<close>
          using tree_fms_in_pseq by auto
        then show ?thesis
          using pt(1) set_subterms by fastforce
      qed
      then obtain m where \<open>t \<in> set (subterms (pseq (shd (sdrop m steps))))\<close>
        by blast
      then have \<open>t \<in> set (ptms (shd (stl (sdrop m steps))))\<close>
        using epath_stl_ptms epath_sdrop \<open>epath steps\<close>
        by (metis (no_types, lifting) Un_iff set_append set_remdups)
      moreover have \<open>epath (stl (sdrop m steps))\<close>
        using epath_sdrop \<open>epath steps\<close> by (meson epath.cases)
      ultimately have \<open>\<forall>k \<ge> m. t \<in> set (ptms (shd (stl (sdrop k steps))))\<close>
        using epath_sdrop_ptms by (metis (no_types, lifting) le_Suc_ex sdrop_add sdrop_stl subsetD)
      then have above: \<open>\<forall>k > m. t \<in> set (ptms (shd (sdrop k steps)))\<close>
        by (metis Nat.lessE less_irrefl_nat less_trans_Suc linorder_not_less sdrop_simps(2))

      let ?pre = \<open>stake (n + m + 1) steps\<close>
      let ?suf = \<open>sdrop (n + m + 1) steps\<close>

      have *: \<open>\<not> affects r ?f\<close> for r
        unfolding affects_def by (cases r, simp_all)+

      have \<open>ev (holds (is_rule ?r)) ?suf\<close>
        using \<open>Saturated steps\<close> Saturated_ev_rule by blast
      then obtain pre suf k where
        pre: \<open>list_all (not (is_rule ?r)) pre\<close> and
        suf: \<open>holds (is_rule ?r) suf\<close> and
        ori: \<open>pre = stake k ?suf\<close> \<open>suf = sdrop k ?suf\<close>
        using ev_prefix_sdrop by blast

      have k: \<open>\<exists>k > m. suf = sdrop k steps\<close>
        using ori by (meson le_add2 less_add_one order_le_less_trans sdrop_add trans_less_add1)

      have \<open>list_all (not (\<lambda>step. affects (snd step) ?f)) ?pre\<close>
        unfolding list_all_def using * by (induct ?pre) simp_all
      then have \<open>?f \<in> set (pseq (shd ?suf))\<close>
        using \<open>epath steps\<close> epath_preserves_unaffected n epath_sdrop
        by (metis (no_types, lifting) list.pred_mono_strong list_all_append
            sdrop_add stake_add stake_sdrop)
      then have \<open>?f \<in> set (pseq (shd suf))\<close>
        using \<open>epath steps\<close> epath_preserves_unaffected n epath_sdrop * ori
        by (metis (no_types, lifting) list.pred_mono_strong pre stake_sdrop)
      moreover have \<open>epath suf\<close>
        using \<open>epath steps\<close> epath_sdrop ori by blast
      then obtain B z' r' where
        z': \<open>(B, z') |\<in>| effect ?r (ptms (shd suf), pseq (shd suf))\<close>
        \<open>shd (stl suf) = ((B, z'), r')\<close>
        using suf epath_effect unfolding pseq_def ptms_def
        by (metis (mono_tags, lifting) holds.elims(2) prod.collapse)

      moreover have \<open>t \<in> set (ptms (shd suf))\<close>
        using above k by (meson le_add2 less_add_one order_le_less_trans)
      ultimately have \<open>Neg (sub 0 t p) \<in> set z'\<close>
        using parts_in_effect[where A=\<open>ptms (shd suf)\<close>] unfolding parts_def by fastforce
      then show ?thesis
        using k pseq_in_tree_fms z'(2)
        by (metis Pair_inject in_mono prod.collapse pseq_def shd_sset sset_sdrop stl_sset)
    qed
  qed
next
  fix p
  assume \<open>Uni p \<in> tree_fms steps\<close> (is \<open>?f \<in> ?H\<close>)
  then obtain n where n: \<open>?f \<in> set (pseq (shd (sdrop n steps)))\<close>
    using tree_fms_in_pseq by auto
  let ?steps = \<open>sdrop n steps\<close>
  let ?r = DeltaUni
  have \<open>ev (holds (is_rule ?r)) ?steps\<close>
    using \<open>Saturated steps\<close> Saturated_ev_rule by blast
  then obtain pre suf where
    pre: \<open>list_all (not (is_rule ?r)) pre\<close> and
    suf: \<open>holds (is_rule ?r) suf\<close> and
    ori: \<open>?steps = pre @- suf\<close>
    using ev_prefix by blast

  have \<open>affects r ?f \<longleftrightarrow> r = ?r\<close> for r
    unfolding affects_def by (cases r) simp_all
  then have \<open>list_all (not (\<lambda>step. affects (snd step) ?f)) pre\<close>
    using pre by simp
  moreover have \<open>epath (pre @- suf)\<close>
    using \<open>epath steps\<close> epath_sdrop ori by metis
  ultimately have \<open>?f \<in> set (pseq (shd suf))\<close>
    using epath_preserves_unaffected n ori by metis

  moreover have \<open>epath suf\<close>
    using \<open>epath (pre @- suf)\<close> epath_sdrop by (metis alwD alw_iff_sdrop alw_shift)
  then obtain B z' r' where
    z': \<open>(B, z') |\<in>| effect ?r (ptms (shd suf), pseq (shd suf))\<close> \<open>shd (stl suf) = ((B, z'), r')\<close>
    using suf epath_effect unfolding pseq_def ptms_def
    by (metis (mono_tags, lifting) holds.elims(2) prod.collapse)
  ultimately obtain C where
    C: \<open>set (ptms (shd suf)) \<subseteq> set C\<close> \<open>sub 0 (Fun (generateNew C) []) p \<in> set z'\<close>
    using parts_in_effect[where B=B and z'=\<open>z'\<close> and z=\<open>pseq (shd suf)\<close> and r=\<open>?r\<close> and p=\<open>Uni p\<close>]
    unfolding parts_def by auto
  then have *: \<open>sub 0 (Fun (generateNew C) []) p \<in> ?H\<close>
    using z'(2) ori pseq_in_tree_fms
    by (metis (no_types, lifting) Pair_inject Un_iff in_mono prod.collapse pseq_def shd_sset
        sset_sdrop sset_shift stl_sset)
  let ?t = \<open>Fun (generateNew C) []\<close>
  show \<open>\<exists>t \<in> terms ?H. sub 0 t p \<in> ?H\<close>
  proof (cases \<open>?t \<in> set (subtermFm (sub 0 ?t p))\<close>)
    case True
    then have \<open>?t \<in> terms ?H\<close>
      unfolding terms_def using * by (metis UN_I empty_iff)
    then show ?thesis
      using * by blast
  next
    case False
    then have \<open>sub 0 t p = sub 0 ?t p\<close> for t
      using sub_const_transfer by metis
    moreover have \<open>terms ?H \<noteq> {}\<close>
      unfolding terms_def by simp
    then have \<open>\<exists>t. t \<in> terms ?H\<close>
      by blast
    ultimately show ?thesis
      using * by metis
  qed
next
  fix p
  assume \<open>Neg (Exi p) \<in> tree_fms steps\<close> (is \<open>?f \<in> ?H\<close>)
  then obtain n where n: \<open>?f \<in> set (pseq (shd (sdrop n steps)))\<close>
    using tree_fms_in_pseq by auto
  let ?steps = \<open>sdrop n steps\<close>
  let ?r = DeltaExi
  have \<open>ev (holds (is_rule ?r)) ?steps\<close>
    using \<open>Saturated steps\<close> Saturated_ev_rule by blast
  then obtain pre suf where
    pre: \<open>list_all (not (is_rule ?r)) pre\<close> and
    suf: \<open>holds (is_rule ?r) suf\<close> and
    ori: \<open>?steps = pre @- suf\<close>
    using ev_prefix by blast

  have \<open>affects r ?f \<longleftrightarrow> r = ?r\<close> for r
    unfolding affects_def by (cases r) simp_all
  then have \<open>list_all (not (\<lambda>step. affects (snd step) ?f)) pre\<close>
    using pre by simp
  moreover have \<open>epath (pre @- suf)\<close>
    using \<open>epath steps\<close> epath_sdrop ori by metis
  ultimately have \<open>?f \<in> set (pseq (shd suf))\<close>
    using epath_preserves_unaffected n ori by metis

  moreover have \<open>epath suf\<close>
    using \<open>epath (pre @- suf)\<close> epath_sdrop by (metis alwD alw_iff_sdrop alw_shift)
  then obtain B z' r' where
    z': \<open>(B, z') |\<in>| effect ?r (ptms (shd suf), pseq (shd suf))\<close> \<open>shd (stl suf) = ((B, z'), r')\<close>
    using suf epath_effect unfolding pseq_def ptms_def
    by (metis (mono_tags, lifting) holds.elims(2) prod.collapse)
  ultimately obtain C where
    C: \<open>set (ptms (shd suf)) \<subseteq> set C\<close> \<open>Neg (sub 0 (Fun (generateNew C) []) p) \<in> set z'\<close>
    using parts_in_effect[where B=B and z'=z' and z=\<open>pseq (shd suf)\<close> and r=\<open>?r\<close> and p=\<open>Neg (Exi p)\<close>]
    unfolding parts_def by auto
  then have *: \<open>Neg (sub 0 (Fun (generateNew C) []) p) \<in> ?H\<close>
    using z'(2) ori pseq_in_tree_fms
    by (metis (no_types, lifting) Pair_inject Un_iff in_mono prod.collapse pseq_def shd_sset
        sset_sdrop sset_shift stl_sset)
  let ?t = \<open>Fun (generateNew C) []\<close>
  show \<open>\<exists>t \<in> terms ?H. Neg (sub 0 t p) \<in> ?H\<close>
  proof (cases \<open>?t \<in> set (subtermFm (Neg (sub 0 ?t p)))\<close>)
    case True
    then have \<open>?t \<in> terms ?H\<close>
      unfolding terms_def using * by (metis UN_I empty_iff)
    then show ?thesis
      using * by blast
  next
    case False
    then have \<open>Neg (sub 0 t p) = Neg (sub 0 ?t p)\<close> for t
      using sub_const_transfer by (metis subtermFm.simps(7))
    moreover have \<open>terms ?H \<noteq> {}\<close>
      unfolding terms_def by simp
    then have \<open>\<exists>t. t \<in> terms ?H\<close>
      by blast
    ultimately show ?thesis
      using * by metis
  qed
next
  fix p
  assume \<open>Neg (Neg p) \<in> tree_fms steps\<close> (is \<open>?f \<in> ?H\<close>)
  then obtain n where n: \<open>?f \<in> set (pseq (shd (sdrop n steps)))\<close>
    using tree_fms_in_pseq by auto
  let ?steps = \<open>sdrop n steps\<close>
  let ?r = NegNeg
  have \<open>ev (holds (is_rule ?r)) ?steps\<close>
    using \<open>Saturated steps\<close> Saturated_ev_rule by blast
  then obtain pre suf where
    pre: \<open>list_all (not (is_rule ?r)) pre\<close> and
    suf: \<open>holds (is_rule ?r) suf\<close> and
    ori: \<open>?steps = pre @- suf\<close>
    using ev_prefix by blast

  have \<open>affects r ?f \<longleftrightarrow> r = ?r\<close> for r
    unfolding affects_def by (cases r) simp_all
  then have \<open>list_all (not (\<lambda>step. affects (snd step) ?f)) pre\<close>
    using pre by simp
  moreover have \<open>epath (pre @- suf)\<close>
    using \<open>epath steps\<close> epath_sdrop ori by metis
  ultimately have \<open>?f \<in> set (pseq (shd suf))\<close>
    using epath_preserves_unaffected n ori by metis

  moreover have \<open>epath suf\<close>
    using \<open>epath (pre @- suf)\<close> epath_sdrop by (metis alwD alw_iff_sdrop alw_shift)
  then obtain B z' r' where
    z': \<open>(B, z') |\<in>| effect ?r (ptms (shd suf), pseq (shd suf))\<close> \<open>shd (stl suf) = ((B, z'), r')\<close>
    using suf epath_effect unfolding pseq_def ptms_def
    by (metis (mono_tags, lifting) holds.elims(2) prod.collapse)
  ultimately have \<open>p \<in> set z'\<close>
    using parts_in_effect unfolding parts_def by fastforce

  then show \<open>p \<in> ?H\<close>
    using z'(2) ori pseq_in_tree_fms
    by (metis (no_types, lifting) Pair_inject Un_iff in_mono prod.collapse pseq_def shd_sset
        sset_sdrop sset_shift stl_sset)
qed

end