(*  Title:      HOL/Old_Number_Theory/Quadratic_Reciprocity.thy
    Authors:    Jeremy Avigad, David Gray, and Adam Kramer
*)

section {* The law of Quadratic reciprocity *}

theory Quadratic_Reciprocity
imports Gauss
begin

text {*
  Lemmas leading up to the proof of theorem 3.3 in Niven and
  Zuckerman's presentation.
*}

context GAUSS
begin

lemma QRLemma1: "a * setsum id A =
  p * setsum (%x. ((x * a) div p)) A + setsum id D + setsum id E"
proof -
  from finite_A have "a * setsum id A = setsum (%x. a * x) A"
    by (auto simp add: setsum_const_mult id_def)
  also have "setsum (%x. a * x) = setsum (%x. x * a)"
    by (auto simp add: mult.commute)
  also have "setsum (%x. x * a) A = setsum id B"
    by (simp add: B_def setsum.reindex [OF inj_on_xa_A])
  also have "... = setsum (%x. p * (x div p) + StandardRes p x) B"
    by (auto simp add: StandardRes_def zmod_zdiv_equality)
  also have "... = setsum (%x. p * (x div p)) B + setsum (StandardRes p) B"
    by (rule setsum.distrib)
  also have "setsum (StandardRes p) B = setsum id C"
    by (auto simp add: C_def setsum.reindex [OF SR_B_inj])
  also from C_eq have "... = setsum id (D \<union> E)"
    by auto
  also from finite_D finite_E have "... = setsum id D + setsum id E"
    by (rule setsum.union_disjoint) (auto simp add: D_def E_def)
  also have "setsum (%x. p * (x div p)) B =
      setsum ((%x. p * (x div p)) o (%x. (x * a))) A"
    by (auto simp add: B_def setsum.reindex inj_on_xa_A)
  also have "... = setsum (%x. p * ((x * a) div p)) A"
    by (auto simp add: o_def)
  also from finite_A have "setsum (%x. p * ((x * a) div p)) A =
    p * setsum (%x. ((x * a) div p)) A"
    by (auto simp add: setsum_const_mult)
  finally show ?thesis by arith
qed

lemma QRLemma2: "setsum id A = p * int (card E) - setsum id E +
  setsum id D"
proof -
  from F_Un_D_eq_A have "setsum id A = setsum id (D \<union> F)"
    by (simp add: Un_commute)
  also from F_D_disj finite_D finite_F
  have "... = setsum id D + setsum id F"
    by (auto simp add: Int_commute intro: setsum.union_disjoint)
  also from F_def have "F = (%x. (p - x)) ` E"
    by auto
  also from finite_E inj_on_pminusx_E have "setsum id ((%x. (p - x)) ` E) =
      setsum (%x. (p - x)) E"
    by (auto simp add: setsum.reindex)
  also from finite_E have "setsum (op - p) E = setsum (%x. p) E - setsum id E"
    by (auto simp add: setsum_subtractf id_def)
  also from finite_E have "setsum (%x. p) E = p * int(card E)"
    by (intro setsum_const)
  finally show ?thesis
    by arith
qed

lemma QRLemma3: "(a - 1) * setsum id A =
    p * (setsum (%x. ((x * a) div p)) A - int(card E)) + 2 * setsum id E"
proof -
  have "(a - 1) * setsum id A = a * setsum id A - setsum id A"
    by (auto simp add: left_diff_distrib)
  also note QRLemma1
  also from QRLemma2 have "p * (\<Sum>x \<in> A. x * a div p) + setsum id D +
     setsum id E - setsum id A =
      p * (\<Sum>x \<in> A. x * a div p) + setsum id D +
      setsum id E - (p * int (card E) - setsum id E + setsum id D)"
    by auto
  also have "... = p * (\<Sum>x \<in> A. x * a div p) -
      p * int (card E) + 2 * setsum id E"
    by arith
  finally show ?thesis
    by (auto simp only: right_diff_distrib)
qed

lemma QRLemma4: "a \<in> zOdd ==>
    (setsum (%x. ((x * a) div p)) A \<in> zEven) = (int(card E): zEven)"
proof -
  assume a_odd: "a \<in> zOdd"
  from QRLemma3 have a: "p * (setsum (%x. ((x * a) div p)) A - int(card E)) =
      (a - 1) * setsum id A - 2 * setsum id E"
    by arith
  from a_odd have "a - 1 \<in> zEven"
    by (rule odd_minus_one_even)
  hence "(a - 1) * setsum id A \<in> zEven"
    by (rule even_times_either)
  moreover have "2 * setsum id E \<in> zEven"
    by (auto simp add: zEven_def)
  ultimately have "(a - 1) * setsum id A - 2 * setsum id E \<in> zEven"
    by (rule even_minus_even)
  with a have "p * (setsum (%x. ((x * a) div p)) A - int(card E)): zEven"
    by simp
  hence "p \<in> zEven | (setsum (%x. ((x * a) div p)) A - int(card E)): zEven"
    by (rule EvenOdd.even_product)
  with p_odd have "(setsum (%x. ((x * a) div p)) A - int(card E)): zEven"
    by (auto simp add: odd_iff_not_even)
  thus ?thesis
    by (auto simp only: even_diff [symmetric])
qed

lemma QRLemma5: "a \<in> zOdd ==>
   (-1::int)^(card E) = (-1::int)^(nat(setsum (%x. ((x * a) div p)) A))"
proof -
  assume "a \<in> zOdd"
  from QRLemma4 [OF this] have
    "(int(card E): zEven) = (setsum (%x. ((x * a) div p)) A \<in> zEven)" ..
  moreover have "0 \<le> int(card E)"
    by auto
  moreover have "0 \<le> setsum (%x. ((x * a) div p)) A"
    proof (intro setsum_nonneg)
      show "\<forall>x \<in> A. 0 \<le> x * a div p"
      proof
        fix x
        assume "x \<in> A"
        then have "0 \<le> x"
          by (auto simp add: A_def)
        with a_nonzero have "0 \<le> x * a"
          by (auto simp add: zero_le_mult_iff)
        with p_g_2 show "0 \<le> x * a div p"
          by (auto simp add: pos_imp_zdiv_nonneg_iff)
      qed
    qed
  ultimately have "(-1::int)^nat((int (card E))) =
      (-1)^nat(((\<Sum>x \<in> A. x * a div p)))"
    by (intro neg_one_power_parity, auto)
  also have "nat (int(card E)) = card E"
    by auto
  finally show ?thesis .
qed

end

lemma MainQRLemma: "[| a \<in> zOdd; 0 < a; ~([a = 0] (mod p)); zprime p; 2 < p;
  A = {x. 0 < x & x \<le> (p - 1) div 2} |] ==>
  (Legendre a p) = (-1::int)^(nat(setsum (%x. ((x * a) div p)) A))"
  apply (subst GAUSS.gauss_lemma)
  apply (auto simp add: GAUSS_def)
  apply (subst GAUSS.QRLemma5)
  apply (auto simp add: GAUSS_def)
  apply (simp add: GAUSS.A_def [OF GAUSS.intro] GAUSS_def)
  done

subsection {* Stuff about S, S1 and S2 *}

locale QRTEMP =
  fixes p     :: "int"
  fixes q     :: "int"

  assumes p_prime: "zprime p"
  assumes p_g_2: "2 < p"
  assumes q_prime: "zprime q"
  assumes q_g_2: "2 < q"
  assumes p_neq_q:      "p \<noteq> q"
begin

definition P_set :: "int set"
  where "P_set = {x. 0 < x & x \<le> ((p - 1) div 2) }"

definition Q_set :: "int set"
  where "Q_set = {x. 0 < x & x \<le> ((q - 1) div 2) }"

definition S :: "(int * int) set"
  where "S = P_set <*> Q_set"

definition S1 :: "(int * int) set"
  where "S1 = { (x, y). (x, y):S & ((p * y) < (q * x)) }"

definition S2 :: "(int * int) set"
  where "S2 = { (x, y). (x, y):S & ((q * x) < (p * y)) }"

definition f1 :: "int => (int * int) set"
  where "f1 j = { (j1, y). (j1, y):S & j1 = j & (y \<le> (q * j) div p) }"

definition f2 :: "int => (int * int) set"
  where "f2 j = { (x, j1). (x, j1):S & j1 = j & (x \<le> (p * j) div q) }"

lemma p_fact: "0 < (p - 1) div 2"
proof -
  from p_g_2 have "2 \<le> p - 1" by arith
  then have "2 div 2 \<le> (p - 1) div 2" by (rule zdiv_mono1, auto)
  then show ?thesis by auto
qed

lemma q_fact: "0 < (q - 1) div 2"
proof -
  from q_g_2 have "2 \<le> q - 1" by arith
  then have "2 div 2 \<le> (q - 1) div 2" by (rule zdiv_mono1, auto)
  then show ?thesis by auto
qed

lemma pb_neq_qa:
  assumes "1 \<le> b" and "b \<le> (q - 1) div 2"
  shows "p * b \<noteq> q * a"
proof
  assume "p * b = q * a"
  then have "q dvd (p * b)" by (auto simp add: dvd_def)
  with q_prime p_g_2 have "q dvd p | q dvd b"
    by (auto simp add: zprime_zdvd_zmult)
  moreover have "~ (q dvd p)"
  proof
    assume "q dvd p"
    with p_prime have "q = 1 | q = p"
      apply (auto simp add: zprime_def QRTEMP_def)
      apply (drule_tac x = q and R = False in allE)
      apply (simp add: QRTEMP_def)
      apply (subgoal_tac "0 \<le> q", simp add: QRTEMP_def)
      apply (insert assms)
      apply (auto simp add: QRTEMP_def)
      done
    with q_g_2 p_neq_q show False by auto
  qed
  ultimately have "q dvd b" by auto
  then have "q \<le> b"
  proof -
    assume "q dvd b"
    moreover from assms have "0 < b" by auto
    ultimately show ?thesis using zdvd_bounds [of q b] by auto
  qed
  with assms have "q \<le> (q - 1) div 2" by auto
  then have "2 * q \<le> 2 * ((q - 1) div 2)" by arith
  then have "2 * q \<le> q - 1"
  proof -
    assume a: "2 * q \<le> 2 * ((q - 1) div 2)"
    with assms have "q \<in> zOdd" by (auto simp add: QRTEMP_def zprime_zOdd_eq_grt_2)
    with odd_minus_one_even have "(q - 1):zEven" by auto
    with even_div_2_prop2 have "(q - 1) = 2 * ((q - 1) div 2)" by auto
    with a show ?thesis by auto
  qed
  then have p1: "q \<le> -1" by arith
  with q_g_2 show False by auto
qed

lemma P_set_finite: "finite (P_set)"
  using p_fact by (auto simp add: P_set_def bdd_int_set_l_le_finite)

lemma Q_set_finite: "finite (Q_set)"
  using q_fact by (auto simp add: Q_set_def bdd_int_set_l_le_finite)

lemma S_finite: "finite S"
  by (auto simp add: S_def  P_set_finite Q_set_finite finite_cartesian_product)

lemma S1_finite: "finite S1"
proof -
  have "finite S" by (auto simp add: S_finite)
  moreover have "S1 \<subseteq> S" by (auto simp add: S1_def S_def)
  ultimately show ?thesis by (auto simp add: finite_subset)
qed

lemma S2_finite: "finite S2"
proof -
  have "finite S" by (auto simp add: S_finite)
  moreover have "S2 \<subseteq> S" by (auto simp add: S2_def S_def)
  ultimately show ?thesis by (auto simp add: finite_subset)
qed

lemma P_set_card: "(p - 1) div 2 = int (card (P_set))"
  using p_fact by (auto simp add: P_set_def card_bdd_int_set_l_le)

lemma Q_set_card: "(q - 1) div 2 = int (card (Q_set))"
  using q_fact by (auto simp add: Q_set_def card_bdd_int_set_l_le)

lemma S_card: "((p - 1) div 2) * ((q - 1) div 2) = int (card(S))"
  using P_set_card Q_set_card P_set_finite Q_set_finite
  by (auto simp add: S_def zmult_int)

lemma S1_Int_S2_prop: "S1 \<inter> S2 = {}"
  by (auto simp add: S1_def S2_def)

lemma S1_Union_S2_prop: "S = S1 \<union> S2"
  apply (auto simp add: S_def P_set_def Q_set_def S1_def S2_def)
proof -
  fix a and b
  assume "~ q * a < p * b" and b1: "0 < b" and b2: "b \<le> (q - 1) div 2"
  with less_linear have "(p * b < q * a) | (p * b = q * a)" by auto
  moreover from pb_neq_qa b1 b2 have "(p * b \<noteq> q * a)" by auto
  ultimately show "p * b < q * a" by auto
qed

lemma card_sum_S1_S2: "((p - 1) div 2) * ((q - 1) div 2) =
    int(card(S1)) + int(card(S2))"
proof -
  have "((p - 1) div 2) * ((q - 1) div 2) = int (card(S))"
    by (auto simp add: S_card)
  also have "... = int( card(S1) + card(S2))"
    apply (insert S1_finite S2_finite S1_Int_S2_prop S1_Union_S2_prop)
    apply (drule card_Un_disjoint, auto)
    done
  also have "... = int(card(S1)) + int(card(S2))" by auto
  finally show ?thesis .
qed

lemma aux1a:
  assumes "0 < a" and "a \<le> (p - 1) div 2"
    and "0 < b" and "b \<le> (q - 1) div 2"
  shows "(p * b < q * a) = (b \<le> q * a div p)"
proof -
  have "p * b < q * a ==> b \<le> q * a div p"
  proof -
    assume "p * b < q * a"
    then have "p * b \<le> q * a" by auto
    then have "(p * b) div p \<le> (q * a) div p"
      by (rule zdiv_mono1) (insert p_g_2, auto)
    then show "b \<le> (q * a) div p"
      apply (subgoal_tac "p \<noteq> 0")
      apply (frule div_mult_self1_is_id, force)
      apply (insert p_g_2, auto)
      done
  qed
  moreover have "b \<le> q * a div p ==> p * b < q * a"
  proof -
    assume "b \<le> q * a div p"
    then have "p * b \<le> p * ((q * a) div p)"
      using p_g_2 by (auto simp add: mult_le_cancel_left)
    also have "... \<le> q * a"
      by (rule zdiv_leq_prop) (insert p_g_2, auto)
    finally have "p * b \<le> q * a" .
    then have "p * b < q * a | p * b = q * a"
      by (simp only: order_le_imp_less_or_eq)
    moreover have "p * b \<noteq> q * a"
      by (rule pb_neq_qa) (insert assms, auto)
    ultimately show ?thesis by auto
  qed
  ultimately show ?thesis ..
qed

lemma aux1b:
  assumes "0 < a" and "a \<le> (p - 1) div 2"
    and "0 < b" and "b \<le> (q - 1) div 2"
  shows "(q * a < p * b) = (a \<le> p * b div q)"
proof -
  have "q * a < p * b ==> a \<le> p * b div q"
  proof -
    assume "q * a < p * b"
    then have "q * a \<le> p * b" by auto
    then have "(q * a) div q \<le> (p * b) div q"
      by (rule zdiv_mono1) (insert q_g_2, auto)
    then show "a \<le> (p * b) div q"
      apply (subgoal_tac "q \<noteq> 0")
      apply (frule div_mult_self1_is_id, force)
      apply (insert q_g_2, auto)
      done
  qed
  moreover have "a \<le> p * b div q ==> q * a < p * b"
  proof -
    assume "a \<le> p * b div q"
    then have "q * a \<le> q * ((p * b) div q)"
      using q_g_2 by (auto simp add: mult_le_cancel_left)
    also have "... \<le> p * b"
      by (rule zdiv_leq_prop) (insert q_g_2, auto)
    finally have "q * a \<le> p * b" .
    then have "q * a < p * b | q * a = p * b"
      by (simp only: order_le_imp_less_or_eq)
    moreover have "p * b \<noteq> q * a"
      by (rule  pb_neq_qa) (insert assms, auto)
    ultimately show ?thesis by auto
  qed
  ultimately show ?thesis ..
