subsection \<open>Permission masks: Maps from heap locations to permission amounts\<close>

theory Mask
  imports PosRat
begin

subsubsection \<open>Definitions\<close>

type_synonym field = string
type_synonym address = nat
type_synonym heap_loc = "address \<times> field"

type_synonym mask = "heap_loc \<Rightarrow> prat"
type_synonym bmask = "heap_loc \<Rightarrow> bool"

definition null where "null = 0"

definition full_mask :: "mask" where
  "full_mask hl = (if fst hl = null then pnone else pwrite)"

definition multiply_mask :: "prat \<Rightarrow> mask \<Rightarrow> mask" where
  "multiply_mask p \<pi> hl = pmult p (\<pi> hl)"

fun empty_mask where
  "empty_mask hl = pnone"

fun empty_bmask where
  "empty_bmask hl = False"

fun add_acc where "add_acc \<pi> hl p = \<pi>(hl := padd (\<pi> hl) p)"

inductive rm_acc where
  "\<pi> hl = padd p r \<Longrightarrow> rm_acc \<pi> hl p (\<pi>(hl := r))"

fun add_masks where
  "add_masks \<pi>' \<pi> hl = padd (\<pi>' hl) (\<pi> hl)"

definition greater_mask where
  "greater_mask \<pi>' \<pi> \<longleftrightarrow> (\<exists>r. \<pi>' = add_masks \<pi> r)"

fun uni_mask where
  "uni_mask hl p = empty_mask(hl := p)"

fun valid_mask :: "mask \<Rightarrow> bool" where
  "valid_mask \<pi> \<longleftrightarrow> (\<forall>hl. pgte pwrite (\<pi> hl)) \<and> (\<forall>f. \<pi> (null, f) = pnone)"

definition valid_null :: "mask \<Rightarrow> bool" where
  "valid_null \<pi> \<longleftrightarrow> (\<forall>f. \<pi> (null, f) = pnone)"

definition equal_on_mask where
  "equal_on_mask \<pi> h h' \<longleftrightarrow> (\<forall>hl. ppos (\<pi> hl) \<longrightarrow> h hl = h' hl)"

definition equal_on_bmask where
  "equal_on_bmask \<pi> h h' \<longleftrightarrow> (\<forall>hl. \<pi> hl \<longrightarrow> h hl = h' hl)"

definition big_add_masks where
  "big_add_masks \<Pi> \<Pi>' h = add_masks (\<Pi> h) (\<Pi>' h)"

definition big_greater_mask where
  "big_greater_mask \<Pi> \<Pi>' \<longleftrightarrow> (\<forall>h. greater_mask (\<Pi> h) (\<Pi>' h))"

definition greater_bmask where
  "greater_bmask H H' \<longleftrightarrow> (\<forall>h. H' h \<longrightarrow> H h)"

definition update_dm where
  "update_dm dm \<pi> \<pi>' hl \<longleftrightarrow> (dm hl \<or> pgt (\<pi> hl) (\<pi>' hl))"

fun pre_get_m where "pre_get_m \<phi> = fst \<phi>"
fun pre_get_h where "pre_get_h \<phi> = snd \<phi>"
fun srm_acc where "srm_acc \<phi> hl p = (rm_acc (pre_get_m \<phi>) hl p, pre_get_h \<phi>)"

datatype val = Bool (the_bool: bool) | Address (the_address: address) | Rat (the_rat: prat)

definition upper_bounded :: "mask \<Rightarrow> prat \<Rightarrow> bool" where
  "upper_bounded \<pi> p \<longleftrightarrow> (\<forall>hl. pgte p (\<pi> hl))"

subsubsection \<open>Lemmas\<close>

lemma ssubsetI:
  assumes "\<And>\<pi> h. (\<pi>, h) \<in> A \<Longrightarrow> (\<pi>, h) \<in> B"
  shows "A \<subseteq> B"
  using assms by auto

lemma double_inclusion:
  assumes "A \<subseteq> B"
      and "B \<subseteq> A"
    shows "A = B"
  using assms by blast

lemma add_masks_comm:
  "add_masks a b = add_masks b a"
proof (rule ext)
  fix x show "add_masks a b x = add_masks b a x"
    by (metis Rep_prat_inverse add.commute add_masks.simps padd.rep_eq)
qed

lemma add_masks_asso:
  "add_masks (add_masks a b) c = add_masks a (add_masks b c)"
proof (rule ext)
  fix x show "add_masks (add_masks a b) c x = add_masks a (add_masks b c) x"
    by (metis Rep_prat_inverse add.assoc add_masks.simps padd.rep_eq)
qed

lemma minus_empty:
  "\<pi> = add_masks \<pi> empty_mask"
proof (rule ext)
  fix x show "\<pi> x = add_masks \<pi> empty_mask x"
    by (metis Rep_prat_inverse add.right_neutral add_masks.simps empty_mask.simps padd.rep_eq pnone.rep_eq)
qed

lemma add_acc_uni_mask:
  "add_acc \<pi> hl p = add_masks \<pi> (uni_mask hl p)"
proof (rule ext)
  fix x show "add_acc \<pi> hl p x = add_masks \<pi> (uni_mask hl p) x"
    by (metis (no_types, opaque_lifting) add_acc.simps add_masks.simps fun_upd_apply minus_empty uni_mask.simps)
qed

lemma add_masks_equiv_valid_null:
  "valid_null (add_masks a b) \<longleftrightarrow> valid_null a \<and> valid_null b"
  by (metis (mono_tags, lifting) add_masks.simps padd_zero valid_null_def)

lemma valid_maskI:
  assumes "\<And>hl. pgte pwrite (\<pi> hl)"
      and "\<And>f. \<pi> (null, f) = pnone"
    shows "valid_mask \<pi>"
  by (simp add: assms(1) assms(2))

lemma greater_mask_equiv_def:
  "greater_mask \<pi>' \<pi> \<longleftrightarrow> (\<forall>hl. pgte (\<pi>' hl) (\<pi> hl))"
  (is "?A \<longleftrightarrow> ?B")
