section \<open>Dichotomous Lazard\<close>

text \<open>This theory contains Lazard's optimization in the computation of
  the subresultant PRS as described by Ducos \cite[Section 2]{Ducos}.\<close>
theory Dichotomous_Lazard
imports
  "HOL-Computational_Algebra.Polynomial_Factorial" (* to_fract *)
begin

lemma power_fract[simp]: "(Fract a b)^n = Fract (a^n) (b^n)"
  by (induct n, auto simp: fract_collapse)

lemma range_to_fract_dvd_iff: assumes b: "b \<noteq> 0"
  shows "Fract a b \<in> range to_fract \<longleftrightarrow> b dvd a"
proof
  assume "b dvd a" then obtain c where a: "a = b * c" unfolding dvd_def by auto
  have "Fract a b = Fract c 1" using b unfolding a by (simp add: eq_fract)
  thus "Fract a b \<in> range to_fract" unfolding to_fract_def by auto
next
  assume "Fract a b \<in> range to_fract"
  then obtain c where "Fract a b = Fract c 1" unfolding to_fract_def by auto
  hence "a = b * c" using b by (simp add: eq_fract)
  thus "b dvd a" ..
qed

lemma Fract_cases_coprime [cases type: fract]:
  fixes q :: "'a :: factorial_ring_gcd fract"
  obtains (Fract) a b where "q = Fract a b" "b \<noteq> 0" "coprime a b"
proof -
  obtain a b where q: "q = Fract a b" and b0: "b \<noteq> 0" by (cases q, auto)
  define g where g: "g = gcd a b"
  define A where A: "A = a div g"
  define B where B: "B = b div g"
  have a: "a = A * g" unfolding A g by simp
  have b: "b = B * g" unfolding B g by simp
  from b0 b have 0: "B \<noteq> 0" by auto
  have q: "q = Fract A B" unfolding q a b
    by (subst eq_fract, auto simp: b0 0 g)
  have cop: "coprime A B" unfolding A B g using b0
    by (simp add: div_gcd_coprime)
  assume "\<And>a b. q = Fract a b \<Longrightarrow> b \<noteq> 0 \<Longrightarrow> coprime a b \<Longrightarrow> thesis"
  from this[OF q 0 cop] show ?thesis .
qed

fun dichotomous_Lazard :: "'a :: idom_divide \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a" where
  "dichotomous_Lazard x y n = (if n \<le> 1 then if n = 1 then x else 1 else
    let (d,r) = Divides.divmod_nat n 2;
       rec = dichotomous_Lazard x y d;
       recsq = rec * rec div y in
    if r = 0 then recsq else recsq * x div y)"

lemma dichotomous_Lazard_main: fixes x :: "'a :: idom_divide"
  assumes "\<And> i. i \<le> n \<Longrightarrow> (to_fract x)^i / (to_fract y)^(i - 1) \<in> range to_fract"
  shows "to_fract (dichotomous_Lazard x y n) = (to_fract x)^n / (to_fract y)^(n-1)"
  using assms
proof (induct x y n rule: dichotomous_Lazard.induct)
  case (1 x y n)
  let ?f = to_fract
  consider (0) "n = 0" | (1) "n = 1" | (n) "\<not> n \<le> 1" by linarith
  thus ?case
  proof cases
    case n
    obtain d r where n2: "Divides.divmod_nat n 2 = (d,r)" by force
    from divmod_nat_def[of n 2] n2 have dr: "d = n div 2" "r = n mod 2" by auto
    hence r: "r = 0 \<or> r = 1" by auto
    define rec where "rec = dichotomous_Lazard x y d"
    let ?sq = "rec * rec div y"
    have res: "dichotomous_Lazard x y n = (if r = 0 then ?sq else ?sq * x div y)"
      unfolding dichotomous_Lazard.simps[of x y n] n2 Let_def rec_def using n by auto
    have ndr: "n = d + d + r" unfolding dr by presburger
    from ndr r n have d0: "d \<noteq> 0" by auto
    have IH: "?f rec = ?f x ^ d / ?f y ^ (d - 1)"
      using 1(1)[OF n refl n2[symmetric] 1(2), folded rec_def] ndr by auto
    have "?f (rec * rec) = ?f x ^ d / ?f y ^ (d - 1) * ?f x ^ d / ?f y ^ (d - 1)" using IH by simp
    also have "\<dots> = ?f x ^ (d + d) / ?f y ^ (d - 1 + (d - 1))" unfolding power_add by simp
    also have "d - 1 + (d - 1) = d + d - 2" using d0 by simp
    finally have id: "?f (rec * rec) = ?f x ^ (d + d) / ?f y ^ (d + d - 2)"  .
    let ?dd = "(?f x ^ (d + d) / ?f y ^ (d + d - 2)) / ?f y"
    let ?d = "?f x ^ (d + d) / ?f y ^ (d + d - 1)"
    have dd: "?dd = ?d" using d0 by (cases d, auto)
    have sq: "?f ?sq = ?d" unfolding dd[symmetric]
    proof (rule sym, rule div_divide_to_fract[OF _ refl refl id[symmetric] refl], unfold dd)
      show "?d \<in> range ?f" by (rule 1(2), insert ndr, auto)
    qed
    show ?thesis
    proof (cases "r = 0")
      case True
      with res sq show ?thesis unfolding ndr by auto
    next
      case False
      with r have r: "r = 1" by auto
      let ?sq' = "?sq * x div y"
      from False res have res: "dichotomous_Lazard x y n = ?sq'" by simp
      from sq have id: "?f (?sq * x) = ?f x ^ (d + d + r) / ?f y ^ (d + d - 1)"
        unfolding r by simp
      let ?dd = "(?f x ^ (d + d + r) / ?f y ^ (d + d - 1)) / ?f y"
      let ?d = "?f x ^ (d + d + r) / ?f y ^ (d + d + r - 1)"
      have dd: "?dd = ?d" using d0 unfolding r by (cases d, auto)
      have sq': "?f ?sq' = ?d" unfolding dd[symmetric]
      proof (rule sym, rule div_divide_to_fract[OF _ refl refl id[symmetric] refl], unfold dd)
        show "?d \<in> range ?f" by (rule 1(2), unfold ndr, auto)
      qed
      show ?thesis unfolding res sq' unfolding ndr by simp
    qed
  qed auto
qed

lemma dichotomous_Lazard: fixes x :: "'a :: factorial_ring_gcd"
  assumes "(to_fract x)^n / (to_fract y)^(n-1) \<in> range to_fract"
  shows "to_fract (dichotomous_Lazard x y n) = (to_fract x)^n / (to_fract y)^(n-1)"
proof (rule dichotomous_Lazard_main)
  fix i
  assume i: "i \<le> n"
  show "to_fract x ^ i / to_fract y ^ (i - 1) \<in> range to_fract"
  proof (cases i)
    case (Suc j)
    have id: "to_fract x ^ i / to_fract y ^ (i - 1) = to_fract x * (to_fract x / to_fract y) ^ j"
      unfolding Suc by (simp add: power_divide)
    from Suc i have "n \<noteq> 0" and j: "j \<le> n - 1" by auto
    hence idd: "to_fract x * (to_fract x / to_fract y) ^ (n - 1) = (to_fract x)^n / (to_fract y)^(n-1)"
      by (cases n, auto simp: power_divide)
    show ?thesis unfolding id
      by (rule to_fract_power_le[OF _ _ j], unfold idd, insert assms, auto)
  next
    case 0
    have "1 = to_fract 1" by simp
    hence "1 \<in> range to_fract" by blast
    thus ?thesis using 0 by auto
  qed
qed

declare dichotomous_Lazard.simps[simp del]

end


(*
    Author:     Stefan Merz
    Author:     Salomon Sickert
    Author:     Julian Brunner
    Author:     Peter Lammich
*)

section \<open>$\omega$-words\<close>

theory Omega_Words_Fun

imports Infinite_Set
begin

text \<open>Note: This theory is based on Stefan Merz's work.\<close>

text \<open>
  Automata recognize languages, which are sets of words. For the
  theory of $\omega$-automata, we are mostly interested in
  $\omega$-words, but it is sometimes useful to reason about
  finite words, too. We are modeling finite words as lists; this
  lets us benefit from the existing library. Other formalizations
  could be investigated, such as representing words as functions
  whose domains are initial intervals of the natural numbers.
\<close>

subsection \<open>Type declaration and elementary operations\<close>

text \<open>
  We represent $\omega$-words as functions from the natural numbers
  to the alphabet type. Other possible formalizations include
  a coinductive definition or a uniform encoding of finite and
  infinite words, as studied by M\"uller et al.
\<close>

type_synonym
  'a word = "nat \<Rightarrow> 'a"

text \<open>
  We can prefix a finite word to an $\omega$-word, and a way
  to obtain an $\omega$-word from a finite, non-empty word is by
  $\omega$-iteration.
\<close>

definition
  conc :: "['a list, 'a word] \<Rightarrow> 'a word"  (infixr "\<frown>" 65)
  where "w \<frown> x == \<lambda>n. if n < length w then w!n else x (n - length w)"

definition
  iter :: "'a list \<Rightarrow> 'a word"  ("(_\<^sup>\<omega>)" [1000])
  where "iter w == if w = [] then undefined else (\<lambda>n. w!(n mod (length w)))"

lemma conc_empty[simp]: "[] \<frown> w = w"
  unfolding conc_def by auto

lemma conc_fst[simp]: "n < length w \<Longrightarrow> (w \<frown> x) n = w!n"
  by (simp add: conc_def)

lemma conc_snd[simp]: "\<not>(n < length w) \<Longrightarrow> (w \<frown> x) n = x (n - length w)"
  by (simp add: conc_def)

lemma iter_nth [simp]: "0 < length w \<Longrightarrow> w\<^sup>\<omega> n = w!(n mod (length w))"
  by (simp add: iter_def)

lemma conc_conc[simp]: "u \<frown> v \<frown> w = (u @ v) \<frown> w" (is "?lhs = ?rhs")
proof
  fix n
  have u: "n < length u \<Longrightarrow> ?lhs n = ?rhs n"
    by (simp add: conc_def nth_append)
  have v: "\<lbrakk> \<not>(n < length u); n < length u + length v \<rbrakk> \<Longrightarrow> ?lhs n = ?rhs n"
    by (simp add: conc_def nth_append, arith)
  have w: "\<not>(n < length u + length v) \<Longrightarrow> ?lhs n = ?rhs n"
    by (simp add: conc_def nth_append, arith)
  from u v w show "?lhs n = ?rhs n" by blast
qed

lemma range_conc[simp]: "range (w\<^sub>1 \<frown> w\<^sub>2) = set w\<^sub>1 \<union> range w\<^sub>2"
proof (intro equalityI subsetI)
  fix a
  assume "a \<in> range (w\<^sub>1 \<frown> w\<^sub>2)"
  then obtain i where 1: "a = (w\<^sub>1 \<frown> w\<^sub>2) i" by auto
  then show "a \<in> set w\<^sub>1 \<union> range w\<^sub>2"
    unfolding 1 by (cases "i < length w\<^sub>1") simp_all
next
  fix a
  assume a: "a \<in> set w\<^sub>1 \<union> range w\<^sub>2"
  then show "a \<in> range (w\<^sub>1 \<frown> w\<^sub>2)"
  proof
    assume "a \<in> set w\<^sub>1"
    then obtain i where 1: "i < length w\<^sub>1" "a = w\<^sub>1 ! i"
      using in_set_conv_nth by metis
    show ?thesis
    proof
      show "a = (w\<^sub>1 \<frown> w\<^sub>2) i" using 1 by auto
      show "i \<in> UNIV" by rule
    qed
  next
    assume "a \<in> range w\<^sub>2"
    then obtain i where 1: "a = w\<^sub>2 i" by auto
    show ?thesis
    proof
      show "a = (w\<^sub>1 \<frown> w\<^sub>2) (length w\<^sub>1 + i)" using 1 by simp
      show "length w\<^sub>1 + i \<in> UNIV" by rule
    qed
  qed
qed

lemma iter_unroll: "0 < length w \<Longrightarrow> w\<^sup>\<omega> = w \<frown> w\<^sup>\<omega>"
  by (rule ext) (simp add: conc_def mod_geq)

subsection \<open>Subsequence, Prefix, and Suffix\<close>

definition suffix :: "[nat, 'a word] \<Rightarrow> 'a word"
  where "suffix k x \<equiv> \<lambda>n. x (k+n)"

definition subsequence :: "'a word \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a list"  ("_ [_ \<rightarrow> _]" 900)
  where "subsequence w i j \<equiv> map w [i..<j]"

abbreviation prefix :: "nat \<Rightarrow> 'a word \<Rightarrow> 'a list"
  where "prefix n w \<equiv> subsequence w 0 n"

lemma suffix_nth [simp]: "(suffix k x) n = x (k+n)"
  by (simp add: suffix_def)

lemma suffix_0 [simp]: "suffix 0 x = x"
  by (simp add: suffix_def)

lemma suffix_suffix [simp]: "suffix m (suffix k x) = suffix (k+m) x"
  by (rule ext) (simp add: suffix_def add.assoc)