qed

lemma (in -) aux2:
  assumes "zprime p" and "zprime q" and "2 < p" and "2 < q"
  shows "(q * ((p - 1) div 2)) div p \<le> (q - 1) div 2"
proof-
  (* Set up what's even and odd *)
  from assms have "p \<in> zOdd & q \<in> zOdd"
    by (auto simp add:  zprime_zOdd_eq_grt_2)
  then have even1: "(p - 1):zEven & (q - 1):zEven"
    by (auto simp add: odd_minus_one_even)
  then have even2: "(2 * p):zEven & ((q - 1) * p):zEven"
    by (auto simp add: zEven_def)
  then have even3: "(((q - 1) * p) + (2 * p)):zEven"
    by (auto simp: EvenOdd.even_plus_even)
  (* using these prove it *)
  from assms have "q * (p - 1) < ((q - 1) * p) + (2 * p)"
    by (auto simp add: int_distrib)
  then have "((p - 1) * q) div 2 < (((q - 1) * p) + (2 * p)) div 2"
    apply (rule_tac x = "((p - 1) * q)" in even_div_2_l)
    by (auto simp add: even3, auto simp add: ac_simps)
  also have "((p - 1) * q) div 2 = q * ((p - 1) div 2)"
    by (auto simp add: even1 even_prod_div_2)
  also have "(((q - 1) * p) + (2 * p)) div 2 = (((q - 1) div 2) * p) + p"
    by (auto simp add: even1 even2 even_prod_div_2 even_sum_div_2)
  finally show ?thesis
    apply (rule_tac x = " q * ((p - 1) div 2)" and
                    y = "(q - 1) div 2" in div_prop2)
    using assms by auto
qed

lemma aux3a: "\<forall>j \<in> P_set. int (card (f1 j)) = (q * j) div p"
proof
  fix j
  assume j_fact: "j \<in> P_set"
  have "int (card (f1 j)) = int (card {y. y \<in> Q_set & y \<le> (q * j) div p})"
  proof -
    have "finite (f1 j)"
    proof -
      have "(f1 j) \<subseteq> S" by (auto simp add: f1_def)
      with S_finite show ?thesis by (auto simp add: finite_subset)
    qed
    moreover have "inj_on (%(x,y). y) (f1 j)"
      by (auto simp add: f1_def inj_on_def)
    ultimately have "card ((%(x,y). y) ` (f1 j)) = card  (f1 j)"
      by (auto simp add: f1_def card_image)
    moreover have "((%(x,y). y) ` (f1 j)) = {y. y \<in> Q_set & y \<le> (q * j) div p}"
      using j_fact by (auto simp add: f1_def S_def Q_set_def P_set_def image_def)
    ultimately show ?thesis by (auto simp add: f1_def)
  qed
  also have "... = int (card {y. 0 < y & y \<le> (q * j) div p})"
  proof -
    have "{y. y \<in> Q_set & y \<le> (q * j) div p} =
        {y. 0 < y & y \<le> (q * j) div p}"
      apply (auto simp add: Q_set_def)
    proof -
      fix x
      assume x: "0 < x" "x \<le> q * j div p"
      with j_fact P_set_def  have "j \<le> (p - 1) div 2" by auto
      with q_g_2 have "q * j \<le> q * ((p - 1) div 2)"
        by (auto simp add: mult_le_cancel_left)
      with p_g_2 have "q * j div p \<le> q * ((p - 1) div 2) div p"
        by (auto simp add: zdiv_mono1)
      also from QRTEMP_axioms j_fact P_set_def have "... \<le> (q - 1) div 2"
        apply simp
        apply (insert aux2)
        apply (simp add: QRTEMP_def)
        done
      finally show "x \<le> (q - 1) div 2" using x by auto
    qed
    then show ?thesis by auto
  qed
  also have "... = (q * j) div p"
  proof -
    from j_fact P_set_def have "0 \<le> j" by auto
    with q_g_2 have "q * 0 \<le> q * j" by (auto simp only: mult_left_mono)
    then have "0 \<le> q * j" by auto
    then have "0 div p \<le> (q * j) div p"
      apply (rule_tac a = 0 in zdiv_mono1)
      apply (insert p_g_2, auto)
      done
    also have "0 div p = 0" by auto
    finally show ?thesis by (auto simp add: card_bdd_int_set_l_le)
  qed
  finally show "int (card (f1 j)) = q * j div p" .
qed

lemma aux3b: "\<forall>j \<in> Q_set. int (card (f2 j)) = (p * j) div q"
proof
  fix j
  assume j_fact: "j \<in> Q_set"
  have "int (card (f2 j)) = int (card {y. y \<in> P_set & y \<le> (p * j) div q})"
  proof -
    have "finite (f2 j)"
    proof -
      have "(f2 j) \<subseteq> S" by (auto simp add: f2_def)
      with S_finite show ?thesis by (auto simp add: finite_subset)
    qed
    moreover have "inj_on (%(x,y). x) (f2 j)"
      by (auto simp add: f2_def inj_on_def)
    ultimately have "card ((%(x,y). x) ` (f2 j)) = card  (f2 j)"
      by (auto simp add: f2_def card_image)
    moreover have "((%(x,y). x) ` (f2 j)) = {y. y \<in> P_set & y \<le> (p * j) div q}"
      using j_fact by (auto simp add: f2_def S_def Q_set_def P_set_def image_def)
    ultimately show ?thesis by (auto simp add: f2_def)
  qed
  also have "... = int (card {y. 0 < y & y \<le> (p * j) div q})"
  proof -
    have "{y. y \<in> P_set & y \<le> (p * j) div q} =
        {y. 0 < y & y \<le> (p * j) div q}"
      apply (auto simp add: P_set_def)
    proof -
      fix x
      assume x: "0 < x" "x \<le> p * j div q"
      with j_fact Q_set_def  have "j \<le> (q - 1) div 2" by auto
      with p_g_2 have "p * j \<le> p * ((q - 1) div 2)"
        by (auto simp add: mult_le_cancel_left)
      with q_g_2 have "p * j div q \<le> p * ((q - 1) div 2) div q"
        by (auto simp add: zdiv_mono1)
      also from QRTEMP_axioms j_fact have "... \<le> (p - 1) div 2"
        by (auto simp add: aux2 QRTEMP_def)
      finally show "x \<le> (p - 1) div 2" using x by auto
      qed
    then show ?thesis by auto
  qed
  also have "... = (p * j) div q"
  proof -
    from j_fact Q_set_def have "0 \<le> j" by auto
    with p_g_2 have "p * 0 \<le> p * j" by (auto simp only: mult_left_mono)
    then have "0 \<le> p * j" by auto
    then have "0 div q \<le> (p * j) div q"
      apply (rule_tac a = 0 in zdiv_mono1)
      apply (insert q_g_2, auto)
      done
    also have "0 div q = 0" by auto
    finally show ?thesis by (auto simp add: card_bdd_int_set_l_le)
  qed
  finally show "int (card (f2 j)) = p * j div q" .
qed

lemma S1_card: "int (card(S1)) = setsum (%j. (q * j) div p) P_set"
proof -
  have "\<forall>x \<in> P_set. finite (f1 x)"
  proof
    fix x
    have "f1 x \<subseteq> S" by (auto simp add: f1_def)
    with S_finite show "finite (f1 x)" by (auto simp add: finite_subset)
  qed
  moreover have "(\<forall>x \<in> P_set. \<forall>y \<in> P_set. x \<noteq> y --> (f1 x) \<inter> (f1 y) = {})"
    by (auto simp add: f1_def)
  moreover note P_set_finite
  ultimately have "int(card (UNION P_set f1)) =
      setsum (%x. int(card (f1 x))) P_set"
    by(simp add:card_UN_disjoint int_setsum o_def)
  moreover have "S1 = UNION P_set f1"
    by (auto simp add: f1_def S_def S1_def S2_def P_set_def Q_set_def aux1a)
  ultimately have "int(card (S1)) = setsum (%j. int(card (f1 j))) P_set"
    by auto
  also have "... = setsum (%j. q * j div p) P_set"
    using aux3a by(fastforce intro: setsum.cong)
  finally show ?thesis .
qed

lemma S2_card: "int (card(S2)) = setsum (%j. (p * j) div q) Q_set"
proof -
  have "\<forall>x \<in> Q_set. finite (f2 x)"
  proof
    fix x
    have "f2 x \<subseteq> S" by (auto simp add: f2_def)
    with S_finite show "finite (f2 x)" by (auto simp add: finite_subset)
  qed
  moreover have "(\<forall>x \<in> Q_set. \<forall>y \<in> Q_set. x \<noteq> y -->
      (f2 x) \<inter> (f2 y) = {})"
    by (auto simp add: f2_def)
  moreover note Q_set_finite
  ultimately have "int(card (UNION Q_set f2)) =
      setsum (%x. int(card (f2 x))) Q_set"
    by(simp add:card_UN_disjoint int_setsum o_def)
  moreover have "S2 = UNION Q_set f2"
    by (auto simp add: f2_def S_def S1_def S2_def P_set_def Q_set_def aux1b)
  ultimately have "int(card (S2)) = setsum (%j. int(card (f2 j))) Q_set"
    by auto
  also have "... = setsum (%j. p * j div q) Q_set"
    using aux3b by(fastforce intro: setsum.cong)
  finally show ?thesis .
qed

lemma S1_carda: "int (card(S1)) =
    setsum (%j. (j * q) div p) P_set"
  by (auto simp add: S1_card ac_simps)

lemma S2_carda: "int (card(S2)) =
    setsum (%j. (j * p) div q) Q_set"
  by (auto simp add: S2_card ac_simps)

lemma pq_sum_prop: "(setsum (%j. (j * p) div q) Q_set) +
    (setsum (%j. (j * q) div p) P_set) = ((p - 1) div 2) * ((q - 1) div 2)"
proof -
  have "(setsum (%j. (j * p) div q) Q_set) +
      (setsum (%j. (j * q) div p) P_set) = int (card S2) + int (card S1)"
    by (auto simp add: S1_carda S2_carda)
  also have "... = int (card S1) + int (card S2)"
    by auto
  also have "... = ((p - 1) div 2) * ((q - 1) div 2)"
    by (auto simp add: card_sum_S1_S2)
  finally show ?thesis .
qed

lemma (in -) pq_prime_neq: "[| zprime p; zprime q; p \<noteq> q |] ==> (~[p = 0] (mod q))"
  apply (auto simp add: zcong_eq_zdvd_prop zprime_def)
  apply (drule_tac x = q in allE)
  apply (drule_tac x = p in allE)
  apply auto
  done

lemma QR_short: "(Legendre p q) * (Legendre q p) =
    (-1::int)^nat(((p - 1) div 2)*((q - 1) div 2))"
proof -
  from QRTEMP_axioms have "~([p = 0] (mod q))"
    by (auto simp add: pq_prime_neq QRTEMP_def)
  with QRTEMP_axioms Q_set_def have a1: "(Legendre p q) = (-1::int) ^
      nat(setsum (%x. ((x * p) div q)) Q_set)"
    apply (rule_tac p = q in  MainQRLemma)
    apply (auto simp add: zprime_zOdd_eq_grt_2 QRTEMP_def)
    done
  from QRTEMP_axioms have "~([q = 0] (mod p))"
    apply (rule_tac p = q and q = p in pq_prime_neq)
    apply (simp add: QRTEMP_def)+
    done
  with QRTEMP_axioms P_set_def have a2: "(Legendre q p) =
      (-1::int) ^ nat(setsum (%x. ((x * q) div p)) P_set)"
    apply (rule_tac p = p in  MainQRLemma)
    apply (auto simp add: zprime_zOdd_eq_grt_2 QRTEMP_def)
    done
  from a1 a2 have "(Legendre p q) * (Legendre q p) =
      (-1::int) ^ nat(setsum (%x. ((x * p) div q)) Q_set) *
        (-1::int) ^ nat(setsum (%x. ((x * q) div p)) P_set)"
    by auto
  also have "... = (-1::int) ^ (nat(setsum (%x. ((x * p) div q)) Q_set) +
                   nat(setsum (%x. ((x * q) div p)) P_set))"
    by (auto simp add: power_add)
  also have "nat(setsum (%x. ((x * p) div q)) Q_set) +
      nat(setsum (%x. ((x * q) div p)) P_set) =
        nat((setsum (%x. ((x * p) div q)) Q_set) +
          (setsum (%x. ((x * q) div p)) P_set))"
    apply (rule_tac z = "setsum (%x. ((x * p) div q)) Q_set" in
      nat_add_distrib [symmetric])
    apply (auto simp add: S1_carda [symmetric] S2_carda [symmetric])
    done
  also have "... = nat(((p - 1) div 2) * ((q - 1) div 2))"
    by (auto simp add: pq_sum_prop)
  finally show ?thesis .
qed

end

theorem Quadratic_Reciprocity:
     "[| p \<in> zOdd; zprime p; q \<in> zOdd; zprime q;
         p \<noteq> q |]
      ==> (Legendre p q) * (Legendre q p) =
          (-1::int)^nat(((p - 1) div 2)*((q - 1) div 2))"
  by (auto simp add: QRTEMP.QR_short zprime_zOdd_eq_grt_2 [symmetric]
                     QRTEMP_def)

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

section "Word Alignment"

theory Aligned
imports
  Word_Lib
  HOL_Lemmas
  More_Divides
begin

definition
  is_aligned :: "'a :: len word \<Rightarrow> nat \<Rightarrow> bool" where
  "is_aligned ptr n \<equiv> 2^n dvd unat ptr"

lemma is_aligned_mask: "(is_aligned w n) = (w && mask n = 0)"
  unfolding is_aligned_def by (rule and_mask_dvd_nat)

lemma is_aligned_to_bl:
  "is_aligned (w :: 'a :: len word) n = (True \<notin> set (drop (size w - n) (to_bl w)))"
  apply (simp add: is_aligned_mask eq_zero_set_bl)
  apply (clarsimp simp: in_set_conv_nth word_size)
  apply (simp add: to_bl_nth word_size cong: conj_cong)
  apply (simp add: diff_diff_less)
  apply safe
   apply (case_tac "n \<le> LENGTH('a)")
    prefer 2
    apply (rule_tac x=i in exI)
    apply clarsimp
   apply (subgoal_tac "\<exists>j < LENGTH('a). j < n \<and> LENGTH('a) - n + j = i")
    apply (erule exE)
    apply (rule_tac x=j in exI)
    apply clarsimp
   apply (thin_tac "w !! t" for t)
   apply (rule_tac x="i + n - LENGTH('a)" in exI)
   apply clarsimp
   apply arith
  apply (rule_tac x="LENGTH('a) - n + i" in exI)
  apply clarsimp
  apply arith
  done

lemma unat_power_lower [simp]:
  assumes nv: "n < LENGTH('a::len)"
  shows "unat ((2::'a::len word) ^ n) = 2 ^ n"
  by (simp add: assms nat_power_eq uint_2p_alt unat_def)

lemma power_overflow:
  "n \<ge> LENGTH('a) \<Longrightarrow> 2 ^ n = (0 :: 'a::len word)"
  by simp

