(*  Title:      HOL/Nonstandard_Analysis/NSCA.thy
    Author:     Jacques D. Fleuriot
    Copyright:  2001, 2002 University of Edinburgh
*)

section\<open>Non-Standard Complex Analysis\<close>

theory NSCA
imports NSComplex HTranscendental
begin

abbreviation
   (* standard complex numbers reagarded as an embedded subset of NS complex *)
   SComplex  :: "hcomplex set" where
   "SComplex \<equiv> Standard"

definition \<comment>\<open>standard part map\<close>
  stc :: "hcomplex => hcomplex" where
  "stc x = (SOME r. x \<in> HFinite & r:SComplex & r \<approx> x)"

subsection\<open>Closure Laws for SComplex, the Standard Complex Numbers\<close>

lemma SComplex_minus_iff [simp]: "(-x \<in> SComplex) = (x \<in> SComplex)"
by (auto, drule Standard_minus, auto)

lemma SComplex_add_cancel:
     "[| x + y \<in> SComplex; y \<in> SComplex |] ==> x \<in> SComplex"
by (drule (1) Standard_diff, simp)

lemma SReal_hcmod_hcomplex_of_complex [simp]:
     "hcmod (hcomplex_of_complex r) \<in> \<real>"
by (simp add: Reals_eq_Standard)

lemma SReal_hcmod_numeral [simp]: "hcmod (numeral w ::hcomplex) \<in> \<real>"
by (simp add: Reals_eq_Standard)

lemma SReal_hcmod_SComplex: "x \<in> SComplex ==> hcmod x \<in> \<real>"
by (simp add: Reals_eq_Standard)

lemma SComplex_divide_numeral:
     "r \<in> SComplex ==> r/(numeral w::hcomplex) \<in> SComplex"
by simp

lemma SComplex_UNIV_complex:
     "{x. hcomplex_of_complex x \<in> SComplex} = (UNIV::complex set)"
by simp

lemma SComplex_iff: "(x \<in> SComplex) = (\<exists>y. x = hcomplex_of_complex y)"
by (simp add: Standard_def image_def)

lemma hcomplex_of_complex_image:
     "hcomplex_of_complex `(UNIV::complex set) = SComplex"
by (simp add: Standard_def)

lemma inv_hcomplex_of_complex_image: "inv hcomplex_of_complex `SComplex = UNIV"
by (auto simp add: Standard_def image_def) (metis inj_star_of inv_f_f)

lemma SComplex_hcomplex_of_complex_image:
      "[| \<exists>x. x: P; P \<le> SComplex |] ==> \<exists>Q. P = hcomplex_of_complex ` Q"
apply (simp add: Standard_def, blast)
done

lemma SComplex_SReal_dense:
     "[| x \<in> SComplex; y \<in> SComplex; hcmod x < hcmod y
      |] ==> \<exists>r \<in> Reals. hcmod x< r & r < hcmod y"
apply (auto intro: SReal_dense simp add: SReal_hcmod_SComplex)
done

subsection\<open>The Finite Elements form a Subring\<close>

lemma HFinite_hcmod_hcomplex_of_complex [simp]:
     "hcmod (hcomplex_of_complex r) \<in> HFinite"
by (auto intro!: SReal_subset_HFinite [THEN subsetD])

lemma HFinite_hcmod_iff: "(x \<in> HFinite) = (hcmod x \<in> HFinite)"
by (simp add: HFinite_def)

lemma HFinite_bounded_hcmod:
  "[|x \<in> HFinite; y \<le> hcmod x; 0 \<le> y |] ==> y: HFinite"
by (auto intro: HFinite_bounded simp add: HFinite_hcmod_iff)

subsection\<open>The Complex Infinitesimals form a Subring\<close>

lemma hcomplex_sum_of_halves: "x/(2::hcomplex) + x/(2::hcomplex) = x"
by auto

lemma Infinitesimal_hcmod_iff:
   "(z \<in> Infinitesimal) = (hcmod z \<in> Infinitesimal)"
by (simp add: Infinitesimal_def)

lemma HInfinite_hcmod_iff: "(z \<in> HInfinite) = (hcmod z \<in> HInfinite)"
by (simp add: HInfinite_def)

lemma HFinite_diff_Infinitesimal_hcmod:
     "x \<in> HFinite - Infinitesimal ==> hcmod x \<in> HFinite - Infinitesimal"
by (simp add: HFinite_hcmod_iff Infinitesimal_hcmod_iff)

lemma hcmod_less_Infinitesimal:
     "[| e \<in> Infinitesimal; hcmod x < hcmod e |] ==> x \<in> Infinitesimal"
by (auto elim: hrabs_less_Infinitesimal simp add: Infinitesimal_hcmod_iff)

lemma hcmod_le_Infinitesimal:
     "[| e \<in> Infinitesimal; hcmod x \<le> hcmod e |] ==> x \<in> Infinitesimal"
by (auto elim: hrabs_le_Infinitesimal simp add: Infinitesimal_hcmod_iff)

lemma Infinitesimal_interval_hcmod:
     "[| e \<in> Infinitesimal;
          e' \<in> Infinitesimal;
          hcmod e' < hcmod x ; hcmod x < hcmod e
       |] ==> x \<in> Infinitesimal"
by (auto intro: Infinitesimal_interval simp add: Infinitesimal_hcmod_iff)

lemma Infinitesimal_interval2_hcmod:
     "[| e \<in> Infinitesimal;
         e' \<in> Infinitesimal;
         hcmod e' \<le> hcmod x ; hcmod x \<le> hcmod e
      |] ==> x \<in> Infinitesimal"
by (auto intro: Infinitesimal_interval2 simp add: Infinitesimal_hcmod_iff)

subsection\<open>The ``Infinitely Close'' Relation\<close>

(*
Goalw [capprox_def,approx_def] "(z @c= w) = (hcmod z \<approx> hcmod w)"
by (auto_tac (claset(),simpset() addsimps [Infinitesimal_hcmod_iff]));
*)

lemma approx_SComplex_mult_cancel_zero:
     "[| a \<in> SComplex; a \<noteq> 0; a*x \<approx> 0 |] ==> x \<approx> 0"
apply (drule Standard_inverse [THEN Standard_subset_HFinite [THEN subsetD]])
apply (auto dest: approx_mult2 simp add: mult.assoc [symmetric])
done

lemma approx_mult_SComplex1: "[| a \<in> SComplex; x \<approx> 0 |] ==> x*a \<approx> 0"
by (auto dest: Standard_subset_HFinite [THEN subsetD] approx_mult1)

lemma approx_mult_SComplex2: "[| a \<in> SComplex; x \<approx> 0 |] ==> a*x \<approx> 0"
by (auto dest: Standard_subset_HFinite [THEN subsetD] approx_mult2)

lemma approx_mult_SComplex_zero_cancel_iff [simp]:
     "[|a \<in> SComplex; a \<noteq> 0 |] ==> (a*x \<approx> 0) = (x \<approx> 0)"
by (blast intro: approx_SComplex_mult_cancel_zero approx_mult_SComplex2)

lemma approx_SComplex_mult_cancel:
     "[| a \<in> SComplex; a \<noteq> 0; a* w \<approx> a*z |] ==> w \<approx> z"
apply (drule Standard_inverse [THEN Standard_subset_HFinite [THEN subsetD]])
apply (auto dest: approx_mult2 simp add: mult.assoc [symmetric])
done

lemma approx_SComplex_mult_cancel_iff1 [simp]:
     "[| a \<in> SComplex; a \<noteq> 0|] ==> (a* w \<approx> a*z) = (w \<approx> z)"
by (auto intro!: approx_mult2 Standard_subset_HFinite [THEN subsetD]
            intro: approx_SComplex_mult_cancel)

(* TODO: generalize following theorems: hcmod -> hnorm *)

lemma approx_hcmod_approx_zero: "(x \<approx> y) = (hcmod (y - x) \<approx> 0)"
apply (subst hnorm_minus_commute)
apply (simp add: approx_def Infinitesimal_hcmod_iff)
done

lemma approx_approx_zero_iff: "(x \<approx> 0) = (hcmod x \<approx> 0)"
by (simp add: approx_hcmod_approx_zero)

lemma approx_minus_zero_cancel_iff [simp]: "(-x \<approx> 0) = (x \<approx> 0)"
by (simp add: approx_def)

lemma Infinitesimal_hcmod_add_diff:
     "u \<approx> 0 ==> hcmod(x + u) - hcmod x \<in> Infinitesimal"