lemma subsequence_append: "prefix (i + j) w = prefix i w @ (w [i \<rightarrow> i + j])"
  unfolding map_append[symmetric] upt_add_eq_append[OF le0] subsequence_def ..

lemma subsequence_drop[simp]: "drop i (w [j \<rightarrow> k]) = w [j + i \<rightarrow> k]"
  by (simp add: subsequence_def drop_map)

lemma subsequence_empty[simp]: "w [i \<rightarrow> j] = [] \<longleftrightarrow> j \<le> i"
  by (auto simp add: subsequence_def)

lemma subsequence_length[simp]: "length (subsequence w i j) = j - i"
  by (simp add: subsequence_def)

lemma subsequence_nth[simp]: "k < j - i \<Longrightarrow> (w [i \<rightarrow> j]) ! k = w (i + k)"
  unfolding subsequence_def
  by auto

lemma subseq_to_zero[simp]: "w[i\<rightarrow>0] = []"
  by simp

lemma subseq_to_smaller[simp]: "i\<ge>j \<Longrightarrow> w[i\<rightarrow>j] = []"
  by simp

lemma subseq_to_Suc[simp]: "i\<le>j \<Longrightarrow> w [i \<rightarrow> Suc j] = w [ i \<rightarrow> j ] @ [w j]"
  by (auto simp: subsequence_def)

lemma subsequence_singleton[simp]: "w [i \<rightarrow> Suc i] = [w i]"
  by (auto simp: subsequence_def)

lemma subsequence_prefix_suffix: "prefix (j - i) (suffix i w) = w [i \<rightarrow> j]"
proof (cases "i \<le> j")
  case True
  have "w [i \<rightarrow> j] = map w (map (\<lambda>n. n + i) [0..<j - i])"
    unfolding map_add_upt subsequence_def
    using le_add_diff_inverse2[OF True] by force
  also
  have "\<dots> = map (\<lambda>n. w (n + i)) [0..<j - i]"
    unfolding map_map comp_def by blast
  finally
  show ?thesis
    unfolding subsequence_def suffix_def add.commute[of i] by simp
next
  case False
  then show ?thesis
    by (simp add: subsequence_def)
qed

lemma prefix_suffix: "x = prefix n x \<frown> (suffix n x)"
  by (rule ext) (simp add: subsequence_def conc_def)

declare prefix_suffix[symmetric, simp]

lemma word_split: obtains v\<^sub>1 v\<^sub>2 where "v = v\<^sub>1 \<frown> v\<^sub>2" "length v\<^sub>1 = k"
proof
  show "v = prefix k v \<frown> suffix k v"
    by (rule prefix_suffix)
  show "length (prefix k v) = k"
    by simp
qed

lemma set_subsequence[simp]: "set (w[i\<rightarrow>j]) = w`{i..<j}"
  unfolding subsequence_def by auto

lemma subsequence_take[simp]: "take i (w [j \<rightarrow> k]) = w [j \<rightarrow> min (j + i) k]"
  by (simp add: subsequence_def take_map min_def)

lemma subsequence_shift[simp]: "(suffix i w) [j \<rightarrow> k] = w [i + j \<rightarrow> i + k]"
  by (metis add_diff_cancel_left subsequence_prefix_suffix suffix_suffix)

lemma suffix_subseq_join[simp]: "i \<le> j \<Longrightarrow> v [i \<rightarrow> j] \<frown> suffix j v = suffix i v"
  by (metis (no_types, lifting) Nat.add_0_right le_add_diff_inverse prefix_suffix
    subsequence_shift suffix_suffix)

lemma prefix_conc_fst[simp]:
  assumes "j \<le> length w"
  shows "prefix j (w \<frown> w') = take j w"
proof -
  have "\<forall>i < j. (prefix j (w \<frown> w')) ! i = (take j w) ! i"
    using assms by (simp add: conc_fst subsequence_def)
  thus ?thesis
    by (simp add: assms list_eq_iff_nth_eq min.absorb2)
qed

lemma prefix_conc_snd[simp]:
  assumes "n \<ge> length u"
  shows "prefix n (u \<frown> v) = u @ prefix (n - length u) v"
proof (intro nth_equalityI allI impI)
  show "length (prefix n (u \<frown> v)) = length (u @ prefix (n - length u) v)"
    using assms by simp
  fix i
  assume "i < length (prefix n (u \<frown> v))"
  then show "prefix n (u \<frown> v) ! i = (u @ prefix (n - length u) v) ! i"
    by (cases "i < length u") (auto simp: nth_append)
qed

lemma prefix_conc_length[simp]: "prefix (length w) (w \<frown> w') = w"
  by simp

lemma suffix_conc_fst[simp]:
  assumes "n \<le> length u"
  shows "suffix n (u \<frown> v) = drop n u \<frown> v"
proof
  show "suffix n (u \<frown> v) i = (drop n u \<frown> v) i" for i
    using assms by (cases "n + i < length u") (auto simp: algebra_simps)
qed

lemma suffix_conc_snd[simp]:
  assumes "n \<ge> length u"
  shows "suffix n (u \<frown> v) = suffix (n - length u) v"
proof
  show "suffix n (u \<frown> v) i = suffix (n - length u) v i" for i
    using assms by simp
qed

lemma suffix_conc_length[simp]: "suffix (length w) (w \<frown> w') = w'"
  unfolding conc_def by force

lemma concat_eq[iff]:
  assumes "length v\<^sub>1 = length v\<^sub>2"
  shows "v\<^sub>1 \<frown> u\<^sub>1 = v\<^sub>2 \<frown> u\<^sub>2 \<longleftrightarrow> v\<^sub>1 = v\<^sub>2 \<and> u\<^sub>1 = u\<^sub>2"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs
  then have 1: "(v\<^sub>1 \<frown> u\<^sub>1) i = (v\<^sub>2 \<frown> u\<^sub>2) i" for i by auto
  show ?rhs
  proof (intro conjI ext nth_equalityI allI impI)
    show "length v\<^sub>1 = length v\<^sub>2" by (rule assms(1))
  next
    fix i
    assume 2: "i < length v\<^sub>1"
    have 3: "i < length v\<^sub>2" using assms(1) 2 by simp
    show "v\<^sub>1 ! i = v\<^sub>2 ! i" using 1[of i] 2 3 by simp
  next
    show "u\<^sub>1 i = u\<^sub>2 i" for i
      using 1[of "length v\<^sub>1 + i"] assms(1) by simp
  qed
next
  assume ?rhs
  then show ?lhs by simp
qed

lemma same_concat_eq[iff]: "u \<frown> v = u \<frown> w \<longleftrightarrow> v = w"
  by simp

lemma comp_concat[simp]: "f \<circ> u \<frown> v = map f u \<frown> (f \<circ> v)"
proof
  fix i
  show "(f \<circ> u \<frown> v) i = (map f u \<frown> (f \<circ> v)) i"
    by (cases "i < length u") simp_all
qed

subsection \<open>Prepending\<close>

primrec build :: "'a \<Rightarrow> 'a word \<Rightarrow> 'a word"  (infixr "##" 65)
  where "(a ## w) 0 = a" | "(a ## w) (Suc i) = w i"

lemma build_eq[iff]: "a\<^sub>1 ## w\<^sub>1 = a\<^sub>2 ## w\<^sub>2 \<longleftrightarrow> a\<^sub>1 = a\<^sub>2 \<and> w\<^sub>1 = w\<^sub>2"
proof
  assume 1: "a\<^sub>1 ## w\<^sub>1 = a\<^sub>2 ## w\<^sub>2"
  have 2: "(a\<^sub>1 ## w\<^sub>1) i = (a\<^sub>2 ## w\<^sub>2) i" for i
    using 1 by auto
  show "a\<^sub>1 = a\<^sub>2 \<and> w\<^sub>1 = w\<^sub>2"
  proof (intro conjI ext)
    show "a\<^sub>1 = a\<^sub>2"
      using 2[of "0"] by simp
    show "w\<^sub>1 i = w\<^sub>2 i" for i
      using 2[of "Suc i"] by simp
  qed
next
  assume 1: "a\<^sub>1 = a\<^sub>2 \<and> w\<^sub>1 = w\<^sub>2"
  show "a\<^sub>1 ## w\<^sub>1 = a\<^sub>2 ## w\<^sub>2" using 1 by simp
qed

lemma build_cons[simp]: "(a # u) \<frown> v = a ## u \<frown> v"
proof
  fix i
  show "((a # u) \<frown> v) i = (a ## u \<frown> v) i"
  proof (cases i)
    case 0
    show ?thesis unfolding 0 by simp
  next
    case (Suc j)
    show ?thesis unfolding Suc by (cases "j < length u", simp+)
  qed
qed

lemma build_append[simp]: "(w @ a # u) \<frown> v = w \<frown> a ## u \<frown> v"
  unfolding conc_conc[symmetric] by simp

lemma build_first[simp]: "w 0 ## suffix (Suc 0) w = w"
proof
  show "(w 0 ## suffix (Suc 0) w) i = w i" for i
    by (cases i) simp_all
qed

lemma build_split[intro]: "w = w 0 ## suffix 1 w"
  by simp

lemma build_range[simp]: "range (a ## w) = insert a (range w)"
proof safe
  show "(a ## w) i \<notin> range w \<Longrightarrow> (a ## w) i = a" for i
    by (cases i) auto
  show "a \<in> range (a ## w)"
  proof (rule range_eqI)
    show "a = (a ## w) 0" by simp
  qed
  show "w i \<in> range (a ## w)" for i
  proof (rule range_eqI)
    show "w i = (a ## w) (Suc i)" by simp
  qed
qed

lemma suffix_singleton_suffix[simp]: "w i ## suffix (Suc i) w = suffix i w"
  using suffix_subseq_join[of i "Suc i" w]
  by simp

text \<open>Find the first occurrence of a letter from a given set\<close>
lemma word_first_split_set:
  assumes "A \<inter> range w \<noteq> {}"
  obtains u a v where "w = u \<frown> [a] \<frown> v" "A \<inter> set u = {}" "a \<in> A"
proof -
  define i where "i = (LEAST i. w i \<in> A)"
  show ?thesis
  proof
    show "w = prefix i w \<frown> [w i] \<frown> suffix (Suc i) w"
      by simp
    show "A \<inter> set (prefix i w) = {}"
      apply safe
      subgoal premises prems for a
      proof -
        from prems obtain k where 3: "k < i" "w k = a"
          by auto
        have 4: "w k \<notin> A"
          using not_less_Least 3(1) unfolding i_def .
        show ?thesis
          using prems(1) 3(2) 4 by auto
      qed
      done
    show "w i \<in> A"
      using LeastI assms(1) unfolding i_def by fast
  qed
qed

subsection \<open>The limit set of an $\omega$-word\<close>

text \<open>
  The limit set (also called infinity set) of an $\omega$-word
  is the set of letters that appear infinitely often in the word.
  This set plays an important role in defining acceptance conditions
  of $\omega$-automata.
\<close>

definition limit :: "'a word \<Rightarrow> 'a set"
  where "limit x \<equiv> {a . \<exists>\<^sub>\<infinity>n . x n = a}"

lemma limit_iff_frequent: "a \<in> limit x \<longleftrightarrow> (\<exists>\<^sub>\<infinity>n . x n = a)"
  by (simp add: limit_def)

text \<open>
  The following is a different way to define the limit,
  using the reverse image, making the laws about reverse
  image applicable to the limit set.
  (Might want to change the definition above?)
\<close>

lemma limit_vimage: "(a \<in> limit x) = infinite (x -` {a})"
  by (simp add: limit_def Inf_many_def vimage_def)

lemma two_in_limit_iff:
  "({a, b} \<subseteq> limit x) =
    ((\<exists>n. x n =a ) \<and> (\<forall>n. x n = a \<longrightarrow> (\<exists>m>n. x m = b)) \<and> (\<forall>m. x m = b \<longrightarrow> (\<exists>n>m. x n = a)))"
  (is "?lhs = (?r1 \<and> ?r2 \<and> ?r3)")
proof
  assume lhs: "?lhs"
  hence 1: "?r1" by (auto simp: limit_def elim: INFM_EX)
  from lhs have "\<forall>n. \<exists>m>n. x m = b" by (auto simp: limit_def INFM_nat)
  hence 2: "?r2" by simp
  from lhs have "\<forall>m. \<exists>n>m. x n = a" by (auto simp: limit_def INFM_nat)
  hence 3: "?r3" by simp
  from 1 2 3 show "?r1 \<and> ?r2 \<and> ?r3" by simp
