(* Title: thys/Abacus_Hoare.thy
   Author: Jian Xu, Xingyuan Zhang, and Christian Urban
   Modifications: Sebastiaan Joosten
*)

theory Abacus_Hoare
  imports Abacus
begin

type_synonym abc_assert = "nat list \<Rightarrow> bool"

definition
  assert_imp :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" ("_ \<mapsto> _" [0, 0] 100)
  where
    "assert_imp P Q \<equiv> \<forall>xs. P xs \<longrightarrow> Q xs"

fun abc_holds_for :: "(nat list \<Rightarrow> bool) \<Rightarrow> (nat \<times> nat list) \<Rightarrow> bool" ("_ abc'_holds'_for _" [100, 99] 100)
  where
    "P abc_holds_for (s, lm) = P lm"

(* Hoare Rules *)
(* halting case *)
(*consts abc_Hoare_halt :: "abc_assert \<Rightarrow> abc_prog \<Rightarrow> abc_assert \<Rightarrow> bool" ("({(1_)}/ (_)/ {(1_)})" 50)*)

fun abc_final :: "(nat \<times> nat list) \<Rightarrow> abc_prog \<Rightarrow> bool"
  where
    "abc_final (s, lm) p = (s = length p)"

fun abc_notfinal :: "abc_conf \<Rightarrow> abc_prog \<Rightarrow> bool"
  where
    "abc_notfinal (s, lm) p = (s < length p)"

definition
  abc_Hoare_halt :: "abc_assert \<Rightarrow> abc_prog \<Rightarrow> abc_assert \<Rightarrow> bool" ("({(1_)}/ (_)/ {(1_)})" 50)
  where
    "abc_Hoare_halt P p Q \<equiv> \<forall>lm. P lm \<longrightarrow> (\<exists>n. abc_final (abc_steps_l (0, lm) p n) p \<and> Q abc_holds_for (abc_steps_l (0, lm) p n))"

lemma abc_Hoare_haltI:
  assumes "\<And>lm. P lm \<Longrightarrow> \<exists>n. abc_final (abc_steps_l (0, lm) p n) p \<and> Q abc_holds_for (abc_steps_l (0, lm) p n)"
  shows "{P} (p::abc_prog) {Q}"
  unfolding abc_Hoare_halt_def
  using assms by auto

text \<open>
  {P} A {Q}   {Q} B {S}
  -----------------------------------------
  {P} A [+] B {S}
\<close>

definition
  abc_Hoare_unhalt :: "abc_assert \<Rightarrow> abc_prog \<Rightarrow> bool" ("({(1_)}/ (_)) \<up>" 50)
  where
    "abc_Hoare_unhalt P p \<equiv> \<forall>args. P args \<longrightarrow> (\<forall> n .abc_notfinal (abc_steps_l (0, args) p n) p)"

lemma abc_Hoare_unhaltI:
  assumes "\<And>args n. P args \<Longrightarrow> abc_notfinal (abc_steps_l (0, args) p n) p"
  shows "{P} (p::abc_prog) \<up>"
  unfolding abc_Hoare_unhalt_def
  using assms by auto

fun abc_inst_shift :: "abc_inst \<Rightarrow> nat \<Rightarrow> abc_inst"
  where
    "abc_inst_shift (Inc m) n = Inc m" |
    "abc_inst_shift (Dec m e) n = Dec m (e + n)" |
    "abc_inst_shift (Goto m) n = Goto (m + n)"

fun abc_shift :: "abc_inst list \<Rightarrow> nat \<Rightarrow> abc_inst list"
  where
    "abc_shift xs n = map (\<lambda> x. abc_inst_shift x n) xs"

fun abc_comp :: "abc_inst list \<Rightarrow> abc_inst list \<Rightarrow>
                           abc_inst list" (infixl "[+]" 99)
  where
    "abc_comp al bl = (let al_len = length al in
                           al @ abc_shift bl al_len)"

lemma abc_comp_first_step_eq_pre:
  "s < length A
 \<Longrightarrow> abc_step_l (s, lm) (abc_fetch s (A [+] B)) =
    abc_step_l (s, lm) (abc_fetch s A)"
  by(simp add: abc_step_l.simps abc_fetch.simps nth_append)

