(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Resultants\<close>

text \<open>We need some results on resultants to show that
  a suitable prime for Berlekamp's algorithm always exists
  if the input is square free. Most of this theory has
  been developed for algebraic numbers, though. We moved this
  theory here, so that algebraic numbers can already use the
  factorization algorithm of this entry.\<close>

subsection \<open>Bivariate Polynomials\<close>

theory Bivariate_Polynomials
imports
  Polynomial_Interpolation.Ring_Hom_Poly
  Subresultants.More_Homomorphisms
  Berlekamp_Zassenhaus.Unique_Factorization_Poly (* Only for preserving sublocaling *)
begin

subsubsection \<open>Evaluation of Bivariate Polynomials\<close>

definition poly2 :: "'a::comm_semiring_1 poly poly \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"
  where "poly2 p x y = poly (poly p [: y :]) x"

lemma poly2_by_map: "poly2 p x = poly (map_poly (\<lambda>c. poly c x) p)"
  apply (rule ext) unfolding poly2_def by (induct p; simp)

lemma poly2_const[simp]: "poly2 [:[:a:]:] x y = a" by (simp add: poly2_def)
lemma poly2_smult[simp,hom_distribs]: "poly2 (smult a p) x y = poly a x * poly2 p x y" by (simp add: poly2_def)

interpretation poly2_hom: comm_semiring_hom "\<lambda>p. poly2 p x y" by (unfold_locales; simp add: poly2_def)
interpretation poly2_hom: comm_ring_hom "\<lambda>p. poly2 p x y"..
interpretation poly2_hom: idom_hom "\<lambda>p. poly2 p x y"..

lemma poly2_pCons[simp,hom_distribs]: "poly2 (pCons a p) x y = poly a x + y * poly2 p x y" by (simp add: poly2_def)
lemma poly2_monom: "poly2 (monom a n) x y = poly a x * y ^ n" by (auto simp: poly_monom poly2_def)

lemma poly_poly_as_poly2: "poly2 p x (poly q x) = poly (poly p q) x" by (induct p; simp add:poly2_def)

text \<open>The following lemma is an extension rule for bivariate polynomials.\<close>

lemma poly2_ext:
  fixes p q :: "'a :: {ring_char_0,idom} poly poly"
  assumes "\<And>x y. poly2 p x y = poly2 q x y" shows "p = q"
proof(intro poly_ext)
  fix r x
  show "poly (poly p r) x = poly (poly q r) x"
    unfolding poly_poly_as_poly2[symmetric] using assms by auto
qed

abbreviation (input) "coeff_lift2 == \<lambda>a. [:[: a :]:]"

lemma coeff_lift2_lift: "coeff_lift2 = coeff_lift \<circ> coeff_lift" by auto

definition "poly_lift = map_poly coeff_lift"
definition "poly_lift2 = map_poly coeff_lift2"

lemma degree_poly_lift[simp]: "degree (poly_lift p) = degree p"
  unfolding poly_lift_def by(rule degree_map_poly; auto)

lemma poly_lift_0[simp]: "poly_lift 0 = 0" unfolding poly_lift_def by simp

lemma poly_lift_0_iff[simp]: "poly_lift p = 0 \<longleftrightarrow> p = 0"
  unfolding poly_lift_def by(induct p;simp)

lemma poly_lift_pCons[simp]:
  "poly_lift (pCons a p) = pCons [:a:] (poly_lift p)"
  unfolding poly_lift_def map_poly_simps by simp

lemma coeff_poly_lift[simp]:
  fixes p:: "'a :: comm_monoid_add poly"
  shows "coeff (poly_lift p) i = coeff_lift (coeff p i)"
  unfolding poly_lift_def by simp

interpretation poly_lift_hom: inj_comm_monoid_add_hom poly_lift
proof-
  interpret map_poly_inj_comm_monoid_add_hom coeff_lift..
  show "inj_comm_monoid_add_hom poly_lift" by (unfold_locales, auto simp: poly_lift_def hom_distribs)
qed
interpretation poly_lift_hom: inj_comm_semiring_hom poly_lift
proof-
  interpret map_poly_inj_comm_semiring_hom coeff_lift..
  show "inj_comm_semiring_hom poly_lift" by (unfold_locales, auto simp add: poly_lift_def hom_distribs)
qed
interpretation poly_lift_hom: inj_comm_ring_hom poly_lift..
interpretation poly_lift_hom: inj_idom_hom poly_lift..

lemma (in comm_monoid_add_hom) map_poly_hom_coeff_lift[simp, hom_distribs]:
  "map_poly hom (coeff_lift a) = coeff_lift (hom a)" by (cases "a=0";simp)

lemma (in comm_ring_hom) map_poly_coeff_lift_hom:
  "map_poly (coeff_lift \<circ> hom) p = map_poly (map_poly hom) (map_poly coeff_lift p)"
proof (induct p)
  case (pCons a p) show ?case
    proof(cases "a = 0")
      case True
        hence "poly_lift p \<noteq> 0" using pCons(1) by simp
        thus ?thesis
          unfolding map_poly_pCons[OF pCons(1)]
          unfolding pCons(2) True by simp
      next case False
        hence "coeff_lift a \<noteq> 0" by simp
        thus ?thesis
        unfolding map_poly_pCons[OF pCons(1)]
        unfolding pCons(2) by simp
    qed
qed auto

lemma poly_poly_lift[simp]:
  fixes p :: "'a :: comm_semiring_0 poly"
  shows "poly (poly_lift p) [:x:] = [: poly p x :]"
proof (induct p)
  case 0 show ?case by simp
  next case (pCons a p) show ?case
    unfolding poly_lift_pCons
    unfolding poly_pCons
    unfolding pCons apply (subst mult.commute) by auto
qed

lemma degree_poly_lift2[simp]:
  "degree (poly_lift2 p) = degree p" unfolding poly_lift2_def by (induct p; auto)

lemma poly_lift2_0[simp]: "poly_lift2 0 = 0" unfolding poly_lift2_def by simp

lemma poly_lift2_0_iff[simp]: "poly_lift2 p = 0 \<longleftrightarrow> p = 0"
  unfolding poly_lift2_def by(induct p;simp)

lemma poly_lift2_pCons[simp]:
  "poly_lift2 (pCons a p) = pCons [:[:a:]:] (poly_lift2 p)"
  unfolding poly_lift2_def map_poly_simps by simp

lemma poly_lift2_lift: "poly_lift2 = poly_lift \<circ> poly_lift" (is "?l = ?r")
proof
  fix p show "?l p = ?r p"
    unfolding poly_lift2_def coeff_lift2_lift poly_lift_def by (induct p; auto)
qed

lemma poly2_poly_lift[simp]: "poly2 (poly_lift p) x y = poly p y" by (induct p;simp)

lemma poly_lift2_nonzero:
  assumes "p \<noteq> 0" shows "poly_lift2 p \<noteq> 0"
  unfolding poly_lift2_def
  apply (subst map_poly_zero)
  using assms by auto

subsubsection \<open>Swapping the Order of Variables\<close>

definition
  "poly_y_x p \<equiv> \<Sum>i\<le>degree p. \<Sum>j\<le>degree (coeff p i). monom (monom (coeff (coeff p i) j) i) j"

lemma poly_y_x_fix_y_deg:
  assumes ydeg: "\<forall>i\<le>degree p. degree (coeff p i) \<le> d"
  shows "poly_y_x p = (\<Sum>i\<le>degree p. \<Sum>j\<le>d. monom (monom (coeff (coeff p i) j) i) j)"
    (is "_ = sum (\<lambda>i. sum (?f i) _) _")
  unfolding poly_y_x_def
  apply (rule sum.cong,simp)
  unfolding atMost_iff
proof -
  fix i assume i: "i \<le> degree p"
  let ?d = "degree (coeff p i)"
  have "{..d} = {..?d} \<union> {Suc ?d .. d}" using ydeg[rule_format, OF i] by auto
  also have "sum (?f i) ... = sum (?f i) {..?d} + sum (?f i) {Suc ?d .. d}"
    by(rule sum.union_disjoint,auto)
  also { fix j
    assume j: "j \<in> { Suc ?d .. d }"
    have "coeff (coeff p i) j = 0" apply (rule coeff_eq_0) using j by auto
    hence "?f i j = 0" by auto
  } hence "sum (?f i) {Suc ?d .. d} = 0" by auto
  finally show "sum (?f i) {..?d} = sum (?f i) {..d}" by auto
qed

lemma poly_y_x_fixed_deg:
  fixes p :: "'a :: comm_monoid_add poly poly"
  defines "d \<equiv> Max { degree (coeff p i) | i. i \<le> degree p }"
  shows "poly_y_x p = (\<Sum>i\<le>degree p. \<Sum>j\<le>d. monom (monom (coeff (coeff p i) j) i) j)"
  apply (rule poly_y_x_fix_y_deg, intro allI impI)
  unfolding d_def
  by (subst Max_ge,auto)

lemma poly_y_x_swapped:
  fixes p :: "'a :: comm_monoid_add poly poly"
  defines "d \<equiv> Max { degree (coeff p i) | i. i \<le> degree p }"
  shows "poly_y_x p = (\<Sum>j\<le>d. \<Sum>i\<le>degree p. monom (monom (coeff (coeff p i) j) i) j)"
  using poly_y_x_fixed_deg[of p, folded d_def] sum.swap by auto

lemma poly2_poly_y_x[simp]: "poly2 (poly_y_x p) x y = poly2 p y x"
  using [[unfold_abs_def = false]]
  apply(subst(3) poly_as_sum_of_monoms[symmetric])
  apply(subst poly_as_sum_of_monoms[symmetric,of "coeff p _"])
  unfolding poly_y_x_def
  unfolding coeff_sum monom_sum
  unfolding poly2_hom.hom_sum
  apply(rule sum.cong, simp)
  apply(rule sum.cong, simp)
  unfolding poly2_monom poly_monom
  unfolding mult.assoc
  unfolding mult.commute..

context begin
private lemma poly_monom_mult:
  fixes p :: "'a :: comm_semiring_1"
  shows "poly (monom p i * q ^ j) y = poly (monom p j * [:y:] ^ i) (poly q y)"
  unfolding poly_hom.hom_mult
  unfolding poly_monom
  apply(subst mult.assoc)
  apply(subst(2) mult.commute)
  by (auto simp: mult.assoc)

lemma poly_poly_y_x:
  fixes p :: "'a :: comm_semiring_1 poly poly"
  shows "poly (poly (poly_y_x p) q) y = poly (poly p [:y:]) (poly q y)"
  apply(subst(5) poly_as_sum_of_monoms[symmetric])
  apply(subst poly_as_sum_of_monoms[symmetric,of "coeff p _"])
  unfolding poly_y_x_def
  unfolding coeff_sum monom_sum
  unfolding poly_hom.hom_sum
  apply(rule sum.cong, simp)
  apply(rule sum.cong, simp)
  unfolding atMost_iff
  unfolding poly2_monom poly_monom
  apply(subst poly_monom_mult)..

end

interpretation poly_y_x_hom: zero_hom poly_y_x by (unfold_locales, auto simp: poly_y_x_def)
interpretation poly_y_x_hom: one_hom poly_y_x by (unfold_locales, auto simp: poly_y_x_def monom_0)

lemma map_poly_sum_commute:
  assumes "h 0 = 0" "\<forall>p q. h (p + q) = h p + h q"
  shows "sum (\<lambda>i. map_poly h (f i)) S = map_poly h (sum f S)"
  apply(induct S rule: infinite_finite_induct)
  using map_poly_add[OF assms] by auto

lemma poly_y_x_const: "poly_y_x [:p:] = poly_lift p" (is "?l = ?r")
proof -
  have "?l = (\<Sum>j\<le>degree p. monom [:coeff p j:] j)"
    unfolding poly_y_x_def by (simp add: monom_0)
  also have "... = poly_lift (\<Sum>x\<le>degree p. monom (coeff p x) x)"
    unfolding poly_lift_hom.hom_sum unfolding poly_lift_def by simp
  also have "... = poly_lift p" unfolding poly_as_sum_of_monoms..
  finally show ?thesis.
qed

lemma poly_y_x_pCons:
  shows "poly_y_x (pCons a p) = poly_lift a + map_poly (pCons 0) (poly_y_x p)"
proof(cases "p = 0")
  interpret ml: map_poly_comm_monoid_add_hom "coeff_lift"..
  interpret mc: map_poly_comm_monoid_add_hom "pCons 0"..
  interpret mm: map_poly_comm_monoid_add_hom "\<lambda>x. monom x i" for i..
  { case False show ?thesis (* I know this is a worst kind of a proof... *)
    apply(subst(1) poly_y_x_fixed_deg)
    apply(unfold degree_pCons_eq[OF False])
    apply(subst(2) atLeast0AtMost[symmetric])
    apply(subst atLeastAtMost_insertL[OF le0,symmetric])
    apply(subst sum.insert,simp,simp)
    apply(unfold coeff_pCons_0)
    apply(unfold monom_0)
    apply(fold coeff_lift_hom.map_poly_hom_monom poly_lift_def)
    apply(fold poly_lift_hom.hom_sum)
    apply(subst poly_as_sum_of_monoms')
    apply(subst Max_ge,simp,simp,force,simp)
    apply(rule cong[of "\<lambda>x. poly_lift a + x", OF refl])
    apply(simp only: image_Suc_atLeastAtMost [symmetric])
    apply(unfold atLeast0AtMost)
    apply(subst sum.reindex,simp)
    apply(unfold o_def)
    apply(unfold coeff_pCons_Suc)
    apply(unfold monom_Suc)
    apply (subst poly_y_x_fix_y_deg[of _ "Max {degree (coeff (pCons a p) i) | i. i \<le> Suc (degree p)}"])
    apply (intro allI impI)
    apply (rule Max.coboundedI)
    by (auto simp: hom_distribs intro: exI[of _ "Suc _"])
  }
  case True show ?thesis by (simp add: True poly_y_x_const)
qed

lemma poly_y_x_pCons_0: "poly_y_x (pCons 0 p) = map_poly (pCons 0) (poly_y_x p)"
proof(cases "p=0")
  case False
  interpret mc: map_poly_comm_monoid_add_hom "pCons 0"..
  interpret mm: map_poly_comm_monoid_add_hom "\<lambda>x. monom x i" for i..
  from False show ?thesis
    apply (unfold poly_y_x_def degree_pCons_eq)
    apply (unfold sum.atMost_Suc_shift)
    by (simp add: hom_distribs monom_Suc)
qed simp

lemma poly_y_x_map_poly_pCons_0: "poly_y_x (map_poly (pCons 0) p) = pCons 0 (poly_y_x p)"
proof-
  let ?l = "\<lambda>i j. monom (monom (coeff (pCons 0 (coeff p i)) j) i) j"
  let ?r = "\<lambda>i j. pCons 0 (monom (monom (coeff (coeff p i) j) i) j)"
  have *: "(\<Sum>j\<le>degree (pCons 0 (coeff p i)). ?l i j) = (\<Sum>j\<le>degree (coeff p i). ?r i j)" for i
  proof(cases "coeff p i = 0")
    case True then show ?thesis by simp
  next
    case False
    show ?thesis
      apply (unfold degree_pCons_eq[OF False])
      apply (unfold sum.atMost_Suc_shift,simp)
      apply (fold monom_Suc)..
  qed
  show ?thesis
    apply (unfold poly_y_x_def)
    apply (unfold hom_distribs pCons_0_hom.degree_map_poly_hom pCons_0_hom.coeff_map_poly_hom)
    unfolding *..
qed

interpretation poly_y_x_hom: comm_monoid_add_hom "poly_y_x :: 'a :: comm_monoid_add poly poly \<Rightarrow> _"
proof (unfold_locales)
  fix p q :: "'a poly poly"
  show "poly_y_x (p + q) = poly_y_x p + poly_y_x q"
  proof (induct p arbitrary:q)
    case 0 show ?case by simp
  next
    case p: (pCons a p)
    show ?case
    proof (induct q)
      case q: (pCons b q)
      show ?case
      apply (unfold add_pCons)
      apply (unfold poly_y_x_pCons)
      apply (unfold p)
      by (simp add: poly_y_x_const ac_simps hom_distribs)
    qed auto
  qed
qed

text \<open>@{const poly_y_x} is bijective.\<close>
lemma poly_y_x_poly_lift:
  fixes p :: "'a :: comm_monoid_add poly"
  shows "poly_y_x (poly_lift p) = [:p:]"
  apply(subst poly_y_x_fix_y_deg[of _ 0],force)
  apply(subst(10) poly_as_sum_of_monoms[symmetric])
  by (auto simp add: monom_sum monom_0 hom_distribs)

lemma poly_y_x_id[simp]:
  fixes p:: "'a :: comm_monoid_add poly poly"
  shows "poly_y_x (poly_y_x p) = p"
proof (induct p)
  case 0
  then show ?case by simp
next
  case (pCons a p)
  interpret mm: map_poly_comm_monoid_add_hom "\<lambda>x. monom x i" for i..
  interpret mc: map_poly_comm_monoid_add_hom "pCons 0" ..
  have pCons_as_add: "pCons a p = [:a:] + pCons 0 p" by simp
  from pCons show ?case
    apply (unfold pCons_as_add)
    by (simp add: poly_y_x_pCons poly_y_x_poly_lift poly_y_x_map_poly_pCons_0 hom_distribs)
qed

interpretation poly_y_x_hom:
  bijective "poly_y_x :: 'a :: comm_monoid_add poly poly \<Rightarrow> _"
  by(unfold bijective_eq_bij, auto intro!:o_bij[of poly_y_x])

lemma inv_poly_y_x[simp]: "Hilbert_Choice.inv poly_y_x = poly_y_x" by auto

interpretation poly_y_x_hom: comm_monoid_add_isom poly_y_x
  by (unfold_locales, auto)

lemma pCons_as_add:
  fixes p :: "'a :: comm_semiring_1 poly"
  shows "pCons a p = [:a:] + monom 1 1 * p" by (auto simp: monom_Suc)

lemma mult_pCons_0: "(*) (pCons 0 1) = pCons 0" by auto

lemma pCons_0_as_mult:(*TODO: Move *)
  shows "pCons (0 :: 'a :: comm_semiring_1)  = (\<lambda>p. pCons 0 1 * p)" by auto

lemma map_poly_pCons_0_as_mult:
  fixes p :: "'a :: comm_semiring_1 poly poly"
  shows "map_poly (pCons 0) p = [:pCons 0 1:] * p"
  apply (subst(1) pCons_0_as_mult)
  apply (fold smult_as_map_poly) by simp

lemma poly_y_x_monom:
  fixes a :: "'a :: comm_semiring_1 poly"
  shows "poly_y_x (monom a n) = smult (monom 1 n) (poly_lift a)"
proof (cases "a = 0")
  case True then show ?thesis by simp
next
  case False
  interpret map_poly_comm_monoid_add_hom "\<lambda>x. c * x" for c :: "'a poly"..
  from False show ?thesis
    apply (unfold poly_y_x_def)
    apply (unfold degree_monom_eq)
    apply (subst(2) lessThan_Suc_atMost[symmetric])
    apply (unfold sum.lessThan_Suc)
    apply (subst sum.neutral,force)
    apply (subst(14) poly_as_sum_of_monoms[symmetric])
    apply (unfold smult_as_map_poly)
    apply (auto simp: monom_altdef[unfolded x_as_monom x_pow_n,symmetric] hom_distribs)
    done
qed

lemma poly_y_x_smult:
  fixes c :: "'a :: comm_semiring_1 poly"
  shows "poly_y_x (smult c p) = poly_lift c * poly_y_x p" (is "?l = ?r")
proof-
  have "smult c p = (\<Sum>i\<le>degree p. monom (coeff (smult c p) i) i)"
    by (metis (no_types, lifting) degree_smult_le poly_as_sum_of_monoms' sum.cong)
  also have "... = (\<Sum>i\<le>degree p. monom (c * coeff p i) i)"
    by auto
  also have "poly_y_x ... = poly_lift c * (\<Sum>i\<le>degree p. smult (monom 1 i) (poly_lift (coeff p i)))"
    by (simp add: poly_y_x_monom hom_distribs)
  also have "... = poly_lift c * poly_y_x (\<Sum>i\<le>degree p. monom (coeff p i) i)"
    by (simp add: poly_y_x_monom hom_distribs)
  finally show ?thesis by (simp add: poly_as_sum_of_monoms)
qed

interpretation poly_y_x_hom:
  comm_semiring_isom "poly_y_x :: 'a :: comm_semiring_1 poly poly \<Rightarrow> _"
proof
  fix p q :: "'a poly poly"
  show "poly_y_x (p * q) = poly_y_x p * poly_y_x q"
  proof (induct p)
    case 0
    then show ?case by simp
  next
    case p: (pCons a p)
    show ?case
      apply (unfold mult_pCons_left)
      apply (unfold hom_distribs)
      apply (unfold poly_y_x_smult)
      apply (unfold poly_y_x_pCons_0)
      apply (unfold p)
      by (simp add: poly_y_x_pCons map_poly_pCons_0_as_mult field_simps)
  qed
qed

interpretation poly_y_x_hom: comm_ring_isom "poly_y_x"..
interpretation poly_y_x_hom: idom_isom "poly_y_x"..

lemma Max_degree_coeff_pCons:
  "Max { degree (coeff (pCons a p) i) | i. i \<le> degree (pCons a p)} =
   max (degree a) (Max {degree (coeff p x) |x. x \<le> degree p})"
proof (cases "p = 0")
  case True show ?thesis unfolding True by simp
next
  case False show ?thesis
    unfolding degree_pCons_eq[OF False]
    unfolding image_Collect[symmetric]
    unfolding atMost_def[symmetric]
    apply(subst(1) atLeast0AtMost[symmetric])
    unfolding atLeastAtMost_insertL[OF le0,symmetric]
    unfolding image_insert
    apply(subst Max_insert,simp,simp)
    unfolding image_Suc_atLeastAtMost [symmetric]
    unfolding image_image
    unfolding atLeast0AtMost by simp
qed

lemma degree_poly_y_x:
  fixes p :: "'a :: comm_ring_1 poly poly"
  assumes "p \<noteq> 0"
  shows "degree (poly_y_x p) = Max { degree (coeff p i) | i. i \<le> degree p }"
    (is "_ = ?d p")
  using assms
proof(induct p)
  interpret rhm: map_poly_comm_ring_hom coeff_lift ..
  let ?f = "\<lambda>p i j. monom (monom (coeff (coeff p i) j) i) j"
  case (pCons a p)
    show ?case
    proof(cases "p=0")
      case True show ?thesis unfolding True unfolding poly_y_x_pCons by auto
      next case False
        note IH = pCons(2)[OF False]
        let ?a = "poly_lift a"
        let ?p = "map_poly (pCons 0) (poly_y_x p)"
        show ?thesis
        proof(cases rule:linorder_cases[of "degree ?a" "degree ?p"])
          case less
            have dle: "degree a \<le> degree (poly_y_x p)"
              apply(rule le_trans[OF less_imp_le[OF less[simplified]]])
              using degree_map_poly_le by auto
            show ?thesis
              unfolding poly_y_x_pCons
              unfolding degree_add_eq_right[OF less]
              unfolding Max_degree_coeff_pCons
              unfolding IH[symmetric]
              unfolding max_absorb2[OF dle]
              apply (rule degree_map_poly) by auto
          next case equal
            have dega: "degree ?a = degree a" by auto
            have degp: "degree (poly_y_x p) = degree a"
              using equal[unfolded dega]
              using degree_map_poly[of "pCons 0" "poly_y_x p"] by auto
            have *: "degree (?a + ?p) = degree a"
            proof(cases "a = 0")
              case True show ?thesis using equal unfolding True by auto
              next case False show ?thesis
                apply(rule antisym)
                  apply(rule degree_add_le, simp, fold equal, simp)
                apply(rule le_degree)
                unfolding coeff_add
                using False
                by auto
            qed
            show ?thesis unfolding poly_y_x_pCons
              unfolding *
              unfolding Max_degree_coeff_pCons
              unfolding IH[symmetric]
              unfolding degp by auto
          next case greater
            have dge: "degree a \<ge> degree (poly_y_x p)"
              apply(rule le_trans[OF _ less_imp_le[OF greater[simplified]]])
              by auto
            show ?thesis
              unfolding poly_y_x_pCons
              unfolding degree_add_eq_left[OF greater]
              unfolding Max_degree_coeff_pCons
              unfolding IH[symmetric]
              unfolding max_absorb1[OF dge] by simp
       qed
   qed
qed auto

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> len_of TYPE('a)")
    prefer 2
    apply (rule_tac x=i in exI)
    apply clarsimp
   apply (subgoal_tac "\<exists>j < len_of TYPE('a). j < n \<and> len_of TYPE('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 - len_of TYPE('a)" in exI)
   apply clarsimp
   apply arith
  apply (rule_tac x="len_of TYPE('a) - n + i" in exI)
  apply clarsimp
  apply arith
  done

lemma unat_power_lower [simp]:
  assumes nv: "n < len_of TYPE('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> len_of TYPE('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 < len_of TYPE('a)"
  show ?thesis
    unfolding is_aligned_def
  proof (rule dvdI [where k = "unat k mod 2 ^ (len_of TYPE('a) - n)"])
    from xv
    have "unat x = (unat (2::word32) ^ n * unat k) mod 2 ^ len_of TYPE('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 ^ (len_of TYPE('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 ^ (len_of TYPE('a) - n))" .
  qed
next
  assume "\<not> n < len_of TYPE('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 ^ (len_of TYPE('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 ^ (len_of TYPE('a) - n)"
    proof (rule nat_power_less_diff)
      have "unat w < 2 ^ size w" unfolding word_size ..
      then have "unat w < 2 ^ len_of TYPE('a)" by simp
      with wv show "2 ^ n * q < 2 ^ len_of TYPE('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 ^ (len_of TYPE('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> len_of TYPE('a)"
  shows   "to_bl w = (take (len_of TYPE('a) - n) (to_bl w)) @ replicate n False"
proof -
  from nv have rl: "\<And>q. q < 2 ^ (len_of TYPE('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> len_of TYPE('a)"
  shows "drop (len_of TYPE('a) - n) (to_bl w) = replicate n False"
proof -
  have "to_bl w = take (len_of TYPE('a) - n) (to_bl w) @ replicate n False"
    by (rule is_aligned_replicate) fact+
  then have "drop (len_of TYPE('a) - n) (to_bl w) = drop (len_of TYPE('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 (len_of TYPE('a) - n) False @ drop (len_of TYPE('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 (len_of TYPE('a) - n) (to_bl w)) @ (drop (len_of TYPE('a) - n) (to_bl off))"
proof cases
  assume nv: "n \<le> len_of TYPE('a)"
  show ?thesis
  proof (subst aligned_bl_add_size, simp_all only: word_size)
    show "drop (len_of TYPE('a) - n) (to_bl w) = replicate n False"
      by (subst is_aligned_replicate [OF aligned nv]) (simp add: word_size)

    from offv show "take (len_of TYPE('a) - n) (to_bl off) =
                    replicate (len_of TYPE('a) - n) False"
      by (subst less_is_drop_replicate, assumption) simp
  qed fact
next
  assume "\<not> n \<le> len_of TYPE('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 < len_of TYPE('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 ^ (len_of TYPE('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 ^ (len_of TYPE('a) - (m + k))"
      by (auto elim: is_alignedE)

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

    have l2: "2 ^ m * q2 < 2 ^ len_of TYPE('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 ^ len_of TYPE('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 ^ len_of TYPE('a)"
        by (subst unat_word_ariths(1)) simp

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

      also
      have "\<dots> = 2 ^ m * ((2 ^ k * q1 +  q2) mod 2 ^ (len_of TYPE('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 < len_of TYPE('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 < len_of TYPE('a)"
  from mv obtain q where mq: "m + q = len_of TYPE('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 ^ len_of TYPE('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 < len_of TYPE('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 < len_of TYPE('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 < len_of TYPE('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 ^ len_of TYPE('a)"
proof -
  have szv: "sz < len_of TYPE('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 ^ (len_of TYPE('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 ^ len_of TYPE('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<len_of TYPE('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<len_of TYPE('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 = len_of TYPE('a) - n")
   apply (simp add: replicate_not_True)
  apply (drule arg_cong [where f=length])
  apply simp
  done

lemma to_bl_2p:
  "n < len_of TYPE('a) \<Longrightarrow>
   to_bl ((2::'a::len word) ^ n) =
   replicate (len_of TYPE('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 < len_of TYPE('a)
   then take (len_of TYPE('a)-Suc n) (to_bl x) @ (\<not>rev (to_bl x)!n) # drop (len_of TYPE('a)-n) (to_bl x)
   else to_bl x)"
proof -
  have x: "to_bl x = take (len_of TYPE('a)-Suc n) (to_bl x) @ drop (len_of TYPE('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 map2_def 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' < len_of TYPE('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> len_of TYPE('a) - Suc n \<le> len_of TYPE('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' < len_of TYPE('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> len_of TYPE('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 ^ len_of TYPE('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 < len_of TYPE('a); off < 2 ^ sz \<rbrakk>
         \<Longrightarrow> unat ptr + off < 2 ^ len_of TYPE('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 < len_of TYPE('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 < len_of TYPE('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 < len_of TYPE('a)"
  and    off: "off \<le> 2 ^ sz"
  shows  "unat ptr + off \<le> 2 ^ len_of TYPE('a)"
proof -
  from al obtain q where ptrq: "ptr = 2 ^ sz * of_nat q" and
    qv: "q < 2 ^ (len_of TYPE('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 ^ len_of TYPE('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' < len_of TYPE('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


theory BinPacking imports Complex_Main
begin
\<comment>\<open> List.sum is defined indirectly via (finite) sets.\<close>
definition sum :: "'a::comm_monoid_add list \<Rightarrow> 'a" where
  "sum xs = foldr (+) xs 0"

\<comment>\<open>The standardised bin capacity.\<close>
abbreviation cp :: real where
  "cp \<equiv> 1"

\<comment>\<open>Takes a list of bin assignments and a weight index,
   and returns the bin number.\<close>
definition bin :: "nat list \<Rightarrow> nat \<Rightarrow> nat" where
  "bin bs i = bs ! i"

\<comment>\<open>Takes a list of bin assignments,
   and returns the total number of bins.\<close>
definition bins :: "nat list \<Rightarrow> nat" where
  "bins bs = card (set bs)"

\<comment>\<open>Takes a list of weights and a partially filled bin,
   and returns a list of bin assignments.\<close>
definition alg :: "real list \<Rightarrow> nat list" where
  "alg = undefined"

abbreviation ws1 :: "real list" where "ws1 == [0.2,0.5,0.4,0.7,0.1,0.3,0.8]"
value "alg ws1 = [0,1,1,2,1,2,0]"

lemma assigns_all1: "length (alg ws) = length ws"
  sorry

lemma assigns_all2: "i < length ws \<Longrightarrow> bin (alg ws) i \<in> set (alg ws)"
  sorry

\<comment>\<open>Takes a list of weights and bin assignments and a bin number,
   and returns the used capacity.\<close>
definition bu :: "(real \<times> nat) list \<Rightarrow> nat \<Rightarrow> real" where
  "bu wb b = sum [w. (w,b') \<leftarrow> wb, b' = b]"

lemma [simp]: "bu [] b = 0" by (simp add: bu_def)
lemma [simp]: "bu ((w,b) # wb) b = w + bu wb b" by (simp add: bu_def)
lemma [simp]: "b \<noteq> b' \<Longrightarrow> bu ((w,b') # wb) b = bu wb b" by (simp add: bu_def)

lemma respects_cp: "list_all (\<lambda>w. w \<le> cp) ws \<Longrightarrow> bu (zip ws (alg ws)) b \<le> cp"
  sorry
end


theory Frac
imports CoreStructures HOL.Rat
begin

subsection \<open> Frac and DFrac \<close>

text \<open> Fractions camera/RA \<close>
text \<open> Positive rational numbers, that are only valid $<= 1$. \<close>
typedef frac = "{p::rat. 0<p}" by (simp add: gt_ex)
setup_lifting type_definition_frac
lemmas [simp] = Rep_frac_inverse Rep_frac_inject
lemmas [simp, intro!] = Rep_frac[unfolded mem_Collect_eq]

instantiation frac :: one begin
lift_definition one_frac :: frac is "1::rat" by simp
instance ..
end
lemmas [simp] = one_frac.rep_eq one_frac_def

instantiation frac :: ofe begin
definition n_equiv_frac :: "nat \<Rightarrow> frac \<Rightarrow> frac \<Rightarrow> bool" where "n_equiv_frac _ \<equiv> (=)"
definition ofe_eq_frac :: "frac \<Rightarrow> frac \<Rightarrow> bool" where "ofe_eq_frac \<equiv> (=)"
instance by standard (auto simp: n_equiv_frac_def ofe_eq_frac_def)
end
instance frac :: discrete by standard (auto simp: n_equiv_frac_def ofe_eq_frac_def)

instantiation frac :: camera begin
lift_definition valid_raw_frac :: "frac \<Rightarrow> sprop" is "\<lambda>p _. (p\<le>1)" .
lift_definition pcore_frac :: "frac \<Rightarrow> frac option" is "\<lambda>_. None" by (rule option.pred_inject(1))
lift_definition op_frac :: "frac \<Rightarrow> frac \<Rightarrow> frac" is "(+)" by simp
instance proof
show "non_expansive (valid_raw::frac \<Rightarrow> sprop)"
  by (rule non_expansiveI) (auto simp: valid_raw_frac_def n_equiv_sprop_def n_equiv_frac_def)
next
show "non_expansive (pcore::frac \<Rightarrow> frac option)" by (rule non_expansiveI)
  (auto simp: pcore_frac_def n_equiv_option_def n_equiv_frac_def)
next
show "non_expansive2 (op::frac \<Rightarrow> frac \<Rightarrow> frac)" by (rule non_expansive2I)
  (auto simp: op_frac_def n_equiv_frac_def)
next
fix a b c :: frac
show "a \<cdot> b \<cdot> c = a \<cdot> (b \<cdot> c)" by (auto simp: op_frac_def)
  (metis (mono_tags) Abs_frac_inverse Rep_frac ab_semigroup_add_class.add_ac(1) op_frac.rep_eq)
next
fix a b :: frac
show "a \<cdot> b = b \<cdot> a" by (auto simp: op_frac_def add.commute)
fix a b :: frac
fix n
show "Rep_sprop (valid_raw (a \<cdot> b)) n \<Longrightarrow> Rep_sprop (valid_raw a) n"
  by (auto simp: valid_raw_frac.rep_eq op_frac.rep_eq)
  (metis Rep_frac add_le_same_cancel1 dual_order.trans linorder_not_less mem_Collect_eq nle_le)
qed (auto simp: op_frac_def valid_raw_frac_def n_equiv_frac_def pcore_frac_def)
end

instance frac :: dcamera by (standard; auto simp: valid_raw_frac_def valid_def)

lemma valid_frac: "valid (q::frac) = n_valid q n"
  by (auto simp: valid_def valid_raw_frac_def)

instantiation frac :: order begin
lift_definition less_frac :: "frac \<Rightarrow> frac \<Rightarrow> bool" is "(<)" .
lift_definition less_eq_frac :: "frac \<Rightarrow> frac \<Rightarrow> bool" is "(\<le>)" .
instance by standard (auto simp: less_frac.rep_eq less_eq_frac.rep_eq)
end

lemma frac_valid: "valid (p\<cdot>q) \<Longrightarrow> ((p::frac)<1)"
  by (auto simp: valid_def valid_raw_frac.rep_eq less_eq_frac.rep_eq less_frac.rep_eq op_frac.rep_eq)
  (metis Rep_frac less_add_same_cancel1 mem_Collect_eq one_frac.rep_eq one_frac_def order_less_le_trans)

lemma one_op: "1\<cdot>q > (1::frac)"
  by (auto simp: less_frac_def op_frac.rep_eq)

lemma frac_not_valid: "(p::frac)=1 \<Longrightarrow> \<not> valid (p\<cdot>q)"
  using one_op frac_valid by auto

lemma frac_own_incl: "incl (p::frac) q \<longleftrightarrow> (p<q)"
proof (auto simp: incl_def op_frac_def less_frac.rep_eq; transfer; auto simp: Abs_frac_inverse)
  fix p q
  assume assms: "0 < p" "p < Rep_frac q"
  have "(a::rat) < b \<Longrightarrow> \<exists>c. b=a+c" for a b by algebra
  with assms(2) obtain c where rep: "Rep_frac q = p+c" by auto
  then have "q = Abs_frac (p+c)" by (metis Rep_frac_inverse)
  with rep assms(2) show "\<exists>c>0. q = Abs_frac (p + c)" by auto
qed

text \<open> Discardable Fractions Camera \<close>
text \<open> This models fractional ownership which can be given up on.  \<close>

datatype dfrac = DfracOwn frac | DfracDiscarded | DfracBoth frac

lemmas dfrac_ex2 = dfrac.exhaust[case_product dfrac.exhaust]
lemmas dfrac_ex3 = dfrac.exhaust[case_product dfrac_ex2]

instantiation dfrac :: ofe begin
definition n_equiv_dfrac :: "nat \<Rightarrow> dfrac \<Rightarrow> dfrac \<Rightarrow> bool" where [simp]: "n_equiv_dfrac _ \<equiv> (=)"
definition ofe_eq_dfrac :: "dfrac \<Rightarrow> dfrac \<Rightarrow> bool" where [simp]: "ofe_eq_dfrac \<equiv> (=)"
instance by standard auto
end
instance dfrac :: discrete by standard auto

fun dfrac_add :: "dfrac \<Rightarrow> dfrac \<Rightarrow> dfrac" where
  "dfrac_add (DfracOwn q) (DfracOwn q') = DfracOwn (q \<cdot> q')"
| "dfrac_add (DfracOwn q) DfracDiscarded = DfracBoth q"
| "dfrac_add (DfracOwn q) (DfracBoth q') = DfracBoth (q \<cdot> q')"
| "dfrac_add DfracDiscarded (DfracOwn q') = DfracBoth q'"
| "dfrac_add DfracDiscarded DfracDiscarded = DfracDiscarded"
| "dfrac_add DfracDiscarded (DfracBoth q') = DfracBoth q'"
| "dfrac_add (DfracBoth q) (DfracOwn q') = DfracBoth (q \<cdot> q')"
| "dfrac_add (DfracBoth q) DfracDiscarded = DfracBoth q"
| "dfrac_add (DfracBoth q) (DfracBoth q') = DfracBoth (q \<cdot> q')"

instantiation dfrac :: camera begin
lift_definition valid_raw_dfrac :: "dfrac \<Rightarrow> sprop" is
  "\<lambda>dq. case dq of DfracOwn q \<Rightarrow> valid_raw q | DfracDiscarded \<Rightarrow> sTrue | DfracBoth q \<Rightarrow> sPure (q<1)" .
definition pcore_dfrac :: "dfrac \<Rightarrow> dfrac option" where "pcore_dfrac dq \<equiv>
  case dq of DfracOwn _ \<Rightarrow> None | _ \<Rightarrow> Some DfracDiscarded"
definition op_dfrac :: "dfrac \<Rightarrow> dfrac \<Rightarrow> dfrac" where "op_dfrac \<equiv> dfrac_add"
instance proof
show "non_expansive (valid_raw::dfrac \<Rightarrow> sprop)"
  by (rule non_expansiveI) (auto simp: valid_raw_dfrac_def ofe_refl split: dfrac.splits)
next
show "non_expansive (pcore::dfrac \<Rightarrow> dfrac option)"
  by (rule non_expansiveI) (auto simp: pcore_dfrac_def n_equiv_option_def split: dfrac.splits)
next
show "non_expansive2 (op::dfrac \<Rightarrow> dfrac \<Rightarrow> dfrac)"
  by (rule non_expansive2I) (auto simp: op_dfrac_def)
next
fix a b c :: dfrac
show "a \<cdot> b \<cdot> c = a \<cdot> (b \<cdot> c)" by (cases a b c rule: dfrac_ex3) (auto simp: op_dfrac_def camera_assoc)
next
fix a b :: dfrac
show "a \<cdot> b = b \<cdot> a" by (cases a; cases b) (auto simp: op_dfrac_def camera_comm)
next
fix a a' :: dfrac
show "pcore a = Some a' \<Longrightarrow> a' \<cdot> a = a" by (cases a; cases a') (auto simp: pcore_dfrac_def op_dfrac_def)
next
fix a a' :: dfrac
show "pcore a = Some a' \<Longrightarrow> pcore a' = pcore a" by (cases a; cases a') (auto simp: pcore_dfrac_def)
next
fix a a' b :: dfrac
show "pcore a = Some a' \<Longrightarrow> \<exists>c. b = a \<cdot> c \<Longrightarrow> \<exists>b'. pcore b = Some b' \<and> (\<exists>c. b' = a' \<cdot> c)"
  by (cases a a' b rule: dfrac_ex3; auto simp: pcore_dfrac_def op_dfrac_def)
  (metis dfrac.exhaust dfrac.simps(6) dfrac_add.simps(4-9) dfrac.distinct(3))+
next
fix a b :: dfrac
fix n
show "Rep_sprop (valid_raw (a \<cdot> b)) n \<Longrightarrow> Rep_sprop (valid_raw a) n"
  by (cases a; cases b;auto simp: valid_raw_dfrac_def op_dfrac_def camera_valid_op Abs_frac_inverse less_frac.rep_eq valid_raw_frac.rep_eq)
  (metis Rep_frac add_le_same_cancel1 dual_order.strict_trans linorder_not_le mem_Collect_eq op_frac.rep_eq camera_valid_op less_eq_rat_def valid_raw_frac.rep_eq)+
next
fix a b1 b2 :: dfrac
fix n
show "Rep_sprop (valid_raw a) n \<Longrightarrow> n_equiv n a (b1 \<cdot> b2) \<Longrightarrow> \<exists>c1 c2. a = c1 \<cdot> c2 \<and> n_equiv n c1 b1 \<and> n_equiv n c2 b2"
  by (cases a; cases b1; cases b2) (auto simp: valid_raw_dfrac_def op_dfrac_def)
qed
end

instance dfrac :: dcamera
  apply (standard; auto simp: valid_raw_dfrac_def valid_def  split: dfrac.splits)
  using d_valid[simplified valid_def] by fast

lemma dfrac_own_incl: "incl (DfracOwn p) (DfracOwn q) \<longleftrightarrow> (p<q)"
proof (standard; unfold incl_def op_dfrac_def)
  assume "\<exists>c. DfracOwn q = dfrac_add (DfracOwn p) c"
  then obtain c where "DfracOwn q = dfrac_add (DfracOwn p) (DfracOwn c)"
    by (metis camera_assoc camera_comm dfrac.distinct(3) dfrac.exhaust dfrac_add.simps(4) dfrac_add.simps(6) op_dfrac_def)
  then have "q = p\<cdot>c" by simp
  then have "incl p q" by (auto simp: incl_def)
  then show "p<q" by (simp add: frac_own_incl)
next
  assume "p<q"
  then obtain c where "q=p\<cdot>c" using incl_def frac_own_incl by metis
  then have "DfracOwn q = dfrac_add (DfracOwn p) (DfracOwn c)" by simp
  then show "\<exists>c. DfracOwn q = dfrac_add (DfracOwn p) c" by fast
qed

lemma valid_dfrac: "valid (q::dfrac) = n_valid q n"
  apply (simp add: valid_def valid_raw_dfrac_def split: dfrac.splits)
  using valid_frac by auto

lemma discarded_core_id: "pcore DfracDiscarded = Some DfracDiscarded"
  by (simp add: pcore_dfrac_def)

lemma valid_dfrac_own: "valid (DfracOwn 1)" unfolding valid_def valid_raw_dfrac_def apply simp
  using one_frac.rep_eq valid_raw_frac.rep_eq by auto

lemma dfrac_valid_own_r: "valid (dq \<cdot> DfracOwn q) \<Longrightarrow> (q < 1)"
apply (cases dq) apply (simp_all add: op_dfrac_def valid_raw_dfrac_def valid_def split: dfrac.splits)
apply (metis camera_comm frac_valid one_frac_def valid_frac)
unfolding op_frac_def
by (metis Rep_frac dual_order.strict_trans less_add_same_cancel2 less_frac.rep_eq mem_Collect_eq op_frac.rep_eq op_frac_def)

lemma dfrac_valid_own_l: "valid (DfracOwn q \<cdot> dq) \<Longrightarrow> (q < 1)"
  using dfrac_valid_own_r camera_comm by metis

lemma dfrac_not_valid_own: "\<not> valid (DfracOwn 1 \<cdot> dq)"
apply (cases dq) apply (simp_all add: valid_def valid_raw_dfrac.rep_eq op_dfrac_def split: dfrac.splits)
apply (metis frac_not_valid one_frac_def valid_frac)
by (meson dual_order.asym frac_own_incl incl_def)

lemma dfrac_discard_update: "dq \<leadsto> {DfracDiscarded}"
proof (auto simp: camera_upd_def)
fix x n
assume assm: "n_valid (dq \<cdot> x) n"
show "n_valid (DfracDiscarded \<cdot> x) n"
proof (cases x)
  case (DfracOwn x1)
  with assm have "x1<Abs_frac 1" using dfrac_valid_own_r by (metis one_frac_def valid_dfrac)
  with DfracOwn show ?thesis by (auto simp: op_dfrac_def valid_def valid_raw_dfrac.rep_eq)
next
  case DfracDiscarded
  then show ?thesis by (auto simp: op_dfrac_def valid_raw_dfrac.rep_eq valid_def)
next
  case (DfracBoth x3)
  from assm have "valid x" unfolding valid_def using camera_comm camera_valid_op by (metis assm dcamera_valid_iff)
  with DfracBoth show ?thesis by (auto simp: valid_def op_dfrac_def valid_raw_dfrac.rep_eq)
qed
qed

lemmas [simp del] = one_frac.rep_eq one_frac_def
end