next
  assume "?r1 \<and> ?r2 \<and> ?r3"
  hence 1: "?r1" and 2: "?r2" and 3: "?r3" by simp+
  have infa: "\<forall>m. \<exists>n\<ge>m. x n = a"
  proof
    fix m
    show "\<exists>n\<ge>m. x n = a" (is "?A m")
    proof (induct m)
      from 1 show "?A 0" by simp
    next
      fix m
      assume ih: "?A m"
      then obtain n where n: "n \<ge> m" "x n = a" by auto
      with 2 obtain k where k: "k>n" "x k = b" by auto
      with 3 obtain l where l: "l>k" "x l = a" by auto
      from n k l have "l \<ge> Suc m" by auto
      with l show "?A (Suc m)" by auto
    qed
  qed
  hence infa': "\<exists>\<^sub>\<infinity>n. x n = a" by (simp add: INFM_nat_le)
  have "\<forall>n. \<exists>m>n. x m = b"
  proof
    fix n
    from infa obtain k where k1: "k\<ge>n" and k2: "x k = a" by auto
    from 2 k2 obtain l where l1: "l>k" and l2: "x l = b" by auto
    from k1 l1 have "l > n" by auto
    with l2 show "\<exists>m>n. x m = b" by auto
  qed
  hence "\<exists>\<^sub>\<infinity>m. x m = b" by (simp add: INFM_nat)
  with infa' show "?lhs" by (auto simp: limit_def)
qed

text \<open>
  For $\omega$-words over a finite alphabet, the limit set is
  non-empty. Moreover, from some position onward, any such word
  contains only letters from its limit set.
\<close>

lemma limit_nonempty:
  assumes fin: "finite (range x)"
  shows "\<exists>a. a \<in> limit x"
proof -
  from fin obtain a where "a \<in> range x \<and> infinite (x -` {a})"
    by (rule inf_img_fin_domE) auto
  hence "a \<in> limit x"
    by (auto simp add: limit_vimage)
  thus ?thesis ..
qed

lemmas limit_nonemptyE = limit_nonempty[THEN exE]

lemma limit_inter_INF:
  assumes hyp: "limit w \<inter> S \<noteq> {}"
  shows "\<exists>\<^sub>\<infinity> n. w n \<in> S"
proof -
  from hyp obtain x where "\<exists>\<^sub>\<infinity> n. w n = x" and "x \<in> S"
    by (auto simp add: limit_def)
  thus ?thesis
    by (auto elim: INFM_mono)
qed

text \<open>
  The reverse implication is true only if $S$ is finite.
\<close>

lemma INF_limit_inter:
  assumes hyp: "\<exists>\<^sub>\<infinity> n. w n \<in>  S"
    and fin: "finite (S \<inter> range w)"
  shows  "\<exists>a. a \<in> limit w \<inter> S"
proof (rule ccontr)
  assume contra: "\<not>(\<exists>a. a \<in> limit w \<inter> S)"
  hence "\<forall>a\<in>S. finite {n. w n = a}"
    by (auto simp add: limit_def Inf_many_def)
  with fin have "finite (UN a:S \<inter> range w. {n. w n = a})"
    by auto
  moreover
  have "(UN a:S \<inter> range w. {n. w n = a}) = {n. w n \<in> S}"
    by auto
  moreover
  note hyp
  ultimately show "False"
    by (simp add: Inf_many_def)
qed

lemma fin_ex_inf_eq_limit: "finite A \<Longrightarrow> (\<exists>\<^sub>\<infinity>i. w i \<in> A) \<longleftrightarrow> limit w \<inter> A \<noteq> {}"
  by (metis INF_limit_inter equals0D finite_Int limit_inter_INF)

lemma limit_in_range_suffix: "limit x \<subseteq> range (suffix k x)"
proof
  fix a
  assume "a \<in> limit x"
  then obtain l where
    kl: "k < l" and xl: "x l = a"
    by (auto simp add: limit_def INFM_nat)
  from kl obtain m where "l = k+m"
    by (auto simp add:  less_iff_Suc_add)
  with xl show "a \<in> range (suffix k x)"
    by auto
qed

lemma limit_in_range: "limit r \<subseteq> range r"
  using limit_in_range_suffix[of r 0] by simp

lemmas limit_in_range_suffixD = limit_in_range_suffix[THEN subsetD]

lemma limit_subset: "limit f \<subseteq> f ` {n..}"
  using limit_in_range_suffix[of f n] unfolding suffix_def by auto

theorem limit_is_suffix:
  assumes fin: "finite (range x)"
  shows "\<exists>k. limit x = range (suffix k x)"
proof -
  have "\<exists>k. range (suffix k x) \<subseteq> limit x"
  proof -
    \<comment> "The set of letters that are not in the limit is certainly finite."
    from fin have "finite (range x - limit x)"
      by simp
    \<comment> "Moreover, any such letter occurs only finitely often"
    moreover
    have "\<forall>a \<in> range x - limit x. finite (x -` {a})"
      by (auto simp add: limit_vimage)
    \<comment> "Thus, there are only finitely many occurrences of such letters."
    ultimately have "finite (UN a : range x - limit x. x -` {a})"
      by (blast intro: finite_UN_I)
    \<comment> "Therefore these occurrences are within some initial interval."
    then obtain k where "(UN a : range x - limit x. x -` {a}) \<subseteq> {..<k}"
      by (blast dest: finite_nat_bounded)
    \<comment> "This is just the bound we are looking for."
    hence "\<forall>m. k \<le> m \<longrightarrow> x m \<in> limit x"
      by (auto simp add: limit_vimage)
    hence "range (suffix k x) \<subseteq> limit x"
      by auto
    thus ?thesis ..
  qed
  then obtain k where "range (suffix k x) \<subseteq> limit x" ..
  with limit_in_range_suffix
  have "limit x = range (suffix k x)"
    by (rule subset_antisym)
  thus ?thesis ..
qed

lemmas limit_is_suffixE = limit_is_suffix[THEN exE]

text \<open>
  The limit set enjoys some simple algebraic laws with respect
  to concatenation, suffixes, iteration, and renaming.
\<close>

theorem limit_conc [simp]: "limit (w \<frown> x) = limit x"
proof (auto)
  fix a assume a: "a \<in> limit (w \<frown> x)"
  have "\<forall>m. \<exists>n. m<n \<and> x n = a"
  proof
    fix m
    from a obtain n where "m + length w < n \<and> (w \<frown> x) n = a"
      by (auto simp add: limit_def Inf_many_def infinite_nat_iff_unbounded)
    hence "m < n - length w \<and> x (n - length w) = a"
      by (auto simp add: conc_def)
    thus "\<exists>n. m<n \<and> x n = a" ..
  qed
  hence "infinite {n . x n = a}"
    by (simp add: infinite_nat_iff_unbounded)
  thus "a \<in> limit x"
    by (simp add: limit_def Inf_many_def)
next
  fix a assume a: "a \<in> limit x"
  have "\<forall>m. length w < m \<longrightarrow> (\<exists>n. m<n \<and> (w \<frown> x) n = a)"
  proof (clarify)
    fix m
    assume m: "length w < m"
    with a obtain n where "m - length w < n \<and> x n = a"
      by (auto simp add: limit_def Inf_many_def infinite_nat_iff_unbounded)
    with m have "m < n + length w \<and> (w \<frown> x) (n + length w) = a"
      by (simp add: conc_def, arith)
    thus "\<exists>n. m<n \<and> (w \<frown> x) n = a" ..
  qed
  hence "infinite {n . (w \<frown> x) n = a}"
    by (simp add: unbounded_k_infinite)
  thus "a \<in> limit (w \<frown> x)"
    by (simp add: limit_def Inf_many_def)
qed

theorem limit_suffix [simp]: "limit (suffix n x) = limit x"
proof -
  have "x = (prefix n x) \<frown> (suffix n x)"
    by (simp add: prefix_suffix)
  hence "limit x = limit (prefix n x \<frown> suffix n x)"
    by simp
  also have "\<dots> = limit (suffix n x)"
    by (rule limit_conc)
  finally show ?thesis
    by (rule sym)
qed

theorem limit_iter [simp]:
  assumes nempty: "0 < length w"
  shows "limit w\<^sup>\<omega> = set w"
proof
  have "limit w\<^sup>\<omega> \<subseteq> range w\<^sup>\<omega>"
    by (auto simp add: limit_def dest: INFM_EX)
  also from nempty have "\<dots> \<subseteq> set w"
    by auto
  finally show "limit w\<^sup>\<omega> \<subseteq> set w" .
next
  {
    fix a assume a: "a \<in> set w"
    then obtain k where k: "k < length w \<and> w!k = a"
      by (auto simp add: set_conv_nth)
    \<comment> "the following bound is terrible, but it simplifies the proof"
    from nempty k have "\<forall>m. w\<^sup>\<omega> ((Suc m)*(length w) + k) = a"
      by (simp add: mod_add_left_eq)
    moreover
    \<comment> "why is the following so hard to prove??"
    have "\<forall>m. m < (Suc m)*(length w) + k"
    proof
      fix m
      from nempty have "1 \<le> length w" by arith
      hence "m*1 \<le> m*length w" by simp
      hence "m \<le> m*length w" by simp
      with nempty have "m < length w + (m*length w) + k" by arith
      thus "m < (Suc m)*(length w) + k" by simp
    qed
    moreover note nempty
    ultimately have "a \<in> limit w\<^sup>\<omega>"
      by (auto simp add: limit_iff_frequent INFM_nat)
  }
  then show "set w \<subseteq> limit w\<^sup>\<omega>" by auto
qed

lemma limit_o [simp]:
  assumes a: "a \<in> limit w"
  shows "f a \<in> limit (f \<circ> w)"
proof -
  from a
  have "\<exists>\<^sub>\<infinity>n. w n = a"
    by (simp add: limit_iff_frequent)
  hence "\<exists>\<^sub>\<infinity>n. f (w n) = f a"
    by (rule INFM_mono, simp)
  thus "f a \<in> limit (f \<circ> w)"
    by (simp add: limit_iff_frequent)
qed

text \<open>
  The converse relation is not true in general: $f(a)$ can be in the
  limit of $f \circ w$ even though $a$ is not in the limit of $w$.
  However, \<open>limit\<close> commutes with renaming if the function is
  injective. More generally, if $f(a)$ is the image of only finitely
  many elements, some of these must be in the limit of $w$.
\<close>

lemma limit_o_inv:
  assumes fin: "finite (f -` {x})"
    and x: "x \<in> limit (f \<circ> w)"
  shows "\<exists>a \<in> (f -` {x}). a \<in> limit w"
proof (rule ccontr)
  assume contra: "\<not> ?thesis"
  \<comment> "hence, every element in the pre-image occurs only finitely often"
  then have "\<forall>a \<in> (f -` {x}). finite {n. w n = a}"
    by (simp add: limit_def Inf_many_def)
  \<comment> "so there are only finitely many occurrences of any such element"
  with fin have "finite (\<Union> a \<in> (f -` {x}). {n. w n = a})"
    by auto
  \<comment> \<open>these are precisely those positions where $x$ occurs in $f \circ w$\<close>
  moreover
  have "(\<Union> a \<in> (f -` {x}). {n. w n = a}) = {n. f(w n) = x}"
    by auto
  ultimately
  \<comment> "so $x$ can occur only finitely often in the translated word"
  have "finite {n. f(w n) = x}"
    by simp
  \<comment> \<open>\ldots\ which yields a contradiction\<close>
  with x show "False"
    by (simp add: limit_def Inf_many_def)
qed

theorem limit_inj [simp]:
  assumes inj: "inj f"
  shows "limit (f \<circ> w) = f ` (limit w)"
proof
  show "f ` limit w \<subseteq> limit (f \<circ> w)"
    by auto
  show "limit (f \<circ> w) \<subseteq> f ` limit w"
  proof
    fix x
    assume x: "x \<in> limit (f \<circ> w)"
    from inj have "finite (f -` {x})"
      by (blast intro: finite_vimageI)
    with x obtain a where a: "a \<in> (f -` {x}) \<and> a \<in> limit w"
      by (blast dest: limit_o_inv)
    thus "x \<in> f ` (limit w)"
      by auto
  qed
qed

lemma limit_inter_empty:
  assumes fin: "finite (range w)"
  assumes hyp: "limit w \<inter> S = {}"
  shows "\<forall>\<^sub>\<infinity>n. w n \<notin> S"
proof -
  from fin obtain k where k_def: "limit w = range (suffix k w)"
    using limit_is_suffix by blast
  have "w (k + k') \<notin> S" for k'
    using hyp unfolding k_def suffix_def image_def by blast
  thus ?thesis
    unfolding MOST_nat_le using le_Suc_ex by blast
qed

text \<open>If the limit is the suffix of the sequence's range,
  we may increase the suffix index arbitrarily\<close>
lemma limit_range_suffix_incr:
  assumes "limit r = range (suffix i r)"
  assumes "j\<ge>i"
  shows "limit r = range (suffix j r)"
    (is "?lhs = ?rhs")
proof -
  have "?lhs = range (suffix i r)"
    using assms by simp
  moreover
  have "\<dots> \<supseteq> ?rhs" using \<open>j\<ge>i\<close>
    by (metis (mono_tags, lifting) assms(2)
        image_subsetI le_Suc_ex range_eqI suffix_def suffix_suffix)
  moreover
  have "\<dots> \<supseteq> ?lhs" by (rule limit_in_range_suffix)
  ultimately
  show "?lhs = ?rhs"
    by (metis antisym_conv limit_in_range_suffix)