proof (rule iffI)
  show "?A \<Longrightarrow> ?B"
  proof (clarify)
    fix hl assume "greater_mask \<pi>' \<pi>"
    then obtain r where "\<pi>' = add_masks \<pi> r"
      using greater_mask_def by blast
    then show "pgte (\<pi>' hl) (\<pi> hl)"
      using Rep_prat padd.rep_eq pgte.rep_eq by auto
  qed
  show "?B \<Longrightarrow> ?A"
  proof -
    assume ?B
    let ?r = "\<lambda>hl. (SOME p. \<pi>' hl = padd (\<pi> hl) p)"
    have "\<pi>' = add_masks \<pi> ?r"
    proof (rule ext)
      fix hl
      have "\<pi>' hl = padd (\<pi> hl) (?r hl)"
        by (meson \<open>\<forall>hl. pgte (\<pi>' hl) (\<pi> hl)\<close> p_greater_exists someI_ex)
      then show "\<pi>' hl = add_masks \<pi> ?r hl"
        by auto
    qed
    then show ?A
      using greater_mask_def by blast
  qed
qed

lemma greater_maskI:
  assumes "\<And>hl. pgte (\<pi>' hl) (\<pi> hl)"
  shows "greater_mask \<pi>' \<pi>"
  by (simp add: assms greater_mask_equiv_def)

lemma greater_mask_properties:
  "greater_mask \<pi> \<pi>"
  "greater_mask a b \<and> greater_mask b c \<Longrightarrow> greater_mask a c"
  "greater_mask \<pi>' \<pi> \<and> greater_mask \<pi> \<pi>' \<Longrightarrow> \<pi> = \<pi>'"
  apply (simp add: greater_maskI pgte.rep_eq)
  apply (metis add_masks_asso greater_mask_def)
proof (rule ext)
  fix x assume "greater_mask \<pi>' \<pi> \<and> greater_mask \<pi> \<pi>'"
  then show "\<pi> x = \<pi>' x"
    by (meson greater_mask_equiv_def pgte_antisym)
qed

lemma greater_mask_decomp:
  assumes "greater_mask a (add_masks b c)"
  shows "\<exists>a1 a2. a = add_masks a1 a2 \<and> greater_mask a1 b \<and> greater_mask a2 c"
  by (metis add_masks_asso assms greater_mask_def greater_mask_properties(1))

lemma valid_empty:
  "valid_mask empty_mask"
  by (metis empty_mask.simps le_add_same_cancel1 p_greater_exists padd.rep_eq pgte.rep_eq pnone.rep_eq valid_mask.simps)

lemma upper_valid_aux:
  assumes "valid_mask a"
      and "a = add_masks b c"
    shows "valid_mask b"
proof (rule valid_maskI)
  show "\<And>hl. pgte pwrite (b hl)"
    using assms(1) assms(2) p_greater_exists padd_asso by fastforce
  fix f show " b (null, f) = pnone"
    by (metis add_masks_comm assms(1) assms(2) empty_mask.simps greater_mask_def greater_mask_equiv_def minus_empty pgte_antisym valid_mask.simps)
qed

lemma upper_valid:
  assumes "valid_mask a"
      and "a = add_masks b c"
    shows "valid_mask b \<and> valid_mask c"
  using add_masks_comm assms(1) assms(2) upper_valid_aux by blast

lemma equal_on_bmaskI:
  assumes "\<And>hl. \<pi> hl \<Longrightarrow> h hl = h' hl"
  shows "equal_on_bmask \<pi> h h'"
  using assms equal_on_bmask_def by blast

lemma big_add_greater:
  "big_greater_mask (big_add_masks A B) B"
  by (metis add_masks_comm big_add_masks_def big_greater_mask_def greater_mask_def)

lemma big_greater_iff:
  "big_greater_mask A B \<Longrightarrow> (\<exists>C. A = big_add_masks B C)"
proof -
  assume "big_greater_mask A B"
  let ?C = "\<lambda>h. SOME r. A h = add_masks (B h) r"
  have "A = big_add_masks B ?C"
  proof (rule ext)
    fix x
    have "A x = add_masks (B x) (?C x)"
    proof (rule ext)
      fix xa
      have "A x = add_masks (B x) (SOME r. A x = add_masks (B x) r)"
        by (metis (mono_tags, lifting) \<open>big_greater_mask A B\<close> big_greater_mask_def greater_mask_def someI_ex)
      then show "A x xa = add_masks (B x) (SOME r. A x = add_masks (B x) r) xa"
        by auto
    qed
    then show "A x = big_add_masks B (\<lambda>h. SOME r. A h = add_masks (B h) r) x"
      by (metis (no_types, lifting) big_add_masks_def)
  qed
  then show "\<exists>C. A = big_add_masks B C"
    by fast
qed

lemma big_add_masks_asso:
  "big_add_masks A (big_add_masks B C) = big_add_masks (big_add_masks A B) C"
proof (rule ext)
  fix x show "big_add_masks A (big_add_masks B C) x = big_add_masks (big_add_masks A B) C x"
    by (simp add: add_masks_asso big_add_masks_def)
qed

lemma big_add_mask_neutral:
  "big_add_masks \<Pi> (\<lambda>_. empty_mask) = \<Pi>"
proof (rule ext)
  fix x show "big_add_masks \<Pi> (\<lambda>_. empty_mask) x = \<Pi> x"
    by (metis big_add_masks_def minus_empty)
qed

lemma sym_equal_on_mask:
  "equal_on_mask \<pi> a b \<longleftrightarrow> equal_on_mask \<pi> b a"
proof -
  have "\<And>a b. equal_on_mask \<pi> a b \<Longrightarrow> equal_on_mask \<pi> b a"
    by (simp add: equal_on_mask_def)
  then show ?thesis by blast
qed

lemma greater_mask_uni_equiv:
  "greater_mask \<pi> (uni_mask hl r) \<longleftrightarrow> pgte (\<pi> hl) r"
  by (metis add_masks_comm fun_upd_apply greater_mask_def greater_mask_equiv_def minus_empty uni_mask.simps)

lemma greater_mask_uniI:
  assumes "pgte (\<pi> hl) r"
  shows "greater_mask \<pi> (uni_mask hl r)"
  using greater_mask_uni_equiv assms by metis

lemma greater_bmask_refl:
  "greater_bmask H H"
  by (simp add: greater_bmask_def)

lemma greater_bmask_trans:
  assumes "greater_bmask A B"
      and "greater_bmask B C"
    shows "greater_bmask A C"
  by (metis assms(1) assms(2) greater_bmask_def)

lemma update_dm_same:
  "update_dm dm \<pi> \<pi> = dm"
proof (rule ext)
  fix x show "update_dm dm \<pi> \<pi> x = dm x"
    by (simp add: pgt.rep_eq update_dm_def)
qed

lemma update_trans:
  assumes "greater_mask \<pi> \<pi>'"
      and "greater_mask \<pi>' \<pi>''"
  shows "update_dm (update_dm dm \<pi> \<pi>') \<pi>' \<pi>'' = update_dm dm \<pi> \<pi>''"
proof (rule ext)
  fix hl show "update_dm (update_dm dm \<pi> \<pi>') \<pi>' \<pi>'' hl = update_dm dm \<pi> \<pi>'' hl"
  proof -
    have "update_dm (update_dm dm \<pi> \<pi>') \<pi>' \<pi>'' hl \<longleftrightarrow> (update_dm dm \<pi> \<pi>') hl \<or> pgt (\<pi>' hl) (\<pi>'' hl)"
      using update_dm_def by metis
    also have "... \<longleftrightarrow> dm hl \<or> pgt (\<pi> hl) (\<pi>' hl) \<or> pgt (\<pi>' hl) (\<pi>'' hl)"
      using update_dm_def by metis
    moreover have "update_dm dm \<pi> \<pi>'' hl \<longleftrightarrow> dm hl \<or> pgt (\<pi> hl) (\<pi>'' hl)"
      using update_dm_def by metis
    moreover have "pgt (\<pi> hl) (\<pi>' hl) \<or> pgt (\<pi>' hl) (\<pi>'' hl) \<longleftrightarrow> pgt (\<pi> hl) (\<pi>'' hl)"
    proof
      show "pgt (\<pi> hl) (\<pi>' hl) \<or> pgt (\<pi>' hl) (\<pi>'' hl) \<Longrightarrow> pgt (\<pi> hl) (\<pi>'' hl)"
        by (metis assms(1) assms(2) greater_mask_equiv_def greater_mask_properties(2) not_pgte_charact pgte_antisym)
      show "pgt (\<pi> hl) (\<pi>'' hl) \<Longrightarrow> pgt (\<pi> hl) (\<pi>' hl) \<or> pgt (\<pi>' hl) (\<pi>'' hl)"
        by (metis assms(1) greater_mask_equiv_def not_pgte_charact pgte_antisym)
    qed
    ultimately show ?thesis by blast
  qed
qed

lemma equal_on_bmask_greater:
  assumes "equal_on_bmask \<pi>' h h'"
      and "greater_bmask \<pi>' \<pi>"
    shows "equal_on_bmask \<pi> h h'"
  by (metis (mono_tags, lifting) assms(1) assms(2) equal_on_bmask_def greater_bmask_def)

lemma update_dm_equal_bmask:
  assumes "\<pi> = add_masks \<pi>' m"
  shows "equal_on_bmask (update_dm dm \<pi> \<pi>') h' h \<longleftrightarrow> equal_on_mask m h h' \<and> equal_on_bmask dm h h'"
proof -
  have "equal_on_bmask (update_dm dm \<pi> \<pi>') h' h \<longleftrightarrow> (\<forall>hl. update_dm dm \<pi> \<pi>' hl \<longrightarrow> h' hl = h hl)"
    by (simp add: equal_on_bmask_def)
  moreover have "\<And>hl. update_dm dm \<pi> \<pi>' hl \<longleftrightarrow> dm hl \<or> pgt (\<pi> hl) (\<pi>' hl)"
    by (simp add: update_dm_def)
  moreover have "(\<forall>hl. update_dm dm \<pi> \<pi>' hl \<longrightarrow> h' hl = h hl) \<longleftrightarrow> equal_on_mask m h h' \<and> equal_on_bmask dm h h'"
  proof
    show "\<forall>hl. update_dm dm \<pi> \<pi>' hl \<longrightarrow> h' hl = h hl \<Longrightarrow> equal_on_mask m h h' \<and> equal_on_bmask dm h h'"
      by (simp add: assms equal_on_bmask_def equal_on_mask_def padd.rep_eq pgt.rep_eq ppos.rep_eq update_dm_def)
    assume "equal_on_mask m h h' \<and> equal_on_bmask dm h h'"
    then have "\<And>hl. update_dm dm \<pi> \<pi>' hl \<Longrightarrow> h' hl = h hl"
      by (metis (full_types) add.right_neutral add_masks.simps assms dual_order.strict_iff_order equal_on_bmask_def equal_on_mask_def padd.rep_eq pgt.rep_eq pnone.rep_eq ppos_eq_pnone update_dm_def)
    then show "\<forall>hl. update_dm dm \<pi> \<pi>' hl \<longrightarrow> h' hl = h hl"
      by simp
  qed
  then show ?thesis
    by (simp add: calculation)
qed

lemma const_sum_mask_greater:
  assumes "add_masks a b = add_masks c d"
      and "greater_mask a c"
    shows "greater_mask d b"
proof (rule ccontr)
  assume "\<not> greater_mask d b"
  then obtain hl where "\<not> pgte (d hl) (b hl)"
    using greater_mask_equiv_def by blast
  then have "pgt (b hl) (d hl)"
    using not_pgte_charact by auto
  then have "pgt (padd (a hl) (b hl)) (padd (c hl) (d hl))"
    by (metis assms(2) greater_mask_equiv_def padd_comm pgte_pgt)
  then show "False"
    by (metis add_masks.simps assms(1) not_pgte_charact order_refl pgte.rep_eq)
qed

lemma add_masks_cancellative:
  assumes "add_masks b c = add_masks b d"
    shows "c = d"
proof (rule ext)
  fix x show "c x = d x"
    by (metis assms(1) const_sum_mask_greater greater_mask_properties(1) greater_mask_properties(3))
qed

lemma equal_on_maskI:
  assumes "\<And>hl. ppos (\<pi> hl) \<Longrightarrow> h hl = h' hl"
  shows "equal_on_mask \<pi> h h'"
  by (simp add: assms equal_on_mask_def)

lemma greater_equal_on_mask:
  assumes "equal_on_mask \<pi>' h h'"
      and "greater_mask \<pi>' \<pi>"
    shows "equal_on_mask \<pi> h h'"
proof (rule equal_on_maskI)
  fix hl assume asm: "ppos (\<pi> hl)"
  then show "h hl = h' hl"
    by (metis assms(1) assms(2) equal_on_mask_def greater_mask_equiv_def less_le_trans pgte.rep_eq ppos.rep_eq)
qed

lemma equal_on_mask_sum:
  "equal_on_mask \<pi>1 h h' \<and> equal_on_mask \<pi>2 h h' \<longleftrightarrow> equal_on_mask (add_masks \<pi>1 \<pi>2) h h'"
proof
  show "equal_on_mask (add_masks \<pi>1 \<pi>2) h h' \<Longrightarrow> equal_on_mask \<pi>1 h h' \<and> equal_on_mask \<pi>2 h h'"
    using add_masks_comm greater_equal_on_mask greater_mask_def by blast
  assume asm0: "equal_on_mask \<pi>1 h h' \<and> equal_on_mask \<pi>2 h h'"
  show "equal_on_mask (add_masks \<pi>1 \<pi>2) h h'"
  proof (rule equal_on_maskI)
    fix hl assume "ppos (add_masks \<pi>1 \<pi>2 hl)"
    then show "h hl = h' hl"
    proof (cases "ppos (\<pi>1 hl)")
      case True
      then show ?thesis
        by (meson asm0 equal_on_mask_def)
    next
      case False
      then show ?thesis
        by (metis asm0 \<open>ppos (add_masks \<pi>1 \<pi>2 hl)\<close> add_masks.simps equal_on_mask_def padd_zero ppos_eq_pnone)
    qed
  qed
qed

lemma valid_larger_mask:
  "valid_mask \<pi> \<longleftrightarrow> greater_mask full_mask \<pi> "
  by (metis fst_eqD full_mask_def greater_maskI greater_mask_def not_one_le_zero not_pgte_charact pgt_implies_pgte pgte.rep_eq pnone.rep_eq pwrite.rep_eq surjective_pairing upper_valid_aux valid_mask.elims(1))

lemma valid_mask_full_mask:
  "valid_mask full_mask"
  using greater_mask_properties(1) valid_larger_mask by blast

lemma mult_greater:
  assumes "greater_mask a b"
  shows "greater_mask (multiply_mask p a) (multiply_mask p b)"
  by (metis (full_types) assms greater_mask_equiv_def multiply_mask_def p_greater_exists pmult_distr)

lemma mult_write_mask:
  "multiply_mask pwrite \<pi> = \<pi>"
proof (rule ext)
  fix x show "multiply_mask pwrite \<pi> x = \<pi> x"
    by (simp add: multiply_mask_def pmult_special(1))
qed

lemma mult_distr_masks:
  "multiply_mask a (add_masks b c) = add_masks (multiply_mask a b) (multiply_mask a c)"
proof (rule ext)
  fix x show "multiply_mask a (add_masks b c) x = add_masks (multiply_mask a b) (multiply_mask a c) x"
    by (simp add: multiply_mask_def pmult_distr)
qed

lemma mult_add_states:
  "multiply_mask (padd a b) \<pi> = add_masks (multiply_mask a \<pi>) (multiply_mask b \<pi>)"
proof (rule ext)
  fix x show "multiply_mask (padd a b) \<pi> x = add_masks (multiply_mask a \<pi>) (multiply_mask b \<pi>) x"
    by (simp add: multiply_mask_def pmult_comm pmult_distr)
qed

lemma upper_boundedI:
  assumes "\<And>hl. pgte p (\<pi> hl)"
  shows "upper_bounded \<pi> p"
  by (simp add: assms upper_bounded_def)

lemma upper_bounded_smaller:
  assumes "upper_bounded \<pi> a"
  shows "upper_bounded (multiply_mask p \<pi>) (pmult p a)"
  by (metis assms multiply_mask_def p_greater_exists pmult_distr upper_bounded_def)

lemma upper_bounded_bigger:
  assumes "upper_bounded \<pi> a"
      and "pgte b a"
    shows "upper_bounded \<pi> b"
  by (meson assms(1) assms(2) order_trans pgte.rep_eq upper_bounded_def)

lemma valid_mult:
  assumes "valid_mask \<pi>"
      and "pgte pwrite p"
    shows "valid_mask (multiply_mask p \<pi>)"
proof (rule valid_maskI)
  have "upper_bounded \<pi> pwrite"
    using assms(1) upper_bounded_def by auto
  then have "upper_bounded (multiply_mask p \<pi>) (pmult p pwrite)"
    by (simp add: upper_bounded_smaller)
  then show "\<And>hl. pgte pwrite (multiply_mask p \<pi> hl)"
    by (metis assms(2) pmult_comm pmult_special(1) upper_bounded_bigger upper_bounded_def)
  show "\<And>f. multiply_mask p \<pi> (null, f) = pnone"
    by (metis Rep_prat_inverse add_0_left assms(1) multiply_mask_def padd.rep_eq padd_cancellative pmult_distr pnone.rep_eq valid_mask.elims(1))
qed

lemma valid_sum:
  assumes "valid_mask a"
      and "valid_mask b"
      and "upper_bounded a ma"
      and "upper_bounded b mb"
      and "pgte pwrite (padd ma mb)"
    shows "valid_mask (add_masks a b)"
      and "upper_bounded (add_masks a b) (padd ma mb)"
proof (rule valid_maskI)
  show "\<And>hl. pgte pwrite (add_masks a b hl)"
  proof -
    fix hl
    have "pgte (padd ma mb) (add_masks a b hl)"
      by (metis (mono_tags, lifting) add_masks.simps add_mono_thms_linordered_semiring(1) assms(3) assms(4) padd.rep_eq pgte.rep_eq upper_bounded_def)
    then show "pgte pwrite (add_masks a b hl)"
      by (meson assms(5) dual_order.trans pgte.rep_eq)
  qed
  show "\<And>f. add_masks a b (null, f) = pnone"
    by (metis Rep_prat_inverse add_0_left add_masks.simps assms(1) assms(2) padd.rep_eq pnone.rep_eq valid_mask.simps)
  show "upper_bounded (add_masks a b) (padd ma mb)"
    using add_mono_thms_linordered_semiring(1) assms(3) assms(4) padd.rep_eq pgte.rep_eq upper_bounded_def by fastforce
qed

lemma valid_multiply:
  assumes "valid_mask a"
      and "upper_bounded a ma"
      and "pgte pwrite (pmult ma p)"
    shows "valid_mask (multiply_mask p a)"
  by (metis (no_types, opaque_lifting) assms(1) assms(2) assms(3) multiply_mask_def pmult_comm pmult_special(2) upper_bounded_bigger upper_bounded_def upper_bounded_smaller valid_mask.elims(1))

lemma greater_mult:
  assumes "greater_mask a b"
  shows "greater_mask (multiply_mask p a) (multiply_mask p b)"
  by (metis Rep_prat assms greater_mask_equiv_def mem_Collect_eq mult_left_mono multiply_mask_def pgte.rep_eq pmult.rep_eq)

end


theory test
  imports Main
begin

lemma notnoteq: "\<not>\<not>A \<Longrightarrow> A"
  apply (rule classical)
  apply (erule notE)
  apply assumption
  done

lemma "\<not>(A \<or> B) \<longrightarrow> \<not>A \<and> \<not>B"
  apply (rule impI)
  apply (rule conjI)
  apply (rule classical)
   apply (erule notE)
   apply (rule disjI1)
   apply (simp add: notnoteq)
  apply (rule classical)
  apply (erule notE)
  apply (simp add: notnoteq)
  done

end


(*  Title:      HOL/Code_Numeral.thy
    Author:     Florian Haftmann, TU Muenchen
*)

section {* Numeric types for code generation onto target language numerals only *}

theory Code_Numeral
imports Nat_Transfer Divides Lifting
begin

subsection {* Type of target language integers *}

typedef integer = "UNIV \<Colon> int set"
  morphisms int_of_integer integer_of_int ..

setup_lifting (no_code) type_definition_integer

lemma integer_eq_iff:
  "k = l \<longleftrightarrow> int_of_integer k = int_of_integer l"
  by transfer rule

lemma integer_eqI:
  "int_of_integer k = int_of_integer l \<Longrightarrow> k = l"
  using integer_eq_iff [of k l] by simp

lemma int_of_integer_integer_of_int [simp]:
  "int_of_integer (integer_of_int k) = k"
  by transfer rule

lemma integer_of_int_int_of_integer [simp]:
  "integer_of_int (int_of_integer k) = k"
  by transfer rule

instantiation integer :: ring_1
begin

lift_definition zero_integer :: integer
  is "0 :: int"
  .

declare zero_integer.rep_eq [simp]

lift_definition one_integer :: integer
  is "1 :: int"
  .

declare one_integer.rep_eq [simp]

lift_definition plus_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer"
  is "plus :: int \<Rightarrow> int \<Rightarrow> int"
  .

declare plus_integer.rep_eq [simp]

lift_definition uminus_integer :: "integer \<Rightarrow> integer"
  is "uminus :: int \<Rightarrow> int"
  .

declare uminus_integer.rep_eq [simp]

lift_definition minus_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer"
  is "minus :: int \<Rightarrow> int \<Rightarrow> int"
  .

declare minus_integer.rep_eq [simp]

lift_definition times_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer"
  is "times :: int \<Rightarrow> int \<Rightarrow> int"
  .

declare times_integer.rep_eq [simp]

instance proof
qed (transfer, simp add: algebra_simps)+

end

lemma [transfer_rule]:
  "rel_fun HOL.eq pcr_integer (\<lambda>k :: int. k :: int) (of_int :: int \<Rightarrow> integer)"
proof -
  have "rel_fun HOL.eq pcr_integer (of_int :: int \<Rightarrow> int) (of_int :: int \<Rightarrow> integer)"
    by (unfold of_int_of_nat [abs_def]) transfer_prover
  then show ?thesis by (simp add: id_def)
qed

lemma [transfer_rule]:
  "rel_fun HOL.eq pcr_integer (numeral :: num \<Rightarrow> int) (numeral :: num \<Rightarrow> integer)"
proof -
  have "rel_fun HOL.eq pcr_integer (numeral :: num \<Rightarrow> int) (\<lambda>n. of_int (numeral n))"
    by transfer_prover
  then show ?thesis by simp
qed

lemma [transfer_rule]:
  "rel_fun HOL.eq (rel_fun HOL.eq pcr_integer) (Num.sub :: _ \<Rightarrow> _ \<Rightarrow> int) (Num.sub :: _ \<Rightarrow> _ \<Rightarrow> integer)"
  by (unfold Num.sub_def [abs_def]) transfer_prover

lemma int_of_integer_of_nat [simp]:
  "int_of_integer (of_nat n) = of_nat n"
  by transfer rule

lift_definition integer_of_nat :: "nat \<Rightarrow> integer"
  is "of_nat :: nat \<Rightarrow> int"
  .

lemma integer_of_nat_eq_of_nat [code]:
  "integer_of_nat = of_nat"
  by transfer rule

lemma int_of_integer_integer_of_nat [simp]:
  "int_of_integer (integer_of_nat n) = of_nat n"
  by transfer rule

lift_definition nat_of_integer :: "integer \<Rightarrow> nat"
  is Int.nat
  .

lemma nat_of_integer_of_nat [simp]:
  "nat_of_integer (of_nat n) = n"
  by transfer simp

lemma int_of_integer_of_int [simp]:
  "int_of_integer (of_int k) = k"
  by transfer simp

lemma nat_of_integer_integer_of_nat [simp]:
  "nat_of_integer (integer_of_nat n) = n"
  by transfer simp

lemma integer_of_int_eq_of_int [simp, code_abbrev]:
  "integer_of_int = of_int"
  by transfer (simp add: fun_eq_iff)

lemma of_int_integer_of [simp]:
  "of_int (int_of_integer k) = (k :: integer)"
  by transfer rule

lemma int_of_integer_numeral [simp]:
  "int_of_integer (numeral k) = numeral k"
  by transfer rule

lemma int_of_integer_sub [simp]:
  "int_of_integer (Num.sub k l) = Num.sub k l"
  by transfer rule

instantiation integer :: "{ring_div, equal, linordered_idom}"
begin

lift_definition div_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer"
  is "Divides.div :: int \<Rightarrow> int \<Rightarrow> int"
  .

declare div_integer.rep_eq [simp]

lift_definition mod_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer"
  is "Divides.mod :: int \<Rightarrow> int \<Rightarrow> int"
  .

declare mod_integer.rep_eq [simp]

lift_definition abs_integer :: "integer \<Rightarrow> integer"
  is "abs :: int \<Rightarrow> int"
  .

declare abs_integer.rep_eq [simp]

lift_definition sgn_integer :: "integer \<Rightarrow> integer"
  is "sgn :: int \<Rightarrow> int"
  .

declare sgn_integer.rep_eq [simp]

lift_definition less_eq_integer :: "integer \<Rightarrow> integer \<Rightarrow> bool"
  is "less_eq :: int \<Rightarrow> int \<Rightarrow> bool"
  .

lift_definition less_integer :: "integer \<Rightarrow> integer \<Rightarrow> bool"
  is "less :: int \<Rightarrow> int \<Rightarrow> bool"
  .

lift_definition equal_integer :: "integer \<Rightarrow> integer \<Rightarrow> bool"
  is "HOL.equal :: int \<Rightarrow> int \<Rightarrow> bool"
  .

instance proof
qed (transfer, simp add: algebra_simps equal less_le_not_le [symmetric] mult_strict_right_mono linear)+

end

lemma [transfer_rule]:
  "rel_fun pcr_integer (rel_fun pcr_integer pcr_integer) (min :: _ \<Rightarrow> _ \<Rightarrow> int) (min :: _ \<Rightarrow> _ \<Rightarrow> integer)"
  by (unfold min_def [abs_def]) transfer_prover

lemma [transfer_rule]:
  "rel_fun pcr_integer (rel_fun pcr_integer pcr_integer) (max :: _ \<Rightarrow> _ \<Rightarrow> int) (max :: _ \<Rightarrow> _ \<Rightarrow> integer)"
  by (unfold max_def [abs_def]) transfer_prover

lemma int_of_integer_min [simp]:
  "int_of_integer (min k l) = min (int_of_integer k) (int_of_integer l)"
  by transfer rule

lemma int_of_integer_max [simp]:
  "int_of_integer (max k l) = max (int_of_integer k) (int_of_integer l)"
  by transfer rule

lemma nat_of_integer_non_positive [simp]:
  "k \<le> 0 \<Longrightarrow> nat_of_integer k = 0"
  by transfer simp

lemma of_nat_of_integer [simp]:
  "of_nat (nat_of_integer k) = max 0 k"
  by transfer auto

instance integer :: semiring_numeral_div
  by intro_classes (transfer,
    fact semiring_numeral_div_class.diff_invert_add1
    semiring_numeral_div_class.le_add_diff_inverse2
    semiring_numeral_div_class.mult_div_cancel
    semiring_numeral_div_class.div_less
    semiring_numeral_div_class.mod_less
    semiring_numeral_div_class.div_positive
    semiring_numeral_div_class.mod_less_eq_dividend
    semiring_numeral_div_class.pos_mod_bound
    semiring_numeral_div_class.pos_mod_sign
    semiring_numeral_div_class.mod_mult2_eq
    semiring_numeral_div_class.div_mult2_eq
    semiring_numeral_div_class.discrete)+

lemma integer_of_nat_0: "integer_of_nat 0 = 0"
by transfer simp

lemma integer_of_nat_1: "integer_of_nat 1 = 1"
by transfer simp

lemma integer_of_nat_numeral:
  "integer_of_nat (numeral n) = numeral n"
by transfer simp

subsection {* Code theorems for target language integers *}

text {* Constructors *}

definition Pos :: "num \<Rightarrow> integer"
where
  [simp, code_abbrev]: "Pos = numeral"

lemma [transfer_rule]:
  "rel_fun HOL.eq pcr_integer numeral Pos"
  by simp transfer_prover

definition Neg :: "num \<Rightarrow> integer"
where
  [simp, code_abbrev]: "Neg n = - Pos n"

lemma [transfer_rule]:
  "rel_fun HOL.eq pcr_integer (\<lambda>n. - numeral n) Neg"
  by (simp add: Neg_def [abs_def]) transfer_prover

code_datatype "0::integer" Pos Neg

text {* Auxiliary operations *}

lift_definition dup :: "integer \<Rightarrow> integer"
  is "\<lambda>k::int. k + k"
  .

lemma dup_code [code]:
  "dup 0 = 0"
  "dup (Pos n) = Pos (Num.Bit0 n)"
  "dup (Neg n) = Neg (Num.Bit0 n)"
  by (transfer, simp only: numeral_Bit0 minus_add_distrib)+

lift_definition sub :: "num \<Rightarrow> num \<Rightarrow> integer"
  is "\<lambda>m n. numeral m - numeral n :: int"
  .

lemma sub_code [code]:
  "sub Num.One Num.One = 0"
  "sub (Num.Bit0 m) Num.One = Pos (Num.BitM m)"
  "sub (Num.Bit1 m) Num.One = Pos (Num.Bit0 m)"
  "sub Num.One (Num.Bit0 n) = Neg (Num.BitM n)"
  "sub Num.One (Num.Bit1 n) = Neg (Num.Bit0 n)"
  "sub (Num.Bit0 m) (Num.Bit0 n) = dup (sub m n)"
  "sub (Num.Bit1 m) (Num.Bit1 n) = dup (sub m n)"
  "sub (Num.Bit1 m) (Num.Bit0 n) = dup (sub m n) + 1"
  "sub (Num.Bit0 m) (Num.Bit1 n) = dup (sub m n) - 1"
  by (transfer, simp add: dbl_def dbl_inc_def dbl_dec_def)+

text {* Implementations *}

lemma one_integer_code [code, code_unfold]:
  "1 = Pos Num.One"
  by simp

lemma plus_integer_code [code]:
  "k + 0 = (k::integer)"
  "0 + l = (l::integer)"
  "Pos m + Pos n = Pos (m + n)"
  "Pos m + Neg n = sub m n"
  "Neg m + Pos n = sub n m"
  "Neg m + Neg n = Neg (m + n)"
  by (transfer, simp)+

lemma uminus_integer_code [code]:
  "uminus 0 = (0::integer)"
  "uminus (Pos m) = Neg m"
  "uminus (Neg m) = Pos m"
  by simp_all

lemma minus_integer_code [code]:
  "k - 0 = (k::integer)"
  "0 - l = uminus (l::integer)"
  "Pos m - Pos n = sub m n"
  "Pos m - Neg n = Pos (m + n)"
  "Neg m - Pos n = Neg (m + n)"
  "Neg m - Neg n = sub n m"
  by (transfer, simp)+

lemma abs_integer_code [code]:
  "\<bar>k\<bar> = (if (k::integer) < 0 then - k else k)"
  by simp

lemma sgn_integer_code [code]:
  "sgn k = (if k = 0 then 0 else if (k::integer) < 0 then - 1 else 1)"
  by simp

lemma times_integer_code [code]:
  "k * 0 = (0::integer)"
  "0 * l = (0::integer)"
  "Pos m * Pos n = Pos (m * n)"
  "Pos m * Neg n = Neg (m * n)"
  "Neg m * Pos n = Neg (m * n)"
  "Neg m * Neg n = Pos (m * n)"
  by simp_all

definition divmod_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer \<times> integer"
where
  "divmod_integer k l = (k div l, k mod l)"

lemma fst_divmod [simp]:
  "fst (divmod_integer k l) = k div l"
  by (simp add: divmod_integer_def)

lemma snd_divmod [simp]:
  "snd (divmod_integer k l) = k mod l"
  by (simp add: divmod_integer_def)

definition divmod_abs :: "integer \<Rightarrow> integer \<Rightarrow> integer \<times> integer"
where
  "divmod_abs k l = (\<bar>k\<bar> div \<bar>l\<bar>, \<bar>k\<bar> mod \<bar>l\<bar>)"

lemma fst_divmod_abs [simp]:
  "fst (divmod_abs k l) = \<bar>k\<bar> div \<bar>l\<bar>"
  by (simp add: divmod_abs_def)

lemma snd_divmod_abs [simp]:
  "snd (divmod_abs k l) = \<bar>k\<bar> mod \<bar>l\<bar>"
  by (simp add: divmod_abs_def)

lemma divmod_abs_code [code]:
  "divmod_abs (Pos k) (Pos l) = divmod k l"
  "divmod_abs (Neg k) (Neg l) = divmod k l"
  "divmod_abs (Neg k) (Pos l) = divmod k l"
  "divmod_abs (Pos k) (Neg l) = divmod k l"
  "divmod_abs j 0 = (0, \<bar>j\<bar>)"
  "divmod_abs 0 j = (0, 0)"
  by (simp_all add: prod_eq_iff)

lemma divmod_integer_code [code]:
  "divmod_integer k l =
    (if k = 0 then (0, 0) else if l = 0 then (0, k) else
    (apsnd \<circ> times \<circ> sgn) l (if sgn k = sgn l
      then divmod_abs k l
      else (let (r, s) = divmod_abs k l in
        if s = 0 then (- r, 0) else (- r - 1, \<bar>l\<bar> - s))))"
proof -
  have aux1: "\<And>k l::int. sgn k = sgn l \<longleftrightarrow> k = 0 \<and> l = 0 \<or> 0 < l \<and> 0 < k \<or> l < 0 \<and> k < 0"
    by (auto simp add: sgn_if)
  have aux2: "\<And>q::int. - int_of_integer k = int_of_integer l * q \<longleftrightarrow> int_of_integer k = int_of_integer l * - q" by auto
  show ?thesis
    by (simp add: prod_eq_iff integer_eq_iff case_prod_beta aux1)
      (auto simp add: zdiv_zminus1_eq_if zmod_zminus1_eq_if div_minus_right mod_minus_right aux2)
qed

lemma div_integer_code [code]:
  "k div l = fst (divmod_integer k l)"
  by simp

lemma mod_integer_code [code]:
  "k mod l = snd (divmod_integer k l)"
  by simp

lemma equal_integer_code [code]:
  "HOL.equal 0 (0::integer) \<longleftrightarrow> True"
  "HOL.equal 0 (Pos l) \<longleftrightarrow> False"
  "HOL.equal 0 (Neg l) \<longleftrightarrow> False"
  "HOL.equal (Pos k) 0 \<longleftrightarrow> False"
  "HOL.equal (Pos k) (Pos l) \<longleftrightarrow> HOL.equal k l"
  "HOL.equal (Pos k) (Neg l) \<longleftrightarrow> False"
  "HOL.equal (Neg k) 0 \<longleftrightarrow> False"
  "HOL.equal (Neg k) (Pos l) \<longleftrightarrow> False"
  "HOL.equal (Neg k) (Neg l) \<longleftrightarrow> HOL.equal k l"
  by (simp_all add: equal)

lemma equal_integer_refl [code nbe]:
  "HOL.equal (k::integer) k \<longleftrightarrow> True"
  by (fact equal_refl)

lemma less_eq_integer_code [code]:
  "0 \<le> (0::integer) \<longleftrightarrow> True"
  "0 \<le> Pos l \<longleftrightarrow> True"
  "0 \<le> Neg l \<longleftrightarrow> False"
  "Pos k \<le> 0 \<longleftrightarrow> False"
  "Pos k \<le> Pos l \<longleftrightarrow> k \<le> l"
  "Pos k \<le> Neg l \<longleftrightarrow> False"
  "Neg k \<le> 0 \<longleftrightarrow> True"
  "Neg k \<le> Pos l \<longleftrightarrow> True"
  "Neg k \<le> Neg l \<longleftrightarrow> l \<le> k"
  by simp_all

lemma less_integer_code [code]:
  "0 < (0::integer) \<longleftrightarrow> False"
  "0 < Pos l \<longleftrightarrow> True"
  "0 < Neg l \<longleftrightarrow> False"
  "Pos k < 0 \<longleftrightarrow> False"
  "Pos k < Pos l \<longleftrightarrow> k < l"
  "Pos k < Neg l \<longleftrightarrow> False"
  "Neg k < 0 \<longleftrightarrow> True"
  "Neg k < Pos l \<longleftrightarrow> True"
  "Neg k < Neg l \<longleftrightarrow> l < k"
  by simp_all

lift_definition integer_of_num :: "num \<Rightarrow> integer"
  is "numeral :: num \<Rightarrow> int"
  .

lemma integer_of_num [code]:
  "integer_of_num num.One = 1"
  "integer_of_num (num.Bit0 n) = (let k = integer_of_num n in k + k)"
  "integer_of_num (num.Bit1 n) = (let k = integer_of_num n in k + k + 1)"
  by (transfer, simp only: numeral.simps Let_def)+

lift_definition num_of_integer :: "integer \<Rightarrow> num"
  is "num_of_nat \<circ> nat"
  .

lemma num_of_integer_code [code]:
  "num_of_integer k = (if k \<le> 1 then Num.One
     else let
       (l, j) = divmod_integer k 2;
       l' = num_of_integer l;
       l'' = l' + l'
     in if j = 0 then l'' else l'' + Num.One)"
proof -
  {
    assume "int_of_integer k mod 2 = 1"
    then have "nat (int_of_integer k mod 2) = nat 1" by simp
    moreover assume *: "1 < int_of_integer k"
    ultimately have **: "nat (int_of_integer k) mod 2 = 1" by (simp add: nat_mod_distrib)
    have "num_of_nat (nat (int_of_integer k)) =
      num_of_nat (2 * (nat (int_of_integer k) div 2) + nat (int_of_integer k) mod 2)"
      by simp
    then have "num_of_nat (nat (int_of_integer k)) =
      num_of_nat (nat (int_of_integer k) div 2 + nat (int_of_integer k) div 2 + nat (int_of_integer k) mod 2)"
      by (simp add: mult_2)
    with ** have "num_of_nat (nat (int_of_integer k)) =
      num_of_nat (nat (int_of_integer k) div 2 + nat (int_of_integer k) div 2 + 1)"
      by simp
  }
  note aux = this
  show ?thesis
    by (auto simp add: num_of_integer_def nat_of_integer_def Let_def case_prod_beta
      not_le integer_eq_iff less_eq_integer_def
      nat_mult_distrib nat_div_distrib num_of_nat_One num_of_nat_plus_distrib
       mult_2 [where 'a=nat] aux add_One)
qed

lemma nat_of_integer_code [code]:
  "nat_of_integer k = (if k \<le> 0 then 0
     else let
       (l, j) = divmod_integer k 2;
       l' = nat_of_integer l;
       l'' = l' + l'
     in if j = 0 then l'' else l'' + 1)"
proof -
  obtain j where "k = integer_of_int j"
  proof
    show "k = integer_of_int (int_of_integer k)" by simp
  qed
  moreover have "2 * (j div 2) = j - j mod 2"
    by (simp add: zmult_div_cancel mult.commute)
  ultimately show ?thesis
    by (auto simp add: split_def Let_def mod_integer_def nat_of_integer_def not_le
      nat_add_distrib [symmetric] Suc_nat_eq_nat_zadd1)
      (auto simp add: mult_2 [symmetric])
qed

lemma int_of_integer_code [code]:
  "int_of_integer k = (if k < 0 then - (int_of_integer (- k))
     else if k = 0 then 0
     else let
       (l, j) = divmod_integer k 2;
       l' = 2 * int_of_integer l
     in if j = 0 then l' else l' + 1)"
  by (auto simp add: split_def Let_def integer_eq_iff zmult_div_cancel)

lemma integer_of_int_code [code]:
  "integer_of_int k = (if k < 0 then - (integer_of_int (- k))
     else if k = 0 then 0
     else let
       (l, j) = divmod_int k 2;
       l' = 2 * integer_of_int l
     in if j = 0 then l' else l' + 1)"
  by (auto simp add: split_def Let_def integer_eq_iff zmult_div_cancel)

