theory nat_pow_times
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) y = y"
| "plus (S n) y = S (plus n y)"

fun mult :: "Nat => Nat => Nat" where
"mult (Z) y = Z"
| "mult (S n) y = plus y (mult n y)"

fun pow :: "Nat => Nat => Nat" where
"pow x (Z) = S Z"
| "pow x (S m) = mult x (pow x m)"

(*hipster plus mult pow *)

theorem x0 :
  "!! (x :: Nat) (y :: Nat) (z :: Nat) .
     (pow x (plus y z)) = (mult (pow x y) (pow x z))"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

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)
 *)

theory Aligned
imports WordLib MoreDivides WordSetup
begin

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

lemma list_of_false:
  "True \<notin> set xs \<Longrightarrow> xs = replicate (length xs) False"
  by (induct xs, simp_all)

lemma eq_zero_set_bl: "(w = 0) = (True \<notin> set (to_bl w))"
  apply (subst word_bl.Rep_inject[symmetric])
  apply (subst to_bl_0)
  apply (rule iffI)
   apply clarsimp
  apply (drule list_of_false)
  apply simp
  done

lemmas and_bang = word_and_nth

lemma diff_diff_less: "(i < m - (m - (n :: nat))) = (i < m \<and> i < n)"
  apply (case_tac "n \<le> m")
   apply fastforce+
  done

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"
  apply (subst word_unat_power)
  apply (subst unat_of_nat)
  apply (subst mod_less)
   apply (simp add: nv)
  apply simp
  done

lemma power_overflow:
  "n \<ge> len_of TYPE('a) \<Longrightarrow> 2 ^ n = (0 :: 'a::len word)"
  apply (subgoal_tac "\<exists>m. n = (len_of TYPE ('a)) + m")
   apply safe
   apply (simp only: power_add word_pow_0)
   apply simp
  apply (rule exI[where x="n - len_of TYPE ('a)"])
  apply simp
  done

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"
  apply (simp add: is_aligned_def)
  apply (rule dvd_trans)
   prefer 2
   apply assumption
  apply (simp add: le_imp_power_dvd)
  done

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
  thus ?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
    thus ?thesis using Suc by simp
  next
    case (Suc m')
    thus ?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 ..
      hence "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
    hence "w = of_nat (2 ^ n * q)" by (subst word_unat.Rep_inverse [symmetric])
    thus "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"
      apply (subst shiftl_t2n [symmetric])
      apply (subst bl_shiftl)
      apply (simp add: min_def word_size)
      done

    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+
  hence "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)"
proof -
  show ?thesis
    apply (subst less_mask_eq [OF lt, symmetric])
    apply (subst bl_and_mask)
    apply simp
    done
qed

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 nat_less_power_trans:
  fixes n :: nat
  assumes nv: "n < 2 ^ (m - k)"
  and     kv: "k \<le> m"
  shows "2 ^ k * n < 2 ^ m"
proof (rule order_less_le_trans)
  show "2 ^ k * n < 2 ^ k * 2 ^ (m - k)"
    by (rule mult_less_mono2 [OF nv zero_less_power]) simp

  show "(2::nat) ^ k * 2 ^ (m - k) \<le> 2 ^ m" using nv kv
    by (subst power_add [symmetric]) simp
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)"
      apply -
      apply (erule ssubst)+
      apply (subst unat_of_nat)
      apply (subst mod_less [OF l1])
      apply (subst unat_of_nat)
      apply (subst mod_less [OF l2])
      apply (subst power_add)
      apply (subst add_mult_distrib2)
      apply simp
      done

    (* (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
      hence "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))"
        apply (subst mult_mod_right)
        apply (subst power_add [symmetric])
        apply (subst le_add_diff_inverse
                     [OF order_trans[OF lt order_less_imp_le[OF nlt]]])
        apply (rule refl)
        done

      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\<Colon>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 mod_div_equality)

    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

  thus ?thesis by (unfold is_aligned_def)
next
  assume "\<not> m < len_of TYPE('a)"
  thus ?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
    apply -
    apply (rule word_unat.Rep_eqD)
    apply (subst unat_mod)
    apply (simp add: dvd_eq_mod_eq_0)
    done
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)"
    apply (rule ccontr)
    using off
    by (clarsimp simp: not_less p2_eq_0[THEN iffD2])

  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
    thus ?thesis using off ptrq qv
      by clarsimp
  next
    case False
    hence 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_1: "to_bl (1::'a::len word) = replicate (len_of TYPE('a) - 1) False @ [True]"
proof -
  have "to_bl (1 :: 'a::len word) = to_bl (mask 1 :: 'a::len word)"
    by (simp add: mask_def)

  also have "\<dots> = replicate (len_of TYPE('a) - 1) False @ [True]"
    apply (subst to_bl_mask)
    apply (clarsimp simp add: min_def)
    apply (case_tac "len_of TYPE('a)", simp)
    apply simp
    done

  finally show ?thesis .
qed

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 thus ?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])
     apply assumption
    apply simp
   apply (rule refl)
  apply (subgoal_tac "\<not> len_of TYPE('a) - Suc n \<le> len_of TYPE('a) - n'")
   prefer 2
   apply arith
  apply (simp add: min_def)
  apply (subst replicate_Suc [symmetric])
  apply (subst replicate_add [symmetric])
  apply simp
  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_le_dividend)
  apply (subst(asm) unat_of_nat_len)
   apply (erule order_less_trans)
   apply (erule power_strict_increasing)
   apply simp
  apply assumption
  done

lemma rsubst:
  "\<lbrakk> P s; s = t \<rbrakk> \<Longrightarrow> P t"
  by simp

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
    thus ?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
    hence 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"
  apply (simp add: and_not_mask)
  apply (erule is_aligned_weaken[rotated])
  apply (rule is_aligned_shift)
  done

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]
  apply (simp add: unat_eq_0 word_size)
  done

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

end


theory Co_Snapshot
  imports
    Snapshot
    Ordered_Resolution_Prover.Lazy_List_Chain
begin

section \<open>Extension to infinite traces\<close>

text \<open>The computation locale assumes that there already exists a known
final configuration $c'$ to the given initial $c$ and trace $t$. However,
we can show that the snapshot algorithm must terminate correctly even if
the underlying computation itself does not terminate. We relax
the trace relation to allow for a potentially infinite number of ``intermediate'' events, and
show that the algorithm's correctness still holds when imposing the same constraints
as in the computation locale.

We use a preexisting theory of lazy list chains by Schlichtkrull, Blanchette,
Traytel and Waldmann~\<^cite>\<open>"Ordered_Resolution_Prover-AFP"\<close> to construct infinite traces.\<close>

primrec ltake where
  "ltake 0 t = []"
| "ltake (Suc i) t = (case t of LNil \<Rightarrow> [] | LCons x t' \<Rightarrow> x # ltake i t')"

primrec ldrop where
  "ldrop 0 t = t"
| "ldrop (Suc i) t = (case t of LNil \<Rightarrow> LNil | LCons x t' \<Rightarrow> ldrop i t')"

lemma ltake_LNil[simp]: "ltake i LNil = []"
  by (induct i) auto

lemma ltake_LCons: "0 < i \<Longrightarrow> ltake i (LCons x t) = x # ltake (i - 1) t"
  by (induct i) auto