lemma abc_before_final:
  "\<lbrakk>abc_final (abc_steps_l (0, lm) p n) p; p \<noteq> []\<rbrakk>
  \<Longrightarrow> \<exists> n'. abc_notfinal (abc_steps_l (0, lm) p n') p \<and>
            abc_final (abc_steps_l (0, lm) p (Suc n')) p"
proof(induct n)
  case 0
  thus "?thesis"
    by(simp add: abc_steps_l.simps)
next
  case (Suc n)
  have ind: " \<lbrakk>abc_final (abc_steps_l (0, lm) p n) p; p \<noteq> []\<rbrakk> \<Longrightarrow>
    \<exists>n'. abc_notfinal (abc_steps_l (0, lm) p n') p \<and> abc_final (abc_steps_l (0, lm) p (Suc n')) p"
    by fact
  have final: "abc_final (abc_steps_l (0, lm) p (Suc n)) p" by fact
  have notnull: "p \<noteq> []" by fact
  show "?thesis"
  proof(cases "abc_final (abc_steps_l (0, lm) p n) p")
    case True
    have "abc_final (abc_steps_l (0, lm) p n) p" by fact
    then have "\<exists>n'. abc_notfinal (abc_steps_l (0, lm) p n') p \<and> abc_final (abc_steps_l (0, lm) p (Suc n')) p"
      using ind notnull
      by simp
    thus "?thesis"
      by simp
  next
    case False
    have "\<not> abc_final (abc_steps_l (0, lm) p n) p" by fact
    from final this have "abc_notfinal (abc_steps_l (0, lm) p n) p"
      by(case_tac "abc_steps_l (0, lm) p n", simp add: abc_step_red2
          abc_step_l.simps abc_fetch.simps split: if_splits)
    thus "?thesis"
      using final
      by(rule_tac x = n in exI, simp)
  qed
qed

lemma abc_comp_frist_steps_eq_pre:
  assumes notfinal: "abc_notfinal (abc_steps_l (0, lm)  A n) A"
    and notnull: "A \<noteq> []"
  shows "abc_steps_l (0, lm) (A [+] B) n = abc_steps_l (0, lm) A n"
  using notfinal
proof(induct n)
  case 0
  thus "?case"
    by(simp add: abc_steps_l.simps)
next
  case (Suc n)
  have ind: "abc_notfinal (abc_steps_l (0, lm) A n) A \<Longrightarrow> abc_steps_l (0, lm) (A [+] B) n = abc_steps_l (0, lm) A n"
    by fact
  have h: "abc_notfinal (abc_steps_l (0, lm) A (Suc n)) A" by fact
  then have a: "abc_notfinal (abc_steps_l (0, lm) A n) A"
    by(simp add: notfinal_Suc)
  then have b: "abc_steps_l (0, lm) (A [+] B) n = abc_steps_l (0, lm) A n"
    using ind by simp
  obtain s lm' where c: "abc_steps_l (0, lm) A n = (s, lm')"
    by (metis prod.exhaust)
  then have d: "s < length A \<and> abc_steps_l (0, lm) (A [+] B) n = (s, lm')"
    using a b by simp
  thus "?case"
    using c
    by(simp add: abc_step_red2 abc_fetch.simps abc_step_l.simps nth_append)
qed

declare abc_shift.simps[simp del] abc_comp.simps[simp del]
lemma halt_steps2: "st \<ge> length A \<Longrightarrow> abc_steps_l (st, lm) A stp = (st, lm)"
  apply(induct stp)
  by(simp_all add: abc_step_red2 abc_steps_l.simps abc_step_l.simps abc_fetch.simps)

lemma halt_steps: "abc_steps_l (length A, lm) A n = (length A, lm)"
  apply(induct n, simp add: abc_steps_l.simps)
  apply(simp add: abc_step_red2 abc_step_l.simps nth_append abc_fetch.simps)
  done

lemma abc_steps_add:
  "abc_steps_l (as, lm) ap (m + n) =
         abc_steps_l (abc_steps_l (as, lm) ap m) ap n"
  apply(induct m arbitrary: n as lm, simp add: abc_steps_l.simps)
proof -
  fix m n as lm
  assume ind:
    "\<And>n as lm. abc_steps_l (as, lm) ap (m + n) =
                   abc_steps_l (abc_steps_l (as, lm) ap m) ap n"
  show "abc_steps_l (as, lm) ap (Suc m + n) =
             abc_steps_l (abc_steps_l (as, lm) ap (Suc m)) ap n"
    apply(insert ind[of as lm "Suc n"], simp)
    apply(insert ind[of as lm "Suc 0"], simp add: abc_steps_l.simps)
    apply(case_tac "(abc_steps_l (as, lm) ap m)", simp)
    apply(simp add: abc_steps_l.simps)
    apply(case_tac "abc_step_l (a, b) (abc_fetch a ap)",
        simp add: abc_steps_l.simps)
    done
qed

lemma equal_when_halt:
  assumes exc1: "abc_steps_l (s, lm) A na = (length A, lma)"
    and exc2: "abc_steps_l (s, lm) A nb = (length A, lmb)"
  shows "lma = lmb"
proof(cases "na > nb")
  case True
  then obtain d where "na = nb + d"
    by (metis add_Suc_right less_iff_Suc_add)
  thus "?thesis" using assms halt_steps
    by(simp add: abc_steps_add)
next
  case False
  then obtain d where "nb = na + d"
    by (metis add.comm_neutral less_imp_add_positive nat_neq_iff)
  thus "?thesis" using assms halt_steps
    by(simp add: abc_steps_add)
qed

lemma abc_comp_frist_steps_halt_eq':
  assumes final: "abc_steps_l (0, lm) A n = (length A, lm')"
    and notnull: "A \<noteq> []"
  shows "\<exists> n'. abc_steps_l (0, lm) (A [+] B) n' = (length A, lm')"
proof -
  have "\<exists> n'. abc_notfinal (abc_steps_l (0, lm) A n') A \<and>
    abc_final (abc_steps_l (0, lm) A (Suc n')) A"
    using assms
    by(rule_tac n = n in abc_before_final, simp_all)
  then obtain na where a:
    "abc_notfinal (abc_steps_l (0, lm) A na) A \<and>
            abc_final (abc_steps_l (0, lm) A (Suc na)) A" ..
  obtain sa lma where b: "abc_steps_l (0, lm) A na = (sa, lma)"
    by (metis prod.exhaust)
  then have c: "abc_steps_l (0, lm) (A [+] B) na = (sa, lma)"
    using a abc_comp_frist_steps_eq_pre[of lm A na B] assms
    by simp
  have d: "sa < length A" using b a by simp
  then have e: "abc_step_l (sa, lma) (abc_fetch sa (A [+] B)) =
    abc_step_l (sa, lma) (abc_fetch sa A)"
    by(rule_tac abc_comp_first_step_eq_pre)
  from a have "abc_steps_l (0, lm) A (Suc na) = (length A, lm')"
    using final equal_when_halt
    by(case_tac "abc_steps_l (0, lm) A (Suc na)" , simp)
  then have "abc_steps_l (0, lm) (A [+] B) (Suc na) = (length A, lm')"
    using a b c e
    by(simp add: abc_step_red2)
  thus "?thesis"
    by blast
qed

lemma abc_exec_null: "abc_steps_l sam [] n = sam"
  apply(cases sam)
  apply(induct n)
   apply(auto simp: abc_step_red2)
   apply(auto simp: abc_step_l.simps abc_steps_l.simps abc_fetch.simps)
  done

lemma abc_comp_frist_steps_halt_eq:
  assumes final: "abc_steps_l (0, lm) A n = (length A, lm')"
  shows "\<exists> n'. abc_steps_l (0, lm) (A [+] B) n' = (length A, lm')"
  using final
  apply(case_tac "A = []")
   apply(rule_tac x = 0 in exI, simp add: abc_steps_l.simps abc_exec_null)
  apply(rule_tac abc_comp_frist_steps_halt_eq', simp_all)
  done

lemma abc_comp_second_step_eq:
  assumes exec: "abc_step_l (s, lm) (abc_fetch s B) = (sa, lma)"
  shows "abc_step_l (s + length A, lm) (abc_fetch (s + length A) (A [+] B))
         = (sa + length A, lma)"
  using assms
  apply(auto simp: abc_step_l.simps abc_fetch.simps nth_append abc_comp.simps abc_shift.simps split : if_splits )
  apply(case_tac [!] "B ! s", auto simp: Let_def)
  done

lemma abc_comp_second_steps_eq:
  assumes exec: "abc_steps_l (0, lm) B n = (sa, lm')"
  shows "abc_steps_l (length A, lm) (A [+] B) n = (sa + length A, lm')"
  using assms
proof(induct n arbitrary: sa lm')
  case 0
  thus "?case"
    by(simp add: abc_steps_l.simps)
next
  case (Suc n)
  have ind: "\<And>sa lm'. abc_steps_l (0, lm) B n = (sa, lm') \<Longrightarrow>
    abc_steps_l (length A, lm) (A [+] B) n = (sa + length A, lm')" by fact
  have exec: "abc_steps_l (0, lm) B (Suc n) = (sa, lm')" by fact
  obtain sb lmb where a: " abc_steps_l (0, lm) B n = (sb, lmb)"
    by (metis prod.exhaust)
  then have "abc_steps_l (length A, lm) (A [+] B) n = (sb + length A, lmb)"
    using ind by simp
  moreover have "abc_step_l (sb + length A, lmb) (abc_fetch (sb + length A) (A [+] B)) = (sa + length A, lm') "
    using a exec abc_comp_second_step_eq
    by(simp add: abc_step_red2)
  ultimately show "?case"
    by(simp add: abc_step_red2)
qed

lemma length_abc_comp[simp, intro]:
  "length (A [+] B) = length A + length B"
  by(auto simp: abc_comp.simps abc_shift.simps)

lemma abc_Hoare_plus_halt :
  assumes A_halt : "{P} (A::abc_prog) {Q}"
    and B_halt : "{Q} (B::abc_prog) {S}"
  shows "{P} (A [+] B) {S}"
proof(rule_tac abc_Hoare_haltI)
  fix lm
  assume a: "P lm"
  then obtain na lma where
    "abc_final (abc_steps_l (0, lm) A na) A"
    and b: "abc_steps_l (0, lm) A na = (length A, lma)"
    and c: "Q abc_holds_for (length A, lma)"
    using A_halt unfolding abc_Hoare_halt_def
    by (metis (full_types) abc_final.simps abc_holds_for.simps prod.exhaust)
  have "\<exists> n. abc_steps_l (0, lm) (A [+] B) n = (length A, lma)"
    using abc_comp_frist_steps_halt_eq b
    by(simp)
  then obtain nx where h1: "abc_steps_l (0, lm) (A [+] B) nx = (length A, lma)" ..
  from c have "Q lma"
    using c unfolding abc_holds_for.simps
    by simp
  then obtain nb lmb where
    "abc_final (abc_steps_l (0, lma) B nb) B"
    and d: "abc_steps_l (0, lma) B nb = (length B, lmb)"
    and e: "S abc_holds_for (length B, lmb)"
    using B_halt unfolding abc_Hoare_halt_def
    by (metis (full_types) abc_final.simps abc_holds_for.simps prod.exhaust)
  have h2: "abc_steps_l (length A, lma) (A [+] B) nb = (length B + length A, lmb)"
    using d abc_comp_second_steps_eq
    by simp
  thus "\<exists>n. abc_final (abc_steps_l (0, lm) (A [+] B) n) (A [+] B) \<and>
    S abc_holds_for abc_steps_l (0, lm) (A [+] B) n"
    using h1 e
    by(rule_tac x = "nx + nb" in exI, simp add: abc_steps_add)
qed

lemma abc_unhalt_append_eq:
  assumes unhalt: "{P} (A::abc_prog) \<up>"
    and P: "P args"
  shows "abc_steps_l (0, args) (A [+] B) stp = abc_steps_l (0, args) A stp"
proof(induct stp)
  case 0
  thus "?case"
    by(simp add: abc_steps_l.simps)
next
  case (Suc stp)
  have ind: "abc_steps_l (0, args) (A [+] B) stp = abc_steps_l (0, args) A stp"
    by fact
  obtain s nl where a: "abc_steps_l (0, args) A stp = (s, nl)"
    by (metis prod.exhaust)
  then have b: "s < length A"
    using unhalt P
    apply(auto simp: abc_Hoare_unhalt_def)
    by (metis abc_notfinal.simps)
  thus "?case"
    using a ind
    by(simp add: abc_step_red2 abc_step_l.simps abc_fetch.simps nth_append abc_comp.simps)
qed

lemma abc_Hoare_plus_unhalt1:
  "{P} (A::abc_prog) \<up> \<Longrightarrow> {P} (A [+] B) \<up>"
  apply(rule abc_Hoare_unhaltI)
  apply(subst abc_unhalt_append_eq,force,force)
  by (metis (mono_tags, lifting) abc_notfinal.elims(3) abc_notfinal.simps add_diff_inverse_nat
      abc_Hoare_unhalt_def le_imp_less_Suc length_abc_comp not_less_eq order_refl trans_le_add1)

lemma notfinal_all_before:
  "\<lbrakk>abc_notfinal (abc_steps_l (0, args) A x) A; y\<le>x \<rbrakk>
  \<Longrightarrow> abc_notfinal (abc_steps_l (0, args) A y) A "
  apply(subgoal_tac "\<exists> d. x = y + d", auto)
   apply(cases "abc_steps_l (0, args) A y",simp)
   apply(rule classical, simp add: abc_steps_add leI halt_steps2)
  by arith

lemma abc_Hoare_plus_unhalt2':
  assumes unhalt: "{Q} (B::abc_prog) \<up>"
    and halt: "{P} (A::abc_prog) {Q}"
    and notnull: "A \<noteq> []"
    and P: "P args"
  shows "abc_notfinal (abc_steps_l (0, args) (A [+] B) n) (A [+] B)"
proof -
  obtain st nl stp where a: "abc_final (abc_steps_l (0, args) A stp) A"
    and b: "Q abc_holds_for (length A, nl)"
    and c: "abc_steps_l (0, args) A stp = (st, nl)"
    using halt P unfolding abc_Hoare_halt_def
    by (metis abc_holds_for.simps prod.exhaust)
  obtain stpa where d:
    "abc_notfinal (abc_steps_l (0, args) A stpa) A \<and> abc_final (abc_steps_l (0, args) A (Suc stpa)) A"
    using abc_before_final[of args A stp,OF a notnull] by metis
  thus "?thesis"
  proof(cases "n < Suc stpa")
    case True
    have h: "n < Suc stpa" by fact
    then have "abc_notfinal (abc_steps_l (0, args) A n) A"
      using d
      by(rule_tac notfinal_all_before, auto)
    moreover then have "abc_steps_l (0, args) (A [+] B) n = abc_steps_l (0, args) A n"
      using notnull
      by(rule_tac abc_comp_frist_steps_eq_pre, simp_all)
    ultimately show "?thesis"
      by(case_tac "abc_steps_l (0, args) A n", simp)
  next
    case False
    have "\<not> n < Suc stpa" by fact
    then obtain d where i1: "n = Suc stpa + d"
      by (metis add_Suc less_iff_Suc_add not_less_eq)
    have "abc_steps_l (0, args) A (Suc stpa) = (length A, nl)"
      using d a c
      apply(case_tac "abc_steps_l (0, args) A stp", simp add: equal_when_halt)
      by(case_tac "abc_steps_l (0, args) A (Suc stpa)", simp add: equal_when_halt)
    moreover have  "abc_steps_l (0, args) (A [+] B) stpa = abc_steps_l (0, args) A stpa"
      using notnull d
      by(rule_tac abc_comp_frist_steps_eq_pre, simp_all)
    ultimately have i2: "abc_steps_l (0, args) (A [+] B) (Suc stpa) = (length A, nl)"
      using d
      apply(case_tac "abc_steps_l (0, args) A stpa", simp)
      by(simp add: abc_step_red2 abc_steps_l.simps abc_fetch.simps abc_comp.simps nth_append)
    obtain s' nl' where i3:"abc_steps_l (0, nl) B d = (s', nl')"
      by (metis prod.exhaust)
    then have i4: "abc_steps_l (0, args) (A [+] B) (Suc stpa + d) = (length A + s', nl')"
      using i2  apply(simp only: abc_steps_add)
      using abc_comp_second_steps_eq[of nl B d s' nl']
      by simp
    moreover have "s' < length B"
      using unhalt b i3
      apply(simp add: abc_Hoare_unhalt_def)
      apply(erule_tac x = nl in allE, simp)
      by(erule_tac x = d in allE, simp)
    ultimately show "?thesis"
      using i1
      by(simp)
  qed
qed

lemma abc_comp_null_left[simp]: "[] [+] A = A"
proof(induct A)
  case (Cons a A)
  then show ?case
    apply(cases a)
    by(auto simp: abc_comp.simps abc_shift.simps)
qed (auto simp: abc_comp.simps abc_shift.simps)

lemma abc_comp_null_right[simp]: "A [+] [] = A"
proof(induct A)
  case (Cons a A)
  then show ?case
    apply(cases a)
    by(auto simp: abc_comp.simps abc_shift.simps)
qed (auto simp: abc_comp.simps abc_shift.simps)

lemma abc_Hoare_plus_unhalt2:
  "\<lbrakk>{Q} (B::abc_prog)\<up>; {P} (A::abc_prog) {Q}\<rbrakk>\<Longrightarrow> {P} (A [+] B) \<up>"
  apply(case_tac "A = []")
   apply(simp add: abc_Hoare_halt_def abc_Hoare_unhalt_def abc_exec_null)
  apply(rule_tac abc_Hoare_unhaltI)
  apply(erule_tac abc_Hoare_plus_unhalt2', simp)
   apply(simp, simp)
  done

end


(*  Title:      HOL/Word/Bits_Bit.thy
    Author:     Author: Brian Huffman, PSU and Gerwin Klein, NICTA
*)

section \<open>Bit operations in $\cal Z_2$\<close>

theory Bits_Bit
imports Bits "~~/src/HOL/Library/Bit"
begin

instantiation bit :: bit
begin

primrec bitNOT_bit where
  "NOT 0 = (1::bit)"
  | "NOT 1 = (0::bit)"

primrec bitAND_bit where
  "0 AND y = (0::bit)"
  | "1 AND y = (y::bit)"

primrec bitOR_bit where
  "0 OR y = (y::bit)"
  | "1 OR y = (1::bit)"

primrec bitXOR_bit where
  "0 XOR y = (y::bit)"
  | "1 XOR y = (NOT y :: bit)"

instance  ..

end

lemmas bit_simps =
  bitNOT_bit.simps bitAND_bit.simps bitOR_bit.simps bitXOR_bit.simps

lemma bit_extra_simps [simp]:
  "x AND 0 = (0::bit)"
  "x AND 1 = (x::bit)"
  "x OR 1 = (1::bit)"
  "x OR 0 = (x::bit)"
  "x XOR 1 = NOT (x::bit)"
  "x XOR 0 = (x::bit)"
  by (cases x, auto)+

lemma bit_ops_comm:
  "(x::bit) AND y = y AND x"
  "(x::bit) OR y = y OR x"
  "(x::bit) XOR y = y XOR x"
  by (cases y, auto)+

lemma bit_ops_same [simp]:
  "(x::bit) AND x = x"
  "(x::bit) OR x = x"
  "(x::bit) XOR x = 0"
  by (cases x, auto)+

lemma bit_not_not [simp]: "NOT (NOT (x::bit)) = x"
  by (cases x) auto

lemma bit_or_def: "(b::bit) OR c = NOT (NOT b AND NOT c)"
  by (induct b, simp_all)

lemma bit_xor_def: "(b::bit) XOR c = (b AND NOT c) OR (NOT b AND c)"
  by (induct b, simp_all)

lemma bit_NOT_eq_1_iff [simp]: "NOT (b::bit) = 1 \<longleftrightarrow> b = 0"
  by (induct b, simp_all)

lemma bit_AND_eq_1_iff [simp]: "(a::bit) AND b = 1 \<longleftrightarrow> a = 1 \<and> b = 1"
  by (induct a, simp_all)

end


(* Title: Cyclic_Group_SPMF.thy
  Author: Andreas Lochbihler, ETH Zurich *)

theory Cyclic_Group_SPMF imports
  Cyclic_Group
  "HOL-Probability.SPMF"
begin

definition sample_uniform :: "nat \<Rightarrow> nat spmf"
where "sample_uniform n = spmf_of_set {..<n}"

lemma spmf_sample_uniform: "spmf (sample_uniform n) x = indicator {..<n} x / n"
by(simp add: sample_uniform_def spmf_of_set)

lemma weight_sample_uniform: "weight_spmf (sample_uniform n) = indicator (range Suc) n"
by(auto simp add: sample_uniform_def weight_spmf_of_set split: split_indicator elim: lessE)

lemma weight_sample_uniform_0 [simp]: "weight_spmf (sample_uniform 0) = 0"
by(auto simp add: weight_sample_uniform indicator_def)

lemma weight_sample_uniform_gt_0 [simp]: "0 < n \<Longrightarrow> weight_spmf (sample_uniform n) = 1"
by(auto simp add: weight_sample_uniform indicator_def gr0_conv_Suc)

lemma lossless_sample_uniform [simp]: "lossless_spmf (sample_uniform n) \<longleftrightarrow> 0 < n"
by(auto simp add: lossless_spmf_def intro: ccontr)

lemma set_spmf_sample_uniform [simp]: "0 < n \<Longrightarrow> set_spmf (sample_uniform n) = {..<n}"
by(simp add: sample_uniform_def)

lemma (in cyclic_group) sample_uniform_one_time_pad:
  assumes [simp]: "c \<in> carrier G"
  shows
  "map_spmf (\<lambda>x. \<^bold>g [^] x \<otimes> c) (sample_uniform (order G)) =
   map_spmf (\<lambda>x. \<^bold>g [^] x) (sample_uniform (order G))"
   (is "?lhs = ?rhs")
proof(cases "finite (carrier G)")
  case False
  thus ?thesis by(simp add: order_def sample_uniform_def)
next
  case True
  have "?lhs = map_spmf (\<lambda>x. x \<otimes> c) ?rhs"
    by(simp add: pmf.map_comp o_def option.map_comp)
  also have rhs: "?rhs = spmf_of_set (carrier G)"
    using True by(simp add: carrier_conv_generator inj_on_generator sample_uniform_def)
  also have "map_spmf (\<lambda>x. x \<otimes> c) \<dots> = spmf_of_set ((\<lambda>x. x \<otimes> c) ` carrier G)"
    by(simp add: inj_on_multc)
  also have "(\<lambda>x. x \<otimes> c) ` carrier G = carrier G"
    using True by(rule endo_inj_surj)(auto simp add: inj_on_multc)
  finally show ?thesis using rhs by simp
qed

end


(*
  Theory: PDF_Values.thy
  Author: Manuel Eberl

  Defines the values and types in the PDF language and the corresponding stock measure spaces.
  Additionally, some functions and lemmas for lifting functions on the HOL types (int, real, \<dots>)
  to PDF values are provided.
*)

header {* Source Language Values *}

theory PDF_Values
imports Giry_Monad Density_Predicates Measure_Embeddings PDF_Misc
begin

subsection {* Values and stock measures *}

datatype pdf_type =  UNIT | BOOL | INTEG | REAL | PRODUCT pdf_type pdf_type

datatype val = UnitVal | BoolVal bool | IntVal int | RealVal real |
               PairVal val val  ("<|_, _|>"  [0,  61] 1000)

abbreviation "TRUE \<equiv> BoolVal True"
abbreviation "FALSE \<equiv> BoolVal False"

type_synonym vname = "nat"
type_synonym state = "vname \<Rightarrow> val"

definition "RealPairVal \<equiv> \<lambda>(x,y). <|RealVal x, RealVal y|>"
definition "extract_real_pair \<equiv> \<lambda><|RealVal x, RealVal y|> \<Rightarrow> (x,y)"
definition "IntPairVal \<equiv> \<lambda>(x,y). <|IntVal x, IntVal y|>"
definition "extract_int_pair \<equiv> \<lambda><|IntVal x, IntVal y|> \<Rightarrow> (x,y)"

lemma inj_RealPairVal: "inj RealPairVal" by (auto simp: RealPairVal_def intro!: injI)
lemma inj_IntPairVal: "inj IntPairVal" by (auto simp: IntPairVal_def intro!: injI)

primrec stock_measure :: "pdf_type \<Rightarrow> val measure" where
  "stock_measure UNIT = count_space {UnitVal}"
| "stock_measure INTEG = count_space (range IntVal)"
| "stock_measure BOOL = count_space (range BoolVal)"
| "stock_measure REAL = embed_measure lborel RealVal"
| "stock_measure (PRODUCT t1 t2) =
       embed_measure (stock_measure t1 \<Otimes>\<^sub>M stock_measure t2) (\<lambda>(a, b). PairVal a b)"

lemma sigma_finite_stock_measure[simp]: "sigma_finite_measure (stock_measure t)"
  by (induction t)
     (auto intro!: sigma_finite_measure_count_space_countable sigma_finite_pair_measure
                   sigma_finite_embed_measure injI sigma_finite_lborel)

fun val_type :: "val \<Rightarrow> pdf_type" where
  "val_type (BoolVal b) = BOOL"
| "val_type (IntVal i) = INTEG"
| "val_type UnitVal = UNIT"
| "val_type (RealVal r) = REAL"
| "val_type (<|v1 , v2|>) = (PRODUCT (val_type v1) (val_type v2))"

definition "type_universe t = {v. val_type v = t}"

lemma space_stock_measure[simp]:
    "space (stock_measure t) = type_universe t"
  by (induction t) (auto simp: space_embed_measure space_pair_measure type_universe_def
                         elim: val_type.elims)

lemma val_in_type_universe[simp]:
    "v \<in> type_universe (val_type v)"
  by (simp add: type_universe_def)

lemma type_universe_type[simp]:
    "w \<in> type_universe t \<Longrightarrow> val_type w = t"
  by (simp add: type_universe_def)

lemma type_universe_nonempty[simp]:
    "type_universe t \<noteq> {}"
  by (subst space_stock_measure[symmetric], induction t)
     (auto simp: space_pair_measure space_embed_measure simp del: space_stock_measure)

lemma inj_RealVal[simp]: "inj RealVal" by (auto intro!: inj_onI)
lemma inj_IntVal[simp]: "inj IntVal" by (auto intro!: inj_onI)
lemma inj_BoolVal[simp]: "inj BoolVal" by (auto intro!: inj_onI)
lemma inj_PairVal: "inj (\<lambda>(x, y). <| x ,  y |>)" by (auto intro: injI)

lemma nn_integral_BoolVal:
  assumes "\<And>x. x \<in> space (stock_measure BOOL) \<Longrightarrow> f x \<ge> 0"
  shows "(\<integral>\<^sup>+x. f x \<partial>stock_measure BOOL) = f (BoolVal True) + f (BoolVal False)"
proof-
  have A: "range BoolVal = {BoolVal True, BoolVal False}" by auto
  from assms show ?thesis
    by (subst stock_measure.simps, subst A, subst nn_integral_count_space_finite)
       (simp_all add: max_def A)
qed

lemma nn_integral_RealVal:
  assumes "f \<in> borel_measurable (embed_measure lborel RealVal)"
  shows "(\<integral>\<^sup>+x. f x \<partial>embed_measure lborel RealVal) = (\<integral>\<^sup>+x. f (RealVal x) \<partial>lborel)"
  using assms by (subst embed_measure_eq_distr, simp, subst nn_integral_distr) simp_all

lemma nn_integral_IntVal:
  "(\<integral>\<^sup>+x. f x \<partial>count_space (range IntVal)) = (\<integral>\<^sup>+x. f (IntVal x) \<partial>count_space UNIV)"
  by (subst embed_measure_count_space[symmetric], simp, subst embed_measure_eq_distr,
       simp, subst nn_integral_distr) (simp_all add: space_embed_measure)

definition extract_pair where "extract_pair \<equiv> \<lambda> <|v,w|> \<Rightarrow> (v,w)"
definition extract_bool where "extract_bool \<equiv> \<lambda> BoolVal v \<Rightarrow> v"
definition extract_real where "extract_real \<equiv> \<lambda> RealVal v \<Rightarrow> v | _ \<Rightarrow> 0"
definition extract_int where "extract_int \<equiv> \<lambda> IntVal v \<Rightarrow> v | _ \<Rightarrow> 0"

lemma BOOL_E: "\<lbrakk>val_type v = BOOL; \<And>b. v = BoolVal b \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
   using assms by (cases v) auto

lemma REAL_E: "\<lbrakk>val_type v = REAL; \<And>b. v = RealVal b \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
   using assms by (cases v) auto

lemma measurable_extract_pair[measurable]:
    "extract_pair \<in> measurable (embed_measure (M \<Otimes>\<^sub>M N) (\<lambda>(x,y). <|x,y|>)) (M  \<Otimes>\<^sub>M N)"
  apply (rule measurable_embed_measure1)
  apply (subst measurable_cong[of _ _ "\<lambda>x. x"])
  apply (auto simp: extract_pair_def)
  done

lemma measurable_extract_real[measurable]:
    "extract_real \<in> measurable (embed_measure lborel RealVal) borel"
  apply (rule measurable_embed_measure1)
  apply (subst measurable_cong[of _ _ "\<lambda>x. x"])
  apply (auto simp: extract_real_def)
  done

lemma measurable_extract_int[measurable]:
    "extract_int \<in> measurable (count_space (range IntVal)) (count_space UNIV)"
    by (rule measurable_count_space)

lemma measurable_extract_bool[measurable]:
    "extract_bool \<in> measurable (count_space (range BoolVal)) (count_space UNIV)"
    by (rule measurable_count_space)

lemma count_space_BoolVal_prod[simp]:
    "count_space (range BoolVal) \<Otimes>\<^sub>M count_space (range BoolVal) =
         count_space (range BoolVal \<times> range BoolVal)"
    by (rule pair_measure_countable) simp_all

lemma measurable_PairVal1:
  assumes "x \<in> space (stock_measure t1)"
  shows "PairVal x \<in> measurable (stock_measure t2)
                      (embed_measure (stock_measure t1 \<Otimes>\<^sub>M stock_measure t2) (split PairVal))"
using assms inj_PairVal by simp

lemma measurable_stock_measure_val_type:
  assumes "f \<in> measurable M (stock_measure t)" "x \<in> space M"
  shows "val_type (f x) = t"
  using assms by (auto dest!: measurable_space)

lemma type_universe_eq_imp_type_eq:
  assumes "type_universe t1 = type_universe t2"
  shows "t1 = t2"
proof-
  from type_universe_nonempty obtain v where A: "v \<in> type_universe t1" by blast
  hence "t1 = val_type v" by simp
  also from A and assms have "v \<in> type_universe t2" by simp
  hence "val_type v = t2" by simp
  finally show ?thesis .
qed

lemma type_universe_eq_iff[simp]: "type_universe t1 = type_universe t2 \<longleftrightarrow> t1 = t2"
  by (blast intro: type_universe_eq_imp_type_eq)

lemma singleton_in_stock_measure[simp]:
  "{v} \<in> sets (stock_measure (val_type v))"
proof (induction v)
  case (PairVal v1 v2)
  have A: "{<|v1, v2|>} = (\<lambda>(v1,v2). <|v1,v2|>) ` ({v1}\<times>{v2})" by simp
  from pair_measureI[OF PairVal.IH] show ?case
    by (simp only: val_type.simps stock_measure.simps A in_sets_embed_measure)
qed (auto simp: sets_embed_measure)

lemma emeasure_stock_measure_singleton_finite[simp]:
    "emeasure (stock_measure (val_type v)) {v} \<noteq> \<infinity>"
proof (induction v)
  case (RealVal r)
  have A: "{RealVal r} = RealVal ` {r}" by simp
  have "RealVal ` {r} \<in> sets (embed_measure lborel RealVal)"
      by (rule in_sets_embed_measure) simp
  thus ?case by (simp only: A val_type.simps stock_measure.simps emeasure_embed_measure
                            inj_RealVal inj_vimage_image_eq) simp
next
  case (PairVal v1 v2)
    let ?M = "\<lambda>x. stock_measure (val_type x)"
    interpret sigma_finite_measure "stock_measure (val_type v2)"
      by (rule sigma_finite_stock_measure)
    have A: "{<|v1, v2|>} = (\<lambda>(v1,v2). <|v1,v2|>) ` ({v1}\<times>{v2})" by simp
    have B: "{v1}\<times>{v2} \<in> ?M v1 \<Otimes>\<^sub>M ?M v2"
      by (intro pair_measureI singleton_in_stock_measure)
    hence "emeasure (?M (<|v1,v2|>)) {<|v1,v2|>} = emeasure (?M v1) {v1} * emeasure (?M v2) {v2}"
      by (simp only: stock_measure.simps val_type.simps A emeasure_embed_measure_image inj_PairVal
                     inj_vimage_image_eq emeasure_pair_measure_Times singleton_in_stock_measure B)
    with PairVal.IH show ?case by simp
qed simp_all

subsection {* Measures on states *}

definition state_measure :: "vname set \<Rightarrow> (vname \<Rightarrow> pdf_type) \<Rightarrow> state measure" where
  "state_measure V \<Gamma> \<equiv> \<Pi>\<^sub>M y\<in>V. stock_measure (\<Gamma> y)"

lemma state_measure_nonempty[simp]: "space (state_measure V \<Gamma>) \<noteq> {}"
  by (simp add: state_measure_def space_PiM PiE_eq_empty_iff)

lemma state_measure_var_type:
    "\<sigma> \<in> space (state_measure V \<Gamma>) \<Longrightarrow> x \<in> V \<Longrightarrow> val_type (\<sigma> x) = \<Gamma> x"
  by (auto simp: state_measure_def space_PiM dest!: PiE_mem)

lemma merge_in_state_measure:
  "x \<in> space (state_measure A \<Gamma>) \<Longrightarrow> y \<in> space (state_measure B \<Gamma>) \<Longrightarrow>
      merge A B (x, y) \<in> space (state_measure (A\<union>B) \<Gamma>)" unfolding state_measure_def
  by (rule measurable_space, rule measurable_merge) (simp add: space_pair_measure)

lemma comp_in_state_measure:
    assumes "\<sigma> \<in> space (state_measure V \<Gamma>)"
    shows "\<sigma> \<circ> f \<in> space (state_measure (f -` V) (\<Gamma> \<circ> f))"
  using assms by (auto simp: state_measure_def space_PiM)

lemma sigma_finite_state_measure[intro]:
    "finite V \<Longrightarrow> sigma_finite_measure (state_measure V \<Gamma>)" unfolding state_measure_def
  by (auto intro!: product_sigma_finite.sigma_finite simp: product_sigma_finite_def)

subsection {* Equalities of measure embeddings *}

lemma embed_measure_RealPairVal:
   "stock_measure (PRODUCT REAL REAL) = embed_measure lborel RealPairVal"
proof-
  have [simp]: "(\<lambda>(x, y). <| x ,  y |>) \<circ> (\<lambda>(x, y). (RealVal x, RealVal y)) = RealPairVal"
    unfolding RealPairVal_def by auto
  have "stock_measure (PRODUCT REAL REAL) =
            embed_measure (embed_measure lborel (\<lambda>(x, y). (RealVal x, RealVal y))) (split PairVal)"
    by (auto simp: embed_measure_prod sigma_finite_lborel lborel_prod)
  also have "... = embed_measure lborel RealPairVal"
    by (subst embed_measure_comp) (auto intro!: injI)
  finally show ?thesis .
qed

lemma embed_measure_IntPairVal:
   "stock_measure (PRODUCT INTEG INTEG) = (count_space (range IntPairVal))"
proof-
  have [simp]: "(\<lambda>(x, y). <| x ,  y |>) ` (range IntVal \<times> range IntVal) = range IntPairVal"
    by (auto simp: IntPairVal_def)
  show ?thesis by (auto simp: embed_measure_prod embed_measure_count_space inj_PairVal)
qed

subsection {* Monadic operations on values *}

definition "return_val x = return (stock_measure (val_type x)) x"

lemma sets_return_val: "sets (return_val x) = sets (stock_measure (val_type x))"
    by (simp add: return_val_def)

lemma measurable_return_val[simp]:
    "return_val \<in> measurable (stock_measure t) (subprob_algebra (stock_measure t))"
  unfolding return_val_def[abs_def]
  apply (subst measurable_cong)
  apply (subst (asm) space_stock_measure, subst type_universe_type, assumption, rule refl)
  apply (rule return_measurable)
  done

lemma bind_return_val:
  assumes "space M \<noteq> {}" "f \<in> measurable M (stock_measure t')"
  shows "M \<guillemotright>= (\<lambda>x. return_val (f x)) = distr M (stock_measure t') f"
  using assms
  by (subst bind_return_distr[symmetric])
     (auto simp: return_val_def intro!: bind_cong dest: measurable_stock_measure_val_type)

lemma bind_return_val':
  assumes "val_type x = t" "f \<in> measurable (stock_measure t) (stock_measure t')"
  shows "return_val x \<guillemotright>= (\<lambda>x. return_val (f x)) = return_val (f x)"
proof-
  have "return_val x \<guillemotright>= (\<lambda>x. return_val (f x)) = return (stock_measure t') (f x)"
    apply (subst bind_return_val, unfold return_val_def, simp)
    apply (insert assms, simp cong: measurable_cong_sets) []
    apply (subst distr_return, simp_all add: assms type_universe_def
                                        del: type_universe_type)
    done
  also from assms(2) have "f x \<in> space (stock_measure t')"
    by (rule measurable_space)
       (simp add: assms(1) type_universe_def del: type_universe_type)
  hence "return (stock_measure t') (f x) = return_val (f x)"
    by (simp add: return_val_def)
  finally show ?thesis .
qed

lemma bind_return_val'':
  assumes "f \<in> measurable (stock_measure (val_type x)) (subprob_algebra M)"
  shows "return_val x \<guillemotright>= f = f x"
unfolding return_val_def by (subst bind_return[OF assms]) simp_all

lemma bind_assoc_return_val:
  assumes sets_M: "sets M = sets (stock_measure t)"
  assumes Mf: "f \<in> measurable (stock_measure t) (stock_measure t')"
  assumes Mg: "g \<in> measurable (stock_measure t') (stock_measure t'')"
  shows "(M \<guillemotright>= (\<lambda>x. return_val (f x))) \<guillemotright>= (\<lambda>x. return_val (g x)) =
             M \<guillemotright>= (\<lambda>x. return_val (g (f x)))"
proof-
  have "(M \<guillemotright>= (\<lambda>x. return_val (f x))) \<guillemotright>= (\<lambda>x. return_val (g x)) =
           M \<guillemotright>= (\<lambda>x. return_val (f x) \<guillemotright>= (\<lambda>x. return_val (g x)))"
    apply (subst bind_assoc)
    apply (rule measurable_compose[OF _ measurable_return_val])
    apply (subst measurable_cong_sets[OF sets_M refl], rule Mf)
    apply (rule measurable_compose[OF Mg measurable_return_val], rule refl)
    done
  also have "... = M \<guillemotright>= (\<lambda>x. return_val (g (f x)))"
    apply (intro bind_cong ballI)
    apply (subst (asm) sets_eq_imp_space_eq[OF sets_M])
    apply (drule measurable_space[OF Mf])
    apply (subst bind_return_val'[where t = t' and t' = t''])
    apply (simp_all add: Mg)
    done
  finally show ?thesis .
qed

lemma bind_return_val_distr:
  assumes sets_M: "sets M = sets (stock_measure t)"
  assumes Mf: "f \<in> measurable (stock_measure t) (stock_measure t')"
  shows "M \<guillemotright>= return_val \<circ> f = distr M (stock_measure t') f"
proof-
  have "M \<guillemotright>= return_val \<circ> f = M \<guillemotright>= return (stock_measure t') \<circ> f"
    apply (intro bind_cong ballI)
    apply (subst (asm) sets_eq_imp_space_eq[OF sets_M])
    apply (drule measurable_space[OF Mf])
    apply (simp add: return_val_def o_def)
    done
  also have "... = distr M (stock_measure t') f"
    apply (rule bind_return_distr)
    apply (simp add: sets_eq_imp_space_eq[OF sets_M])
    apply (subst measurable_cong_sets[OF sets_M refl], rule Mf)
    done
  finally show ?thesis .
qed

subsection {* Lifting of functions *}

definition lift_RealVal where
  "lift_RealVal f \<equiv> \<lambda> RealVal v \<Rightarrow> RealVal (f v) | _ \<Rightarrow> RealVal (f 0)"
definition lift_IntVal where
  "lift_IntVal f \<equiv> \<lambda> IntVal v \<Rightarrow> IntVal (f v) | _ \<Rightarrow> IntVal (f 0)"
definition lift_RealIntVal where
  "lift_RealIntVal f g \<equiv> \<lambda> IntVal v \<Rightarrow> IntVal (f v) | RealVal v \<Rightarrow> RealVal (g v)"
definition lift_RealIntVal2 where
  "lift_RealIntVal2 f g \<equiv> \<lambda> <|IntVal v, IntVal w|> \<Rightarrow> IntVal (f v w)
                          | <|RealVal v, RealVal w|> \<Rightarrow> RealVal (g v w)"
definition lift_Comp where
  "lift_Comp f g \<equiv> \<lambda> <|IntVal v, IntVal w|> \<Rightarrow> BoolVal (f v w)
                   | <|RealVal v, RealVal w|> \<Rightarrow> BoolVal (g v w)"

lemma lift_RealIntVal_Real:
  "x \<in> space (stock_measure REAL) \<Longrightarrow> lift_RealIntVal f g x = lift_RealVal g x"
  by (auto simp: space_embed_measure lift_RealIntVal_def lift_RealVal_def)

lemma lift_RealIntVal_Int:
  "x \<in> space (stock_measure INTEG) \<Longrightarrow> lift_RealIntVal f g x = lift_IntVal f x"
  by (auto simp: space_embed_measure lift_RealIntVal_def lift_IntVal_def)

lemma measurable_lift_RealVal[measurable]:
  assumes "f \<in> borel_measurable borel"
  shows "lift_RealVal f \<in> measurable (embed_measure lborel RealVal) (embed_measure lborel RealVal)"
    (is "_ \<in> measurable ?M _")
proof-
  have "lift_RealVal f = RealVal \<circ> f \<circ> extract_real"
    unfolding lift_RealVal_def extract_real_def by (intro ext) (auto split: val.split)
  also have "RealVal \<in> measurable borel ?M" by simp
  hence "RealVal \<circ> f \<circ> extract_real \<in> measurable ?M ?M"
    by (intro measurable_comp) (blast intro!: measurable_extract_real assms)+
  finally show ?thesis .
qed

lemma measurable_lift_IntVal[simp]:
    "lift_IntVal f \<in> range IntVal \<rightarrow> range IntVal"
  by (auto simp: lift_IntVal_def)

lemma measurable_lift_Comp_RealVal[measurable]:
  assumes "Measurable.pred (borel \<Otimes>\<^sub>M borel) (split g)"
  shows "lift_Comp f g \<in> measurable (embed_measure (embed_measure lborel RealVal \<Otimes>\<^sub>M
                                        embed_measure lborel RealVal) (split PairVal))
                                    (count_space (range BoolVal))"
    (is "_ \<in> measurable ?M ?N")
proof-
  have "\<And>x. x \<in> space ?M \<Longrightarrow> lift_Comp f g x =
                (BoolVal \<circ> (\<lambda>x. g (fst x) (snd x)) \<circ>
                (\<lambda>(x,y). (extract_real x, extract_real y)) \<circ> extract_pair) x"
    by (auto simp: o_def extract_real_def extract_pair_def
             lift_Comp_def space_pair_measure space_embed_measure split: val.split)
  moreover have "... \<in> measurable ?M ?N"
    by (intro measurable_comp, rule measurable_extract_pair, subst measurable_split_conv,
        rule measurable_Pair, rule measurable_compose[OF measurable_fst measurable_extract_real],
        rule measurable_compose[OF measurable_snd measurable_extract_real],
        subst measurable_split_conv[symmetric], rule assms, simp)
  ultimately show ?thesis by (simp cong: measurable_cong)
qed

lemma measurable_lift_Comp_IntVal[simp]:
    "lift_Comp f g \<in> measurable (embed_measure (count_space (range IntVal) \<Otimes>\<^sub>M
                                    count_space (range IntVal)) (split PairVal))
                                (count_space (range BoolVal))"
  by (auto simp: lift_Comp_def embed_measure_count_space inj_PairVal)

lemma measurable_lift_RealIntVal_IntVal[simp]:
    "lift_RealIntVal f g \<in> range IntVal \<rightarrow> range IntVal"
  by (auto simp: embed_measure_count_space lift_RealIntVal_def)

lemma measurable_lift_RealIntVal_RealVal[measurable]:
  assumes "g \<in> borel_measurable borel"
  shows "lift_RealIntVal f g \<in>
           measurable (embed_measure lborel RealVal) (embed_measure lborel RealVal)"
    (is "_ \<in> measurable ?M _")
proof-
  have "\<And>x. x \<in> space ?M \<Longrightarrow> lift_RealIntVal f g x = lift_RealVal g x"
    unfolding lift_RealVal_def lift_RealIntVal_def
    by (auto split: val.split simp: space_embed_measure)
  with assms and measurable_lift_RealVal show ?thesis by (simp cong: measurable_cong)
qed

lemma measurable_lift_RealIntVal2_IntVal[measurable]:
    "lift_RealIntVal2 f g \<in> measurable (embed_measure (count_space (range IntVal) \<Otimes>\<^sub>M
                                          count_space (range IntVal)) (split PairVal))
                                       (count_space (range IntVal))"
  by (auto simp: lift_RealIntVal2_def embed_measure_count_space inj_PairVal)

lemma measurable_lift_RealIntVal2_RealVal[measurable]:
  assumes "(\<lambda>x. g (fst x) (snd x)) \<in> borel_measurable (borel \<Otimes>\<^sub>M borel)"
  shows "lift_RealIntVal2 f g \<in> measurable (embed_measure (embed_measure lborel RealVal \<Otimes>\<^sub>M
                                                embed_measure lborel RealVal) (split PairVal))
                                           (embed_measure lborel RealVal)"
    (is "_ \<in> measurable ?M ?N")
proof-
  have "\<And>x. x \<in> space ?M \<Longrightarrow> lift_RealIntVal2 f g x =
                (RealVal \<circ> (\<lambda>x. g (fst x) (snd x)) \<circ>
                (\<lambda>(x,y). (extract_real x, extract_real y)) \<circ> extract_pair) x"
    by (auto simp: o_def extract_real_def extract_pair_def
             lift_RealIntVal2_def space_pair_measure space_embed_measure split: val.split)
  moreover have "... \<in> measurable ?M ?N"
    by (intro measurable_comp, rule measurable_extract_pair, subst measurable_split_conv,
        rule measurable_Pair, rule measurable_compose[OF measurable_fst measurable_extract_real],
        rule measurable_compose[OF measurable_snd measurable_extract_real], rule assms,
        subst measurable_lborel2[symmetric], rule measurable_embed_measure2, rule inj_RealVal)
  ultimately show ?thesis by (simp cong: measurable_cong)
qed

lemma distr_lift_RealVal:
  fixes f
  assumes Mf: "f \<in> borel_measurable borel"
  assumes pdens: "has_subprob_density M (stock_measure REAL) \<delta>"
  assumes dens': "\<And>M \<delta>. has_subprob_density M lborel \<delta> \<Longrightarrow> has_density (distr M borel f) lborel (g \<delta>)"
  defines "N \<equiv> distr M (stock_measure REAL) (lift_RealVal f)"
  shows "has_density N (stock_measure REAL) (g (\<lambda>x. \<delta> (RealVal x)) \<circ> extract_real)"
proof (rule has_densityI)
  from assms(2) have dens: "has_density M (stock_measure REAL) \<delta>"
    unfolding has_subprob_density_def by simp
  have MRV: "RealVal \<in> measurable borel (embed_measure lborel RealVal)"
    by (subst measurable_lborel2[symmetric], rule measurable_embed_measure2) simp
  from dens have sets_M: "sets M = sets (embed_measure lborel RealVal)" by (auto dest: has_densityD)

  have "N = distr M (stock_measure REAL) (lift_RealVal f)" by (simp add: N_def)
  also have "lift_RealVal f = RealVal \<circ> f \<circ> extract_real"
    unfolding lift_RealVal_def extract_real_def by (intro ext) (auto simp: o_def split: val.split)
  also have "distr M (stock_measure REAL) ... =
               distr (distr (distr M lborel extract_real) borel f) (stock_measure REAL) RealVal"
    apply (subst distr_distr[symmetric], intro measurable_comp, rule assms(1), simp add: MRV)
    apply (subst measurable_cong_sets[OF sets_M refl], rule measurable_extract_real)
    apply (subst distr_distr[symmetric], subst stock_measure.simps, rule MRV,
           simp_all add: assms(1) cong: distr_cong)
    done
  also have dens'': "has_density (distr (distr M lborel extract_real) borel f) lborel (g (\<delta> \<circ> RealVal))"
    by (intro dens' has_subprob_density_embed_measure'') (insert pdens, simp_all add: extract_real_def)
  hence "distr (distr M lborel extract_real) borel f = density lborel (g (\<delta> \<circ> RealVal))"
    by (rule has_densityD)
  also have "distr ... (stock_measure REAL) RealVal = embed_measure ... RealVal" (is "_ = ?M")
    by (subst embed_measure_eq_distr[OF inj_RealVal], intro distr_cong)
       (simp_all add: sets_embed_measure)
  also have "... = density (embed_measure lborel RealVal) (g (\<lambda>x. \<delta> (RealVal x)) \<circ> extract_real)"
    using dens''[unfolded o_def]
    apply (subst density_embed_measure', simp, simp add: extract_real_def)
    apply (erule has_densityD, simp add: o_def)
    done
  finally show "N = density (stock_measure REAL) (g (\<lambda>x. \<delta> (RealVal x)) \<circ> extract_real)" by simp

  from dens''[unfolded o_def]
    show "g (\<lambda>x. \<delta> (RealVal x)) \<circ> extract_real \<in> borel_measurable (stock_measure REAL)"
    by (intro measurable_comp, subst stock_measure.simps)
       (rule measurable_extract_real, subst measurable_lborel2[symmetric], erule has_densityD)
  fix x assume "x \<in> space (stock_measure REAL)"
  thus "(g (\<lambda>x. \<delta> (RealVal x)) \<circ> extract_real) x \<ge> 0" unfolding o_def
    by (intro has_densityD(2)[OF dens''[unfolded o_def]]) auto
qed (subst space_stock_measure, simp)

lemma distr_lift_IntVal:
  fixes f
  assumes pdens: "has_density M (stock_measure INTEG) \<delta>"
  assumes dens': "\<And>M \<delta>. has_density M (count_space UNIV) \<delta> \<Longrightarrow>
                            has_density (distr M (count_space UNIV) f) (count_space UNIV) (g \<delta>)"
  defines "N \<equiv> distr M (stock_measure INTEG) (lift_IntVal f)"
  shows "has_density N (stock_measure INTEG) (g (\<lambda>x. \<delta> (IntVal x)) \<circ> extract_int)"
proof (rule has_densityI)
  let ?R = "count_space UNIV" and ?S = "count_space (range IntVal)"
  have Mf: "f \<in> measurable ?R ?R" by simp
  have MIV: "IntVal \<in> measurable ?R ?S" by simp
  from assms(1) have dens: "has_density M (stock_measure INTEG) \<delta>"
    unfolding has_subprob_density_def by simp
  from dens have sets_M: "sets M = sets ?S" by (auto dest!: has_densityD(3))

  have "N = distr M (stock_measure INTEG) (lift_IntVal f)" by (simp add: N_def)
  also have "lift_IntVal f = IntVal \<circ> f \<circ> extract_int"
    unfolding lift_IntVal_def extract_int_def by (intro ext) (auto simp: o_def split: val.split)
  also have "distr M (stock_measure INTEG) ... =
               distr (distr (distr M ?R extract_int) ?R f) (stock_measure INTEG) IntVal"
    apply (subst distr_distr[symmetric], intro measurable_comp, rule Mf, simp)
    apply (subst measurable_cong_sets[OF sets_M refl], simp)
    apply (subst distr_distr[symmetric], subst stock_measure.simps, rule MIV, simp_all add: Mf)
    done
  also have dens'': "has_density (distr (distr M ?R extract_int) ?R f) ?R (g (\<delta> \<circ> IntVal))"
    by (intro dens' has_density_embed_measure'')
       (insert dens, simp_all add: extract_int_def embed_measure_count_space)
  hence "distr (distr M ?R extract_int) ?R f = density ?R (g (\<delta> \<circ> IntVal))"
    by (rule has_densityD)
  also have "distr ... (stock_measure INTEG) IntVal = embed_measure ... IntVal" (is "_ = ?M")
    by (subst embed_measure_eq_distr[OF inj_IntVal], intro distr_cong)
       (auto simp: sets_embed_measure subset_image_iff)
  also have "... = density (embed_measure ?R IntVal) (g (\<lambda>x. \<delta> (IntVal x)) \<circ> extract_int)"
    using dens''[unfolded o_def]
    apply (subst density_embed_measure', simp, simp add: extract_int_def)
    apply (erule has_densityD, simp add: o_def)
    done
  finally show "N = density (stock_measure INTEG) (g (\<lambda>x. \<delta> (IntVal x)) \<circ> extract_int)"
    by (simp add: embed_measure_count_space)

  from dens''[unfolded o_def]
    show "g (\<lambda>x. \<delta> (IntVal x)) \<circ> extract_int \<in> borel_measurable (stock_measure INTEG)"
    by (simp add: embed_measure_count_space)
  fix x assume "x \<in> space (stock_measure INTEG)"
  thus "(g (\<lambda>x. \<delta> (IntVal x)) \<circ> extract_int) x \<ge> 0" unfolding o_def
    by (intro has_densityD(2)[OF dens''[unfolded o_def]]) auto
qed (subst space_stock_measure, simp)

lemma measurable_extract_real_pair[measurable]:
  "extract_real_pair \<in> borel_measurable (stock_measure (PRODUCT REAL REAL))"
proof-
  let ?f = "\<lambda>x. (extract_real (fst (extract_pair x)), extract_real (snd (extract_pair x)))"
  have "?f \<in> borel_measurable (stock_measure (PRODUCT REAL REAL))" by simp
  also have "?f \<in> borel_measurable (stock_measure (PRODUCT REAL REAL)) \<longleftrightarrow>
                  extract_real_pair \<in> borel_measurable (stock_measure (PRODUCT REAL REAL))"
    by (intro measurable_cong)
       (auto simp: extract_real_pair_def space_embed_measure
                   space_pair_measure extract_real_def extract_pair_def)
  finally show ?thesis .
qed

lemma distr_lift_RealPairVal:
  fixes f f' g
  assumes Mf: "split f \<in> borel_measurable borel"
  assumes pdens: "has_subprob_density M (stock_measure (PRODUCT REAL REAL)) \<delta>"
  assumes dens': "\<And>M \<delta>. has_subprob_density M lborel \<delta> \<Longrightarrow> has_density (distr M borel (split f)) lborel (g \<delta>)"
  defines "N \<equiv> distr M (stock_measure REAL) (lift_RealIntVal2 f' f)"
  shows "has_density N (stock_measure REAL) (g (\<lambda>x. \<delta> (RealPairVal x)) \<circ> extract_real)"
proof (rule has_densityI)
  from assms(2) have dens: "has_density M (stock_measure (PRODUCT REAL REAL)) \<delta>"
    unfolding has_subprob_density_def by simp
  have sets_M: "sets M = sets (stock_measure (PRODUCT REAL REAL))"
    by (auto simp: has_subprob_densityD[OF pdens])
  hence [simp]: "space M = space (stock_measure (PRODUCT REAL REAL))"
    by (rule sets_eq_imp_space_eq)
  have meas_M[simp]: "measurable M = measurable (stock_measure (PRODUCT REAL REAL))"
    by (intro ext measurable_cong_sets) (simp_all add: sets_M)
  have MRV: "RealVal \<in> measurable borel (embed_measure lborel RealVal)"
    by (subst measurable_lborel2[symmetric], rule measurable_embed_measure2) simp

  have "N = distr M (stock_measure REAL) (lift_RealIntVal2 f' f)" by (simp add: N_def)
  also have "... = distr M (stock_measure REAL) (RealVal \<circ> split f \<circ> extract_real_pair)"
    by (intro distr_cong) (auto simp: lift_RealIntVal2_def extract_real_pair_def
                                       space_embed_measure space_pair_measure)
  also have "... = distr (distr (distr M lborel extract_real_pair) borel (split f))
                        (stock_measure REAL) RealVal"
    apply (subst distr_distr[symmetric], intro measurable_comp, rule assms(1), simp add: MRV)
    apply (subst meas_M, rule measurable_extract_real_pair)
    apply (subst distr_distr[symmetric], subst stock_measure.simps, rule MRV,
           simp_all add: assms(1) cong: distr_cong)
    done
  also have dens'': "has_density (distr (distr M lborel extract_real_pair) borel (split f)) lborel
                      (g (\<delta> \<circ> RealPairVal))" using inj_RealPairVal embed_measure_RealPairVal
    by (intro dens' has_subprob_density_embed_measure'')
       (insert pdens, simp_all add: extract_real_pair_def RealPairVal_def split: prod.split)
  hence "distr (distr M lborel extract_real_pair) borel (split f) =
             density lborel (g (\<delta> \<circ> RealPairVal))" by (rule has_densityD)
  also have "distr ... (stock_measure REAL) RealVal = embed_measure ... RealVal" (is "_ = ?M")
    by (subst embed_measure_eq_distr[OF inj_RealVal], intro distr_cong)
       (simp_all add: sets_embed_measure)
  also have "... = density (embed_measure lborel RealVal) (g (\<lambda>x. \<delta> (RealPairVal x)) \<circ> extract_real)"
    using dens''[unfolded o_def]
    by (subst density_embed_measure', simp, simp add: extract_real_def)
       (erule has_densityD, simp add: o_def)
  finally show "N = density (stock_measure REAL) (g (\<lambda>x. \<delta> (RealPairVal x)) \<circ> extract_real)" by simp

  from dens''[unfolded o_def]
    show "g (\<lambda>x. \<delta> (RealPairVal x)) \<circ> extract_real \<in> borel_measurable (stock_measure REAL)"
    by (intro measurable_comp, subst stock_measure.simps)
       (rule measurable_extract_real, subst measurable_lborel2[symmetric], erule has_densityD)
  fix x assume "x \<in> space (stock_measure REAL)"
  thus "(g (\<lambda>x. \<delta> (RealPairVal x)) \<circ> extract_real) x \<ge> 0" unfolding o_def
    by (intro has_densityD(2)[OF dens''[unfolded o_def]]) auto
qed (subst space_stock_measure, simp)

lemma distr_lift_IntPairVal:
  fixes f f'
  assumes pdens: "has_density M (stock_measure (PRODUCT INTEG INTEG)) \<delta>"
  assumes dens': "\<And>M \<delta>. has_density M (count_space UNIV) \<delta> \<Longrightarrow>
                            has_density (distr M (count_space UNIV) (split f))
                                        (count_space UNIV) (g \<delta>)"
  defines "N \<equiv> distr M (stock_measure INTEG) (lift_RealIntVal2 f f')"
  shows "has_density N (stock_measure INTEG) (g (\<lambda>x. \<delta> (IntPairVal x)) \<circ> extract_int)"
proof (rule has_densityI)
  let ?R = "count_space UNIV" and ?S = "count_space (range IntVal)"
  and ?T = "count_space (range IntPairVal)" and ?tp = "PRODUCT INTEG INTEG"
  have Mf: "f \<in> measurable ?R ?R" by simp
  have MIV: "IntVal \<in> measurable ?R ?S" by simp
  from assms(1) have dens: "has_density M (stock_measure ?tp) \<delta>"
    unfolding has_subprob_density_def by simp
  from dens have "M = density (stock_measure ?tp) \<delta>" by (rule has_densityD)
  hence sets_M: "sets M = sets ?T" by (subst embed_measure_IntPairVal[symmetric]) auto
  hence [simp]: "space M = space ?T" by (rule sets_eq_imp_space_eq)
  from sets_M have [simp]: "measurable M = measurable (count_space (range IntPairVal))"
    by (intro ext measurable_cong_sets) simp_all

  have "N = distr M (stock_measure INTEG) (lift_RealIntVal2 f f')" by (simp add: N_def)

  also have "... = distr M (stock_measure INTEG) (IntVal \<circ> split f \<circ> extract_int_pair)"
    by (intro distr_cong) (auto simp: lift_RealIntVal2_def extract_int_pair_def
                                       space_embed_measure space_pair_measure IntPairVal_def)
  also have "... = distr (distr (distr M (count_space UNIV) extract_int_pair)
                        (count_space UNIV) (split f)) (stock_measure INTEG) IntVal"
    apply (subst distr_distr[of _ ?R, symmetric], simp, simp)
    apply (subst distr_distr[symmetric], subst stock_measure.simps, rule MIV,
           simp_all add: assms(1) cong: distr_cong)
    done
  also have dens'': "has_density (distr (distr M (count_space UNIV) extract_int_pair) ?R (split f)) ?R
                      (g (\<delta> \<circ> IntPairVal))" using inj_IntPairVal embed_measure_IntPairVal
    by (intro dens' has_density_embed_measure'')
       (insert dens, simp_all add: extract_int_def embed_measure_count_space
                         extract_int_pair_def IntPairVal_def split: prod.split)
  hence "distr (distr M (count_space UNIV) extract_int_pair) ?R (split f) =
             density ?R (g (\<delta> \<circ> IntPairVal))" by (rule has_densityD)
  also have "distr ... (stock_measure INTEG) IntVal = embed_measure ... IntVal" (is "_ = ?M")
    by (subst embed_measure_eq_distr[OF inj_IntVal], intro distr_cong)
       (auto simp: sets_embed_measure subset_image_iff)
  also have "... = density (embed_measure ?R IntVal) (g (\<lambda>x. \<delta> (IntPairVal x)) \<circ> extract_int)"
    using dens''[unfolded o_def]
    by (subst density_embed_measure', simp, simp add: extract_int_def)
       (erule has_densityD, simp add: o_def)
  finally show "N = density (stock_measure INTEG) (g (\<lambda>x. \<delta> (IntPairVal x)) \<circ> extract_int)"
    by (simp add: embed_measure_count_space)

  from dens''[unfolded o_def]
    show "g (\<lambda>x. \<delta> (IntPairVal x)) \<circ> extract_int \<in> borel_measurable (stock_measure INTEG)"
    by (simp add: embed_measure_count_space)
  fix x assume "x \<in> space (stock_measure INTEG)"
  thus "(g (\<lambda>x. \<delta> (IntPairVal x)) \<circ> extract_int) x \<ge> 0" unfolding o_def
    by (intro has_densityD(2)[OF dens''[unfolded o_def]]) auto
qed (subst space_stock_measure, simp)

end


(*  Title:      HOL/UNITY/UNITY.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1998  University of Cambridge

The basic UNITY theory (revised version, based upon the "co"
operator).

From Misra, "A Logic for Concurrent Programming", 1994.
*)

section \<open>The Basic UNITY Theory\<close>

theory UNITY imports Main begin

definition
  "Program =
    {(init:: 'a set, acts :: ('a * 'a)set set,
      allowed :: ('a * 'a)set set). Id \<in> acts & Id: allowed}"

typedef 'a program = "Program :: ('a set * ('a * 'a) set set * ('a * 'a) set set) set"
  morphisms Rep_Program Abs_Program
  unfolding Program_def by blast

definition Acts :: "'a program => ('a * 'a)set set" where
    "Acts F == (%(init, acts, allowed). acts) (Rep_Program F)"

definition "constrains" :: "['a set, 'a set] => 'a program set"  (infixl "co"     60) where
    "A co B == {F. \<forall>act \<in> Acts F. act``A \<subseteq> B}"

definition unless  :: "['a set, 'a set] => 'a program set"  (infixl "unless" 60)  where
    "A unless B == (A-B) co (A \<union> B)"

definition mk_program :: "('a set * ('a * 'a)set set * ('a * 'a)set set)
                   => 'a program" where
    "mk_program == %(init, acts, allowed).
                      Abs_Program (init, insert Id acts, insert Id allowed)"

definition Init :: "'a program => 'a set" where
    "Init F == (%(init, acts, allowed). init) (Rep_Program F)"

definition AllowedActs :: "'a program => ('a * 'a)set set" where
    "AllowedActs F == (%(init, acts, allowed). allowed) (Rep_Program F)"

definition Allowed :: "'a program => 'a program set" where
    "Allowed F == {G. Acts G \<subseteq> AllowedActs F}"

definition stable     :: "'a set => 'a program set" where
    "stable A == A co A"

definition strongest_rhs :: "['a program, 'a set] => 'a set" where
    "strongest_rhs F A == \<Inter>{B. F \<in> A co B}"

definition invariant :: "'a set => 'a program set" where
    "invariant A == {F. Init F \<subseteq> A} \<inter> stable A"

definition increasing :: "['a => 'b::{order}] => 'a program set" where
    \<comment>\<open>Polymorphic in both states and the meaning of \<open>\<le>\<close>\<close>
    "increasing f == \<Inter>z. stable {s. z \<le> f s}"

subsubsection\<open>The abstract type of programs\<close>

lemmas program_typedef =
     Rep_Program Rep_Program_inverse Abs_Program_inverse
     Program_def Init_def Acts_def AllowedActs_def mk_program_def

lemma Id_in_Acts [iff]: "Id \<in> Acts F"
apply (cut_tac x = F in Rep_Program)
apply (auto simp add: program_typedef)
done

lemma insert_Id_Acts [iff]: "insert Id (Acts F) = Acts F"
by (simp add: insert_absorb)

lemma Acts_nonempty [simp]: "Acts F \<noteq> {}"
by auto

lemma Id_in_AllowedActs [iff]: "Id \<in> AllowedActs F"
apply (cut_tac x = F in Rep_Program)
apply (auto simp add: program_typedef)
done

lemma insert_Id_AllowedActs [iff]: "insert Id (AllowedActs F) = AllowedActs F"
by (simp add: insert_absorb)

subsubsection\<open>Inspectors for type "program"\<close>

lemma Init_eq [simp]: "Init (mk_program (init,acts,allowed)) = init"
by (simp add: program_typedef)

lemma Acts_eq [simp]: "Acts (mk_program (init,acts,allowed)) = insert Id acts"
by (simp add: program_typedef)

lemma AllowedActs_eq [simp]:
     "AllowedActs (mk_program (init,acts,allowed)) = insert Id allowed"
by (simp add: program_typedef)

subsubsection\<open>Equality for UNITY programs\<close>

lemma surjective_mk_program [simp]:
     "mk_program (Init F, Acts F, AllowedActs F) = F"
apply (cut_tac x = F in Rep_Program)
apply (auto simp add: program_typedef)
apply (drule_tac f = Abs_Program in arg_cong)+
apply (simp add: program_typedef insert_absorb)
done

lemma program_equalityI:
     "[| Init F = Init G; Acts F = Acts G; AllowedActs F = AllowedActs G |]
      ==> F = G"
apply (rule_tac t = F in surjective_mk_program [THEN subst])
apply (rule_tac t = G in surjective_mk_program [THEN subst], simp)
done

lemma program_equalityE:
     "[| F = G;
         [| Init F = Init G; Acts F = Acts G; AllowedActs F = AllowedActs G |]
         ==> P |] ==> P"
by simp

lemma program_equality_iff:
     "(F=G) =
      (Init F = Init G & Acts F = Acts G &AllowedActs F = AllowedActs G)"
by (blast intro: program_equalityI program_equalityE)

subsubsection\<open>co\<close>

lemma constrainsI:
    "(!!act s s'. [| act: Acts F;  (s,s') \<in> act;  s \<in> A |] ==> s': A')
     ==> F \<in> A co A'"
by (simp add: constrains_def, blast)

lemma constrainsD:
    "[| F \<in> A co A'; act: Acts F;  (s,s'): act;  s \<in> A |] ==> s': A'"
by (unfold constrains_def, blast)

lemma constrains_empty [iff]: "F \<in> {} co B"
by (unfold constrains_def, blast)

lemma constrains_empty2 [iff]: "(F \<in> A co {}) = (A={})"
by (unfold constrains_def, blast)

lemma constrains_UNIV [iff]: "(F \<in> UNIV co B) = (B = UNIV)"
by (unfold constrains_def, blast)

lemma constrains_UNIV2 [iff]: "F \<in> A co UNIV"
by (unfold constrains_def, blast)

text\<open>monotonic in 2nd argument\<close>
lemma constrains_weaken_R:
    "[| F \<in> A co A'; A'<=B' |] ==> F \<in> A co B'"
by (unfold constrains_def, blast)

text\<open>anti-monotonic in 1st argument\<close>
lemma constrains_weaken_L:
    "[| F \<in> A co A'; B \<subseteq> A |] ==> F \<in> B co A'"
by (unfold constrains_def, blast)

lemma constrains_weaken:
   "[| F \<in> A co A'; B \<subseteq> A; A'<=B' |] ==> F \<in> B co B'"
by (unfold constrains_def, blast)

subsubsection\<open>Union\<close>

lemma constrains_Un:
    "[| F \<in> A co A'; F \<in> B co B' |] ==> F \<in> (A \<union> B) co (A' \<union> B')"
by (unfold constrains_def, blast)

lemma constrains_UN:
    "(!!i. i \<in> I ==> F \<in> (A i) co (A' i))
     ==> F \<in> (\<Union>i \<in> I. A i) co (\<Union>i \<in> I. A' i)"
by (unfold constrains_def, blast)

lemma constrains_Un_distrib: "(A \<union> B) co C = (A co C) \<inter> (B co C)"
by (unfold constrains_def, blast)

lemma constrains_UN_distrib: "(\<Union>i \<in> I. A i) co B = (\<Inter>i \<in> I. A i co B)"
by (unfold constrains_def, blast)

lemma constrains_Int_distrib: "C co (A \<inter> B) = (C co A) \<inter> (C co B)"
by (unfold constrains_def, blast)

lemma constrains_INT_distrib: "A co (\<Inter>i \<in> I. B i) = (\<Inter>i \<in> I. A co B i)"
by (unfold constrains_def, blast)

subsubsection\<open>Intersection\<close>

lemma constrains_Int:
    "[| F \<in> A co A'; F \<in> B co B' |] ==> F \<in> (A \<inter> B) co (A' \<inter> B')"
by (unfold constrains_def, blast)

lemma constrains_INT:
    "(!!i. i \<in> I ==> F \<in> (A i) co (A' i))
     ==> F \<in> (\<Inter>i \<in> I. A i) co (\<Inter>i \<in> I. A' i)"
by (unfold constrains_def, blast)

lemma constrains_imp_subset: "F \<in> A co A' ==> A \<subseteq> A'"
by (unfold constrains_def, auto)

text\<open>The reasoning is by subsets since "co" refers to single actions
  only.  So this rule isn't that useful.\<close>
lemma constrains_trans:
    "[| F \<in> A co B; F \<in> B co C |] ==> F \<in> A co C"
by (unfold constrains_def, blast)

lemma constrains_cancel:
   "[| F \<in> A co (A' \<union> B); F \<in> B co B' |] ==> F \<in> A co (A' \<union> B')"
by (unfold constrains_def, clarify, blast)

subsubsection\<open>unless\<close>

lemma unlessI: "F \<in> (A-B) co (A \<union> B) ==> F \<in> A unless B"
by (unfold unless_def, assumption)

lemma unlessD: "F \<in> A unless B ==> F \<in> (A-B) co (A \<union> B)"
by (unfold unless_def, assumption)

subsubsection\<open>stable\<close>

lemma stableI: "F \<in> A co A ==> F \<in> stable A"
by (unfold stable_def, assumption)

lemma stableD: "F \<in> stable A ==> F \<in> A co A"
by (unfold stable_def, assumption)

lemma stable_UNIV [simp]: "stable UNIV = UNIV"
by (unfold stable_def constrains_def, auto)

subsubsection\<open>Union\<close>

lemma stable_Un:
    "[| F \<in> stable A; F \<in> stable A' |] ==> F \<in> stable (A \<union> A')"

apply (unfold stable_def)
apply (blast intro: constrains_Un)
done

lemma stable_UN:
    "(!!i. i \<in> I ==> F \<in> stable (A i)) ==> F \<in> stable (\<Union>i \<in> I. A i)"
apply (unfold stable_def)
apply (blast intro: constrains_UN)
done

lemma stable_Union:
    "(!!A. A \<in> X ==> F \<in> stable A) ==> F \<in> stable (\<Union>X)"
by (unfold stable_def constrains_def, blast)

subsubsection\<open>Intersection\<close>

lemma stable_Int:
    "[| F \<in> stable A;  F \<in> stable A' |] ==> F \<in> stable (A \<inter> A')"
apply (unfold stable_def)
apply (blast intro: constrains_Int)
done

lemma stable_INT:
    "(!!i. i \<in> I ==> F \<in> stable (A i)) ==> F \<in> stable (\<Inter>i \<in> I. A i)"
apply (unfold stable_def)
apply (blast intro: constrains_INT)
done

lemma stable_Inter:
    "(!!A. A \<in> X ==> F \<in> stable A) ==> F \<in> stable (\<Inter>X)"
by (unfold stable_def constrains_def, blast)

lemma stable_constrains_Un:
    "[| F \<in> stable C; F \<in> A co (C \<union> A') |] ==> F \<in> (C \<union> A) co (C \<union> A')"
by (unfold stable_def constrains_def, blast)

lemma stable_constrains_Int:
  "[| F \<in> stable C; F \<in>  (C \<inter> A) co A' |] ==> F \<in> (C \<inter> A) co (C \<inter> A')"
by (unfold stable_def constrains_def, blast)

(*[| F \<in> stable C; F \<in>  (C \<inter> A) co A |] ==> F \<in> stable (C \<inter> A) *)
lemmas stable_constrains_stable = stable_constrains_Int[THEN stableI]

subsubsection\<open>invariant\<close>

lemma invariantI: "[| Init F \<subseteq> A;  F \<in> stable A |] ==> F \<in> invariant A"
by (simp add: invariant_def)

text\<open>Could also say @{term "invariant A \<inter> invariant B \<subseteq> invariant(A \<inter> B)"}\<close>
lemma invariant_Int:
     "[| F \<in> invariant A;  F \<in> invariant B |] ==> F \<in> invariant (A \<inter> B)"
by (auto simp add: invariant_def stable_Int)

subsubsection\<open>increasing\<close>

lemma increasingD:
     "F \<in> increasing f ==> F \<in> stable {s. z \<subseteq> f s}"
by (unfold increasing_def, blast)

lemma increasing_constant [iff]: "F \<in> increasing (%s. c)"
by (unfold increasing_def stable_def, auto)

lemma mono_increasing_o:
     "mono g ==> increasing f \<subseteq> increasing (g o f)"
apply (unfold increasing_def stable_def constrains_def, auto)
apply (blast intro: monoD order_trans)
done

(*Holds by the theorem (Suc m \<subseteq> n) = (m < n) *)
lemma strict_increasingD:
     "!!z::nat. F \<in> increasing f ==> F \<in> stable {s. z < f s}"
by (simp add: increasing_def Suc_le_eq [symmetric])

(** The Elimination Theorem.  The "free" m has become universally quantified!
    Should the premise be !!m instead of \<forall>m ?  Would make it harder to use
    in forward proof. **)

lemma elimination:
    "[| \<forall>m \<in> M. F \<in> {s. s x = m} co (B m) |]
     ==> F \<in> {s. s x \<in> M} co (\<Union>m \<in> M. B m)"
by (unfold constrains_def, blast)

text\<open>As above, but for the trivial case of a one-variable state, in which the
  state is identified with its one variable.\<close>
lemma elimination_sing:
    "(\<forall>m \<in> M. F \<in> {m} co (B m)) ==> F \<in> M co (\<Union>m \<in> M. B m)"
by (unfold constrains_def, blast)

subsubsection\<open>Theoretical Results from Section 6\<close>

lemma constrains_strongest_rhs:
    "F \<in> A co (strongest_rhs F A )"
by (unfold constrains_def strongest_rhs_def, blast)

lemma strongest_rhs_is_strongest:
    "F \<in> A co B ==> strongest_rhs F A \<subseteq> B"
by (unfold constrains_def strongest_rhs_def, blast)

subsubsection\<open>Ad-hoc set-theory rules\<close>

lemma Un_Diff_Diff [simp]: "A \<union> B - (A - B) = B"
by blast

lemma Int_Union_Union: "\<Union>B \<inter> A = \<Union>((%C. C \<inter> A)`B)"
by blast

text\<open>Needed for WF reasoning in WFair.thy\<close>

lemma Image_less_than [simp]: "less_than `` {k} = greaterThan k"
by blast

lemma Image_inverse_less_than [simp]: "less_than^-1 `` {k} = lessThan k"
by blast

subsection\<open>Partial versus Total Transitions\<close>

definition totalize_act :: "('a * 'a)set => ('a * 'a)set" where
    "totalize_act act == act \<union> Id_on (-(Domain act))"

definition totalize :: "'a program => 'a program" where
    "totalize F == mk_program (Init F,
                               totalize_act ` Acts F,
                               AllowedActs F)"

definition mk_total_program :: "('a set * ('a * 'a)set set * ('a * 'a)set set)
                   => 'a program" where
    "mk_total_program args == totalize (mk_program args)"

definition all_total :: "'a program => bool" where
    "all_total F == \<forall>act \<in> Acts F. Domain act = UNIV"

lemma insert_Id_image_Acts: "f Id = Id ==> insert Id (f`Acts F) = f ` Acts F"
by (blast intro: sym [THEN image_eqI])

subsubsection\<open>Basic properties\<close>

lemma totalize_act_Id [simp]: "totalize_act Id = Id"
by (simp add: totalize_act_def)

lemma Domain_totalize_act [simp]: "Domain (totalize_act act) = UNIV"
by (auto simp add: totalize_act_def)

lemma Init_totalize [simp]: "Init (totalize F) = Init F"
by (unfold totalize_def, auto)

lemma Acts_totalize [simp]: "Acts (totalize F) = (totalize_act ` Acts F)"
by (simp add: totalize_def insert_Id_image_Acts)

lemma AllowedActs_totalize [simp]: "AllowedActs (totalize F) = AllowedActs F"
by (simp add: totalize_def)

lemma totalize_constrains_iff [simp]: "(totalize F \<in> A co B) = (F \<in> A co B)"
by (simp add: totalize_def totalize_act_def constrains_def, blast)

lemma totalize_stable_iff [simp]: "(totalize F \<in> stable A) = (F \<in> stable A)"
by (simp add: stable_def)

lemma totalize_invariant_iff [simp]:
     "(totalize F \<in> invariant A) = (F \<in> invariant A)"
by (simp add: invariant_def)

lemma all_total_totalize: "all_total (totalize F)"
by (simp add: totalize_def all_total_def)

lemma Domain_iff_totalize_act: "(Domain act = UNIV) = (totalize_act act = act)"
by (force simp add: totalize_act_def)

lemma all_total_imp_totalize: "all_total F ==> (totalize F = F)"
apply (simp add: all_total_def totalize_def)
apply (rule program_equalityI)
  apply (simp_all add: Domain_iff_totalize_act image_def)
done

lemma all_total_iff_totalize: "all_total F = (totalize F = F)"
apply (rule iffI)
 apply (erule all_total_imp_totalize)
apply (erule subst)
apply (rule all_total_totalize)
done

lemma mk_total_program_constrains_iff [simp]:
     "(mk_total_program args \<in> A co B) = (mk_program args \<in> A co B)"
by (simp add: mk_total_program_def)

subsection\<open>Rules for Lazy Definition Expansion\<close>

text\<open>They avoid expanding the full program, which is a large expression\<close>

lemma def_prg_Init:
     "F = mk_total_program (init,acts,allowed) ==> Init F = init"
by (simp add: mk_total_program_def)

lemma def_prg_Acts:
     "F = mk_total_program (init,acts,allowed)
      ==> Acts F = insert Id (totalize_act ` acts)"
by (simp add: mk_total_program_def)

lemma def_prg_AllowedActs:
     "F = mk_total_program (init,acts,allowed)
      ==> AllowedActs F = insert Id allowed"
by (simp add: mk_total_program_def)

text\<open>An action is expanded if a pair of states is being tested against it\<close>
lemma def_act_simp:
     "act = {(s,s'). P s s'} ==> ((s,s') \<in> act) = P s s'"
by (simp add: mk_total_program_def)

text\<open>A set is expanded only if an element is being tested against it\<close>
lemma def_set_simp: "A = B ==> (x \<in> A) = (x \<in> B)"
by (simp add: mk_total_program_def)

subsubsection\<open>Inspectors for type "program"\<close>

lemma Init_total_eq [simp]:
     "Init (mk_total_program (init,acts,allowed)) = init"
by (simp add: mk_total_program_def)

lemma Acts_total_eq [simp]:
    "Acts(mk_total_program(init,acts,allowed)) = insert Id (totalize_act`acts)"
by (simp add: mk_total_program_def)

lemma AllowedActs_total_eq [simp]:
     "AllowedActs (mk_total_program (init,acts,allowed)) = insert Id allowed"
by (auto simp add: mk_total_program_def)

end