(*  Title:       Tarski's geometry
    Author:      Tim Makarios <tjm1983 at gmail.com>, 2012
    Maintainer:  Tim Makarios <tjm1983 at gmail.com>
*)

section "Tarski's geometry"

theory Tarski
  imports Complex_Main Miscellany Metric
begin

subsection "The axioms"
text \<open>The axioms, and all theorems beginning with \emph{th}
  followed by a number, are based on corresponding axioms and
  theorems in \cite{schwabhauser}.\<close>

locale tarski_first3 =
  fixes C :: "'p \<Rightarrow> 'p \<Rightarrow> 'p \<Rightarrow> 'p \<Rightarrow> bool"     ("_ _ \<congruent> _ _" [99,99,99,99] 50)
  assumes A1: "\<forall>a b. a b \<congruent> b a"
  and A2: "\<forall>a b p q r s. a b \<congruent> p q \<and> a b \<congruent> r s \<longrightarrow> p q \<congruent> r s"
  and A3: "\<forall>a b c. a b \<congruent> c c \<longrightarrow> a = b"

locale tarski_first5 = tarski_first3 +
  fixes B :: "'p \<Rightarrow> 'p \<Rightarrow> 'p \<Rightarrow> bool"
  assumes A4: "\<forall>q a b c. \<exists>x. B q a x \<and> a x \<congruent> b c"
  and A5: "\<forall>a b c d a' b' c' d'. a \<noteq> b \<and> B a b c \<and> B a' b' c'
                                               \<and> a b \<congruent> a' b' \<and> b c \<congruent> b' c' \<and> a d \<congruent> a' d' \<and> b d \<congruent> b' d'
                                       \<longrightarrow> c d \<congruent> c' d'"

locale tarski_absolute_space = tarski_first5 +
  assumes A6: "\<forall>a b. B a b a \<longrightarrow> a = b"
  and A7: "\<forall>a b c p q. B a p c \<and> B b q c \<longrightarrow> (\<exists>x. B p x b \<and> B q x a)"
  and A11: "\<forall>X Y. (\<exists>a. \<forall>x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B a x y)
                        \<longrightarrow> (\<exists>b. \<forall>x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B x b y)"

locale tarski_absolute = tarski_absolute_space +
  assumes A8: "\<exists>a b c. \<not> B a b c \<and> \<not> B b c a \<and> \<not> B c a b"
  and A9: "\<forall>p q a b c. p \<noteq> q \<and> a p \<congruent> a q \<and> b p \<congruent> b q \<and> c p \<congruent> c q
                             \<longrightarrow> B a b c \<or> B b c a \<or> B c a b"

locale tarski_space = tarski_absolute_space +
  assumes A10: "\<forall>a b c d t. B a d t \<and> B b d c \<and> a \<noteq> d
                                    \<longrightarrow> (\<exists>x y. B a b x \<and> B a c y \<and> B x t y)"

locale tarski = tarski_absolute + tarski_space

subsection "Semimetric spaces satisfy the first three axioms"

context semimetric
begin
  definition smC :: "'p \<Rightarrow> 'p \<Rightarrow> 'p \<Rightarrow> 'p \<Rightarrow> bool" ("_ _ \<congruent>\<^sub>s\<^sub>m _ _" [99,99,99,99] 50)
    where [simp]: "a b \<congruent>\<^sub>s\<^sub>m c d \<equiv> dist a b = dist c d"
end

sublocale semimetric < tarski_first3 smC
proof
  from symm show "\<forall>a b. a b \<congruent>\<^sub>s\<^sub>m b a" by simp
  show "\<forall>a b p q r s. a b \<congruent>\<^sub>s\<^sub>m p q \<and> a b \<congruent>\<^sub>s\<^sub>m r s \<longrightarrow> p q \<congruent>\<^sub>s\<^sub>m r s" by simp
  show "\<forall>a b c. a b \<congruent>\<^sub>s\<^sub>m c c \<longrightarrow> a = b" by simp
qed

subsection "Some consequences of the first three axioms"