lemma is_alignedI [intro?]:
  fixes x::"'a::len word"
  assumes xv: "x = 2 ^ n * k"
  shows   "is_aligned x n"
proof cases
  assume nv: "n < LENGTH('a)"
  show ?thesis
    unfolding is_aligned_def
  proof (rule dvdI [where k = "unat k mod 2 ^ (LENGTH('a) - n)"])
    from xv
    have "unat x = (unat (2::word32) ^ n * unat k) mod 2 ^ LENGTH('a)"
      using nv
      by (subst (asm) word_unat.Rep_inject [symmetric], simp,
          subst unat_word_ariths, simp)

    also have "\<dots> =  2 ^ n * (unat k mod 2 ^ (LENGTH('a) - n))" using nv
      by (simp add: mult_mod_right power_add [symmetric] add_diff_inverse)

    finally show "unat x = 2 ^ n * (unat k mod 2 ^ (LENGTH('a) - n))" .
  qed
next
  assume "\<not> n < LENGTH('a)"
  with xv
  show ?thesis by (simp add: not_less power_overflow is_aligned_def)
qed

lemma is_aligned_weaken:
  "\<lbrakk> is_aligned w x; x \<ge> y \<rbrakk> \<Longrightarrow> is_aligned w y"
  unfolding is_aligned_def
  by (erule dvd_trans [rotated]) (simp add: le_imp_power_dvd)

lemma nat_power_less_diff:
  assumes lt: "(2::nat) ^ n * q < 2 ^ m"
  shows "q < 2 ^ (m - n)"
  using lt
proof (induct n arbitrary: m)
  case 0
  then show ?case by simp