apply (drule approx_approx_zero_iff [THEN iffD1])
apply (rule_tac e = "hcmod u" and e' = "- hcmod u" in Infinitesimal_interval2)
apply (auto simp add: mem_infmal_iff [symmetric])
apply (rule_tac c1 = "hcmod x" in add_le_cancel_left [THEN iffD1])
apply auto
done

lemma approx_hcmod_add_hcmod: "u \<approx> 0 ==> hcmod(x + u) \<approx> hcmod x"
apply (rule approx_minus_iff [THEN iffD2])
apply (auto intro: Infinitesimal_hcmod_add_diff simp add: mem_infmal_iff [symmetric])
done

subsection\<open>Zero is the Only Infinitesimal Complex Number\<close>

lemma Infinitesimal_less_SComplex:
   "[| x \<in> SComplex; y \<in> Infinitesimal; 0 < hcmod x |] ==> hcmod y < hcmod x"
by (auto intro: Infinitesimal_less_SReal SReal_hcmod_SComplex simp add: Infinitesimal_hcmod_iff)

lemma SComplex_Int_Infinitesimal_zero: "SComplex Int Infinitesimal = {0}"
by (auto simp add: Standard_def Infinitesimal_hcmod_iff)

lemma SComplex_Infinitesimal_zero:
     "[| x \<in> SComplex; x \<in> Infinitesimal|] ==> x = 0"
by (cut_tac SComplex_Int_Infinitesimal_zero, blast)

lemma SComplex_HFinite_diff_Infinitesimal:
     "[| x \<in> SComplex; x \<noteq> 0 |] ==> x \<in> HFinite - Infinitesimal"
by (auto dest: SComplex_Infinitesimal_zero Standard_subset_HFinite [THEN subsetD])

lemma hcomplex_of_complex_HFinite_diff_Infinitesimal:
     "hcomplex_of_complex x \<noteq> 0
      ==> hcomplex_of_complex x \<in> HFinite - Infinitesimal"
by (rule SComplex_HFinite_diff_Infinitesimal, auto)

lemma numeral_not_Infinitesimal [simp]:
     "numeral w \<noteq> (0::hcomplex) ==> (numeral w::hcomplex) \<notin> Infinitesimal"
by (fast dest: Standard_numeral [THEN SComplex_Infinitesimal_zero])

lemma approx_SComplex_not_zero:
     "[| y \<in> SComplex; x \<approx> y; y\<noteq> 0 |] ==> x \<noteq> 0"
by (auto dest: SComplex_Infinitesimal_zero approx_sym [THEN mem_infmal_iff [THEN iffD2]])

lemma SComplex_approx_iff:
     "[|x \<in> SComplex; y \<in> SComplex|] ==> (x \<approx> y) = (x = y)"
by (auto simp add: Standard_def)

lemma numeral_Infinitesimal_iff [simp]:
     "((numeral w :: hcomplex) \<in> Infinitesimal) =
      (numeral w = (0::hcomplex))"
apply (rule iffI)
apply (fast dest: Standard_numeral [THEN SComplex_Infinitesimal_zero])
apply (simp (no_asm_simp))
done

lemma approx_unique_complex:
     "[| r \<in> SComplex; s \<in> SComplex; r \<approx> x; s \<approx> x|] ==> r = s"
by (blast intro: SComplex_approx_iff [THEN iffD1] approx_trans2)

subsection \<open>Properties of @{term hRe}, @{term hIm} and @{term HComplex}\<close>

lemma abs_hRe_le_hcmod: "\<And>x. \<bar>hRe x\<bar> \<le> hcmod x"
by transfer (rule abs_Re_le_cmod)

lemma abs_hIm_le_hcmod: "\<And>x. \<bar>hIm x\<bar> \<le> hcmod x"
by transfer (rule abs_Im_le_cmod)

lemma Infinitesimal_hRe: "x \<in> Infinitesimal \<Longrightarrow> hRe x \<in> Infinitesimal"
apply (rule InfinitesimalI2, simp)
apply (rule order_le_less_trans [OF abs_hRe_le_hcmod])
apply (erule (1) InfinitesimalD2)
done

lemma Infinitesimal_hIm: "x \<in> Infinitesimal \<Longrightarrow> hIm x \<in> Infinitesimal"
apply (rule InfinitesimalI2, simp)
apply (rule order_le_less_trans [OF abs_hIm_le_hcmod])
apply (erule (1) InfinitesimalD2)
done

lemma real_sqrt_lessI: "\<lbrakk>0 < u; x < u\<^sup>2\<rbrakk> \<Longrightarrow> sqrt x < u"
(* TODO: this belongs somewhere else *)
by (frule real_sqrt_less_mono) simp

lemma hypreal_sqrt_lessI:
  "\<And>x u. \<lbrakk>0 < u; x < u\<^sup>2\<rbrakk> \<Longrightarrow> ( *f* sqrt) x < u"
by transfer (rule real_sqrt_lessI)

lemma hypreal_sqrt_ge_zero: "\<And>x. 0 \<le> x \<Longrightarrow> 0 \<le> ( *f* sqrt) x"
by transfer (rule real_sqrt_ge_zero)

lemma Infinitesimal_sqrt:
  "\<lbrakk>x \<in> Infinitesimal; 0 \<le> x\<rbrakk> \<Longrightarrow> ( *f* sqrt) x \<in> Infinitesimal"
apply (rule InfinitesimalI2)
apply (drule_tac r="r\<^sup>2" in InfinitesimalD2, simp)
apply (simp add: hypreal_sqrt_ge_zero)
apply (rule hypreal_sqrt_lessI, simp_all)
done

lemma Infinitesimal_HComplex:
  "\<lbrakk>x \<in> Infinitesimal; y \<in> Infinitesimal\<rbrakk> \<Longrightarrow> HComplex x y \<in> Infinitesimal"
apply (rule Infinitesimal_hcmod_iff [THEN iffD2])
apply (simp add: hcmod_i)
apply (rule Infinitesimal_add)
apply (erule Infinitesimal_hrealpow, simp)
apply (erule Infinitesimal_hrealpow, simp)
done

lemma hcomplex_Infinitesimal_iff:
  "(x \<in> Infinitesimal) = (hRe x \<in> Infinitesimal \<and> hIm x \<in> Infinitesimal)"
apply (safe intro!: Infinitesimal_hRe Infinitesimal_hIm)
apply (drule (1) Infinitesimal_HComplex, simp)
done

lemma hRe_diff [simp]: "\<And>x y. hRe (x - y) = hRe x - hRe y"
by transfer simp

lemma hIm_diff [simp]: "\<And>x y. hIm (x - y) = hIm x - hIm y"
by transfer simp

lemma approx_hRe: "x \<approx> y \<Longrightarrow> hRe x \<approx> hRe y"
unfolding approx_def by (drule Infinitesimal_hRe) simp

lemma approx_hIm: "x \<approx> y \<Longrightarrow> hIm x \<approx> hIm y"
unfolding approx_def by (drule Infinitesimal_hIm) simp

lemma approx_HComplex:
  "\<lbrakk>a \<approx> b; c \<approx> d\<rbrakk> \<Longrightarrow> HComplex a c \<approx> HComplex b d"
unfolding approx_def by (simp add: Infinitesimal_HComplex)

lemma hcomplex_approx_iff:
  "(x \<approx> y) = (hRe x \<approx> hRe y \<and> hIm x \<approx> hIm y)"
unfolding approx_def by (simp add: hcomplex_Infinitesimal_iff)

lemma HFinite_hRe: "x \<in> HFinite \<Longrightarrow> hRe x \<in> HFinite"
apply (auto simp add: HFinite_def SReal_def)
apply (rule_tac x="star_of r" in exI, simp)
apply (erule order_le_less_trans [OF abs_hRe_le_hcmod])
done

lemma HFinite_hIm: "x \<in> HFinite \<Longrightarrow> hIm x \<in> HFinite"
apply (auto simp add: HFinite_def SReal_def)
apply (rule_tac x="star_of r" in exI, simp)
apply (erule order_le_less_trans [OF abs_hIm_le_hcmod])
done

lemma HFinite_HComplex:
  "\<lbrakk>x \<in> HFinite; y \<in> HFinite\<rbrakk> \<Longrightarrow> HComplex x y \<in> HFinite"
apply (subgoal_tac "HComplex x 0 + HComplex 0 y \<in> HFinite", simp)
apply (rule HFinite_add)
apply (simp add: HFinite_hcmod_iff hcmod_i)
apply (simp add: HFinite_hcmod_iff hcmod_i)
done

lemma hcomplex_HFinite_iff:
  "(x \<in> HFinite) = (hRe x \<in> HFinite \<and> hIm x \<in> HFinite)"
apply (safe intro!: HFinite_hRe HFinite_hIm)
apply (drule (1) HFinite_HComplex, simp)
done

lemma hcomplex_HInfinite_iff:
  "(x \<in> HInfinite) = (hRe x \<in> HInfinite \<or> hIm x \<in> HInfinite)"
by (simp add: HInfinite_HFinite_iff hcomplex_HFinite_iff)

lemma hcomplex_of_hypreal_approx_iff [simp]:
     "(hcomplex_of_hypreal x \<approx> hcomplex_of_hypreal z) = (x \<approx> z)"
by (simp add: hcomplex_approx_iff)

lemma Standard_HComplex:
  "\<lbrakk>x \<in> Standard; y \<in> Standard\<rbrakk> \<Longrightarrow> HComplex x y \<in> Standard"
by (simp add: HComplex_def)

(* Here we go - easy proof now!! *)
lemma stc_part_Ex: "x:HFinite ==> \<exists>t \<in> SComplex. x \<approx> t"
apply (simp add: hcomplex_HFinite_iff hcomplex_approx_iff)
apply (rule_tac x="HComplex (st (hRe x)) (st (hIm x))" in bexI)
apply (simp add: st_approx_self [THEN approx_sym])
apply (simp add: Standard_HComplex st_SReal [unfolded Reals_eq_Standard])
done

lemma stc_part_Ex1: "x:HFinite ==> \<exists>!t. t \<in> SComplex &  x \<approx> t"
apply (drule stc_part_Ex, safe)
apply (drule_tac [2] approx_sym, drule_tac [2] approx_sym, drule_tac [2] approx_sym)
apply (auto intro!: approx_unique_complex)
done

lemmas hcomplex_of_complex_approx_inverse =
  hcomplex_of_complex_HFinite_diff_Infinitesimal [THEN [2] approx_inverse]

subsection\<open>Theorems About Monads\<close>

lemma monad_zero_hcmod_iff: "(x \<in> monad 0) = (hcmod x:monad 0)"
by (simp add: Infinitesimal_monad_zero_iff [symmetric] Infinitesimal_hcmod_iff)

subsection\<open>Theorems About Standard Part\<close>

lemma stc_approx_self: "x \<in> HFinite ==> stc x \<approx> x"
apply (simp add: stc_def)
apply (frule stc_part_Ex, safe)
apply (rule someI2)
apply (auto intro: approx_sym)
done

lemma stc_SComplex: "x \<in> HFinite ==> stc x \<in> SComplex"
apply (simp add: stc_def)
apply (frule stc_part_Ex, safe)
apply (rule someI2)
apply (auto intro: approx_sym)
done

lemma stc_HFinite: "x \<in> HFinite ==> stc x \<in> HFinite"
by (erule stc_SComplex [THEN Standard_subset_HFinite [THEN subsetD]])

lemma stc_unique: "\<lbrakk>y \<in> SComplex; y \<approx> x\<rbrakk> \<Longrightarrow> stc x = y"
apply (frule Standard_subset_HFinite [THEN subsetD])
apply (drule (1) approx_HFinite)
apply (unfold stc_def)
apply (rule some_equality)
apply (auto intro: approx_unique_complex)
done

lemma stc_SComplex_eq [simp]: "x \<in> SComplex ==> stc x = x"
apply (erule stc_unique)
apply (rule approx_refl)
done

lemma stc_hcomplex_of_complex:
     "stc (hcomplex_of_complex x) = hcomplex_of_complex x"
by auto

lemma stc_eq_approx:
     "[| x \<in> HFinite; y \<in> HFinite; stc x = stc y |] ==> x \<approx> y"
by (auto dest!: stc_approx_self elim!: approx_trans3)

lemma approx_stc_eq:
     "[| x \<in> HFinite; y \<in> HFinite; x \<approx> y |] ==> stc x = stc y"
by (blast intro: approx_trans approx_trans2 SComplex_approx_iff [THEN iffD1]
          dest: stc_approx_self stc_SComplex)

lemma stc_eq_approx_iff:
     "[| x \<in> HFinite; y \<in> HFinite|] ==> (x \<approx> y) = (stc x = stc y)"
by (blast intro: approx_stc_eq stc_eq_approx)

lemma stc_Infinitesimal_add_SComplex:
     "[| x \<in> SComplex; e \<in> Infinitesimal |] ==> stc(x + e) = x"
apply (erule stc_unique)
apply (erule Infinitesimal_add_approx_self)
done

lemma stc_Infinitesimal_add_SComplex2:
     "[| x \<in> SComplex; e \<in> Infinitesimal |] ==> stc(e + x) = x"
apply (erule stc_unique)
apply (erule Infinitesimal_add_approx_self2)
done

lemma HFinite_stc_Infinitesimal_add:
     "x \<in> HFinite ==> \<exists>e \<in> Infinitesimal. x = stc(x) + e"
by (blast dest!: stc_approx_self [THEN approx_sym] bex_Infinitesimal_iff2 [THEN iffD2])

lemma stc_add:
     "[| x \<in> HFinite; y \<in> HFinite |] ==> stc (x + y) = stc(x) + stc(y)"
by (simp add: stc_unique stc_SComplex stc_approx_self approx_add)

lemma stc_numeral [simp]: "stc (numeral w) = numeral w"
by (rule Standard_numeral [THEN stc_SComplex_eq])

lemma stc_zero [simp]: "stc 0 = 0"
by simp

lemma stc_one [simp]: "stc 1 = 1"
by simp

lemma stc_minus: "y \<in> HFinite ==> stc(-y) = -stc(y)"
by (simp add: stc_unique stc_SComplex stc_approx_self approx_minus)

lemma stc_diff:
     "[| x \<in> HFinite; y \<in> HFinite |] ==> stc (x-y) = stc(x) - stc(y)"
by (simp add: stc_unique stc_SComplex stc_approx_self approx_diff)

lemma stc_mult:
     "[| x \<in> HFinite; y \<in> HFinite |]
               ==> stc (x * y) = stc(x) * stc(y)"
by (simp add: stc_unique stc_SComplex stc_approx_self approx_mult_HFinite)

lemma stc_Infinitesimal: "x \<in> Infinitesimal ==> stc x = 0"
by (simp add: stc_unique mem_infmal_iff)

lemma stc_not_Infinitesimal: "stc(x) \<noteq> 0 ==> x \<notin> Infinitesimal"
by (fast intro: stc_Infinitesimal)

lemma stc_inverse:
     "[| x \<in> HFinite; stc x \<noteq> 0 |]
      ==> stc(inverse x) = inverse (stc x)"
apply (drule stc_not_Infinitesimal)
apply (simp add: stc_unique stc_SComplex stc_approx_self approx_inverse)
done

lemma stc_divide [simp]:
     "[| x \<in> HFinite; y \<in> HFinite; stc y \<noteq> 0 |]
      ==> stc(x/y) = (stc x) / (stc y)"
by (simp add: divide_inverse stc_mult stc_not_Infinitesimal HFinite_inverse stc_inverse)

lemma stc_idempotent [simp]: "x \<in> HFinite ==> stc(stc(x)) = stc(x)"
by (blast intro: stc_HFinite stc_approx_self approx_stc_eq)

lemma HFinite_HFinite_hcomplex_of_hypreal:
     "z \<in> HFinite ==> hcomplex_of_hypreal z \<in> HFinite"
by (simp add: hcomplex_HFinite_iff)

lemma SComplex_SReal_hcomplex_of_hypreal:
     "x \<in> \<real> ==>  hcomplex_of_hypreal x \<in> SComplex"
apply (rule Standard_of_hypreal)
apply (simp add: Reals_eq_Standard)
done

lemma stc_hcomplex_of_hypreal:
 "z \<in> HFinite ==> stc(hcomplex_of_hypreal z) = hcomplex_of_hypreal (st z)"
apply (rule stc_unique)
apply (rule SComplex_SReal_hcomplex_of_hypreal)
apply (erule st_SReal)
apply (simp add: hcomplex_of_hypreal_approx_iff st_approx_self)
done

(*
Goal "x \<in> HFinite ==> hcmod(stc x) = st(hcmod x)"
by (dtac stc_approx_self 1)
by (auto_tac (claset(),simpset() addsimps [bex_Infinitesimal_iff2 RS sym]));

approx_hcmod_add_hcmod
*)

lemma Infinitesimal_hcnj_iff [simp]:
     "(hcnj z \<in> Infinitesimal) = (z \<in> Infinitesimal)"
by (simp add: Infinitesimal_hcmod_iff)

lemma Infinitesimal_hcomplex_of_hypreal_epsilon [simp]:
     "hcomplex_of_hypreal \<epsilon> \<in> Infinitesimal"
by (simp add: Infinitesimal_hcmod_iff)

end


theory v3_isar_T
  imports Main  "../../QML"
begin

text \<open>
@{text "Compossibility\<^sub>3'"}: If a table @{term x} is originally made from matter @{term y} and it
is possible for a table to be the only table  originally made from matter @{term z} according to plan @{term p},
then it is also possible for table @{term x} to be originally made from matter @{term y} and in
addition some table or other @{term x'} to be the only table  originally made from matter @{term z}
according to plan @{term p}.

@{text "Origin Uniqueness\<^sub>1'"}: It is impossible that a single table @{term x} is originally made from
matter @{term y} and in addition is originally made from matter @{term z}.

@{text "Sufficiency\<^sub>3'"}: If it is possible that a table @{term x'} is the only table originally made from matter @{term z}
according to plan @{term p}, then necessarily any table that is the only table originally made from matter @{term z}
according to plan @{term p} is the very table @{term x'} and no other.
\<close>

text \<open>
@{text "Origin Essentialism\<^sub>3'"}: If a given table is originally made from certain matter, then it is necessary
that the given table is not the only table  originally made from any non-overlapping matter according to any plan.
\<close>

consts planTable :: "\<mu> \<Rightarrow> \<mu> \<Rightarrow> \<mu> \<Rightarrow> \<sigma>" ("P")
(* (P x y p) \<equiv> x made from y according to p *)
axiomatization where refl :"(\<forall>x. x r x)"

lemma
assumes compossibilty3: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. ((P x y p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. P t z p \<^bold>\<and> (\<^bold>\<forall>t'.(\<^bold>\<not>(t \<^bold>=\<^sup>L t') \<^bold>\<rightarrow> \<^bold>\<not>(P t' z p))))) \<^bold>\<rightarrow> \<^bold>\<diamond>((P x y p) \<^bold>\<and> (\<^bold>\<exists>x'. P x' z p \<^bold>\<and> (\<^bold>\<forall>x''.(\<^bold>\<not>(x' \<^bold>=\<^sup>L x'') \<^bold>\<rightarrow> \<^bold>\<not>(P x'' z p))))))\<rfloor>"
assumes sufficiency3: "\<lfloor>(\<^bold>\<forall>y. \<^bold>\<forall>x'. \<^bold>\<forall>p. \<^bold>\<diamond>(P x' y p \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x' \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t y p)))) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x. (P x y p \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t y p)))) \<^bold>\<rightarrow> (x\<^bold>=\<^sup>Lx')))\<rfloor>"
assumes origin_uniqueness3: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<not>(\<^bold>\<diamond>((P x y p) \<^bold>\<and> (P x z p) \<^bold>\<and> \<^bold>\<not>(y\<^bold>=\<^sup>L z))))\<rfloor>"
shows origin_essentialism3: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. (\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (P x y p)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p' \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p'))))))\<rfloor>"