context tarski_first3
begin
  notation %invisible C ("_ _ \<equiv> _ _" [99,99,99,99] 50)
  lemma A1': "a b \<congruent> b a"
    by (simp add: A1)

  lemma A2': "\<lbrakk>a b \<congruent> p q; a b \<congruent> r s\<rbrakk> \<Longrightarrow> p q \<congruent> r s"
  proof -
    assume "a b \<congruent> p q" and "a b \<congruent> r s"
    with A2 show ?thesis by blast
  qed

  lemma A3': "a b \<congruent> c c \<Longrightarrow> a = b"
    by (simp add: A3)

  theorem th2_1: "a b \<congruent> a b"
  proof -
    from A2' [of b a a b a b] and A1' [of b a] show ?thesis by simp
  qed

  theorem th2_2: "a b \<congruent> c d \<Longrightarrow> c d \<congruent> a b"
  proof -
    assume "a b \<congruent> c d"
    with A2' [of a b c d a b] and th2_1 [of a b] show ?thesis by simp
  qed

  theorem th2_3: "\<lbrakk>a b \<congruent> c d; c d \<congruent> e f\<rbrakk> \<Longrightarrow> a b \<congruent> e f"
  proof -
    assume "a b \<congruent> c d"
    with th2_2 [of a b c d] have "c d \<congruent> a b" by simp
    assume "c d \<congruent> e f"
    with A2' [of c d a b e f] and \<open>c d \<congruent> a b\<close> show ?thesis by simp
  qed

  theorem th2_4: "a b \<congruent> c d \<Longrightarrow> b a \<congruent> c d"
  proof -
    assume "a b \<congruent> c d"
    with th2_3 [of b a a b c d] and A1' [of b a] show ?thesis by simp
  qed

  definition is_segment :: "'p set \<Rightarrow> bool" where
  "is_segment X \<equiv> \<exists>x y. X = {x, y}"

  definition segments :: "'p set set" where
  "segments = {X. is_segment X}"

  definition SC :: "'p set \<Rightarrow> 'p set \<Rightarrow> bool" where
  "SC X Y \<equiv> \<exists>w x y z. X = {w, x} \<and> Y = {y, z} \<and> w x \<congruent> y z"

  definition SC_rel :: "('p set \<times> 'p set) set" where
  "SC_rel = {(X, Y) | X Y. SC X Y}"

  lemma left_segment_congruence:
    assumes "{a, b} = {p, q}" and "p q \<congruent> c d"
    shows "a b \<congruent> c d"
  proof cases
    assume "a = p"
    with unordered_pair_element_equality [of a b p q] and \<open>{a, b} = {p, q}\<close>
      have "b = q" by simp
    with \<open>p q \<congruent> c d\<close> and \<open>a = p\<close> show ?thesis by simp
  next
    assume "a \<noteq> p"
    with \<open>{a, b} = {p, q}\<close> have "a = q" by auto
    with unordered_pair_element_equality [of a b q p] and \<open>{a, b} = {p, q}\<close>
      have "b = p" by auto
    with \<open>p q \<congruent> c d\<close> and \<open>a = q\<close> have "b a \<congruent> c d" by simp
    with th2_4 [of b a c d] show ?thesis by simp
  qed

  lemma right_segment_congruence:
    assumes "{c, d} = {p, q}" and "a b \<congruent> p q"
    shows "a b \<congruent> c d"
  proof -
    from th2_2 [of a b p q] and \<open>a b \<congruent> p q\<close> have "p q \<congruent> a b" by simp
    with left_segment_congruence [of c d p q a b] and \<open>{c, d} = {p, q}\<close>
      have "c d \<congruent> a b" by simp
    with th2_2 [of c d a b] show ?thesis by simp
  qed

  lemma C_SC_equiv: "a b \<congruent> c d = SC {a, b} {c, d}"
  proof
    assume "a b \<congruent> c d"
    with SC_def [of "{a, b}" "{c, d}"] show "SC {a, b} {c, d}" by auto
  next
    assume "SC {a, b} {c, d}"
    with SC_def [of "{a, b}" "{c, d}"]
      obtain w x y z where "{a, b} = {w, x}" and "{c, d} = {y, z}" and "w x \<congruent> y z"
        by blast
    from left_segment_congruence [of a b w x y z] and
        \<open>{a, b} = {w, x}\<close> and
        \<open>w x \<congruent> y z\<close>
      have "a b \<congruent> y z" by simp
    with right_segment_congruence [of c d y z a b] and \<open>{c, d} = {y, z}\<close>
      show "a b \<congruent> c d" by simp
  qed

  lemmas SC_refl = th2_1 [simplified]

  lemma SC_rel_refl: "refl_on segments SC_rel"
  proof -
    note refl_on_def [of segments SC_rel]
    moreover
    { fix Z
      assume "Z \<in> SC_rel"
      with SC_rel_def obtain X Y where "Z = (X, Y)" and "SC X Y" by auto
      from \<open>SC X Y\<close> and SC_def [of X Y]
        have "\<exists>w x. X = {w, x}" and "\<exists>y z. Y = {y, z}" by auto
      with is_segment_def [of X] and is_segment_def [of Y]
        have "is_segment X" and "is_segment Y" by auto
      with segments_def have "X \<in> segments" and "Y \<in> segments" by auto
      with \<open>Z = (X, Y)\<close> have "Z \<in> segments \<times> segments" by simp }
    hence "SC_rel \<subseteq> segments \<times> segments" by auto
    moreover
    { fix X
      assume "X \<in> segments"
      with segments_def have "is_segment X" by auto
      with is_segment_def [of X] obtain x y where "X = {x, y}" by auto
      with SC_def [of X X] and SC_refl have "SC X X" by (simp add: C_SC_equiv)
      with SC_rel_def have "(X, X) \<in> SC_rel" by simp }
    hence "\<forall>X. X \<in> segments \<longrightarrow> (X, X) \<in> SC_rel" by simp
    ultimately show ?thesis by simp
  qed

  lemma SC_sym:
    assumes "SC X Y"
    shows "SC Y X"
  proof -
    from SC_def [of X Y] and \<open>SC X Y\<close>
      obtain w x y z where "X = {w, x}" and "Y = {y, z}" and "w x \<congruent> y z"
        by auto
    from th2_2 [of w x y z] and \<open>w x \<congruent> y z\<close> have "y z \<congruent> w x" by simp
    with SC_def [of Y X] and \<open>X = {w, x}\<close> and \<open>Y = {y, z}\<close>
      show "SC Y X" by (simp add: C_SC_equiv)
  qed

  lemma SC_sym': "SC X Y = SC Y X"
  proof
    assume "SC X Y"
    with SC_sym [of X Y] show "SC Y X" by simp
  next
    assume "SC Y X"
    with SC_sym [of Y X] show "SC X Y" by simp
  qed

  lemma SC_rel_sym: "sym SC_rel"
  proof -
    { fix X Y
      assume "(X, Y) \<in> SC_rel"
      with SC_rel_def have "SC X Y" by simp
      with SC_sym' have "SC Y X" by simp
      with SC_rel_def have "(Y, X) \<in> SC_rel" by simp }
    with sym_def [of SC_rel] show ?thesis by blast
  qed

  lemma SC_trans:
    assumes "SC X Y" and "SC Y Z"
    shows "SC X Z"
  proof -
    from SC_def [of X Y] and \<open>SC X Y\<close>
      obtain w x y z where "X = {w, x}" and "Y = {y, z}" and "w x \<congruent> y z"
        by auto
    from SC_def [of Y Z] and \<open>SC Y Z\<close>
      obtain p q r s where "Y = {p, q}" and "Z = {r, s}" and "p q \<congruent> r s" by auto
    from \<open>Y = {y, z}\<close> and \<open>Y = {p, q}\<close> and \<open>p q \<congruent> r s\<close>
      have "y z \<congruent> r s" by (simp add: C_SC_equiv)
    with th2_3 [of w x y z r s] and \<open>w x \<congruent> y z\<close> have "w x \<congruent> r s" by simp
    with SC_def [of X Z] and \<open>X = {w, x}\<close> and \<open>Z = {r, s}\<close>
      show "SC X Z" by (simp add: C_SC_equiv)
  qed

  lemma SC_rel_trans: "trans SC_rel"
  proof -
    { fix X Y Z
      assume "(X, Y) \<in> SC_rel" and "(Y, Z) \<in> SC_rel"
      with SC_rel_def have "SC X Y" and "SC Y Z" by auto
      with SC_trans [of X Y Z] have "SC X Z" by simp
      with SC_rel_def have "(X, Z) \<in> SC_rel" by simp }
    with trans_def [of SC_rel] show ?thesis by blast
  qed

  lemma A3_reversed:
    assumes "a a \<congruent> b c"
    shows "b = c"
  proof -
    from \<open>a a \<congruent> b c\<close> have "b c \<congruent> a a" by (rule th2_2)
    thus "b = c" by (rule A3')
  qed

  lemma equiv_segments_SC_rel: "equiv segments SC_rel"
    by (simp add: equiv_def SC_rel_refl SC_rel_sym SC_rel_trans)

end

subsection "Some consequences of the first five axioms"

context tarski_first5
begin
  lemma A4': "\<exists>x. B q a x \<and> a x \<congruent> b c"
    by (simp add: A4 [simplified])

  theorem th2_8: "a a \<congruent> b b"
  proof -
    from A4' [of _ a b b] obtain x where "a x \<congruent> b b" by auto
    with A3' [of a x b] have "x = a" by simp
    with \<open>a x \<congruent> b b\<close> show ?thesis by simp
  qed

  definition OFS :: "['p,'p,'p,'p,'p,'p,'p,'p] \<Rightarrow> bool" where
   "OFS a b c d a' b' c' d' \<equiv>
      B a b c \<and> B a' b' c' \<and> a b \<congruent> a' b' \<and> b c \<congruent> b' c' \<and> a d \<congruent> a' d' \<and> b d \<congruent> b' d'"

  lemma A5': "\<lbrakk>OFS a b c d a' b' c' d'; a \<noteq> b\<rbrakk> \<Longrightarrow> c d \<congruent> c' d'"
  proof -
    assume "OFS a b c d a' b' c' d'" and "a \<noteq> b"
    with A5 and OFS_def show ?thesis by blast
  qed

  theorem th2_11:
    assumes hypotheses:
      "B a b c"
      "B a' b' c'"
      "a b \<congruent> a' b'"
      "b c \<congruent> b' c'"
    shows "a c \<congruent> a' c'"
  proof cases
    assume "a = b"
    with \<open>a b \<congruent> a' b'\<close> have "a' = b'" by (simp add: A3_reversed)
    with \<open>b c \<congruent> b' c'\<close> and \<open>a = b\<close> show ?thesis by simp
  next
    assume "a \<noteq> b"
    moreover
      note A5' [of a b c a a' b' c' a'] and
        unordered_pair_equality [of a c] and
        unordered_pair_equality [of a' c']
    moreover
      from OFS_def [of a b c a a' b' c' a'] and
          hypotheses and
          th2_8 [of a a'] and
          unordered_pair_equality [of a b] and
          unordered_pair_equality [of a' b']
        have "OFS a b c a a' b' c' a'" by (simp add: C_SC_equiv)
    ultimately show ?thesis by (simp add: C_SC_equiv)
  qed

  lemma A4_unique:
    assumes "q \<noteq> a" and "B q a x" and "a x \<congruent> b c"
    and "B q a x'" and "a x' \<congruent> b c"
    shows "x = x'"
  proof -
    from SC_sym' and SC_trans and C_SC_equiv and \<open>a x' \<congruent> b c\<close> and \<open>a x \<congruent> b c\<close>
      have "a x \<congruent> a x'" by blast
    with th2_11 [of q a x q a x'] and \<open>B q a x\<close> and \<open>B q a x'\<close> and SC_refl
      have "q x \<congruent> q x'" by simp
    with OFS_def [of q a x x q a x x'] and
        \<open>B q a x\<close> and
        SC_refl and
        \<open>a x \<congruent> a x'\<close>
      have "OFS q a x x q a x x'" by simp
    with A5' [of q a x x q a x x'] and \<open>q \<noteq> a\<close> have "x x \<congruent> x x'" by simp
    thus "x = x'" by (rule A3_reversed)
  qed

  theorem th2_12:
    assumes "q \<noteq> a"
    shows "\<exists>!x. B q a x \<and> a x \<congruent> b c"
    using \<open>q \<noteq> a\<close> and A4' and A4_unique
    by blast
end

subsection "Simple theorems about betweenness"

theorem (in tarski_first5) th3_1: "B a b b"
proof -
  from A4 [rule_format, of a b b b] obtain x where "B a b x" and "b x \<congruent> b b" by auto
  from A3 [rule_format, of b x b] and \<open>b x \<congruent> b b\<close> have "b = x" by simp
  with \<open>B a b x\<close> show "B a b b" by simp
qed

context tarski_absolute_space
begin
  lemma A6':
    assumes "B a b a"
    shows "a = b"
  proof -
    from A6 and \<open>B a b a\<close> show "a = b" by simp
  qed

  lemma A7':
    assumes "B a p c" and "B b q c"
    shows "\<exists>x. B p x b \<and> B q x a"
  proof -
    from A7 and \<open>B a p c\<close> and \<open>B b q c\<close> show ?thesis by blast
  qed

  lemma A11':
    assumes "\<forall> x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B a x y"
    shows "\<exists> b. \<forall> x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B x b y"
  proof -
    from assms have "\<exists> a. \<forall> x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B a x y" by (rule exI)
    thus "\<exists> b. \<forall> x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B x b y" by (rule A11 [rule_format])
  qed

  theorem th3_2:
    assumes "B a b c"
    shows "B c b a"
  proof -
    from th3_1 have "B b c c" by simp
    with A7' and \<open>B a b c\<close> obtain x where "B b x b" and "B c x a" by blast
    from A6' and \<open>B b x b\<close> have "x = b" by auto
    with \<open>B c x a\<close> show "B c b a" by simp
  qed

  theorem th3_4:
    assumes "B a b c" and "B b a c"
    shows "a = b"
  proof -
    from \<open>B a b c\<close> and \<open>B b a c\<close> and A7' [of a b c b a]
    obtain x where "B b x b" and "B a x a" by auto
    hence "b = x" and "a = x" by (simp_all add: A6')
    thus "a = b" by simp
  qed

  theorem th3_5_1:
    assumes "B a b d" and "B b c d"
    shows "B a b c"
  proof -
    from \<open>B a b d\<close> and \<open>B b c d\<close> and A7' [of a b d b c]
    obtain x where "B b x b" and "B c x a" by auto
    from \<open>B b x b\<close> have "b = x" by (rule A6')
    with \<open>B c x a\<close> have "B c b a" by simp
    thus "B a b c" by (rule th3_2)
  qed

  theorem th3_6_1:
    assumes "B a b c" and "B a c d"
    shows "B b c d"
  proof -
    from \<open>B a c d\<close> and \<open>B a b c\<close> and th3_2 have "B d c a" and "B c b a" by fast+
    hence "B d c b" by (rule th3_5_1)
    thus "B b c d" by (rule th3_2)
  qed

  theorem th3_7_1:
    assumes "b \<noteq> c" and "B a b c" and "B b c d"
    shows "B a c d"
  proof -
    from A4' obtain x where "B a c x" and "c x \<congruent> c d" by fast
    from \<open>B a b c\<close> and \<open>B a c x\<close> have "B b c x" by (rule th3_6_1)
    have "c d \<congruent> c d" by (rule th2_1)
    with \<open>b \<noteq> c\<close> and \<open>B b c x\<close> and \<open>c x \<congruent> c d\<close> and \<open>B b c d\<close>
    have "x = d" by (rule A4_unique)
    with \<open>B a c x\<close> show "B a c d" by simp
  qed

subsection "Simple theorems about congruence and betweenness"

definition (in tarski_first5) Col :: "'p \<Rightarrow> 'p \<Rightarrow> 'p \<Rightarrow> bool" where
  "Col a b c \<equiv> B a b c \<or> B b c a \<or> B c a b"

end


(*  Title:      HOL/Word/Word_Bitwise.thy
    Authors:    Thomas Sewell, NICTA and Sascha Boehme, TU Muenchen
*)

theory Word_Bitwise
  imports Word
begin

text \<open>Helper constants used in defining addition\<close>

definition xor3 :: "bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool"
  where "xor3 a b c = (a = (b = c))"

definition carry :: "bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool"
  where "carry a b c = ((a \<and> (b \<or> c)) \<or> (b \<and> c))"

lemma carry_simps:
  "carry True a b = (a \<or> b)"
  "carry a True b = (a \<or> b)"
  "carry a b True = (a \<or> b)"
  "carry False a b = (a \<and> b)"
  "carry a False b = (a \<and> b)"
  "carry a b False = (a \<and> b)"
  by (auto simp add: carry_def)

lemma xor3_simps:
  "xor3 True a b = (a = b)"
  "xor3 a True b = (a = b)"
  "xor3 a b True = (a = b)"
  "xor3 False a b = (a \<noteq> b)"
  "xor3 a False b = (a \<noteq> b)"
  "xor3 a b False = (a \<noteq> b)"
  by (simp_all add: xor3_def)

text \<open>Breaking up word equalities into equalities on their
  bit lists. Equalities are generated and manipulated in the
  reverse order to \<^const>\<open>to_bl\<close>.\<close>

lemma bl_word_sub: "to_bl (x - y) = to_bl (x + (- y))"
  by simp

lemma rbl_word_1: "rev (to_bl (1 :: 'a::len0 word)) = takefill False (LENGTH('a)) [True]"
  apply (rule_tac s="rev (to_bl (word_succ (0 :: 'a word)))" in trans)
   apply simp
  apply (simp only: rtb_rbl_ariths(1)[OF refl])
  apply simp
  apply (case_tac "LENGTH('a)")
   apply simp
  apply (simp add: takefill_alt)
  done

lemma rbl_word_if: "rev (to_bl (if P then x else y)) = map2 (If P) (rev (to_bl x)) (rev (to_bl y))"
  by (simp add: split_def)

lemma rbl_add_carry_Cons:
  "(if car then rbl_succ else id) (rbl_add (x # xs) (y # ys)) =
    xor3 x y car # (if carry x y car then rbl_succ else id) (rbl_add xs ys)"
  by (simp add: carry_def xor3_def)

lemma rbl_add_suc_carry_fold:
  "length xs = length ys \<Longrightarrow>
    \<forall>car. (if car then rbl_succ else id) (rbl_add xs ys) =
      (foldr (\<lambda>(x, y) res car. xor3 x y car # res (carry x y car)) (zip xs ys) (\<lambda>_. [])) car"
  apply (erule list_induct2)
   apply simp
  apply (simp only: rbl_add_carry_Cons)
  apply simp
  done

lemma to_bl_plus_carry:
  "to_bl (x + y) =
    rev (foldr (\<lambda>(x, y) res car. xor3 x y car # res (carry x y car))
      (rev (zip (to_bl x) (to_bl y))) (\<lambda>_. []) False)"
  using rbl_add_suc_carry_fold[where xs="rev (to_bl x)" and ys="rev (to_bl y)"]
  apply (simp add: word_add_rbl[OF refl refl])
  apply (drule_tac x=False in spec)
  apply (simp add: zip_rev)
  done

definition "rbl_plus cin xs ys =
  foldr (\<lambda>(x, y) res car. xor3 x y car # res (carry x y car)) (zip xs ys) (\<lambda>_. []) cin"

lemma rbl_plus_simps:
  "rbl_plus cin (x # xs) (y # ys) = xor3 x y cin # rbl_plus (carry x y cin) xs ys"
  "rbl_plus cin [] ys = []"
  "rbl_plus cin xs [] = []"
  by (simp_all add: rbl_plus_def)

lemma rbl_word_plus: "rev (to_bl (x + y)) = rbl_plus False (rev (to_bl x)) (rev (to_bl y))"
  by (simp add: rbl_plus_def to_bl_plus_carry zip_rev)

definition "rbl_succ2 b xs = (if b then rbl_succ xs else xs)"

lemma rbl_succ2_simps:
  "rbl_succ2 b [] = []"
  "rbl_succ2 b (x # xs) = (b \<noteq> x) # rbl_succ2 (x \<and> b) xs"
  by (simp_all add: rbl_succ2_def)

lemma twos_complement: "- x = word_succ (NOT x)"
  using arg_cong[OF word_add_not[where x=x], where f="\<lambda>a. a - x + 1"]
  by (simp add: word_succ_p1 word_sp_01[unfolded word_succ_p1] del: word_add_not)

lemma rbl_word_neg: "rev (to_bl (- x)) = rbl_succ2 True (map Not (rev (to_bl x)))"
  by (simp add: twos_complement word_succ_rbl[OF refl] bl_word_not rev_map rbl_succ2_def)

lemma rbl_word_cat:
  "rev (to_bl (word_cat x y :: 'a::len0 word)) =
    takefill False (LENGTH('a)) (rev (to_bl y) @ rev (to_bl x))"
  by (simp add: word_cat_bl word_rev_tf)

lemma rbl_word_slice:
  "rev (to_bl (slice n w :: 'a::len0 word)) =
    takefill False (LENGTH('a)) (drop n (rev (to_bl w)))"
  apply (simp add: slice_take word_rev_tf rev_take)
  apply (cases "n < LENGTH('b)", simp_all)
  done

lemma rbl_word_ucast:
  "rev (to_bl (ucast x :: 'a::len0 word)) = takefill False (LENGTH('a)) (rev (to_bl x))"
  apply (simp add: to_bl_ucast takefill_alt)
  apply (simp add: rev_drop)
  apply (cases "LENGTH('a) < LENGTH('b)")
   apply simp_all
  done

lemma rbl_shiftl:
  "rev (to_bl (w << n)) = takefill False (size w) (replicate n False @ rev (to_bl w))"
  by (simp add: bl_shiftl takefill_alt word_size rev_drop)

lemma rbl_shiftr:
  "rev (to_bl (w >> n)) = takefill False (size w) (drop n (rev (to_bl w)))"
  by (simp add: shiftr_slice rbl_word_slice word_size)

definition "drop_nonempty v n xs = (if n < length xs then drop n xs else [last (v # xs)])"

lemma drop_nonempty_simps:
  "drop_nonempty v (Suc n) (x # xs) = drop_nonempty x n xs"
  "drop_nonempty v 0 (x # xs) = (x # xs)"
  "drop_nonempty v n [] = [v]"
  by (simp_all add: drop_nonempty_def)

definition "takefill_last x n xs = takefill (last (x # xs)) n xs"

lemma takefill_last_simps:
  "takefill_last z (Suc n) (x # xs) = x # takefill_last x n xs"
  "takefill_last z 0 xs = []"
  "takefill_last z n [] = replicate n z"
  by (simp_all add: takefill_last_def) (simp_all add: takefill_alt)

lemma rbl_sshiftr:
  "rev (to_bl (w >>> n)) = takefill_last False (size w) (drop_nonempty False n (rev (to_bl w)))"
  apply (cases "n < size w")
   apply (simp add: bl_sshiftr takefill_last_def word_size
      takefill_alt rev_take last_rev
      drop_nonempty_def)
  apply (subgoal_tac "(w >>> n) = of_bl (replicate (size w) (msb w))")
   apply (simp add: word_size takefill_last_def takefill_alt
      last_rev word_msb_alt word_rev_tf
      drop_nonempty_def take_Cons')
   apply (case_tac "LENGTH('a)", simp_all)
  apply (rule word_eqI)
  apply (simp add: nth_sshiftr word_size test_bit_of_bl
      msb_nth)
  done

lemma nth_word_of_int:
  "(word_of_int x :: 'a::len0 word) !! n = (n < LENGTH('a) \<and> bin_nth x n)"
  apply (simp add: test_bit_bl word_size to_bl_of_bin)
  apply (subst conj_cong[OF refl], erule bin_nth_bl)
  apply auto
  done

lemma nth_scast:
  "(scast (x :: 'a::len word) :: 'b::len word) !! n =
    (n < LENGTH('b) \<and>
    (if n < LENGTH('a) - 1 then x !! n
     else x !! (LENGTH('a) - 1)))"
  by (simp add: scast_def nth_sint)

lemma rbl_word_scast:
  "rev (to_bl (scast x :: 'a::len word)) = takefill_last False (LENGTH('a)) (rev (to_bl x))"
  apply (rule nth_equalityI)
   apply (simp add: word_size takefill_last_def)
  apply (clarsimp simp: nth_scast takefill_last_def
      nth_takefill word_size nth_rev to_bl_nth)
  apply (cases "LENGTH('b)")
   apply simp
  apply (clarsimp simp: less_Suc_eq_le linorder_not_less
      last_rev word_msb_alt[symmetric]
      msb_nth)
  done

definition rbl_mul :: "bool list \<Rightarrow> bool list \<Rightarrow> bool list"
  where "rbl_mul xs ys = foldr (\<lambda>x sm. rbl_plus False (map ((\<and>) x) ys) (False # sm)) xs []"

lemma rbl_mul_simps:
  "rbl_mul (x # xs) ys = rbl_plus False (map ((\<and>) x) ys) (False # rbl_mul xs ys)"
  "rbl_mul [] ys = []"
  by (simp_all add: rbl_mul_def)

lemma takefill_le2: "length xs \<le> n \<Longrightarrow> takefill x m (takefill x n xs) = takefill x m xs"
  by (simp add: takefill_alt replicate_add[symmetric])

lemma take_rbl_plus: "\<forall>n b. take n (rbl_plus b xs ys) = rbl_plus b (take n xs) (take n ys)"
  apply (simp add: rbl_plus_def take_zip[symmetric])
  apply (rule_tac list="zip xs ys" in list.induct)
   apply simp
  apply (clarsimp simp: split_def)
  apply (case_tac n, simp_all)
  done

lemma word_rbl_mul_induct:
  "length xs \<le> size y \<Longrightarrow>
    rbl_mul xs (rev (to_bl y)) = take (length xs) (rev (to_bl (of_bl (rev xs) * y)))"
  for y :: "'a::len word"
proof (induct xs)
  case Nil
  show ?case by (simp add: rbl_mul_simps)
next
  case (Cons z zs)

  have rbl_word_plus': "to_bl (x + y) = rev (rbl_plus False (rev (to_bl x)) (rev (to_bl y)))"
    for x y :: "'a word"
    by (simp add: rbl_word_plus[symmetric])

  have mult_bit: "to_bl (of_bl [z] * y) = map ((\<and>) z) (to_bl y)"
    by (cases z) (simp cong: map_cong, simp add: map_replicate_const cong: map_cong)

  have shiftl: "of_bl xs * 2 * y = (of_bl xs * y) << 1" for xs
    by (simp add: shiftl_t2n)

  have zip_take_triv: "\<And>xs ys n. n = length ys \<Longrightarrow> zip (take n xs) ys = zip xs ys"
    by (rule nth_equalityI) simp_all

  from Cons show ?case
    apply (simp add: trans [OF of_bl_append add.commute]
        rbl_mul_simps rbl_word_plus' distrib_right mult_bit shiftl rbl_shiftl)
    apply (simp add: takefill_alt word_size rev_map take_rbl_plus min_def)
    apply (simp add: rbl_plus_def zip_take_triv)
    done
qed

lemma rbl_word_mul: "rev (to_bl (x * y)) = rbl_mul (rev (to_bl x)) (rev (to_bl y))"
  for x :: "'a::len word"
  using word_rbl_mul_induct[where xs="rev (to_bl x)" and y=y] by (simp add: word_size)

text \<open>Breaking up inequalities into bitlist properties.\<close>

definition
  "rev_bl_order F xs ys =
     (length xs = length ys \<and>
       ((xs = ys \<and> F)
          \<or> (\<exists>n < length xs. drop (Suc n) xs = drop (Suc n) ys
                   \<and> \<not> xs ! n \<and> ys ! n)))"

lemma rev_bl_order_simps:
  "rev_bl_order F [] [] = F"
  "rev_bl_order F (x # xs) (y # ys) = rev_bl_order ((y \<and> \<not> x) \<or> ((y \<or> \<not> x) \<and> F)) xs ys"
   apply (simp_all add: rev_bl_order_def)
  apply (rule conj_cong[OF refl])
  apply (cases "xs = ys")
   apply (simp add: nth_Cons')
   apply blast
  apply (simp add: nth_Cons')
  apply safe
   apply (rule_tac x="n - 1" in exI)
   apply simp
  apply (rule_tac x="Suc n" in exI)
  apply simp
  done

lemma rev_bl_order_rev_simp:
  "length xs = length ys \<Longrightarrow>
   rev_bl_order F (xs @ [x]) (ys @ [y]) = ((y \<and> \<not> x) \<or> ((y \<or> \<not> x) \<and> rev_bl_order F xs ys))"
  by (induct arbitrary: F rule: list_induct2) (auto simp: rev_bl_order_simps)

lemma rev_bl_order_bl_to_bin:
  "length xs = length ys \<Longrightarrow>
    rev_bl_order True xs ys = (bl_to_bin (rev xs) \<le> bl_to_bin (rev ys)) \<and>
    rev_bl_order False xs ys = (bl_to_bin (rev xs) < bl_to_bin (rev ys))"
  apply (induct xs ys rule: list_induct2)
   apply (simp_all add: rev_bl_order_simps bl_to_bin_app_cat)
  apply (auto simp add: bl_to_bin_def Bit_B0 Bit_B1 add1_zle_eq Bit_def)
  done

lemma word_le_rbl: "x \<le> y \<longleftrightarrow> rev_bl_order True (rev (to_bl x)) (rev (to_bl y))"
  for x y :: "'a::len0 word"
  by (simp add: rev_bl_order_bl_to_bin word_le_def)

lemma word_less_rbl: "x < y \<longleftrightarrow> rev_bl_order False (rev (to_bl x)) (rev (to_bl y))"
  for x y :: "'a::len0 word"
  by (simp add: word_less_alt rev_bl_order_bl_to_bin)

lemma word_sint_msb_eq: "sint x = uint x - (if msb x then 2 ^ size x else 0)"
  apply (cases "msb x")
   apply (rule word_sint.Abs_eqD[where 'a='a], simp_all)
    apply (simp add: word_size wi_hom_syms word_of_int_2p_len)
   apply (simp add: sints_num word_size)
   apply (rule conjI)
    apply (simp add: le_diff_eq')
    apply (rule order_trans[where y="2 ^ (LENGTH('a) - 1)"])
     apply (simp add: power_Suc[symmetric])
    apply (simp add: linorder_not_less[symmetric] mask_eq_iff[symmetric])
    apply (rule notI, drule word_eqD[where x="size x - 1"])
    apply (simp add: msb_nth word_ops_nth_size word_size)
   apply (simp add: order_less_le_trans[where y=0])
  apply (rule word_uint.Abs_eqD[where 'a='a], simp_all)
  apply (simp add: linorder_not_less uints_num word_msb_sint)
  apply (rule order_less_le_trans[OF sint_lt])
  apply simp
  done

lemma word_sle_msb_le: "x <=s y \<longleftrightarrow> (msb y \<longrightarrow> msb x) \<and> ((msb x \<and> \<not> msb y) \<or> x \<le> y)"
  apply (simp add: word_sle_def word_sint_msb_eq word_size word_le_def)
  apply safe
   apply (rule order_trans[OF _ uint_ge_0])
   apply (simp add: order_less_imp_le)
  apply (erule notE[OF leD])
  apply (rule order_less_le_trans[OF _ uint_ge_0])
  apply simp
  done

lemma word_sless_msb_less: "x <s y \<longleftrightarrow> (msb y \<longrightarrow> msb x) \<and> ((msb x \<and> \<not> msb y) \<or> x < y)"
  by (auto simp add: word_sless_def word_sle_msb_le)

definition "map_last f xs = (if xs = [] then [] else butlast xs @ [f (last xs)])"

lemma map_last_simps:
  "map_last f [] = []"
  "map_last f [x] = [f x]"
  "map_last f (x # y # zs) = x # map_last f (y # zs)"
  by (simp_all add: map_last_def)

lemma word_sle_rbl:
  "x <=s y \<longleftrightarrow> rev_bl_order True (map_last Not (rev (to_bl x))) (map_last Not (rev (to_bl y)))"
  using word_msb_alt[where w=x] word_msb_alt[where w=y]
  apply (simp add: word_sle_msb_le word_le_rbl)
  apply (subgoal_tac "length (to_bl x) = length (to_bl y)")
   apply (cases "to_bl x", simp)
   apply (cases "to_bl y", simp)
   apply (clarsimp simp: map_last_def rev_bl_order_rev_simp)
   apply auto
  done

lemma word_sless_rbl:
  "x <s y \<longleftrightarrow> rev_bl_order False (map_last Not (rev (to_bl x))) (map_last Not (rev (to_bl y)))"
  using word_msb_alt[where w=x] word_msb_alt[where w=y]
  apply (simp add: word_sless_msb_less word_less_rbl)
  apply (subgoal_tac "length (to_bl x) = length (to_bl y)")
   apply (cases "to_bl x", simp)
   apply (cases "to_bl y", simp)
   apply (clarsimp simp: map_last_def rev_bl_order_rev_simp)
   apply auto
  done

text \<open>Lemmas for unpacking \<^term>\<open>rev (to_bl n)\<close> for numerals n and also
  for irreducible values and expressions.\<close>

lemma rev_bin_to_bl_simps:
  "rev (bin_to_bl 0 x) = []"
  "rev (bin_to_bl (Suc n) (numeral (num.Bit0 nm))) = False # rev (bin_to_bl n (numeral nm))"
  "rev (bin_to_bl (Suc n) (numeral (num.Bit1 nm))) = True # rev (bin_to_bl n (numeral nm))"
  "rev (bin_to_bl (Suc n) (numeral (num.One))) = True # replicate n False"
  "rev (bin_to_bl (Suc n) (- numeral (num.Bit0 nm))) = False # rev (bin_to_bl n (- numeral nm))"
  "rev (bin_to_bl (Suc n) (- numeral (num.Bit1 nm))) =
    True # rev (bin_to_bl n (- numeral (nm + num.One)))"
  "rev (bin_to_bl (Suc n) (- numeral (num.One))) = True # replicate n True"
  "rev (bin_to_bl (Suc n) (- numeral (num.Bit0 nm + num.One))) =
    True # rev (bin_to_bl n (- numeral (nm + num.One)))"
  "rev (bin_to_bl (Suc n) (- numeral (num.Bit1 nm + num.One))) =
    False # rev (bin_to_bl n (- numeral (nm + num.One)))"
  "rev (bin_to_bl (Suc n) (- numeral (num.One + num.One))) =
    False # rev (bin_to_bl n (- numeral num.One))"
  apply simp_all
  apply (simp_all only: bin_to_bl_aux_alt)
  apply (simp_all)
  apply (simp_all add: bin_to_bl_zero_aux bin_to_bl_minus1_aux)
  done

lemma to_bl_upt: "to_bl x = rev (map ((!!) x) [0 ..< size x])"
  apply (rule nth_equalityI)
   apply (simp add: word_size)
  apply (auto simp: to_bl_nth word_size nth_rev)
  done

lemma rev_to_bl_upt: "rev (to_bl x) = map ((!!) x) [0 ..< size x]"
  by (simp add: to_bl_upt)

lemma upt_eq_list_intros:
  "j \<le> i \<Longrightarrow> [i ..< j] = []"
  "i = x \<Longrightarrow> x < j \<Longrightarrow> [x + 1 ..< j] = xs \<Longrightarrow> [i ..< j] = (x # xs)"
  by (simp_all add: upt_eq_Cons_conv)

subsection \<open>Tactic definition\<close>

ML \<open>
structure Word_Bitwise_Tac =
struct

val word_ss = simpset_of \<^theory_context>\<open>Word\<close>;

fun mk_nat_clist ns =
  fold_rev (Thm.mk_binop \<^cterm>\<open>Cons :: nat \<Rightarrow> _\<close>)
    ns \<^cterm>\<open>[] :: nat list\<close>;

fun upt_conv ctxt ct =
  case Thm.term_of ct of
    (\<^const>\<open>upt\<close> $ n $ m) =>
      let
        val (i, j) = apply2 (snd o HOLogic.dest_number) (n, m);
        val ns = map (Numeral.mk_cnumber \<^ctyp>\<open>nat\<close>) (i upto (j - 1))
          |> mk_nat_clist;
        val prop =
          Thm.mk_binop \<^cterm>\<open>(=) :: nat list \<Rightarrow> _\<close> ct ns
          |> Thm.apply \<^cterm>\<open>Trueprop\<close>;
      in
        try (fn () =>
          Goal.prove_internal ctxt [] prop
            (K (REPEAT_DETERM (resolve_tac ctxt @{thms upt_eq_list_intros} 1
                ORELSE simp_tac (put_simpset word_ss ctxt) 1))) |> mk_meta_eq) ()
      end
  | _ => NONE;

val expand_upt_simproc =
  Simplifier.make_simproc \<^context> "expand_upt"
   {lhss = [\<^term>\<open>upt x y\<close>], proc = K upt_conv};

fun word_len_simproc_fn ctxt ct =
  (case Thm.term_of ct of
    Const (\<^const_name>\<open>len_of\<close>, _) $ t =>
     (let
        val T = fastype_of t |> dest_Type |> snd |> the_single
        val n = Numeral.mk_cnumber \<^ctyp>\<open>nat\<close> (Word_Lib.dest_binT T);
        val prop =
          Thm.mk_binop \<^cterm>\<open>(=) :: nat \<Rightarrow> _\<close> ct n
          |> Thm.apply \<^cterm>\<open>Trueprop\<close>;
      in
        Goal.prove_internal ctxt [] prop (K (simp_tac (put_simpset word_ss ctxt) 1))
        |> mk_meta_eq |> SOME
      end handle TERM _ => NONE | TYPE _ => NONE)
  | _ => NONE);

val word_len_simproc =
  Simplifier.make_simproc \<^context> "word_len"
   {lhss = [\<^term>\<open>len_of x\<close>], proc = K word_len_simproc_fn};

(* convert 5 or nat 5 to Suc 4 when n_sucs = 1, Suc (Suc 4) when n_sucs = 2,
   or just 5 (discarding nat) when n_sucs = 0 *)

fun nat_get_Suc_simproc_fn n_sucs ctxt ct =
  let
    val (f $ arg) = Thm.term_of ct;
    val n =
      (case arg of \<^term>\<open>nat\<close> $ n => n | n => n)
      |> HOLogic.dest_number |> snd;
    val (i, j) = if n > n_sucs then (n_sucs, n - n_sucs) else (n, 0);
    val arg' = funpow i HOLogic.mk_Suc (HOLogic.mk_number \<^typ>\<open>nat\<close> j);
    val _ = if arg = arg' then raise TERM ("", []) else ();
    fun propfn g =
      HOLogic.mk_eq (g arg, g arg')
      |> HOLogic.mk_Trueprop |> Thm.cterm_of ctxt;
    val eq1 =
      Goal.prove_internal ctxt [] (propfn I)
        (K (simp_tac (put_simpset word_ss ctxt) 1));
  in
    Goal.prove_internal ctxt [] (propfn (curry (op $) f))
      (K (simp_tac (put_simpset HOL_ss ctxt addsimps [eq1]) 1))
    |> mk_meta_eq |> SOME
  end handle TERM _ => NONE;

fun nat_get_Suc_simproc n_sucs ts =
  Simplifier.make_simproc \<^context> "nat_get_Suc"
   {lhss = map (fn t => t $ \<^term>\<open>n :: nat\<close>) ts,
    proc = K (nat_get_Suc_simproc_fn n_sucs)};

val no_split_ss =
  simpset_of (put_simpset HOL_ss \<^context>
    |> Splitter.del_split @{thm if_split});

val expand_word_eq_sss =
  (simpset_of (put_simpset HOL_basic_ss \<^context> addsimps
       @{thms word_eq_rbl_eq word_le_rbl word_less_rbl word_sle_rbl word_sless_rbl}),
  map simpset_of [
   put_simpset no_split_ss \<^context> addsimps
    @{thms rbl_word_plus rbl_word_and rbl_word_or rbl_word_not
                                rbl_word_neg bl_word_sub rbl_word_xor
                                rbl_word_cat rbl_word_slice rbl_word_scast
                                rbl_word_ucast rbl_shiftl rbl_shiftr rbl_sshiftr
                                rbl_word_if},
   put_simpset no_split_ss \<^context> addsimps
    @{thms to_bl_numeral to_bl_neg_numeral to_bl_0 rbl_word_1},
   put_simpset no_split_ss \<^context> addsimps
    @{thms rev_rev_ident rev_replicate rev_map to_bl_upt word_size}
          addsimprocs [word_len_simproc],
   put_simpset no_split_ss \<^context> addsimps
    @{thms list.simps split_conv replicate.simps list.map
                                zip_Cons_Cons zip_Nil drop_Suc_Cons drop_0 drop_Nil
                                foldr.simps list.map zip.simps(1) zip_Nil zip_Cons_Cons takefill_Suc_Cons
                                takefill_Suc_Nil takefill.Z rbl_succ2_simps
                                rbl_plus_simps rev_bin_to_bl_simps append.simps
                                takefill_last_simps drop_nonempty_simps
                                rev_bl_order_simps}
          addsimprocs [expand_upt_simproc,
                       nat_get_Suc_simproc 4
                         [\<^term>\<open>replicate\<close>, \<^term>\<open>takefill x\<close>,
                          \<^term>\<open>drop\<close>, \<^term>\<open>bin_to_bl\<close>,
                          \<^term>\<open>takefill_last x\<close>,
                          \<^term>\<open>drop_nonempty x\<close>]],
    put_simpset no_split_ss \<^context> addsimps @{thms xor3_simps carry_simps if_bool_simps}
  ])

fun tac ctxt =
  let
    val (ss, sss) = expand_word_eq_sss;
  in
    foldr1 (op THEN_ALL_NEW)
      ((CHANGED o safe_full_simp_tac (put_simpset ss ctxt)) ::
        map (fn ss => safe_full_simp_tac (put_simpset ss ctxt)) sss)
  end;

end
\<close>

method_setup word_bitwise =
  \<open>Scan.succeed (fn ctxt => Method.SIMPLE_METHOD (Word_Bitwise_Tac.tac ctxt 1))\<close>
  "decomposer for word equalities and inequalities into bit propositions"

end


(*
Title: Quantales with Converse
Author: Cameron Calk, Georg Struth
Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
*)

section \<open>Quantales with Converse\<close>

theory Quantale_conv
  imports Modal_Quantale MKA_conv

begin

subsection \<open>Involutive quantales\<close>

text \<open>The following axioms for involutive quantales are standard.\<close>

class involutive_quantale = quantale + invol_op +
  assumes inv_invol: "(x\<^sup>\<circ>)\<^sup>\<circ> = x"
  and inv_contrav: "(x \<cdot> y)\<^sup>\<circ> = y\<^sup>\<circ> \<cdot> x\<^sup>\<circ>"
  and inv_sup: "(\<Squnion>X)\<^sup>\<circ> = \<Squnion>{x\<^sup>\<circ> |x. x \<in> X}"

context involutive_quantale
begin

lemma inv_iso: "x \<le> y \<Longrightarrow> x\<^sup>\<circ> \<le> y\<^sup>\<circ>"
  by (smt (verit, ccfv_SIG) insertI1 insertI2 local.Sup_upper local.inv_sup local.sup.absorb1 local.sup_Sup mem_Collect_eq)

lemma inv_binsup: "(x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> \<squnion> y\<^sup>\<circ>"
  apply (rule order.antisym)
   apply (metis local.inv_invol local.inv_iso local.sup.cobounded1 local.sup.cobounded2 qdual.qd.add_least)
  by (simp add: local.inv_iso)

end

sublocale involutive_quantale \<subseteq> invqka: involutive_kleene_algebra invol "1" "(\<cdot>)" "(\<squnion>)" "\<bottom>" "(\<le>)" "(<)" qstar
  by (unfold_locales, simp_all add: local.inv_contrav inv_binsup inv_invol)

context involutive_quantale
begin

lemma inv_binf [simp]: "(x \<sqinter> y)\<^sup>\<circ> = x\<^sup>\<circ> \<sqinter> y\<^sup>\<circ>"
proof-
  {fix z
  have "(z \<le> (x \<sqinter> y)\<^sup>\<circ>) = (z\<^sup>\<circ> \<le> x \<sqinter> y)"
    using invqka.inv_adj by blast
  also have "\<dots> = (z\<^sup>\<circ> \<le> x \<and> z\<^sup>\<circ> \<le> y)"
    by simp
  also have "\<dots> = (z \<le> x\<^sup>\<circ> \<and> z \<le> y\<^sup>\<circ>)"
    by (simp add: invqka.inv_adj)
  also have "\<dots> = (z \<le> x\<^sup>\<circ> \<sqinter> y\<^sup>\<circ>)"
    by simp
  finally have "(z \<le> (x \<sqinter> y)\<^sup>\<circ>) = (z \<le> x\<^sup>\<circ> \<sqinter> y\<^sup>\<circ>)".}
  thus ?thesis
    using local.dual_order.antisym by blast
qed

lemma inv_inf [simp]: "(\<Sqinter>X)\<^sup>\<circ> = \<Sqinter>{x\<^sup>\<circ> |x. x \<in> X}"
  apply (rule order.antisym)
  using invqka.inv_adj local.Inf_lower local.le_Inf_iff apply auto[1]
  by (metis (mono_tags, lifting) invqka.inv_adj local.Inf_greatest local.Inf_lower mem_Collect_eq)

lemma inv_top [simp]: "\<top>\<^sup>\<circ> = \<top>"
proof-
  have a: "\<top>\<^sup>\<circ> \<le> \<top>"
    by simp
  hence "(\<top>\<^sup>\<circ>)\<^sup>\<circ> \<le> \<top>\<^sup>\<circ>"
    using local.inv_iso by blast
  hence "\<top> \<le> \<top>\<^sup>\<circ>"
    by simp
  thus ?thesis
    by (simp add: local.top_le)
qed
lemma inv_qstar_aux [simp]: "(x^i)\<^sup>\<circ> = (x\<^sup>\<circ>) ^ i"
  apply (induct i)
  using local.inv_contrav local.power_Suc2 by auto

lemma inv_conjugate: "(x\<^sup>\<circ> \<sqinter> y = \<bottom>) = (x \<sqinter> y\<^sup>\<circ> = \<bottom>)"
  using inv_binf invqka.inv_zero by fastforce

definition "do x = 1 \<sqinter> (x \<cdot> x\<^sup>\<circ>)"

definition "cd x = 1 \<sqinter> (x\<^sup>\<circ> \<cdot> x)"

lemma do_inv: "do (x\<^sup>\<circ>) = cd x"
proof-
  have "do (x\<^sup>\<circ>) = 1 \<sqinter> (x\<^sup>\<circ> \<cdot> (x\<^sup>\<circ>)\<^sup>\<circ>)"
    by (simp add: do_def)
  also have "\<dots> = 1 \<sqinter> (x\<^sup>\<circ> \<cdot> x)"
    by simp
  also have "\<dots> = cd x"
    by (simp add: cd_def)
  finally show ?thesis.
qed

lemma cd_inv: "cd (x\<^sup>\<circ>) = do x"
  by (simp add: cd_def do_def)

lemma do_le_top: "do x \<le> 1 \<sqinter> (x \<cdot> \<top>)"
  using do_def local.inf_mono local.order_refl local.top_greatest qdual.qd.mult_iso by presburger

lemma do_subid: "do x \<le> 1"
  by (simp add: do_def)

lemma do_bot [simp]: "do \<bottom> = \<bottom>"
  by (simp add: do_def)

lemma do_iso: "x \<le> y \<Longrightarrow> do x \<le> do y"
  using do_def local.eq_refl local.inf_mono local.inv_iso qdual.qd.dd.mult_iso by presburger

lemma do_subdist: "do x \<squnion> do y \<le> do (x \<squnion> y)"
proof-
  have "do x \<le> do (x \<squnion> y)" and  "do y \<le> do (x \<squnion> y)"
    by (simp_all add: do_iso)
  thus ?thesis
    by simp
qed

lemma inv_do [simp]: "(do x)\<^sup>\<circ> = do x"
  by (simp add: do_def)

lemma inv_cd [simp]: "(cd x)\<^sup>\<circ> = cd x"
  by (metis do_inv inv_do)

text \<open>The strong Gelfand property (name by Palmigiano and Re) is important for dioids and Kleene algebras.\<close>

lemma strong_gelfand: "x \<le> x \<cdot> x\<^sup>\<circ> \<cdot> x"
  nitpick (* counterexample *)
  oops

  text \<open>The modular law is a convenient axiom for relational quantales, in a setting where the underlying
lattice is not boolean.\<close>

lemma modular_law: "(x \<cdot> y) \<sqinter> z \<le> (x \<sqinter> (z \<cdot> y\<^sup>\<circ>)) \<cdot> y"
  nitpick (* counterexample *)
  oops

lemma dedekind: "(x \<cdot> y) \<sqinter> z \<le> (x \<sqinter> (z \<cdot> y\<^sup>\<circ>)) \<cdot> (y \<sqinter> (x\<^sup>\<circ> \<cdot> z))"
  nitpick (* counterexample *)
  oops

end

sublocale commutative_quantale \<subseteq> ciq: involutive_quantale id _ _ _ _ _ _ _ _ _ _
  by (unfold_locales, simp_all add: mult_commute)

class distributive_involutive_quantale = involutive_quantale + distributive_quantale

class boolean_involutive_quantale = involutive_quantale + boolean_quantale

class quantale_converse = involutive_quantale +
  assumes strong_gelfand: "x \<le> x \<cdot> x\<^sup>\<circ> \<cdot> x"

begin

lemma modular_law: "(x \<cdot> y) \<sqinter> z \<le> (x \<sqinter> (z \<cdot> y\<^sup>\<circ>)) \<cdot> y"
  nitpick (* counterexample *)
  oops

lemma peirce_1: "(x \<cdot> y) \<sqinter> z\<^sup>\<circ> = \<bottom> \<Longrightarrow> (y \<cdot> z) \<sqinter> x\<^sup>\<circ> = \<bottom>"
  nitpick (* counterexample *)
  oops

lemma dedekind: "(x \<cdot> y) \<sqinter> z \<le> (x \<sqinter> (z \<cdot> y\<^sup>\<circ>)) \<cdot> (y \<sqinter> (x\<^sup>\<circ> \<cdot> z))"
  nitpick (* counterexample *)
  oops

lemma do_gelfand [simp]: "do x \<cdot> do x \<cdot> do x = do x"
  apply (rule order.antisym)
   apply (metis local.do_def local.inf.cobounded1 local.mult_1_right qdual.qd.mult_iso qdual.qd.mult_isor)
  by (metis local.inv_do local.strong_gelfand)

lemma cd_gelfand [simp]: "cd x \<cdot> cd x \<cdot> cd x = cd x"
  by (metis do_gelfand local.do_inv)

lemma do_idem [simp]: "do x \<cdot> do x  = do x"
proof (rule order.antisym)
  show a: "do x \<cdot> do x \<le> do x"
    using local.do_subid qdual.qd.mult_isor by fastforce
  have "do x = do x \<cdot> do x \<cdot> do x"
    by simp
  thus "do x \<le> do x \<cdot> do x"
    by (metis a qdual.qd.mult_isol)
qed

lemma cd_idem: "cd x \<cdot> cd x  = cd x"
  by (metis do_idem local.do_inv)

lemma dodo [simp]: "do (do x) = do x"
proof-
  have "do (do x) = 1 \<sqinter> (do x \<cdot> do x)"
    using local.do_def local.inv_do by force
  also have "\<dots> = 1 \<sqinter> do x"
    by simp
  also have "\<dots> = do x"
    by (simp add: local.do_def)
  finally show ?thesis.
qed

lemma cdcd: "cd (cd x) = cd x"
  using cd_idem local.cd_def local.inv_cd by force

lemma docd_compat [simp]: "do (cd x) = cd x"
proof-
  have "do (cd x) = do (do (x\<^sup>\<circ>))"
    by (simp add: local.do_inv)
  also have "\<dots> = do (x\<^sup>\<circ>)"
    by simp
  also have "\<dots> = cd x"
    by (simp add: local.do_inv)
  finally show ?thesis.
qed

lemma cddo_compat [simp]: "cd (do x) = do x"
  by (metis docd_compat local.cd_inv local.inv_do)

lemma "do x = 1 \<sqinter> (x \<cdot> \<top>)"
  nitpick
  oops

end

sublocale quantale_converse \<subseteq> convqka: kleene_algebra_converse invol "1" "(\<cdot>)" "(\<squnion>)" "\<bottom>" "(\<le>)" "(<)"  qstar
  by (unfold_locales, simp add: local.strong_gelfand)

class dedekind_quantale = involutive_quantale +
  assumes modular_law: "(x \<cdot> y) \<sqinter> z \<le> (x \<sqinter> (z \<cdot> y\<^sup>\<circ>)) \<cdot> y"

subsection \<open>Dedekind quantales\<close>

sublocale dedekind_quantale \<subseteq> convdqka: kleene_algebra_converse invol "1" "(\<cdot>)" "(\<squnion>)" "\<bottom>" "(\<le>)" "(<)" qstar
  by (unfold_locales, metis local.inf.absorb2 local.le_top local.modular_law local.top_greatest)

context dedekind_quantale
begin

subclass quantale_converse
  apply unfold_locales
  by (simp add: local.convdqka.strong_gelfand)

lemma modular_2 [simp]: "((x \<sqinter> (z \<cdot> y\<^sup>\<circ>)) \<cdot> y) \<sqinter> z = (x \<cdot> y) \<sqinter> z"

  by (meson local.inf.cobounded1 local.inf_le2 local.inf_mono local.le_infI local.modular_law local.order_eq_iff qdual.qd.mult_iso)

lemma modular_1 [simp]: "(x \<cdot> (y \<sqinter> (x\<^sup>\<circ> \<cdot> z))) \<sqinter> z = (x \<cdot> y) \<sqinter> z"
  by (metis local.inv_binf local.inv_contrav local.inv_invol modular_2)

lemma dedekind: "(x \<cdot> y) \<sqinter> z \<le> (x \<sqinter> (z \<cdot> y\<^sup>\<circ>)) \<cdot> (y \<sqinter> (x\<^sup>\<circ> \<cdot> z))"
  by (smt (verit, ccfv_threshold) local.inf_commute local.inv_binf local.inv_contrav local.inv_invol local.modular_law modular_1)

lemma modular3: "(x \<cdot> y) \<sqinter> z \<le> x \<cdot> (y \<sqinter> (x\<^sup>\<circ> \<cdot> z))"
  by (metis local.inf.cobounded1 modular_1)

lemma peirce: "((x \<cdot> y) \<sqinter> z\<^sup>\<circ> = \<bottom>) = ((y \<cdot> z) \<sqinter> x\<^sup>\<circ> = \<bottom>)"
  by (metis local.bot_annil local.inf.commute local.inf_bot_right local.inv_conjugate local.inv_contrav modular_2)

lemma schroeder_1: "((x \<cdot> y) \<sqinter> z = \<bottom>) = (y \<sqinter> (x\<^sup>\<circ> \<cdot> z) = \<bottom>)"
  by (metis local.inf.commute local.inv_conjugate local.inv_contrav local.inv_invol peirce)

lemma schroeder_2: "((x \<cdot> y) \<sqinter> z = \<bottom>) = (x \<sqinter> (z \<cdot> y\<^sup>\<circ>) = \<bottom>)"
  by (metis local.bot_annil local.bot_unique local.inf.commute local.inv_invol local.modular_law)

lemma lla_top_aux: "p \<le> 1 \<Longrightarrow> ((x \<le> p \<cdot> x) = (x \<le> p \<cdot> \<top>))"
proof
  assume h: "p \<le> 1"
  and h1: "x \<le> p \<cdot> x"
  thus "x \<le> p \<cdot> \<top>"
    using local.order_trans local.top_greatest qdual.qd.mult_isor by blast
next
  assume h: "p \<le> 1"
  and "x \<le> p \<cdot> \<top>"
  hence "x = (p \<cdot> \<top>) \<sqinter> x"
    using local.inf.absorb_iff2 by auto
  also have "\<dots> \<le> p \<cdot> (\<top> \<sqinter> (p\<^sup>\<circ> \<cdot> x))"
    using modular3 by blast
  also have "\<dots> = p \<cdot> p \<cdot> x"
    by (simp add: h local.convdqka.subid_conv mult_assoc)
  finally show "x \<le> p \<cdot> x"
    by (metis h local.dual_order.trans local.mult_1_left qdual.qd.mult_isol)
qed

lemma lla: "p \<le> 1 \<Longrightarrow> ((do x \<le> p) = (x \<le> p \<cdot> \<top>))"
  apply standard
  apply (smt (verit) lla_top_aux local.do_def local.inf.assoc local.inf.cobounded2 local.inf.commute local.inf.idem local.inf.orderE modular_2 qdual.qd.oner)
proof -
  assume a1: "x \<le> p \<cdot> \<top>"
  assume a2: "p \<le> 1"
  have f3: "x \<cdot> \<top> \<le> p \<cdot> \<top> \<cdot> \<top>"
    using a1 qdual.qd.dd.mult_iso by auto
  have f4: "p \<cdot> do x \<le> p"
    by (metis (full_types) local.do_le_top local.inf.bounded_iff local.mult.monoid_axioms local.order.partial_preordering_axioms monoid.right_neutral partial_preordering.refl qdual.qd.dd.mult_iso)
  have "x \<cdot> \<top> \<le> p \<cdot> \<top>"
    using f3 by (simp add: local.mult.semigroup_axioms semigroup.assoc)
  then show "do x \<le> p"
    using f4 a2 lla_top_aux local.do_le_top local.inf.bounded_iff local.order_trans by blast
qed

lemma do_top: "do x = 1 \<sqinter> (x \<cdot> \<top>)"
proof-
  have "1 \<sqinter> (x \<cdot> \<top>) = 1 \<sqinter> (x \<cdot> (\<top> \<sqinter> x\<^sup>\<circ> \<cdot> 1))"
    by (metis local.inf.commute local.inf_top.left_neutral modular_1)
  also have "\<dots> = do x"
    by (simp add: local.do_def)
  finally show ?thesis..
qed

lemma do_absorp: "x \<le> do x \<cdot> x"
proof-
  have "x = x \<sqinter> (x \<cdot> 1)"
    by simp
  also have "\<dots> \<le> (1 \<sqinter> (x \<cdot> x\<^sup>\<circ>)) \<cdot> x"
    using local.inf.absorb_iff2 modular_2 by force
  also have "\<dots> = do x \<cdot> x"
    by (simp add: local.do_def)
  finally show ?thesis.
qed

lemma do_absorp_eq [simp]: "do x \<cdot> x = x"
  by (metis do_absorp do_subid local.mult_1_left local.order.antisym qdual.qd.mult_isol)

lemma do_top2: "x \<cdot> \<top> = do x \<cdot> \<top>"
proof (rule order.antisym)
  have "x \<cdot> \<top> = do x \<cdot> x \<cdot> \<top>"
    by simp
  also have "\<dots> \<le> do x \<cdot> \<top> \<cdot> \<top>"
    using local.order_refl local.top_greatest qdual.qd.mult_iso by presburger
  also have "\<dots> = do x \<cdot> \<top>"
    by (simp add: local.mult.semigroup_axioms semigroup.assoc)
  finally show "x \<cdot> \<top> \<le> do x \<cdot> \<top>".
  have "do x \<cdot> \<top> = (1 \<sqinter> (x \<cdot> \<top>)) \<cdot> \<top>"
    by (simp add: do_top)
  also have "\<dots> \<le> (1 \<cdot> \<top>) \<sqinter> (x \<cdot> \<top> \<cdot> \<top>)"
    using qdual.qd.mult_isol by auto
  also have "\<dots> = x \<cdot> \<top>"
    by (simp add: mult_assoc)
  finally show "do x \<cdot> \<top> \<le> x \<cdot> \<top>".
qed

lemma do_local [simp]: "do (x \<cdot> do y) = do (x \<cdot> y)"
proof-
  have "do (x \<cdot> do y) = 1 \<sqinter> (x \<cdot> do y \<cdot> \<top>)"
    using do_top by force
  also have "\<dots> = 1 \<sqinter> (x \<cdot> y \<cdot> \<top>)"
    by (metis do_top2 local.qdual.mult_assoc)
  also have "\<dots> = do (x \<cdot> y)"
    by (simp add: do_top)
  finally show ?thesis
    by force
qed

lemma do_inf: "do (x \<sqinter> y) = 1 \<sqinter> (y \<cdot> x\<^sup>\<circ>)"
  by (smt (z3) do_absorp_eq invqka.inv_one local.do_def local.inf_commute local.inv_binf local.inv_contrav local.inv_invol local.mult_1_right modular_1 modular_2 mult_assoc)

lemma "do (x \<squnion> y) \<le> do x \<squnion> do y"
  unfolding do_top
  nitpick (* no proof no counterexample *)
  oops

lemma
  fixes f::"'a \<Rightarrow> 'a" and g::"'a \<Rightarrow> 'a"
  assumes f_absorb: "\<forall>x. x \<le> f x \<cdot> x"
  and f_local: "\<forall>x y. f (x \<cdot> f y) = f (x \<cdot> y)"
  and f_add: "\<forall>x y. f (x \<squnion> y) = f x \<squnion> f y"
  and f_subid: "\<forall>x. f x \<le> \<top>"
  and f_zero: "f \<bottom> = \<bottom>"
  and g_absorb: "\<forall>x. x \<le> g x \<cdot> x"
  and g_local: "\<forall>x y. g (x \<cdot> g y) = g (x \<cdot> y)"
  and g_add: "\<forall>x y. g (x \<squnion> y) = g x \<squnion> g y"
  and g_subid: "\<forall>x. g x \<le> \<top>"
  and g_zero: "g \<bottom> = \<bottom>"
shows "f = g"
  nitpick[show_all]
  oops

end

class distributive_dedekind_quantale = distributive_quantale + dedekind_quantale

begin

text \<open>In distributive modular quantales we can derive all domain axioms.\<close>

lemma do_sup [simp]: "do (x \<squnion> y) = do x \<squnion> do y"
proof-
  have "do (x \<squnion> y) = 1 \<sqinter> ((x \<squnion> y) \<cdot> \<top>)"
    by (simp add: local.do_top)
  also have "\<dots> = 1 \<sqinter> (x \<cdot> \<top> \<squnion> y \<cdot> \<top>)"
    by (simp add: qdual.qd.distl)
  also have "\<dots> = (1 \<sqinter> (x \<cdot> \<top>)) \<squnion> (1 \<sqinter> (y \<cdot> \<top>))"
    by (simp add: local.inf_sup_distrib1)
  also have "\<dots> = do x \<squnion> do y"
    by (simp add: local.do_top)
  finally show ?thesis.
qed

lemma
  fixes f::"'a \<Rightarrow> 'a" and g::"'a \<Rightarrow> 'a"
  assumes f_absorb: "\<forall>x. x \<le> f x \<cdot> x"
  and f_local: "\<forall>x y. f (x \<cdot> f y) = f (x \<cdot> y)"
  and f_add: "\<forall>x y. f (x \<squnion> y) = f x \<squnion> f y"
  and f_subid: "\<forall>x. f x \<le> \<top>"
  and f_zero: "f \<bottom> = \<bottom>"
  and g_absorb: "\<forall>x. x \<le> g x \<cdot> x"
  and g_local: "\<forall>x y. g (x \<cdot> g y) = g (x \<cdot> y)"
  and g_add: "\<forall>x y. g (x \<squnion> y) = g x \<squnion> g y"
  and g_subid: "\<forall>x. g x \<le> \<top>"
  and g_zero: "g \<bottom> = \<bottom>"
shows "f = g"
  nitpick[show_all]
  oops

end

sublocale distributive_dedekind_quantale \<subseteq> modal_kleene_algebra "1" "(\<cdot>)" "(\<squnion>)" "\<bottom>" "(\<le>)" "(<)" qstar cd do
  apply unfold_locales
             apply (simp add: local.cd_def local.inf.absorb_iff2)
            apply (metis local.do_inv local.do_local local.inv_contrav local.inv_do)
           apply (metis local.do_inv local.do_sup local.inv_binsup)
          apply (simp add: local.cd_def)+
      apply (simp add: local.do_top local.inf_sup_distrib1 qdual.qd.distl)
  by (simp_all add: local.do_subid)

class boolean_dedekind_quantale = boolean_quantale + dedekind_quantale

begin

lemma inv_neg: "(-x)\<^sup>\<circ> = -(x\<^sup>\<circ>)"
  by (metis invqka.inv_sup invqka.inv_zero local.compl_unique local.inf_compl_bot local.inv_binf local.inv_top local.sup_compl_top)

lemma residuation: "x\<^sup>\<circ> \<cdot> -(x \<cdot> y) \<le> -y"
  using local.compl_le_swap1 local.inf_compl_bot local.inf_shunt local.schroeder_1 by blast

end

lemma (in involutive_quantale) dedekind_modular:
  assumes "(x \<cdot> y) \<sqinter> z \<le> (x \<sqinter> (z \<cdot> y\<^sup>\<circ>)) \<cdot> (y \<sqinter> (x\<^sup>\<circ> \<cdot> z))"
  shows "(x \<cdot> y) \<sqinter> z \<le> (x \<sqinter> (z \<cdot> y\<^sup>\<circ>)) \<cdot> y"
  using assms local.inf_le1 local.order_trans qdual.qd.mult_isor by blast

lemma (in distributive_involutive_quantale) schroeder_modular:
  assumes "\<forall>x y z. ((x \<cdot> y) \<sqinter> z = \<bottom>) = (y \<sqinter> (x\<^sup>\<circ> \<cdot> z) = \<bottom>)"
  and "\<forall>x y z. ((x \<cdot> y) \<sqinter> z = \<bottom>) = (x \<sqinter> (z \<cdot> y\<^sup>\<circ>) = \<bottom>)"
  and "((x \<cdot> y) \<sqinter> z\<^sup>\<circ> = \<bottom>) = ((y \<cdot> z) \<sqinter> x\<^sup>\<circ> = \<bottom>)"
shows "\<forall>x y z. (x \<cdot> y) \<sqinter> z \<le> (x \<sqinter> (z \<cdot> y\<^sup>\<circ>)) \<cdot> y"
  nitpick (* counterexample *)
  oops

lemma (in involutive_quantale)
  assumes "\<forall>x y z w. (y \<sqinter> (z \<cdot> x\<^sup>\<circ>) \<le> w \<longrightarrow> (y \<cdot> x) \<sqinter> z \<le> w \<cdot> x)"
  shows "\<forall>x y z. (x \<cdot> y) \<sqinter> z \<le> (x \<sqinter> (z \<cdot> y\<^sup>\<circ>)) \<cdot> y"
  using assms by blast

lemma (in involutive_quantale)
  assumes "\<forall>x y z. (x \<cdot> y) \<sqinter> z \<le> (x \<sqinter> (z \<cdot> y\<^sup>\<circ>)) \<cdot> y"
  shows "\<forall>w x y z.  (y \<sqinter> (z \<cdot> x\<^sup>\<circ>) \<le> w \<longrightarrow> (y \<cdot> x) \<sqinter> z \<le> w \<cdot> x)"
  using assms local.order_trans qdual.qd.mult_isol by blast

lemma (in boolean_involutive_quantale) res_peirce:
  assumes "\<forall>x y. x\<^sup>\<circ> \<cdot> -(x \<cdot> y) \<le> -y"
  shows  "((x \<cdot> y) \<sqinter> z\<^sup>\<circ> = \<bottom>) = ((y \<cdot> z) \<sqinter> x\<^sup>\<circ> = \<bottom>)"
proof
  assume "(x \<cdot> y) \<sqinter> z\<^sup>\<circ> = \<bottom>"
  hence "z\<^sup>\<circ> \<le> -(x \<cdot> y)"
    by (simp add: local.inf.commute local.inf_shunt)
  thus "(y \<cdot> z) \<sqinter> x\<^sup>\<circ> = \<bottom>"
    by (metis assms local.dual_order.trans local.inf_shunt local.inv_conjugate local.inv_contrav local.inv_invol qdual.qd.mult_isor)
next
  assume "(y \<cdot> z) \<sqinter> x\<^sup>\<circ> = \<bottom>"
  hence "x\<^sup>\<circ> \<le> -(y \<cdot> z)"
    using local.compl_le_swap1 local.inf_shunt by blast
  thus "(x \<cdot> y) \<sqinter> z\<^sup>\<circ> = \<bottom>"
    by (smt (verit, ccfv_SIG) assms local.inf_shunt local.inv_conjugate local.inv_contrav local.le_sup_iff local.sup_absorb2 qdual.qd.distr)
qed

lemma (in boolean_involutive_quantale) res_schroeder1:
  assumes "\<forall>x y. x\<^sup>\<circ> \<cdot> -(x \<cdot> y) \<le> -y"
  shows "((x \<cdot> y) \<sqinter> z = \<bottom>) = (y \<sqinter> (x\<^sup>\<circ> \<cdot> z) = \<bottom>)"
proof
  assume h: "(x \<cdot> y) \<sqinter> z = \<bottom>"
  hence "z \<le> -(x \<cdot> y)"
    by (simp add: local.inf.commute local.inf_shunt)
  thus "y \<sqinter> (x\<^sup>\<circ> \<cdot> z) = \<bottom>"
    by (meson assms local.compl_le_swap1 local.inf_shunt local.order_trans qdual.qd.mult_isor)
next
  assume "y \<sqinter> (x\<^sup>\<circ> \<cdot> z) = \<bottom>"
  hence "y \<le> -(x\<^sup>\<circ> \<cdot> z)"
    by (simp add: local.inf_shunt)
  thus "(x \<cdot> y) \<sqinter> z = \<bottom>"
    by (metis assms local.inf_shunt local.inv_invol local.order_trans qdual.qd.mult_isor)
qed

lemma (in boolean_involutive_quantale) res_schroeder2:
  assumes "\<forall>x y. x\<^sup>\<circ> \<cdot> -(x \<cdot> y) \<le> -y"
  shows "((x \<cdot> y) \<sqinter> z = \<bottom>) = (x \<sqinter> (z \<cdot> y\<^sup>\<circ>) = \<bottom>)"
  by (metis assms local.inv_invol local.res_peirce local.res_schroeder1)

lemma (in boolean_involutive_quantale) res_mod:
  assumes  "\<forall>x y. x\<^sup>\<circ> \<cdot> -(x \<cdot> y) \<le> -y"
  shows "(x \<cdot> y) \<sqinter> z \<le> (x \<sqinter> (z \<cdot> y\<^sup>\<circ>)) \<cdot> y"
proof-
  have "(x \<cdot> y) \<sqinter> z = ((x \<sqinter> ((z \<cdot> y\<^sup>\<circ>) \<squnion> -(z \<cdot> y\<^sup>\<circ>))) \<cdot> y) \<sqinter> z"
    by simp
  also have "\<dots> = (((x \<sqinter> (z \<cdot> y\<^sup>\<circ>)) \<cdot> y) \<sqinter> z) \<squnion> (((x \<sqinter> -(z \<cdot> y\<^sup>\<circ>)) \<cdot> y) \<sqinter> z)"
    using local.inf_sup_distrib1 local.inf_sup_distrib2 qdual.qd.distl by presburger
  also have "\<dots> \<le> ((x \<sqinter> (z \<cdot> y\<^sup>\<circ>)) \<cdot> y) \<squnion> ((x \<cdot> y) \<sqinter> (-(z \<cdot> y\<^sup>\<circ>)) \<cdot> y \<sqinter> z)"
    by (metis assms local.inf.cobounded1 local.inf.commute local.inf_compl_bot_right local.res_schroeder2 local.sup_bot_right)
  also have "\<dots> \<le> ((x \<sqinter> (z \<cdot> y\<^sup>\<circ>)) \<cdot> y) \<squnion> ((x \<cdot> y) \<sqinter> -z  \<sqinter> z)"
    by (metis assms local.inf.commute local.inf_compl_bot_right local.res_schroeder2 local.sup.cobounded1 local.sup_bot_right)
  also have "\<dots> \<le> ((x \<sqinter> (z \<cdot> y\<^sup>\<circ>)) \<cdot> y)"
    by (simp add: local.inf.commute)
  finally show ?thesis.
qed

class involutive_modal_quantale = modal_quantale + involutive_quantale

sublocale involutive_modal_quantale \<subseteq> invmqmka: involutive_modal_kleene_algebra "1" "(\<cdot>)" "(\<squnion>)" "\<bottom>" "(\<le>)" "(<)" qstar invol cod dom..

context involutive_modal_quantale
begin

lemma "dom x \<le> x \<cdot> x\<^sup>\<circ>"
  nitpick (* 3-element counterexample *)
  oops

lemma "x \<le> x \<cdot> x\<^sup>\<circ> \<cdot> x \<Longrightarrow> dom x \<le> x \<cdot> x\<^sup>\<circ>"
  nitpick (* 3-element counterexample *)
  oops

lemma "dom (x\<^sup>\<circ>) = cod x"
  nitpick (* 4-element counterexample *)
  oops

lemma "dom x \<le> do x"
  nitpick
  oops

lemma do_approx_dom: "do x \<le> dom x"
proof -
  have "do x = dom (do x) \<cdot> do x"
    by simp
  also have "\<dots> \<le> dom (1 \<sqinter> (x \<cdot> x\<^sup>\<circ>))"
    by (metis local.do_def local.inf.cobounded1 local.mult_1_right qdual.qd.mult_isor)
  also have "\<dots> \<le> dom 1 \<sqinter> dom (x \<cdot>  x\<^sup>\<circ>)"
    using local.dom_meet_sub by presburger
  also have "\<dots> \<le> dom (x \<cdot> dom (x\<^sup>\<circ>))"
    by simp
  also have "\<dots> \<le> dom x"
    using local.dom_meet local.dqmka.d_export_var local.inf.absorb_iff2 by presburger
  finally show ?thesis.
qed

end

class modal_quantale_converse = involutive_modal_quantale + quantale_converse

sublocale modal_quantale_converse \<subseteq> invmqmka: modal_kleene_algebra_converse "1" "(\<cdot>)" "(\<squnion>)" "\<bottom>" "(\<le>)" "(<)" qstar invol cod dom
  by (unfold_locales, simp add: local.strong_gelfand)

class modal_quantale_strong_converse = involutive_modal_quantale +
  assumes weak_dom_def: "dom x \<le> x \<cdot> x\<^sup>\<circ>"
  and weak_cod_def: "cod x \<le> x\<^sup>\<circ> \<cdot> x"

sublocale modal_quantale_strong_converse \<subseteq> invmqmka: modal_kleene_algebra_strong_converse "1" "(\<cdot>)" "(\<squnion>)" "\<bottom>" "(\<le>)" "(<)" qstar invol cod dom
  by (unfold_locales, simp_all add: local.weak_dom_def local.weak_cod_def)

context modal_quantale_strong_converse
begin

lemma "(x \<cdot> y) \<sqinter> z \<le> (x \<sqinter> (z \<cdot> y\<^sup>\<circ>)) \<cdot> y"
  nitpick (* 5-element counterexample *)
  oops

lemma dom_def: "dom x = 1 \<sqinter> (x \<cdot> x\<^sup>\<circ>)"
  apply (rule order.antisym)
  apply (simp add: local.dom_subid local.weak_dom_def)
  by (smt (verit, best) local.dom_subid local.dqmka.d_absorb_eq local.dqmka.d_iso local.dual_order.trans local.inf.cobounded1 local.inf.cobounded2 local.mqs.msrdual.cod_local local.mult_1_right qdual.qd.mult_isor)

lemma cod_def: "cod x = 1 \<sqinter> (x\<^sup>\<circ> \<cdot> x)"
  by (metis invqka.inv_one local.cd_compat local.coddual.dqmka.d_absorb_eq local.coddual.dqmka.d_export_var local.dc_compat local.dom_def local.dqmka.d_absorb_eq local.dqmka.d_export local.inv_binf local.inv_contrav local.inv_invol)

lemma "do x = dom x"
  by (simp add: local.do_def local.dom_def)

end

class dedekind_modal_distributive_quantale = involutive_modal_quantale + dedekind_quantale + distributive_quantale

begin

lemma "dom x = do x"
  nitpick (* 3-element counterexample *)
  oops

end

class dedekind_modal_boolean_quantale = involutive_modal_quantale + dedekind_quantale + boolean_quantale

begin

lemma subid_idem: "p \<le> 1 \<Longrightarrow> p \<cdot> p = p"
  by (metis (full_types) local.convdqka.subid_conv local.do_absorp local.do_def local.dual_order.antisym local.eq_refl local.inf_absorb2 local.mult_1_right qdual.qd.dd.mult_iso)

lemma subid_comm: "p \<le> 1 \<Longrightarrow> q \<le> 1 \<Longrightarrow> p \<cdot> q = q \<cdot> p"
  by (smt (verit, ccfv_SIG) local.dual_order.antisym local.dual_order.trans local.mult_1_left local.mult_1_right local.qdual.mult_assoc qdual.qd.mult_isol qdual.qd.mult_isor subid_idem)

lemma subid_meet_comp: "p \<le> 1 \<Longrightarrow> q \<le> 1 \<Longrightarrow> p \<sqinter> q = p \<cdot> q"
  by (smt (verit, ccfv_SIG) local.inf.absorb2 local.inf.assoc local.inf.cobounded1 local.inf.cobounded2 local.inf.orderE local.mult_1_right qdual.qd.mult_isor subid_comm subid_idem)

lemma subid_dom: "p \<le> 1 \<Longrightarrow> dom p = p"
proof-
  assume h: "p \<le> 1"
  have a: "p \<squnion> (1 \<sqinter> -p) = 1"
    using h local.sup.absorb_iff2 local.sup_inf_distrib1 by auto
  have "(1 \<sqinter> -p) \<sqinter> p = \<bottom>"
    by (simp add: local.inf.commute)
  thus ?thesis
    by (smt (verit, best) a h local.dom_subid local.dom_zero local.dqmka.d_absorb_eq local.dqmka.d_id local.dqmka.d_iso local.inf.absorb1 local.inf_le1 local.mqs.msrdual.cod_local qdual.qd.distr subid_comm subid_meet_comp)
qed

lemma do_prop: "(do x \<le> do y) = (x \<le> do y \<cdot> \<top>)"
  by (metis local.do_absorp_eq local.do_top local.do_top2 local.inf_mono local.order_refl local.top_greatest local.top_top mult_assoc qdual.qd.mult_iso)

lemma "(do x \<le> do y) = (x \<le> do y \<cdot> x)"
  by (smt (verit, del_insts) do_prop local.do_absorp_eq local.eq_refl local.inf.absorb2 local.inf.coboundedI1 local.top_greatest qdual.qd.mult_iso)

lemma lla_subid: "p \<le> 1 \<Longrightarrow> ((dom x \<le> p) = (x \<le> p \<cdot> x))"
  by (metis local.dqmka.lla subid_dom)

lemma dom_do: "dom x = do x"
proof-
  have "x \<le> do x \<cdot> x"
    by simp
  hence "dom x \<le> do x"
    using lla_subid local.do_subid by auto
  thus ?thesis
    by (simp add: local.antisym_conv local.do_approx_dom)
qed

end

end