qed

text \<open>For two finite sequences, we can find a common suffix index such
  that the limits can be represented as these suffixes' ranges.\<close>
lemma common_range_limit:
  assumes "finite (range x)"
    and "finite (range y)"
  obtains i where "limit x = range (suffix i x)"
    and "limit y = range (suffix i y)"
proof -
  obtain i j where 1: "limit x = range (suffix i x)"
    and 2: "limit y = range (suffix j y)"
    using assms limit_is_suffix by metis
  have "limit x = range (suffix (max i j) x)"
    and "limit y = range (suffix (max i j) y)"
    using limit_range_suffix_incr[OF 1] limit_range_suffix_incr[OF 2]
    by auto
  thus ?thesis
    using that by metis
qed

subsection \<open>Index sequences and piecewise definitions\<close>

text \<open>
  A word can be defined piecewise: given a sequence of words $w_0, w_1, \ldots$
  and a strictly increasing sequence of integers $i_0, i_1, \ldots$ where $i_0=0$,
  a single word is obtained by concatenating subwords of the $w_n$ as given by
  the integers: the resulting word is
  \[
    (w_0)_{i_0} \ldots (w_0)_{i_1-1} (w_1)_{i_1} \ldots (w_1)_{i_2-1} \ldots
  \]
  We prepare the field by proving some trivial facts about such sequences of
  indexes.
\<close>

definition idx_sequence :: "nat word \<Rightarrow> bool"
  where "idx_sequence idx \<equiv> (idx 0 = 0) \<and> (\<forall>n. idx n < idx (Suc n))"

lemma idx_sequence_less:
  assumes iseq: "idx_sequence idx"
  shows "idx n < idx (Suc(n+k))"
proof (induct k)
  from iseq show "idx n < idx (Suc (n + 0))"
    by (simp add: idx_sequence_def)
next
  fix k
  assume ih: "idx n < idx (Suc(n+k))"
  from iseq have "idx (Suc(n+k)) < idx (Suc(n + Suc k))"
    by (simp add: idx_sequence_def)
  with ih show "idx n < idx (Suc(n + Suc k))"
    by (rule less_trans)
qed

lemma idx_sequence_inj:
  assumes iseq: "idx_sequence idx"
    and eq: "idx m = idx n"
  shows "m = n"
proof (cases m n rule: linorder_cases)
  case greater
  then obtain k where "m = Suc(n+k)"
    by (auto simp add: less_iff_Suc_add)
  with iseq have "idx n < idx m"
    by (simp add: idx_sequence_less)
  with eq show ?thesis
    by simp
next
  case less
  then obtain k where "n = Suc(m+k)"
    by (auto simp add: less_iff_Suc_add)
  with iseq have "idx m < idx n"
    by (simp add: idx_sequence_less)
  with eq show ?thesis
    by simp
qed

lemma idx_sequence_mono:
  assumes iseq: "idx_sequence idx"
    and m: "m \<le> n"
  shows "idx m \<le> idx n"
proof (cases "m=n")
  case True
  thus ?thesis by simp
next
  case False
  with m have "m < n" by simp
  then obtain k where "n = Suc(m+k)"
    by (auto simp add: less_iff_Suc_add)
  with iseq have "idx m < idx n"
    by (simp add: idx_sequence_less)
  thus ?thesis by simp
qed

text \<open>
  Given an index sequence, every natural number is contained in the
  interval defined by two adjacent indexes, and in fact this interval
  is determined uniquely.
\<close>

lemma idx_sequence_idx:
  assumes "idx_sequence idx"
  shows "idx k \<in> {idx k ..< idx (Suc k)}"
using assms by (auto simp add: idx_sequence_def)

lemma idx_sequence_interval:
  assumes iseq: "idx_sequence idx"
  shows "\<exists>k. n \<in> {idx k ..< idx (Suc k) }"
    (is "?P n" is "\<exists>k. ?in n k")
proof (induct n)
  from iseq have "0 = idx 0"
    by (simp add: idx_sequence_def)
  moreover
  from iseq have "idx 0 \<in> {idx 0 ..< idx (Suc 0) }"
    by (rule idx_sequence_idx)
  ultimately
  show "?P 0" by auto
next
  fix n
  assume "?P n"
  then obtain k where k: "?in n k" ..
  show "?P (Suc n)"
  proof (cases "Suc n < idx (Suc k)")
    case True
    with k have "?in (Suc n) k"
      by simp
    thus ?thesis ..
  next
    case False
    with k have "Suc n = idx (Suc k)"
      by auto
    with iseq have "?in (Suc n) (Suc k)"
      by (simp add: idx_sequence_def)
    thus ?thesis ..
  qed
qed

lemma idx_sequence_interval_unique:
  assumes iseq: "idx_sequence idx"
    and k: "n \<in> {idx k ..< idx (Suc k)}"
    and m: "n \<in> {idx m ..< idx (Suc m)}"
  shows "k = m"
proof (cases k m rule: linorder_cases)
  case less
  hence "Suc k \<le> m" by simp
  with iseq have "idx (Suc k) \<le> idx m"
    by (rule idx_sequence_mono)
  with m have "idx (Suc k) \<le> n"
    by auto
  with k have "False"
    by simp
  thus ?thesis ..
next
  case greater
  hence "Suc m \<le> k" by simp
  with iseq have "idx (Suc m) \<le> idx k"
    by (rule idx_sequence_mono)
  with k have "idx (Suc m) \<le> n"
    by auto
  with m have "False"
    by simp
  thus ?thesis ..
qed

lemma idx_sequence_unique_interval:
  assumes iseq: "idx_sequence idx"
  shows "\<exists>! k. n \<in> {idx k ..< idx (Suc k) }"
proof (rule ex_ex1I)
  from iseq show "\<exists>k. n \<in> {idx k ..< idx (Suc k)}"
    by (rule idx_sequence_interval)
next
  fix k y
  assume "n \<in> {idx k..<idx (Suc k)}" and "n \<in> {idx y..<idx (Suc y)}"
  with iseq show "k = y" by (auto elim: idx_sequence_interval_unique)
qed

text \<open>
  Now we can define the piecewise construction of a word using
  an index sequence.
\<close>

definition merge :: "'a word word \<Rightarrow> nat word \<Rightarrow> 'a word"
  where "merge ws idx \<equiv> \<lambda>n. let i = THE i. n \<in> {idx i ..< idx (Suc i) } in ws i n"

lemma merge:
  assumes idx: "idx_sequence idx"
    and n: "n \<in> {idx i ..< idx (Suc i)}"
  shows "merge ws idx n = ws i n"
proof -
  from n have "(THE k. n \<in> {idx k ..< idx (Suc k) }) = i"
    by (rule the_equality[OF _ sym[OF idx_sequence_interval_unique[OF idx n]]]) simp
  thus ?thesis
    by (simp add: merge_def Let_def)
qed

lemma merge0:
  assumes idx: "idx_sequence idx"
  shows "merge ws idx 0 = ws 0 0"
proof (rule merge[OF idx])
  from idx have "idx 0 < idx (Suc 0)"
    unfolding idx_sequence_def by blast
  with idx show "0 \<in> {idx 0 ..< idx (Suc 0)}"
    by (simp add: idx_sequence_def)
qed

lemma merge_Suc:
  assumes idx: "idx_sequence idx"
    and n: "n \<in> {idx i ..< idx (Suc i)}"
  shows "merge ws idx (Suc n) = (if Suc n = idx (Suc i) then ws (Suc i) else ws i) (Suc n)"
proof auto
  assume eq: "Suc n = idx (Suc i)"
  from idx have "idx (Suc i) < idx (Suc(Suc i))"
    unfolding idx_sequence_def by blast
  with eq idx show "merge ws idx (idx (Suc i)) = ws (Suc i) (idx (Suc i))"
    by (simp add: merge)
next
  assume neq: "Suc n \<noteq> idx (Suc i)"
  with n have "Suc n \<in> {idx i ..< idx (Suc i) }"
    by auto
  with idx show "merge ws idx (Suc n) = ws i (Suc n)"
    by (rule merge)
qed

end


theory sse_operation_negative
  imports sse_boolean_algebra
begin
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format=3] (*default Nitpick settings*)

section \<open>Negative semantic conditions for operations\<close>

text\<open>\noindent{We define and interrelate some conditions on operations (i.e. propositional functions of type
@{text "\<sigma>\<Rightarrow>\<sigma>"}), this time involving negative-like properties.}\<close>

named_theorems Defs

subsection \<open>Definitions and interrelations (finitary case)\<close>

subsubsection \<open>Principles of excluded middle, contradiction and explosion\<close>

text\<open>\noindent{TND: tertium non datur, aka. law of excluded middle (resp. strong, weak, minimal).}\<close>
abbreviation pTND  ("TND\<^sup>_  _") where "TND\<^sup>a  \<eta> \<equiv>       \<^bold>\<top>  \<^bold>\<approx> a \<^bold>\<or> (\<eta> a)"
abbreviation pTNDw ("TNDw\<^sup>_ _") where "TNDw\<^sup>a \<eta> \<equiv> \<forall>b. (\<eta> b) \<^bold>\<preceq> a \<^bold>\<or> (\<eta> a)"
abbreviation pTNDm ("TNDm\<^sup>_ _") where "TNDm\<^sup>a \<eta> \<equiv>     (\<eta> \<^bold>\<bottom>) \<^bold>\<preceq> a \<^bold>\<or> (\<eta> a)"
definition "TND  \<eta> \<equiv> \<forall>\<phi>. TND\<^sup>\<phi>  \<eta>"
definition "TNDw \<eta> \<equiv> \<forall>\<phi>. TNDw\<^sup>\<phi> \<eta>"
definition "TNDm \<eta> \<equiv> \<forall>\<phi>. TNDm\<^sup>\<phi> \<eta>"
declare TND_def[Defs] TNDw_def[Defs] TNDm_def[Defs]

text\<open>\noindent{Explore some (non)entailment relations:}\<close>
lemma "TND  \<eta> \<Longrightarrow> TNDw \<eta>" unfolding Defs conn by simp
lemma "TNDw \<eta> \<Longrightarrow> TND  \<eta>" nitpick oops
lemma "TNDw \<eta> \<Longrightarrow> TNDm \<eta>" unfolding Defs by simp
lemma "TNDm \<eta> \<Longrightarrow> TNDw \<eta>" nitpick oops

text\<open>\noindent{ECQ: ex contradictione (sequitur) quodlibet (resp: strong, weak, minimal).}\<close>
abbreviation pECQ  ("ECQ\<^sup>_ _")  where "ECQ\<^sup>a  \<eta> \<equiv>     a \<^bold>\<and> (\<eta> a) \<^bold>\<approx> \<^bold>\<bottom>"
abbreviation pECQw ("ECQw\<^sup>_ _") where "ECQw\<^sup>a \<eta> \<equiv> \<forall>b. a \<^bold>\<and> (\<eta> a) \<^bold>\<preceq> (\<eta> b)"
abbreviation pECQm ("ECQm\<^sup>_ _") where "ECQm\<^sup>a \<eta> \<equiv>     a \<^bold>\<and> (\<eta> a) \<^bold>\<preceq> (\<eta> \<^bold>\<top>)"
definition "ECQ  \<eta> \<equiv> \<forall>a. ECQ\<^sup>a  \<eta>"
definition "ECQw \<eta> \<equiv> \<forall>a. ECQw\<^sup>a \<eta>"
definition "ECQm \<eta> \<equiv> \<forall>a. ECQm\<^sup>a \<eta>"
declare ECQ_def[Defs] ECQw_def[Defs] ECQm_def[Defs]

text\<open>\noindent{Explore some (non)entailment relations:}\<close>
lemma "ECQ  \<eta> \<Longrightarrow> ECQw \<eta>" unfolding Defs conn by blast
lemma "ECQw \<eta> \<Longrightarrow> ECQ  \<eta>" nitpick oops
lemma "ECQw \<eta> \<Longrightarrow> ECQm \<eta>" unfolding Defs conn by simp
lemma "ECQm \<eta> \<Longrightarrow> ECQw \<eta>" nitpick oops

text\<open>\noindent{LNC: law of non-contradiction.}\<close>
abbreviation pLNC  ("LNC\<^sup>_ _")  where "LNC\<^sup>a \<eta> \<equiv> \<eta>(a \<^bold>\<and> \<eta> a) \<^bold>\<approx> \<^bold>\<top>"
definition "LNC \<eta> \<equiv> \<forall>a. LNC\<^sup>a \<eta>"
declare LNC_def[Defs]

text\<open>\noindent{ECQ and LNC are in general independent.}\<close>
lemma "ECQ \<eta> \<Longrightarrow> LNC \<eta>" nitpick oops
lemma "LNC \<eta> \<Longrightarrow> ECQm \<eta>" nitpick oops

subsubsection \<open>Contraposition rules\<close>