proof (rule allI)
  fix w
  show "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. (\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (P x y p)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p' \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p')))))) w"
  proof (rule allI)
    fix x
    show "(\<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. (\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (P x y p)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p' \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p')))))) w"
    proof (rule allI)
      fix y
      show "(\<^bold>\<forall>z. \<^bold>\<forall>p. (\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (P x y p)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p' \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p')))))) w"
      proof  (rule allI)
        fix z
        show "(\<^bold>\<forall>p. (\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (P x y p)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p' \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p')))))) w"
        proof (rule allI)
          fix p
          show "((\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (P x y p)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p' \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p')))))) w"
          proof  (rule impI)
            assume antecedent: "((\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (P x y p))) w"
            show  "(\<^bold>\<not>(\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p' \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p')))))) w"
            proof  (rule notI)
              assume n_consequent: "(\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p' \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p'))))) w"

              from antecedent have "((\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (P x y p))) w" by simp
              then have non_overlapping: "(\<^bold>\<not>(y \<^bold>=\<^sup>L z)) w" by (rule conjE)
              have table_x_from_y: "(P x y p) w" using `((\<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> (P x y p))) w` by (rule conjE)

              from n_consequent have "(\<^bold>\<diamond>(\<^bold>\<forall>p'. P x z p' \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p'))))) w" by simp
              then obtain v where v: "(w r v) \<and> (((\<^bold>\<forall>p'. P x z p' \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p'))))) v)" by (rule exE)
              then have "w r v" by  (rule conjE)
              have  "((\<^bold>\<forall>p'. P x z p' \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p'))))) v"
                using `(w r v) \<and> (((\<^bold>\<forall>p'. P x z p' \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p'))))) v)` by (rule conjE)
              then have "((P x z p \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p))))) v" by (rule allE)
              then have possibility: "(\<^bold>\<diamond>(P x z p \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p))))) w"
                using `w r v`by auto

              have compossibilty3_ante: "((P x y p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. P t z p \<^bold>\<and> (\<^bold>\<forall>t'.(\<^bold>\<not>(t \<^bold>=\<^sup>L t') \<^bold>\<rightarrow> \<^bold>\<not>(P t' z p))))) w"
                using non_overlapping and table_x_from_y and possibility by auto

              from compossibilty3 have "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. ((P x y p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. P t z p \<^bold>\<and> (\<^bold>\<forall>t'.(\<^bold>\<not>(t \<^bold>=\<^sup>L t') \<^bold>\<rightarrow> \<^bold>\<not>(P t' z p))))) \<^bold>\<rightarrow> \<^bold>\<diamond>((P x y p) \<^bold>\<and> (\<^bold>\<exists>x'. P x' z p \<^bold>\<and> (\<^bold>\<forall>x''.(\<^bold>\<not>(x' \<^bold>=\<^sup>L x'') \<^bold>\<rightarrow> \<^bold>\<not>(P x'' z p)))))) w"..
              then have "(\<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. ((P x y p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. P t z p \<^bold>\<and> (\<^bold>\<forall>t'.(\<^bold>\<not>(t \<^bold>=\<^sup>L t') \<^bold>\<rightarrow> \<^bold>\<not>(P t' z p))))) \<^bold>\<rightarrow> \<^bold>\<diamond>((P x y p) \<^bold>\<and> (\<^bold>\<exists>x'. P x' z p \<^bold>\<and> (\<^bold>\<forall>x''.(\<^bold>\<not>(x' \<^bold>=\<^sup>L x'') \<^bold>\<rightarrow> \<^bold>\<not>(P x'' z p)))))) w" by (rule allE)
              then have "(\<^bold>\<forall>z. \<^bold>\<forall>p. ((P x y p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. P t z p \<^bold>\<and> (\<^bold>\<forall>t'.(\<^bold>\<not>(t \<^bold>=\<^sup>L t') \<^bold>\<rightarrow> \<^bold>\<not>(P t' z p))))) \<^bold>\<rightarrow> \<^bold>\<diamond>((P x y p) \<^bold>\<and> (\<^bold>\<exists>x'. P x' z p \<^bold>\<and> (\<^bold>\<forall>x''.(\<^bold>\<not>(x' \<^bold>=\<^sup>L x'') \<^bold>\<rightarrow> \<^bold>\<not>(P x'' z p)))))) w" by (rule allE)
              then have "(\<^bold>\<forall>p. ((P x y p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. P t z p \<^bold>\<and> (\<^bold>\<forall>t'.(\<^bold>\<not>(t \<^bold>=\<^sup>L t') \<^bold>\<rightarrow> \<^bold>\<not>(P t' z p))))) \<^bold>\<rightarrow> \<^bold>\<diamond>((P x y p) \<^bold>\<and> (\<^bold>\<exists>x'. P x' z p \<^bold>\<and> (\<^bold>\<forall>x''.(\<^bold>\<not>(x' \<^bold>=\<^sup>L x'') \<^bold>\<rightarrow> \<^bold>\<not>(P x'' z p)))))) w" by (rule allE)
              then have "(((P x y p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. P t z p \<^bold>\<and> (\<^bold>\<forall>t'.(\<^bold>\<not>(t \<^bold>=\<^sup>L t') \<^bold>\<rightarrow> \<^bold>\<not>(P t' z p))))) \<^bold>\<rightarrow> \<^bold>\<diamond>((P x y p) \<^bold>\<and> (\<^bold>\<exists>x'. P x' z p \<^bold>\<and> (\<^bold>\<forall>x''.(\<^bold>\<not>(x' \<^bold>=\<^sup>L x'') \<^bold>\<rightarrow> \<^bold>\<not>(P x'' z p)))))) w" by (rule allE)

              then have "(\<^bold>\<diamond>((P x y p) \<^bold>\<and> (\<^bold>\<exists>x'. P x' z p \<^bold>\<and> (\<^bold>\<forall>x''.(\<^bold>\<not>(x' \<^bold>=\<^sup>L x'') \<^bold>\<rightarrow> \<^bold>\<not>(P x'' z p)))))) w"
                using compossibilty3_ante by (rule mp)
              then obtain u where u: "(w r u) \<and> ((((P x y p) \<^bold>\<and> (\<^bold>\<exists>x'. P x' z p \<^bold>\<and> (\<^bold>\<forall>x''.(\<^bold>\<not>(x' \<^bold>=\<^sup>L x'') \<^bold>\<rightarrow> \<^bold>\<not>(P x'' z p)))))) u)" by (rule exE)
              then  have "((((P x y p) \<^bold>\<and> (\<^bold>\<exists>x'. P x' z p \<^bold>\<and> (\<^bold>\<forall>x''.(\<^bold>\<not>(x' \<^bold>=\<^sup>L x'') \<^bold>\<rightarrow> \<^bold>\<not>(P x'' z p)))))) u)" by (rule conjE)
              then have "(\<^bold>\<exists>x'. P x' z p \<^bold>\<and> (\<^bold>\<forall>x''.(\<^bold>\<not>(x' \<^bold>=\<^sup>L x'') \<^bold>\<rightarrow> \<^bold>\<not>(P x'' z p)))) u" by (rule conjE)
              then obtain x' where x': "((P x' z p) \<^bold>\<and> (\<^bold>\<forall>x''.(\<^bold>\<not>(x' \<^bold>=\<^sup>L x'') \<^bold>\<rightarrow> \<^bold>\<not>(P x'' z p)))) u" by (rule exE)
              then have sufficiency3_cons_ante: "((P x' z p) \<^bold>\<and> (\<^bold>\<forall>x''.(\<^bold>\<not>(x' \<^bold>=\<^sup>L x'') \<^bold>\<rightarrow> \<^bold>\<not>(P x'' z p)))) u" by simp

              have "(w r u)"
                using `(w r u) \<and> ((((P x y p) \<^bold>\<and> (\<^bold>\<exists>x'. P x' z p \<^bold>\<and> (\<^bold>\<forall>x''.(\<^bold>\<not>(x' \<^bold>=\<^sup>L x'') \<^bold>\<rightarrow> \<^bold>\<not>(P x'' z p)))))) u)` by (rule conjE)

              from sufficiency3 have "(\<^bold>\<forall>z. \<^bold>\<forall>x. \<^bold>\<forall>p. \<^bold>\<diamond>(P x z p \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p)))) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (P x' z p \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x' \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p)))) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx))) w"..
              then have "(\<^bold>\<forall>x. \<^bold>\<forall>p. \<^bold>\<diamond>(P x z p \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p)))) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (P x' z p \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x' \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p)))) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx))) w" by (rule allE)
              then have "(\<^bold>\<forall>p. \<^bold>\<diamond>(P x z p \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p)))) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (P x' z p \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x' \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p)))) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx))) w" by (rule allE)
              then have "(\<^bold>\<diamond>(P x z p \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p)))) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x'. (P x' z p \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x' \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p)))) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx))) w" by (rule allE)
              then have "(\<^bold>\<box>(\<^bold>\<forall>x'. (P x' z p \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x' \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p)))) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx))) w"
                using possibility by auto
              then have "((P x' z p \<^bold>\<and> (\<^bold>\<forall>t.(\<^bold>\<not>(x' \<^bold>=\<^sup>L t) \<^bold>\<rightarrow> \<^bold>\<not>(P t z p)))) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx)) u"
                using `w r u` by auto
              then have identity: "(x'\<^bold>=\<^sup>Lx) u" using sufficiency3_cons_ante by (rule mp)

              from sufficiency3_cons_ante have "(P x' z p) u" by auto
              then have "(P x z p) u" using identity by auto
              moreover from u have "(P x y p) u" by auto
              then have conj_existence: "(P x y p \<^bold>\<and> P x z p) u" using `(P x z p) u` by simp
              then have impossible_arg: "(P x y p u) \<and> (P x z p u) \<and> \<not>((y \<^bold>=\<^sup>L z) u)"
                using non_overlapping by auto

              from origin_uniqueness3 have "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<not>(\<^bold>\<diamond>((P x y p) \<^bold>\<and> (P x z p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z)))) u"..
               then have "(\<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<forall>p.\<^bold>\<not>(\<^bold>\<diamond>((P x y p) \<^bold>\<and> (P x z p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z)))) u" by (rule allE)
               then have "(\<^bold>\<forall>z. \<^bold>\<forall>p. \<^bold>\<not>(\<^bold>\<diamond>((P x y p) \<^bold>\<and> (P x z p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z)))) u" by (rule allE)
               then have "(\<^bold>\<forall>p. \<^bold>\<not>(\<^bold>\<diamond>((P x y p) \<^bold>\<and> (P x z p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z)))) u" by (rule allE)
               then have "(\<^bold>\<not>(\<^bold>\<diamond>((P x y p) \<^bold>\<and> (P x z p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z)))) u" by (rule allE)
               then have "(\<^bold>\<box>(\<^bold>\<not>((P x y p) \<^bold>\<and> (P x z p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z)))) u" by auto
               then have "(\<^bold>\<not>((P x y p) \<^bold>\<and> (P x z p) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) u" using refl by blast
               then have "\<not>((P x y p u) \<and> (P x z p u) \<and> \<not>((y \<^bold>=\<^sup>L z) u))" by simp
               then show "False" using impossible_arg by (rule notE)

             qed
           qed
         qed
       qed
     qed
   qed
 qed

end


theory SimpleMonitorExample