hide_const (open) Pos Neg sub dup divmod_abs

subsection {* Serializer setup for target language integers *}

code_reserved Eval int Integer abs

code_printing
  type_constructor integer \<rightharpoonup>
    (SML) "IntInf.int"
    and (OCaml) "Big'_int.big'_int"
    and (Haskell) "Integer"
    and (Scala) "BigInt"
    and (Eval) "int"
| class_instance integer :: equal \<rightharpoonup>
    (Haskell) -

code_printing
  constant "0::integer" \<rightharpoonup>
    (SML) "!(0/ :/ IntInf.int)"
    and (OCaml) "Big'_int.zero'_big'_int"
    and (Haskell) "!(0/ ::/ Integer)"
    and (Scala) "BigInt(0)"

setup {*
  fold (fn target =>
    Numeral.add_code @{const_name Code_Numeral.Pos} I Code_Printer.literal_numeral target
    #> Numeral.add_code @{const_name Code_Numeral.Neg} (op ~) Code_Printer.literal_numeral target)
    ["SML", "OCaml", "Haskell", "Scala"]
*}

code_printing
  constant "plus :: integer \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
    (SML) "IntInf.+ ((_), (_))"
    and (OCaml) "Big'_int.add'_big'_int"
    and (Haskell) infixl 6 "+"
    and (Scala) infixl 7 "+"
    and (Eval) infixl 8 "+"
| constant "uminus :: integer \<Rightarrow> _" \<rightharpoonup>
    (SML) "IntInf.~"
    and (OCaml) "Big'_int.minus'_big'_int"
    and (Haskell) "negate"
    and (Scala) "!(- _)"
    and (Eval) "~/ _"
| constant "minus :: integer \<Rightarrow> _" \<rightharpoonup>
    (SML) "IntInf.- ((_), (_))"
    and (OCaml) "Big'_int.sub'_big'_int"
    and (Haskell) infixl 6 "-"
    and (Scala) infixl 7 "-"
    and (Eval) infixl 8 "-"
| constant Code_Numeral.dup \<rightharpoonup>
    (SML) "IntInf.*/ (2,/ (_))"
    and (OCaml) "Big'_int.mult'_big'_int/ (Big'_int.big'_int'_of'_int/ 2)"
    and (Haskell) "!(2 * _)"
    and (Scala) "!(2 * _)"
    and (Eval) "!(2 * _)"
| constant Code_Numeral.sub \<rightharpoonup>
    (SML) "!(raise/ Fail/ \"sub\")"
    and (OCaml) "failwith/ \"sub\""
    and (Haskell) "error/ \"sub\""
    and (Scala) "!sys.error(\"sub\")"
| constant "times :: integer \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
    (SML) "IntInf.* ((_), (_))"
    and (OCaml) "Big'_int.mult'_big'_int"
    and (Haskell) infixl 7 "*"
    and (Scala) infixl 8 "*"
    and (Eval) infixl 9 "*"
| constant Code_Numeral.divmod_abs \<rightharpoonup>
    (SML) "IntInf.divMod/ (IntInf.abs _,/ IntInf.abs _)"
    and (OCaml) "Big'_int.quomod'_big'_int/ (Big'_int.abs'_big'_int _)/ (Big'_int.abs'_big'_int _)"
    and (Haskell) "divMod/ (abs _)/ (abs _)"
    and (Scala) "!((k: BigInt) => (l: BigInt) =>/ if (l == 0)/ (BigInt(0), k) else/ (k.abs '/% l.abs))"
    and (Eval) "Integer.div'_mod/ (abs _)/ (abs _)"
| constant "HOL.equal :: integer \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
    (SML) "!((_ : IntInf.int) = _)"
    and (OCaml) "Big'_int.eq'_big'_int"
    and (Haskell) infix 4 "=="
    and (Scala) infixl 5 "=="
    and (Eval) infixl 6 "="
| constant "less_eq :: integer \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
    (SML) "IntInf.<= ((_), (_))"
    and (OCaml) "Big'_int.le'_big'_int"
    and (Haskell) infix 4 "<="
    and (Scala) infixl 4 "<="
    and (Eval) infixl 6 "<="
| constant "less :: integer \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
    (SML) "IntInf.< ((_), (_))"
    and (OCaml) "Big'_int.lt'_big'_int"
    and (Haskell) infix 4 "<"
    and (Scala) infixl 4 "<"
    and (Eval) infixl 6 "<"

code_identifier
  code_module Code_Numeral \<rightharpoonup> (SML) Arith and (OCaml) Arith and (Haskell) Arith

subsection {* Type of target language naturals *}

typedef natural = "UNIV \<Colon> nat set"
  morphisms nat_of_natural natural_of_nat ..

setup_lifting (no_code) type_definition_natural

lemma natural_eq_iff [termination_simp]:
  "m = n \<longleftrightarrow> nat_of_natural m = nat_of_natural n"
  by transfer rule

lemma natural_eqI:
  "nat_of_natural m = nat_of_natural n \<Longrightarrow> m = n"
  using natural_eq_iff [of m n] by simp

lemma nat_of_natural_of_nat_inverse [simp]:
  "nat_of_natural (natural_of_nat n) = n"
  by transfer rule

lemma natural_of_nat_of_natural_inverse [simp]:
  "natural_of_nat (nat_of_natural n) = n"
  by transfer rule

instantiation natural :: "{comm_monoid_diff, semiring_1}"
begin

lift_definition zero_natural :: natural
  is "0 :: nat"
  .

declare zero_natural.rep_eq [simp]

lift_definition one_natural :: natural
  is "1 :: nat"
  .

declare one_natural.rep_eq [simp]

lift_definition plus_natural :: "natural \<Rightarrow> natural \<Rightarrow> natural"
  is "plus :: nat \<Rightarrow> nat \<Rightarrow> nat"
  .

declare plus_natural.rep_eq [simp]

lift_definition minus_natural :: "natural \<Rightarrow> natural \<Rightarrow> natural"
  is "minus :: nat \<Rightarrow> nat \<Rightarrow> nat"
  .

declare minus_natural.rep_eq [simp]

lift_definition times_natural :: "natural \<Rightarrow> natural \<Rightarrow> natural"
  is "times :: nat \<Rightarrow> nat \<Rightarrow> nat"
  .

declare times_natural.rep_eq [simp]

instance proof
qed (transfer, simp add: algebra_simps)+

end

lemma [transfer_rule]:
  "rel_fun HOL.eq pcr_natural (\<lambda>n::nat. n) (of_nat :: nat \<Rightarrow> natural)"
proof -
  have "rel_fun HOL.eq pcr_natural (of_nat :: nat \<Rightarrow> nat) (of_nat :: nat \<Rightarrow> natural)"
    by (unfold of_nat_def [abs_def]) transfer_prover
  then show ?thesis by (simp add: id_def)
qed

lemma [transfer_rule]:
  "rel_fun HOL.eq pcr_natural (numeral :: num \<Rightarrow> nat) (numeral :: num \<Rightarrow> natural)"
proof -
  have "rel_fun HOL.eq pcr_natural (numeral :: num \<Rightarrow> nat) (\<lambda>n. of_nat (numeral n))"
    by transfer_prover
  then show ?thesis by simp
qed

lemma nat_of_natural_of_nat [simp]:
  "nat_of_natural (of_nat n) = n"
  by transfer rule

lemma natural_of_nat_of_nat [simp, code_abbrev]:
  "natural_of_nat = of_nat"
  by transfer rule

lemma of_nat_of_natural [simp]:
  "of_nat (nat_of_natural n) = n"
  by transfer rule

lemma nat_of_natural_numeral [simp]:
  "nat_of_natural (numeral k) = numeral k"
  by transfer rule

instantiation natural :: "{semiring_div, equal, linordered_semiring}"
begin

lift_definition div_natural :: "natural \<Rightarrow> natural \<Rightarrow> natural"
  is "Divides.div :: nat \<Rightarrow> nat \<Rightarrow> nat"
  .

declare div_natural.rep_eq [simp]

lift_definition mod_natural :: "natural \<Rightarrow> natural \<Rightarrow> natural"
  is "Divides.mod :: nat \<Rightarrow> nat \<Rightarrow> nat"
  .

declare mod_natural.rep_eq [simp]

lift_definition less_eq_natural :: "natural \<Rightarrow> natural \<Rightarrow> bool"
  is "less_eq :: nat \<Rightarrow> nat \<Rightarrow> bool"
  .

declare less_eq_natural.rep_eq [termination_simp]

lift_definition less_natural :: "natural \<Rightarrow> natural \<Rightarrow> bool"
  is "less :: nat \<Rightarrow> nat \<Rightarrow> bool"
  .

declare less_natural.rep_eq [termination_simp]

lift_definition equal_natural :: "natural \<Rightarrow> natural \<Rightarrow> bool"
  is "HOL.equal :: nat \<Rightarrow> nat \<Rightarrow> bool"
  .

instance proof
qed (transfer, simp add: algebra_simps equal less_le_not_le [symmetric] linear)+

end

lemma [transfer_rule]:
  "rel_fun pcr_natural (rel_fun pcr_natural pcr_natural) (min :: _ \<Rightarrow> _ \<Rightarrow> nat) (min :: _ \<Rightarrow> _ \<Rightarrow> natural)"
  by (unfold min_def [abs_def]) transfer_prover

lemma [transfer_rule]:
  "rel_fun pcr_natural (rel_fun pcr_natural pcr_natural) (max :: _ \<Rightarrow> _ \<Rightarrow> nat) (max :: _ \<Rightarrow> _ \<Rightarrow> natural)"
  by (unfold max_def [abs_def]) transfer_prover

lemma nat_of_natural_min [simp]:
  "nat_of_natural (min k l) = min (nat_of_natural k) (nat_of_natural l)"
  by transfer rule

lemma nat_of_natural_max [simp]:
  "nat_of_natural (max k l) = max (nat_of_natural k) (nat_of_natural l)"
  by transfer rule

lift_definition natural_of_integer :: "integer \<Rightarrow> natural"
  is "nat :: int \<Rightarrow> nat"
  .

lift_definition integer_of_natural :: "natural \<Rightarrow> integer"
  is "of_nat :: nat \<Rightarrow> int"
  .

lemma natural_of_integer_of_natural [simp]:
  "natural_of_integer (integer_of_natural n) = n"
  by transfer simp

lemma integer_of_natural_of_integer [simp]:
  "integer_of_natural (natural_of_integer k) = max 0 k"
  by transfer auto

lemma int_of_integer_of_natural [simp]:
  "int_of_integer (integer_of_natural n) = of_nat (nat_of_natural n)"
  by transfer rule

lemma integer_of_natural_of_nat [simp]:
  "integer_of_natural (of_nat n) = of_nat n"
  by transfer rule

lemma [measure_function]:
  "is_measure nat_of_natural"
  by (rule is_measure_trivial)

subsection {* Inductive representation of target language naturals *}

lift_definition Suc :: "natural \<Rightarrow> natural"
  is Nat.Suc
  .

declare Suc.rep_eq [simp]

old_rep_datatype "0::natural" Suc
  by (transfer, fact nat.induct nat.inject nat.distinct)+

lemma natural_cases [case_names nat, cases type: natural]:
  fixes m :: natural
  assumes "\<And>n. m = of_nat n \<Longrightarrow> P"
  shows P
  using assms by transfer blast

lemma [simp, code]: "size_natural = nat_of_natural"
proof (rule ext)
  fix n
  show "size_natural n = nat_of_natural n"
    by (induct n) simp_all
qed

lemma [simp, code]: "size = nat_of_natural"
proof (rule ext)
  fix n
  show "size n = nat_of_natural n"
    by (induct n) simp_all
qed

lemma natural_decr [termination_simp]:
  "n \<noteq> 0 \<Longrightarrow> nat_of_natural n - Nat.Suc 0 < nat_of_natural n"
  by transfer simp

lemma natural_zero_minus_one: "(0::natural) - 1 = 0"
  by (rule zero_diff)

lemma Suc_natural_minus_one: "Suc n - 1 = n"
  by transfer simp

hide_const (open) Suc

subsection {* Code refinement for target language naturals *}

lift_definition Nat :: "integer \<Rightarrow> natural"
  is nat
  .

lemma [code_post]:
  "Nat 0 = 0"
  "Nat 1 = 1"
  "Nat (numeral k) = numeral k"
  by (transfer, simp)+

lemma [code abstype]:
  "Nat (integer_of_natural n) = n"
  by transfer simp

lemma [code abstract]:
  "integer_of_natural (natural_of_nat n) = of_nat n"
  by simp

lemma [code abstract]:
  "integer_of_natural (natural_of_integer k) = max 0 k"
  by simp

lemma [code_abbrev]:
  "natural_of_integer (Code_Numeral.Pos k) = numeral k"
  by transfer simp

lemma [code abstract]:
  "integer_of_natural 0 = 0"
  by transfer simp

lemma [code abstract]:
  "integer_of_natural 1 = 1"
  by transfer simp

lemma [code abstract]:
  "integer_of_natural (Code_Numeral.Suc n) = integer_of_natural n + 1"
  by transfer simp

lemma [code, code_unfold]:
  "case_natural f g n = (if n = 0 then f else g (n - 1))"
  by (cases n rule: natural.exhaust) (simp_all, simp add: Suc_def)

declare natural.rec [code del]

lemma [code abstract]:
  "integer_of_natural (m + n) = integer_of_natural m + integer_of_natural n"
  by transfer simp

lemma [code abstract]:
  "integer_of_natural (m - n) = max 0 (integer_of_natural m - integer_of_natural n)"
  by transfer simp

lemma [code abstract]:
  "integer_of_natural (m * n) = integer_of_natural m * integer_of_natural n"
  by transfer (simp add: of_nat_mult)

lemma [code abstract]:
  "integer_of_natural (m div n) = integer_of_natural m div integer_of_natural n"
  by transfer (simp add: zdiv_int)

lemma [code abstract]:
  "integer_of_natural (m mod n) = integer_of_natural m mod integer_of_natural n"
  by transfer (simp add: zmod_int)

lemma [code]:
  "HOL.equal m n \<longleftrightarrow> HOL.equal (integer_of_natural m) (integer_of_natural n)"
  by transfer (simp add: equal)

lemma [code nbe]: "HOL.equal n (n::natural) \<longleftrightarrow> True"
  by (rule equal_class.equal_refl)

lemma [code]: "m \<le> n \<longleftrightarrow> integer_of_natural m \<le> integer_of_natural n"
  by transfer simp

lemma [code]: "m < n \<longleftrightarrow> integer_of_natural m < integer_of_natural n"
  by transfer simp

hide_const (open) Nat

lifting_update integer.lifting
lifting_forget integer.lifting

lifting_update natural.lifting
lifting_forget natural.lifting

code_reflect Code_Numeral
  datatypes natural = _
  functions integer_of_natural natural_of_integer

end


(*******************************************************************************

  Symmetric (shared) and asymmetric (public/private) keys.
  (based on Larry Paulson's theory Public.thy)

*******************************************************************************)

section \<open>Symmetric and Asymetric Keys\<close>

theory Keys imports Agents begin

text \<open>Divide keys into session and long-term keys. Define different kinds
of long-term keys in second step.\<close>

datatype key =    \<comment> \<open>long-term keys\<close>
  macK "as"     \<comment> \<open>local MACing key\<close>
| pubK "as"     \<comment> \<open>as's public key\<close>
| priK "as"     \<comment> \<open>as's private key\<close>

text\<open>The inverse of a symmetric key is itself; that of a public key
       is the private key and vice versa\<close>

fun invKey :: "key \<Rightarrow> key" where
  "invKey (pubK A) = priK A"
| "invKey (priK A) = pubK A"
| "invKey K = K"

definition
  symKeys :: "key set" where
  "symKeys \<equiv> {K. invKey K = K}"

lemma invKey_K: "K \<in> symKeys \<Longrightarrow> invKey K = K"
by (simp add: symKeys_def)

text \<open>Most lemmas we need come for free with the inductive type definition:
injectiveness and distinctness.\<close>

lemma invKey_invKey_id [simp]: "invKey (invKey K) = K"
by (cases K, auto)

lemma invKey_eq [simp]: "(invKey K = invKey K') = (K=K')"
apply (safe)
apply (drule_tac f=invKey in arg_cong, simp)
done

text \<open>We get most lemmas below for free from the inductive definition
of type @{typ key}. Many of these are just proved as a reality check.\<close>

subsection\<open>Asymmetric Keys\<close>
(******************************************************************************)

text \<open>No private key equals any public key (essential to ensure that private
keys are private!). A similar statement an axiom in Paulson's theory!\<close>

lemma privateKey_neq_publicKey: "priK A \<noteq> pubK A'"
by auto

lemma publicKey_neq_privateKey: "pubK A \<noteq> priK A'"
by auto

subsection\<open>Basic properties of @{term pubK} and @{term priK}\<close>

lemma publicKey_inject [iff]: "(pubK A = pubK A') = (A = A')"
by (auto)

lemma not_symKeys_pubK [iff]: "pubK A \<notin> symKeys"
by (simp add: symKeys_def)

lemma not_symKeys_priK [iff]: "priK A \<notin> symKeys"
by (simp add: symKeys_def)

lemma symKey_neq_priK: "K \<in> symKeys \<Longrightarrow> K \<noteq> priK A"
by (auto simp add: symKeys_def)

lemma symKeys_neq_imp_neq: "(K \<in> symKeys) \<noteq> (K' \<in> symKeys) \<Longrightarrow> K \<noteq> K'"
by blast

lemma symKeys_invKey_iff [iff]: "(invKey K \<in> symKeys) = (K \<in> symKeys)"
by (unfold symKeys_def, auto)

subsection\<open>"Image" equations that hold for injective functions\<close>

lemma invKey_image_eq [simp]: "(invKey x \<in> invKey`A) = (x \<in> A)"
by auto

(*holds because invKey is injective*)

lemma invKey_pubK_image_priK_image [simp]: "invKey ` pubK ` AS = priK ` AS"
by (auto simp add: image_def)

lemma publicKey_notin_image_privateKey: "pubK A \<notin> priK ` AS"
by auto

lemma privateKey_notin_image_publicKey: "priK x \<notin> pubK ` AA"
by auto

lemma publicKey_image_eq [simp]: "(pubK x \<in> pubK ` AA) = (x \<in> AA)"
by auto

lemma privateKey_image_eq [simp]: "(priK A \<in> priK ` AS) = (A \<in> AS)"
by auto

subsection\<open>Symmetric Keys\<close>
(******************************************************************************)

text \<open>The following was stated as an axiom in Paulson's theory.\<close>

lemma sym_shrK: "macK X \<in> symKeys"   \<comment> \<open>All shared keys are symmetric\<close>
by (simp add: symKeys_def)

text \<open>Symmetric keys and inversion\<close>

lemma symK_eq_invKey: "\<lbrakk> SK = invKey K; SK \<in> symKeys \<rbrakk> \<Longrightarrow> K = SK"
by (auto simp add: symKeys_def)

text \<open>Image-related lemmas.\<close>

lemma publicKey_notin_image_shrK: "pubK x \<notin> macK ` AA"
by auto

lemma privateKey_notin_image_shrK: "priK x \<notin> macK ` AA"
by auto

lemma shrK_notin_image_publicKey: "macK x \<notin> pubK ` AA"
by auto

lemma shrK_notin_image_privateKey: "macK x \<notin> priK ` AA"
by auto

lemma shrK_image_eq [simp]: "(macK x \<in> macK ` AA) = (x \<in> AA)"
by auto

end


(*<*)
(*
 * Domains of natural numbers.
 * (C)opyright 2009-2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory Nats
imports HOLCF
begin
(*>*)

section\<open>Boxed Types, HOL's natural numbers hoisted.\<close>

subsection\<open>Unboxed naturals.\<close>

text\<open>We can represent the unboxed naturals as a discrete domain (every
number is equal to itself and unequal to everything else, and there is no
bottom). Think of these functions as the machine operations.

We could actually lift all HOL types and classes in this way; indeed
the HOLCF theory "Lift" does something similar, but is not as
fine-grained as this development.

Note: we default to just CPOs (not pointed CPOs) in this theory. We
adopt bothg the Isabelle syntax for overloaded arithmetic and the
notation for unboxed operators of \citet{SPJ-JL:1991}.\<close>

default_sort predomain

type_synonym UNat = "nat discr"

instantiation discr :: (zero) zero
begin
definition zero_discr_def: "0 \<equiv> Discr 0"
instance ..
end

lemma zero_discr[simp]: "undiscr 0 = 0" unfolding zero_discr_def by simp

instantiation discr :: (one) one
begin
definition one_discr_def: "1 \<equiv> Discr 1"
instance ..
end

lemma one_discr[simp]: "undiscr 1 = 1" unfolding one_discr_def by simp

instantiation discr :: (ord) ord
begin
definition less_def[simp]: "m < n \<equiv> (undiscr m) < (undiscr n)"
definition le_def[simp]:   "m \<le> n \<equiv> (undiscr m) \<le> (undiscr n)"
instance ..
end

definition
  uPlus :: "UNat \<rightarrow> UNat \<rightarrow> UNat" where
  "uPlus \<equiv> \<Lambda> x y. Discr (undiscr x + undiscr y)"

abbreviation
  uPlus_syn :: "UNat \<Rightarrow> UNat \<Rightarrow> UNat" (infixl "+\<^sub>#" 65) where
  "x +\<^sub># y \<equiv> uPlus\<cdot>x\<cdot>y"

instantiation discr :: (plus) plus
begin
definition plus_discr_def[simp]: "x + y \<equiv> Discr (undiscr x + undiscr y)"
instance ..
end

definition
  uMinus :: "UNat \<rightarrow> UNat \<rightarrow> UNat" where
  "uMinus \<equiv> \<Lambda> x y. Discr (undiscr x - undiscr y)"

abbreviation
  uMinus_syn :: "UNat \<Rightarrow> UNat \<Rightarrow> UNat" (infixl "-\<^sub>#" 65) where
  "x -\<^sub># y \<equiv> uMinus\<cdot>x\<cdot>y"

instantiation discr :: (minus) minus
begin
definition minus_discr_def[simp]: "x - y \<equiv> Discr (undiscr x - undiscr y)"
instance ..
end

definition
  uMult :: "UNat \<rightarrow> UNat \<rightarrow> UNat" where
  "uMult \<equiv> \<Lambda> x y. Discr (undiscr x * undiscr y)"

abbreviation
  uMult_syn :: "UNat \<Rightarrow> UNat \<Rightarrow> UNat" (infixl "*\<^sub>#" 65) where
  "x *\<^sub># y \<equiv> uMult\<cdot>x\<cdot>y"

instantiation discr :: (times) times
begin
definition times_discr_def[simp]: "x * y \<equiv> Discr (undiscr x * undiscr y)"
instance ..
end

lemma uMult_unit_left: "1 *\<^sub># (x::UNat) = x"
  unfolding uMult_def one_discr_def by simp
lemma uMult_unit_right: "(x::UNat) *\<^sub># 1 = x"
  unfolding uMult_def one_discr_def by simp

lemma uMult_assoc: "(x *\<^sub># y) *\<^sub># z = x *\<^sub># (y *\<^sub># z)"
  unfolding uMult_def by simp

lemma uMult_commute: "x *\<^sub># y = y *\<^sub># x"
  unfolding uMult_def by simp

lemma uMult_left_commute: "a *\<^sub># (b *\<^sub># c) = b *\<^sub># (a *\<^sub># c)"
  unfolding uMult_def by simp

lemmas uMult_arithmetic =
  uMult_unit_left uMult_unit_right uMult_assoc uMult_commute uMult_left_commute

subsection \<open>The "@{term \<bottom>}" monad.\<close>

text\<open>

As Brian Huffman helpfully observed, the "@{term "\<bottom>"}" type
constructor supports the monadic operations; it's isomorphic to
Haskell's @{term "Maybe a"}, or ML's @{typ "'a option"}.

Note that @{term "return"} is @{term "up"}.

\<close>

definition
  bbind :: "('a::cpo)\<^sub>\<bottom> \<rightarrow> ('a \<rightarrow> ('b::pcpo)) \<rightarrow> 'b" where
  "bbind \<equiv> \<Lambda> b g. fup\<cdot>g\<cdot>b"

abbreviation
  bbind_syn :: "('a::cpo)\<^sub>\<bottom> \<Rightarrow> ('a \<rightarrow> ('b::pcpo)) \<Rightarrow> 'b" (infixl ">>=" 65) where
  "b >>= g \<equiv> bbind\<cdot>b\<cdot>g"

lemma bbind_strict1[simp]: "bbind\<cdot>\<bottom> = \<bottom>"
  by (simp add: bbind_def)
lemma bbind_strict2[simp]: "x >>= \<bottom> = \<bottom>"
  by (cases x, simp_all add: bbind_def)

lemma bbind_leftID[simp]: "up\<cdot>a >>= f = f\<cdot>a" by (simp add: bbind_def)
lemma bbind_rightID[simp]: "m >>= up = m" by (cases m, simp_all)

lemma bbind_assoc[simp]: "f >>= g >>= h = f >>= (\<Lambda> x. g\<cdot>x >>= h)"
  by (cases f, simp_all)

lemma bbind_case_distr_strict: "f\<cdot>\<bottom> = \<bottom> \<Longrightarrow> f\<cdot>(g >>= h) = g >>= (\<Lambda> x. f\<cdot>(h\<cdot>x))"
  unfolding bbind_def by (cases g, simp_all)

text\<open>

Kleisli composition is sometimes helpful. It forms a monad too,
and has many useful algebraic properties. Unfortunately it is more
work than is useful to write the lemmas in a way that makes the
higher-order unifier in the simplifier happy. Seems easier just to
unfold the definition and go from there.

\<close>

definition
  bKleisli :: "('a::cpo \<rightarrow> ('b::cpo)\<^sub>\<bottom>) \<rightarrow> ('b \<rightarrow> ('c::cpo)\<^sub>\<bottom>) \<rightarrow> ('a \<rightarrow> 'c\<^sub>\<bottom>)" where
  "bKleisli \<equiv> \<Lambda> f g x. f\<cdot>x >>= g"

abbreviation
  bKleisli_syn :: "('a::cpo \<rightarrow> ('b::cpo)\<^sub>\<bottom>) \<Rightarrow> ('b \<rightarrow> ('c::cpo)\<^sub>\<bottom>) \<Rightarrow> ('a \<rightarrow> 'c\<^sub>\<bottom>)" (infixl ">=>" 65) where
  "b >=> g \<equiv> bKleisli\<cdot>b\<cdot>g"

lemma bKleisli_strict1[simp]: "bKleisli\<cdot>\<bottom> = \<bottom>"
  by (simp add: bKleisli_def)
lemma bKleisli_strict2[simp]: "b >=> \<bottom> = \<bottom>"
  by (rule cfun_eqI, simp add: bKleisli_def)

lemma bKleisli_bbind: "(f >>= g) >=> h = f >>= (\<Lambda> x. g\<cdot>x >=> h)"
  by (cases f, simp_all)

text \<open>

The "Box" type denotes computations that, when demanded, yield
either @{term "\<bottom>"} or an unboxed value. Note that the @{term "Box"}
constructor is strict, and so merely tags the lifted computation @{typ
"'a\<^sub>\<bottom>"}. @{typ "'a"} can be pointed or unpointed. This approach enables
us to distinguish the boxed values from the lifted-function-space that
models recursive functions with unboxed codomains.

\<close>

domain 'a Box = Box (unbox :: "'a\<^sub>\<bottom>")

definition
  box :: "('a::predomain) \<rightarrow> 'a Box" where
  "box \<equiv> Box oo up"

lemma boxI: "Box\<cdot>(up\<cdot>x) = box\<cdot>x" unfolding box_def by simp
lemma unbox_box[simp]: "unbox\<cdot>(box\<cdot>x) = up\<cdot>x" unfolding box_def by simp
lemma unbox_Box[simp]: "x \<noteq> \<bottom> \<Longrightarrow> unbox\<cdot>(Box\<cdot>x) = x" by simp

text\<open>

If we suceed in @{term "box"}ing something, then clearly that
something was not @{term "\<bottom>"}.

\<close>

lemma box_casedist[case_names bottom Box, cases type: Box]:
  assumes xbot: "x = \<bottom> \<Longrightarrow> P"
      and xbox: "\<And>u. x = box\<cdot>u \<Longrightarrow> P"
  shows "P"
proof(cases x)
  case bottom with xbot show ?thesis by simp
next
  case (Box u) with xbox show ?thesis
    by (cases u, simp_all add: box_def up_def cont_Iup bottomI[OF minimal_up])
qed

lemma bbind_leftID'[simp]: "unbox\<cdot>a >>= box = a" by (cases a, simp_all add: bbind_def)

(*<*)
text \<open>

The optimisations of \citet{SPJ-JL:1991}.

p11: Repeated unboxing of the same value can be done once (roughly:
store the value in a register). Their story is more general.

\<close>

lemma box_repeated:
  "x >>= (\<Lambda> x'. f >>= (\<Lambda> y'. x >>= body\<cdot>x'\<cdot>y'))
  = x >>= (\<Lambda> x'. f >>= (\<Lambda> y'. body\<cdot>x'\<cdot>y'\<cdot>x'))"
  by (cases x, simp_all)
(*>*)

text\<open>Lift binary predicates over @{typ "'a discr"} into @{typ "'a discr Box"}.\<close>

text \<open>@{term "bliftM"} and @{term "bliftM2"} encapsulate the boxing
and unboxing.\<close>

definition
  bliftM :: "('a::predomain \<rightarrow> 'b::predomain) \<Rightarrow> 'a Box \<rightarrow> 'b Box" where
  "bliftM f \<equiv> \<Lambda> x. unbox\<cdot>x >>= (\<Lambda> x'. box\<cdot>(f\<cdot>x'))"

lemma bliftM_strict1[simp]: "bliftM f\<cdot>\<bottom> = \<bottom>" by (simp add: bliftM_def)
lemma bliftM_op[simp]: "bliftM f\<cdot>(box\<cdot>x) = box\<cdot>(f\<cdot>x)" by (simp add: bliftM_def)

definition
  bliftM2 :: "('a::predomain \<rightarrow> 'b::predomain \<rightarrow> 'c::predomain) \<Rightarrow> 'a Box \<rightarrow> 'b Box \<rightarrow> 'c Box" where
  "bliftM2 f \<equiv> \<Lambda> x y. unbox\<cdot>x >>= (\<Lambda> x'. unbox\<cdot>y >>= (\<Lambda> y'. box\<cdot>(f\<cdot>x'\<cdot>y')))"

lemma bliftM2_strict1[simp]: "bliftM2 f\<cdot>\<bottom> = \<bottom>" by (rule cfun_eqI)+ (simp add: bliftM2_def)
lemma bliftM2_strict2[simp]: "bliftM2 f\<cdot>x\<cdot>\<bottom> = \<bottom>" by (cases x, simp_all add: bliftM2_def)
lemma bliftM2_op[simp]: "bliftM2 f\<cdot>(box\<cdot>x)\<cdot>(box\<cdot>y) = box\<cdot>(f\<cdot>x\<cdot>y)" by (simp add: bliftM2_def)

text\<open>

Define the arithmetic operations. We need extra continuity lemmas as
we're using the full function space, so we can re-use the conventional
operators. The goal is to work at this level.

\<close>

instantiation Box :: ("{predomain,plus}") plus
begin
definition plus_Box_def: "x + y \<equiv> bliftM2 (\<Lambda> a b. a + b)\<cdot>x\<cdot>y"
instance ..
end

lemma plus_Box_cont[simp, cont2cont]:
  "\<lbrakk>cont g; cont h\<rbrakk> \<Longrightarrow> cont (\<lambda>x. (g x :: 'a :: {predomain, plus} Box) + h x)"
  unfolding plus_Box_def by simp

lemma plus_Box_strict1[simp]: "\<bottom> + (y :: 'a::{predomain, plus} Box) = \<bottom>"
  unfolding plus_Box_def by simp
lemma plus_Box_strict2[simp]: "(x :: 'a::{predomain, plus} Box) + \<bottom> = \<bottom>"
  unfolding plus_Box_def by simp

instantiation Box :: ("{predomain,minus}") minus
begin
definition minus_Box_def: "x - y \<equiv> bliftM2 (\<Lambda> a b. a - b)\<cdot>x\<cdot>y"
instance ..
end

lemma minus_Box_cont[simp, cont2cont]:
  "\<lbrakk>cont g; cont h\<rbrakk> \<Longrightarrow> cont (\<lambda>x. (g x :: 'a :: {predomain, minus} Box) - h x)"
  unfolding minus_Box_def by simp

lemma minus_Box_strict1[simp]: "\<bottom> - (y :: 'a::{predomain, minus} Box) = \<bottom>"
  unfolding minus_Box_def by simp
lemma minus_Box_strict2[simp]: "(x :: 'a::{predomain, minus} Box) - \<bottom> = \<bottom>"
  unfolding minus_Box_def by simp

instantiation Box :: ("{predomain,times}") times
begin
definition times_Box_def: "x * y \<equiv> bliftM2 (\<Lambda> a b. a * b)\<cdot>x\<cdot>y"
instance ..
end

lemma times_Box_cont[simp, cont2cont]:
  "\<lbrakk>cont g; cont h\<rbrakk> \<Longrightarrow> cont (\<lambda>x. (g x :: 'a :: {predomain, times} Box) * h x)"
  unfolding times_Box_def by simp

lemma times_Box_strict1[simp]: "\<bottom> * (y :: 'a::{predomain, times} Box) = \<bottom>"
  unfolding times_Box_def by simp
lemma times_Box_strict2[simp]: "(x :: 'a::{predomain, times} Box) * \<bottom> = \<bottom>"
  unfolding times_Box_def by simp

definition
  bpred :: "('a::countable discr \<Rightarrow> 'a discr \<Rightarrow> bool) \<Rightarrow> 'a discr Box \<rightarrow> 'a discr Box \<rightarrow> tr" where
  "bpred p \<equiv> \<Lambda> x y. unbox\<cdot>x >>= (\<Lambda> x'. unbox\<cdot>y >>= (\<Lambda> y'. if p x' y' then TT else FF))"

lemma bpred_strict1[simp]: "bpred p\<cdot>\<bottom> = \<bottom>" unfolding bpred_def by (rule cfun_eqI, simp)
lemma bpred_strict2[simp]: "bpred p\<cdot>x\<cdot>\<bottom> = \<bottom>" unfolding bpred_def by (cases x, simp_all)

lemma bpred_eval[simp]: "bpred p\<cdot>(box\<cdot>x)\<cdot>(box\<cdot>y) = (if p x y then TT else FF)"
  unfolding bpred_def by simp

abbreviation
  beq_syn :: "'a::countable discr Box \<Rightarrow> 'a discr Box \<Rightarrow> tr" (infix "=\<^sub>B" 50) where
  "x =\<^sub>B y \<equiv> bpred (=)\<cdot>x\<cdot>y"

abbreviation
  ble_syn :: "'a::{countable,ord} discr Box \<Rightarrow> 'a discr Box \<Rightarrow> tr" (infix "\<le>\<^sub>B" 50) where
  "x \<le>\<^sub>B y \<equiv> bpred (\<le>)\<cdot>x\<cdot>y"

abbreviation
  blt_syn :: "'a::{countable,ord} discr Box \<Rightarrow> 'a discr Box \<Rightarrow> tr" (infix "<\<^sub>B" 50) where
  "x <\<^sub>B y \<equiv> bpred (<)\<cdot>x\<cdot>y"

subsection\<open>The flat domain of natural numbers\<close>

text\<open>Lift arithmetic to the boxed naturals. Define some things that make
playing with boxed naturals more convenient.\<close>

type_synonym Nat = "UNat Box"

instantiation Box :: ("{predomain, zero}") zero
begin
definition zero_Nat_def: "0 \<equiv> box\<cdot>0"
instance ..
end

instantiation Box :: ("{predomain, one}") one
begin
definition one_Nat_def: "1 \<equiv> box\<cdot>1"
instance ..
end

text \<open>We need to know the underlying operations are continuous for these to work.\<close>

lemma plus_Nat_eval[simp]: "(box\<cdot>x :: Nat) + box\<cdot>y = box\<cdot>(x + y)" unfolding plus_Box_def by simp
lemma minus_Nat_eval[simp]: "(box\<cdot>x :: Nat) - box\<cdot>y = box\<cdot>(x - y)" unfolding minus_Box_def by simp
lemma times_Nat_eval[simp]: "(box\<cdot>x :: Nat) * box\<cdot>y = box\<cdot>(x * y)" unfolding times_Box_def by simp

definition
  Nat_case :: "'a::domain \<rightarrow> (Nat \<rightarrow> 'a) \<rightarrow> Nat \<rightarrow> 'a" where
  "Nat_case \<equiv> \<Lambda> z s n. unbox\<cdot>n >>= (\<Lambda> n'. case_nat z (\<lambda>n''. s\<cdot>(box\<cdot>(Discr n''))) (undiscr n'))"

lemma cont_case_nat[simp]:
  "\<lbrakk>cont (\<lambda>x. f x); \<And>n. cont (\<lambda>x. g x n) \<rbrakk> \<Longrightarrow> cont (\<lambda>x. case_nat (f x) (g x) n)"
  by (cases n, simp_all)

lemma Nat_case_strict[simp]: "Nat_case\<cdot>z\<cdot>s\<cdot>\<bottom> = \<bottom>" by (simp add: Nat_case_def)
lemma Nat_case_zero[simp]: "Nat_case\<cdot>z\<cdot>s\<cdot>0 = z" by (simp add: Nat_case_def zero_Nat_def zero_discr_def)

lemma Nat_case_add_1[simp]:
  assumes ndef: "n \<noteq> \<bottom>"
  shows "Nat_case\<cdot>z\<cdot>s\<cdot>(n + 1) = s\<cdot>n"
proof -
  from ndef obtain nu where nu: "n = box\<cdot>nu"
    unfolding box_def
    apply (cases "n" rule: Box.exhaust)
    apply simp
    apply (case_tac "u")
    apply simp_all
    done
  then obtain u where "nu = Discr u"
    unfolding box_def
    apply (cases nu)
    apply simp
    done
  with nu show ?thesis unfolding one_Nat_def by simp
qed

lemma Nat_case_case_nat: "Nat_case\<cdot>z\<cdot>s\<cdot>(box\<cdot>(Discr n)) = case_nat z (\<lambda>n'. s\<cdot>(box\<cdot>(Discr n'))) n"
  by (simp add: Nat_case_def)

lemma Nat_casedist[case_names bottom zero Suc]:
  fixes x :: Nat
  assumes xbot: "x = \<bottom> \<Longrightarrow> P"
      and xzero: "x = 0 \<Longrightarrow> P"
      and xsuc: "\<And>n. x = n + 1 \<Longrightarrow> P"
  shows "P"
proof(cases x rule: Box.exhaust)
  case bottom with xbot show ?thesis by simp
next
  case (Box u) hence xu: "x = Box\<cdot>u" and ubottom: "u \<noteq> \<bottom>" .
  from ubottom obtain n where ndn: "u = up\<cdot>(Discr n)" apply (cases u) apply simp_all apply (case_tac x) apply simp done
  show ?thesis
  proof(cases n)
    case 0 with ndn xu xzero show ?thesis unfolding zero_Nat_def by (simp add: boxI zero_discr_def)
  next
    case (Suc m) with ndn xu xsuc[where n="box\<cdot>(Discr m)"]
    show ?thesis
      unfolding plus_Box_def unfolding one_Nat_def by (simp add: boxI one_discr_def)
  qed
qed

lemma cont_Nat_case[simp]:
  "\<lbrakk>cont (\<lambda>x. f x); \<And>n. cont (\<lambda>x. g x\<cdot>n) \<rbrakk> \<Longrightarrow> cont (\<lambda>x. Nat_case\<cdot>(f x)\<cdot>(g x)\<cdot>n)"
  apply (cases n rule: Nat_casedist)
    apply simp_all
  apply (case_tac na rule: Box.exhaust)
   apply simp_all
  done

lemma Nat_induct[case_names bottom zero Suc]:
  fixes P :: "Nat \<Rightarrow> bool"
  assumes xbot: "P \<bottom>"
      and xzero: "P 0"
      and xsuc: "\<And>n. \<lbrakk>n \<noteq> \<bottom>; P n \<rbrakk> \<Longrightarrow> P (n + 1)"
  shows "P x"
proof(cases x rule: box_casedist)
  case bottom with xbot show ?thesis by simp
next
  case (Box u)
  then obtain n where un: "u = Discr n" by (cases u, simp)
  {
    fix n
    have "\<And>x. x = box\<cdot>(Discr n) \<Longrightarrow> P x"
    proof(induct n)
      case 0 with xzero show ?case unfolding zero_Nat_def zero_discr_def by simp
    next
      case (Suc n)
      hence "P (box\<cdot>(Discr n))" by simp
      with xsuc[where n="box\<cdot>(Discr n)"] have "P (box\<cdot>(Discr n) + 1)" unfolding box_def by simp
      with Suc show ?case unfolding one_Nat_def one_discr_def plus_Box_def by simp
    qed
  }
  with un Box show ?thesis by simp
qed

lemma plus_commute: "(x :: Nat) + y = y + x"
proof -
  have dc: "\<And>u v. (undiscr (u::nat discr) + undiscr v) = (undiscr v + undiscr u)"
    by simp
  thus ?thesis
    apply (cases x)
     apply simp
    apply (cases y)
    by (simp_all add: dc plus_Box_def)
qed

lemma mult_unit: "(x::Nat) * 1 = x"
  unfolding times_Box_def one_Nat_def by (cases x, simp_all)

lemma mult_commute: "(x :: Nat) * y = y * x"
proof -
  have dc: "\<And>u v. (undiscr (u::nat discr) * undiscr v) = (undiscr v * undiscr u)"
    by simp
  show ?thesis
    apply (cases x)
     apply simp
    apply (cases y)
    by (simp_all add: dc)
qed

lemma mult_assoc: "((x :: Nat) * y) * z = x * (y * z)"
proof -
  have ac: "\<And>u v w. undiscr (u::nat discr) * (undiscr v * undiscr w)
                   =  (undiscr u * undiscr v) * undiscr w" by simp
  show ?thesis
    apply (cases x)
     apply simp
    apply (cases y)
     apply simp
    apply (cases z)
     apply simp
    by (simp add: ac)
qed

text\<open>Restore the HOLCF default sort.\<close>

default_sort "domain"

(*<*)
end
(*>*)


(*  Title:      LCF/LCF.thy
    Author:     Tobias Nipkow
    Copyright   1992  University of Cambridge
*)

section \<open>LCF on top of First-Order Logic\<close>

theory LCF
imports FOL
begin

text \<open>This theory is based on Lawrence Paulson's book Logic and Computation.\<close>

subsection \<open>Natural Deduction Rules for LCF\<close>

class cpo = "term"
default_sort cpo

typedecl tr
typedecl void
typedecl ('a,'b) prod  (infixl "*" 6)
typedecl ('a,'b) sum  (infixl "+" 5)

instance "fun" :: (cpo, cpo) cpo ..
instance prod :: (cpo, cpo) cpo ..
instance sum :: (cpo, cpo) cpo ..
instance tr :: cpo ..
instance void :: cpo ..

consts
 UU     :: "'a"
 TT     :: "tr"
 FF     :: "tr"
 FIX    :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a"
 FST    :: "'a*'b \<Rightarrow> 'a"
 SND    :: "'a*'b \<Rightarrow> 'b"
 INL    :: "'a \<Rightarrow> 'a+'b"
 INR    :: "'b \<Rightarrow> 'a+'b"
 WHEN   :: "['a\<Rightarrow>'c, 'b\<Rightarrow>'c, 'a+'b] \<Rightarrow> 'c"
 adm    :: "('a \<Rightarrow> o) \<Rightarrow> o"
 VOID   :: "void"               ("'(')")
 PAIR   :: "['a,'b] \<Rightarrow> 'a*'b"   ("(1<_,/_>)" [0,0] 100)
 COND   :: "[tr,'a,'a] \<Rightarrow> 'a"   ("(_ \<Rightarrow>/ (_ |/ _))" [60,60,60] 60)
 less   :: "['a,'a] \<Rightarrow> o"       (infixl "<<" 50)

axiomatization where
  (** DOMAIN THEORY **)

  eq_def:        "x=y == x << y \<and> y << x" and

  less_trans:    "\<lbrakk>x << y; y << z\<rbrakk> \<Longrightarrow> x << z" and

  less_ext:      "(\<forall>x. f(x) << g(x)) \<Longrightarrow> f << g" and

  mono:          "\<lbrakk>f << g; x << y\<rbrakk> \<Longrightarrow> f(x) << g(y)" and

  minimal:       "UU << x" and

  FIX_eq:        "\<And>f. f(FIX(f)) = FIX(f)"

axiomatization where
  (** TR **)

  tr_cases:      "p=UU \<or> p=TT \<or> p=FF" and

  not_TT_less_FF: "\<not> TT << FF" and
  not_FF_less_TT: "\<not> FF << TT" and
  not_TT_less_UU: "\<not> TT << UU" and
  not_FF_less_UU: "\<not> FF << UU" and

  COND_UU:       "UU \<Rightarrow> x | y  =  UU" and
  COND_TT:       "TT \<Rightarrow> x | y  =  x" and
  COND_FF:       "FF \<Rightarrow> x | y  =  y"

axiomatization where
  (** PAIRS **)

  surj_pairing:  "<FST(z),SND(z)> = z" and

  FST:   "FST(<x,y>) = x" and
  SND:   "SND(<x,y>) = y"

axiomatization where
  (*** STRICT SUM ***)

  INL_DEF: "\<not>x=UU \<Longrightarrow> \<not>INL(x)=UU" and
  INR_DEF: "\<not>x=UU \<Longrightarrow> \<not>INR(x)=UU" and

  INL_STRICT: "INL(UU) = UU" and
  INR_STRICT: "INR(UU) = UU" and

  WHEN_UU:  "WHEN(f,g,UU) = UU" and
  WHEN_INL: "\<not>x=UU \<Longrightarrow> WHEN(f,g,INL(x)) = f(x)" and
  WHEN_INR: "\<not>x=UU \<Longrightarrow> WHEN(f,g,INR(x)) = g(x)" and

  SUM_EXHAUSTION:
    "z = UU \<or> (\<exists>x. \<not>x=UU \<and> z = INL(x)) \<or> (\<exists>y. \<not>y=UU \<and> z = INR(y))"

axiomatization where
  (** VOID **)

  void_cases:    "(x::void) = UU"

  (** INDUCTION **)

axiomatization where
  induct: "\<lbrakk>adm(P); P(UU); \<forall>x. P(x) \<longrightarrow> P(f(x))\<rbrakk> \<Longrightarrow> P(FIX(f))"

axiomatization where
  (** Admissibility / Chain Completeness **)
  (* All rules can be found on pages 199--200 of Larry's LCF book.
     Note that "easiness" of types is not taken into account
     because it cannot be expressed schematically; flatness could be. *)

  adm_less:      "\<And>t u. adm(\<lambda>x. t(x) << u(x))" and
  adm_not_less:  "\<And>t u. adm(\<lambda>x.\<not> t(x) << u)" and
  adm_not_free:  "\<And>A. adm(\<lambda>x. A)" and
  adm_subst:     "\<And>P t. adm(P) \<Longrightarrow> adm(\<lambda>x. P(t(x)))" and
  adm_conj:      "\<And>P Q. \<lbrakk>adm(P); adm(Q)\<rbrakk> \<Longrightarrow> adm(\<lambda>x. P(x)\<and>Q(x))" and
  adm_disj:      "\<And>P Q. \<lbrakk>adm(P); adm(Q)\<rbrakk> \<Longrightarrow> adm(\<lambda>x. P(x)\<or>Q(x))" and
  adm_imp:       "\<And>P Q. \<lbrakk>adm(\<lambda>x.\<not>P(x)); adm(Q)\<rbrakk> \<Longrightarrow> adm(\<lambda>x. P(x)\<longrightarrow>Q(x))" and
  adm_all:       "\<And>P. (\<And>y. adm(P(y))) \<Longrightarrow> adm(\<lambda>x. \<forall>y. P(y,x))"

lemma eq_imp_less1: "x = y \<Longrightarrow> x << y"
  by (simp add: eq_def)

lemma eq_imp_less2: "x = y \<Longrightarrow> y << x"
  by (simp add: eq_def)

lemma less_refl [simp]: "x << x"
  apply (rule eq_imp_less1)
  apply (rule refl)
  done

lemma less_anti_sym: "\<lbrakk>x << y; y << x\<rbrakk> \<Longrightarrow> x=y"
  by (simp add: eq_def)

lemma ext: "(\<And>x::'a::cpo. f(x)=(g(x)::'b::cpo)) \<Longrightarrow> (\<lambda>x. f(x))=(\<lambda>x. g(x))"
  apply (rule less_anti_sym)
  apply (rule less_ext)
  apply simp
  apply simp
  done

lemma cong: "\<lbrakk>f = g; x = y\<rbrakk> \<Longrightarrow> f(x)=g(y)"
  by simp

lemma less_ap_term: "x << y \<Longrightarrow> f(x) << f(y)"
  by (rule less_refl [THEN mono])

lemma less_ap_thm: "f << g \<Longrightarrow> f(x) << g(x)"
  by (rule less_refl [THEN [2] mono])

lemma ap_term: "(x::'a::cpo) = y \<Longrightarrow> (f(x)::'b::cpo) = f(y)"
  apply (rule cong [OF refl])
  apply simp
  done

lemma ap_thm: "f = g \<Longrightarrow> f(x) = g(x)"
  apply (erule cong)
  apply (rule refl)
  done

lemma UU_abs: "(\<lambda>x::'a::cpo. UU) = UU"
  apply (rule less_anti_sym)
  prefer 2
  apply (rule minimal)
  apply (rule less_ext)
  apply (rule allI)
  apply (rule minimal)
  done

lemma UU_app: "UU(x) = UU"
  by (rule UU_abs [symmetric, THEN ap_thm])

lemma less_UU: "x << UU \<Longrightarrow> x=UU"
  apply (rule less_anti_sym)
  apply assumption
  apply (rule minimal)
  done

lemma tr_induct: "\<lbrakk>P(UU); P(TT); P(FF)\<rbrakk> \<Longrightarrow> \<forall>b. P(b)"
  apply (rule allI)
  apply (rule mp)
  apply (rule_tac [2] p = b in tr_cases)
  apply blast
  done

lemma Contrapos: "\<not> B \<Longrightarrow> (A \<Longrightarrow> B) \<Longrightarrow> \<not>A"
  by blast

lemma not_less_imp_not_eq1: "\<not> x << y \<Longrightarrow> x \<noteq> y"
  apply (erule Contrapos)
  apply simp
  done

lemma not_less_imp_not_eq2: "\<not> y << x \<Longrightarrow> x \<noteq> y"
  apply (erule Contrapos)
  apply simp
  done

lemma not_UU_eq_TT: "UU \<noteq> TT"
  by (rule not_less_imp_not_eq2) (rule not_TT_less_UU)
lemma not_UU_eq_FF: "UU \<noteq> FF"
  by (rule not_less_imp_not_eq2) (rule not_FF_less_UU)
lemma not_TT_eq_UU: "TT \<noteq> UU"
  by (rule not_less_imp_not_eq1) (rule not_TT_less_UU)
lemma not_TT_eq_FF: "TT \<noteq> FF"
  by (rule not_less_imp_not_eq1) (rule not_TT_less_FF)
lemma not_FF_eq_UU: "FF \<noteq> UU"
  by (rule not_less_imp_not_eq1) (rule not_FF_less_UU)
lemma not_FF_eq_TT: "FF \<noteq> TT"
  by (rule not_less_imp_not_eq1) (rule not_FF_less_TT)

lemma COND_cases_iff [rule_format]:
    "\<forall>b. P(b\<Rightarrow>x|y) \<longleftrightarrow> (b=UU\<longrightarrow>P(UU)) \<and> (b=TT\<longrightarrow>P(x)) \<and> (b=FF\<longrightarrow>P(y))"
  apply (insert not_UU_eq_TT not_UU_eq_FF not_TT_eq_UU
    not_TT_eq_FF not_FF_eq_UU not_FF_eq_TT)
  apply (rule tr_induct)
  apply (simplesubst COND_UU)
  apply blast
  apply (simplesubst COND_TT)
  apply blast
  apply (simplesubst COND_FF)
  apply blast
  done

lemma COND_cases:
  "\<lbrakk>x = UU \<longrightarrow> P(UU); x = TT \<longrightarrow> P(xa); x = FF \<longrightarrow> P(y)\<rbrakk> \<Longrightarrow> P(x \<Rightarrow> xa | y)"
  apply (rule COND_cases_iff [THEN iffD2])
  apply blast
  done

lemmas [simp] =
  minimal
  UU_app
  UU_app [THEN ap_thm]
  UU_app [THEN ap_thm, THEN ap_thm]
  not_TT_less_FF not_FF_less_TT not_TT_less_UU not_FF_less_UU not_UU_eq_TT
  not_UU_eq_FF not_TT_eq_UU not_TT_eq_FF not_FF_eq_UU not_FF_eq_TT
  COND_UU COND_TT COND_FF
  surj_pairing FST SND

subsection \<open>Ordered pairs and products\<close>

lemma expand_all_PROD: "(\<forall>p. P(p)) \<longleftrightarrow> (\<forall>x y. P(<x,y>))"
  apply (rule iffI)
  apply blast
  apply (rule allI)
  apply (rule surj_pairing [THEN subst])
  apply blast
  done

lemma PROD_less: "(p::'a*'b) << q \<longleftrightarrow> FST(p) << FST(q) \<and> SND(p) << SND(q)"
  apply (rule iffI)
  apply (rule conjI)
  apply (erule less_ap_term)
  apply (erule less_ap_term)
  apply (erule conjE)
  apply (rule surj_pairing [of p, THEN subst])
  apply (rule surj_pairing [of q, THEN subst])
  apply (rule mono, erule less_ap_term, assumption)
  done

lemma PROD_eq: "p=q \<longleftrightarrow> FST(p)=FST(q) \<and> SND(p)=SND(q)"
  apply (rule iffI)
  apply simp
  apply (unfold eq_def)
  apply (simp add: PROD_less)
  done

lemma PAIR_less [simp]: "<a,b> << <c,d> \<longleftrightarrow> a<<c \<and> b<<d"
  by (simp add: PROD_less)

lemma PAIR_eq [simp]: "<a,b> = <c,d> \<longleftrightarrow> a=c \<and> b=d"
  by (simp add: PROD_eq)

lemma UU_is_UU_UU [simp]: "<UU,UU> = UU"
  by (rule less_UU) (simp add: PROD_less)

lemma FST_STRICT [simp]: "FST(UU) = UU"
  apply (rule subst [OF UU_is_UU_UU])
  apply (simp del: UU_is_UU_UU)
  done

lemma SND_STRICT [simp]: "SND(UU) = UU"
  apply (rule subst [OF UU_is_UU_UU])
  apply (simp del: UU_is_UU_UU)
  done

subsection \<open>Fixedpoint theory\<close>

lemma adm_eq: "adm(\<lambda>x. t(x)=(u(x)::'a::cpo))"
  apply (unfold eq_def)
  apply (rule adm_conj adm_less)+
  done

lemma adm_not_not: "adm(P) \<Longrightarrow> adm(\<lambda>x. \<not> \<not> P(x))"
  by simp

lemma not_eq_TT: "\<forall>p. \<not>p=TT \<longleftrightarrow> (p=FF \<or> p=UU)"
  and not_eq_FF: "\<forall>p. \<not>p=FF \<longleftrightarrow> (p=TT \<or> p=UU)"
  and not_eq_UU: "\<forall>p. \<not>p=UU \<longleftrightarrow> (p=TT \<or> p=FF)"
  by (rule tr_induct, simp_all)+

lemma adm_not_eq_tr: "\<forall>p::tr. adm(\<lambda>x. \<not>t(x)=p)"
  apply (rule tr_induct)
  apply (simp_all add: not_eq_TT not_eq_FF not_eq_UU)
  apply (rule adm_disj adm_eq)+
  done

lemmas adm_lemmas =
  adm_not_free adm_eq adm_less adm_not_less
  adm_not_eq_tr adm_conj adm_disj adm_imp adm_all

method_setup induct = \<open>
  Scan.lift Parse.embedded_inner_syntax >> (fn v => fn ctxt =>
    SIMPLE_METHOD' (fn i =>
      Rule_Insts.res_inst_tac ctxt [((("f", 0), Position.none), v)] [] @{thm induct} i THEN
      REPEAT (resolve_tac ctxt @{thms adm_lemmas} i)))
\<close>

lemma least_FIX: "f(p) = p \<Longrightarrow> FIX(f) << p"
  apply (induct f)
  apply (rule minimal)
  apply (intro strip)
  apply (erule subst)
  apply (erule less_ap_term)
  done

lemma lfp_is_FIX:
  assumes 1: "f(p) = p"
    and 2: "\<forall>q. f(q)=q \<longrightarrow> p << q"
  shows "p = FIX(f)"
  apply (rule less_anti_sym)
  apply (rule 2 [THEN spec, THEN mp])
  apply (rule FIX_eq)
  apply (rule least_FIX)
  apply (rule 1)
  done

lemma FIX_pair: "<FIX(f),FIX(g)> = FIX(\<lambda>p.<f(FST(p)),g(SND(p))>)"
  apply (rule lfp_is_FIX)
  apply (simp add: FIX_eq [of f] FIX_eq [of g])
  apply (intro strip)
  apply (simp add: PROD_less)
  apply (rule conjI)
  apply (rule least_FIX)
  apply (erule subst, rule FST [symmetric])
  apply (rule least_FIX)
  apply (erule subst, rule SND [symmetric])
  done

lemma FIX1: "FIX(f) = FST(FIX(\<lambda>p. <f(FST(p)),g(SND(p))>))"
  by (rule FIX_pair [unfolded PROD_eq FST SND, THEN conjunct1])

lemma FIX2: "FIX(g) = SND(FIX(\<lambda>p. <f(FST(p)),g(SND(p))>))"
  by (rule FIX_pair [unfolded PROD_eq FST SND, THEN conjunct2])

lemma induct2:
  assumes 1: "adm(\<lambda>p. P(FST(p),SND(p)))"
    and 2: "P(UU::'a,UU::'b)"
    and 3: "\<forall>x y. P(x,y) \<longrightarrow> P(f(x),g(y))"
  shows "P(FIX(f),FIX(g))"
  apply (rule FIX1 [THEN ssubst, of _ f g])
  apply (rule FIX2 [THEN ssubst, of _ f g])
  apply (rule induct [where ?f = "\<lambda>x. <f(FST(x)),g(SND(x))>"])
  apply (rule 1)
  apply simp
  apply (rule 2)
  apply (simp add: expand_all_PROD)
  apply (rule 3)
  done

ML \<open>
fun induct2_tac ctxt (f, g) i =
  Rule_Insts.res_inst_tac ctxt
    [((("f", 0), Position.none), f), ((("g", 0), Position.none), g)] [] @{thm induct2} i THEN
  REPEAT(resolve_tac ctxt @{thms adm_lemmas} i)
\<close>

end


(*  Title:      HOL/Lifting_Set.thy
    Author:     Brian Huffman and Ondrej Kuncar
*)

section \<open>Setup for Lifting/Transfer for the set type\<close>

theory Lifting_Set
imports Lifting Groups_Big
begin

subsection \<open>Relator and predicator properties\<close>

lemma rel_setD1: "\<lbrakk> rel_set R A B; x \<in> A \<rbrakk> \<Longrightarrow> \<exists>y \<in> B. R x y"
  and rel_setD2: "\<lbrakk> rel_set R A B; y \<in> B \<rbrakk> \<Longrightarrow> \<exists>x \<in> A. R x y"
  by (simp_all add: rel_set_def)

lemma rel_set_conversep [simp]: "rel_set A\<inverse>\<inverse> = (rel_set A)\<inverse>\<inverse>"
  unfolding rel_set_def by auto

lemma rel_set_eq [relator_eq]: "rel_set (=) = (=)"
  unfolding rel_set_def fun_eq_iff by auto

lemma rel_set_mono[relator_mono]:
  assumes "A \<le> B"
  shows "rel_set A \<le> rel_set B"
  using assms unfolding rel_set_def by blast

lemma rel_set_OO[relator_distr]: "rel_set R OO rel_set S = rel_set (R OO S)"
  apply (rule sym)
  apply (intro ext)
  subgoal for X Z
    apply (rule iffI)
    apply (rule relcomppI [where b="{y. (\<exists>x\<in>X. R x y) \<and> (\<exists>z\<in>Z. S y z)}"])
    apply (simp add: rel_set_def, fast)+
    done
  done

lemma Domainp_set[relator_domain]:
  "Domainp (rel_set T) = (\<lambda>A. Ball A (Domainp T))"
  unfolding rel_set_def Domainp_iff[abs_def]
  apply (intro ext)
  apply (rule iffI)
  apply blast
  subgoal for A by (rule exI [where x="{y. \<exists>x\<in>A. T x y}"]) fast
  done

lemma left_total_rel_set[transfer_rule]:
  "left_total A \<Longrightarrow> left_total (rel_set A)"
  unfolding left_total_def rel_set_def
  apply safe
  subgoal for X by (rule exI [where x="{y. \<exists>x\<in>X. A x y}"]) fast
  done

lemma left_unique_rel_set[transfer_rule]:
  "left_unique A \<Longrightarrow> left_unique (rel_set A)"
  unfolding left_unique_def rel_set_def
  by fast

lemma right_total_rel_set [transfer_rule]:
  "right_total A \<Longrightarrow> right_total (rel_set A)"
  using left_total_rel_set[of "A\<inverse>\<inverse>"] by simp

lemma right_unique_rel_set [transfer_rule]:
  "right_unique A \<Longrightarrow> right_unique (rel_set A)"
  unfolding right_unique_def rel_set_def by fast

lemma bi_total_rel_set [transfer_rule]:
  "bi_total A \<Longrightarrow> bi_total (rel_set A)"
  by(simp add: bi_total_alt_def left_total_rel_set right_total_rel_set)

lemma bi_unique_rel_set [transfer_rule]:
  "bi_unique A \<Longrightarrow> bi_unique (rel_set A)"
  unfolding bi_unique_def rel_set_def by fast

lemma set_relator_eq_onp [relator_eq_onp]:
  "rel_set (eq_onp P) = eq_onp (\<lambda>A. Ball A P)"
  unfolding fun_eq_iff rel_set_def eq_onp_def Ball_def by fast

lemma bi_unique_rel_set_lemma:
  assumes "bi_unique R" and "rel_set R X Y"
  obtains f where "Y = image f X" and "inj_on f X" and "\<forall>x\<in>X. R x (f x)"
proof
  define f where "f x = (THE y. R x y)" for x
  { fix x assume "x \<in> X"
    with \<open>rel_set R X Y\<close> \<open>bi_unique R\<close> have "R x (f x)"
      by (simp add: bi_unique_def rel_set_def f_def) (metis theI)
    with assms \<open>x \<in> X\<close>
    have  "R x (f x)" "\<forall>x'\<in>X. R x' (f x) \<longrightarrow> x = x'" "\<forall>y\<in>Y. R x y \<longrightarrow> y = f x" "f x \<in> Y"
      by (fastforce simp add: bi_unique_def rel_set_def)+ }
  note * = this
  moreover
  { fix y assume "y \<in> Y"
    with \<open>rel_set R X Y\<close> *(3) \<open>y \<in> Y\<close> have "\<exists>x\<in>X. y = f x"
      by (fastforce simp: rel_set_def) }
  ultimately show "\<forall>x\<in>X. R x (f x)" "Y = image f X" "inj_on f X"
    by (auto simp: inj_on_def image_iff)
qed

subsection \<open>Quotient theorem for the Lifting package\<close>

lemma Quotient_set[quot_map]:
  assumes "Quotient R Abs Rep T"
  shows "Quotient (rel_set R) (image Abs) (image Rep) (rel_set T)"
  using assms unfolding Quotient_alt_def4
  apply (simp add: rel_set_OO[symmetric])
  apply (simp add: rel_set_def)
  apply fast
  done

subsection \<open>Transfer rules for the Transfer package\<close>

subsubsection \<open>Unconditional transfer rules\<close>

context includes lifting_syntax
begin

lemma empty_transfer [transfer_rule]: "(rel_set A) {} {}"
  unfolding rel_set_def by simp

lemma insert_transfer [transfer_rule]:
  "(A ===> rel_set A ===> rel_set A) insert insert"
  unfolding rel_fun_def rel_set_def by auto

lemma union_transfer [transfer_rule]:
  "(rel_set A ===> rel_set A ===> rel_set A) union union"
  unfolding rel_fun_def rel_set_def by auto

lemma Union_transfer [transfer_rule]:
  "(rel_set (rel_set A) ===> rel_set A) Union Union"
  unfolding rel_fun_def rel_set_def by simp fast

lemma image_transfer [transfer_rule]:
  "((A ===> B) ===> rel_set A ===> rel_set B) image image"
  unfolding rel_fun_def rel_set_def by simp fast

lemma UNION_transfer [transfer_rule]: \<comment> \<open>TODO deletion candidate\<close>
  "(rel_set A ===> (A ===> rel_set B) ===> rel_set B) (\<lambda>A f. \<Union>(f ` A)) (\<lambda>A f. \<Union>(f ` A))"
  by transfer_prover

lemma Ball_transfer [transfer_rule]:
  "(rel_set A ===> (A ===> (=)) ===> (=)) Ball Ball"
  unfolding rel_set_def rel_fun_def by fast

lemma Bex_transfer [transfer_rule]:
  "(rel_set A ===> (A ===> (=)) ===> (=)) Bex Bex"
  unfolding rel_set_def rel_fun_def by fast

lemma Pow_transfer [transfer_rule]:
  "(rel_set A ===> rel_set (rel_set A)) Pow Pow"
  apply (rule rel_funI)
  apply (rule rel_setI)
  subgoal for X Y X'
    apply (rule rev_bexI [where x="{y\<in>Y. \<exists>x\<in>X'. A x y}"])
    apply clarsimp
    apply (simp add: rel_set_def)
    apply fast
    done
  subgoal for X Y Y'
    apply (rule rev_bexI [where x="{x\<in>X. \<exists>y\<in>Y'. A x y}"])
    apply clarsimp
    apply (simp add: rel_set_def)
    apply fast
    done
  done

lemma rel_set_transfer [transfer_rule]:
  "((A ===> B ===> (=)) ===> rel_set A ===> rel_set B ===> (=)) rel_set rel_set"
  unfolding rel_fun_def rel_set_def by fast

lemma bind_transfer [transfer_rule]:
  "(rel_set A ===> (A ===> rel_set B) ===> rel_set B) Set.bind Set.bind"
  unfolding bind_UNION [abs_def] by transfer_prover

lemma INF_parametric [transfer_rule]: \<comment> \<open>TODO deletion candidate\<close>
  "(rel_set A ===> (A ===> HOL.eq) ===> HOL.eq) (\<lambda>A f. Inf (f ` A)) (\<lambda>A f. Inf (f ` A))"
  by transfer_prover

lemma SUP_parametric [transfer_rule]: \<comment> \<open>TODO deletion candidate\<close>
  "(rel_set R ===> (R ===> HOL.eq) ===> HOL.eq) (\<lambda>A f. Sup (f ` A)) (\<lambda>A f. Sup (f ` A))"
  by transfer_prover

subsubsection \<open>Rules requiring bi-unique, bi-total or right-total relations\<close>

lemma member_transfer [transfer_rule]:
  assumes "bi_unique A"
  shows "(A ===> rel_set A ===> (=)) (\<in>) (\<in>)"
  using assms unfolding rel_fun_def rel_set_def bi_unique_def by fast

lemma right_total_Collect_transfer[transfer_rule]:
  assumes "right_total A"
  shows "((A ===> (=)) ===> rel_set A) (\<lambda>P. Collect (\<lambda>x. P x \<and> Domainp A x)) Collect"
  using assms unfolding right_total_def rel_set_def rel_fun_def Domainp_iff by fast

lemma Collect_transfer [transfer_rule]:
  assumes "bi_total A"
  shows "((A ===> (=)) ===> rel_set A) Collect Collect"
  using assms unfolding rel_fun_def rel_set_def bi_total_def by fast

lemma inter_transfer [transfer_rule]:
  assumes "bi_unique A"
  shows "(rel_set A ===> rel_set A ===> rel_set A) inter inter"
  using assms unfolding rel_fun_def rel_set_def bi_unique_def by fast

lemma Diff_transfer [transfer_rule]:
  assumes "bi_unique A"
  shows "(rel_set A ===> rel_set A ===> rel_set A) (-) (-)"
  using assms unfolding rel_fun_def rel_set_def bi_unique_def
  unfolding Ball_def Bex_def Diff_eq
  by (safe, simp, metis, simp, metis)

lemma subset_transfer [transfer_rule]:
  assumes [transfer_rule]: "bi_unique A"
  shows "(rel_set A ===> rel_set A ===> (=)) (\<subseteq>) (\<subseteq>)"
  unfolding subset_eq [abs_def] by transfer_prover

context
  includes lifting_syntax
begin

lemma strict_subset_transfer [transfer_rule]:
  assumes [transfer_rule]: "bi_unique A"
  shows "(rel_set A ===> rel_set A ===> (=)) (\<subset>) (\<subset>)"
  unfolding subset_not_subset_eq by transfer_prover

end

declare right_total_UNIV_transfer[transfer_rule]

lemma UNIV_transfer [transfer_rule]:
  assumes "bi_total A"
  shows "(rel_set A) UNIV UNIV"
  using assms unfolding rel_set_def bi_total_def by simp

lemma right_total_Compl_transfer [transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" and [transfer_rule]: "right_total A"
  shows "(rel_set A ===> rel_set A) (\<lambda>S. uminus S \<inter> Collect (Domainp A)) uminus"
  unfolding Compl_eq [abs_def]
  by (subst Collect_conj_eq[symmetric]) transfer_prover

lemma Compl_transfer [transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" and [transfer_rule]: "bi_total A"
  shows "(rel_set A ===> rel_set A) uminus uminus"
  unfolding Compl_eq [abs_def] by transfer_prover

lemma right_total_Inter_transfer [transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" and [transfer_rule]: "right_total A"
  shows "(rel_set (rel_set A) ===> rel_set A) (\<lambda>S. \<Inter>S \<inter> Collect (Domainp A)) Inter"
  unfolding Inter_eq[abs_def]
  by (subst Collect_conj_eq[symmetric]) transfer_prover

lemma Inter_transfer [transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" and [transfer_rule]: "bi_total A"
  shows "(rel_set (rel_set A) ===> rel_set A) Inter Inter"
  unfolding Inter_eq [abs_def] by transfer_prover

lemma filter_transfer [transfer_rule]:
  assumes [transfer_rule]: "bi_unique A"
  shows "((A ===> (=)) ===> rel_set A ===> rel_set A) Set.filter Set.filter"
  unfolding Set.filter_def[abs_def] rel_fun_def rel_set_def by blast

lemma finite_transfer [transfer_rule]:
  "bi_unique A \<Longrightarrow> (rel_set A ===> (=)) finite finite"
  by (rule rel_funI, erule (1) bi_unique_rel_set_lemma)
     (auto dest: finite_imageD)

lemma card_transfer [transfer_rule]:
  "bi_unique A \<Longrightarrow> (rel_set A ===> (=)) card card"
  by (rule rel_funI, erule (1) bi_unique_rel_set_lemma)
     (simp add: card_image)

context
  includes lifting_syntax
begin

lemma vimage_right_total_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique B" "right_total A"
  shows "((A ===> B) ===> rel_set B ===> rel_set A) (\<lambda>f X. f -` X \<inter> Collect (Domainp A)) vimage"
proof -
  let ?vimage = "(\<lambda>f B. {x. f x \<in> B \<and> Domainp A x})"
  have "((A ===> B) ===> rel_set B ===> rel_set A) ?vimage vimage"
    unfolding vimage_def
    by transfer_prover
  also have "?vimage = (\<lambda>f X. f -` X \<inter> Collect (Domainp A))"
    by auto
  finally show ?thesis .
qed

end

lemma vimage_parametric [transfer_rule]:
  assumes [transfer_rule]: "bi_total A" "bi_unique B"
  shows "((A ===> B) ===> rel_set B ===> rel_set A) vimage vimage"
  unfolding vimage_def[abs_def] by transfer_prover

lemma Image_parametric [transfer_rule]:
  assumes "bi_unique A"
  shows "(rel_set (rel_prod A B) ===> rel_set A ===> rel_set B) (``) (``)"
  by (intro rel_funI rel_setI)
    (force dest: rel_setD1 bi_uniqueDr[OF assms], force dest: rel_setD2 bi_uniqueDl[OF assms])

lemma inj_on_transfer[transfer_rule]:
  "((A ===> B) ===> rel_set A ===> (=)) inj_on inj_on"
  if [transfer_rule]: "bi_unique A" "bi_unique B"
  unfolding inj_on_def
  by transfer_prover

end

lemma (in comm_monoid_set) F_parametric [transfer_rule]:
  fixes A :: "'b \<Rightarrow> 'c \<Rightarrow> bool"
  assumes "bi_unique A"
  shows "rel_fun (rel_fun A (=)) (rel_fun (rel_set A) (=)) F F"
proof (rule rel_funI)+
  fix f :: "'b \<Rightarrow> 'a" and g S T
  assume "rel_fun A (=) f g" "rel_set A S T"
  with \<open>bi_unique A\<close> obtain i where "bij_betw i S T" "\<And>x. x \<in> S \<Longrightarrow> f x = g (i x)"
    by (auto elim: bi_unique_rel_set_lemma simp: rel_fun_def bij_betw_def)
  then show "F f S = F g T"
    by (simp add: reindex_bij_betw)
qed

lemmas sum_parametric = sum.F_parametric
lemmas prod_parametric = prod.F_parametric

lemma rel_set_UNION:
  assumes [transfer_rule]: "rel_set Q A B" "rel_fun Q (rel_set R) f g"
  shows "rel_set R (\<Union>(f ` A)) (\<Union>(g ` B))"
  by transfer_prover

context
  includes lifting_syntax
begin

lemma fold_graph_transfer[transfer_rule]:
  assumes "bi_unique R" "right_total R"
  shows "((R ===> (=) ===> (=)) ===> (=) ===> rel_set R ===> (=) ===> (=)) fold_graph fold_graph"
proof(intro rel_funI)
  fix f1 :: "'a \<Rightarrow> 'c \<Rightarrow> 'c" and f2 :: "'b \<Rightarrow> 'c \<Rightarrow> 'c"
  assume rel_f: "(R ===> (=) ===> (=)) f1 f2"
  fix z1 z2 :: 'c assume [simp]: "z1 = z2"
  fix A1 A2 assume rel_A: "rel_set R A1 A2"
  fix y1 y2 :: 'c assume [simp]: "y1 = y2"

  from \<open>bi_unique R\<close> \<open>right_total R\<close> have The_y: "\<forall>y. \<exists>!x. R x y"
    unfolding bi_unique_def right_total_def by auto
  define r where "r \<equiv> \<lambda>y. THE x. R x y"

  from The_y have r_y: "R (r y) y" for y
    unfolding r_def using the_equality by fastforce
  with assms rel_A have "inj_on r A2" "A1 = r ` A2"
    unfolding r_def rel_set_def inj_on_def bi_unique_def
      apply(auto simp: image_iff) by metis+
  with \<open>bi_unique R\<close> rel_f r_y have "(f1 o r) y = f2 y" for y
    unfolding bi_unique_def rel_fun_def by auto
  then have "(f1 o r) = f2"
    by blast
  then show "fold_graph f1 z1 A1 y1 = fold_graph f2 z2 A2 y2"
    by (fastforce simp: fold_graph_image[OF \<open>inj_on r A2\<close>] \<open>A1 = r ` A2\<close>)
qed

lemma fold_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique R" "right_total R"
  shows "((R ===> (=) ===> (=)) ===> (=) ===> rel_set R ===> (=)) Finite_Set.fold Finite_Set.fold"
  unfolding Finite_Set.fold_def
  by transfer_prover

end

end


section \<open> Countable Non-Determinism \<close>

theory ITree_Countable_Nondeterminism
  imports ITree_UTP
begin

text \<open> A type class to characterise a countable nondeterminism event. \<close>

class ndetev =
  fixes ndetev :: "nat \<Longrightarrow>\<^sub>\<triangle> 'a"
  assumes wb_ndetev [simp]: "wb_prism ndetev"

definition CNChoice :: "nat set \<Rightarrow> (nat \<Rightarrow> ('e::ndetev, 's) htree) \<Rightarrow> ('e, 's) htree" where
"CNChoice A P = input_in ndetev (\<lambda> _. A) P"

lemma CNChoice_pred [itree_pred]: "\<lbrakk>CNChoice A P\<rbrakk>\<^sub>p (s, s') = (\<exists>v\<in>A. \<lbrakk>P v\<rbrakk>\<^sub>p (s, s'))"
  by (simp add: CNChoice_def itree_pred)

chantype pndet =
  pndetev :: nat

instantiation pndet :: ndetev
begin
definition ndetev_pndet :: "nat \<Longrightarrow>\<^sub>\<triangle> pndet" where
"ndetev_pndet = pndetev"

instance by (intro_classes, simp add: ndetev_pndet_def)
end

definition prog_ndet :: "(pndet, 's) htree \<Rightarrow> (pndet, 's) htree \<Rightarrow> (pndet, 's) htree" where
"prog_ndet P Q = CNChoice {0, 1} ((\<lambda> x. Stop)(0 := P, 1 := Q))"

bundle prog_ndet_syntax
begin

notation
  prog_ndet (infixl "\<sqinter>" 60)

end

bundle no_prog_ndet_syntax
begin

no_notation
  prog_ndet (infixl "\<sqinter>" 60)

end

unbundle prog_ndet_syntax

lemma prog_ndet_pred [itree_pred]: "\<lbrakk>P \<sqinter> Q\<rbrakk>\<^sub>p (s, s') = ( \<lbrakk>P\<rbrakk>\<^sub>p (s, s') \<or> \<lbrakk>Q\<rbrakk>\<^sub>p (s, s'))"
  by (simp add: prog_ndet_def itree_pred)

lemma prog_ndet_rel [itree_rel]: "itree_rel (C\<^sub>1 \<sqinter> C\<^sub>2) = itree_rel C\<^sub>1 \<union> itree_rel C\<^sub>2"
  by (simp add: itree_rel_def itree_pred set_eq_iff)

lemma hl_prog_ndet [hoare_safe]:
  assumes "\<^bold>{P\<^bold>} C\<^sub>1 \<^bold>{Q\<^bold>}" "\<^bold>{P\<^bold>} C\<^sub>2 \<^bold>{Q\<^bold>}"
  shows "\<^bold>{P\<^bold>} C\<^sub>1 \<sqinter> C\<^sub>2 \<^bold>{Q\<^bold>}"
  using assms by (simp add: hoare_triple_def itree_rel)

lemma wp_prog_ndet [wp]: "wp (C\<^sub>1 \<sqinter> C\<^sub>2) P = (wp C\<^sub>1 P \<or> wp C\<^sub>2 P)\<^sub>e"
  by (expr_simp add: wp_itree_def itree_rel; auto)

lemma wlp_prog_ndet [wp]: "wlp (C\<^sub>1 \<sqinter> C\<^sub>2) P = (wlp C\<^sub>1 P \<and> wlp C\<^sub>2 P)\<^sub>e"
  by (expr_simp add: wlp_itree_def itree_rel; auto)

unbundle no_prog_ndet_syntax

end