text\<open>\noindent{CoP: contraposition (global/rule variants, resp. weak, strong var. 1, strong var. 2, strong var. 3).}\<close>
abbreviation pCoPw ("CoPw\<^sup>_\<^sup>_ _") where "CoPw\<^sup>a\<^sup>b \<eta> \<equiv> a \<^bold>\<preceq> b \<longrightarrow> (\<eta> b) \<^bold>\<preceq> (\<eta> a)"
abbreviation pCoP1 ("CoP1\<^sup>_\<^sup>_ _") where "CoP1\<^sup>a\<^sup>b \<eta> \<equiv> a \<^bold>\<preceq> (\<eta> b) \<longrightarrow> b \<^bold>\<preceq> (\<eta> a)"
abbreviation pCoP2 ("CoP2\<^sup>_\<^sup>_ _") where "CoP2\<^sup>a\<^sup>b \<eta> \<equiv> (\<eta> a) \<^bold>\<preceq> b \<longrightarrow> (\<eta> b) \<^bold>\<preceq> a"
abbreviation pCoP3 ("CoP3\<^sup>_\<^sup>_ _") where "CoP3\<^sup>a\<^sup>b \<eta> \<equiv> (\<eta> a) \<^bold>\<preceq> (\<eta> b) \<longrightarrow> b \<^bold>\<preceq> a"
definition "CoPw  \<eta> \<equiv> \<forall>a b. CoPw\<^sup>a\<^sup>b \<eta>"
definition "CoP1  \<eta> \<equiv> \<forall>a b. CoP1\<^sup>a\<^sup>b \<eta>"
definition "CoP1' \<eta> \<equiv> \<forall>a b. a \<^bold>\<preceq> (\<eta> b) \<longleftrightarrow> b \<^bold>\<preceq> (\<eta> a)"
definition "CoP2  \<eta> \<equiv> \<forall>a b. CoP2\<^sup>a\<^sup>b \<eta>"
definition "CoP2' \<eta> \<equiv> \<forall>a b. (\<eta> a) \<^bold>\<preceq> b \<longleftrightarrow> (\<eta> b) \<^bold>\<preceq> a"
definition "CoP3  \<eta> \<equiv> \<forall>a b. CoP3\<^sup>a\<^sup>b \<eta>"
declare CoPw_def[Defs] CoP1_def[Defs] CoP1'_def[Defs]
        CoP2_def[Defs] CoP2'_def[Defs] CoP3_def[Defs]

lemma CoP1_defs_rel: "CoP1 \<eta> = CoP1' \<eta>" unfolding Defs by metis
lemma CoP2_defs_rel: "CoP2 \<eta> = CoP2' \<eta>" unfolding Defs by metis

text\<open>\noindent{Explore some (non)entailment relations:}\<close>
lemma "CoP1 \<eta> \<Longrightarrow> CoPw \<eta>" unfolding Defs by metis
lemma "CoPw \<eta> \<Longrightarrow> CoP1 \<eta>" nitpick oops
lemma "CoP2 \<eta> \<Longrightarrow> CoPw \<eta>" unfolding Defs by metis
lemma "CoPw \<eta> \<Longrightarrow> CoP2 \<eta>" nitpick oops
lemma "CoP3 \<eta> \<Longrightarrow> CoPw \<eta>" (*nitpick*) oops \<comment>\<open> no countermodel found so far \<close>
lemma "CoPw \<eta> \<Longrightarrow> CoP3 \<eta>" nitpick oops

text\<open>\noindent{All three strong variants are pairwise independent. However, CoP3 follows from CoP1 plus CoP2.}\<close>
lemma CoP123: "CoP1 \<eta> \<Longrightarrow> CoP2 \<eta> \<Longrightarrow> CoP3 \<eta>" unfolding Defs by smt
text\<open>\noindent{Taking all CoP together still leaves room for a boldly paraconsistent resp. paracomplete logic.}\<close>
lemma "CoP1 \<eta> \<Longrightarrow> CoP2 \<eta> \<Longrightarrow> ECQm \<eta>" nitpick oops
lemma "CoP1 \<eta> \<Longrightarrow> CoP2 \<eta> \<Longrightarrow> TNDm \<eta>" nitpick oops

subsubsection \<open>Modus tollens rules\<close>

text\<open>\noindent{MT: modus (tollendo) tollens (global/rule variants).}\<close>
abbreviation pMT0 ("MT0\<^sup>_\<^sup>_ _") where "MT0\<^sup>a\<^sup>b \<eta> \<equiv> a \<^bold>\<preceq> b \<and> (\<eta> b) \<^bold>\<approx> \<^bold>\<top> \<longrightarrow> (\<eta> a) \<^bold>\<approx> \<^bold>\<top>"
abbreviation pMT1 ("MT1\<^sup>_\<^sup>_ _") where "MT1\<^sup>a\<^sup>b \<eta> \<equiv> a \<^bold>\<preceq> (\<eta> b) \<and> b \<^bold>\<approx> \<^bold>\<top> \<longrightarrow> (\<eta> a) \<^bold>\<approx> \<^bold>\<top>"
abbreviation pMT2 ("MT2\<^sup>_\<^sup>_ _") where "MT2\<^sup>a\<^sup>b \<eta> \<equiv> (\<eta> a) \<^bold>\<preceq> b \<and> (\<eta> b) \<^bold>\<approx> \<^bold>\<top> \<longrightarrow> a \<^bold>\<approx> \<^bold>\<top>"
abbreviation pMT3 ("MT3\<^sup>_\<^sup>_ _") where "MT3\<^sup>a\<^sup>b \<eta> \<equiv> (\<eta> a) \<^bold>\<preceq> (\<eta> b) \<and> b \<^bold>\<approx> \<^bold>\<top> \<longrightarrow> a \<^bold>\<approx> \<^bold>\<top>"
definition "MT0 \<eta> \<equiv> \<forall>a b. MT0\<^sup>a\<^sup>b \<eta>"
definition "MT1 \<eta> \<equiv> \<forall>a b. MT1\<^sup>a\<^sup>b \<eta>"
definition "MT2 \<eta> \<equiv> \<forall>a b. MT2\<^sup>a\<^sup>b \<eta>"
definition "MT3 \<eta> \<equiv> \<forall>a b. MT3\<^sup>a\<^sup>b \<eta>"
declare MT0_def[Defs] MT1_def[Defs] MT2_def[Defs] MT3_def[Defs]

text\<open>\noindent{Again, all MT variants are pairwise independent. We explore some (non)entailment relations:}\<close>
lemma "CoPw \<eta> \<Longrightarrow> MT0 \<eta>" unfolding Defs by (metis top_def)
lemma "CoP1 \<eta> \<Longrightarrow> MT1 \<eta>" unfolding Defs by (metis top_def)
lemma "CoP2 \<eta> \<Longrightarrow> MT2 \<eta>" unfolding Defs by (metis top_def)
lemma "CoP3 \<eta> \<Longrightarrow> MT3 \<eta>" unfolding Defs by (metis top_def)
lemma "MT0 \<eta> \<Longrightarrow> MT1 \<eta> \<Longrightarrow> MT2 \<eta> \<Longrightarrow> MT3 \<eta> \<Longrightarrow> CoPw \<eta>" nitpick oops
lemma "MT0 \<eta> \<Longrightarrow> MT1 \<eta> \<Longrightarrow> MT2 \<eta> \<Longrightarrow> MT3 \<eta> \<Longrightarrow> ECQm \<eta>" nitpick oops
lemma "MT0 \<eta> \<Longrightarrow> MT1 \<eta> \<Longrightarrow> MT2 \<eta> \<Longrightarrow> MT3 \<eta> \<Longrightarrow> TNDm \<eta>" nitpick oops
lemma MT123: "MT1 \<eta> \<Longrightarrow> MT2 \<eta> \<Longrightarrow> MT3 \<eta>"  unfolding Defs by smt

subsubsection \<open>Double negation introduction and elimination\<close>

text\<open>\noindent{DNI/DNE: double negation introduction/elimination (as axioms).}\<close>
abbreviation pDNI ("DNI\<^sup>_ _") where "DNI\<^sup>a \<eta> \<equiv> a \<^bold>\<preceq> \<eta> (\<eta> a)"
abbreviation pDNE ("DNE\<^sup>_ _") where "DNE\<^sup>a \<eta> \<equiv> \<eta> (\<eta> a) \<^bold>\<preceq> a"
definition "DNI \<eta> \<equiv> \<forall>a. DNI\<^sup>a \<eta>"
definition "DNE \<eta> \<equiv> \<forall>a. DNE\<^sup>a \<eta>"
declare DNI_def[Defs] DNE_def[Defs]

text\<open>\noindent{CoP1 (resp. CoP2) can alternatively be defined as CoPw plus DNI (resp. DNE).}\<close>
lemma "DNI \<eta> \<Longrightarrow> CoP1 \<eta>" nitpick oops
lemma CoP1_def2: "CoP1 \<eta> = (CoPw \<eta> \<and> DNI \<eta>)" unfolding Defs by smt
lemma "DNE \<eta> \<Longrightarrow>  CoP2 \<eta>" nitpick oops
lemma CoP2_def2: "CoP2 \<eta> = (CoPw \<eta> \<and> DNE \<eta>)" unfolding Defs by smt

text\<open>\noindent{Explore some non-entailment relations:}\<close>
lemma "DNI \<eta> \<Longrightarrow> DNE \<eta> \<Longrightarrow> CoPw \<eta>" nitpick oops
lemma "DNI \<eta> \<Longrightarrow> DNE \<eta> \<Longrightarrow> TNDm \<eta>" nitpick oops
lemma "DNI \<eta> \<Longrightarrow> DNE \<eta> \<Longrightarrow> ECQm \<eta>" nitpick oops
lemma "DNI \<eta> \<Longrightarrow> DNE \<eta> \<Longrightarrow> MT0 \<eta>" nitpick oops
lemma "DNI \<eta> \<Longrightarrow> DNE \<eta> \<Longrightarrow> MT1 \<eta>" nitpick oops
lemma "DNI \<eta> \<Longrightarrow> DNE \<eta> \<Longrightarrow> MT2 \<eta>" nitpick oops
lemma "DNI \<eta> \<Longrightarrow> DNE \<eta> \<Longrightarrow> MT3 \<eta>" nitpick oops

text\<open>\noindent{DNI/DNE: double negation introduction/elimination (as rules).}\<close>
abbreviation prDNI ("rDNI\<^sup>_ _") where "rDNI\<^sup>a \<eta> \<equiv> a \<^bold>\<approx> \<^bold>\<top> \<longrightarrow> \<eta> (\<eta> a) \<^bold>\<approx> \<^bold>\<top>"
abbreviation prDNE ("rDNE\<^sup>_ _") where "rDNE\<^sup>a \<eta> \<equiv> \<eta> (\<eta> a) \<^bold>\<approx> \<^bold>\<top> \<longrightarrow> a \<^bold>\<approx> \<^bold>\<top>"
definition "rDNI \<eta> \<equiv> \<forall>a. rDNI\<^sup>a \<eta>"
definition "rDNE \<eta> \<equiv> \<forall>a. rDNE\<^sup>a \<eta>"
declare rDNI_def[Defs] rDNE_def[Defs]

text\<open>\noindent{The rule variants are strictly weaker than the axiom variants,}\<close>
lemma "DNI \<eta> \<Longrightarrow> rDNI \<eta>" by (simp add: DNI_def rDNI_def top_def)
lemma "rDNI \<eta> \<Longrightarrow> DNI \<eta>" nitpick oops
lemma "DNE \<eta> \<Longrightarrow> rDNE \<eta>" by (metis DNE_def rDNE_def top_def)
lemma "rDNE \<eta> \<Longrightarrow> DNE \<eta>" nitpick oops
text\<open>\noindent{and follow already from modus tollens.}\<close>
lemma MT1_rDNI: "MT1 \<eta> \<Longrightarrow> rDNI \<eta>" unfolding Defs by blast
lemma MT2_rDNE: "MT2 \<eta> \<Longrightarrow> rDNE \<eta>" unfolding Defs by blast

subsubsection \<open>Normality and its dual\<close>

text\<open>\noindent{n(D)Nor: negative (dual) 'normality'.}\<close>
definition "nNor \<eta> \<equiv> (\<eta> \<^bold>\<bottom>) \<^bold>\<approx> \<^bold>\<top>"
definition "nDNor \<eta> \<equiv> (\<eta> \<^bold>\<top>) \<^bold>\<approx> \<^bold>\<bottom>"
declare nNor_def[Defs] nDNor_def[Defs]

text\<open>\noindent{nNor (resp. nDNor) is entailed by CoP1 (resp. CoP2). }\<close>
lemma CoP1_Nor: "CoP1 \<eta> \<Longrightarrow> nNor \<eta>" unfolding Defs conn by simp
lemma CoP2_DNor: "CoP2 \<eta> \<Longrightarrow> nDNor \<eta>" unfolding Defs conn by fastforce
lemma "DNI \<eta> \<Longrightarrow> nNor \<eta>" nitpick oops
lemma "DNE \<eta> \<Longrightarrow> nDNor \<eta>" nitpick oops
text\<open>\noindent{nNor and nDNor together entail the rule variant of DNI (rDNI).}\<close>
lemma nDNor_rDNI: "nNor \<eta> \<Longrightarrow> nDNor \<eta> \<Longrightarrow> rDNI \<eta>" unfolding Defs using nDNor_def nNor_def eq_ext by metis
lemma "nNor \<eta> \<Longrightarrow> nDNor \<eta> \<Longrightarrow> rDNE \<eta>" nitpick oops