imports FaultModelling FaultTree

begin

datatype FMode = Omission ("O\<^sub>M") | Commission ("C\<^sub>O\<^sub>m")

datatype FailureVarName =
  FB1 ("F\<^sub>B\<^sub>1" 50)
  | FB2 ("F\<^sub>B\<^sub>2" 50)
  | FMon ("F\<^sub>M\<^sub>o\<^sub>n" 50)

datatype ComponentPortName =
  OutB1 ("out\<^sub>B\<^sub>1")
  | OutB2 ("out\<^sub>B\<^sub>2")
  | In1Mon ("in\<^sub>M\<^sub>o\<^sub>n\<^sub>1")
  | In2Mon ("in\<^sub>M\<^sub>o\<^sub>n\<^sub>2")
  | OutMon ("out\<^sub>M\<^sub>o\<^sub>n")

type_synonym SMComponent =
"(FailureVarName, FMode, ComponentPortName, ComponentPortName) Component"

type_synonym SMValue = "(FMode, ComponentPortName) OperationalMode"

type_synonym SMConditionalMode = "(FailureVarName, FMode, ComponentPortName) ConditionalMode"

definition Battery :: "ComponentPortName \<Rightarrow> FailureVarName \<Rightarrow> SMComponent" where
  "Battery OutP FB \<equiv> \<lambda> m.
  [
    OutP \<mapsto> CVIF FB (CVC (FailureMode Omission)) (CVC (NominalMode 5))
  ]"

definition Monitor :: "(SMValue \<Rightarrow> bool) \<Rightarrow> SMComponent" where
  "Monitor P \<equiv> \<lambda> m .
  [
    OutMon \<mapsto>
      CVIF FMon
        (ConditionalValuePredicate P (m In1Mon) (m In1Mon) (m In2Mon))
        (ConditionalValuePredicate P (m In1Mon) (m In2Mon) (m In1Mon))
  ]"

definition SMon_A :: "(ComponentPortName, ComponentPortName) Connections"
where
  "SMon_A \<equiv> [ In1Mon \<mapsto> OutB1, In2Mon \<mapsto> OutB2 ] "

definition SMon_Cs :: "SMComponent list"
where
  "SMon_Cs \<equiv>
  [
    Battery OutB1 FB1,
    Battery OutB2 FB2,
    Monitor (\<lambda> b . (eq_Values (FailureMode Omission) b) \<or> (gt_Values (NominalMode 2) b))
  ]"

definition SMon :: "SMComponent"
where
  "SMon \<equiv> System SMon_A SMon_Cs"

definition SMon_OutMon :: "SMConditionalMode"
where
  "SMon_OutMon \<equiv> the (SMon (\<lambda> x. CVC (VarMode x)) OutMon)"

lemma "equiv_test
  (CVP2BE
    (\<lambda> b . b = (FailureMode Omission))
    (the ((Battery OutB1 FB1) (\<lambda> x. CVC (VarMode x)) OutB1)))
  (Atom_bool_expr FB1)"
apply (auto simp add: Battery_def equiv_test)
done

corollary "equiv_test
    (CVP2BE (\<lambda> b . b = (FailureMode Omission)) SMon_OutMon)
    (Or_bool_expr
      (And_bool_expr (Atom_bool_expr FB1) (Atom_bool_expr FB2))
      (And_bool_expr
        (Atom_bool_expr FMon)
        (Or_bool_expr (Atom_bool_expr FB1) (Atom_bool_expr FB2))))"
apply (simp add: SMon_OutMon_def SMon_def SMon_Cs_def SMon_A_def Battery_def Monitor_def)
apply (simp add: System_def SystemComponents_def SystemPortValuation_def )
apply (simp add: fun_upd_fun_def)
apply (simp add: lt_Values_def)
apply (auto simp add: equiv_test)
done

corollary "equiv_test
    (CVP2BE (\<lambda> b . b = (FailureMode Omission)) SMon_OutMon)
    (FT2BE
      (
        IntermediaryEvent FTGOr
          (IntermediaryEvent FTGAnd (BasicEvent FB1) (BasicEvent FB2))
          (
            IntermediaryEvent FTGAnd
              (BasicEvent FMon)
              (IntermediaryEvent FTGOr (BasicEvent FB1) (BasicEvent FB2))
          )
      )
    )"
apply (simp add: SMon_OutMon_def SMon_def SMon_Cs_def SMon_A_def Battery_def Monitor_def)
apply (simp add: System_def SystemComponents_def SystemPortValuation_def )
apply (simp add: fun_upd_fun_def)
apply (simp add: lt_Values_def)
apply (auto simp add: equiv_test)
done

end


(*  Title:       The Ipurge Unwinding Theorem for CSP Noninterference Security
    Author:      Pasquale Noce
                 Security Certification Specialist at Arjo Systems - Gep S.p.A.
                 pasquale dot noce dot lavoro at gmail dot com
                 pasquale dot noce at arjowiggins-it dot com
*)

section "The Ipurge Unwinding Theorem for deterministic and trace set processes"

theory DeterministicProcesses
imports IpurgeUnwinding
begin

text \<open>
\null

In accordance with Hoare's formal definition of deterministic processes \cite{R3}, this section
shows that a process is deterministic just in case it is a \emph{trace set process}, i.e. it may be
identified by means of a trace set alone, matching the set of its traces, in place of a
failures-divergences pair. Then, variants of the Ipurge Unwinding Theorem are proven for
deterministic processes and trace set processes.
\<close>

subsection "Deterministic processes"

text \<open>
Here below are the definitions of predicates \<open>d_future_consistent\<close> and
\<open>d_weakly_future_consistent\<close>, which are variants of predicates @{term future_consistent} and
@{term weakly_future_consistent} meant for applying to deterministic processes. In some detail,
being deterministic processes such that refused events are completely specified by accepted events
(cf. \cite{R3}, \cite{R1}), the new predicates are such that their truth values can be determined
by just considering the accepted events of the process taken as input.

Then, it is proven that these predicates are characterized by the same connection as that of their
general-purpose counterparts, viz. \<open>d_future_consistent\<close> implies
\<open>d_weakly_future_consistent\<close>, and they are equivalent for domain-relation map
@{term rel_ipurge}. Finally, the predicates are shown to be equivalent to their general-purpose
counterparts in the case of a deterministic process.

\null
\<close>

definition d_future_consistent ::
 "'a process \<Rightarrow> ('a \<Rightarrow> 'd) \<Rightarrow> ('a, 'd) dom_rel_map \<Rightarrow> bool" where
"d_future_consistent P D R \<equiv>
  \<forall>u \<in> range D. \<forall>xs ys. (xs, ys) \<in> R u \<longrightarrow>
    (xs \<in> traces P) = (ys \<in> traces P) \<and>
    next_dom_events P D u xs = next_dom_events P D u ys"

definition d_weakly_future_consistent ::
 "'a process \<Rightarrow> ('d \<times> 'd) set \<Rightarrow> ('a \<Rightarrow> 'd) \<Rightarrow> ('a, 'd) dom_rel_map \<Rightarrow> bool" where
"d_weakly_future_consistent P I D R \<equiv>
  \<forall>u \<in> range D \<inter> (-I) `` range D. \<forall>xs ys. (xs, ys) \<in> R u \<longrightarrow>
    (xs \<in> traces P) = (ys \<in> traces P) \<and>
    next_dom_events P D u xs = next_dom_events P D u ys"

lemma dfc_implies_dwfc:
 "d_future_consistent P D R \<Longrightarrow> d_weakly_future_consistent P I D R"
by (simp only: d_future_consistent_def d_weakly_future_consistent_def, blast)

lemma dfc_equals_dwfc_rel_ipurge:
 "d_future_consistent P D (rel_ipurge P I D) =
  d_weakly_future_consistent P I D (rel_ipurge P I D)"
proof (rule iffI, erule dfc_implies_dwfc,
 simp only: d_future_consistent_def d_weakly_future_consistent_def,
 rule ballI, (rule allI)+, rule impI)
  fix u xs ys
  assume
    A: "\<forall>u \<in> range D \<inter> (-I) `` range D. \<forall>xs ys. (xs, ys) \<in> rel_ipurge P I D u \<longrightarrow>
      (xs \<in> traces P) = (ys \<in> traces P) \<and>
      next_dom_events P D u xs = next_dom_events P D u ys" and
    B: "u \<in> range D" and
    C: "(xs, ys) \<in> rel_ipurge P I D u"
  show "(xs \<in> traces P) = (ys \<in> traces P) \<and>
    next_dom_events P D u xs = next_dom_events P D u ys"
  proof (cases "u \<in> range D \<inter> (-I) `` range D")
    case True
    with A have "\<forall>xs ys. (xs, ys) \<in> rel_ipurge P I D u \<longrightarrow>
      (xs \<in> traces P) = (ys \<in> traces P) \<and>
      next_dom_events P D u xs = next_dom_events P D u ys" ..
    hence "(xs, ys) \<in> rel_ipurge P I D u \<longrightarrow>
      (xs \<in> traces P) = (ys \<in> traces P) \<and>
      next_dom_events P D u xs = next_dom_events P D u ys"
     by blast
    thus ?thesis using C ..
  next
    case False
    hence D: "u \<notin> (-I) `` range D" using B by simp
    have "ipurge_tr_rev I D u xs = ipurge_tr_rev I D u ys"
     using C by (simp add: rel_ipurge_def)
    moreover have "\<forall>zs. ipurge_tr_rev I D u zs = zs"
    proof (rule allI, rule ipurge_tr_rev_all, rule ballI, erule imageE, rule ccontr)
      fix v x
      assume "(v, u) \<notin> I"
      hence "(v, u) \<in> -I" by simp
      moreover assume "v = D x"
      hence "v \<in> range D" by simp
      ultimately have "u \<in> (-I) `` range D" ..
      thus False using D by contradiction
    qed
    ultimately show ?thesis by simp
  qed
qed

lemma d_fc_equals_dfc:
  assumes A: "deterministic P"
  shows "future_consistent P D R = d_future_consistent P D R"
proof (rule iffI, simp_all only: d_future_consistent_def,
 rule ballI, (rule allI)+, rule impI, rule conjI, rule fc_traces, assumption+,
 simp_all add: future_consistent_def del: ball_simps)
  assume B: "\<forall>u \<in> range D. \<forall>xs ys. (xs, ys) \<in> R u \<longrightarrow>
    (xs \<in> traces P) = (ys \<in> traces P) \<and>
    next_dom_events P D u xs = next_dom_events P D u ys"
  show "\<forall>u \<in> range D. \<forall>xs ys. (xs, ys) \<in> R u \<longrightarrow>
    ref_dom_events P D u xs = ref_dom_events P D u ys"
  proof (rule ballI, (rule allI)+, rule impI,
   simp add: ref_dom_events_def set_eq_iff, rule allI)
    fix u xs ys x
    assume "u \<in> range D"
    with B have "\<forall>xs ys. (xs, ys) \<in> R u \<longrightarrow>
      (xs \<in> traces P) = (ys \<in> traces P) \<and>
      next_dom_events P D u xs = next_dom_events P D u ys" ..
    hence "(xs, ys) \<in> R u \<longrightarrow>
      (xs \<in> traces P) = (ys \<in> traces P) \<and>
      next_dom_events P D u xs = next_dom_events P D u ys"
     by blast
    moreover assume "(xs, ys) \<in> R u"
    ultimately have C: "(xs \<in> traces P) = (ys \<in> traces P) \<and>
      next_dom_events P D u xs = next_dom_events P D u ys" ..
    show "(u = D x \<and> {x} \<in> refusals P xs) = (u = D x \<and> {x} \<in> refusals P ys)"
    proof (cases "u = D x", simp_all, cases "xs \<in> traces P")
      assume D: "u = D x" and E: "xs \<in> traces P"
      have
        A': "\<forall>xs \<in> traces P. \<forall>X. X \<in> refusals P xs = (X \<inter> next_events P xs = {})"
       using A by (simp add: deterministic_def)
      hence "\<forall>X. X \<in> refusals P xs = (X \<inter> next_events P xs = {})" using E ..
      hence "{x} \<in> refusals P xs = ({x} \<inter> next_events P xs = {})" ..
      moreover have "ys \<in> traces P" using C and E by simp
      with A' have "\<forall>X. X \<in> refusals P ys = (X \<inter> next_events P ys = {})" ..
      hence "{x} \<in> refusals P ys = ({x} \<inter> next_events P ys = {})" ..
      moreover have "{x} \<inter> next_events P xs = {x} \<inter> next_events P ys"
      proof (simp add: set_eq_iff, rule allI, rule iffI, erule_tac [!] conjE, simp_all)
        assume "x \<in> next_events P xs"
        hence "x \<in> next_dom_events P D u xs" using D by (simp add: next_dom_events_def)
        hence "x \<in> next_dom_events P D u ys" using C by simp
        thus "x \<in> next_events P ys" by (simp add: next_dom_events_def)
      next
        assume "x \<in> next_events P ys"
        hence "x \<in> next_dom_events P D u ys" using D by (simp add: next_dom_events_def)
        hence "x \<in> next_dom_events P D u xs" using C by simp
        thus "x \<in> next_events P xs" by (simp add: next_dom_events_def)
      qed
      ultimately show "({x} \<in> refusals P xs) = ({x} \<in> refusals P ys)" by simp
    next
      assume D: "xs \<notin> traces P"
      hence "\<forall>X. (xs, X) \<notin> failures P" by (simp add: traces_def Domain_iff)
      hence "refusals P xs = {}" by (rule_tac equals0I, simp add: refusals_def)
      moreover have "ys \<notin> traces P" using C and D by simp
      hence "\<forall>X. (ys, X) \<notin> failures P" by (simp add: traces_def Domain_iff)
      hence "refusals P ys = {}" by (rule_tac equals0I, simp add: refusals_def)
      ultimately show "({x} \<in> refusals P xs) = ({x} \<in> refusals P ys)" by simp
    qed
  qed