next
  case (Suc n)

  have ih: "\<And>m. 2 ^ n * q < 2 ^ m \<Longrightarrow> q < 2 ^ (m - n)"
    and prem: "2 ^ Suc n * q < 2 ^ m" by fact+

  show ?case
  proof (cases m)
    case 0
    then show ?thesis using Suc by simp
  next
    case (Suc m')
    then show ?thesis using prem
      by (simp add: ac_simps ih)
  qed
qed

lemma is_alignedE_pre:
  fixes w::"'a::len word"
  assumes aligned: "is_aligned w n"
  shows        rl: "\<exists>q. w = 2 ^ n * (of_nat q) \<and> q < 2 ^ (LENGTH('a) - n)"
proof -
  from aligned obtain q where wv: "unat w = 2 ^ n * q"
    unfolding is_aligned_def ..

  show ?thesis
  proof (rule exI, intro conjI)
    show "q < 2 ^ (LENGTH('a) - n)"
    proof (rule nat_power_less_diff)
      have "unat w < 2 ^ size w" unfolding word_size ..
      then have "unat w < 2 ^ LENGTH('a)" by simp
      with wv show "2 ^ n * q < 2 ^ LENGTH('a)" by simp
    qed

    have r: "of_nat (2 ^ n) = (2::word32) ^ n"
      by (induct n) simp+

    from wv have "of_nat (unat w) = of_nat (2 ^ n * q)" by simp
    then have "w = of_nat (2 ^ n * q)" by (subst word_unat.Rep_inverse [symmetric])
    then show "w = 2 ^ n * (of_nat q)" by (simp add: r)
  qed
qed

lemma is_alignedE:
  "\<lbrakk>is_aligned (w::'a::len word) n;
    \<And>q. \<lbrakk>w = 2 ^ n * (of_nat q); q < 2 ^ (LENGTH('a) - n)\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  by (auto dest: is_alignedE_pre)

lemma is_aligned_replicate:
  fixes w::"'a::len word"
  assumes aligned: "is_aligned w n"
  and          nv: "n \<le> LENGTH('a)"
  shows   "to_bl w = (take (LENGTH('a) - n) (to_bl w)) @ replicate n False"
proof -
  from nv have rl: "\<And>q. q < 2 ^ (LENGTH('a) - n) \<Longrightarrow>
      to_bl (2 ^ n * (of_nat q :: 'a word)) =
      drop n (to_bl (of_nat q :: 'a word)) @ replicate n False"
    by (metis bl_shiftl le_antisym min_def shiftl_t2n wsst_TYs(3))
  show ?thesis using aligned
    by (auto simp: rl elim: is_alignedE)
qed

lemma is_aligned_drop:
  fixes w::"'a::len word"
  assumes "is_aligned w n" "n \<le> LENGTH('a)"
  shows "drop (LENGTH('a) - n) (to_bl w) = replicate n False"
proof -
  have "to_bl w = take (LENGTH('a) - n) (to_bl w) @ replicate n False"
    by (rule is_aligned_replicate) fact+
  then have "drop (LENGTH('a) - n) (to_bl w) = drop (LENGTH('a) - n) \<dots>" by simp
  also have "\<dots> = replicate n False" by simp
  finally show ?thesis .
qed

lemma less_is_drop_replicate:
  fixes x::"'a::len word"
  assumes lt: "x < 2 ^ n"
  shows   "to_bl x = replicate (LENGTH('a) - n) False @ drop (LENGTH('a) - n) (to_bl x)"
  by (metis assms bl_and_mask' less_mask_eq)

lemma is_aligned_add_conv:
  fixes off::"'a::len word"
  assumes aligned: "is_aligned w n"
  and        offv: "off < 2 ^ n"
  shows    "to_bl (w + off) =
   (take (LENGTH('a) - n) (to_bl w)) @ (drop (LENGTH('a) - n) (to_bl off))"
proof cases
  assume nv: "n \<le> LENGTH('a)"
  show ?thesis
  proof (subst aligned_bl_add_size, simp_all only: word_size)
    show "drop (LENGTH('a) - n) (to_bl w) = replicate n False"
      by (subst is_aligned_replicate [OF aligned nv]) (simp add: word_size)

    from offv show "take (LENGTH('a) - n) (to_bl off) =
                    replicate (LENGTH('a) - n) False"
      by (subst less_is_drop_replicate, assumption) simp
  qed fact
next
  assume "\<not> n \<le> LENGTH('a)"
  with offv show ?thesis by (simp add: power_overflow)
qed

lemma aligned_add_aligned:
  fixes x::"'a::len word"
  assumes aligned1: "is_aligned x n"
  and     aligned2: "is_aligned y m"
  and           lt: "m \<le> n"
  shows   "is_aligned (x + y) m"
proof cases
  assume nlt: "n < LENGTH('a)"
  show ?thesis
    unfolding is_aligned_def dvd_def
  proof -
    from aligned2 obtain q2 where yv: "y = 2 ^ m * of_nat q2"
      and q2v: "q2 < 2 ^ (LENGTH('a) - m)"
      by (auto elim: is_alignedE)

    from lt obtain k where kv: "m + k = n" by (auto simp: le_iff_add)
    with aligned1 obtain q1 where xv: "x = 2 ^ (m + k) * of_nat q1"
      and q1v: "q1 < 2 ^ (LENGTH('a) - (m + k))"
      by (auto elim: is_alignedE)

    have l1: "2 ^ (m + k) * q1 < 2 ^ LENGTH('a)"
      by (rule nat_less_power_trans [OF q1v])
         (subst kv, rule order_less_imp_le [OF nlt])

    have l2: "2 ^ m * q2 < 2 ^ LENGTH('a)"
      by (rule nat_less_power_trans [OF q2v],
          rule order_less_imp_le [OF order_le_less_trans])
         fact+

    have "x = of_nat (2 ^ (m + k) *  q1)" using xv
      by simp

    moreover have "y = of_nat (2 ^ m * q2)" using yv
      by simp

    ultimately have upls: "unat x + unat y = 2 ^ m * (2 ^ k * q1 + q2)"
    proof -
      have f1: "unat x = 2 ^ (m + k) * q1"
        by (metis (no_types) \<open>x = of_nat (2 ^ (m + k) * q1)\<close> l1 nat_mod_lem word_unat.inverse_norm
                             zero_less_numeral zero_less_power)
      have "unat y = 2 ^ m * q2"
        by (metis (no_types) \<open>y = of_nat (2 ^ m * q2)\<close> l2 nat_mod_lem word_unat.inverse_norm
                             zero_less_numeral zero_less_power)
      then show ?thesis
        using f1 by (simp add: power_add semiring_normalization_rules(34))
    qed

    (* (2 ^ k * q1 + q2) *)
    show "\<exists>d. unat (x + y) = 2 ^ m * d"
    proof (cases "unat x + unat y < 2 ^ LENGTH('a)")
      case True

      have "unat (x + y) = unat x + unat y"
        by (subst unat_plus_if', rule if_P) fact

      also have "\<dots> = 2 ^ m * (2 ^ k * q1 + q2)" by (rule upls)
      finally show ?thesis ..
    next
      case False
      then have "unat (x + y) = (unat x + unat y) mod 2 ^ LENGTH('a)"
        by (subst unat_word_ariths(1)) simp

      also have "\<dots> = (2 ^ m * (2 ^ k * q1 + q2)) mod 2 ^ LENGTH('a)"
        by (subst upls, rule refl)

      also
      have "\<dots> = 2 ^ m * ((2 ^ k * q1 +  q2) mod 2 ^ (LENGTH('a) - m))"
      proof -
        have "m \<le> len_of (TYPE('a))"
          by (meson le_trans less_imp_le_nat lt nlt)
        then show ?thesis
          by (metis mult_mod_right ordered_cancel_comm_monoid_diff_class.add_diff_inverse power_add)
      qed

      finally show ?thesis ..
    qed
  qed
next
  assume "\<not> n < LENGTH('a)"
  with assms
  show ?thesis by (simp add: not_less power_overflow is_aligned_mask mask_def)
qed

corollary aligned_sub_aligned:
  "\<lbrakk>is_aligned (x::'a::len word) n; is_aligned y m; m \<le> n\<rbrakk>
   \<Longrightarrow> is_aligned (x - y) m"
  apply (simp del: add_uminus_conv_diff add:diff_conv_add_uminus)
  apply (erule aligned_add_aligned, simp_all)
  apply (erule is_alignedE)
  apply (rule_tac k="- of_nat q" in is_alignedI)
  apply simp
  done

lemma is_aligned_shift:
  fixes k::"'a::len word"
  shows "is_aligned (k << m) m"
proof cases
  assume mv: "m < LENGTH('a)"
  from mv obtain q where mq: "m + q = LENGTH('a)" and "0 < q"
    by (auto dest: less_imp_add_positive)

  have "(2::nat) ^ m dvd unat (k << m)"
  proof
    have kv: "(unat k div 2 ^ q) * 2 ^ q + unat k mod 2 ^ q = unat k"
      by (rule div_mult_mod_eq)

    have "unat (k << m) = unat (2 ^ m * k)" by (simp add: shiftl_t2n)
    also have "\<dots> = (2 ^ m * unat k) mod (2 ^ LENGTH('a))" using mv
      by (subst unat_word_ariths(2))+ simp
    also have "\<dots> = 2 ^ m * (unat k mod 2 ^ q)"
      by (subst mq [symmetric], subst power_add, subst mod_mult2_eq) simp
    finally show "unat (k << m) = 2 ^ m * (unat k mod 2 ^ q)" .
  qed

  then show ?thesis by (unfold is_aligned_def)
next
  assume "\<not> m < LENGTH('a)"
  then show ?thesis
    by (simp add: not_less power_overflow is_aligned_mask mask_def
                  shiftl_zero_size word_size)
qed

lemma aligned_mod_eq_0:
  fixes p::"'a::len word"
  assumes al: "is_aligned p sz"
  shows   "p mod 2 ^ sz = 0"
proof cases
  assume szv: "sz < LENGTH('a)"
  with al
  show ?thesis
    unfolding is_aligned_def
    by (simp add: and_mask_dvd_nat p2_gt_0 word_mod_2p_is_mask)
next
  assume "\<not> sz < LENGTH('a)"
  with al show ?thesis
    by (simp add: not_less power_overflow is_aligned_mask mask_def word_mod_by_0)
qed

lemma is_aligned_triv: "is_aligned (2 ^ n ::'a::len word) n"
  by (rule is_alignedI [where k = 1], simp)

lemma is_aligned_mult_triv1: "is_aligned (2 ^ n * x  ::'a::len word) n"
  by (rule is_alignedI [OF refl])

lemma is_aligned_mult_triv2: "is_aligned (x * 2 ^ n ::'a::len word) n"
  by (subst mult.commute, simp add: is_aligned_mult_triv1)

lemma word_power_less_0_is_0:
  fixes x :: "'a::len word"
  shows "x < a ^ 0 \<Longrightarrow> x = 0" by simp

lemma nat_add_offset_less:
  fixes x :: nat
  assumes yv: "y < 2 ^ n"
  and     xv: "x < 2 ^ m"
  and     mn: "sz = m + n"
  shows   "x * 2 ^ n + y < 2 ^ sz"
proof (subst mn)
  from yv obtain qy where "y + qy = 2 ^ n" and "0 < qy"
    by (auto dest: less_imp_add_positive)

  have "x * 2 ^ n + y < x * 2 ^ n + 2 ^ n" by simp fact+
  also have "\<dots> = (x + 1) * 2 ^ n" by simp
  also have "\<dots> \<le> 2 ^ (m + n)" using xv
    by (subst power_add) (rule mult_le_mono1, simp)
  finally show "x * 2 ^ n + y < 2 ^ (m + n)" .
qed

lemma is_aligned_no_wrap:
  fixes off :: "'a::len word"
  fixes ptr :: "'a::len word"
  assumes al: "is_aligned ptr sz"
  and    off: "off < 2 ^ sz"
  shows  "unat ptr + unat off < 2 ^ LENGTH('a)"
proof -
  have szv: "sz < LENGTH('a)"
  using off p2_gt_0 word_neq_0_conv by fastforce

  from al obtain q where ptrq: "ptr = 2 ^ sz * of_nat q" and
    qv: "q < 2 ^ (LENGTH('a) - sz)" by (auto elim: is_alignedE)

  show ?thesis
  proof (cases "sz = 0")
    case True
    then show ?thesis using off ptrq qv by clarsimp
  next
    case False
    then have sne: "0 < sz" ..

    show ?thesis
    proof -
      have uq: "unat (of_nat q ::'a::len word) = q"
        apply (subst unat_of_nat)
        apply (rule mod_less)
        apply (rule order_less_trans [OF qv])
        apply (rule power_strict_increasing [OF diff_less [OF sne]])
         apply (simp_all)
        done

      have uptr: "unat ptr = 2 ^ sz * q"
        apply (subst ptrq)
        apply (subst iffD1 [OF unat_mult_lem])
         apply (subst unat_power_lower [OF szv])
         apply (subst uq)
         apply (rule nat_less_power_trans [OF qv order_less_imp_le [OF szv]])
        apply (subst uq)
        apply (subst unat_power_lower [OF szv])
        apply simp
        done

      show "unat ptr + unat off < 2 ^ LENGTH('a)" using szv
        apply (subst uptr)
        apply (subst mult.commute, rule nat_add_offset_less [OF _ qv])
        apply (rule order_less_le_trans [OF unat_mono [OF off] order_eq_refl])
         apply simp_all
        done
    qed
  qed
qed

lemma is_aligned_no_wrap':
  fixes ptr :: "'a::len word"
  assumes al: "is_aligned ptr sz"
  and    off: "off < 2 ^ sz"
  shows  "ptr \<le> ptr + off"
  by (subst no_plus_overflow_unat_size, subst word_size, rule is_aligned_no_wrap) fact+

lemma is_aligned_no_overflow':
  fixes p :: "'a::len word"
  assumes al: "is_aligned p n"
  shows "p \<le> p + (2 ^ n - 1)"
proof cases
  assume "n<LENGTH('a)"
  with al
  have "2^n - (1::'a::len word) < 2^n"
    by (simp add: word_less_nat_alt unat_sub_if_size)
  with al
  show ?thesis by (rule is_aligned_no_wrap')
next
  assume "\<not> n<LENGTH('a)"
  with al
  show ?thesis
  by (simp add: not_less power_overflow is_aligned_mask mask_2pm1)
qed

lemma replicate_not_True:
  "\<And>n. xs = replicate n False \<Longrightarrow> True \<notin> set xs"
  by (induct xs) auto

lemma is_aligned_replicateI:
  "to_bl p = addr @ replicate n False \<Longrightarrow> is_aligned (p::'a::len word) n"
  apply (simp add: is_aligned_to_bl word_size)
  apply (subgoal_tac "length addr = LENGTH('a) - n")
   apply (simp add: replicate_not_True)
  apply (drule arg_cong [where f=length])
  apply simp
  done

lemma to_bl_2p:
  "n < LENGTH('a) \<Longrightarrow>
   to_bl ((2::'a::len word) ^ n) =
   replicate (LENGTH('a) - Suc n) False @ True # replicate n False"
  apply (subst shiftl_1 [symmetric])
  apply (subst bl_shiftl)
  apply (simp add: to_bl_1 min_def word_size)
  done

lemma map_zip_replicate_False_xor:
  "n = length xs \<Longrightarrow> map (\<lambda>(x, y). x = (\<not> y)) (zip xs (replicate n False)) = xs"
  by (induct xs arbitrary: n, auto)

lemma drop_minus_lem:
  "\<lbrakk> n \<le> length xs; 0 < n; n' = length xs \<rbrakk> \<Longrightarrow> drop (n' - n) xs = rev xs ! (n - 1)  # drop (Suc (n' - n)) xs"
proof (induct xs arbitrary: n n')
  case Nil then show ?case by simp
next
  case (Cons y ys)
  from Cons.prems
  show ?case
    apply simp
    apply (cases "n = Suc (length ys)")
     apply (simp add: nth_append)
    apply (simp add: Suc_diff_le Cons.hyps nth_append)
    apply clarsimp
    apply arith
    done
qed

lemma drop_minus:
  "\<lbrakk> n < length xs; n' = length xs \<rbrakk> \<Longrightarrow> drop (n' - Suc n) xs = rev xs ! n  # drop (n' - n) xs"
  apply (subst drop_minus_lem)
     apply simp
    apply simp
   apply simp
  apply simp
  apply (cases "length xs", simp)
  apply (simp add: Suc_diff_le)
  done

lemma xor_2p_to_bl:
  fixes x::"'a::len word"
  shows "to_bl (x xor 2^n) =
  (if n < LENGTH('a)
   then take (LENGTH('a)-Suc n) (to_bl x) @ (\<not>rev (to_bl x)!n) # drop (LENGTH('a)-n) (to_bl x)
   else to_bl x)"
proof -
  have x: "to_bl x = take (LENGTH('a)-Suc n) (to_bl x) @ drop (LENGTH('a)-Suc n) (to_bl x)"
    by simp

  show ?thesis
  apply simp
  apply (rule conjI)
   apply (clarsimp simp: word_size)
   apply (simp add: bl_word_xor to_bl_2p)
   apply (subst x)
   apply (subst zip_append)
    apply simp
   apply (simp add: map_zip_replicate_False_xor drop_minus)
  apply (auto simp add: word_size nth_w2p intro!: word_eqI)
  done
qed

lemma aligned_add_xor:
  assumes al: "is_aligned (x::'a::len word) n'" and le: "n < n'"
  shows "(x + 2^n) xor 2^n = x"
proof cases
  assume "n' < LENGTH('a)"
  with assms show ?thesis
  apply -
  apply (rule word_bl.Rep_eqD)
  apply (subst xor_2p_to_bl)
  apply simp
  apply (subst is_aligned_add_conv, simp, simp add: word_less_nat_alt)+
  apply (simp add: to_bl_2p nth_append)
  apply (cases "n' = Suc n")
   apply simp
   apply (subst is_aligned_replicate [where n="Suc n", simplified, symmetric]; simp)
  apply (subgoal_tac "\<not> LENGTH('a) - Suc n \<le> LENGTH('a) - n'")
   prefer 2
   apply arith
  apply (subst replicate_Suc [symmetric])
  apply (subst replicate_add [symmetric])
  apply (simp add: is_aligned_replicate [simplified, symmetric])
  done
next
  assume "\<not> n' < LENGTH('a)"
  with al show ?thesis
    by (simp add: is_aligned_mask mask_def not_less power_overflow)
qed

lemma is_aligned_0 [simp]:
  "is_aligned p 0"
  by (simp add: is_aligned_def)

lemma is_aligned_replicateD:
  "\<lbrakk> is_aligned (w::'a::len word) n; n \<le> LENGTH('a) \<rbrakk>
     \<Longrightarrow> \<exists>xs. to_bl w = xs @ replicate n False
               \<and> length xs = size w - n"
  apply (subst is_aligned_replicate, assumption+)
  apply (rule exI, rule conjI, rule refl)
  apply (simp add: word_size)
  done

lemma is_aligned_add_multI:
  fixes p :: "'a::len word"
  shows "\<lbrakk>is_aligned p m; n \<le> m; n' = n\<rbrakk> \<Longrightarrow> is_aligned (p + x * 2 ^ n) n'"
  apply (erule aligned_add_aligned)
  apply (auto intro: is_alignedI [where k="x"])
  done

lemma unat_of_nat_len:
  "x < 2 ^ LENGTH('a) \<Longrightarrow> unat (of_nat x :: 'a::len word) = x"
  by (simp add: word_size unat_of_nat)

lemma is_aligned_no_wrap''':
  fixes ptr :: "'a::len word"
  shows"\<lbrakk> is_aligned ptr sz; sz < LENGTH('a); off < 2 ^ sz \<rbrakk>
         \<Longrightarrow> unat ptr + off < 2 ^ LENGTH('a)"
  apply (drule is_aligned_no_wrap[where off="of_nat off"])
   apply (simp add: word_less_nat_alt)
   apply (erule order_le_less_trans[rotated])
   apply (subst unat_of_nat)
   apply (rule mod_less_eq_dividend)
  apply (subst(asm) unat_of_nat_len)
   apply (erule order_less_trans)
   apply (erule power_strict_increasing)
   apply simp
  apply assumption
  done

lemma aligned_small_is_0:
  "\<lbrakk> is_aligned x n; x < 2 ^ n \<rbrakk> \<Longrightarrow> x = 0"
  apply (erule is_aligned_get_word_bits)
   apply (frule is_aligned_add_conv [rotated, where w=0])
    apply (simp add: is_aligned_def)
   apply simp
   apply (drule is_aligned_replicateD)
    apply simp
   apply (clarsimp simp: word_size)
   apply (subst (asm) replicate_add [symmetric])
   apply (drule arg_cong[where f="of_bl :: bool list \<Rightarrow> 'a::len word"])
   apply simp
  apply (simp only: replicate.simps[symmetric, where x=False]
                    drop_replicate)
  done

corollary is_aligned_less_sz:
  "\<lbrakk>is_aligned a sz; a \<noteq> 0\<rbrakk> \<Longrightarrow> \<not> a < 2 ^ sz"
  by (rule notI, drule(1) aligned_small_is_0, erule(1) notE)

lemma aligned_at_least_t2n_diff:
  "\<lbrakk>is_aligned x n; is_aligned y n; x < y\<rbrakk> \<Longrightarrow> x \<le> y - 2 ^ n"
  apply (erule is_aligned_get_word_bits[where p=y])
   apply (rule ccontr)
   apply (clarsimp simp: linorder_not_le)
   apply (subgoal_tac "y - x = 0")
    apply clarsimp
   apply (rule aligned_small_is_0)
    apply (erule(1) aligned_sub_aligned)
    apply simp
   apply unat_arith
  apply simp
  done

lemma word_sub_1_le:
  "x \<noteq> 0 \<Longrightarrow> x - 1 \<le> (x :: ('a :: len) word)"
  apply (subst no_ulen_sub)
  apply simp
  apply (cases "uint x = 0")
   apply (simp add: uint_0_iff)
  apply (insert uint_ge_0[where x=x])
  apply arith
  done

lemma is_aligned_no_overflow'':
  "\<lbrakk>is_aligned x n; x + 2 ^ n \<noteq> 0\<rbrakk> \<Longrightarrow> x \<le> x + 2 ^ n"
  apply (frule is_aligned_no_overflow')
  apply (erule order_trans)
  apply (simp add: field_simps)
  apply (erule word_sub_1_le)
  done

lemma is_aligned_nth:
  "is_aligned p m = (\<forall>n < m. \<not>p !! n)"
  apply (clarsimp simp: is_aligned_mask bang_eq word_size)
  apply (rule iffI)
   apply clarsimp
   apply (case_tac "n < size p")
    apply (simp add: word_size)
   apply (drule test_bit_size)
   apply simp
  apply clarsimp
  done

lemma range_inter:
  "({a..b} \<inter> {c..d} = {}) = (\<forall>x. \<not>(a \<le> x \<and> x \<le> b \<and> c \<le> x \<and> x \<le> d))"
  by auto

lemma aligned_inter_non_empty:
  "\<lbrakk> {p..p + (2 ^ n - 1)} \<inter> {p..p + 2 ^ m - 1} = {};
     is_aligned p n; is_aligned p m\<rbrakk> \<Longrightarrow> False"
  apply (clarsimp simp only: range_inter)
  apply (erule_tac x=p in allE)
  apply simp
  apply (erule impE)
   apply (erule is_aligned_no_overflow')
  apply (erule notE)
  apply (erule is_aligned_no_overflow)
  done

lemma not_aligned_mod_nz:
  assumes al: "\<not> is_aligned a n"
  shows "a mod 2 ^ n \<noteq> 0"
proof cases
  assume "n < LENGTH('a)"
  with al
  show ?thesis
    apply (simp add: is_aligned_def dvd_eq_mod_eq_0 word_arith_nat_mod)
    apply (erule of_nat_neq_0)
    apply (rule order_less_trans)
     apply (rule mod_less_divisor)
     apply simp
    apply simp
    done
next
  assume "\<not> n < LENGTH('a)"
  with al
  show ?thesis
    by (simp add: is_aligned_mask mask_def not_less power_overflow
                  word_less_nat_alt word_mod_by_0)
qed

lemma nat_add_offset_le:
  fixes x :: nat
  assumes yv: "y \<le> 2 ^ n"
  and     xv: "x < 2 ^ m"
  and     mn: "sz = m + n"
  shows   "x * 2 ^ n + y \<le> 2 ^ sz"
proof (subst mn)
  from yv obtain qy where "y + qy = 2 ^ n"
    by (auto simp: le_iff_add)

  have "x * 2 ^ n + y \<le> x * 2 ^ n + 2 ^ n"
    using yv xv by simp
  also have "\<dots> = (x + 1) * 2 ^ n" by simp
  also have "\<dots> \<le> 2 ^ (m + n)" using xv
    by (subst power_add) (rule mult_le_mono1, simp)
  finally show "x * 2 ^ n + y \<le> 2 ^ (m + n)" .
qed

lemma is_aligned_no_wrap_le:
  fixes ptr::"'a::len word"
  assumes al: "is_aligned ptr sz"
  and    szv: "sz < LENGTH('a)"
  and    off: "off \<le> 2 ^ sz"
  shows  "unat ptr + off \<le> 2 ^ LENGTH('a)"
proof -
  from al obtain q where ptrq: "ptr = 2 ^ sz * of_nat q" and
    qv: "q < 2 ^ (LENGTH('a) - sz)" by (auto elim: is_alignedE)

  show ?thesis
  proof (cases "sz = 0")
    case True
    then show ?thesis using off ptrq qv
      apply (clarsimp)
      apply (erule le_SucE)
       apply (simp add: unat_of_nat)
      apply (simp add: less_eq_Suc_le [symmetric] unat_of_nat)
      done
  next
    case False
    then have sne: "0 < sz" ..

    show ?thesis
    proof -
      have uq: "unat (of_nat q :: 'a word) = q"
        apply (subst unat_of_nat)
        apply (rule mod_less)
        apply (rule order_less_trans [OF qv])
        apply (rule power_strict_increasing [OF diff_less [OF sne]])
        apply simp_all
        done

      have uptr: "unat ptr = 2 ^ sz * q"
        apply (subst ptrq)
        apply (subst iffD1 [OF unat_mult_lem])
        apply (subst unat_power_lower [OF szv])
        apply (subst uq)
        apply (rule nat_less_power_trans [OF qv order_less_imp_le [OF szv]])
        apply (subst uq)
        apply (subst unat_power_lower [OF szv])
        apply simp
        done

      show "unat ptr + off \<le> 2 ^ LENGTH('a)" using szv
        apply (subst uptr)
        apply (subst mult.commute, rule nat_add_offset_le [OF off qv])
        apply simp
        done
    qed
  qed
qed

lemma is_aligned_neg_mask:
  "m \<le> n \<Longrightarrow> is_aligned (x && ~~ mask n) m"
  by (metis and_not_mask is_aligned_shift is_aligned_weaken)

lemma unat_minus:
  "unat (- (x :: ('a :: len) word))
    = (if x = 0 then 0 else (2 ^ size x) - unat x)"
  using unat_sub_if_size[where x="2 ^ size x" and y=x]
  by (simp add: unat_eq_0 word_size)

lemma is_aligned_minus:
  "is_aligned p n \<Longrightarrow> is_aligned (- p) n"
  apply (clarsimp simp: is_aligned_def unat_minus word_size word_neq_0_conv)
  apply (rule dvd_diff_nat, simp_all)
  apply (rule le_imp_power_dvd)
  apply (fold is_aligned_def)
  apply (erule_tac Q="0<p" in contrapos_pp)
  apply (clarsimp simp add: is_aligned_mask mask_def power_overflow)
  done

lemma add_mask_lower_bits:
  "\<lbrakk>is_aligned (x :: 'a :: len word) n;
    \<forall>n' \<ge> n. n' < LENGTH('a) \<longrightarrow> \<not> p !! n'\<rbrakk> \<Longrightarrow> x + p && ~~mask n = x"
  apply (subst word_plus_and_or_coroll)
   apply (rule word_eqI)
   apply (clarsimp simp: word_size is_aligned_nth)
   apply (erule_tac x=na in allE)+
   apply simp
  apply (rule word_eqI)
  apply (clarsimp simp: word_size is_aligned_nth word_ops_nth_size le_def)
  apply blast
  done

lemma is_aligned_andI1:
  "is_aligned x n \<Longrightarrow> is_aligned (x && y) n"
  by (simp add: is_aligned_nth)

lemma is_aligned_andI2:
  "is_aligned y n \<Longrightarrow> is_aligned (x && y) n"
  by (simp add: is_aligned_nth)

lemma is_aligned_shiftl:
  "is_aligned w (n - m) \<Longrightarrow> is_aligned (w << m) n"
  by (simp add: is_aligned_nth nth_shiftl)

lemma is_aligned_shiftr:
  "is_aligned w (n + m) \<Longrightarrow> is_aligned (w >> m) n"
  by (simp add: is_aligned_nth nth_shiftr)

lemma is_aligned_shiftl_self:
  "is_aligned (p << n) n"
  by (rule is_aligned_shift)

lemma is_aligned_neg_mask_eq:
  "is_aligned p n \<Longrightarrow> p && ~~ mask n = p"
  by (metis add.left_neutral is_aligned_mask word_plus_and_or_coroll2)

lemma is_aligned_shiftr_shiftl:
  "is_aligned w n \<Longrightarrow> w >> n << n = w"
  by (metis and_not_mask is_aligned_neg_mask_eq)

lemma aligned_shiftr_mask_shiftl:
  "is_aligned x n \<Longrightarrow> ((x >> n) && mask v) << n = x && mask (v + n)"
  apply (rule word_eqI)
  apply (simp add: word_size nth_shiftl nth_shiftr)
  apply (subgoal_tac "\<forall>m. x !! m \<longrightarrow> m \<ge> n")
   apply auto[1]
  apply (clarsimp simp: is_aligned_mask)
  apply (drule_tac x=m in word_eqD)
  apply (frule test_bit_size)
  apply (simp add: word_size)
  done

end


(*  Title:      ZF/pair.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge
*)

section{*Ordered Pairs*}

theory pair imports upair
begin

ML_file "simpdata.ML"

setup {*
  map_theory_simpset
    (Simplifier.set_mksimps (K (map mk_eq o ZF_atomize o gen_all))
      #> Simplifier.add_cong @{thm if_weak_cong})
*}

ML {* val ZF_ss = simpset_of @{context} *}

simproc_setup defined_Bex ("\<exists>x\<in>A. P(x) & Q(x)") = {*
  fn _ => Quantifier1.rearrange_bex
    (fn ctxt =>
      unfold_tac ctxt @{thms Bex_def} THEN
      Quantifier1.prove_one_point_ex_tac)
*}

simproc_setup defined_Ball ("\<forall>x\<in>A. P(x) \<longrightarrow> Q(x)") = {*
  fn _ => Quantifier1.rearrange_ball
    (fn ctxt =>
      unfold_tac ctxt @{thms Ball_def} THEN
      Quantifier1.prove_one_point_all_tac)
*}

(** Lemmas for showing that <a,b> uniquely determines a and b **)

lemma singleton_eq_iff [iff]: "{a} = {b} \<longleftrightarrow> a=b"
by (rule extension [THEN iff_trans], blast)

lemma doubleton_eq_iff: "{a,b} = {c,d} \<longleftrightarrow> (a=c & b=d) | (a=d & b=c)"
by (rule extension [THEN iff_trans], blast)

lemma Pair_iff [simp]: "<a,b> = <c,d> \<longleftrightarrow> a=c & b=d"
by (simp add: Pair_def doubleton_eq_iff, blast)

lemmas Pair_inject = Pair_iff [THEN iffD1, THEN conjE, elim!]

lemmas Pair_inject1 = Pair_iff [THEN iffD1, THEN conjunct1]
lemmas Pair_inject2 = Pair_iff [THEN iffD1, THEN conjunct2]

lemma Pair_not_0: "<a,b> \<noteq> 0"
apply (unfold Pair_def)
apply (blast elim: equalityE)
done

lemmas Pair_neq_0 = Pair_not_0 [THEN notE, elim!]

declare sym [THEN Pair_neq_0, elim!]

lemma Pair_neq_fst: "<a,b>=a ==> P"
proof (unfold Pair_def)
  assume eq: "{{a, a}, {a, b}} = a"
  have  "{a, a} \<in> {{a, a}, {a, b}}" by (rule consI1)
  hence "{a, a} \<in> a" by (simp add: eq)
  moreover have "a \<in> {a, a}" by (rule consI1)
  ultimately show "P" by (rule mem_asym)
qed

lemma Pair_neq_snd: "<a,b>=b ==> P"
proof (unfold Pair_def)
  assume eq: "{{a, a}, {a, b}} = b"
  have  "{a, b} \<in> {{a, a}, {a, b}}" by blast
  hence "{a, b} \<in> b" by (simp add: eq)
  moreover have "b \<in> {a, b}" by blast
  ultimately show "P" by (rule mem_asym)
qed

subsection{*Sigma: Disjoint Union of a Family of Sets*}

text{*Generalizes Cartesian product*}

lemma Sigma_iff [simp]: "<a,b>: Sigma(A,B) \<longleftrightarrow> a \<in> A & b \<in> B(a)"
by (simp add: Sigma_def)

lemma SigmaI [TC,intro!]: "[| a \<in> A;  b \<in> B(a) |] ==> <a,b> \<in> Sigma(A,B)"
by simp

lemmas SigmaD1 = Sigma_iff [THEN iffD1, THEN conjunct1]
lemmas SigmaD2 = Sigma_iff [THEN iffD1, THEN conjunct2]

(*The general elimination rule*)
lemma SigmaE [elim!]:
    "[| c \<in> Sigma(A,B);
        !!x y.[| x \<in> A;  y \<in> B(x);  c=<x,y> |] ==> P
     |] ==> P"
by (unfold Sigma_def, blast)

lemma SigmaE2 [elim!]:
    "[| <a,b> \<in> Sigma(A,B);
        [| a \<in> A;  b \<in> B(a) |] ==> P
     |] ==> P"
by (unfold Sigma_def, blast)

lemma Sigma_cong:
    "[| A=A';  !!x. x \<in> A' ==> B(x)=B'(x) |] ==>
     Sigma(A,B) = Sigma(A',B')"
by (simp add: Sigma_def)

(*Sigma_cong, Pi_cong NOT given to Addcongs: they cause
  flex-flex pairs and the "Check your prover" error.  Most
  Sigmas and Pis are abbreviated as * or -> *)

lemma Sigma_empty1 [simp]: "Sigma(0,B) = 0"
by blast

lemma Sigma_empty2 [simp]: "A*0 = 0"
by blast

lemma Sigma_empty_iff: "A*B=0 \<longleftrightarrow> A=0 | B=0"
by blast

subsection{*Projections @{term fst} and @{term snd}*}

lemma fst_conv [simp]: "fst(<a,b>) = a"
by (simp add: fst_def)

lemma snd_conv [simp]: "snd(<a,b>) = b"
by (simp add: snd_def)

lemma fst_type [TC]: "p \<in> Sigma(A,B) ==> fst(p) \<in> A"
by auto

lemma snd_type [TC]: "p \<in> Sigma(A,B) ==> snd(p) \<in> B(fst(p))"
by auto

lemma Pair_fst_snd_eq: "a \<in> Sigma(A,B) ==> <fst(a),snd(a)> = a"
by auto

subsection{*The Eliminator, @{term split}*}

(*A META-equality, so that it applies to higher types as well...*)
lemma split [simp]: "split(%x y. c(x,y), <a,b>) == c(a,b)"
by (simp add: split_def)

lemma split_type [TC]:
    "[|  p \<in> Sigma(A,B);
         !!x y.[| x \<in> A; y \<in> B(x) |] ==> c(x,y):C(<x,y>)
     |] ==> split(%x y. c(x,y), p) \<in> C(p)"
by (erule SigmaE, auto)

lemma expand_split:
  "u \<in> A*B ==>
        R(split(c,u)) \<longleftrightarrow> (\<forall>x\<in>A. \<forall>y\<in>B. u = <x,y> \<longrightarrow> R(c(x,y)))"
by (auto simp add: split_def)

subsection{*A version of @{term split} for Formulae: Result Type @{typ o}*}

lemma splitI: "R(a,b) ==> split(R, <a,b>)"
by (simp add: split_def)

lemma splitE:
    "[| split(R,z);  z \<in> Sigma(A,B);
        !!x y. [| z = <x,y>;  R(x,y) |] ==> P
     |] ==> P"
by (auto simp add: split_def)

lemma splitD: "split(R,<a,b>) ==> R(a,b)"
by (simp add: split_def)

text {*
  \bigskip Complex rules for Sigma.
*}

lemma split_paired_Bex_Sigma [simp]:
     "(\<exists>z \<in> Sigma(A,B). P(z)) \<longleftrightarrow> (\<exists>x \<in> A. \<exists>y \<in> B(x). P(<x,y>))"
by blast

lemma split_paired_Ball_Sigma [simp]:
     "(\<forall>z \<in> Sigma(A,B). P(z)) \<longleftrightarrow> (\<forall>x \<in> A. \<forall>y \<in> B(x). P(<x,y>))"
by blast

end


(*  Title:      HOL/Algebra/Galois_Connection.thy
    Author:     Alasdair Armstrong and Simon Foster
    Copyright:  Alasdair Armstrong and Simon Foster
*)

theory Galois_Connection
  imports Complete_Lattice
begin

section \<open> Galois connections \<close>

subsection \<open> Definition and basic properties \<close>

record ('a, 'b, 'c, 'd) galcon =
  orderA :: "('a, 'c) gorder_scheme" ("\<X>\<index>")
  orderB :: "('b, 'd) gorder_scheme" ("\<Y>\<index>")
  lower  :: "'a \<Rightarrow> 'b" ("\<pi>\<^sup>*\<index>")
  upper  :: "'b \<Rightarrow> 'a" ("\<pi>\<^sub>*\<index>")

type_synonym ('a, 'b) galois = "('a, 'b, unit, unit) galcon"

abbreviation "inv_galcon G \<equiv> \<lparr> orderA = inv_gorder \<Y>\<^bsub>G\<^esub>, orderB = inv_gorder \<X>\<^bsub>G\<^esub>, lower = upper G, upper = lower G \<rparr>"

definition comp_galcon :: "('b, 'c) galois \<Rightarrow> ('a, 'b) galois \<Rightarrow> ('a, 'c) galois" (infixr "\<circ>\<^sub>g" 85)
where "G \<circ>\<^sub>g F = \<lparr> orderA = orderA F, orderB = orderB G, lower = lower G \<circ> lower F, upper = upper F \<circ> upper G \<rparr>"

definition id_galcon :: "'a gorder \<Rightarrow> ('a, 'a) galois" ("I\<^sub>g") where
"I\<^sub>g(A) = \<lparr> orderA = A, orderB = A, lower = id, upper = id \<rparr>"

subsection \<open> Well-typed connections \<close>

locale connection =
  fixes G (structure)
  assumes is_order_A: "partial_order \<X>"
  and is_order_B: "partial_order \<Y>"
  and lower_closure: "\<pi>\<^sup>* \<in> carrier \<X> \<rightarrow> carrier \<Y>"
  and upper_closure: "\<pi>\<^sub>* \<in> carrier \<Y> \<rightarrow> carrier \<X>"
begin

  lemma lower_closed: "x \<in> carrier \<X> \<Longrightarrow> \<pi>\<^sup>* x \<in> carrier \<Y>"
    using lower_closure by auto

  lemma upper_closed: "y \<in> carrier \<Y> \<Longrightarrow> \<pi>\<^sub>* y \<in> carrier \<X>"
    using upper_closure by auto

end

subsection \<open> Galois connections \<close>

locale galois_connection = connection +
  assumes galois_property: "\<lbrakk>x \<in> carrier \<X>; y \<in> carrier \<Y>\<rbrakk> \<Longrightarrow> \<pi>\<^sup>* x \<sqsubseteq>\<^bsub>\<Y>\<^esub> y \<longleftrightarrow> x \<sqsubseteq>\<^bsub>\<X>\<^esub> \<pi>\<^sub>* y"
begin

  lemma is_weak_order_A: "weak_partial_order \<X>"
  proof -
    interpret po: partial_order \<X>
      by (metis is_order_A)
    show ?thesis ..
  qed

  lemma is_weak_order_B: "weak_partial_order \<Y>"
  proof -
    interpret po: partial_order \<Y>
      by (metis is_order_B)
    show ?thesis ..
  qed

  lemma right: "\<lbrakk>x \<in> carrier \<X>; y \<in> carrier \<Y>; \<pi>\<^sup>* x \<sqsubseteq>\<^bsub>\<Y>\<^esub> y\<rbrakk> \<Longrightarrow> x \<sqsubseteq>\<^bsub>\<X>\<^esub> \<pi>\<^sub>* y"
    by (metis galois_property)

  lemma left: "\<lbrakk>x \<in> carrier \<X>; y \<in> carrier \<Y>; x \<sqsubseteq>\<^bsub>\<X>\<^esub> \<pi>\<^sub>* y\<rbrakk> \<Longrightarrow> \<pi>\<^sup>* x \<sqsubseteq>\<^bsub>\<Y>\<^esub> y"
    by (metis galois_property)

  lemma deflation: "y \<in> carrier \<Y> \<Longrightarrow> \<pi>\<^sup>* (\<pi>\<^sub>* y) \<sqsubseteq>\<^bsub>\<Y>\<^esub> y"
    by (metis Pi_iff is_weak_order_A left lower_closure upper_closure weak_partial_order.le_refl)

  lemma inflation: "x \<in> carrier \<X> \<Longrightarrow> x \<sqsubseteq>\<^bsub>\<X>\<^esub> \<pi>\<^sub>* (\<pi>\<^sup>* x)"
    by (metis (no_types, lifting) PiE galois_connection.right galois_connection_axioms is_weak_order_B lower_closure upper_closure weak_partial_order.le_refl)

  lemma lower_iso: "isotone \<X> \<Y> \<pi>\<^sup>*"
  proof (auto simp add:isotone_def)
    show "weak_partial_order \<X>"
      by (metis is_weak_order_A)
    show "weak_partial_order \<Y>"
      by (metis is_weak_order_B)
    fix x y
    assume a: "x \<in> carrier \<X>" "y \<in> carrier \<X>" "x \<sqsubseteq>\<^bsub>\<X>\<^esub> y"
    have b: "\<pi>\<^sup>* y \<in> carrier \<Y>"
      using a(2) lower_closure by blast
    then have "\<pi>\<^sub>* (\<pi>\<^sup>* y) \<in> carrier \<X>"
      using upper_closure by blast
    then have "x \<sqsubseteq>\<^bsub>\<X>\<^esub> \<pi>\<^sub>* (\<pi>\<^sup>* y)"
      by (meson a inflation is_weak_order_A weak_partial_order.le_trans)
    thus "\<pi>\<^sup>* x \<sqsubseteq>\<^bsub>\<Y>\<^esub> \<pi>\<^sup>* y"
      by (meson b a(1) Pi_iff galois_property lower_closure upper_closure)
  qed

  lemma upper_iso: "isotone \<Y> \<X> \<pi>\<^sub>*"
    apply (auto simp add:isotone_def)
    apply (metis is_weak_order_B)
    apply (metis is_weak_order_A)
    apply (metis (no_types, lifting) Pi_mem deflation is_weak_order_B lower_closure right upper_closure weak_partial_order.le_trans)
  done

  lemma lower_comp: "x \<in> carrier \<X> \<Longrightarrow> \<pi>\<^sup>* (\<pi>\<^sub>* (\<pi>\<^sup>* x)) = \<pi>\<^sup>* x"
    by (meson deflation funcset_mem inflation is_order_B lower_closure lower_iso partial_order.le_antisym upper_closure use_iso2)

  lemma lower_comp': "x \<in> carrier \<X> \<Longrightarrow> (\<pi>\<^sup>* \<circ> \<pi>\<^sub>* \<circ> \<pi>\<^sup>*) x = \<pi>\<^sup>* x"
    by (simp add: lower_comp)

  lemma upper_comp: "y \<in> carrier \<Y> \<Longrightarrow> \<pi>\<^sub>* (\<pi>\<^sup>* (\<pi>\<^sub>* y)) = \<pi>\<^sub>* y"
  proof -
    assume a1: "y \<in> carrier \<Y>"
    hence f1: "\<pi>\<^sub>* y \<in> carrier \<X>" using upper_closure by blast
    have f2: "\<pi>\<^sup>* (\<pi>\<^sub>* y) \<sqsubseteq>\<^bsub>\<Y>\<^esub> y" using a1 deflation by blast
    have f3: "\<pi>\<^sub>* (\<pi>\<^sup>* (\<pi>\<^sub>* y)) \<in> carrier \<X>"
      using f1 lower_closure upper_closure by auto
    have "\<pi>\<^sup>* (\<pi>\<^sub>* y) \<in> carrier \<Y>" using f1 lower_closure by blast
    thus "\<pi>\<^sub>* (\<pi>\<^sup>* (\<pi>\<^sub>* y)) = \<pi>\<^sub>* y"
      by (meson a1 f1 f2 f3 inflation is_order_A partial_order.le_antisym upper_iso use_iso2)
  qed

  lemma upper_comp': "y \<in> carrier \<Y> \<Longrightarrow> (\<pi>\<^sub>* \<circ> \<pi>\<^sup>* \<circ> \<pi>\<^sub>*) y = \<pi>\<^sub>* y"
    by (simp add: upper_comp)

  lemma adjoint_idem1: "idempotent \<Y> (\<pi>\<^sup>* \<circ> \<pi>\<^sub>*)"
    by (simp add: idempotent_def is_order_B partial_order.eq_is_equal upper_comp)

  lemma adjoint_idem2: "idempotent \<X> (\<pi>\<^sub>* \<circ> \<pi>\<^sup>*)"
    by (simp add: idempotent_def is_order_A partial_order.eq_is_equal lower_comp)

  lemma fg_iso: "isotone \<Y> \<Y> (\<pi>\<^sup>* \<circ> \<pi>\<^sub>*)"
    by (metis iso_compose lower_closure lower_iso upper_closure upper_iso)

  lemma gf_iso: "isotone \<X> \<X> (\<pi>\<^sub>* \<circ> \<pi>\<^sup>*)"
    by (metis iso_compose lower_closure lower_iso upper_closure upper_iso)

  lemma semi_inverse1: "x \<in> carrier \<X> \<Longrightarrow> \<pi>\<^sup>* x = \<pi>\<^sup>* (\<pi>\<^sub>* (\<pi>\<^sup>* x))"
    by (metis lower_comp)

  lemma semi_inverse2: "x \<in> carrier \<Y> \<Longrightarrow> \<pi>\<^sub>* x = \<pi>\<^sub>* (\<pi>\<^sup>* (\<pi>\<^sub>* x))"
    by (metis upper_comp)

  theorem lower_by_complete_lattice:
    assumes "complete_lattice \<Y>" "x \<in> carrier \<X>"
    shows "\<pi>\<^sup>*(x) = \<Sqinter>\<^bsub>\<Y>\<^esub> { y \<in> carrier \<Y>. x \<sqsubseteq>\<^bsub>\<X>\<^esub> \<pi>\<^sub>*(y) }"
  proof -
    interpret Y: complete_lattice \<Y>
      by (simp add: assms)

    show ?thesis
    proof (rule Y.le_antisym)
      show x: "\<pi>\<^sup>* x \<in> carrier \<Y>"
        using assms(2) lower_closure by blast
      show "\<pi>\<^sup>* x \<sqsubseteq>\<^bsub>\<Y>\<^esub> \<Sqinter>\<^bsub>\<Y>\<^esub>{y \<in> carrier \<Y>. x \<sqsubseteq>\<^bsub>\<X>\<^esub> \<pi>\<^sub>* y}"
      proof (rule Y.weak.inf_greatest)
        show "{y \<in> carrier \<Y>. x \<sqsubseteq>\<^bsub>\<X>\<^esub> \<pi>\<^sub>* y} \<subseteq> carrier \<Y>"
          by auto
        show "\<pi>\<^sup>* x \<in> carrier \<Y>" by (fact x)
        fix z
        assume "z \<in> {y \<in> carrier \<Y>. x \<sqsubseteq>\<^bsub>\<X>\<^esub> \<pi>\<^sub>* y}"
        thus "\<pi>\<^sup>* x \<sqsubseteq>\<^bsub>\<Y>\<^esub> z"
          using assms(2) left by auto
      qed
      show "\<Sqinter>\<^bsub>\<Y>\<^esub>{y \<in> carrier \<Y>. x \<sqsubseteq>\<^bsub>\<X>\<^esub> \<pi>\<^sub>* y} \<sqsubseteq>\<^bsub>\<Y>\<^esub> \<pi>\<^sup>* x"
      proof (rule Y.weak.inf_lower)
        show "{y \<in> carrier \<Y>. x \<sqsubseteq>\<^bsub>\<X>\<^esub> \<pi>\<^sub>* y} \<subseteq> carrier \<Y>"
          by auto
        show "\<pi>\<^sup>* x \<in> {y \<in> carrier \<Y>. x \<sqsubseteq>\<^bsub>\<X>\<^esub> \<pi>\<^sub>* y}"
        proof (auto)
          show "\<pi>\<^sup>* x \<in> carrier \<Y>" by (fact x)
          show "x \<sqsubseteq>\<^bsub>\<X>\<^esub> \<pi>\<^sub>* (\<pi>\<^sup>* x)"
            using assms(2) inflation by blast
        qed
      qed
      show "\<Sqinter>\<^bsub>\<Y>\<^esub>{y \<in> carrier \<Y>. x \<sqsubseteq>\<^bsub>\<X>\<^esub> \<pi>\<^sub>* y} \<in> carrier \<Y>"
       by (auto intro: Y.weak.inf_closed)
    qed
  qed

  theorem upper_by_complete_lattice:
    assumes "complete_lattice \<X>" "y \<in> carrier \<Y>"
    shows "\<pi>\<^sub>*(y) = \<Squnion>\<^bsub>\<X>\<^esub> { x \<in> carrier \<X>. \<pi>\<^sup>*(x) \<sqsubseteq>\<^bsub>\<Y>\<^esub> y }"
  proof -
    interpret X: complete_lattice \<X>
      by (simp add: assms)
    show ?thesis
    proof (rule X.le_antisym)
      show y: "\<pi>\<^sub>* y \<in> carrier \<X>"
        using assms(2) upper_closure by blast
      show "\<pi>\<^sub>* y \<sqsubseteq>\<^bsub>\<X>\<^esub> \<Squnion>\<^bsub>\<X>\<^esub>{x \<in> carrier \<X>. \<pi>\<^sup>* x \<sqsubseteq>\<^bsub>\<Y>\<^esub> y}"
      proof (rule X.weak.sup_upper)
        show "{x \<in> carrier \<X>. \<pi>\<^sup>* x \<sqsubseteq>\<^bsub>\<Y>\<^esub> y} \<subseteq> carrier \<X>"
          by auto
        show "\<pi>\<^sub>* y \<in> {x \<in> carrier \<X>. \<pi>\<^sup>* x \<sqsubseteq>\<^bsub>\<Y>\<^esub> y}"
        proof (auto)
          show "\<pi>\<^sub>* y \<in> carrier \<X>" by (fact y)
          show "\<pi>\<^sup>* (\<pi>\<^sub>* y) \<sqsubseteq>\<^bsub>\<Y>\<^esub> y"
            by (simp add: assms(2) deflation)
        qed
      qed
      show "\<Squnion>\<^bsub>\<X>\<^esub>{x \<in> carrier \<X>. \<pi>\<^sup>* x \<sqsubseteq>\<^bsub>\<Y>\<^esub> y} \<sqsubseteq>\<^bsub>\<X>\<^esub> \<pi>\<^sub>* y"
      proof (rule X.weak.sup_least)
        show "{x \<in> carrier \<X>. \<pi>\<^sup>* x \<sqsubseteq>\<^bsub>\<Y>\<^esub> y} \<subseteq> carrier \<X>"
          by auto
        show "\<pi>\<^sub>* y \<in> carrier \<X>" by (fact y)
        fix z
        assume "z \<in> {x \<in> carrier \<X>. \<pi>\<^sup>* x \<sqsubseteq>\<^bsub>\<Y>\<^esub> y}"
        thus "z \<sqsubseteq>\<^bsub>\<X>\<^esub> \<pi>\<^sub>* y"
          by (simp add: assms(2) right)
      qed
      show "\<Squnion>\<^bsub>\<X>\<^esub>{x \<in> carrier \<X>. \<pi>\<^sup>* x \<sqsubseteq>\<^bsub>\<Y>\<^esub> y} \<in> carrier \<X>"
       by (auto intro: X.weak.sup_closed)
    qed
  qed

  lemma
    assumes "complete_lattice \<X>" "complete_lattice \<Y>" "X \<subseteq> carrier \<X>"
    shows "\<pi>\<^sup>*(\<Squnion>\<^bsub>\<X>\<^esub> X) = \<Squnion>\<^bsub>\<Y>\<^esub> {\<pi>\<^sup>*(x) | x. x \<in> X}"
    oops (* TODO *)

end

lemma dual_galois [simp]: " galois_connection \<lparr> orderA = inv_gorder B, orderB = inv_gorder A, lower = f, upper = g \<rparr>
                          = galois_connection \<lparr> orderA = A, orderB = B, lower = g, upper = f \<rparr>"
  by (auto simp add: galois_connection_def galois_connection_axioms_def connection_def dual_order_iff)

definition lower_adjoint :: "('a, 'c) gorder_scheme \<Rightarrow> ('b, 'd) gorder_scheme \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool" where
  "lower_adjoint A B f \<equiv> \<exists>g. galois_connection \<lparr> orderA = A, orderB = B, lower = f, upper = g \<rparr>"

definition upper_adjoint :: "('a, 'c) gorder_scheme \<Rightarrow> ('b, 'd) gorder_scheme \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> bool" where
  "upper_adjoint A B g \<equiv> \<exists>f. galois_connection \<lparr> orderA = A, orderB = B, lower = f, upper = g \<rparr>"

lemma lower_adjoint_dual [simp]: "lower_adjoint (inv_gorder A) (inv_gorder B) f = upper_adjoint B A f"
  by (simp add: lower_adjoint_def upper_adjoint_def)

lemma upper_adjoint_dual [simp]: "upper_adjoint (inv_gorder A) (inv_gorder B) f = lower_adjoint B A f"
  by (simp add: lower_adjoint_def upper_adjoint_def)

lemma lower_type: "lower_adjoint A B f \<Longrightarrow> f \<in> carrier A \<rightarrow> carrier B"
  by (auto simp add:lower_adjoint_def galois_connection_def galois_connection_axioms_def connection_def)

lemma upper_type: "upper_adjoint A B g \<Longrightarrow> g \<in> carrier B \<rightarrow> carrier A"
  by (auto simp add:upper_adjoint_def galois_connection_def galois_connection_axioms_def connection_def)

subsection \<open> Composition of Galois connections \<close>

lemma id_galois: "partial_order A \<Longrightarrow> galois_connection (I\<^sub>g(A))"
  by (simp add: id_galcon_def galois_connection_def galois_connection_axioms_def connection_def)

lemma comp_galcon_closed:
  assumes "galois_connection G" "galois_connection F" "\<Y>\<^bsub>F\<^esub> = \<X>\<^bsub>G\<^esub>"
  shows "galois_connection (G \<circ>\<^sub>g F)"
proof -
  interpret F: galois_connection F
    by (simp add: assms)
  interpret G: galois_connection G
    by (simp add: assms)

  have "partial_order \<X>\<^bsub>G \<circ>\<^sub>g F\<^esub>"
    by (simp add: F.is_order_A comp_galcon_def)
  moreover have "partial_order \<Y>\<^bsub>G \<circ>\<^sub>g F\<^esub>"
    by (simp add: G.is_order_B comp_galcon_def)
  moreover have "\<pi>\<^sup>*\<^bsub>G\<^esub> \<circ> \<pi>\<^sup>*\<^bsub>F\<^esub> \<in> carrier \<X>\<^bsub>F\<^esub> \<rightarrow> carrier \<Y>\<^bsub>G\<^esub>"
    using F.lower_closure G.lower_closure assms(3) by auto
  moreover have "\<pi>\<^sub>*\<^bsub>F\<^esub> \<circ> \<pi>\<^sub>*\<^bsub>G\<^esub> \<in> carrier \<Y>\<^bsub>G\<^esub> \<rightarrow> carrier \<X>\<^bsub>F\<^esub>"
    using F.upper_closure G.upper_closure assms(3) by auto
  moreover
  have "\<And> x y. \<lbrakk>x \<in> carrier \<X>\<^bsub>F\<^esub>; y \<in> carrier \<Y>\<^bsub>G\<^esub> \<rbrakk> \<Longrightarrow>
               (\<pi>\<^sup>*\<^bsub>G\<^esub> (\<pi>\<^sup>*\<^bsub>F\<^esub> x) \<sqsubseteq>\<^bsub>\<Y>\<^bsub>G\<^esub>\<^esub> y) = (x \<sqsubseteq>\<^bsub>\<X>\<^bsub>F\<^esub>\<^esub> \<pi>\<^sub>*\<^bsub>F\<^esub> (\<pi>\<^sub>*\<^bsub>G\<^esub> y))"
    by (metis F.galois_property F.lower_closure G.galois_property G.upper_closure assms(3) Pi_iff)
  ultimately show ?thesis
    by (simp add: comp_galcon_def galois_connection_def galois_connection_axioms_def connection_def)
qed

lemma comp_galcon_right_unit [simp]: "F \<circ>\<^sub>g I\<^sub>g(\<X>\<^bsub>F\<^esub>) = F"
  by (simp add: comp_galcon_def id_galcon_def)

lemma comp_galcon_left_unit [simp]: "I\<^sub>g(\<Y>\<^bsub>F\<^esub>) \<circ>\<^sub>g F = F"
  by (simp add: comp_galcon_def id_galcon_def)

lemma galois_connectionI:
  assumes
    "partial_order A" "partial_order B"
    "L \<in> carrier A \<rightarrow> carrier B" "R \<in> carrier B \<rightarrow> carrier A"
    "isotone A B L" "isotone B A R"
    "\<And> x y. \<lbrakk> x \<in> carrier A; y \<in> carrier B \<rbrakk> \<Longrightarrow> L x \<sqsubseteq>\<^bsub>B\<^esub> y \<longleftrightarrow> x \<sqsubseteq>\<^bsub>A\<^esub> R y"
  shows "galois_connection \<lparr> orderA = A, orderB = B, lower = L, upper = R \<rparr>"
  using assms by (simp add: galois_connection_def connection_def galois_connection_axioms_def)

lemma galois_connectionI':
  assumes
    "partial_order A" "partial_order B"
    "L \<in> carrier A \<rightarrow> carrier B" "R \<in> carrier B \<rightarrow> carrier A"
    "isotone A B L" "isotone B A R"
    "\<And> X. X \<in> carrier(B) \<Longrightarrow> L(R(X)) \<sqsubseteq>\<^bsub>B\<^esub> X"
    "\<And> X. X \<in> carrier(A) \<Longrightarrow> X \<sqsubseteq>\<^bsub>A\<^esub> R(L(X))"
  shows "galois_connection \<lparr> orderA = A, orderB = B, lower = L, upper = R \<rparr>"
  using assms
  by (auto simp add: galois_connection_def connection_def galois_connection_axioms_def, (meson PiE isotone_def weak_partial_order.le_trans)+)

subsection \<open> Retracts \<close>

locale retract = galois_connection +
  assumes retract_property: "x \<in> carrier \<X> \<Longrightarrow> \<pi>\<^sub>* (\<pi>\<^sup>* x) \<sqsubseteq>\<^bsub>\<X>\<^esub> x"
begin
  lemma retract_inverse: "x \<in> carrier \<X> \<Longrightarrow> \<pi>\<^sub>* (\<pi>\<^sup>* x) = x"
    by (meson funcset_mem inflation is_order_A lower_closure partial_order.le_antisym retract_axioms retract_axioms_def retract_def upper_closure)

  lemma retract_injective: "inj_on \<pi>\<^sup>* (carrier \<X>)"
    by (metis inj_onI retract_inverse)
end

theorem comp_retract_closed:
  assumes "retract G" "retract F" "\<Y>\<^bsub>F\<^esub> = \<X>\<^bsub>G\<^esub>"
  shows "retract (G \<circ>\<^sub>g F)"
proof -
  interpret f: retract F
    by (simp add: assms)
  interpret g: retract G
    by (simp add: assms)
  interpret gf: galois_connection "(G \<circ>\<^sub>g F)"
    by (simp add: assms(1) assms(2) assms(3) comp_galcon_closed retract.axioms(1))
  show ?thesis
  proof
    fix x
    assume "x \<in> carrier \<X>\<^bsub>G \<circ>\<^sub>g F\<^esub>"
    thus "le \<X>\<^bsub>G \<circ>\<^sub>g F\<^esub> (\<pi>\<^sub>*\<^bsub>G \<circ>\<^sub>g F\<^esub> (\<pi>\<^sup>*\<^bsub>G \<circ>\<^sub>g F\<^esub> x)) x"
      using assms(3) f.inflation f.lower_closed f.retract_inverse g.retract_inverse by (auto simp add: comp_galcon_def)
  qed
qed

subsection \<open> Coretracts \<close>

locale coretract = galois_connection +
  assumes coretract_property: "y \<in> carrier \<Y> \<Longrightarrow> y \<sqsubseteq>\<^bsub>\<Y>\<^esub> \<pi>\<^sup>* (\<pi>\<^sub>* y)"
begin
  lemma coretract_inverse: "y \<in> carrier \<Y> \<Longrightarrow> \<pi>\<^sup>* (\<pi>\<^sub>* y) = y"
    by (meson coretract_axioms coretract_axioms_def coretract_def deflation funcset_mem is_order_B lower_closure partial_order.le_antisym upper_closure)

  lemma retract_injective: "inj_on \<pi>\<^sub>* (carrier \<Y>)"
    by (metis coretract_inverse inj_onI)
end

theorem comp_coretract_closed:
  assumes "coretract G" "coretract F" "\<Y>\<^bsub>F\<^esub> = \<X>\<^bsub>G\<^esub>"
  shows "coretract (G \<circ>\<^sub>g F)"
proof -
  interpret f: coretract F
    by (simp add: assms)
  interpret g: coretract G
    by (simp add: assms)
  interpret gf: galois_connection "(G \<circ>\<^sub>g F)"
    by (simp add: assms(1) assms(2) assms(3) comp_galcon_closed coretract.axioms(1))
  show ?thesis
  proof
    fix y
    assume "y \<in> carrier \<Y>\<^bsub>G \<circ>\<^sub>g F\<^esub>"
    thus "le \<Y>\<^bsub>G \<circ>\<^sub>g F\<^esub> y (\<pi>\<^sup>*\<^bsub>G \<circ>\<^sub>g F\<^esub> (\<pi>\<^sub>*\<^bsub>G \<circ>\<^sub>g F\<^esub> y))"
      by (simp add: comp_galcon_def assms(3) f.coretract_inverse g.coretract_property g.upper_closed)
  qed
qed

subsection \<open> Galois Bijections \<close>

locale galois_bijection = connection +
  assumes lower_iso: "isotone \<X> \<Y> \<pi>\<^sup>*"
  and upper_iso: "isotone \<Y> \<X> \<pi>\<^sub>*"
  and lower_inv_eq: "x \<in> carrier \<X> \<Longrightarrow> \<pi>\<^sub>* (\<pi>\<^sup>* x) = x"
  and upper_inv_eq: "y \<in> carrier \<Y> \<Longrightarrow> \<pi>\<^sup>* (\<pi>\<^sub>* y) = y"
begin

  lemma lower_bij: "bij_betw \<pi>\<^sup>* (carrier \<X>) (carrier \<Y>)"
    by (rule bij_betwI[where g="\<pi>\<^sub>*"], auto intro: upper_inv_eq lower_inv_eq upper_closed lower_closed)

  lemma upper_bij: "bij_betw \<pi>\<^sub>* (carrier \<Y>) (carrier \<X>)"
    by (rule bij_betwI[where g="\<pi>\<^sup>*"], auto intro: upper_inv_eq lower_inv_eq upper_closed lower_closed)

sublocale gal_bij_conn: galois_connection
  apply (unfold_locales, auto)
  using lower_closed lower_inv_eq upper_iso use_iso2 apply fastforce
  using lower_iso upper_closed upper_inv_eq use_iso2 apply fastforce
done

sublocale gal_bij_ret: retract
  by (unfold_locales, simp add: gal_bij_conn.is_weak_order_A lower_inv_eq weak_partial_order.le_refl)

sublocale gal_bij_coret: coretract
  by (unfold_locales, simp add: gal_bij_conn.is_weak_order_B upper_inv_eq weak_partial_order.le_refl)

end

theorem comp_galois_bijection_closed:
  assumes "galois_bijection G" "galois_bijection F" "\<Y>\<^bsub>F\<^esub> = \<X>\<^bsub>G\<^esub>"
  shows "galois_bijection (G \<circ>\<^sub>g F)"
proof -
  interpret f: galois_bijection F
    by (simp add: assms)
  interpret g: galois_bijection G
    by (simp add: assms)
  interpret gf: galois_connection "(G \<circ>\<^sub>g F)"
    by (simp add: assms(3) comp_galcon_closed f.gal_bij_conn.galois_connection_axioms g.gal_bij_conn.galois_connection_axioms galois_connection.axioms(1))
  show ?thesis
  proof
    show "isotone \<X>\<^bsub>G \<circ>\<^sub>g F\<^esub> \<Y>\<^bsub>G \<circ>\<^sub>g F\<^esub> \<pi>\<^sup>*\<^bsub>G \<circ>\<^sub>g F\<^esub>"
      by (simp add: comp_galcon_def, metis comp_galcon_def galcon.select_convs(1) galcon.select_convs(2) galcon.select_convs(3) gf.lower_iso)
    show "isotone \<Y>\<^bsub>G \<circ>\<^sub>g F\<^esub> \<X>\<^bsub>G \<circ>\<^sub>g F\<^esub> \<pi>\<^sub>*\<^bsub>G \<circ>\<^sub>g F\<^esub>"
      by (simp add: gf.upper_iso)
    fix x
    assume "x \<in> carrier \<X>\<^bsub>G \<circ>\<^sub>g F\<^esub>"
    thus "\<pi>\<^sub>*\<^bsub>G \<circ>\<^sub>g F\<^esub> (\<pi>\<^sup>*\<^bsub>G \<circ>\<^sub>g F\<^esub> x) = x"
      using assms(3) f.lower_closed f.lower_inv_eq g.lower_inv_eq by (auto simp add: comp_galcon_def)
  next
    fix y
    assume "y \<in> carrier \<Y>\<^bsub>G \<circ>\<^sub>g F\<^esub>"
    thus "\<pi>\<^sup>*\<^bsub>G \<circ>\<^sub>g F\<^esub> (\<pi>\<^sub>*\<^bsub>G \<circ>\<^sub>g F\<^esub> y) = y"
      by (simp add: comp_galcon_def assms(3) f.upper_inv_eq g.upper_closed g.upper_inv_eq)
  qed
qed

end


(* Title: Domain Quantales
   Author: Victor Gomes, Georg Struth
   Maintainer: Victor Gomes <victor.gomes@cl.cam.ac.uk>
               Georg Struth <g.struth@sheffield.ac.uk>
*)

section \<open>Component for Recursive Programs\<close>

theory Domain_Quantale
  imports KAD.Modal_Kleene_Algebra

begin

text \<open>This component supports the verification and step-wise refinement of recursive programs
in a partial correctness setting.\<close>

notation
  times (infixl "\<cdot>" 70) and
  bot ("\<bottom>") and
  top ("\<top>") and
  inf (infixl "\<sqinter>" 65) and
  sup (infixl "\<squnion>" 65)

subsection \<open>Lattice-Ordered Monoids with Domain\<close>

class bd_lattice_ordered_monoid = bounded_lattice + distrib_lattice + monoid_mult +
  assumes left_distrib: "x \<cdot> (y \<squnion> z) = x \<cdot> y \<squnion> x \<cdot> z"
  and right_distrib: "(x \<squnion> y) \<cdot> z = x \<cdot> z \<squnion> y \<cdot> z"
  and bot_annil [simp]: "\<bottom> \<cdot> x = \<bottom>"
  and bot_annir [simp]: "x \<cdot> \<bottom> = \<bottom>"

begin

sublocale semiring_one_zero "(\<squnion>)" "(\<cdot>)" "1" "bot"
  by (standard, auto simp: sup.assoc sup.commute sup_left_commute left_distrib right_distrib sup_absorb1)

sublocale dioid_one_zero "(\<squnion>)" "(\<cdot>)" "1" bot "(\<le>)" "(<)"
  by (standard, simp add: le_iff_sup, auto)

end

no_notation ads_d ("d")
  and ars_r ("r")
  and antirange_op ("ar _" [999] 1000)

class domain_bdlo_monoid = bd_lattice_ordered_monoid +
  assumes rdv: "(z \<sqinter> x \<cdot> top) \<cdot> y = z \<cdot> y \<sqinter> x \<cdot> top"

begin

definition "d x = 1 \<sqinter> x \<cdot> \<top>"

sublocale ds: domain_semiring "(\<squnion>)" "(\<cdot>)" "1" "\<bottom>" "d" "(\<le>)" "(<)"
proof standard
  fix x y
  show "x \<squnion> d x \<cdot> x = d x \<cdot> x"
    by (metis d_def inf_sup_absorb left_distrib mult_1_left mult_1_right rdv sup.absorb_iff1 sup.idem sup.left_commute top_greatest)
  show "d (x \<cdot> d y) = d (x \<cdot> y)"
    by (simp add: d_def inf_absorb2 rdv  mult_assoc)
  show "d x \<squnion> 1 = 1"
    by (simp add: d_def sup.commute)
  show "d bot = bot"
    by (simp add: d_def inf.absorb1 inf.commute)
  show "d (x \<squnion> y) = d x \<squnion> d y"
    by (simp add: d_def inf_sup_distrib1)
qed

end

subsection\<open>Boolean Monoids with Domain\<close>

class boolean_monoid = boolean_algebra + monoid_mult +
  assumes left_distrib': "x \<cdot> (y \<squnion> z) = x \<cdot> y \<squnion> x \<cdot> z"
  and right_distrib': "(x \<squnion> y) \<cdot> z = x \<cdot> z \<squnion> y \<cdot> z"
  and bot_annil' [simp]: "\<bottom> \<cdot> x = \<bottom>"
  and bot_annir' [simp]: "x \<cdot> \<bottom> = \<bottom>"

begin

subclass bd_lattice_ordered_monoid
  by (standard, simp_all add: left_distrib' right_distrib')

lemma inf_bot_iff_le: "x \<sqinter> y = \<bottom> \<longleftrightarrow> x \<le> -y"
  by (metis le_iff_inf inf_sup_distrib1 inf_top_right sup_bot.left_neutral sup_compl_top compl_inf_bot inf.assoc inf_bot_right)

end

class domain_boolean_monoid = boolean_monoid +
  assumes rdv': "(z \<sqinter> x \<cdot> \<top>) \<cdot> y = z \<cdot> y \<sqinter> x \<cdot> \<top>"

begin

sublocale dblo: domain_bdlo_monoid "1" "(\<cdot>)" "(\<sqinter>)" "(\<le>)" "(<)" "(\<squnion>)" "\<bottom>" "\<top>"
  by (standard, simp add: rdv')

definition "a x = 1 \<sqinter> -(dblo.d x)"

lemma a_d_iff: "a x = 1 \<sqinter> -(x \<cdot> \<top>)"
  by (clarsimp simp: a_def dblo.d_def inf_sup_distrib1)

lemma topr: "-(x \<cdot> \<top>) \<cdot> \<top> = -(x \<cdot> \<top>)"
proof (rule order.antisym)
  show "-(x \<cdot> \<top>) \<le> -(x \<cdot> \<top>) \<cdot> \<top>"
    by (metis mult_isol_var mult_oner order_refl top_greatest)
  have "-(x \<cdot> \<top>) \<sqinter> (x \<cdot> \<top>) = \<bottom>"
    by simp
  hence "(-(x \<cdot> \<top>) \<sqinter> (x \<cdot> \<top>)) \<cdot> \<top>  = \<bottom>"
    by simp
  hence "-(x \<cdot> \<top>) \<cdot> \<top> \<sqinter> (x \<cdot> \<top>)  = \<bottom>"
    by (metis rdv')
  thus "-(x \<cdot> \<top>) \<cdot> \<top> \<le> -(x \<cdot> \<top>)"
    by (simp add: inf_bot_iff_le)
qed

lemma dd_a: "dblo.d x = a (a x)"
  by (metis a_d_iff dblo.d_def double_compl inf_top.left_neutral mult_1_left rdv' topr)

lemma ad_a [simp]: "a (dblo.d x) = a x"
  by (simp add: a_def)

lemma da_a [simp]: "dblo.d (a x) = a x"
  using ad_a dd_a by auto

lemma a1 [simp]: "a x \<cdot> x = \<bottom>"
proof -
  have "a x \<cdot> x \<cdot> \<top> = \<bottom>"
    by (metis a_d_iff inf_compl_bot mult_1_left rdv' topr)
  then show ?thesis
    by (metis (no_types) dblo.d_def dblo.ds.domain_very_strict inf_bot_right)
qed

lemma a2 [simp]: "a (x \<cdot> y) \<squnion> a (x \<cdot> a (a y)) = a (x \<cdot> a (a y))"
  by (metis a_def dblo.ds.dsr2 dd_a sup.idem)

lemma a3 [simp]: "a (a x) \<squnion> a x = 1"
  by (metis a_def da_a inf.commute sup.commute sup_compl_top sup_inf_absorb sup_inf_distrib1)

subclass domain_bdlo_monoid ..

text \<open>The next statement shows that every boolean monoid with domain is an antidomain semiring.
In this setting the domain operation has been defined explicitly.\<close>

sublocale ad: antidomain_semiring a "(\<squnion>)" "(\<cdot>)" "1" "\<bottom>" "(\<le>)" "(<)"
  rewrites ad_eq: "ad.ads_d x = d x"
proof -
  show "class.antidomain_semiring a (\<squnion>) (\<cdot>) 1 \<bottom> (\<le>) (<)"
    by (standard, simp_all)
  then interpret ad: antidomain_semiring a "(\<squnion>)" "(\<cdot>)" "1" "\<bottom>" "(\<le>)" "(<)" .
  show "ad.ads_d x = d x"
    by (simp add: ad.ads_d_def dd_a)
qed

end

subsection\<open>Boolean Monoids with Range\<close>

class range_boolean_monoid = boolean_monoid +
  assumes ldv': "y \<cdot> (z \<sqinter> \<top> \<cdot> x) = y \<cdot> z \<sqinter> \<top> \<cdot> x"

begin

definition "r x = 1 \<sqinter> \<top> \<cdot> x"

definition "ar x = 1 \<sqinter> -(r x)"

lemma ar_r_iff: "ar x = 1 \<sqinter> -(\<top> \<cdot> x)"
  by (simp add: ar_def inf_sup_distrib1 r_def)

lemma topl: "\<top>\<cdot>(-(\<top> \<cdot> x)) = -(\<top> \<cdot> x)"
proof (rule order.antisym)
  show "\<top> \<cdot> - (\<top> \<cdot> x) \<le> - (\<top> \<cdot> x)"
    by (metis bot_annir' compl_inf_bot inf_bot_iff_le ldv')
  show "- (\<top> \<cdot> x) \<le> \<top> \<cdot> - (\<top> \<cdot> x)"
    by (metis inf_le2 inf_top.right_neutral mult_1_left mult_isor)
qed

lemma r_ar: "r x = ar (ar x)"
  by (metis ar_r_iff double_compl inf.commute inf_top.right_neutral ldv' mult_1_right r_def topl)

lemma ar_ar [simp]: "ar (r x) = ar x"
  by (simp add: ar_def ldv' r_def)

lemma rar_ar [simp]: "r (ar x) = ar x"
  using r_ar ar_ar by force

lemma ar1 [simp]: "x \<cdot> ar x = \<bottom>"
proof -
  have "\<top> \<cdot> x \<cdot> ar x = \<bottom>"
    by (metis ar_r_iff inf_compl_bot ldv' mult_oner topl)
  then show ?thesis
    by (metis inf_bot_iff_le inf_le2 inf_top.right_neutral mult_1_left mult_isor mult_oner topl)
qed

lemma ars: "r (r x \<cdot> y) = r (x \<cdot> y)"
  by (metis inf.commute inf_top.right_neutral ldv' mult_oner mult_assoc r_def)

lemma ar2 [simp]: "ar (x \<cdot> y) \<squnion> ar (ar (ar x) \<cdot> y) = ar (ar (ar x) \<cdot> y)"
  by (metis ar_def ars r_ar sup.idem)

lemma ar3 [simp]: "ar (ar x) \<squnion> ar x = 1 "
  by (metis ar_def rar_ar inf.commute sup.commute sup_compl_top sup_inf_absorb sup_inf_distrib1)

sublocale ar: antirange_semiring "(\<squnion>)" "(\<cdot>)" "1" "\<bottom>" ar "(\<le>)" "(<)"
  rewrites ar_eq: "ar.ars_r x = r x"
proof -
  show "class.antirange_semiring (\<squnion>) (\<cdot>) 1 \<bottom> ar (\<le>) (<)"
    by (standard, simp_all)
  then interpret ar: antirange_semiring "(\<squnion>)" "(\<cdot>)" "1" "\<bottom>" ar "(\<le>)" "(<)" .
  show "ar.ars_r x = r x"
    by (simp add: ar.ars_r_def r_ar)
qed

end

subsection \<open>Quantales\<close>

text \<open>This part will eventually move into an AFP quantale entry.\<close>

class quantale = complete_lattice + monoid_mult +
  assumes Sup_distr: "Sup X \<cdot> y = Sup {z. \<exists>x \<in> X. z = x \<cdot> y}"
  and Sup_distl: "x \<cdot> Sup Y = Sup {z. \<exists>y \<in> Y. z = x \<cdot> y}"

begin

lemma bot_annil'' [simp]: "\<bottom> \<cdot> x = \<bottom>"
  using Sup_distr[where X="{}"] by auto

lemma bot_annirr'' [simp]: "x \<cdot> \<bottom> = \<bottom>"
  using Sup_distl[where Y="{}"] by auto

lemma sup_distl: "x \<cdot> (y \<squnion> z) = x \<cdot> y \<squnion> x \<cdot> z"
  using Sup_distl[where Y="{y, z}"] by (fastforce intro!: Sup_eqI)

lemma sup_distr: "(x \<squnion> y) \<cdot> z = x \<cdot> z \<squnion> y \<cdot> z"
  using Sup_distr[where X="{x, y}"] by (fastforce intro!: Sup_eqI)

sublocale semiring_one_zero "(\<squnion>)" "(\<cdot>)" "1" "\<bottom>"
  by (standard, auto simp: sup.assoc sup.commute sup_left_commute sup_distl sup_distr)

sublocale dioid_one_zero "(\<squnion>)" "(\<cdot>)" "1" "\<bottom>" "(\<le>)" "(<)"
  by (standard, simp add: le_iff_sup, auto)

lemma Sup_sup_pred: "x \<squnion> Sup{y. P y} = Sup{y. y = x \<or> P y}"
  apply (rule order.antisym)
  apply (simp add: Collect_mono Sup_subset_mono Sup_upper)
  using Sup_least Sup_upper le_supI2 by fastforce

definition star :: "'a \<Rightarrow> 'a" where
  "star x = (SUP i. x ^ i)"

lemma star_def_var1: "star x = Sup{y. \<exists>i. y = x ^ i}"
  by (simp add: star_def full_SetCompr_eq)

lemma star_def_var2: "star x = Sup{x ^ i |i. True}"
  by (simp add: star_def full_SetCompr_eq)

lemma star_unfoldl' [simp]: "1 \<squnion> x \<cdot> (star x) = star x"
proof -
  have "1 \<squnion> x \<cdot> (star x) = x ^ 0 \<squnion> x \<cdot> Sup{y. \<exists>i. y = x ^ i}"
    by (simp add: star_def_var1)
  also have "... = x ^ 0 \<squnion> Sup{y. \<exists>i. y = x ^ (i + 1)}"
    by (simp add: Sup_distl, metis)
  also have "... = Sup{y. y = x ^ 0 \<or> (\<exists>i. y = x ^ (i + 1))}"
    using Sup_sup_pred by simp
  also have "... = Sup{y. \<exists>i. y = x ^ i}"
    by (metis Suc_eq_plus1 power.power.power_Suc power.power_eq_if)
  finally show ?thesis
    by (simp add: star_def_var1)
qed

lemma star_unfoldr' [simp]: "1 \<squnion> (star x) \<cdot> x = star x"
proof -
  have "1 \<squnion> (star x) \<cdot> x = x ^ 0 \<squnion> Sup{y. \<exists>i. y = x ^ i} \<cdot> x"
    by (simp add: star_def_var1)
  also have "... = x ^ 0 \<squnion> Sup{y. \<exists>i. y = x ^ i \<cdot> x}"
    by (simp add: Sup_distr, metis)
  also have "... = x ^ 0 \<squnion> Sup{y. \<exists>i. y = x ^ (i + 1)}"
    using power_Suc2 by simp
   also have "... = Sup{y. y = x ^ 0 \<or> (\<exists>i. y = x ^ (i + 1))}"
    using Sup_sup_pred by simp
  also have "... = Sup{y. \<exists>i. y = x ^ i}"
    by (metis Suc_eq_plus1 power.power.power_Suc power.power_eq_if)
  finally show ?thesis
    by (simp add: star_def_var1)
qed

lemma (in dioid_one_zero) power_inductl: "z + x \<cdot> y \<le> y \<Longrightarrow> (x ^ n) \<cdot> z \<le> y"
proof (induct n)
  case 0 show ?case
    using "0.prems" by simp
  case Suc thus ?case
    by (simp, metis mult.assoc mult_isol order_trans)
qed

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

lemma star_inductl': "z \<squnion> x \<cdot> y \<le> y \<Longrightarrow> (star x) \<cdot> z \<le> y"
proof -
  assume "z \<squnion> x \<cdot> y \<le> y"
  hence "\<forall>i. x ^ i \<cdot> z \<le> y"
    by (simp add: power_inductl)
  hence "Sup{w. \<exists>i. w = x ^ i \<cdot> z} \<le> y"
    by (intro Sup_least, fast)
  hence "Sup{w. \<exists>i. w = x ^ i} \<cdot> z \<le> y"
    using Sup_distr Sup_le_iff by auto
  thus "(star x) \<cdot> z \<le> y"
    by (simp add: star_def_var1)
qed

lemma star_inductr': "z \<squnion> y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> (star x) \<le> y"
proof -
  assume "z \<squnion> y \<cdot> x \<le> y"
  hence "\<forall>i. z \<cdot> x ^ i  \<le> y"
    by (simp add: power_inductr)
  hence "Sup{w. \<exists>i. w = z \<cdot> x ^ i} \<le> y"
    by (intro Sup_least, fast)
  hence "z \<cdot> Sup{w. \<exists>i. w = x ^ i} \<le> y"
    using Sup_distl Sup_le_iff by auto
  thus "z \<cdot> (star x) \<le> y"
    by (simp add: star_def_var1)
qed

sublocale ka: kleene_algebra "(\<squnion>)" "(\<cdot>)" "1" "\<bottom>" "(\<le>)" "(<)" star
  by standard (simp_all add: star_inductl' star_inductr')

end

text \<open>Distributive quantales are often assumed to satisfy infinite distributivity laws between
joins and meets, but finite ones suffice for our purposes.\<close>

class distributive_quantale = quantale + distrib_lattice

begin

subclass bd_lattice_ordered_monoid
  by (standard, simp_all add: distrib_left)

lemma "(1 \<sqinter> x \<cdot> \<top>) \<cdot> x = x"
(* nitpick [expect=genuine]*)
oops

end

subsection \<open>Domain Quantales\<close>

class domain_quantale = distributive_quantale +
  assumes rdv'': "(z \<sqinter> x \<cdot> \<top>) \<cdot> y = z \<cdot> y \<sqinter> x \<cdot> \<top>"

begin

subclass domain_bdlo_monoid
  by (standard, simp add: rdv'')

end

class range_quantale = distributive_quantale +
  assumes ldv'': "y \<cdot> (z \<sqinter> \<top> \<cdot> x) = y \<cdot> z \<sqinter> \<top> \<cdot> x"

class boolean_quantale = quantale + complete_boolean_algebra

begin

subclass boolean_monoid
  by (standard, simp_all add: sup_distl)

lemma "(1 \<sqinter> x \<cdot> \<top>) \<cdot> x = x"
(*nitpick[expect=genuine]*)
oops

lemma "(1 \<sqinter> -(x \<cdot> \<top>)) \<cdot> x = \<bottom>"
(*nitpick[expect=genuine]*)
oops

end

subsection\<open>Boolean Domain Quantales\<close>

class domain_boolean_quantale = domain_quantale + boolean_quantale

begin

subclass domain_boolean_monoid
  by (standard, simp add: rdv'')

lemma fbox_eq: "ad.fbox x q = Sup{d p |p. d p \<cdot> x \<le> x \<cdot> d q}"
  apply (rule Sup_eqI[symmetric])
  apply clarsimp
  using ad.fbox_demodalisation3 ad.fbox_simp apply auto[1]
  apply clarsimp
  by (metis ad.fbox_def ad.fbox_demodalisation3 ad.fbox_simp da_a eq_refl)

lemma fdia_eq: "ad.fdia x p = Inf{d q |q. x \<cdot> d p \<le> d q \<cdot> x}"
  apply (rule Inf_eqI[symmetric])
  apply clarsimp
  using ds.fdemodalisation2 apply auto[1]
  apply clarsimp
  by (metis ad.fd_eq_fdia ad.fdia_def da_a double_compl ds.fdemodalisation2 inf_bot_iff_le inf_compl_bot)

text \<open>The specification statement can be defined explicitly.\<close>

definition R :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
  "R p q \<equiv> Sup{x. (d p) \<cdot> x \<le> x \<cdot> d q}"

lemma "x \<le> R p q \<Longrightarrow> d p \<le> ad.fbox x (d q)"
proof (simp add: R_def ad.kat_1_equiv ad.kat_2_equiv)
  assume "x \<le> Sup{x. d p \<cdot> x \<cdot> a q = \<bottom>}"
  hence "d p \<cdot> x \<cdot> a q \<le> d p \<cdot> Sup{x. d p \<cdot> x \<cdot> a q = \<bottom>} \<cdot> a q "
    using mult_double_iso by blast
  also have "... = Sup{d p \<cdot> x \<cdot> a q |x. d p \<cdot> x \<cdot> a q = \<bottom>}"
    apply (subst Sup_distl)
    apply (subst Sup_distr)
    apply clarsimp
    by metis
  also have "... = \<bottom>"
    by (auto simp: Sup_eqI)
  finally show ?thesis
    using ad.fbox_demodalisation3 ad.kat_3 ad.kat_4 le_bot by blast
qed

lemma "d p \<le> ad.fbox x (d q) \<Longrightarrow> x \<le> R p q"
  apply (simp add: R_def)
  apply (rule Sup_upper)
  apply simp
  using ad.fbox_demodalisation3 ad.fbox_simp apply auto[1]
done

end

subsection\<open>Relational Model of Boolean Domain Quantales\<close>

interpretation rel_dbq: domain_boolean_quantale
  \<open>(-)\<close> uminus \<open>(\<inter>)\<close> \<open>(\<subseteq>)\<close> \<open>(\<subset>)\<close> \<open>(\<union>)\<close> \<open>{}\<close> UNIV \<open>\<Inter>\<close> \<open>\<Union>\<close> Id \<open>(O)\<close>
  by standard auto

subsection\<open>Modal Boolean Quantales\<close>

class range_boolean_quantale = range_quantale + boolean_quantale

begin

subclass range_boolean_monoid
  by (standard, simp add: ldv'')

lemma fbox_eq: "ar.bbox x (r q) = Sup{r p |p. x \<cdot> r p \<le> (r q) \<cdot> x}"
  apply (rule Sup_eqI[symmetric])
  apply clarsimp
  using ar.ardual.fbox_demodalisation3 ar.ardual.fbox_simp apply auto[1]
  apply clarsimp
  by (metis ar.ardual.fbox_def ar.ardual.fbox_demodalisation3 eq_refl rar_ar)

lemma fdia_eq: "ar.bdia x (r p) = Inf{r q |q. (r p) \<cdot> x \<le> x \<cdot> r q}"
  apply (rule Inf_eqI[symmetric])
  apply clarsimp
  using ar.ars_r_def ar.ardual.fdemodalisation22 ar.ardual.kat_3_equiv_opp ar.ardual.kat_4_equiv_opp apply auto[1]
  apply clarsimp
  using ar.bdia_def ar.ardual.ds.fdemodalisation2 r_ar by fastforce

end

class modal_boolean_quantale = domain_boolean_quantale + range_boolean_quantale +
  assumes domrange' [simp]: "d (r x) = r x"
  and rangedom' [simp]: "r (d x) = d x"

begin

sublocale mka: modal_kleene_algebra "(\<squnion>)" "(\<cdot>)" 1 \<bottom> "(\<le>)" "(<)" star a ar
  by standard (simp_all add: ar_eq ad_eq)

end

no_notation fbox ("( |_] _)" [61,81] 82)
  and antidomain_semiringl_class.fbox ("( |_] _)" [61,81] 82)

notation ad.fbox ("( |_] _)" [61,81] 82)

subsection \<open>Recursion Rule\<close>

lemma recursion: "mono (f :: 'a \<Rightarrow> 'a :: domain_boolean_quantale) \<Longrightarrow>
  (\<And>x. d p \<le> |x] d q \<Longrightarrow> d p \<le> |f x] d q) \<Longrightarrow>  d p \<le> |lfp f] d q"
  apply (erule lfp_ordinal_induct [where f=f], simp)
  by (auto simp: ad.addual.ardual.fbox_demodalisation3 Sup_distr Sup_distl intro: Sup_mono)

text \<open>We have already tested this rule in the context of test quantales~\<^cite>\<open>"ArmstrongGS15"\<close>, which is based
on a formalisation of quantales that is currently not in the AFP. The two theories will be merged as
soon as the quantale is available in the AFP.\<close>

end