subsubsection \<open>De Morgan laws\<close>

text\<open>\noindent{DM: De Morgan laws.}\<close>
abbreviation pDM1 ("DM1\<^sup>_\<^sup>_ _") where "DM1\<^sup>a\<^sup>b \<eta> \<equiv> \<eta>(a \<^bold>\<or> b) \<^bold>\<preceq> (\<eta> a) \<^bold>\<and> (\<eta> b)"
abbreviation pDM2 ("DM2\<^sup>_\<^sup>_ _") where "DM2\<^sup>a\<^sup>b \<eta> \<equiv> (\<eta> a) \<^bold>\<or> (\<eta> b) \<^bold>\<preceq> \<eta>(a \<^bold>\<and> b)"
abbreviation pDM3 ("DM3\<^sup>_\<^sup>_ _") where "DM3\<^sup>a\<^sup>b \<eta> \<equiv> \<eta>(a \<^bold>\<and> b) \<^bold>\<preceq> (\<eta> a) \<^bold>\<or> (\<eta> b)"
abbreviation pDM4 ("DM4\<^sup>_\<^sup>_ _") where "DM4\<^sup>a\<^sup>b \<eta> \<equiv> (\<eta> a) \<^bold>\<and> (\<eta> b) \<^bold>\<preceq>  \<eta>(a \<^bold>\<or> b)"
definition "DM1 \<eta> \<equiv> \<forall>a b. DM1\<^sup>a\<^sup>b \<eta>"
definition "DM2 \<eta> \<equiv> \<forall>a b. DM2\<^sup>a\<^sup>b \<eta>"
definition "DM3 \<eta> \<equiv> \<forall>a b. DM3\<^sup>a\<^sup>b \<eta>"
definition "DM4 \<eta> \<equiv> \<forall>a b. DM4\<^sup>a\<^sup>b \<eta>"
declare DM1_def[Defs] DM2_def[Defs] DM3_def[Defs] DM4_def[Defs]

text\<open>\noindent{CoPw, DM1 and DM2 are indeed equivalent.}\<close>
lemma DM1_CoPw: "DM1 \<eta> = CoPw \<eta>" proof -
  have LtoR: "DM1 \<eta> \<Longrightarrow> CoPw \<eta>" proof -
  assume dm1: "DM1 \<eta>"
  { fix a b
    { assume "a \<^bold>\<preceq> b"
      hence 1: "a \<^bold>\<or> b \<^bold>\<preceq> b" unfolding conn by simp
      have 2: "b \<^bold>\<preceq> a \<^bold>\<or> b" unfolding conn by simp
      from 1 2 have "b = a \<^bold>\<or> b" using eq_ext by blast
      hence 3: "\<eta> b \<^bold>\<approx> \<eta> (a \<^bold>\<or> b)" by auto
      from dm1 have "\<eta>(a \<^bold>\<or> b) \<^bold>\<preceq> (\<eta> a) \<^bold>\<and> (\<eta> b)" unfolding Defs by blast
      hence 4: "(\<eta> b) \<^bold>\<preceq> (\<eta> a) \<^bold>\<and> (\<eta> b)" using 3 by simp
      have 5: "(\<eta> a) \<^bold>\<and> (\<eta> b) \<^bold>\<preceq> (\<eta> a)" unfolding conn by simp
      from 4 5 have "(\<eta> b) \<^bold>\<preceq> (\<eta> a)" by simp
    } hence "a \<^bold>\<preceq> b \<longrightarrow> (\<eta> b) \<^bold>\<preceq> (\<eta> a)" by (rule impI)
  } thus ?thesis unfolding Defs by simp
  qed
  have RtoL: "CoPw \<eta> \<Longrightarrow> DM1 \<eta>" unfolding Defs conn by (metis (no_types, lifting))
  thus ?thesis using LtoR RtoL by blast
qed
lemma DM2_CoPw: "DM2 \<eta> = CoPw \<eta>" proof -
 have LtoR: "DM2 \<eta> \<Longrightarrow> CoPw \<eta>" proof -
   assume dm2: "DM2 \<eta>"
    { fix a b
      { assume "a \<^bold>\<preceq> b"
        hence 1: "a \<^bold>\<preceq> a \<^bold>\<and> b" unfolding conn by simp
        have 2: "a \<^bold>\<and> b \<^bold>\<preceq> a" unfolding conn by simp
        from 1 2 have "a = a \<^bold>\<and> b" using eq_ext by blast
        hence 3: "\<eta> a \<^bold>\<approx> \<eta> (a \<^bold>\<and> b)" by auto
        from dm2 have "(\<eta> a) \<^bold>\<or> (\<eta> b) \<^bold>\<preceq> \<eta>(a \<^bold>\<and> b)" unfolding Defs by blast
        hence 4: "(\<eta> a) \<^bold>\<or> (\<eta> b) \<^bold>\<preceq> (\<eta> a) " using 3 by simp
        have 5: "(\<eta> b) \<^bold>\<preceq> (\<eta> a) \<^bold>\<or> (\<eta> b)" unfolding conn by simp
        from 4 5 have "(\<eta> b) \<^bold>\<preceq> (\<eta> a)" by simp
      } hence "a \<^bold>\<preceq> b \<longrightarrow> (\<eta> b) \<^bold>\<preceq> (\<eta> a)" by (rule impI)
    } thus ?thesis unfolding Defs by simp
  qed
  have RtoL: "CoPw \<eta> \<Longrightarrow> DM2 \<eta>" unfolding Defs conn by (metis (no_types, lifting))
  thus ?thesis using LtoR RtoL by blast
qed
lemma DM12: "DM1 \<eta> = DM2 \<eta>" by (simp add: DM1_CoPw DM2_CoPw)

text\<open>\noindent{DM3 (resp. DM4) are entailed by CoPw together with DNE (resp. DNI).}\<close>
lemma CoPw_DNE_DM3: "CoPw \<eta> \<Longrightarrow> DNE \<eta> \<Longrightarrow> DM3 \<eta>" proof -
  assume copw: "CoPw \<eta>" and dne: "DNE \<eta>"
  { fix a b
    have "\<eta>(a) \<^bold>\<preceq> (\<eta> a) \<^bold>\<or> (\<eta> b)" unfolding conn by simp
    hence "\<eta>(\<eta>(a) \<^bold>\<or> \<eta>(b)) \<^bold>\<preceq> \<eta>((\<eta> a))" using CoPw_def copw by (metis (no_types, lifting))
    hence 1: "\<eta>(\<eta>(a) \<^bold>\<or> \<eta>(b)) \<^bold>\<preceq> a" using DNE_def dne by metis
    have "\<eta>(b) \<^bold>\<preceq> (\<eta> a) \<^bold>\<or> (\<eta> b)" unfolding conn by simp
    hence "\<eta>(\<eta>(a) \<^bold>\<or> \<eta>(b)) \<^bold>\<preceq> \<eta>((\<eta> b))" using CoPw_def copw by (metis (no_types, lifting))
    hence 2: "\<eta>(\<eta>(a) \<^bold>\<or> \<eta>(b)) \<^bold>\<preceq> b" using DNE_def dne by metis
    from 1 2 have "\<eta>(\<eta>(a) \<^bold>\<or> \<eta>(b)) \<^bold>\<preceq> a \<^bold>\<and> b" unfolding conn by simp
    hence "\<eta>(a \<^bold>\<and> b) \<^bold>\<preceq> \<eta>(\<eta>(\<eta>(a) \<^bold>\<or> \<eta>(b)))" using CoPw_def copw by smt
    hence "\<eta>(a \<^bold>\<and> b) \<^bold>\<preceq> (\<eta> a) \<^bold>\<or> (\<eta> b)" using DNE_def dne by metis
  } thus ?thesis by (simp add: DM3_def)
qed
lemma CoPw_DNI_DM4: "CoPw \<eta> \<Longrightarrow> DNI \<eta> \<Longrightarrow> DM4 \<eta>" proof -
  assume copw: "CoPw \<eta>" and dni: "DNI \<eta>"
  { fix a b
    have "(\<eta> a) \<^bold>\<and> (\<eta> b) \<^bold>\<preceq> \<eta>(a)" unfolding conn by simp
    hence "\<eta>((\<eta> a)) \<^bold>\<preceq> \<eta>(\<eta>(a) \<^bold>\<and> \<eta>(b))" using CoPw_def copw by (metis (no_types, lifting))
    hence 1: "a \<^bold>\<preceq> \<eta>(\<eta>(a) \<^bold>\<and> \<eta>(b))" using DNI_def dni by metis
    have "(\<eta> a) \<^bold>\<and> (\<eta> b) \<^bold>\<preceq> \<eta>(b)" unfolding conn by simp
    hence "\<eta>((\<eta> b)) \<^bold>\<preceq> \<eta>(\<eta>(a) \<^bold>\<and> \<eta>(b))" using CoPw_def copw by (metis (no_types, lifting))
    hence 2: "b \<^bold>\<preceq> \<eta>(\<eta>(a) \<^bold>\<and> \<eta>(b))" using DNI_def dni by metis
    from 1 2 have "a \<^bold>\<or> b \<^bold>\<preceq> \<eta>(\<eta>(a) \<^bold>\<and> \<eta>(b))" unfolding conn by simp
    hence "\<eta>(\<eta>(\<eta>(a) \<^bold>\<and> \<eta>(b))) \<^bold>\<preceq> \<eta>(a \<^bold>\<or> b)" using CoPw_def copw by auto
    hence "\<eta>(a) \<^bold>\<and> \<eta>(b) \<^bold>\<preceq> \<eta>(a \<^bold>\<or> b)" using DNI_def dni by simp
  } thus ?thesis by (simp add: DM4_def)
qed
text\<open>\noindent{From this follows that DM3 (resp. DM4) is entailed by CoP2 (resp. CoP1).}\<close>
lemma CoP2_DM3: "CoP2 \<eta> \<Longrightarrow> DM3 \<eta>" by (simp add: CoP2_def2 CoPw_DNE_DM3)
lemma CoP1_DM4: "CoP1 \<eta> \<Longrightarrow> DM4 \<eta>" by (simp add: CoP1_def2 CoPw_DNI_DM4)
text\<open>\noindent{Explore some non-entailment relations:}\<close>
lemma "CoPw \<eta> \<Longrightarrow> DM3 \<eta> \<Longrightarrow> DM4 \<eta> \<Longrightarrow> nNor \<eta> \<Longrightarrow> nDNor \<eta> \<Longrightarrow> DNI \<eta>" nitpick oops
lemma "CoPw \<eta> \<Longrightarrow> DM3 \<eta> \<Longrightarrow> DM4 \<eta> \<Longrightarrow> nNor \<eta> \<Longrightarrow> nDNor \<eta> \<Longrightarrow> DNE \<eta>" nitpick oops
lemma "CoPw \<eta> \<Longrightarrow> DM3 \<eta> \<Longrightarrow> DM4 \<eta> \<Longrightarrow> DNI \<eta> \<Longrightarrow> DNE \<eta> \<Longrightarrow> ECQm \<eta>" nitpick oops
lemma "CoPw \<eta> \<Longrightarrow> DM3 \<eta> \<Longrightarrow> DM4 \<eta> \<Longrightarrow> DNI \<eta> \<Longrightarrow> DNE \<eta> \<Longrightarrow> TNDm \<eta>" nitpick oops

subsubsection \<open>Contextual (strong) contraposition rule\<close>

text\<open>\noindent{XCoP: contextual contraposition (global/rule variant).}\<close>
abbreviation pXCoP ("XCoP\<^sup>_\<^sup>_ _") where "XCoP\<^sup>a\<^sup>b \<eta> \<equiv> \<forall>c. c \<^bold>\<and> a \<^bold>\<preceq> b \<longrightarrow> c \<^bold>\<and> (\<eta> b) \<^bold>\<preceq> (\<eta> a)"
definition "XCoP \<eta> \<equiv> \<forall>a b. XCoP\<^sup>a\<^sup>b \<eta>"
declare XCoP_def[Defs]

text\<open>\noindent{XCoP can alternatively be defined as ECQw plus TNDw.}\<close>
lemma XCoP_def2: "XCoP \<eta> = (ECQw \<eta> \<and> TNDw \<eta>)" proof -
  have LtoR1: "XCoP \<eta> \<Longrightarrow> ECQw \<eta>" unfolding XCoP_def ECQw_def conn by auto
  have LtoR2: "XCoP \<eta> \<Longrightarrow> TNDw \<eta>" unfolding XCoP_def TNDw_def conn by (smt atom_def atomic2 conn)
  have RtoL: "ECQw \<eta> \<and> TNDw \<eta> \<Longrightarrow> XCoP \<eta>" using XCoP_def ECQw_def TNDw_def unfolding conn by metis
  from LtoR1 LtoR2 RtoL show ?thesis by blast