qed

lemma d_wfc_equals_dwfc:
  assumes A: "deterministic P"
  shows "weakly_future_consistent P I D R = d_weakly_future_consistent P I D R"
proof (rule iffI, simp_all only: d_weakly_future_consistent_def,
 rule ballI, (rule allI)+, rule impI, rule conjI, rule wfc_traces, assumption+,
 simp_all add: weakly_future_consistent_def del: ball_simps)
  assume B: "\<forall>u \<in> range D \<inter> (- I) `` range D. \<forall>xs ys. (xs, ys) \<in> R u \<longrightarrow>
    (xs \<in> traces P) = (ys \<in> traces P) \<and>
    next_dom_events P D u xs = next_dom_events P D u ys"
  show "\<forall>u \<in> range D \<inter> (- I) `` range D. \<forall>xs ys. (xs, ys) \<in> R u \<longrightarrow>
    ref_dom_events P D u xs = ref_dom_events P D u ys"
  proof (rule ballI, (rule allI)+, rule impI,
   simp (no_asm_simp) add: ref_dom_events_def set_eq_iff, rule allI)
    fix u xs ys x
    assume "u \<in> range D \<inter> (- I) `` range D"
    with B have "\<forall>xs ys. (xs, ys) \<in> R u \<longrightarrow>
      (xs \<in> traces P) = (ys \<in> traces P) \<and>
      next_dom_events P D u xs = next_dom_events P D u ys" ..
    hence "(xs, ys) \<in> R u \<longrightarrow>
      (xs \<in> traces P) = (ys \<in> traces P) \<and>
      next_dom_events P D u xs = next_dom_events P D u ys"
     by blast
    moreover assume "(xs, ys) \<in> R u"
    ultimately have C: "(xs \<in> traces P) = (ys \<in> traces P) \<and>
      next_dom_events P D u xs = next_dom_events P D u ys" ..
    show "(u = D x \<and> {x} \<in> refusals P xs) = (u = D x \<and> {x} \<in> refusals P ys)"
    proof (cases "u = D x", simp_all, cases "xs \<in> traces P")
      assume D: "u = D x" and E: "xs \<in> traces P"
      have A': "\<forall>xs \<in> traces P. \<forall>X.
        X \<in> refusals P xs = (X \<inter> next_events P xs = {})"
       using A by (simp add: deterministic_def)
      hence "\<forall>X. X \<in> refusals P xs = (X \<inter> next_events P xs = {})" using E ..
      hence "{x} \<in> refusals P xs = ({x} \<inter> next_events P xs = {})" ..
      moreover have "ys \<in> traces P" using C and E by simp
      with A' have "\<forall>X. X \<in> refusals P ys = (X \<inter> next_events P ys = {})" ..
      hence "{x} \<in> refusals P ys = ({x} \<inter> next_events P ys = {})" ..
      moreover have "{x} \<inter> next_events P xs = {x} \<inter> next_events P ys"
      proof (simp add: set_eq_iff, rule allI, rule iffI, erule_tac [!] conjE, simp_all)
        assume "x \<in> next_events P xs"
        hence "x \<in> next_dom_events P D u xs" using D by (simp add: next_dom_events_def)
        hence "x \<in> next_dom_events P D u ys" using C by simp
        thus "x \<in> next_events P ys" by (simp add: next_dom_events_def)
      next
        assume "x \<in> next_events P ys"
        hence "x \<in> next_dom_events P D u ys" using D by (simp add: next_dom_events_def)
        hence "x \<in> next_dom_events P D u xs" using C by simp
        thus "x \<in> next_events P xs" by (simp add: next_dom_events_def)
      qed
      ultimately show "({x} \<in> refusals P xs) = ({x} \<in> refusals P ys)" by simp
    next
      assume D: "xs \<notin> traces P"
      hence "\<forall>X. (xs, X) \<notin> failures P" by (simp add: traces_def Domain_iff)
      hence "refusals P xs = {}" by (rule_tac equals0I, simp add: refusals_def)
      moreover have "ys \<notin> traces P" using C and D by simp
      hence "\<forall>X. (ys, X) \<notin> failures P" by (simp add: traces_def Domain_iff)
      hence "refusals P ys = {}" by (rule_tac equals0I, simp add: refusals_def)
      ultimately show "({x} \<in> refusals P xs) = ({x} \<in> refusals P ys)" by simp
    qed
  qed
qed

text \<open>
\null

Here below is the proof of a variant of the Ipurge Unwinding Theorem applying to deterministic
processes. Unsurprisingly, its enunciation contains predicate @{term d_weakly_future_consistent} in
place of @{term weakly_future_consistent}. Furthermore, the assumption that the process be refusals
union closed is replaced by the assumption that it be deterministic, since the former property is
shown to be entailed by the latter.

\null
\<close>

lemma d_implies_ruc:
  assumes A: "deterministic P"
  shows "ref_union_closed P"
proof (subst ref_union_closed_def, (rule allI)+, (rule impI)+, erule exE)
  fix xs A X
  have "\<forall>xs \<in> traces P. \<forall>X. X \<in> refusals P xs = (X \<inter> next_events P xs = {})"
   using A by (simp add: deterministic_def)
  moreover assume B: "\<forall>X \<in> A. (xs, X) \<in> failures P" and "X \<in> A"
  hence "(xs, X) \<in> failures P" ..
  hence "xs \<in> traces P" by (rule failures_traces)
  ultimately have C: "\<forall>X. X \<in> refusals P xs = (X \<inter> next_events P xs = {})" ..
  have D: "\<forall>X \<in> A. X \<inter> next_events P xs = {}"
  proof
    fix X
    assume "X \<in> A"
    with B have "(xs, X) \<in> failures P" ..
    hence "X \<in> refusals P xs" by (simp add: refusals_def)
    thus "X \<inter> next_events P xs = {}" using C by simp
  qed
  have "(\<Union>X \<in> A. X) \<in> refusals P xs = ((\<Union>X \<in> A. X) \<inter> next_events P xs = {})"
   using C ..
  hence E: "(xs, \<Union>X \<in> A. X) \<in> failures P =
    ((\<Union>X \<in> A. X) \<inter> next_events P xs = {})"
   by (simp add: refusals_def)
  show "(xs, \<Union>X \<in> A. X) \<in> failures P"
  proof (rule ssubst [OF E], rule equals0I, erule IntE, erule UN_E)
    fix x X
    assume "X \<in> A"
    with D have "X \<inter> next_events P xs = {}" ..
    moreover assume "x \<in> X" and "x \<in> next_events P xs"
    hence "x \<in> X \<inter> next_events P xs" ..
    hence "\<exists>x. x \<in> X \<inter> next_events P xs" ..
    hence "X \<inter> next_events P xs \<noteq> {}" by (subst ex_in_conv [symmetric])
    ultimately show False by contradiction
  qed
qed

theorem d_ipurge_unwinding:
  assumes A: "deterministic P"
  shows "secure P I D = d_weakly_future_consistent P I D (rel_ipurge P I D)"
proof (insert d_wfc_equals_dwfc [of P I D "rel_ipurge P I D", OF A], erule subst)
qed (insert d_implies_ruc [OF A], rule ipurge_unwinding)

subsection "Trace set processes"

text \<open>
In \cite{R3}, section 2.8, Hoare formulates a simplified definition of a deterministic process,
identified with a \emph{trace set}, i.e. a set of event lists containing the empty list and any
prefix of each of its elements. Of course, this is consistent with the definition of determinism
applying to processes identified with failures-divergences pairs, which implies that their refusals
are completely specified by their traces (cf. \cite{R3}, \cite{R1}).

Here below are the definitions of a function \<open>ts_process\<close>, converting the input set of lists
into a process, and a predicate \<open>trace_set\<close>, returning @{term True} just in case the input set
of lists has the aforesaid properties. An analysis is then conducted about the output of the
functions defined in \cite{R1}, section 1.1, when acting on a \emph{trace set process}, i.e. a
process that may be expressed as \<open>ts_process T\<close> where \<open>trace_set T\<close> matches
@{term True}.

\null
\<close>

definition ts_process :: "'a list set \<Rightarrow> 'a process" where
"ts_process T \<equiv> Abs_process ({(xs, X). xs \<in> T \<and> (\<forall>x \<in> X. xs @ [x] \<notin> T)}, {})"

definition trace_set :: "'a list set \<Rightarrow> bool" where
"trace_set T \<equiv> [] \<in> T \<and> (\<forall>xs x. xs @ [x] \<in> T \<longrightarrow> xs \<in> T)"

lemma ts_process_rep:
  assumes A: "trace_set T"
  shows "Rep_process (ts_process T) =
    ({(xs, X). xs \<in> T \<and> (\<forall>x \<in> X. xs @ [x] \<notin> T)}, {})"
proof (subst ts_process_def, rule Abs_process_inverse, simp add: process_set_def,
 (subst conj_assoc [symmetric])+, (rule conjI)+, simp_all add:
 process_prop_1_def
 process_prop_2_def
 process_prop_3_def
 process_prop_4_def
 process_prop_5_def
 process_prop_6_def)
  show "[] \<in> T" using A by (simp add: trace_set_def)
next
  show "\<forall>xs. (\<exists>x. xs @ [x] \<in> T \<and> (\<exists>X. \<forall>x' \<in> X. xs @ [x, x'] \<notin> T)) \<longrightarrow> xs \<in> T"
  proof (rule allI, rule impI, erule exE, erule conjE)
    fix xs x
    have "\<forall>xs x. xs @ [x] \<in> T \<longrightarrow> xs \<in> T" using A by (simp add: trace_set_def)
    hence "xs @ [x] \<in> T \<longrightarrow> xs \<in> T" by blast
    moreover assume "xs @ [x] \<in> T"
    ultimately show "xs \<in> T" ..
  qed
next
  show "\<forall>xs X. xs \<in> T \<and> (\<exists>Y. (\<forall>x \<in> Y. xs @ [x] \<notin> T) \<and> X \<subseteq> Y) \<longrightarrow>
    (\<forall>x \<in> X. xs @ [x] \<notin> T)"
  proof ((rule allI)+, rule impI, (erule conjE, (erule exE)?)+, rule ballI)
    fix xs x X Y
    assume "\<forall>x \<in> Y. xs @ [x] \<notin> T"
    moreover assume "X \<subseteq> Y" and "x \<in> X"
    hence "x \<in> Y" ..
    ultimately show "xs @ [x] \<notin> T" ..
  qed
qed

lemma ts_process_failures:
 "trace_set T \<Longrightarrow>
  failures (ts_process T) = {(xs, X). xs \<in> T \<and> (\<forall>x \<in> X. xs @ [x] \<notin> T)}"
by (drule ts_process_rep, simp add: failures_def)

lemma ts_process_futures:
 "trace_set T \<Longrightarrow>
  futures (ts_process T) xs =
  {(ys, Y). xs @ ys \<in> T \<and> (\<forall>y \<in> Y. xs @ ys @ [y] \<notin> T)}"
by (simp add: futures_def ts_process_failures)

lemma ts_process_traces:
 "trace_set T \<Longrightarrow> traces (ts_process T) = T"
proof (drule ts_process_failures, simp add: traces_def, rule set_eqI, rule iffI, simp_all)
qed (rule_tac x = "{}" in exI, simp)

lemma ts_process_refusals:
 "trace_set T \<Longrightarrow> xs \<in> T \<Longrightarrow>
  refusals (ts_process T) xs = {X. \<forall>x \<in> X. xs @ [x] \<notin> T}"
by (drule ts_process_failures, simp add: refusals_def)

lemma ts_process_next_events:
 "trace_set T \<Longrightarrow> (x \<in> next_events (ts_process T) xs) = (xs @ [x] \<in> T)"
by (drule ts_process_traces, simp add: next_events_def)

text \<open>
\null

In what follows, the proof is given of two results which provide a connection between the notions of
deterministic and trace set processes: any trace set process is deterministic, and any process is
deterministic just in case it is equal to the trace set process corresponding to the set of its
traces.

\null
\<close>

lemma ts_process_d:
 "trace_set T \<Longrightarrow> deterministic (ts_process T)"
proof (frule ts_process_traces, simp add: deterministic_def, rule ballI,
 drule ts_process_refusals, assumption, simp add: next_events_def,
 rule allI, rule iffI)
  fix xs X
  assume "\<forall>x \<in> X. xs @ [x] \<notin> T"
  thus "X \<inter> {x. xs @ [x] \<in> T} = {}"
  by (rule_tac equals0I, erule_tac IntE, simp)