lemma take_ltake: "i \<le> j \<Longrightarrow> take i (ltake j xs) = ltake i xs"
  by (induct j arbitrary: i xs) (auto simp: le_Suc_eq take_Cons' ltake_LCons split: llist.splits if_splits)

lemma nth_ltake [simp]: "i < min n (llength xs) \<Longrightarrow> (ltake n xs) ! i = lnth xs i"
  by (induct n arbitrary: i xs)
    (auto simp: nth_Cons' gr0_conv_Suc eSuc_enat[symmetric] split: llist.splits)

lemma length_ltake[simp]: "length (ltake i xs) = (case llength xs of \<infinity> \<Rightarrow> i | enat m \<Rightarrow> min i m)"
  by (induct i arbitrary: xs)
    (auto simp: zero_enat_def[symmetric] eSuc_enat split: llist.splits enat.splits)

lemma ltake_prepend:
  "ltake i (prepend xs t) = (if i \<le> length xs then take i xs else xs @ ltake (i - length xs) t)"
proof (induct i arbitrary: xs t)
  case 0
  then show ?case
    by (cases xs) auto
next
  case (Suc i)
  then show ?case
    by (cases xs) auto
qed

lemma prepend_ltake_ldrop_id: "prepend (ltake i t) (ldrop i t) = t"
  by (induct i arbitrary: t) (auto split: llist.splits)

context distributed_system
begin

coinductive cotrace where
    cotr_init: "cotrace c LNil"
  | cotr_step: "\<lbrakk> c \<turnstile> ev \<mapsto> c'; cotrace c' t \<rbrakk> \<Longrightarrow> cotrace c (LCons ev t)"

lemma cotrace_trace: "cotrace c t \<Longrightarrow> \<exists>!c'. trace c (ltake i t) c'"
proof (induct i arbitrary: c t)
  case (Suc i)
  then show ?case
  proof (cases t)
    case (LCons ev t')
    with Suc(2) obtain c' where "c \<turnstile> ev \<mapsto> c'" "cotrace c' t'"
      by (auto elim: cotrace.cases)
    with Suc(1)[OF \<open>cotrace c' t'\<close>] show ?thesis
      by (auto simp: LCons elim: trace.intros(2) elim: trace.cases trace_and_start_determines_end)
  qed (auto intro: trace.intros elim: trace.cases)
qed (auto simp: zero_enat_def[symmetric] intro: trace.intros elim: trace.cases)

definition cos where "cos c t i = s c (ltake i t) i"

lemma cotrace_trace_cos: "cotrace c t \<Longrightarrow> trace c (ltake i t) (cos c t i)"
  unfolding cos_def s_def
  by (subst take_ltake, auto dest!: cotrace_trace[of _ _ i] elim!: theI')

lemma s_0[simp]: "s c t 0 = c"
  unfolding s_def
  by (auto intro!: the_equality[where P = "trace c []"] trace.intros elim: trace.cases)

lemma s_chop: "i \<le> length t \<Longrightarrow> s c t i = s c (take i t) i"
  unfolding s_def
  by auto

lemma cotrace_prepend: "trace c t c' \<Longrightarrow> cotrace c' u \<Longrightarrow> cotrace c (prepend t u)"
  by (induct c t c' rule: trace.induct) (auto intro: cotrace.intros)

lemma s_Cons: "\<exists>c''. trace c' xs c'' \<Longrightarrow> c \<turnstile> ev \<mapsto> c' \<Longrightarrow> s c (ev # xs) (Suc i) = s c' xs i"
  by (smt exists_trace_for_any_i take_Suc_Cons tr_step trace_and_start_determines_end)

lemma cotrace_ldrop: "cotrace c t \<Longrightarrow> i \<le> llength t \<Longrightarrow> cotrace (cos c t i) (ldrop i t)"
proof (induct i arbitrary: c t)
  case (Suc i)
  then show ?case
  proof (cases t)
    case (LCons ev t')
    with Suc(2) obtain c' where "c \<turnstile> ev \<mapsto> c'" "cotrace c' t'"
      by (auto elim: cotrace.cases)
    with Suc(1)[OF \<open>cotrace c' t'\<close>] Suc(3) show ?thesis
      by (auto simp: LCons cos_def eSuc_enat[symmetric] s_chop[symmetric] s_Cons[OF cotrace_trace'])
  qed (auto intro: cotrace.intros)
qed (auto simp: zero_enat_def[symmetric] cos_def intro: cotrace.intros)

end

locale cocomputation = distributed_system +
  fixes
    init :: "('a, 'b, 'c) configuration"
  assumes
    finite_channels:
      "finite {i. \<exists>p q. channel i = Some (p, q)}" and
    strongly_connected_raw:
      "\<forall>p q. (p \<noteq> q) \<longrightarrow>
         (tranclp (\<lambda>p q. (\<exists>i. channel i = Some (p, q)))) p q" and

    at_least_two_processes:
      "card (UNIV :: 'a set) > 1" and
    finite_processes:
      "finite (UNIV :: 'a set)" and

    no_initial_Marker:
      "\<forall>i. (\<exists>p q. channel i = Some (p, q))
      \<longrightarrow> Marker \<notin> set (msgs init i)" and
    no_msgs_if_no_channel:
      "\<forall>i. channel i = None \<longrightarrow> msgs init i = []" and
    no_initial_process_snapshot:
      "\<forall>p. \<not> has_snapshotted init p" and
    no_initial_channel_snapshot:
      "\<forall>i. channel_snapshot init i = ([], NotStarted)" and

    valid: "\<exists>t. cotrace init t" and
    l1: "\<forall>t i cid. cotrace init t
                 \<and> Marker \<in> set (msgs (cos init t i) cid)
      \<longrightarrow> (\<exists>j \<le> llength t. j \<ge> i \<and> Marker \<notin> set (msgs (cos init t j) cid))" and
    l2: "\<forall>t p. cotrace init t
      \<longrightarrow> (\<exists>i \<le> llength t. has_snapshotted (cos init t i) p)"
begin

abbreviation coS where "coS \<equiv> cos init"

definition "some_snapshot t p = (SOME i. has_snapshotted (coS t i) p \<and> i \<le> llength t)"

lemma has_snapshotted:
  "cotrace init t \<Longrightarrow> has_snapshotted (coS t (some_snapshot t p)) p \<and> some_snapshot t p \<le> llength t"
  unfolding some_snapshot_def by (rule someI_ex) (auto dest!: l2[rule_format])

lemma cotrace_cos: "cotrace init t \<Longrightarrow> j < llength t \<Longrightarrow>
  (coS t j) \<turnstile> lnth t j \<mapsto> (coS t (Suc j))"
  apply (drule cotrace_trace_cos[of _ _ "Suc j"])
  apply (drule step_Suc[rotated, of _ _ _ "j"])
   apply (auto split: enat.splits llist.splits) []
  apply (auto simp: s_chop[of j "_ # ltake j _"] cos_def nth_Cons' ltake_LCons lnth_LCons'
    take_Cons' take_ltake
    split: llist.splits enat.splits if_splits elim: order.strict_trans2[rotated])
  apply (subst (asm) s_chop[of j "_ # ltake j _"])
   apply (auto simp: take_Cons' take_ltake split: enat.splits)
  done

lemma snapshot_stable:
  "cotrace init t \<Longrightarrow> i \<le> j \<Longrightarrow> has_snapshotted (coS t i) p \<Longrightarrow> has_snapshotted (coS t j) p"
  apply (drule cotrace_trace_cos[of _ _ j])
  unfolding cos_def
  by (metis exists_trace_for_any_i_j order_refl s_def snapshot_stable take_ltake)

lemma no_markers_if_all_snapshotted:
  "cotrace init t \<Longrightarrow> i \<le> j \<Longrightarrow> \<forall>p. has_snapshotted (coS t i) p \<Longrightarrow>
      Marker \<notin> set (msgs (coS t i) c) \<Longrightarrow> Marker \<notin> set (msgs (coS t j) c)"
  apply (drule cotrace_trace_cos[of _ _ j])
  unfolding cos_def
  by (metis exists_trace_for_any_i_j no_markers_if_all_snapshotted order_refl s_def take_ltake)

lemma cotrace_all_have_snapshotted:
  assumes "cotrace init t"
  shows "\<exists>i \<le> llength t. \<forall>p. has_snapshotted (coS t i) p"
proof -
  let ?i = "Max (range (some_snapshot t))"
  show ?thesis
    using has_snapshotted[OF assms] snapshot_stable[OF assms, of "some_snapshot t _" ?i _]
    apply (intro exI[of _ ?i])
    apply (auto simp: finite_processes)
     apply (cases "llength t"; auto simp: )
     apply (subst Max_le_iff)
       apply (auto simp: finite_processes)
    apply blast
    done
qed

lemma no_messages_if_no_channel:
  assumes "cotrace init t"
  shows "channel cid = None \<Longrightarrow> msgs (coS t i) cid = []"
  using no_messages_introduced_if_no_channel[OF assms[THEN cotrace_trace_cos, of i] no_msgs_if_no_channel, of cid i]
  by (auto simp: cos_def)

lemma cotrace_all_have_snapshotted_and_no_markers:
  assumes "cotrace init t"
  shows "\<exists>i \<le> llength t. (\<forall>p. has_snapshotted (coS t i) p) \<and>
                         (\<forall>c. Marker \<notin> set (msgs (coS t i) c))"
proof -
  from cotrace_all_have_snapshotted[OF assms] obtain j :: nat where
    j: "j \<le> llength t" "\<forall>p. has_snapshotted (coS t j) p" by blast
  from j(2) have *: "has_snapshotted (coS t k) p" if "k \<ge> j" for k p
      using snapshot_stable[OF assms, of j k p] that by auto
  define C where "C = {c. Marker \<in> set (msgs (coS t j) c)}"
  have "finite C"
    using no_messages_if_no_channel[OF assms, of _ j] unfolding C_def
    by (intro finite_subset[OF _ finite_channels]) fastforce
  define pick where "pick = (\<lambda>c. SOME k. k \<le> llength t \<and> k \<ge> j \<and> Marker \<notin> set (msgs (coS t k) c))"
  { fix c
    assume "c \<in> C"
    then have "\<exists>k \<le> llength t. k \<ge> j \<and> Marker \<notin> set (msgs (coS t k) c)"
      using l1[rule_format, of t j c] assms unfolding C_def by blast
    then have "pick c \<le> llength t \<and> pick c \<ge> j \<and> Marker \<notin> set (msgs (coS t (pick c)) c)"
      unfolding pick_def
      by (rule someI_ex)
  } note pick = conjunct1[OF this] conjunct1[OF conjunct2[OF this]] conjunct2[OF conjunct2[OF this]]
  show ?thesis
  proof (cases "C = {}")
    case True
    with j show ?thesis
      by (auto intro!: exI[of _ j] simp: C_def)
  next
    define m where "m = Max (pick ` C)"
    case False
    with \<open>finite C\<close> have m: "m \<in> pick ` C" "\<forall>x \<in> pick ` C. m \<ge> x"
      unfolding m_def by auto
    then have "j \<le> m" using pick(2) by auto
    from *[OF \<open>j \<le> m\<close>] have "Marker \<notin> set (msgs (coS t m) c)" for c
    proof (cases "c \<in> C")
      case True
      then show ?thesis
        using no_markers_if_all_snapshotted[OF assms, of "pick c" m c] pick[of c] m *
        by auto
    next
      case False
      then show ?thesis
        using no_markers_if_all_snapshotted[OF assms \<open>j \<le> m\<close> j(2), of c]
        by (auto simp: C_def)
    qed
    with *[OF \<open>j \<le> m\<close>] m pick show ?thesis by auto
  qed
qed

context
  fixes t
  assumes cotrace: "cotrace init t"
begin

definition "final_i \<equiv>
  (SOME i. i \<le> llength t \<and> (\<forall>p. has_snapshotted (coS t i) p) \<and> (\<forall>c. Marker \<notin> set (msgs (coS t i) c)))"

definition final where
  "final = coS t final_i"

lemma final_i: "final_i \<le> llength t" "(\<forall>p. has_snapshotted (coS t final_i) p)" "(\<forall>c. Marker \<notin> set (msgs (coS t final_i) c))"
  unfolding final_i_def
  by (rule someI2_ex[OF cotrace_all_have_snapshotted_and_no_markers[OF cotrace]]; auto intro: cotrace_trace_cos[OF cotrace])+

lemma final: "\<exists>t. trace init t final" "(\<forall>p. has_snapshotted final p)" "(\<forall>c. Marker \<notin> set (msgs final c))"
  unfolding final_def
  by (rule cotrace_trace_cos[OF cotrace] final_i exI)+

interpretation computation channel trans send recv init final
  apply standard
            apply (rule finite_channels)
           apply (rule strongly_connected_raw)
          apply (rule at_least_two_processes)
         apply (rule finite_processes)
        apply (rule no_initial_Marker)
       apply (rule no_msgs_if_no_channel)
      apply (rule no_initial_process_snapshot)
     apply (rule no_initial_channel_snapshot)
    apply (rule final(1))
   apply (intro allI impI)
  subgoal for t i cid
    apply (rule exI[of _ "length t"])
    apply (metis exists_trace_for_any_i final(3) le_cases take_all trace_and_start_determines_end)
    done
  apply (intro allI impI)
  subgoal for t p
    apply (rule exI[of _ "length t"])
    apply (metis exists_trace_for_any_i final(2) order_refl take_all trace_and_start_determines_end)
    done
  done

definition coperm where
  "coperm l r = (\<exists>xs ys z. mset xs = mset ys \<and> l = prepend xs z \<and> r = prepend ys z)"

lemma copermIL: "mset ys = mset xs \<Longrightarrow> t = prepend xs z \<Longrightarrow> coperm (prepend ys z) t"
  unfolding coperm_def by auto

lemma snapshot_algorithm_is_cocorrect:
  "\<exists>t' i. cotrace init t' \<and> coperm t' t \<and> state_equal_to_snapshot (coS t' i) final \<and> i \<le> final_i"
proof -
  define prefix where "prefix = ltake final_i t"
  define suffix where "suffix = ldrop final_i t"
  have [simp]: "prepend prefix suffix = t"
    unfolding prefix_def suffix_def prepend_ltake_ldrop_id ..
  have [simp]: "cotrace final suffix"
    unfolding suffix_def final_def
    by (auto simp: cotrace final_i(1) intro!: cotrace_ldrop)
  from cotrace_trace_cos[OF cotrace] have "trace init prefix final"
    unfolding final_def prefix_def by blast
  with snapshot_algorithm_is_correct obtain prefix' i where
    "trace init prefix' final" "mset prefix' = mset prefix" "state_equal_to_snapshot (S prefix' i) final"
    "i \<le> length prefix'"
    by blast
  moreover from \<open>mset prefix' = mset prefix\<close> \<open>i \<le> length prefix'\<close> have "i \<le> final_i"
    by (auto dest!: mset_eq_length simp: prefix_def split: enat.splits)
  ultimately show ?thesis
    by (intro exI[of _ "prepend prefix' suffix"] exI[of _ i])
      (auto simp: cos_def ltake_prepend s_chop[symmetric] intro!: cotrace_prepend elim!: copermIL)
qed

end

print_statement snapshot_algorithm_is_cocorrect

end

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

(*
  The state and error monads in Isabelle,
*)

chapter "Monads"

theory StateMonad (* unused *)
imports Lib
begin

type_synonym ('s,'a) state_monad = "'s \<Rightarrow> 'a \<times> 's"

definition
  runState :: "('s,'a) state_monad \<Rightarrow> 's \<Rightarrow> 'a \<times> 's"
where
  "runState \<equiv> id"

definition
  "return a \<equiv> \<lambda>s. (a,s)"

definition
  bind :: "('s, 'a) state_monad \<Rightarrow> ('a \<Rightarrow> ('s, 'b) state_monad) \<Rightarrow>
           ('s, 'b) state_monad" (infixl ">>=" 60)
where
  "bind f g \<equiv> (\<lambda>s. let (v,s') = f s in (g v) s')"

definition
  "bind' f g \<equiv> bind f (\<lambda>_. g)"

declare bind'_def [iff]

definition
  "get \<equiv> \<lambda>s. (s,s)"

definition
  "put s \<equiv> \<lambda>_. ((),s)"

definition
  "gets f \<equiv> get >>= (\<lambda>s. return $ f s)"

definition
  "modify f \<equiv> get >>= (\<lambda>s. put $ f s)"

definition
  "when p s \<equiv> if p then s else return ()"

definition
  "unless p s \<equiv> when (\<not>p) s"

text \<open>The monad laws:\<close>

lemma return_bind [simp]: "(return x >>= f) = f x"
  by (simp add: return_def bind_def runState_def)

lemma bind_return [simp]: "(m >>= return) = m"
  unfolding bind_def return_def runState_def
  by (simp add: Let_def split_def)

lemma bind_assoc:
  fixes m :: "('s,'a) state_monad"
  fixes f :: "'a \<Rightarrow> ('s,'b) state_monad"
  fixes g :: "'b \<Rightarrow> ('s,'c) state_monad"
  shows "(m >>= f) >>= g  =  m >>= (\<lambda>x. f x >>= g)"
  unfolding bind_def
  by (clarsimp simp add: Let_def split_def)

text \<open>An errorT state\_monad (returnOk=return, bindE=bind):\<close>

definition
  "returnOk \<equiv> return o Inr"

definition
  "throwError \<equiv> return o Inl"

definition
  "Ok \<equiv> Inr"

definition
  lift :: "('a \<Rightarrow> ('s, 'e + 'b) state_monad) \<Rightarrow> 'e+'a \<Rightarrow> ('s, 'e + 'b) state_monad"
where
  "lift f v \<equiv> case v of Inl e \<Rightarrow> throwError e | Inr v' \<Rightarrow> f v'"

definition
  lift2 :: "('c \<Rightarrow> ('a, 'b + 'e + 'd) state_monad) \<Rightarrow> 'b+'e+'c \<Rightarrow> ('a, 'b+'e+'d) state_monad"
where
  "lift2 f v \<equiv> case v of
                 Inl e \<Rightarrow> throwError e
               | Inr v'' \<Rightarrow> (case v'' of Inl e' \<Rightarrow> return $ Inr $ Inl e' | Inr v' \<Rightarrow> f v')"

(* This is used if you are just trying to throwError by itself *)
definition
  raise :: "'a \<Rightarrow> 's \<Rightarrow> ('a + unit) \<times> 's"
where
  "raise \<equiv> return \<circ> Inl"

definition
  bindE :: "('s, 'e + 'a) state_monad \<Rightarrow> ('a \<Rightarrow> ('s, 'e + 'b) state_monad) \<Rightarrow>
            ('s, 'e + 'b) state_monad"  (infixl ">>=E" 60)
where
  "bindE f g \<equiv> bind f (lift g)"

definition
  "bindE' f g \<equiv> bindE f (\<lambda>_. g)"

definition
  liftE :: "('s,'a) state_monad \<Rightarrow> ('s, 'e+'a) state_monad" where
  "liftE f \<equiv> \<lambda>s. let (v,s') = f s in (Inr v, s')"

definition
  "whenE P f \<equiv> if P then f else returnOk ()"

definition
  "unlessE P f \<equiv> if P then returnOk () else f"

definition
  "throw_opt ex x \<equiv> case x of None \<Rightarrow> throwError ex | Some v \<Rightarrow> returnOk v"

definition
  "bindEE f g \<equiv> bind f (lift2 g)"
definition
  "bindEE' f g \<equiv> bindEE f (\<lambda>_. g)"

definition
  "modifyE \<equiv> (liftE \<circ> modify)"
definition
  "getsE x \<equiv> liftE $ gets x"

syntax
  bindEE :: "'a \<Rightarrow> 'b \<Rightarrow> 'c" (infixl ">>=EE" 60)

declare
  bindE'_def [iff]
  bindEE_def [iff]
  bindEE'_def [iff]

lemma returnOk_bindE [simp]: "(returnOk x >>=E f) = f x"
  unfolding bindE_def return_def returnOk_def
  by (clarsimp simp: lift_def bind_def)

lemma lift_return [simp]:
  "lift (return \<circ> Inr) = return"
  by (auto simp: lift_def throwError_def split: sum.splits)

lemma bindE_returnOk [simp]: "(m >>=E returnOk) = m"
  by (simp add: bindE_def returnOk_def)

 lemma bindE_assoc:
  shows "(m >>=E f) >>=E g  =  m >>=E (\<lambda>x. f x >>=E g)"
  by (auto simp: Let_def bindE_def bind_def lift_def split_def runState_def throwError_def return_def
           split: sum.splits)

lemma throwError_bindE [simp]:
  "throwError E >>=E f = throwError E"
  by (simp add: bindE_def bind_def throwError_def lift_def return_def)

subsection "Syntax for state monad"

nonterminal
  dobinds and dobind and nobind

syntax
  "_dobind"    :: "[pttrn, 'a] => dobind"             ("(_ <-/ _)" 10)
  ""           :: "dobind => dobinds"                 ("_")
  "_nobind"    :: "'a => dobind"                      ("_")
  "_dobinds"   :: "[dobind, dobinds] => dobinds"      ("(_);//(_)")

  "_do"        :: "[dobinds, 'a] => 'a"               ("(do (_);//   (_)//od)" 100)
syntax (xsymbols)
  "_dobind"    :: "[pttrn, 'a] => dobind"             ("(_ \<leftarrow>/ _)" 10)

translations
  "_do (_dobinds b bs) e"  == "_do b (_do bs e)"
  "_do (_nobind b) e"      == "CONST bind' b e"
  "do x <- a; e od"        == "a >>= (\<lambda>x. e)"

lemma "do x \<leftarrow> return 1; return 2; return x od = return 1"
  by simp

subsection "Syntax for errorT state monad"

syntax
  "_doE" :: "[dobinds, 'a] => 'a"  ("(doE (_);//    (_)//odE)" 100)

translations
  "_doE (_dobinds b bs) e"  == "_doE b (_doE bs e)"
  "_doE (_nobind b) e"      == "CONST bindE' b e"
  "doE x <- a; e odE"       == "a >>=E (\<lambda>x. e)"

subsection "Syntax for errorT errorT state monad"

syntax
  "_doEE" :: "[dobinds, 'a] => 'a" ("(doEE (_);//     (_)//odEE)" 100)

translations
  "_doEE (_dobinds b bs) e"  == "_doEE b (_doEE bs e)"
  "_doEE (_nobind b) e"      == "CONST bindEE' b e"
  "doEE x <- a; e odEE"      == "a >>=EE (\<lambda>x. e)"

primrec
  inc_forloop :: "nat \<Rightarrow> 'g::{plus,one} \<Rightarrow> ('g \<Rightarrow> ('a, 'b + unit) state_monad) \<Rightarrow>
                  ('a, 'b + unit) state_monad"
where
  "inc_forloop 0 current body = returnOk ()"
| "inc_forloop (Suc left) current body = doE body current ; inc_forloop left (current+1) body odE"

primrec
  do_times :: "nat \<Rightarrow> ('a, 'b + unit) state_monad \<Rightarrow> ('a, 'b + unit) state_monad \<Rightarrow>
              ('a, 'b + unit) state_monad"
where
  "do_times 0 body increment = returnOk ()"
| "do_times (Suc left) body increment = doE body ; increment ; do_times left body increment odE"

definition
  function_update :: "'a \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b)" where
  "function_update index modifier f \<equiv>
   \<lambda>x. if x = index then modifier (f x) else (f x)"

lemma "doE x \<leftarrow> returnOk 1; returnOk 2; returnOk x odE = returnOk 1"
  by simp

term "doEE x \<leftarrow> returnOk $ Ok 1; returnOk $ Ok 2; returnOk $ Ok x odEE"

definition
  "skip \<equiv> returnOk $ Ok ()"

definition
  "liftM f m \<equiv> do x \<leftarrow> m; return (f x) od"
definition
  "liftME f m \<equiv> doE x \<leftarrow> m; returnOk (f x) odE"

definition
  "sequence_x xs \<equiv> foldr (\<lambda>x y. x >>= (\<lambda>_. y)) xs (return ())"

definition
  "zipWithM_x f xs ys \<equiv> sequence_x (zipWith f xs ys)"
definition
  "mapM_x f xs \<equiv> sequence_x (map f xs)"

definition
  "sequence xs \<equiv> let mcons = (\<lambda>p q. p >>= (\<lambda>x. q >>= (\<lambda>y. return (x#y))))
                 in foldr mcons xs (return [])"

definition
  "mapM f xs \<equiv> sequence (map f xs)"

definition
  "sequenceE_x xs \<equiv> foldr (\<lambda>x y. doE uu <- x; y odE) xs (returnOk ())"
definition
  "mapME_x f xs \<equiv> sequenceE_x (map f xs)"

definition
  "sequenceEE_x xs \<equiv> foldr bindEE' xs (skip)"
definition
  "mapMEE_x f xs \<equiv> sequenceEE_x (map f xs)"

definition
  catch :: "('s, 'a + 'b) state_monad \<Rightarrow> ('a \<Rightarrow> ('s, 'b) state_monad) \<Rightarrow> ('s, 'b) state_monad"
where
  "catch f handler \<equiv> do x \<leftarrow> f;
                        case x of
                            Inr b \<Rightarrow> return b
                          | Inl e \<Rightarrow> handler e
                      od"

definition
  handleE :: "('s, 'x + 'a) state_monad \<Rightarrow>
              ('x \<Rightarrow> ('s, 'x + 'a) state_monad) \<Rightarrow>
              ('s, 'x + 'a) state_monad" (infix "<handle>" 11) where
  "f <handle> handler \<equiv>
   do v \<leftarrow> f; case v of Inl e \<Rightarrow> handler e | Inr v' \<Rightarrow> return v od"

definition
  handle_elseE :: "('s, 'x + 'a) state_monad \<Rightarrow>
                   ('x \<Rightarrow> ('s, 'x + 'a) state_monad) \<Rightarrow>
                   ('a \<Rightarrow> ('s, 'x + 'a) state_monad) \<Rightarrow>
                   ('s, 'x + 'a) state_monad" ("_ <handle> _ <else> _" 10)
where
  "f <handle> handler <else> continue \<equiv>
    do v \<leftarrow> f;
       case v of Inl e \<Rightarrow> handler e
               | Inr v \<Rightarrow> continue v
    od"

definition
  isSkip :: "('s, 'a) state_monad \<Rightarrow> bool" where
  "isSkip m \<equiv> \<forall>s. \<exists>r. m s = (r,s)"

lemma isSkip_bindI: "\<lbrakk> isSkip f; \<And>x. isSkip (g x) \<rbrakk> \<Longrightarrow> isSkip (f >>= g)"
  apply (clarsimp simp: isSkip_def bind_def Let_def)
  apply (erule_tac x=s in allE)
  apply clarsimp
  done

lemma isSkip_return [simp,intro!]:
  "isSkip (return x)"
  by (simp add: isSkip_def return_def)

lemma isSkip_gets [simp,intro!]:
  "isSkip (gets x)"
  by (simp add: isSkip_def gets_def get_def bind_def return_def)

lemma isSkip_liftE [iff]: "isSkip (liftE f) = isSkip f"
  apply (simp add: isSkip_def liftE_def Let_def split_def)
  apply rule
   apply clarsimp
   apply (case_tac "f s")
   apply (erule_tac x = s in allE)
   apply simp
  apply clarsimp
  apply (case_tac "f s")
  apply (erule_tac x = s in allE)
  apply simp
  done

lemma isSkip_liftI [simp, intro!]:
  "\<lbrakk> \<And>y. x = Inr y \<Longrightarrow> isSkip (f y) \<rbrakk> \<Longrightarrow> isSkip (lift f x)"
  by (simp add: lift_def throwError_def return_def isSkip_def split: sum.splits)

lemma isSkip_Error [iff]:
  "isSkip (throwError x)"
  by (simp add: throwError_def)

lemma isSkip_returnOk [iff]:
  "isSkip (returnOk x)"
  by (simp add: returnOk_def)

lemma isSkip_throw_opt [iff]:
  "isSkip (throw_opt e x)"
  by (simp add: throw_opt_def split: option.splits)

lemma nested_bind [simp]:
  "do x <- do y <- f; return (g y) od; h x od =
   do y <- f; h (g y) od"
  apply (clarsimp simp add: bind_def)
  apply (rule ext)
  apply (clarsimp simp add: Let_def split_def runState_def return_def)
  done

lemma skip_bind:
  "isSkip s \<Longrightarrow> do _ \<leftarrow> s; g od = g"
  apply (clarsimp simp add: bind_def)
  apply (rule ext)
  apply (clarsimp simp add: isSkip_def Let_def)
  apply (erule_tac x=sa in allE)
  apply clarsimp
  done

lemma bind_eqI:
  "\<lbrakk> f = f'; \<And>x. g x = g' x \<rbrakk> \<Longrightarrow> f >>= g = f' >>= g'"
  by (simp add: bind_def)

lemma bind'_cong [fundef_cong]:
  "\<lbrakk> f = f'; \<And>v s s'. f' s = (v, s') \<Longrightarrow> g s' = g' s' \<rbrakk> \<Longrightarrow> bind' f g = bind' f' g'"
  by (auto intro: bind_cong)

lemma bindE_cong[fundef_cong]:
  "\<lbrakk> M = M' ; \<And>v s s'. M' s = (Inr v, s') \<Longrightarrow> N v s' = N' v s' \<rbrakk> \<Longrightarrow> bindE M N = bindE M' N'"
  apply (simp add: bindE_def)
  apply (rule bind_cong)
   apply (rule refl)
  apply (unfold lift_def)
  apply (case_tac v, simp_all)
  done

lemma bindE'_cong[fundef_cong]:
  "\<lbrakk> M = M' ; \<And>v s s'. M' s = (Inr v, s') \<Longrightarrow> N s' = N' s' \<rbrakk> \<Longrightarrow> bindE' M N = bindE' M' N'"
  by (auto intro: bindE_cong)

definition
  valid :: "('s \<Rightarrow> bool) \<Rightarrow> ('s,'a) state_monad \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool" ("\<lbrace>_\<rbrace> _ \<lbrace>_\<rbrace>") where
  "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace> \<equiv> \<forall>s. P s \<longrightarrow> split Q (f s)"

definition
  validE :: "('s \<Rightarrow> bool) \<Rightarrow> ('s, 'a + 'b) state_monad \<Rightarrow> ('b \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow>
             ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool" ("\<lbrace>_\<rbrace> _ \<lbrace>_\<rbrace>, \<lbrace>_\<rbrace>") where
  "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,\<lbrace>R\<rbrace> \<equiv> \<forall>s. P s \<longrightarrow> split (\<lambda>r s. case r of Inr b \<Rightarrow> Q b s
                                                  | Inl a \<Rightarrow> R a s) (f s)"

lemma validE_def2:
  "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,\<lbrace>R\<rbrace> \<equiv> \<lbrace>P\<rbrace> f \<lbrace> \<lambda>r s. case r of Inr b \<Rightarrow> Q b s | Inl a \<Rightarrow> R a s \<rbrace>"
  by (unfold valid_def validE_def)

definition
  pred_lift_exact :: "('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool)" ("\<guillemotleft>_,_\<guillemotright>") where
  "pred_lift_exact P Q \<equiv> \<lambda>x y. P x \<and> Q y"

lemma pred_lift_taut[simp]: "\<guillemotleft>\<top>,\<top>\<guillemotright> = \<top>\<top>"
  by (simp add:pred_lift_exact_def)

lemma pred_lift_cont_l[simp]: "\<guillemotleft>\<bottom>,x\<guillemotright> = \<bottom>\<bottom>"
  by (simp add:pred_lift_exact_def)

lemma pred_lift_cont_r[simp]: "\<guillemotleft>x,\<bottom>\<guillemotright> = \<bottom>\<bottom>"
  by (simp add:pred_lift_exact_def)

lemma pred_liftI[intro!]: "\<lbrakk> P x; Q y \<rbrakk> \<Longrightarrow> \<guillemotleft>P,Q\<guillemotright> x y"
  by (simp add:pred_lift_exact_def)

lemma pred_exact_split:
  "\<guillemotleft>P,Q\<guillemotright> = (\<guillemotleft>P,\<top>\<guillemotright> and \<guillemotleft>\<top>,Q\<guillemotright>)"
  by (simp add:pred_lift_exact_def pred_conj_def)

lemma pred_lift_add[simp]: "\<guillemotleft>P,Q\<guillemotright> x = ((\<lambda>s. P x) and Q)"
  by (simp add:pred_lift_exact_def pred_conj_def)

lemma seq':
  "\<lbrakk> \<lbrace>A\<rbrace> f \<lbrace>B\<rbrace>;
     \<forall>x. P x \<longrightarrow> \<lbrace>C\<rbrace> g x \<lbrace>D\<rbrace>;
     \<forall>x s. B x s \<longrightarrow> P x \<and> C s \<rbrakk> \<Longrightarrow>
   \<lbrace>A\<rbrace> do x \<leftarrow> f; g x od \<lbrace>D\<rbrace>"
  apply (clarsimp simp: valid_def runState_def bind_def Let_def split_def)
  apply (case_tac "f s")
  apply fastforce
  done

lemma seq:
  assumes "\<lbrace>A\<rbrace> f \<lbrace>B\<rbrace>"
  assumes "\<And>x. P x \<Longrightarrow> \<lbrace>C\<rbrace> g x \<lbrace>D\<rbrace>"
  assumes "\<And>x s. B x s \<Longrightarrow> P x \<and> C s"
  shows "\<lbrace>A\<rbrace> do x \<leftarrow> f; g x od \<lbrace>D\<rbrace>"
  using assms by (blast intro: seq')

lemma seq_invar_nobind:
  assumes f_valid: "\<lbrace>A\<rbrace> f \<lbrace>\<guillemotleft>\<top>,A\<guillemotright>\<rbrace>"
  assumes g_valid: "\<And>x. \<lbrace>A\<rbrace> g x \<lbrace>\<guillemotleft>\<top>,A\<guillemotright>\<rbrace>"
  shows "\<lbrace>A\<rbrace> do x \<leftarrow> f; g x od \<lbrace>\<guillemotleft>\<top>,A\<guillemotright>\<rbrace>"
  apply(rule_tac B="\<guillemotleft>\<top>,A\<guillemotright>" and C="A" and P="\<top>" in seq)
    apply(insert f_valid g_valid)
    apply(simp_all add:pred_lift_exact_def)
  done

lemma seq_invar_bind:
  assumes f_valid: "\<lbrace>A\<rbrace> f \<lbrace>\<guillemotleft>B,A\<guillemotright>\<rbrace>"
  assumes g_valid: "\<And>x. P x \<Longrightarrow> \<lbrace>A\<rbrace> g x \<lbrace>\<guillemotleft>\<top>,A\<guillemotright>\<rbrace>"
  assumes bind: "\<And>x. B x \<Longrightarrow> P x"
  shows "\<lbrace>A\<rbrace> do x \<leftarrow> f; g x od \<lbrace>\<guillemotleft>\<top>,A\<guillemotright>\<rbrace>"
  apply(rule_tac B="\<guillemotleft>B,A\<guillemotright>" and C="A" and P="P" in seq)
    apply(insert f_valid g_valid bind)
    apply(simp_all add: pred_lift_exact_def)
  done

lemma seq_noimp:
  assumes f_valid: "\<lbrace>A\<rbrace> f \<lbrace>\<guillemotleft>C,B\<guillemotright>\<rbrace>"
  assumes g_valid: "\<And>x. C x \<Longrightarrow> \<lbrace>B\<rbrace> g x \<lbrace>D\<rbrace>"
  shows "\<lbrace>A\<rbrace> do x \<leftarrow> f; g x od \<lbrace>D\<rbrace>"
  apply(rule_tac B="\<guillemotleft>C,B\<guillemotright>" and C="B" and P="C" in seq)
    apply(insert f_valid g_valid, simp_all add:pred_lift_exact_def)
  done

lemma seq_ext':
  "\<lbrakk> \<lbrace>A\<rbrace> f \<lbrace>B\<rbrace>; \<forall>x. \<lbrace>B x\<rbrace> g x \<lbrace>C\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>A\<rbrace> do x \<leftarrow> f; g x od \<lbrace>C\<rbrace>"
  by (clarsimp simp: valid_def runState_def bind_def Let_def split_def)

lemma seq_ext:
  assumes "\<lbrace>A\<rbrace> f \<lbrace>B\<rbrace>" "\<And>x. \<lbrace>B x\<rbrace> g x \<lbrace>C\<rbrace>"
  shows "\<lbrace>A\<rbrace> do x \<leftarrow> f; g x od \<lbrace>C\<rbrace>"
  using assms by (blast intro: seq_ext')

lemma seqE':
  "\<lbrakk> \<lbrace>A\<rbrace> f \<lbrace>B\<rbrace>,\<lbrace>E\<rbrace>;
     \<forall>x. \<lbrace>B x\<rbrace> g x \<lbrace>C\<rbrace>,\<lbrace>E\<rbrace> \<rbrakk> \<Longrightarrow>
   \<lbrace>A\<rbrace> doE x \<leftarrow> f; g x odE \<lbrace>C\<rbrace>,\<lbrace>E\<rbrace>"
  apply(simp add: bindE_def lift_def bind_def Let_def split_def)
  apply(clarsimp simp: validE_def)
  apply(rename_tac s r x)
  apply(case_tac "fst (f s)"; case_tac r; fastforce simp:throwError_def return_def)
  done

lemma seqE:
  assumes "\<lbrace>A\<rbrace> f \<lbrace>B\<rbrace>,\<lbrace>E\<rbrace>" "\<And>x. \<lbrace>B x\<rbrace> g x \<lbrace>C\<rbrace>,\<lbrace>E\<rbrace>"
  shows "\<lbrace>A\<rbrace> doE x \<leftarrow> f; g x odE \<lbrace>C\<rbrace>,\<lbrace>E\<rbrace>"
  using assms by(blast intro: seqE')

lemma get_sp:
  "\<lbrace>P\<rbrace> get \<lbrace>\<lambda>a s. s = a \<and> P s\<rbrace>"
  by (simp add:get_def valid_def)

lemma put_sp:
  "\<lbrace>\<top>\<rbrace> put a \<lbrace>\<lambda>_ s. s = a\<rbrace>"
  by (simp add:put_def valid_def)

lemma return_sp:
  "\<lbrace>P\<rbrace> return a \<lbrace>\<lambda>b s. b = a \<and> P s\<rbrace>"
  by (simp add:return_def valid_def)

lemma hoare_post_conj [intro!]:
  "\<lbrakk> \<lbrace> P \<rbrace> a \<lbrace> Q \<rbrace>; \<lbrace> P \<rbrace> a \<lbrace> R \<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace> P \<rbrace> a \<lbrace> Q and R \<rbrace>"
  by (simp add:valid_def split_def pred_conj_def)

lemma hoare_pre_disj [intro!]:
  "\<lbrakk> \<lbrace> P \<rbrace> a \<lbrace> R \<rbrace>; \<lbrace> Q \<rbrace> a \<lbrace> R \<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace> P or Q \<rbrace> a \<lbrace> R \<rbrace>"
  by (simp add:valid_def pred_disj_def)

lemma hoare_post_taut [iff]: "\<lbrace> P \<rbrace> a \<lbrace> \<top>\<top> \<rbrace>"
  by (simp add:valid_def)

lemma hoare_pre_cont [iff]: "\<lbrace> \<bottom> \<rbrace> a \<lbrace> P \<rbrace>"
  by (simp add:valid_def)

lemma hoare_return [intro!]: "\<And>x. P x \<Longrightarrow> \<lbrace> Q \<rbrace> return x \<lbrace> \<guillemotleft>P,Q\<guillemotright> \<rbrace>"
  by (simp add:valid_def return_def pred_lift_exact_def)

lemma hoare_return_drop [iff]: "\<lbrace> Q \<rbrace> return x \<lbrace> \<guillemotleft>\<top>,Q\<guillemotright> \<rbrace>"
  by (simp add:valid_def return_def pred_lift_exact_def)

lemma hoare_return_drop_var [iff]: "\<lbrace> Q \<rbrace> return x \<lbrace> \<lambda>r. Q \<rbrace>"
  by (simp add:valid_def return_def pred_lift_exact_def)

lemma hoare_return_only [intro!]: "\<And>x. P x \<Longrightarrow> \<lbrace> Q \<rbrace> return x \<lbrace> \<guillemotleft>P,\<top>\<guillemotright> \<rbrace>"
  by (simp add:valid_def return_def pred_lift_exact_def)

lemma hoare_get [iff]: "\<lbrace> P \<rbrace> get \<lbrace> \<guillemotleft>P,P\<guillemotright> \<rbrace>"
  by (simp add:valid_def get_def pred_lift_exact_def)

lemma hoare_gets [intro!]: "\<lbrakk> \<And>s. P s \<Longrightarrow> Q (f s) s \<rbrakk> \<Longrightarrow> \<lbrace> P \<rbrace> gets f \<lbrace> Q \<rbrace>"
  by (simp add:valid_def gets_def get_def bind_def return_def)

lemma hoare_modify [iff]: "\<lbrace> P o f \<rbrace> modify f \<lbrace> \<guillemotleft>\<top>,P\<guillemotright> \<rbrace>"
  by (simp add:valid_def modify_def pred_lift_exact_def put_def bind_def get_def)

lemma hoare_modifyE [intro!]: "\<lbrakk> \<And>s. P s \<Longrightarrow> Q (f s) \<rbrakk> \<Longrightarrow> \<lbrace> P \<rbrace> modify f \<lbrace> \<guillemotleft>\<top>,Q\<guillemotright> \<rbrace>"
  by (simp add:valid_def modify_def pred_lift_exact_def put_def bind_def get_def)

lemma hoare_modifyE_var [intro!]: "\<lbrakk> \<And>s. P s \<Longrightarrow> Q (f s) \<rbrakk> \<Longrightarrow> \<lbrace> P \<rbrace> modify f \<lbrace> \<lambda>r s. Q s \<rbrace>"
  by (simp add:valid_def modify_def pred_lift_exact_def put_def bind_def get_def)

lemma hoare_put [intro!]: "P x \<Longrightarrow> \<lbrace> Q \<rbrace> put x \<lbrace> \<guillemotleft>\<top>,P\<guillemotright>\<rbrace>"
  by (simp add:valid_def put_def pred_lift_exact_def)

lemma hoare_if [intro!]:
  "\<lbrakk> P \<Longrightarrow> \<lbrace> Q \<rbrace> a \<lbrace> R \<rbrace>; \<not> P \<Longrightarrow> \<lbrace> Q \<rbrace> b \<lbrace> R \<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace> Q \<rbrace> if P then a else b \<lbrace> R \<rbrace>"
  by (simp add:valid_def)

lemma hoare_when [intro!]:
  "\<lbrakk> \<lbrakk> P \<rbrakk> \<Longrightarrow> \<lbrace> Q \<rbrace> a \<lbrace> \<guillemotleft>\<top>,R\<guillemotright> \<rbrace>; \<And>s. \<lbrakk> \<not> P; Q s \<rbrakk> \<Longrightarrow> R s \<rbrakk> \<Longrightarrow>
   \<lbrace> Q \<rbrace> when P a \<lbrace> \<guillemotleft>\<top>,R\<guillemotright> \<rbrace>"
  by (simp add:valid_def when_def split_def return_def pred_lift_exact_def)

lemma hoare_unless [intro!]:
  "\<lbrakk> \<And>s. \<lbrakk> P; Q s \<rbrakk> \<Longrightarrow> R s; \<lbrakk> \<not> P \<rbrakk> \<Longrightarrow> \<lbrace> Q \<rbrace> a \<lbrace> \<guillemotleft>\<top>,R\<guillemotright> \<rbrace> \<rbrakk> \<Longrightarrow>
   \<lbrace> Q \<rbrace> unless P a \<lbrace> \<guillemotleft>\<top>,R\<guillemotright> \<rbrace>"
  by (simp add:valid_def unless_def split_def when_def return_def pred_lift_exact_def)

lemma hoare_pre_subst: "\<lbrakk> A = B; \<lbrace>A\<rbrace> a \<lbrace>C\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>B\<rbrace> a \<lbrace>C\<rbrace>"
  by (clarsimp simp:valid_def split_def)

lemma hoare_post_subst: "\<lbrakk> B = C; \<lbrace>A\<rbrace> a \<lbrace>B\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>A\<rbrace> a \<lbrace>C\<rbrace>"
  by (clarsimp simp:valid_def split_def)

lemma hoare_pre_tautI: "\<lbrakk> \<lbrace>A and P\<rbrace> a \<lbrace>B\<rbrace>; \<lbrace>A and not P\<rbrace> a \<lbrace>B\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>A\<rbrace> a \<lbrace>B\<rbrace>"
  by (clarsimp simp:valid_def split_def pred_conj_def pred_neg_def, blast)

lemma hoare_return_var[intro!]: "\<lbrakk> \<And>x. P x \<Longrightarrow> Q x \<rbrakk> \<Longrightarrow> (\<And>x. P x \<Longrightarrow> \<lbrace>R\<rbrace> return x \<lbrace>\<guillemotleft>Q,R\<guillemotright>\<rbrace>)"
  by (rule hoare_return)

lemma hoare_return_drop_imp[intro!]: "\<lbrakk> \<And>s. P s \<Longrightarrow> Q s \<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> return x \<lbrace>\<guillemotleft>\<top>,Q\<guillemotright>\<rbrace>"
 by (simp add:valid_def return_def)

lemmas hoare_case_option_inference = option.exhaust

lemma hoare_pre_imp: "\<lbrakk> \<lbrace>Q\<rbrace> a \<lbrace>R\<rbrace>; \<And>s. P s \<Longrightarrow> Q s \<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> a \<lbrace>R\<rbrace>"
  by (simp add:valid_def)

lemma hoare_post_imp: "\<lbrakk> \<lbrace>P\<rbrace> a \<lbrace>Q\<rbrace>; \<And>r s. Q r s \<Longrightarrow> R r s \<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> a \<lbrace>R\<rbrace>"
  by (simp add:valid_def split_def)

lemma hoare_post_impE:
  "\<lbrakk> \<lbrace>P\<rbrace> a \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace>; \<And>r s. Q r s \<Longrightarrow> R r s; \<And>e s. E e s \<Longrightarrow> F e s \<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> a \<lbrace>R\<rbrace>,\<lbrace>F\<rbrace>"
  apply(clarsimp simp: validE_def)
  apply(rename_tac s r x)
  apply(case_tac r; fastforce)
  done

lemma "isSkip f \<Longrightarrow> \<lbrace> P \<rbrace> f \<lbrace> \<guillemotleft>\<top>,P\<guillemotright> \<rbrace>"
  apply (clarsimp simp: valid_def split_def isSkip_def)
  apply (rename_tac s)
  apply (case_tac "f s")
  apply (erule_tac x=s in allE)
  apply auto
  done

end


(*  Title:      HOL/Library/DAList_Multiset.thy
    Author:     Lukas Bulwahn, TU Muenchen
*)

section \<open>Multisets partially implemented by association lists\<close>

theory DAList_Multiset
imports Multiset DAList
begin

text \<open>Delete prexisting code equations\<close>

declare [[code drop: "{#}" Multiset.is_empty add_mset
  "plus :: 'a multiset \<Rightarrow> _" "minus :: 'a multiset \<Rightarrow> _"
  inf_subset_mset sup_subset_mset image_mset filter_mset count
  "size :: _ multiset \<Rightarrow> nat" sum_mset prod_mset
  set_mset sorted_list_of_multiset subset_mset subseteq_mset
  equal_multiset_inst.equal_multiset]]

text \<open>Raw operations on lists\<close>

definition join_raw ::
    "('key \<Rightarrow> 'val \<times> 'val \<Rightarrow> 'val) \<Rightarrow>
      ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
  where "join_raw f xs ys = foldr (\<lambda>(k, v). map_default k v (\<lambda>v'. f k (v', v))) ys xs"

lemma join_raw_Nil [simp]: "join_raw f xs [] = xs"
  by (simp add: join_raw_def)

lemma join_raw_Cons [simp]:
  "join_raw f xs ((k, v) # ys) = map_default k v (\<lambda>v'. f k (v', v)) (join_raw f xs ys)"
  by (simp add: join_raw_def)

lemma map_of_join_raw:
  assumes "distinct (map fst ys)"
  shows "map_of (join_raw f xs ys) x =
    (case map_of xs x of
      None \<Rightarrow> map_of ys x
    | Some v \<Rightarrow> (case map_of ys x of None \<Rightarrow> Some v | Some v' \<Rightarrow> Some (f x (v, v'))))"
  using assms
  apply (induct ys)
  apply (auto simp add: map_of_map_default split: option.split)
  apply (metis map_of_eq_None_iff option.simps(2) weak_map_of_SomeI)
  apply (metis Some_eq_map_of_iff map_of_eq_None_iff option.simps(2))
  done

lemma distinct_join_raw:
  assumes "distinct (map fst xs)"
  shows "distinct (map fst (join_raw f xs ys))"
  using assms
proof (induct ys)
  case Nil
  then show ?case by simp
next
  case (Cons y ys)
  then show ?case by (cases y) (simp add: distinct_map_default)
qed

definition "subtract_entries_raw xs ys = foldr (\<lambda>(k, v). AList.map_entry k (\<lambda>v'. v' - v)) ys xs"

lemma map_of_subtract_entries_raw:
  assumes "distinct (map fst ys)"
  shows "map_of (subtract_entries_raw xs ys) x =
    (case map_of xs x of
      None \<Rightarrow> None
    | Some v \<Rightarrow> (case map_of ys x of None \<Rightarrow> Some v | Some v' \<Rightarrow> Some (v - v')))"
  using assms
  unfolding subtract_entries_raw_def
  apply (induct ys)
  apply auto
  apply (simp split: option.split)
  apply (simp add: map_of_map_entry)
  apply (auto split: option.split)
  apply (metis map_of_eq_None_iff option.simps(3) option.simps(4))
  apply (metis map_of_eq_None_iff option.simps(4) option.simps(5))
  done

lemma distinct_subtract_entries_raw:
  assumes "distinct (map fst xs)"
  shows "distinct (map fst (subtract_entries_raw xs ys))"
  using assms
  unfolding subtract_entries_raw_def
  by (induct ys) (auto simp add: distinct_map_entry)

text \<open>Operations on alists with distinct keys\<close>

lift_definition join :: "('a \<Rightarrow> 'b \<times> 'b \<Rightarrow> 'b) \<Rightarrow> ('a, 'b) alist \<Rightarrow> ('a, 'b) alist \<Rightarrow> ('a, 'b) alist"
  is join_raw
  by (simp add: distinct_join_raw)

lift_definition subtract_entries :: "('a, ('b :: minus)) alist \<Rightarrow> ('a, 'b) alist \<Rightarrow> ('a, 'b) alist"
  is subtract_entries_raw
  by (simp add: distinct_subtract_entries_raw)

text \<open>Implementing multisets by means of association lists\<close>

definition count_of :: "('a \<times> nat) list \<Rightarrow> 'a \<Rightarrow> nat"
  where "count_of xs x = (case map_of xs x of None \<Rightarrow> 0 | Some n \<Rightarrow> n)"

lemma count_of_multiset: "count_of xs \<in> multiset"
proof -
  let ?A = "{x::'a. 0 < (case map_of xs x of None \<Rightarrow> 0::nat | Some n \<Rightarrow> n)}"
  have "?A \<subseteq> dom (map_of xs)"
  proof
    fix x
    assume "x \<in> ?A"
    then have "0 < (case map_of xs x of None \<Rightarrow> 0::nat | Some n \<Rightarrow> n)"
      by simp
    then have "map_of xs x \<noteq> None"
      by (cases "map_of xs x") auto
    then show "x \<in> dom (map_of xs)"
      by auto
  qed
  with finite_dom_map_of [of xs] have "finite ?A"
    by (auto intro: finite_subset)
  then show ?thesis
    by (simp add: count_of_def fun_eq_iff multiset_def)
qed

lemma count_simps [simp]:
  "count_of [] = (\<lambda>_. 0)"
  "count_of ((x, n) # xs) = (\<lambda>y. if x = y then n else count_of xs y)"
  by (simp_all add: count_of_def fun_eq_iff)

lemma count_of_empty: "x \<notin> fst ` set xs \<Longrightarrow> count_of xs x = 0"
  by (induct xs) (simp_all add: count_of_def)

lemma count_of_filter: "count_of (List.filter (P \<circ> fst) xs) x = (if P x then count_of xs x else 0)"
  by (induct xs) auto

lemma count_of_map_default [simp]:
  "count_of (map_default x b (\<lambda>x. x + b) xs) y =
    (if x = y then count_of xs x + b else count_of xs y)"
  unfolding count_of_def by (simp add: map_of_map_default split: option.split)

lemma count_of_join_raw:
  "distinct (map fst ys) \<Longrightarrow>
    count_of xs x + count_of ys x = count_of (join_raw (\<lambda>x (x, y). x + y) xs ys) x"
  unfolding count_of_def by (simp add: map_of_join_raw split: option.split)

lemma count_of_subtract_entries_raw:
  "distinct (map fst ys) \<Longrightarrow>
    count_of xs x - count_of ys x = count_of (subtract_entries_raw xs ys) x"
  unfolding count_of_def by (simp add: map_of_subtract_entries_raw split: option.split)

text \<open>Code equations for multiset operations\<close>

definition Bag :: "('a, nat) alist \<Rightarrow> 'a multiset"
  where "Bag xs = Abs_multiset (count_of (DAList.impl_of xs))"

code_datatype Bag

lemma count_Bag [simp, code]: "count (Bag xs) = count_of (DAList.impl_of xs)"
  by (simp add: Bag_def count_of_multiset)

lemma Mempty_Bag [code]: "{#} = Bag (DAList.empty)"
  by (simp add: multiset_eq_iff alist.Alist_inverse DAList.empty_def)

lift_definition is_empty_Bag_impl :: "('a, nat) alist \<Rightarrow> bool" is
  "\<lambda>xs. list_all (\<lambda>x. snd x = 0) xs" .

lemma is_empty_Bag [code]: "Multiset.is_empty (Bag xs) \<longleftrightarrow> is_empty_Bag_impl xs"
proof -
  have "Multiset.is_empty (Bag xs) \<longleftrightarrow> (\<forall>x. count (Bag xs) x = 0)"
    unfolding Multiset.is_empty_def multiset_eq_iff by simp
  also have "\<dots> \<longleftrightarrow> (\<forall>x\<in>fst ` set (alist.impl_of xs). count (Bag xs) x = 0)"
  proof (intro iffI allI ballI)
    fix x assume A: "\<forall>x\<in>fst ` set (alist.impl_of xs). count (Bag xs) x = 0"
    thus "count (Bag xs) x = 0"
    proof (cases "x \<in> fst ` set (alist.impl_of xs)")
      case False
      thus ?thesis by (force simp: count_of_def split: option.splits)
    qed (insert A, auto)
  qed simp_all
  also have "\<dots> \<longleftrightarrow> list_all (\<lambda>x. snd x = 0) (alist.impl_of xs)"
    by (auto simp: count_of_def list_all_def)
  finally show ?thesis by (simp add: is_empty_Bag_impl.rep_eq)
qed

lemma union_Bag [code]: "Bag xs + Bag ys = Bag (join (\<lambda>x (n1, n2). n1 + n2) xs ys)"
  by (rule multiset_eqI)
    (simp add: count_of_join_raw alist.Alist_inverse distinct_join_raw join_def)

lemma add_mset_Bag [code]: "add_mset x (Bag xs) =
    Bag (join (\<lambda>x (n1, n2). n1 + n2) (DAList.update x 1 DAList.empty) xs)"
  unfolding add_mset_add_single[of x "Bag xs"] union_Bag[symmetric]
  by (simp add: multiset_eq_iff update.rep_eq empty.rep_eq)

lemma minus_Bag [code]: "Bag xs - Bag ys = Bag (subtract_entries xs ys)"
  by (rule multiset_eqI)
    (simp add: count_of_subtract_entries_raw alist.Alist_inverse
      distinct_subtract_entries_raw subtract_entries_def)

lemma filter_Bag [code]: "filter_mset P (Bag xs) = Bag (DAList.filter (P \<circ> fst) xs)"
  by (rule multiset_eqI) (simp add: count_of_filter DAList.filter.rep_eq)

lemma mset_eq [code]: "HOL.equal (m1::'a::equal multiset) m2 \<longleftrightarrow> m1 \<subseteq># m2 \<and> m2 \<subseteq># m1"
  by (metis equal_multiset_def subset_mset.eq_iff)

text \<open>By default the code for \<open><\<close> is \<^prop>\<open>xs < ys \<longleftrightarrow> xs \<le> ys \<and> \<not> xs = ys\<close>.
With equality implemented by \<open>\<le>\<close>, this leads to three calls of  \<open>\<le>\<close>.
Here is a more efficient version:\<close>
lemma mset_less[code]: "xs \<subset># (ys :: 'a multiset) \<longleftrightarrow> xs \<subseteq># ys \<and> \<not> ys \<subseteq># xs"
  by (rule subset_mset.less_le_not_le)

lemma mset_less_eq_Bag0:
  "Bag xs \<subseteq># A \<longleftrightarrow> (\<forall>(x, n) \<in> set (DAList.impl_of xs). count_of (DAList.impl_of xs) x \<le> count A x)"
    (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs
  then show ?rhs by (auto simp add: subseteq_mset_def)
next
  assume ?rhs
  show ?lhs
  proof (rule mset_subset_eqI)
    fix x
    from \<open>?rhs\<close> have "count_of (DAList.impl_of xs) x \<le> count A x"
      by (cases "x \<in> fst ` set (DAList.impl_of xs)") (auto simp add: count_of_empty)
    then show "count (Bag xs) x \<le> count A x" by (simp add: subset_mset_def)
  qed
qed

lemma mset_less_eq_Bag [code]:
  "Bag xs \<subseteq># (A :: 'a multiset) \<longleftrightarrow> (\<forall>(x, n) \<in> set (DAList.impl_of xs). n \<le> count A x)"
proof -
  {
    fix x n
    assume "(x,n) \<in> set (DAList.impl_of xs)"
    then have "count_of (DAList.impl_of xs) x = n"
    proof transfer
      fix x n
      fix xs :: "('a \<times> nat) list"
      show "(distinct \<circ> map fst) xs \<Longrightarrow> (x, n) \<in> set xs \<Longrightarrow> count_of xs x = n"
      proof (induct xs)
        case Nil
        then show ?case by simp
      next
        case (Cons ym ys)
        obtain y m where ym: "ym = (y,m)" by force
        note Cons = Cons[unfolded ym]
        show ?case
        proof (cases "x = y")
          case False
          with Cons show ?thesis
            unfolding ym by auto
        next
          case True
          with Cons(2-3) have "m = n" by force
          with True show ?thesis
            unfolding ym by auto
        qed
      qed
    qed
  }
  then show ?thesis
    unfolding mset_less_eq_Bag0 by auto
qed

declare multiset_inter_def [code]
declare sup_subset_mset_def [code]
declare mset.simps [code]

fun fold_impl :: "('a \<Rightarrow> nat \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> ('a \<times> nat) list \<Rightarrow> 'b"
where
  "fold_impl fn e ((a,n) # ms) = (fold_impl fn ((fn a n) e) ms)"
| "fold_impl fn e [] = e"

context
begin

qualified definition fold :: "('a \<Rightarrow> nat \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> ('a, nat) alist \<Rightarrow> 'b"
  where "fold f e al = fold_impl f e (DAList.impl_of al)"

end

context comp_fun_commute
begin

lemma DAList_Multiset_fold:
  assumes fn: "\<And>a n x. fn a n x = (f a ^^ n) x"
  shows "fold_mset f e (Bag al) = DAList_Multiset.fold fn e al"
  unfolding DAList_Multiset.fold_def
proof (induct al)
  fix ys
  let ?inv = "{xs :: ('a \<times> nat) list. (distinct \<circ> map fst) xs}"
  note cs[simp del] = count_simps
  have count[simp]: "\<And>x. count (Abs_multiset (count_of x)) = count_of x"
    by (rule Abs_multiset_inverse[OF count_of_multiset])
  assume ys: "ys \<in> ?inv"
  then show "fold_mset f e (Bag (Alist ys)) = fold_impl fn e (DAList.impl_of (Alist ys))"
    unfolding Bag_def unfolding Alist_inverse[OF ys]
  proof (induct ys arbitrary: e rule: list.induct)
    case Nil
    show ?case
      by (rule trans[OF arg_cong[of _ "{#}" "fold_mset f e", OF multiset_eqI]])
         (auto, simp add: cs)
  next
    case (Cons pair ys e)
    obtain a n where pair: "pair = (a,n)"
      by force
    from fn[of a n] have [simp]: "fn a n = (f a ^^ n)"
      by auto
    have inv: "ys \<in> ?inv"
      using Cons(2) by auto
    note IH = Cons(1)[OF inv]
    define Ys where "Ys = Abs_multiset (count_of ys)"
    have id: "Abs_multiset (count_of ((a, n) # ys)) = (((+) {# a #}) ^^ n) Ys"
      unfolding Ys_def
    proof (rule multiset_eqI, unfold count)
      fix c
      show "count_of ((a, n) # ys) c =
        count (((+) {#a#} ^^ n) (Abs_multiset (count_of ys))) c" (is "?l = ?r")
      proof (cases "c = a")
        case False
        then show ?thesis
          unfolding cs by (induct n) auto
      next
        case True
        then have "?l = n" by (simp add: cs)
        also have "n = ?r" unfolding True
        proof (induct n)
          case 0
          from Cons(2)[unfolded pair] have "a \<notin> fst ` set ys" by auto
          then show ?case by (induct ys) (simp, auto simp: cs)
        next
          case Suc
          then show ?case by simp
        qed
        finally show ?thesis .
      qed
    qed
    show ?case
      unfolding pair
      apply (simp add: IH[symmetric])
      unfolding id Ys_def[symmetric]
      apply (induct n)
      apply (auto simp: fold_mset_fun_left_comm[symmetric])
      done
  qed
qed

end

context
begin

private lift_definition single_alist_entry :: "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) alist" is "\<lambda>a b. [(a, b)]"
  by auto

lemma image_mset_Bag [code]:
  "image_mset f (Bag ms) =
    DAList_Multiset.fold (\<lambda>a n m. Bag (single_alist_entry (f a) n) + m) {#} ms"
  unfolding image_mset_def
proof (rule comp_fun_commute.DAList_Multiset_fold, unfold_locales, (auto simp: ac_simps)[1])
  fix a n m
  show "Bag (single_alist_entry (f a) n) + m = ((add_mset \<circ> f) a ^^ n) m" (is "?l = ?r")
  proof (rule multiset_eqI)
    fix x
    have "count ?r x = (if x = f a then n + count m x else count m x)"
      by (induct n) auto
    also have "\<dots> = count ?l x"
      by (simp add: single_alist_entry.rep_eq)
    finally show "count ?l x = count ?r x" ..
  qed
qed

end

\<comment> \<open>we cannot use \<open>\<lambda>a n. (+) (a * n)\<close> for folding, since \<open>(*)\<close> is not defined in \<open>comm_monoid_add\<close>\<close>
lemma sum_mset_Bag[code]: "sum_mset (Bag ms) = DAList_Multiset.fold (\<lambda>a n. (((+) a) ^^ n)) 0 ms"
  unfolding sum_mset.eq_fold
  apply (rule comp_fun_commute.DAList_Multiset_fold)
  apply unfold_locales
  apply (auto simp: ac_simps)
  done

\<comment> \<open>we cannot use \<open>\<lambda>a n. (*) (a ^ n)\<close> for folding, since \<open>(^)\<close> is not defined in \<open>comm_monoid_mult\<close>\<close>
lemma prod_mset_Bag[code]: "prod_mset (Bag ms) = DAList_Multiset.fold (\<lambda>a n. (((*) a) ^^ n)) 1 ms"
  unfolding prod_mset.eq_fold
  apply (rule comp_fun_commute.DAList_Multiset_fold)
  apply unfold_locales
  apply (auto simp: ac_simps)
  done

lemma size_fold: "size A = fold_mset (\<lambda>_. Suc) 0 A" (is "_ = fold_mset ?f _ _")
proof -
  interpret comp_fun_commute ?f by standard auto
  show ?thesis by (induct A) auto
qed

lemma size_Bag[code]: "size (Bag ms) = DAList_Multiset.fold (\<lambda>a n. (+) n) 0 ms"
  unfolding size_fold
proof (rule comp_fun_commute.DAList_Multiset_fold, unfold_locales, simp)
  fix a n x
  show "n + x = (Suc ^^ n) x"
    by (induct n) auto
qed

lemma set_mset_fold: "set_mset A = fold_mset insert {} A" (is "_ = fold_mset ?f _ _")
proof -
  interpret comp_fun_commute ?f by standard auto
  show ?thesis by (induct A) auto
qed

lemma set_mset_Bag[code]:
  "set_mset (Bag ms) = DAList_Multiset.fold (\<lambda>a n. (if n = 0 then (\<lambda>m. m) else insert a)) {} ms"
  unfolding set_mset_fold
proof (rule comp_fun_commute.DAList_Multiset_fold, unfold_locales, (auto simp: ac_simps)[1])
  fix a n x
  show "(if n = 0 then \<lambda>m. m else insert a) x = (insert a ^^ n) x" (is "?l n = ?r n")
  proof (cases n)
    case 0
    then show ?thesis by simp
  next
    case (Suc m)
    then have "?l n = insert a x" by simp
    moreover have "?r n = insert a x" unfolding Suc by (induct m) auto
    ultimately show ?thesis by auto
  qed
qed

instantiation multiset :: (exhaustive) exhaustive
begin

definition exhaustive_multiset ::
  "('a multiset \<Rightarrow> (bool \<times> term list) option) \<Rightarrow> natural \<Rightarrow> (bool \<times> term list) option"
  where "exhaustive_multiset f i = Quickcheck_Exhaustive.exhaustive (\<lambda>xs. f (Bag xs)) i"

instance ..

end

end