qed
text\<open>\noindent{Explore some (non)entailment relations:}\<close>
lemma "XCoP \<eta> \<Longrightarrow> ECQ \<eta>" nitpick oops
lemma "XCoP \<eta> \<Longrightarrow> TND \<eta>" nitpick oops
lemma XCoP_CoPw: "XCoP \<eta> \<Longrightarrow> CoPw \<eta>" unfolding Defs conn by metis
lemma "XCoP \<eta> \<Longrightarrow> CoP1 \<eta>" nitpick oops
lemma "XCoP \<eta> \<Longrightarrow> CoP2 \<eta>" nitpick oops
lemma "XCoP \<eta> \<Longrightarrow> CoP3 \<eta>" nitpick oops
lemma "CoP1 \<eta> \<and> CoP2 \<eta> \<Longrightarrow> XCoP \<eta>" nitpick oops
lemma "XCoP \<eta> \<Longrightarrow> nNor \<eta>" nitpick oops
lemma "XCoP \<eta> \<Longrightarrow> nDNor \<eta>" nitpick oops
lemma "XCoP \<eta> \<Longrightarrow> rDNI \<eta>" nitpick oops
lemma "XCoP \<eta> \<Longrightarrow> rDNE \<eta>" nitpick oops
lemma XCoP_DM3: "XCoP \<eta> \<Longrightarrow> DM3 \<eta>" unfolding DM3_def XCoP_def conn using ECQw_def TNDw_def atom_def atomic2 conn by smt
lemma XCoP_DM4: "XCoP \<eta> \<Longrightarrow> DM4 \<eta>" unfolding DM4_def XCoP_def conn using ECQw_def TNDw_def atom_def atomic2 conn by smt

subsubsection \<open>Local contraposition axioms\<close>
text\<open>\noindent{Observe that the definitions below take implication as an additional parameter: @{text "\<iota>"}.}\<close>

text\<open>\noindent{lCoP: contraposition (local/axiom variants).}\<close>
abbreviation plCoPw ("lCoPw\<^sup>_\<^sup>_ _ _") where "lCoPw\<^sup>a\<^sup>b \<iota> \<eta> \<equiv> (\<iota> a b::\<sigma>) \<^bold>\<preceq> (\<iota> (\<eta> b) (\<eta> a))"
abbreviation plCoP1 ("lCoP1\<^sup>_\<^sup>_ _ _") where "lCoP1\<^sup>a\<^sup>b \<iota> \<eta> \<equiv> (\<iota> a (\<eta> b::\<sigma>)) \<^bold>\<preceq> (\<iota> b (\<eta> a))"
abbreviation plCoP2 ("lCoP2\<^sup>_\<^sup>_ _ _") where "lCoP2\<^sup>a\<^sup>b \<iota> \<eta> \<equiv> (\<iota> (\<eta> a) b::\<sigma>) \<^bold>\<preceq> (\<iota> (\<eta> b) a)"
abbreviation plCoP3 ("lCoP3\<^sup>_\<^sup>_ _ _") where "lCoP3\<^sup>a\<^sup>b \<iota> \<eta> \<equiv> (\<iota> (\<eta> a) (\<eta> b::\<sigma>)) \<^bold>\<preceq> (\<iota> b a)"
definition "lCoPw  \<iota> \<eta> \<equiv> \<forall>a b. lCoPw\<^sup>a\<^sup>b \<iota> \<eta>"
definition "lCoP1  \<iota> \<eta> \<equiv> \<forall>a b. lCoP1\<^sup>a\<^sup>b \<iota> \<eta>"
definition "lCoP1' \<iota> \<eta> \<equiv> \<forall>a b. (\<iota> a (\<eta> b)) \<^bold>\<approx> (\<iota> b (\<eta> a))"
definition "lCoP2  \<iota> \<eta> \<equiv> \<forall>a b. lCoP2\<^sup>a\<^sup>b \<iota> \<eta>"
definition "lCoP2' \<iota> \<eta> \<equiv> \<forall>a b. (\<iota> (\<eta> a) b) \<^bold>\<approx> (\<iota> (\<eta> b) a)"
definition "lCoP3  \<iota> \<eta> \<equiv> \<forall>a b. lCoP3\<^sup>a\<^sup>b \<iota> \<eta>"
declare lCoPw_def[Defs] lCoP1_def[Defs] lCoP1'_def[Defs]
        lCoP2_def[Defs] lCoP2'_def[Defs] lCoP3_def[Defs]