next
  fix xs X
  assume A: "X \<inter> {x. xs @ [x] \<in> T} = {}"
  show "\<forall>x \<in> X. xs @ [x] \<notin> T"
  proof (rule ballI, rule notI)
    fix x
    assume "x \<in> X" and "xs @ [x] \<in> T"
    hence "x \<in> X \<inter> {x. xs @ [x] \<in> T}" by simp
    moreover have "x \<notin> X \<inter> {x. xs @ [x] \<in> T}" using A by (rule equals0D)
    ultimately show False by contradiction
  qed
qed

definition divergences :: "'a process \<Rightarrow> 'a list set" where
"divergences P \<equiv> snd (Rep_process P)"

lemma d_divergences:
  assumes A: "deterministic P"
  shows "divergences P = {}"
proof (subst divergences_def, rule equals0I)
  fix xs
  have B: "Rep_process P \<in> process_set" (is "?P' \<in> _") by (rule Rep_process)
  hence "\<forall>xs. \<exists>x. xs \<in> snd ?P' \<longrightarrow> xs @ [x] \<in> snd ?P'"
   by (simp add: process_set_def process_prop_5_def)
  hence "\<exists>x. xs \<in> snd ?P' \<longrightarrow> xs @ [x] \<in> snd ?P'" ..
  then obtain x where "xs \<in> snd ?P' \<longrightarrow> xs @ [x] \<in> snd ?P'" ..
  moreover assume C: "xs \<in> snd ?P'"
  ultimately have D: "xs @ [x] \<in> snd ?P'" ..
  have E: "\<forall>xs X. xs \<in> snd ?P' \<longrightarrow> (xs, X) \<in> fst ?P'"
   using B by (simp add: process_set_def process_prop_6_def)
  hence "xs \<in> snd ?P' \<longrightarrow> (xs, {x}) \<in> fst ?P'" by blast
  hence "{x} \<in> refusals P xs"
   using C by (drule_tac mp, simp_all add: failures_def refusals_def)
  moreover have "xs @ [x] \<in> snd ?P' \<longrightarrow> (xs @ [x], {}) \<in> fst ?P'"
   using E by blast
  hence "(xs @ [x], {}) \<in> failures P"
   using D by (drule_tac mp, simp_all add: failures_def)
  hence F: "xs @ [x] \<in> traces P" by (rule failures_traces)
  hence "{x} \<inter> next_events P xs \<noteq> {}" by (simp add: next_events_def)
  ultimately have G: "({x} \<in> refusals P xs) \<noteq> ({x} \<inter> next_events P xs = {})"
   by simp
  have "\<forall>xs \<in> traces P. \<forall>X. X \<in> refusals P xs = (X \<inter> next_events P xs = {})"
   using A by (simp add: deterministic_def)
  moreover have "xs \<in> traces P" using F by (rule process_rule_2_traces)
  ultimately have "\<forall>X. X \<in> refusals P xs = (X \<inter> next_events P xs = {})" ..
  hence "{x} \<in> refusals P xs = ({x} \<inter> next_events P xs = {})" ..
  thus False using G by contradiction
qed

lemma trace_set_traces:
 "trace_set (traces P)"
proof (simp only: trace_set_def traces_def failures_def Domain_iff,
 rule conjI, (rule_tac [2] allI)+, rule_tac [2] impI, erule_tac [2] exE)
  have "Rep_process P \<in> process_set" (is "?P' \<in> _") by (rule Rep_process)
  hence "([], {}) \<in> fst ?P'" by (simp add: process_set_def process_prop_1_def)
  thus "\<exists>X. ([], X) \<in> fst ?P'" ..
next
  fix xs x X
  have "Rep_process P \<in> process_set" (is "?P' \<in> _") by (rule Rep_process)
  hence "\<forall>xs x X. (xs @ [x], X) \<in> fst ?P' \<longrightarrow> (xs, {}) \<in> fst ?P'"
   by (simp add: process_set_def process_prop_2_def)
  hence "(xs @ [x], X) \<in> fst ?P' \<longrightarrow> (xs, {}) \<in> fst ?P'" by blast
  moreover assume "(xs @ [x], X) \<in> fst ?P'"
  ultimately have "(xs, {}) \<in> fst ?P'" ..
  thus "\<exists>X. (xs, X) \<in> fst ?P'" ..
qed

lemma d_implies_ts_process_traces:
 "deterministic P \<Longrightarrow> ts_process (traces P) = P"
proof (simp add: Rep_process_inject [symmetric] prod_eq_iff failures_def [symmetric],
 insert trace_set_traces [of P], frule ts_process_rep, frule d_divergences,
 simp add: divergences_def deterministic_def)
  assume A: "\<forall>xs \<in> traces P. \<forall>X.
    (X \<in> refusals P xs) = (X \<inter> next_events P xs = {})"
  assume B: "trace_set (traces P)"
  hence C: "traces (ts_process (traces P)) = traces P" by (rule ts_process_traces)
  show "failures (ts_process (traces P)) = failures P"
  proof (rule equalityI, rule_tac [!] subsetI, simp_all only: split_paired_all)
    fix xs X
    assume D: "(xs, X) \<in> failures (ts_process (traces P))"
    hence "xs \<in> traces (ts_process (traces P))" by (rule failures_traces)
    hence E: "xs \<in> traces P" using C by simp
    with B have
     "refusals (ts_process (traces P)) xs = {X. \<forall>x \<in> X. xs @ [x] \<notin> traces P}"
     by (rule ts_process_refusals)
    moreover have "X \<in> refusals (ts_process (traces P)) xs"
     using D by (simp add: refusals_def)
    ultimately have "\<forall>x \<in> X. xs @ [x] \<notin> traces P" by simp
    hence "X \<inter> next_events P xs = {}"
     by (rule_tac equals0I, erule_tac IntE, simp add: next_events_def)
    moreover have "\<forall>X. (X \<in> refusals P xs) = (X \<inter> next_events P xs = {})"
     using A and E ..
    hence "(X \<in> refusals P xs) = (X \<inter> next_events P xs = {})" ..
    ultimately have "X \<in> refusals P xs" by simp
    thus "(xs, X) \<in> failures P" by (simp add: refusals_def)
  next
    fix xs X
    assume D: "(xs, X) \<in> failures P"
    hence E: "xs \<in> traces P" by (rule failures_traces)
    with A have "\<forall>X. (X \<in> refusals P xs) = (X \<inter> next_events P xs = {})" ..
    hence "(X \<in> refusals P xs) = (X \<inter> next_events P xs = {})" ..
    moreover have "X \<in> refusals P xs" using D by (simp add: refusals_def)
    ultimately have F: "X \<inter> {x. xs @ [x] \<in> traces P} = {}"
     by (simp add: next_events_def)
    have "\<forall>x \<in> X. xs @ [x] \<notin> traces P"
    proof (rule ballI, rule notI)
      fix x
      assume "x \<in> X" and "xs @ [x] \<in> traces P"
      hence "x \<in> X \<inter> {x. xs @ [x] \<in> traces P}" by simp
      moreover have "x \<notin> X \<inter> {x. xs @ [x] \<in> traces P}" using F by (rule equals0D)
      ultimately show False by contradiction
    qed
    moreover have
     "refusals (ts_process (traces P)) xs = {X. \<forall>x \<in> X. xs @ [x] \<notin> traces P}"
     using B and E by (rule ts_process_refusals)
    ultimately have "X \<in> refusals (ts_process (traces P)) xs" by simp
    thus "(xs, X) \<in> failures (ts_process (traces P))" by (simp add: refusals_def)
  qed
qed

lemma ts_process_traces_implies_d:
 "ts_process (traces P) = P \<Longrightarrow> deterministic P"
by (insert trace_set_traces [of P], drule ts_process_d, simp)

lemma d_equals_ts_process_traces:
 "deterministic P = (ts_process (traces P) = P)"
by (rule iffI, erule d_implies_ts_process_traces, rule ts_process_traces_implies_d)

text \<open>
\null

Finally, a variant of the Ipurge Unwinding Theorem applying to trace set processes is derived from
the variant for deterministic processes. Particularly, the assumption that the process be
deterministic is replaced by the assumption that it be a trace set process,
since the former property is entailed by the latter (cf. above).

\null
\<close>

theorem ts_ipurge_unwinding:
 "trace_set T \<Longrightarrow>
  secure (ts_process T) I D =
  d_weakly_future_consistent (ts_process T) I D (rel_ipurge (ts_process T) I D)"
by (rule d_ipurge_unwinding, rule ts_process_d)

end


theory TTreeImplCardinality
imports TTreeAnalysisSig CardinalityAnalysisSig "Cardinality-Domain-Lists"
begin

context TTreeAnalysis
begin

fun unstack :: "stack \<Rightarrow> exp \<Rightarrow> exp" where
  "unstack [] e = e"
| "unstack (Alts e1 e2 # S) e = unstack S e"
| "unstack (Upd x # S) e = unstack S e"
| "unstack (Arg x # S) e = unstack S (App e x)"
| "unstack (Dummy x # S) e = unstack S e"

fun Fstack :: "Arity list \<Rightarrow> stack \<Rightarrow> var ttree"
  where "Fstack _ [] = \<bottom>"
  | "Fstack (a#as) (Alts e1 e2 # S) = (Texp e1\<cdot>a \<oplus>\<oplus> Texp e2\<cdot>a) \<otimes>\<otimes> Fstack as S"
  | "Fstack as (Arg x # S) = many_calls x \<otimes>\<otimes> Fstack as S"
  | "Fstack as (_ # S) = Fstack as S"

(*
lemma carrier_Fstack[simp]: "carrier (Fstack S) = ap S"
  by (induction S rule: Fstack.induct) (auto simp add: empty_is_bottom[symmetric])
*)

fun prognosis :: "AEnv \<Rightarrow> Arity list \<Rightarrow> Arity \<Rightarrow> conf \<Rightarrow> var \<Rightarrow> two"
   where "prognosis ae as a (\<Gamma>, e, S) = pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (Texp e\<cdot>a \<otimes>\<otimes> Fstack as S)))"
end

end


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

chapter \<open>Unsigned words of 8 bits\<close>

theory Uint8 imports
  Code_Target_Word_Base
begin

text \<open>
  Restriction for OCaml code generation:
  OCaml does not provide an int8 type, so no special code generation
  for this type is set up. If the theory \<open>Code_Target_Bits_Int\<close>
  is imported, the type \<open>uint8\<close> is emulated via @{typ "8 word"}.
\<close>

declare prod.Quotient[transfer_rule]

section \<open>Type definition and primitive operations\<close>

typedef uint8 = "UNIV :: 8 word set" ..

setup_lifting type_definition_uint8

text \<open>Use an abstract type for code generation to disable pattern matching on @{term Abs_uint8}.\<close>
declare Rep_uint8_inverse[code abstype]

declare Quotient_uint8[transfer_rule]

instantiation uint8 :: "{neg_numeral, modulo, comm_monoid_mult, comm_ring}" begin
lift_definition zero_uint8 :: uint8 is "0" .
lift_definition one_uint8 :: uint8 is "1" .
lift_definition plus_uint8 :: "uint8 \<Rightarrow> uint8 \<Rightarrow> uint8" is "(+)" .
lift_definition minus_uint8 :: "uint8 \<Rightarrow> uint8 \<Rightarrow> uint8" is "(-)" .
lift_definition uminus_uint8 :: "uint8 \<Rightarrow> uint8" is uminus .
lift_definition times_uint8 :: "uint8 \<Rightarrow> uint8 \<Rightarrow> uint8" is "(*)" .
lift_definition divide_uint8 :: "uint8 \<Rightarrow> uint8 \<Rightarrow> uint8" is "(div)" .
lift_definition modulo_uint8 :: "uint8 \<Rightarrow> uint8 \<Rightarrow> uint8" is "(mod)" .
instance by standard (transfer, simp add: algebra_simps)+
end

instantiation uint8 :: linorder begin
lift_definition less_uint8 :: "uint8 \<Rightarrow> uint8 \<Rightarrow> bool" is "(<)" .
lift_definition less_eq_uint8 :: "uint8 \<Rightarrow> uint8 \<Rightarrow> bool" is "(\<le>)" .
instance by standard (transfer, simp add: less_le_not_le linear)+
end

lemmas [code] = less_uint8.rep_eq less_eq_uint8.rep_eq

instantiation uint8 :: bit_operations begin
lift_definition bitNOT_uint8 :: "uint8 \<Rightarrow> uint8" is bitNOT .
lift_definition bitAND_uint8 :: "uint8 \<Rightarrow> uint8 \<Rightarrow> uint8" is bitAND .
lift_definition bitOR_uint8 :: "uint8 \<Rightarrow> uint8 \<Rightarrow> uint8" is bitOR .
lift_definition bitXOR_uint8 :: "uint8 \<Rightarrow> uint8 \<Rightarrow> uint8" is bitXOR .
lift_definition test_bit_uint8 :: "uint8 \<Rightarrow> nat \<Rightarrow> bool" is test_bit .
lift_definition set_bit_uint8 :: "uint8 \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> uint8" is set_bit .
lift_definition lsb_uint8 :: "uint8 \<Rightarrow> bool" is lsb .
lift_definition shiftl_uint8 :: "uint8 \<Rightarrow> nat \<Rightarrow> uint8" is shiftl .
lift_definition shiftr_uint8 :: "uint8 \<Rightarrow> nat \<Rightarrow> uint8" is shiftr .
lift_definition msb_uint8 :: "uint8 \<Rightarrow> bool" is msb .
instance ..
end

instantiation uint8 :: bit_comprehension begin
lift_definition set_bits_uint8 :: "(nat \<Rightarrow> bool) \<Rightarrow> uint8" is "set_bits" .
instance ..
end

lemmas [code] = test_bit_uint8.rep_eq lsb_uint8.rep_eq msb_uint8.rep_eq

instantiation uint8 :: equal begin
lift_definition equal_uint8 :: "uint8 \<Rightarrow> uint8 \<Rightarrow> bool" is "equal_class.equal" .
instance by standard (transfer, simp add: equal_eq)
end

lemmas [code] = equal_uint8.rep_eq

instantiation uint8 :: size begin
lift_definition size_uint8 :: "uint8 \<Rightarrow> nat" is "size" .
instance ..
end

lemmas [code] = size_uint8.rep_eq

lift_definition sshiftr_uint8 :: "uint8 \<Rightarrow> nat \<Rightarrow> uint8" (infixl ">>>" 55) is sshiftr .

lift_definition uint8_of_int :: "int \<Rightarrow> uint8" is "word_of_int" .

definition uint8_of_nat :: "nat \<Rightarrow> uint8"
where "uint8_of_nat = uint8_of_int \<circ> int"

lift_definition int_of_uint8 :: "uint8 \<Rightarrow> int" is "uint" .
lift_definition nat_of_uint8 :: "uint8 \<Rightarrow> nat" is "unat" .

definition integer_of_uint8 :: "uint8 \<Rightarrow> integer"
where "integer_of_uint8 = integer_of_int o int_of_uint8"

text \<open>Use pretty numerals from integer for pretty printing\<close>

context includes integer.lifting begin

lift_definition Uint8 :: "integer \<Rightarrow> uint8" is "word_of_int" .

lemma Rep_uint8_numeral [simp]: "Rep_uint8 (numeral n) = numeral n"
by(induction n)(simp_all add: one_uint8_def Abs_uint8_inverse numeral.simps plus_uint8_def)

lemma numeral_uint8_transfer [transfer_rule]:
  "(rel_fun (=) cr_uint8) numeral numeral"
by(auto simp add: cr_uint8_def)

lemma numeral_uint8 [code_unfold]: "numeral n = Uint8 (numeral n)"
by transfer simp

lemma Rep_uint8_neg_numeral [simp]: "Rep_uint8 (- numeral n) = - numeral n"
by(simp only: uminus_uint8_def)(simp add: Abs_uint8_inverse)

lemma neg_numeral_uint8 [code_unfold]: "- numeral n = Uint8 (- numeral n)"
by transfer(simp add: cr_uint8_def)

end

lemma Abs_uint8_numeral [code_post]: "Abs_uint8 (numeral n) = numeral n"
by(induction n)(simp_all add: one_uint8_def numeral.simps plus_uint8_def Abs_uint8_inverse)

lemma Abs_uint8_0 [code_post]: "Abs_uint8 0 = 0"
by(simp add: zero_uint8_def)

lemma Abs_uint8_1 [code_post]: "Abs_uint8 1 = 1"
by(simp add: one_uint8_def)

section \<open>Code setup\<close>

code_printing code_module Uint8 \<rightharpoonup> (SML)
\<open>(* Test that words can handle numbers between 0 and 3 *)
val _ = if 3 <= Word.wordSize then () else raise (Fail ("wordSize less than 3"));

structure Uint8 : sig
  val set_bit : Word8.word -> IntInf.int -> bool -> Word8.word
  val shiftl : Word8.word -> IntInf.int -> Word8.word
  val shiftr : Word8.word -> IntInf.int -> Word8.word
  val shiftr_signed : Word8.word -> IntInf.int -> Word8.word
  val test_bit : Word8.word -> IntInf.int -> bool
end = struct

fun set_bit x n b =
  let val mask = Word8.<< (0wx1, Word.fromLargeInt (IntInf.toLarge n))
  in if b then Word8.orb (x, mask)
     else Word8.andb (x, Word8.notb mask)
  end

fun shiftl x n =
  Word8.<< (x, Word.fromLargeInt (IntInf.toLarge n))

fun shiftr x n =
  Word8.>> (x, Word.fromLargeInt (IntInf.toLarge n))

fun shiftr_signed x n =
  Word8.~>> (x, Word.fromLargeInt (IntInf.toLarge n))

fun test_bit x n =
  Word8.andb (x, Word8.<< (0wx1, Word.fromLargeInt (IntInf.toLarge n))) <> Word8.fromInt 0

end; (* struct Uint8 *)\<close>
code_reserved SML Uint8

code_printing code_module Uint8 \<rightharpoonup> (Haskell)
 \<open>module Uint8(Int8, Word8) where

  import Data.Int(Int8)
  import Data.Word(Word8)\<close>
code_reserved Haskell Uint8

text \<open>
  Scala provides only signed 8bit numbers, so we use these and
  implement sign-sensitive operations like comparisons manually.
\<close>

code_printing code_module Uint8 \<rightharpoonup> (Scala)
\<open>object Uint8 {

def less(x: Byte, y: Byte) : Boolean =
  if (x < 0) y < 0 && x < y
  else y < 0 || x < y

def less_eq(x: Byte, y: Byte) : Boolean =
  if (x < 0) y < 0 && x <= y
  else y < 0 || x <= y

def set_bit(x: Byte, n: BigInt, b: Boolean) : Byte =
  if (b)
    (x | (1 << n.intValue)).toByte
  else
    (x & (1 << n.intValue).unary_~).toByte

def shiftl(x: Byte, n: BigInt) : Byte = (x << n.intValue).toByte

def shiftr(x: Byte, n: BigInt) : Byte = ((x & 255) >>> n.intValue).toByte

def shiftr_signed(x: Byte, n: BigInt) : Byte = (x >> n.intValue).toByte

def test_bit(x: Byte, n: BigInt) : Boolean =
  (x & (1 << n.intValue)) != 0

} /* object Uint8 */\<close>
code_reserved Scala Uint8