lemma lCoP1_defs_rel: "lCoP1 \<iota> \<eta> = lCoP1' \<iota> \<eta>" by (metis (full_types) lCoP1'_def lCoP1_def)
lemma lCoP2_defs_rel: "lCoP2 \<iota> \<eta> = lCoP2' \<iota> \<eta>" by (metis (full_types) lCoP2'_def lCoP2_def)

text\<open>\noindent{All local contraposition variants are in general independent from each other. However if we take
classical implication we can verify some relationships.}\<close>

lemma lCoP1_def2: "lCoP1(\<^bold>\<rightarrow>) \<eta> = (lCoPw(\<^bold>\<rightarrow>) \<eta> \<and> DNI \<eta>)" unfolding Defs conn by smt
lemma lCoP2_def2: "lCoP2(\<^bold>\<rightarrow>) \<eta> = (lCoPw(\<^bold>\<rightarrow>) \<eta> \<and> DNE \<eta>)" unfolding Defs conn by smt

lemma "lCoP1(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> lCoPw(\<^bold>\<rightarrow>) \<eta>" unfolding Defs conn by metis
lemma "lCoPw(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> lCoP1(\<^bold>\<rightarrow>) \<eta>" nitpick oops
lemma "lCoP2(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> lCoPw(\<^bold>\<rightarrow>) \<eta>" unfolding Defs conn by metis
lemma "lCoPw(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> lCoP2(\<^bold>\<rightarrow>) \<eta>" nitpick oops
lemma "lCoP3(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> lCoPw(\<^bold>\<rightarrow>) \<eta>" unfolding Defs conn by blast
lemma "lCoPw(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> lCoP3(\<^bold>\<rightarrow>) \<eta>" nitpick oops
lemma lCoP123: "lCoP1(\<^bold>\<rightarrow>) \<eta> \<and> lCoP2(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> lCoP3(\<^bold>\<rightarrow>) \<eta>" unfolding Defs conn by metis

text\<open>\noindent{Local variants imply global ones as expected.}\<close>
lemma "lCoPw(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> CoPw \<eta>" unfolding Defs conn by metis
lemma "lCoP1(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> CoP1 \<eta>" unfolding Defs conn by metis
lemma "lCoP2(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> CoP2 \<eta>" unfolding Defs conn by metis
lemma "lCoP3(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> CoP3 \<eta>" unfolding Defs conn by metis

text\<open>\noindent{Explore some (non)entailment relations.}\<close>
lemma lCoPw_XCoP: "lCoPw(\<^bold>\<rightarrow>) \<eta> = XCoP \<eta>" unfolding Defs conn by (smt XCoP_def XCoP_def2 TNDw_def conn)
lemma lCoP1_TND: "lCoP1(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> TND \<eta>" by (smt XCoP_CoPw XCoP_def2 CoP1_Nor CoP1_def2 nNor_def TND_def TNDw_def lCoP1_def2 lCoPw_XCoP conn)
lemma "TND \<eta> \<Longrightarrow> lCoP1(\<^bold>\<rightarrow>) \<eta>" nitpick oops
lemma lCoP2_ECQ: "lCoP2(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> ECQ \<eta>" by (smt XCoP_CoPw XCoP_def2 CoP2_DNor CoP2_def2 nDNor_def ECQ_def ECQw_def lCoP2_def2 lCoPw_XCoP conn)
lemma "ECQ \<eta> \<Longrightarrow> lCoP2(\<^bold>\<rightarrow>) \<eta>" nitpick oops

subsubsection \<open>Local modus tollens axioms\<close>

text\<open>\noindent{lMT: Modus tollens (local/axiom variants).}\<close>
abbreviation plMT0 ("lMT0\<^sup>_\<^sup>_ _ _") where "lMT0\<^sup>a\<^sup>b \<iota> \<eta> \<equiv> (\<iota> a b::\<sigma>) \<^bold>\<and> (\<eta> b) \<^bold>\<preceq> (\<eta> a)"
abbreviation plMT1 ("lMT1\<^sup>_\<^sup>_ _ _") where "lMT1\<^sup>a\<^sup>b \<iota> \<eta> \<equiv> (\<iota> a (\<eta> b::\<sigma>)) \<^bold>\<and> b \<^bold>\<preceq> (\<eta> a)"
abbreviation plMT2 ("lMT2\<^sup>_\<^sup>_ _ _") where "lMT2\<^sup>a\<^sup>b \<iota> \<eta> \<equiv> (\<iota> (\<eta> a) b::\<sigma>) \<^bold>\<and> (\<eta> b) \<^bold>\<preceq> a"
abbreviation plMT3 ("lMT3\<^sup>_\<^sup>_ _ _") where "lMT3\<^sup>a\<^sup>b \<iota> \<eta> \<equiv> (\<iota> (\<eta> a) (\<eta> b::\<sigma>)) \<^bold>\<and> b \<^bold>\<preceq> a"
definition "lMT0 \<iota> \<eta> \<equiv> \<forall>a b. lMT0\<^sup>a\<^sup>b \<iota> \<eta>"
definition "lMT1 \<iota> \<eta> \<equiv> \<forall>a b. lMT1\<^sup>a\<^sup>b \<iota> \<eta>"
definition "lMT2 \<iota> \<eta> \<equiv> \<forall>a b. lMT2\<^sup>a\<^sup>b \<iota> \<eta>"
definition "lMT3 \<iota> \<eta> \<equiv> \<forall>a b. lMT3\<^sup>a\<^sup>b \<iota> \<eta>"
declare lMT0_def[Defs] lMT1_def[Defs] lMT2_def[Defs] lMT3_def[Defs]

text\<open>\noindent{All local MT variants are in general independent from each other and also from local CoP instances.
However if we take classical implication we can verify that local MT and CoP are indeed equivalent.}\<close>
lemma "lMT0(\<^bold>\<rightarrow>) \<eta> = lCoPw(\<^bold>\<rightarrow>) \<eta>" unfolding Defs conn by metis
lemma "lMT1(\<^bold>\<rightarrow>) \<eta> = lCoP1(\<^bold>\<rightarrow>) \<eta>" unfolding Defs conn by metis
lemma "lMT2(\<^bold>\<rightarrow>) \<eta> = lCoP2(\<^bold>\<rightarrow>) \<eta>" unfolding Defs conn by metis
lemma "lMT3(\<^bold>\<rightarrow>) \<eta> = lCoP3(\<^bold>\<rightarrow>) \<eta>" unfolding Defs conn by metis

subsubsection \<open>Disjunctive syllogism\<close>

text\<open>\noindent{DS: disjunctive syllogism.}\<close>
abbreviation pDS1 ("DS1\<^sup>_\<^sup>_ _ _") where "DS1\<^sup>a\<^sup>b \<iota> \<eta> \<equiv> (a \<^bold>\<or> b::\<sigma>) \<^bold>\<preceq> (\<iota> (\<eta> a) b)"
abbreviation pDS2 ("DS2\<^sup>_\<^sup>_ _ _") where "DS2\<^sup>a\<^sup>b \<iota> \<eta> \<equiv> (\<iota> (\<eta> a) b::\<sigma>) \<^bold>\<preceq> (a \<^bold>\<or> b)"
abbreviation pDS3 ("DS3\<^sup>_\<^sup>_ _ _") where "DS3\<^sup>a\<^sup>b \<iota> \<eta> \<equiv> ((\<eta> a) \<^bold>\<or> b::\<sigma>) \<^bold>\<preceq> (\<iota> a b)"
abbreviation pDS4 ("DS4\<^sup>_\<^sup>_ _ _") where "DS4\<^sup>a\<^sup>b \<iota> \<eta> \<equiv> (\<iota> a b::\<sigma>) \<^bold>\<preceq> ((\<eta> a) \<^bold>\<or> b)"
definition "DS1 \<iota> \<eta> \<equiv> \<forall>a b. DS1\<^sup>a\<^sup>b \<iota> \<eta>"
definition "DS2 \<iota> \<eta> \<equiv> \<forall>a b. DS2\<^sup>a\<^sup>b \<iota> \<eta>"
definition "DS3 \<iota> \<eta> \<equiv> \<forall>a b. DS3\<^sup>a\<^sup>b \<iota> \<eta>"
definition "DS4 \<iota> \<eta> \<equiv> \<forall>a b. DS4\<^sup>a\<^sup>b \<iota> \<eta>"
declare DS1_def[Defs] DS2_def[Defs] DS3_def[Defs] DS4_def[Defs]

text\<open>\noindent{All DS variants are in general independent from each other. However if we take classical implication
we can verify that the pairs DS1-DS3 and DS2-DS4 are indeed equivalent. }\<close>
lemma "DS1(\<^bold>\<rightarrow>) \<eta> = DS3(\<^bold>\<rightarrow>) \<eta>" unfolding Defs by (metis impl_def join_def)
lemma "DS2(\<^bold>\<rightarrow>) \<eta> = DS4(\<^bold>\<rightarrow>) \<eta>" unfolding Defs by (metis impl_def join_def)

text\<open>\noindent{Explore some (non)entailment relations.}\<close>
lemma DS1_nDNor: "DS1(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> nDNor \<eta>" unfolding Defs by (metis bottom_def impl_def join_def top_def)
lemma DS2_nNor:  "DS2(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> nNor \<eta>" unfolding Defs by (metis bottom_def impl_def join_def top_def)
lemma lCoP2_DS1: "lCoP2(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> DS1(\<^bold>\<rightarrow>) \<eta>" unfolding Defs conn by metis
lemma lCoP1_DS2: "lCoP1(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> DS2(\<^bold>\<rightarrow>) \<eta>" unfolding Defs by (metis (no_types, lifting) conn)
lemma "CoP2 \<eta> \<Longrightarrow> DS1(\<^bold>\<rightarrow>) \<eta>" nitpick oops
lemma "CoP1 \<eta> \<Longrightarrow> DS2(\<^bold>\<rightarrow>) \<eta>" nitpick oops

end


section \<open>Helper definitions and lemmas\<close>

theory vcg_helpers
  imports utp_extensions
begin

lemma disjE1:
  assumes \<open>P \<or> Q\<close>
    and \<open>P \<Longrightarrow> R\<close>
    and \<open>\<not> P \<Longrightarrow> Q \<Longrightarrow> R\<close>
  shows \<open>R\<close>
  using assms by blast

lemma insert_with_sorted:
  assumes \<open>sorted (xs\<^sub>1 @ xs\<^sub>2)\<close>
      and \<open>\<forall>y \<in> set xs\<^sub>2. x < y\<close>
      and \<open>x \<ge> last xs\<^sub>1\<close>
      and \<open>xs\<^sub>1 \<noteq> []\<close>
  shows \<open>sorted (xs\<^sub>1 @ x # xs\<^sub>2)\<close>
  using assms
  by (auto simp: sorted_append sorted_Cons) (smt One_nat_def Suc_pred diff_Suc_less
      dual_order.trans in_set_conv_nth last_conv_nth leD length_greater_0_conv not_less_eq_eq
      sorted_nth_mono)

subsection Swap

text \<open>The below definition provides an easy-to-understand swap-elements-at-i-and-(i-1) function.\<close>
definition \<open>swap_at i xs = xs[i := xs!(i-1), i-1 := xs!i]\<close>
abbreviation \<open>swap_at\<^sub>u \<equiv> bop swap_at\<close>

text \<open>The below definition provides a more general swap function.\<close>
definition \<open>swap i j xs = xs[i := xs!j, j := xs!i]\<close>
abbreviation \<open>swap\<^sub>u \<equiv> trop swap\<close>

lemma mset_swap[simp]:
  assumes \<open>i < length xs\<close>
      and \<open>j < length xs\<close>
  shows \<open>mset (swap i j xs) = mset xs\<close>
  using assms unfolding swap_def
  by (simp add: mset_swap)

lemma set_swap[simp]:
  assumes \<open>i < length xs\<close>
      and \<open>j < length xs\<close>
    shows \<open>set (swap i j xs) = set xs\<close>
  using assms unfolding swap_def
  by simp

lemma swap_commute:
  \<open>swap i j xs = swap j i xs\<close>
  unfolding swap_def
  by (cases \<open>i = j\<close>) (auto simp: list_update_swap)

lemma swap_id[simp]:
  assumes \<open>i < length xs\<close>
  shows \<open>swap i i xs = xs\<close>
  using assms unfolding swap_def
  by simp

lemma drop_swap[simp]:
  assumes \<open>i < n\<close>
      and \<open>j < n\<close>
  shows \<open>drop n (swap i j xs) = drop n xs\<close>
  using assms unfolding swap_def
  by simp

lemma take_swap[simp]:
  assumes \<open>n \<le> i\<close>
      and \<open>n \<le> j\<close>
  shows \<open>take n (swap i j xs) = take n xs\<close>
  using assms unfolding swap_def
  by simp

lemma swap_length_id[simp]:
  assumes \<open>i < length xs\<close>
      and \<open>j < length xs\<close>
  shows \<open>length (swap i j xs) = length xs\<close>
  using assms unfolding swap_def
  by simp

lemma swap_nth1[simp]:
  assumes \<open>i < length xs\<close>
      and \<open>j < length xs\<close>
  shows \<open>swap i j xs ! i = xs ! j\<close>
  using assms unfolding swap_def
  by (simp add: nth_list_update)

lemma swap_nth2[simp]:
  assumes \<open>i < length xs\<close>
      and \<open>j < length xs\<close>
  shows \<open>swap i j xs ! j = xs ! i\<close>
  using assms unfolding swap_def
  by (simp add: nth_list_update)

subsection Slice

definition \<open>slice l u A \<equiv> drop l (take u A)\<close>
abbreviation \<open>slice\<^sub>u \<equiv> trop slice\<close>

lemma slice_empty[simp]:
  assumes \<open>i \<ge> j\<close>
  shows \<open>slice i j xs = []\<close>
  using assms unfolding slice_def
  by simp

lemma slice_nonempty[simp]:
  assumes \<open>i < j\<close>
      and \<open>i < length xs\<close>
  shows \<open>slice i j xs \<noteq> []\<close>
  using assms unfolding slice_def
  by simp

lemma slice_suc2_eq:
  assumes \<open>j < length xs\<close>
      and \<open>i \<le> j\<close>
    shows \<open>slice i (Suc j) xs = slice i j xs @ [xs!j]\<close>
  using assms unfolding slice_def
  by (metis diff_is_0_eq drop_0 drop_append length_take less_imp_le min.absorb2
      take_Suc_conv_app_nth)

lemma slice_update_outofbounds_upper[simp]:
  assumes \<open>j \<le> k\<close>
  shows \<open>slice i j (xs[k := l]) = slice i j xs\<close>
  using assms unfolding slice_def
  by simp

lemma slice_update2_outofbounds_lower[simp]:
  assumes \<open>k < i\<close>
  shows \<open>slice i j (xs[k := l]) = slice i j xs\<close>
  using assms unfolding slice_def
  by (simp add: drop_take)

lemma drop_set_conv_nth:
  \<open>set (drop i xs) = {xs!k | k. i \<le> k \<and> k < length xs}\<close>
  apply (induction xs rule: rev_induct)
   apply (auto simp: nth_append)
  by (metis (no_types, lifting) Suc_pred cancel_comm_monoid_add_class.diff_cancel diff_is_0_eq
      drop_Cons' drop_Nil in_set_conv_nth length_drop length_pos_if_in_set lessI less_Suc0
      less_not_refl)

lemma take_set_conv_nth:
  \<open>set (take i xs) = {xs!k | k. k < min i (length xs)}\<close>
  apply (induction i)
   apply auto
   apply (smt in_set_conv_nth le_eq_less_or_eq length_take less_Suc_eq less_le_trans min.absorb2
      not_less_eq_eq nth_take take_all)
  using in_set_conv_nth by fastforce

lemma slice_set_conv_nth:
  \<open>set (slice i j xs) = {xs!k | k. i \<le> k \<and> k < j \<and> k < length xs}\<close>
  unfolding slice_def
  by (auto simp: drop_set_conv_nth take_set_conv_nth) force

lemma slice_update_extract:
  assumes \<open>lo \<le> i\<close>
     and \<open>i < hi\<close>
  shows \<open>slice lo hi (A[i := x]) = (slice lo hi A)[i-lo := x]\<close>
  using assms unfolding slice_def
  by (simp add: drop_update_swap take_update_swap)

lemma slice_length[simp]:
  assumes \<open>lo \<le> hi\<close>
      and \<open>hi \<le> length xs\<close>
  shows \<open>length (slice lo hi xs) = hi - lo\<close>
  using assms unfolding slice_def
  by simp

lemma nth_slice_offset[simp]:
  assumes \<open>i < hi - lo\<close>
      and \<open>lo \<le> hi\<close>
      and \<open>hi \<le> length xs\<close>
  shows \<open>(slice lo hi xs)!i = xs!(i + lo)\<close>
  using assms unfolding slice_def
  by (simp add: add.commute min.absorb2)

lemma slice_merge[simp]:
  assumes \<open>lo \<le> i\<close>
      and \<open>i \<le> hi\<close>
      and \<open>hi < length xs\<close>
  shows \<open>slice lo i xs @ slice i hi xs = slice lo hi xs\<close>
  using assms unfolding slice_def
  by (smt append_take_drop_id diff_is_0_eq drop_0 drop_append length_take less_or_eq_imp_le
      min.absorb2 take_take)

lemma element_in_set_of_slice: \<comment> \<open>May not be useful\<close>
  assumes \<open>lo \<le> i\<close>
      and \<open>i < hi\<close>
      and \<open>i < length xs\<close>
  shows \<open>xs!i \<in> set (slice lo hi xs)\<close>
  using assms
  by (auto simp: slice_set_conv_nth)

lemma take_slice[simp]: \<open>take n (slice lo hi xs) = slice lo (min (n + lo) hi) xs\<close>
  unfolding slice_def by (simp add: take_drop)

lemma drop_slice[simp]:
  \<open>drop n (slice lo hi xs) = slice (n + lo) hi xs\<close>
  unfolding slice_def by simp

subsection \<open>Swap and Slice together\<close>

lemma slice_swap_extract:
  assumes \<open>lo \<le> i\<close>
    and \<open>lo \<le> j\<close>
    and \<open>i < hi\<close>
    and \<open>j < hi\<close>
    and \<open>i < length xs \<or> j < length xs\<close> \<comment> \<open>Not sure why it doesn't need both at once.\<close>
  shows \<open>slice lo hi (swap i j xs) = swap (i - lo) (j - lo) (slice lo hi xs)\<close>
  using assms unfolding slice_def swap_def
  by (smt append_take_drop_id drop_update_swap le_cases length_take min.absorb2 not_less nth_append
      order_trans take_all take_update_swap)
(*   if using `hi \<le> length xs`, only need `by (simp add: drop_update_swap take_update_swap)` *)

lemma mset_slice_swap[simp]:
  assumes \<open>lo \<le> i\<close>
      and \<open>lo \<le> j\<close>
      and \<open>i < hi\<close>
      and \<open>j < hi\<close>
      and \<open>i < length xs\<close>
      and \<open>j < length xs\<close>
  shows \<open>mset (slice lo hi (swap i j xs)) = mset (slice lo hi xs)\<close>
  using assms
  apply (simp add: slice_swap_extract)
  unfolding slice_def
  by simp

lemma set_slice_swap[simp]:
  assumes \<open>lo \<le> i\<close>
      and \<open>lo \<le> j\<close>
      and \<open>i < hi\<close>
      and \<open>j < hi\<close>
      and \<open>i < length xs\<close>
      and \<open>j < length xs\<close>
  shows \<open>set (slice lo hi (swap i j xs)) = set (slice lo hi xs)\<close>
  using assms
  apply (simp add: slice_swap_extract)
  unfolding slice_def
  by simp

lemma set_slice_swap_greaterthan: \<comment> \<open>Not all that useful. Could be more general.\<close>
  fixes xs :: \<open>_::linorder list\<close>
  assumes \<open>\<forall>x \<in> set (slice i hi xs). x \<ge> xs!hi\<close>
      and \<open>i \<le> hi\<close>
      and \<open>hi < length xs\<close>
  shows \<open>\<forall>x \<in> set (slice i (Suc hi) (swap i hi xs)). x \<ge> xs!hi\<close>
  using assms
  apply auto \<comment> \<open>First application cannot use @{thm slice_suc2_eq} or we get an extra goal.\<close>
  by (auto simp add: slice_suc2_eq)

lemma slice_swap1[simp]:
  assumes \<open>i < lo\<close>
      and \<open>j < lo\<close>
  shows \<open>slice lo hi (swap i j xs) = slice lo hi xs\<close>
  using assms unfolding slice_def swap_def
  by (simp add: drop_take)

lemma slice_swap2[simp]:
  assumes \<open>hi \<le> i\<close>
      and \<open>hi \<le> j\<close>
  shows \<open>slice lo hi (swap i j xs) = slice lo hi xs\<close>
  using assms unfolding slice_def swap_def
  by simp

subsection \<open>Sorting pivots\<close>

definition \<open>pivot_invr i A \<equiv> \<forall>x \<in> set (take i A). \<forall>y \<in> set (drop i A). x \<le> y\<close>
abbreviation \<open>pivot_invr\<^sub>u \<equiv> bop pivot_invr\<close>

subsection \<open>Miscellaneous\<close>

lemma upred_taut_refl: \<open>`A \<Rightarrow> A`\<close>
  by pred_simp

text \<open>Minor helper for blocks in partial correctness.\<close>
abbreviation \<open>stet v s \<equiv> \<guillemotleft>\<lbrakk>v\<rbrakk>\<^sub>e s\<guillemotright>\<close>

end