text \<open>
  Avoid @{term Abs_uint8} in generated code, use @{term Rep_uint8'} instead.
  The symbolic implementations for code\_simp use @{term Rep_uint8}.

  The new destructor @{term Rep_uint8'} is executable.
  As the simplifier is given the [code abstract] equations literally,
  we cannot implement @{term Rep_uint8} directly, because that makes code\_simp loop.

  If code generation raises Match, some equation probably contains @{term Rep_uint8}
  ([code abstract] equations for @{typ uint8} may use @{term Rep_uint8} because
  these instances will be folded away.)

  To convert @{typ "8 word"} values into @{typ uint8}, use @{term "Abs_uint8'"}.
\<close>

definition Rep_uint8' where [simp]: "Rep_uint8' = Rep_uint8"

lemma Rep_uint8'_transfer [transfer_rule]:
  "rel_fun cr_uint8 (=) (\<lambda>x. x) Rep_uint8'"
unfolding Rep_uint8'_def by(rule uint8.rep_transfer)

lemma Rep_uint8'_code [code]: "Rep_uint8' x = (BITS n. x !! n)"
by transfer simp

lift_definition Abs_uint8' :: "8 word \<Rightarrow> uint8" is "\<lambda>x :: 8 word. x" .

lemma Abs_uint8'_code [code]: "Abs_uint8' x = Uint8 (integer_of_int (uint x))"
including integer.lifting by transfer simp

declare [[code drop: "term_of_class.term_of :: uint8 \<Rightarrow> _"]]

lemma term_of_uint8_code [code]:
  defines "TR \<equiv> typerep.Typerep" and "bit0 \<equiv> STR ''Numeral_Type.bit0''" shows
  "term_of_class.term_of x =
   Code_Evaluation.App (Code_Evaluation.Const (STR ''Uint8.uint8.Abs_uint8'') (TR (STR ''fun'') [TR (STR ''Word.word'') [TR bit0 [TR bit0 [TR bit0 [TR (STR ''Numeral_Type.num1'') []]]]], TR (STR ''Uint8.uint8'') []]))
       (term_of_class.term_of (Rep_uint8' x))"
by(simp add: term_of_anything)

lemma Uin8_code [code abstract]: "Rep_uint8 (Uint8 i) = word_of_int (int_of_integer_symbolic i)"
unfolding Uint8_def int_of_integer_symbolic_def by(simp add: Abs_uint8_inverse)

code_printing type_constructor uint8 \<rightharpoonup>
  (SML) "Word8.word" and
  (Haskell) "Uint8.Word8" and
  (Scala) "Byte"
| constant Uint8 \<rightharpoonup>
  (SML) "Word8.fromLargeInt (IntInf.toLarge _)" and
  (Haskell) "(Prelude.fromInteger _ :: Uint8.Word8)" and
  (Haskell_Quickcheck) "(Prelude.fromInteger (Prelude.toInteger _) :: Uint8.Word8)" and
  (Scala) "_.byteValue"
| constant "0 :: uint8" \<rightharpoonup>
  (SML) "(Word8.fromInt 0)" and
  (Haskell) "(0 :: Uint8.Word8)" and
  (Scala) "0.toByte"
| constant "1 :: uint8" \<rightharpoonup>
  (SML) "(Word8.fromInt 1)" and
  (Haskell) "(1 :: Uint8.Word8)" and
  (Scala) "1.toByte"
| constant "plus :: uint8 \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
  (SML) "Word8.+ ((_), (_))" and
  (Haskell) infixl 6 "+" and
  (Scala) "(_ +/ _).toByte"
| constant "uminus :: uint8 \<Rightarrow> _" \<rightharpoonup>
  (SML) "Word8.~" and
  (Haskell) "negate" and
  (Scala) "(- _).toByte"
| constant "minus :: uint8 \<Rightarrow> _" \<rightharpoonup>
  (SML) "Word8.- ((_), (_))" and
  (Haskell) infixl 6 "-" and
  (Scala) "(_ -/ _).toByte"
| constant "times :: uint8 \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
  (SML) "Word8.* ((_), (_))" and
  (Haskell) infixl 7 "*" and
  (Scala) "(_ */ _).toByte"
| constant "HOL.equal :: uint8 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
  (SML) "!((_ : Word8.word) = _)" and
  (Haskell) infix 4 "==" and
  (Scala) infixl 5 "=="
| class_instance uint8 :: equal \<rightharpoonup> (Haskell) -
| constant "less_eq :: uint8 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
  (SML) "Word8.<= ((_), (_))" and
  (Haskell) infix 4 "<=" and
  (Scala) "Uint8.less'_eq"
| constant "less :: uint8 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
  (SML) "Word8.< ((_), (_))" and
  (Haskell) infix 4 "<" and
  (Scala) "Uint8.less"
| constant "bitNOT :: uint8 \<Rightarrow> _" \<rightharpoonup>
  (SML) "Word8.notb" and
  (Haskell) "Data'_Bits.complement" and
  (Scala) "_.unary'_~.toByte"
| constant "bitAND :: uint8 \<Rightarrow> _" \<rightharpoonup>
  (SML) "Word8.andb ((_),/ (_))" and
  (Haskell) infixl 7 "Data_Bits..&." and
  (Scala) "(_ & _).toByte"
| constant "bitOR :: uint8 \<Rightarrow> _" \<rightharpoonup>
  (SML) "Word8.orb ((_),/ (_))" and
  (Haskell) infixl 5 "Data_Bits..|." and
  (Scala) "(_ | _).toByte"
| constant "bitXOR :: uint8 \<Rightarrow> _" \<rightharpoonup>
  (SML) "Word8.xorb ((_),/ (_))" and
  (Haskell) "Data'_Bits.xor" and
  (Scala) "(_ ^ _).toByte"

definition uint8_divmod :: "uint8 \<Rightarrow> uint8 \<Rightarrow> uint8 \<times> uint8" where
  "uint8_divmod x y =
  (if y = 0 then (undefined ((div) :: uint8 \<Rightarrow> _) x (0 :: uint8), undefined ((mod) :: uint8 \<Rightarrow> _) x (0 :: uint8))
  else (x div y, x mod y))"

definition uint8_div :: "uint8 \<Rightarrow> uint8 \<Rightarrow> uint8"
where "uint8_div x y = fst (uint8_divmod x y)"

definition uint8_mod :: "uint8 \<Rightarrow> uint8 \<Rightarrow> uint8"
where "uint8_mod x y = snd (uint8_divmod x y)"

lemma div_uint8_code [code]: "x div y = (if y = 0 then 0 else uint8_div x y)"
including undefined_transfer unfolding uint8_divmod_def uint8_div_def
by transfer (simp add: word_div_def)

lemma mod_uint8_code [code]: "x mod y = (if y = 0 then x else uint8_mod x y)"
including undefined_transfer unfolding uint8_mod_def uint8_divmod_def
by transfer (simp add: word_mod_def)

definition uint8_sdiv :: "uint8 \<Rightarrow> uint8 \<Rightarrow> uint8"
where
  "uint8_sdiv x y =
   (if y = 0 then undefined ((div) :: uint8 \<Rightarrow> _) x (0 :: uint8)
    else Abs_uint8 (Rep_uint8 x sdiv Rep_uint8 y))"

definition div0_uint8 :: "uint8 \<Rightarrow> uint8"
where [code del]: "div0_uint8 x = undefined ((div) :: uint8 \<Rightarrow> _) x (0 :: uint8)"
declare [[code abort: div0_uint8]]

definition mod0_uint8 :: "uint8 \<Rightarrow> uint8"
where [code del]: "mod0_uint8 x = undefined ((mod) :: uint8 \<Rightarrow> _) x (0 :: uint8)"
declare [[code abort: mod0_uint8]]

lemma uint8_divmod_code [code]:
  "uint8_divmod x y =
  (if 0x80 \<le> y then if x < y then (0, x) else (1, x - y)
   else if y = 0 then (div0_uint8 x, mod0_uint8 x)
   else let q = (uint8_sdiv (x >> 1) y) << 1;
            r = x - q * y
        in if r \<ge> y then (q + 1, r - y) else (q, r))"
including undefined_transfer unfolding uint8_divmod_def uint8_sdiv_def div0_uint8_def mod0_uint8_def
by transfer(simp add: divmod_via_sdivmod)

lemma uint8_sdiv_code [code abstract]:
  "Rep_uint8 (uint8_sdiv x y) =
   (if y = 0 then Rep_uint8 (undefined ((div) :: uint8 \<Rightarrow> _) x (0 :: uint8))
    else Rep_uint8 x sdiv Rep_uint8 y)"
unfolding uint8_sdiv_def by(simp add: Abs_uint8_inverse)

text \<open>
  Note that we only need a translation for signed division, but not for the remainder
  because @{thm uint8_divmod_code} computes both with division only.
\<close>

code_printing
  constant uint8_div \<rightharpoonup>
  (SML) "Word8.div ((_), (_))" and
  (Haskell) "Prelude.div"
| constant uint8_mod \<rightharpoonup>
  (SML) "Word8.mod ((_), (_))" and
  (Haskell) "Prelude.mod"
| constant uint8_divmod \<rightharpoonup>
  (Haskell) "divmod"
| constant uint8_sdiv \<rightharpoonup>
  (Scala) "(_ '/ _).toByte"

definition uint8_test_bit :: "uint8 \<Rightarrow> integer \<Rightarrow> bool"
where [code del]:
  "uint8_test_bit x n =
  (if n < 0 \<or> 7 < n then undefined (test_bit :: uint8 \<Rightarrow> _) x n
   else x !! (nat_of_integer n))"

lemma test_bit_uint8_code [code]:
  "test_bit x n \<longleftrightarrow> n < 8 \<and> uint8_test_bit x (integer_of_nat n)"
including undefined_transfer integer.lifting unfolding uint8_test_bit_def
by transfer(auto cong: conj_cong dest: test_bit_size simp add: word_size)

lemma uint8_test_bit_code [code]:
  "uint8_test_bit w n =
  (if n < 0 \<or> 7 < n then undefined (test_bit :: uint8 \<Rightarrow> _) w n else Rep_uint8 w !! nat_of_integer n)"
unfolding uint8_test_bit_def by(simp add: test_bit_uint8.rep_eq)

code_printing constant uint8_test_bit \<rightharpoonup>
  (SML) "Uint8.test'_bit" and
  (Haskell) "Data'_Bits.testBitBounded" and
  (Scala) "Uint8.test'_bit" and
  (Eval) "(fn x => fn i => if i < 0 orelse i >= 8 then raise (Fail \"argument to uint8'_test'_bit out of bounds\") else Uint8.test'_bit x i)"

definition uint8_set_bit :: "uint8 \<Rightarrow> integer \<Rightarrow> bool \<Rightarrow> uint8"
where [code del]:
  "uint8_set_bit x n b =
  (if n < 0 \<or> 7 < n then undefined (set_bit :: uint8 \<Rightarrow> _) x n b
   else set_bit x (nat_of_integer n) b)"

lemma set_bit_uint8_code [code]:
  "set_bit x n b = (if n < 8 then uint8_set_bit x (integer_of_nat n) b else x)"
including undefined_transfer integer.lifting unfolding uint8_set_bit_def
by(transfer)(auto cong: conj_cong simp add: not_less set_bit_beyond word_size)

lemma uint8_set_bit_code [code abstract]:
  "Rep_uint8 (uint8_set_bit w n b) =
  (if n < 0 \<or> 7 < n then Rep_uint8 (undefined (set_bit :: uint8 \<Rightarrow> _) w n b)
   else set_bit (Rep_uint8 w) (nat_of_integer n) b)"
including undefined_transfer unfolding uint8_set_bit_def by transfer simp

code_printing constant uint8_set_bit \<rightharpoonup>
  (SML) "Uint8.set'_bit" and
  (Haskell) "Data'_Bits.setBitBounded" and
  (Scala) "Uint8.set'_bit" and
  (Eval) "(fn x => fn i => fn b => if i < 0 orelse i >= 8 then raise (Fail \"argument to uint8'_set'_bit out of bounds\") else Uint8.set'_bit x i b)"

lift_definition uint8_set_bits :: "(nat \<Rightarrow> bool) \<Rightarrow> uint8 \<Rightarrow> nat \<Rightarrow> uint8" is set_bits_aux .

lemma uint8_set_bits_code [code]:
  "uint8_set_bits f w n =
  (if n = 0 then w
   else let n' = n - 1 in uint8_set_bits f ((w << 1) OR (if f n' then 1 else 0)) n')"
by(transfer fixing: n)(cases n, simp_all)

lemma set_bits_uint8 [code]:
  "(BITS n. f n) = uint8_set_bits f 0 8"
by transfer(simp add: set_bits_conv_set_bits_aux)

lemma lsb_code [code]: fixes x :: uint8 shows "lsb x = x !! 0"
by transfer(simp add: word_lsb_def word_test_bit_def)

definition uint8_shiftl :: "uint8 \<Rightarrow> integer \<Rightarrow> uint8"
where [code del]:
  "uint8_shiftl x n = (if n < 0 \<or> 8 \<le> n then undefined (shiftl :: uint8 \<Rightarrow> _) x n else x << (nat_of_integer n))"

lemma shiftl_uint8_code [code]: "x << n = (if n < 8 then uint8_shiftl x (integer_of_nat n) else 0)"
including undefined_transfer integer.lifting unfolding uint8_shiftl_def
by transfer(simp add: not_less shiftl_zero_size word_size)

lemma uint8_shiftl_code [code abstract]:
  "Rep_uint8 (uint8_shiftl w n) =
  (if n < 0 \<or> 8 \<le> n then Rep_uint8 (undefined (shiftl :: uint8 \<Rightarrow> _) w n)
   else Rep_uint8 w << nat_of_integer n)"
including undefined_transfer unfolding uint8_shiftl_def by transfer simp

code_printing constant uint8_shiftl \<rightharpoonup>
  (SML) "Uint8.shiftl" and
  (Haskell) "Data'_Bits.shiftlBounded" and
  (Scala) "Uint8.shiftl" and
  (Eval) "(fn x => fn i => if i < 0 orelse i >= 8 then raise (Fail \"argument to uint8'_shiftl out of bounds\") else Uint8.shiftl x i)"

definition uint8_shiftr :: "uint8 \<Rightarrow> integer \<Rightarrow> uint8"
where [code del]:
  "uint8_shiftr x n = (if n < 0 \<or> 8 \<le> n then undefined (shiftr :: uint8 \<Rightarrow> _) x n else x >> (nat_of_integer n))"

lemma shiftr_uint8_code [code]: "x >> n = (if n < 8 then uint8_shiftr x (integer_of_nat n) else 0)"
including undefined_transfer integer.lifting unfolding uint8_shiftr_def
by transfer(simp add: not_less shiftr_zero_size word_size)

lemma uint8_shiftr_code [code abstract]:
  "Rep_uint8 (uint8_shiftr w n) =
  (if n < 0 \<or> 8 \<le> n then Rep_uint8 (undefined (shiftr :: uint8 \<Rightarrow> _) w n)
   else Rep_uint8 w >> nat_of_integer n)"
including undefined_transfer unfolding uint8_shiftr_def by transfer simp

code_printing constant uint8_shiftr \<rightharpoonup>
  (SML) "Uint8.shiftr" and
  (Haskell) "Data'_Bits.shiftrBounded" and
  (Scala) "Uint8.shiftr" and
  (Eval) "(fn x => fn i => if i < 0 orelse i >= 8 then raise (Fail \"argument to uint8'_shiftr out of bounds\") else Uint8.shiftr x i)"

definition uint8_sshiftr :: "uint8 \<Rightarrow> integer \<Rightarrow> uint8"
where [code del]:
  "uint8_sshiftr x n =
  (if n < 0 \<or> 8 \<le> n then undefined sshiftr_uint8 x n else sshiftr_uint8 x (nat_of_integer n))"

lemma sshiftr_beyond: fixes x :: "'a :: len word" shows
  "size x \<le> n \<Longrightarrow> x >>> n = (if x !! (size x - 1) then -1 else 0)"
by(rule word_eqI)(simp add: nth_sshiftr word_size)

lemma sshiftr_uint8_code [code]:
  "x >>> n =
  (if n < 8 then uint8_sshiftr x (integer_of_nat n) else if x !! 7 then -1 else 0)"
including undefined_transfer integer.lifting unfolding uint8_sshiftr_def
by transfer (simp add: not_less sshiftr_beyond word_size)

lemma uint8_sshiftr_code [code abstract]:
  "Rep_uint8 (uint8_sshiftr w n) =
  (if n < 0 \<or> 8 \<le> n then Rep_uint8 (undefined sshiftr_uint8 w n)
   else Rep_uint8 w >>> nat_of_integer n)"
including undefined_transfer unfolding uint8_sshiftr_def by transfer simp

code_printing constant uint8_sshiftr \<rightharpoonup>
  (SML) "Uint8.shiftr'_signed" and
  (Haskell)
    "(Prelude.fromInteger (Prelude.toInteger (Data'_Bits.shiftrBounded (Prelude.fromInteger (Prelude.toInteger _) :: Uint8.Int8) _)) :: Uint8.Word8)" and
  (Scala) "Uint8.shiftr'_signed" and
  (Eval) "(fn x => fn i => if i < 0 orelse i >= 8 then raise (Fail \"argument to uint8'_sshiftr out of bounds\") else Uint8.shiftr'_signed x i)"

lemma uint8_msb_test_bit: "msb x \<longleftrightarrow> (x :: uint8) !! 7"
by transfer(simp add: msb_nth)

lemma msb_uint16_code [code]: "msb x \<longleftrightarrow> uint8_test_bit x 7"
by(simp add: uint8_test_bit_def uint8_msb_test_bit)

lemma uint8_of_int_code [code]: "uint8_of_int i = Uint8 (integer_of_int i)"
including integer.lifting by transfer simp

lemma int_of_uint8_code [code]:
  "int_of_uint8 x = int_of_integer (integer_of_uint8 x)"
by(simp add: integer_of_uint8_def)

lemma nat_of_uint8_code [code]:
  "nat_of_uint8 x = nat_of_integer (integer_of_uint8 x)"
unfolding integer_of_uint8_def including integer.lifting by transfer (simp add: unat_def)

definition integer_of_uint8_signed :: "uint8 \<Rightarrow> integer"
where
  "integer_of_uint8_signed n = (if n !! 7 then undefined integer_of_uint8 n else integer_of_uint8 n)"

lemma integer_of_uint8_signed_code [code]:
  "integer_of_uint8_signed n =
  (if n !! 7 then undefined integer_of_uint8 n else integer_of_int (uint (Rep_uint8' n)))"
unfolding integer_of_uint8_signed_def integer_of_uint8_def
including undefined_transfer by transfer simp

code_printing
  constant "integer_of_uint8" \<rightharpoonup>
  (SML) "IntInf.fromLarge (Word8.toLargeInt _)" and
  (Haskell) "Prelude.toInteger"
| constant "integer_of_uint8_signed" \<rightharpoonup>
  (Scala) "BigInt"

section \<open>Quickcheck setup\<close>

definition uint8_of_natural :: "natural \<Rightarrow> uint8"
where "uint8_of_natural x \<equiv> Uint8 (integer_of_natural x)"

instantiation uint8 :: "{random, exhaustive, full_exhaustive}" begin
definition "random_uint8 \<equiv> qc_random_cnv uint8_of_natural"
definition "exhaustive_uint8 \<equiv> qc_exhaustive_cnv uint8_of_natural"
definition "full_exhaustive_uint8 \<equiv> qc_full_exhaustive_cnv uint8_of_natural"
instance ..
end

instantiation uint8 :: narrowing begin

interpretation quickcheck_narrowing_samples
  "\<lambda>i. let x = Uint8 i in (x, 0xFF - x)" "0"
  "Typerep.Typerep (STR ''Uint8.uint8'') []" .

definition "narrowing_uint8 d = qc_narrowing_drawn_from (narrowing_samples d) d"
declare [[code drop: "partial_term_of :: uint8 itself \<Rightarrow> _"]]
lemmas partial_term_of_uint8 [code] = partial_term_of_code

instance ..
end

no_notation sshiftr_uint8 (infixl ">>>" 55)

end