(*  Title:      ZF/OrderType.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section{*Order Types and Ordinal Arithmetic*}

theory OrderType imports OrderArith OrdQuant Nat_ZF begin

text{*The order type of a well-ordering is the least ordinal isomorphic to it.
Ordinal arithmetic is traditionally defined in terms of order types, as it is
here.  But a definition by transfinite recursion would be much simpler!*}

definition
  ordermap  :: "[i,i]=>i"  where
   "ordermap(A,r) == \<lambda>x\<in>A. wfrec[A](r, x, %x f. f `` pred(A,x,r))"

definition
  ordertype :: "[i,i]=>i"  where
   "ordertype(A,r) == ordermap(A,r)``A"

definition
  (*alternative definition of ordinal numbers*)
  Ord_alt   :: "i => o"  where
   "Ord_alt(X) == well_ord(X, Memrel(X)) & (\<forall>u\<in>X. u=pred(X, u, Memrel(X)))"

definition
  (*coercion to ordinal: if not, just 0*)
  ordify    :: "i=>i"  where
    "ordify(x) == if Ord(x) then x else 0"

definition
  (*ordinal multiplication*)
  omult      :: "[i,i]=>i"           (infixl "**" 70)  where
   "i ** j == ordertype(j*i, rmult(j,Memrel(j),i,Memrel(i)))"

definition
  (*ordinal addition*)
  raw_oadd   :: "[i,i]=>i"  where
    "raw_oadd(i,j) == ordertype(i+j, radd(i,Memrel(i),j,Memrel(j)))"

definition
  oadd      :: "[i,i]=>i"           (infixl "++" 65)  where
    "i ++ j == raw_oadd(ordify(i),ordify(j))"

definition
  (*ordinal subtraction*)
  odiff      :: "[i,i]=>i"           (infixl "--" 65)  where
    "i -- j == ordertype(i-j, Memrel(i))"

notation (xsymbols)
  omult  (infixl "\<times>\<times>" 70)

notation (HTML output)
  omult  (infixl "\<times>\<times>" 70)

subsection{*Proofs needing the combination of Ordinal.thy and Order.thy*}

lemma le_well_ord_Memrel: "j \<le> i ==> well_ord(j, Memrel(i))"
apply (rule well_ordI)
apply (rule wf_Memrel [THEN wf_imp_wf_on])
apply (simp add: ltD lt_Ord linear_def
                 ltI [THEN lt_trans2 [of _ j i]])
apply (intro ballI Ord_linear)
apply (blast intro: Ord_in_Ord lt_Ord)+
done

(*"Ord(i) ==> well_ord(i, Memrel(i))"*)
lemmas well_ord_Memrel = le_refl [THEN le_well_ord_Memrel]

(*Kunen's Theorem 7.3 (i), page 16;  see also Ordinal/Ord_in_Ord
  The smaller ordinal is an initial segment of the larger *)
lemma lt_pred_Memrel:
    "j<i ==> pred(i, j, Memrel(i)) = j"
apply (simp add: pred_def lt_def)
apply (blast intro: Ord_trans)
done

lemma pred_Memrel:
      "x \<in> A ==> pred(A, x, Memrel(A)) = A \<inter> x"
by (unfold pred_def Memrel_def, blast)

lemma Ord_iso_implies_eq_lemma:
     "[| j<i;  f \<in> ord_iso(i,Memrel(i),j,Memrel(j)) |] ==> R"
apply (frule lt_pred_Memrel)
apply (erule ltE)
apply (rule well_ord_Memrel [THEN well_ord_iso_predE, of i f j], auto)
apply (unfold ord_iso_def)
(*Combining the two simplifications causes looping*)
apply (simp (no_asm_simp))
apply (blast intro: bij_is_fun [THEN apply_type] Ord_trans)
done

(*Kunen's Theorem 7.3 (ii), page 16.  Isomorphic ordinals are equal*)
lemma Ord_iso_implies_eq:
     "[| Ord(i);  Ord(j);  f \<in> ord_iso(i,Memrel(i),j,Memrel(j)) |]
      ==> i=j"
apply (rule_tac i = i and j = j in Ord_linear_lt)
apply (blast intro: ord_iso_sym Ord_iso_implies_eq_lemma)+
done

subsection{*Ordermap and ordertype*}

lemma ordermap_type:
    "ordermap(A,r) \<in> A -> ordertype(A,r)"
apply (unfold ordermap_def ordertype_def)
apply (rule lam_type)
apply (rule lamI [THEN imageI], assumption+)
done

subsubsection{*Unfolding of ordermap *}

(*Useful for cardinality reasoning; see CardinalArith.ML*)
lemma ordermap_eq_image:
    "[| wf[A](r);  x \<in> A |]
     ==> ordermap(A,r) ` x = ordermap(A,r) `` pred(A,x,r)"
apply (unfold ordermap_def pred_def)
apply (simp (no_asm_simp))
apply (erule wfrec_on [THEN trans], assumption)
apply (simp (no_asm_simp) add: subset_iff image_lam vimage_singleton_iff)
done

(*Useful for rewriting PROVIDED pred is not unfolded until later!*)
lemma ordermap_pred_unfold:
     "[| wf[A](r);  x \<in> A |]
      ==> ordermap(A,r) ` x = {ordermap(A,r)`y . y \<in> pred(A,x,r)}"
by (simp add: ordermap_eq_image pred_subset ordermap_type [THEN image_fun])

(*pred-unfolded version.  NOT suitable for rewriting -- loops!*)
lemmas ordermap_unfold = ordermap_pred_unfold [simplified pred_def]

(*The theorem above is

[| wf[A](r); x \<in> A |]
==> ordermap(A,r) ` x = {ordermap(A,r) ` y . y: {y \<in> A . <y,x> \<in> r}}

NOTE: the definition of ordermap used here delivers ordinals only if r is
transitive.  If r is the predecessor relation on the naturals then
ordermap(nat,predr) ` n equals {n-1} and not n.  A more complicated definition,
like

  ordermap(A,r) ` x = Union{succ(ordermap(A,r) ` y) . y: {y \<in> A . <y,x> \<in> r}},

might eliminate the need for r to be transitive.
*)

subsubsection{*Showing that ordermap, ordertype yield ordinals *}

lemma Ord_ordermap:
    "[| well_ord(A,r);  x \<in> A |] ==> Ord(ordermap(A,r) ` x)"
apply (unfold well_ord_def tot_ord_def part_ord_def, safe)
apply (rule_tac a=x in wf_on_induct, assumption+)
apply (simp (no_asm_simp) add: ordermap_pred_unfold)
apply (rule OrdI [OF _ Ord_is_Transset])
apply (unfold pred_def Transset_def)
apply (blast intro: trans_onD
             dest!: ordermap_unfold [THEN equalityD1])+
done

lemma Ord_ordertype:
    "well_ord(A,r) ==> Ord(ordertype(A,r))"
apply (unfold ordertype_def)
apply (subst image_fun [OF ordermap_type subset_refl])
apply (rule OrdI [OF _ Ord_is_Transset])
prefer 2 apply (blast intro: Ord_ordermap)
apply (unfold Transset_def well_ord_def)
apply (blast intro: trans_onD
             dest!: ordermap_unfold [THEN equalityD1])
done

subsubsection{*ordermap preserves the orderings in both directions *}

lemma ordermap_mono:
     "[| <w,x>: r;  wf[A](r);  w \<in> A; x \<in> A |]
      ==> ordermap(A,r)`w \<in> ordermap(A,r)`x"
apply (erule_tac x1 = x in ordermap_unfold [THEN ssubst], assumption, blast)
done

(*linearity of r is crucial here*)
lemma converse_ordermap_mono:
    "[| ordermap(A,r)`w \<in> ordermap(A,r)`x;  well_ord(A,r); w \<in> A; x \<in> A |]
     ==> <w,x>: r"
apply (unfold well_ord_def tot_ord_def, safe)
apply (erule_tac x=w and y=x in linearE, assumption+)
apply (blast elim!: mem_not_refl [THEN notE])
apply (blast dest: ordermap_mono intro: mem_asym)
done

lemmas ordermap_surj =
    ordermap_type [THEN surj_image, unfolded ordertype_def [symmetric]]

lemma ordermap_bij:
    "well_ord(A,r) ==> ordermap(A,r) \<in> bij(A, ordertype(A,r))"
apply (unfold well_ord_def tot_ord_def bij_def inj_def)
apply (force intro!: ordermap_type ordermap_surj
             elim: linearE dest: ordermap_mono
             simp add: mem_not_refl)
done

subsubsection{*Isomorphisms involving ordertype *}

lemma ordertype_ord_iso:
 "well_ord(A,r)
  ==> ordermap(A,r) \<in> ord_iso(A,r, ordertype(A,r), Memrel(ordertype(A,r)))"
apply (unfold ord_iso_def)
apply (safe elim!: well_ord_is_wf
            intro!: ordermap_type [THEN apply_type] ordermap_mono ordermap_bij)
apply (blast dest!: converse_ordermap_mono)
done

lemma ordertype_eq:
     "[| f \<in> ord_iso(A,r,B,s);  well_ord(B,s) |]
      ==> ordertype(A,r) = ordertype(B,s)"
apply (frule well_ord_ord_iso, assumption)
apply (rule Ord_iso_implies_eq, (erule Ord_ordertype)+)
apply (blast intro: ord_iso_trans ord_iso_sym ordertype_ord_iso)
done

lemma ordertype_eq_imp_ord_iso:
     "[| ordertype(A,r) = ordertype(B,s); well_ord(A,r);  well_ord(B,s) |]
      ==> \<exists>f. f \<in> ord_iso(A,r,B,s)"
apply (rule exI)
apply (rule ordertype_ord_iso [THEN ord_iso_trans], assumption)
apply (erule ssubst)
apply (erule ordertype_ord_iso [THEN ord_iso_sym])
done

subsubsection{*Basic equalities for ordertype *}

(*Ordertype of Memrel*)
lemma le_ordertype_Memrel: "j \<le> i ==> ordertype(j,Memrel(i)) = j"
apply (rule Ord_iso_implies_eq [symmetric])
apply (erule ltE, assumption)
apply (blast intro: le_well_ord_Memrel Ord_ordertype)
apply (rule ord_iso_trans)
apply (erule_tac [2] le_well_ord_Memrel [THEN ordertype_ord_iso])
apply (rule id_bij [THEN ord_isoI])
apply (simp (no_asm_simp))
apply (fast elim: ltE Ord_in_Ord Ord_trans)
done

(*"Ord(i) ==> ordertype(i, Memrel(i)) = i"*)
lemmas ordertype_Memrel = le_refl [THEN le_ordertype_Memrel]

lemma ordertype_0 [simp]: "ordertype(0,r) = 0"
apply (rule id_bij [THEN ord_isoI, THEN ordertype_eq, THEN trans])
apply (erule emptyE)
apply (rule well_ord_0)
apply (rule Ord_0 [THEN ordertype_Memrel])
done

(*Ordertype of rvimage:  [| f \<in> bij(A,B);  well_ord(B,s) |] ==>
                         ordertype(A, rvimage(A,f,s)) = ordertype(B,s) *)
lemmas bij_ordertype_vimage = ord_iso_rvimage [THEN ordertype_eq]

subsubsection{*A fundamental unfolding law for ordertype. *}

(*Ordermap returns the same result if applied to an initial segment*)
lemma ordermap_pred_eq_ordermap:
     "[| well_ord(A,r);  y \<in> A;  z \<in> pred(A,y,r) |]
      ==> ordermap(pred(A,y,r), r) ` z = ordermap(A, r) ` z"
apply (frule wf_on_subset_A [OF well_ord_is_wf pred_subset])
apply (rule_tac a=z in wf_on_induct, assumption+)
apply (safe elim!: predE)
apply (simp (no_asm_simp) add: ordermap_pred_unfold well_ord_is_wf pred_iff)
(*combining these two simplifications LOOPS! *)
apply (simp (no_asm_simp) add: pred_pred_eq)
apply (simp add: pred_def)
apply (rule RepFun_cong [OF _ refl])
apply (drule well_ord_is_trans_on)
apply (fast elim!: trans_onD)
done

lemma ordertype_unfold:
    "ordertype(A,r) = {ordermap(A,r)`y . y \<in> A}"
apply (unfold ordertype_def)
apply (rule image_fun [OF ordermap_type subset_refl])
done

text{*Theorems by Krzysztof Grabczewski; proofs simplified by lcp *}

lemma ordertype_pred_subset: "[| well_ord(A,r);  x \<in> A |] ==>
          ordertype(pred(A,x,r),r) \<subseteq> ordertype(A,r)"
apply (simp add: ordertype_unfold well_ord_subset [OF _ pred_subset])
apply (fast intro: ordermap_pred_eq_ordermap elim: predE)
done

lemma ordertype_pred_lt:
     "[| well_ord(A,r);  x \<in> A |]
      ==> ordertype(pred(A,x,r),r) < ordertype(A,r)"
apply (rule ordertype_pred_subset [THEN subset_imp_le, THEN leE])
apply (simp_all add: Ord_ordertype well_ord_subset [OF _ pred_subset])
apply (erule sym [THEN ordertype_eq_imp_ord_iso, THEN exE])
apply (erule_tac [3] well_ord_iso_predE)
apply (simp_all add: well_ord_subset [OF _ pred_subset])
done

(*May rewrite with this -- provided no rules are supplied for proving that
        well_ord(pred(A,x,r), r) *)
lemma ordertype_pred_unfold:
     "well_ord(A,r)
      ==> ordertype(A,r) = {ordertype(pred(A,x,r),r). x \<in> A}"
apply (rule equalityI)
apply (safe intro!: ordertype_pred_lt [THEN ltD])
apply (auto simp add: ordertype_def well_ord_is_wf [THEN ordermap_eq_image]
                      ordermap_type [THEN image_fun]
                      ordermap_pred_eq_ordermap pred_subset)
done

subsection{*Alternative definition of ordinal*}

(*proof by Krzysztof Grabczewski*)
lemma Ord_is_Ord_alt: "Ord(i) ==> Ord_alt(i)"
apply (unfold Ord_alt_def)
apply (rule conjI)
apply (erule well_ord_Memrel)
apply (unfold Ord_def Transset_def pred_def Memrel_def, blast)
done

(*proof by lcp*)
lemma Ord_alt_is_Ord:
    "Ord_alt(i) ==> Ord(i)"
apply (unfold Ord_alt_def Ord_def Transset_def well_ord_def
                     tot_ord_def part_ord_def trans_on_def)
apply (simp add: pred_Memrel)
apply (blast elim!: equalityE)
done

subsection{*Ordinal Addition*}

subsubsection{*Order Type calculations for radd *}

text{*Addition with 0 *}

lemma bij_sum_0: "(\<lambda>z\<in>A+0. case(%x. x, %y. y, z)) \<in> bij(A+0, A)"
apply (rule_tac d = Inl in lam_bijective, safe)
apply (simp_all (no_asm_simp))
done

lemma ordertype_sum_0_eq:
     "well_ord(A,r) ==> ordertype(A+0, radd(A,r,0,s)) = ordertype(A,r)"
apply (rule bij_sum_0 [THEN ord_isoI, THEN ordertype_eq])
prefer 2 apply assumption
apply force
done

lemma bij_0_sum: "(\<lambda>z\<in>0+A. case(%x. x, %y. y, z)) \<in> bij(0+A, A)"
apply (rule_tac d = Inr in lam_bijective, safe)
apply (simp_all (no_asm_simp))
done

lemma ordertype_0_sum_eq:
     "well_ord(A,r) ==> ordertype(0+A, radd(0,s,A,r)) = ordertype(A,r)"
apply (rule bij_0_sum [THEN ord_isoI, THEN ordertype_eq])
prefer 2 apply assumption
apply force
done

text{*Initial segments of radd.  Statements by Grabczewski *}

(*In fact, pred(A+B, Inl(a), radd(A,r,B,s)) = pred(A,a,r)+0 *)
lemma pred_Inl_bij:
 "a \<in> A ==> (\<lambda>x\<in>pred(A,a,r). Inl(x))
          \<in> bij(pred(A,a,r), pred(A+B, Inl(a), radd(A,r,B,s)))"
apply (unfold pred_def)
apply (rule_tac d = "case (%x. x, %y. y) " in lam_bijective)
apply auto
done

lemma ordertype_pred_Inl_eq:
     "[| a \<in> A;  well_ord(A,r) |]
      ==> ordertype(pred(A+B, Inl(a), radd(A,r,B,s)), radd(A,r,B,s)) =
          ordertype(pred(A,a,r), r)"
apply (rule pred_Inl_bij [THEN ord_isoI, THEN ord_iso_sym, THEN ordertype_eq])
apply (simp_all add: well_ord_subset [OF _ pred_subset])
apply (simp add: pred_def)
done

lemma pred_Inr_bij:
 "b \<in> B ==>
         id(A+pred(B,b,s))
         \<in> bij(A+pred(B,b,s), pred(A+B, Inr(b), radd(A,r,B,s)))"
apply (unfold pred_def id_def)
apply (rule_tac d = "%z. z" in lam_bijective, auto)
done

lemma ordertype_pred_Inr_eq:
     "[| b \<in> B;  well_ord(A,r);  well_ord(B,s) |]
      ==> ordertype(pred(A+B, Inr(b), radd(A,r,B,s)), radd(A,r,B,s)) =
          ordertype(A+pred(B,b,s), radd(A,r,pred(B,b,s),s))"
apply (rule pred_Inr_bij [THEN ord_isoI, THEN ord_iso_sym, THEN ordertype_eq])
prefer 2 apply (force simp add: pred_def id_def, assumption)
apply (blast intro: well_ord_radd well_ord_subset [OF _ pred_subset])
done

subsubsection{*ordify: trivial coercion to an ordinal *}

lemma Ord_ordify [iff, TC]: "Ord(ordify(x))"
by (simp add: ordify_def)

(*Collapsing*)
lemma ordify_idem [simp]: "ordify(ordify(x)) = ordify(x)"
by (simp add: ordify_def)

subsubsection{*Basic laws for ordinal addition *}

lemma Ord_raw_oadd: "[|Ord(i); Ord(j)|] ==> Ord(raw_oadd(i,j))"
by (simp add: raw_oadd_def ordify_def Ord_ordertype well_ord_radd
              well_ord_Memrel)

lemma Ord_oadd [iff,TC]: "Ord(i++j)"
by (simp add: oadd_def Ord_raw_oadd)

text{*Ordinal addition with zero *}

lemma raw_oadd_0: "Ord(i) ==> raw_oadd(i,0) = i"
by (simp add: raw_oadd_def ordify_def ordertype_sum_0_eq
              ordertype_Memrel well_ord_Memrel)

lemma oadd_0 [simp]: "Ord(i) ==> i++0 = i"
apply (simp (no_asm_simp) add: oadd_def raw_oadd_0 ordify_def)
done

lemma raw_oadd_0_left: "Ord(i) ==> raw_oadd(0,i) = i"
by (simp add: raw_oadd_def ordify_def ordertype_0_sum_eq ordertype_Memrel
              well_ord_Memrel)

lemma oadd_0_left [simp]: "Ord(i) ==> 0++i = i"
by (simp add: oadd_def raw_oadd_0_left ordify_def)

lemma oadd_eq_if_raw_oadd:
     "i++j = (if Ord(i) then (if Ord(j) then raw_oadd(i,j) else i)
              else (if Ord(j) then j else 0))"
by (simp add: oadd_def ordify_def raw_oadd_0_left raw_oadd_0)

lemma raw_oadd_eq_oadd: "[|Ord(i); Ord(j)|] ==> raw_oadd(i,j) = i++j"
by (simp add: oadd_def ordify_def)

(*** Further properties of ordinal addition.  Statements by Grabczewski,
    proofs by lcp. ***)

(*Surely also provable by transfinite induction on j?*)
lemma lt_oadd1: "k<i ==> k < i++j"
apply (simp add: oadd_def ordify_def lt_Ord2 raw_oadd_0, clarify)
apply (simp add: raw_oadd_def)
apply (rule ltE, assumption)
apply (rule ltI)
apply (force simp add: ordertype_pred_unfold well_ord_radd well_ord_Memrel
          ordertype_pred_Inl_eq lt_pred_Memrel leI [THEN le_ordertype_Memrel])
apply (blast intro: Ord_ordertype well_ord_radd well_ord_Memrel)
done

(*Thus also we obtain the rule  @{term"i++j = k ==> i \<le> k"} *)
lemma oadd_le_self: "Ord(i) ==> i \<le> i++j"
apply (rule all_lt_imp_le)
apply (auto simp add: Ord_oadd lt_oadd1)
done

text{*Various other results *}

lemma id_ord_iso_Memrel: "A<=B ==> id(A) \<in> ord_iso(A, Memrel(A), A, Memrel(B))"
apply (rule id_bij [THEN ord_isoI])
apply (simp (no_asm_simp))
apply blast
done

lemma subset_ord_iso_Memrel:
     "[| f \<in> ord_iso(A,Memrel(B),C,r); A<=B |] ==> f \<in> ord_iso(A,Memrel(A),C,r)"
apply (frule ord_iso_is_bij [THEN bij_is_fun, THEN fun_is_rel])
apply (frule ord_iso_trans [OF id_ord_iso_Memrel], assumption)
apply (simp add: right_comp_id)
done

lemma restrict_ord_iso:
     "[| f \<in> ord_iso(i, Memrel(i), Order.pred(A,a,r), r);  a \<in> A; j < i;
       trans[A](r) |]
      ==> restrict(f,j) \<in> ord_iso(j, Memrel(j), Order.pred(A,f`j,r), r)"
apply (frule ltD)
apply (frule ord_iso_is_bij [THEN bij_is_fun, THEN apply_type], assumption)
apply (frule ord_iso_restrict_pred, assumption)
apply (simp add: pred_iff trans_pred_pred_eq lt_pred_Memrel)
apply (blast intro!: subset_ord_iso_Memrel le_imp_subset [OF leI])
done

lemma restrict_ord_iso2:
     "[| f \<in> ord_iso(Order.pred(A,a,r), r, i, Memrel(i));  a \<in> A;
       j < i; trans[A](r) |]
      ==> converse(restrict(converse(f), j))
          \<in> ord_iso(Order.pred(A, converse(f)`j, r), r, j, Memrel(j))"
by (blast intro: restrict_ord_iso ord_iso_sym ltI)

lemma ordertype_sum_Memrel:
     "[| well_ord(A,r);  k<j |]
      ==> ordertype(A+k, radd(A, r, k, Memrel(j))) =
          ordertype(A+k, radd(A, r, k, Memrel(k)))"
apply (erule ltE)
apply (rule ord_iso_refl [THEN sum_ord_iso_cong, THEN ordertype_eq])
apply (erule OrdmemD [THEN id_ord_iso_Memrel, THEN ord_iso_sym])
apply (simp_all add: well_ord_radd well_ord_Memrel)
done

lemma oadd_lt_mono2: "k<j ==> i++k < i++j"
apply (simp add: oadd_def ordify_def raw_oadd_0_left lt_Ord lt_Ord2, clarify)
apply (simp add: raw_oadd_def)
apply (rule ltE, assumption)
apply (rule ordertype_pred_unfold [THEN equalityD2, THEN subsetD, THEN ltI])
apply (simp_all add: Ord_ordertype well_ord_radd well_ord_Memrel)
apply (rule bexI)
apply (erule_tac [2] InrI)
apply (simp add: ordertype_pred_Inr_eq well_ord_Memrel lt_pred_Memrel
                 leI [THEN le_ordertype_Memrel] ordertype_sum_Memrel)
done

lemma oadd_lt_cancel2: "[| i++j < i++k;  Ord(j) |] ==> j<k"
apply (simp (asm_lr) add: oadd_eq_if_raw_oadd split add: split_if_asm)
 prefer 2
 apply (frule_tac i = i and j = j in oadd_le_self)
 apply (simp (asm_lr) add: oadd_def ordify_def lt_Ord not_lt_iff_le [THEN iff_sym])
apply (rule Ord_linear_lt, auto)
apply (simp_all add: raw_oadd_eq_oadd)
apply (blast dest: oadd_lt_mono2 elim: lt_irrefl lt_asym)+
done

lemma oadd_lt_iff2: "Ord(j) ==> i++j < i++k \<longleftrightarrow> j<k"
by (blast intro!: oadd_lt_mono2 dest!: oadd_lt_cancel2)

lemma oadd_inject: "[| i++j = i++k;  Ord(j); Ord(k) |] ==> j=k"
apply (simp add: oadd_eq_if_raw_oadd split add: split_if_asm)
apply (simp add: raw_oadd_eq_oadd)
apply (rule Ord_linear_lt, auto)
apply (force dest: oadd_lt_mono2 [of concl: i] simp add: lt_not_refl)+
done

lemma lt_oadd_disj: "k < i++j ==> k<i | (\<exists>l\<in>j. k = i++l )"
apply (simp add: Ord_in_Ord' [of _ j] oadd_eq_if_raw_oadd
            split add: split_if_asm)
 prefer 2
 apply (simp add: Ord_in_Ord' [of _ j] lt_def)
apply (simp add: ordertype_pred_unfold well_ord_radd well_ord_Memrel raw_oadd_def)
apply (erule ltD [THEN RepFunE])
apply (force simp add: ordertype_pred_Inl_eq well_ord_Memrel ltI
                       lt_pred_Memrel le_ordertype_Memrel leI
                       ordertype_pred_Inr_eq ordertype_sum_Memrel)
done

subsubsection{*Ordinal addition with successor -- via associativity! *}

lemma oadd_assoc: "(i++j)++k = i++(j++k)"
apply (simp add: oadd_eq_if_raw_oadd Ord_raw_oadd raw_oadd_0 raw_oadd_0_left, clarify)
apply (simp add: raw_oadd_def)
apply (rule ordertype_eq [THEN trans])
apply (rule sum_ord_iso_cong [OF ordertype_ord_iso [THEN ord_iso_sym]
                                 ord_iso_refl])
apply (simp_all add: Ord_ordertype well_ord_radd well_ord_Memrel)
apply (rule sum_assoc_ord_iso [THEN ordertype_eq, THEN trans])
apply (rule_tac [2] ordertype_eq)
apply (rule_tac [2] sum_ord_iso_cong [OF ord_iso_refl ordertype_ord_iso])
apply (blast intro: Ord_ordertype well_ord_radd well_ord_Memrel)+
done

lemma oadd_unfold: "[| Ord(i);  Ord(j) |] ==> i++j = i \<union> (\<Union>k\<in>j. {i++k})"
apply (rule subsetI [THEN equalityI])
apply (erule ltI [THEN lt_oadd_disj, THEN disjE])
apply (blast intro: Ord_oadd)
apply (blast elim!: ltE, blast)
apply (force intro: lt_oadd1 oadd_lt_mono2 simp add: Ord_mem_iff_lt)
done

lemma oadd_1: "Ord(i) ==> i++1 = succ(i)"
apply (simp (no_asm_simp) add: oadd_unfold Ord_1 oadd_0)
apply blast
done

lemma oadd_succ [simp]: "Ord(j) ==> i++succ(j) = succ(i++j)"
apply (simp add: oadd_eq_if_raw_oadd, clarify)
apply (simp add: raw_oadd_eq_oadd)
apply (simp add: oadd_1 [of j, symmetric] oadd_1 [of "i++j", symmetric]
                 oadd_assoc)
done

text{*Ordinal addition with limit ordinals *}

lemma oadd_UN:
     "[| !!x. x \<in> A ==> Ord(j(x));  a \<in> A |]
      ==> i ++ (\<Union>x\<in>A. j(x)) = (\<Union>x\<in>A. i++j(x))"
by (blast intro: ltI Ord_UN Ord_oadd lt_oadd1 [THEN ltD]
                 oadd_lt_mono2 [THEN ltD]
          elim!: ltE dest!: ltI [THEN lt_oadd_disj])

lemma oadd_Limit: "Limit(j) ==> i++j = (\<Union>k\<in>j. i++k)"
apply (frule Limit_has_0 [THEN ltD])
apply (simp add: Limit_is_Ord [THEN Ord_in_Ord] oadd_UN [symmetric]
                 Union_eq_UN [symmetric] Limit_Union_eq)
done

lemma oadd_eq_0_iff: "[| Ord(i); Ord(j) |] ==> (i ++ j) = 0 \<longleftrightarrow> i=0 & j=0"
apply (erule trans_induct3 [of j])
apply (simp_all add: oadd_Limit)
apply (simp add: Union_empty_iff Limit_def lt_def, blast)
done

lemma oadd_eq_lt_iff: "[| Ord(i); Ord(j) |] ==> 0 < (i ++ j) \<longleftrightarrow> 0<i | 0<j"
by (simp add: Ord_0_lt_iff [symmetric] oadd_eq_0_iff)

lemma oadd_LimitI: "[| Ord(i); Limit(j) |] ==> Limit(i ++ j)"
apply (simp add: oadd_Limit)
apply (frule Limit_has_1 [THEN ltD])
apply (rule increasing_LimitI)
 apply (rule Ord_0_lt)
  apply (blast intro: Ord_in_Ord [OF Limit_is_Ord])
 apply (force simp add: Union_empty_iff oadd_eq_0_iff
                        Limit_is_Ord [of j, THEN Ord_in_Ord], auto)
apply (rule_tac x="succ(y)" in bexI)
 apply (simp add: ltI Limit_is_Ord [of j, THEN Ord_in_Ord])
apply (simp add: Limit_def lt_def)
done

text{*Order/monotonicity properties of ordinal addition *}

lemma oadd_le_self2: "Ord(i) ==> i \<le> j++i"
proof (induct i rule: trans_induct3)
  case 0 thus ?case by (simp add: Ord_0_le)
next
  case (succ i) thus ?case by (simp add: oadd_succ succ_leI)
next
  case (limit l)
  hence "l = (\<Union>x\<in>l. x)"
    by (simp add: Union_eq_UN [symmetric] Limit_Union_eq)
  also have "... \<le> (\<Union>x\<in>l. j++x)"
    by (rule le_implies_UN_le_UN) (rule limit.hyps)
  finally have "l \<le> (\<Union>x\<in>l. j++x)" .
  thus ?case using limit.hyps by (simp add: oadd_Limit)
qed

lemma oadd_le_mono1: "k \<le> j ==> k++i \<le> j++i"
apply (frule lt_Ord)
apply (frule le_Ord2)
apply (simp add: oadd_eq_if_raw_oadd, clarify)
apply (simp add: raw_oadd_eq_oadd)
apply (erule_tac i = i in trans_induct3)
apply (simp (no_asm_simp))
apply (simp (no_asm_simp) add: oadd_succ succ_le_iff)
apply (simp (no_asm_simp) add: oadd_Limit)
apply (rule le_implies_UN_le_UN, blast)
done

lemma oadd_lt_mono: "[| i' \<le> i;  j'<j |] ==> i'++j' < i++j"
by (blast intro: lt_trans1 oadd_le_mono1 oadd_lt_mono2 Ord_succD elim: ltE)

lemma oadd_le_mono: "[| i' \<le> i;  j' \<le> j |] ==> i'++j' \<le> i++j"
by (simp del: oadd_succ add: oadd_succ [symmetric] le_Ord2 oadd_lt_mono)

lemma oadd_le_iff2: "[| Ord(j); Ord(k) |] ==> i++j \<le> i++k \<longleftrightarrow> j \<le> k"
by (simp del: oadd_succ add: oadd_lt_iff2 oadd_succ [symmetric] Ord_succ)

lemma oadd_lt_self: "[| Ord(i);  0<j |] ==> i < i++j"
apply (rule lt_trans2)
apply (erule le_refl)
apply (simp only: lt_Ord2  oadd_1 [of i, symmetric])
apply (blast intro: succ_leI oadd_le_mono)
done

text{*Every ordinal is exceeded by some limit ordinal.*}
lemma Ord_imp_greater_Limit: "Ord(i) ==> \<exists>k. i<k & Limit(k)"
apply (rule_tac x="i ++ nat" in exI)
apply (blast intro: oadd_LimitI  oadd_lt_self  Limit_nat [THEN Limit_has_0])
done

lemma Ord2_imp_greater_Limit: "[|Ord(i); Ord(j)|] ==> \<exists>k. i<k & j<k & Limit(k)"
apply (insert Ord_Un [of i j, THEN Ord_imp_greater_Limit])
apply (simp add: Un_least_lt_iff)
done

subsection{*Ordinal Subtraction*}

text{*The difference is @{term "ordertype(j-i, Memrel(j))"}.
    It's probably simpler to define the difference recursively!*}

lemma bij_sum_Diff:
     "A<=B ==> (\<lambda>y\<in>B. if(y \<in> A, Inl(y), Inr(y))) \<in> bij(B, A+(B-A))"
apply (rule_tac d = "case (%x. x, %y. y) " in lam_bijective)
apply (blast intro!: if_type)
apply (fast intro!: case_type)
apply (erule_tac [2] sumE)
apply (simp_all (no_asm_simp))
done

lemma ordertype_sum_Diff:
     "i \<le> j ==>
            ordertype(i+(j-i), radd(i,Memrel(j),j-i,Memrel(j))) =
            ordertype(j, Memrel(j))"
apply (safe dest!: le_subset_iff [THEN iffD1])
apply (rule bij_sum_Diff [THEN ord_isoI, THEN ord_iso_sym, THEN ordertype_eq])
apply (erule_tac [3] well_ord_Memrel, assumption)
apply (simp (no_asm_simp))
apply (frule_tac j = y in Ord_in_Ord, assumption)
apply (frule_tac j = x in Ord_in_Ord, assumption)
apply (simp (no_asm_simp) add: Ord_mem_iff_lt lt_Ord not_lt_iff_le)
apply (blast intro: lt_trans2 lt_trans)
done

lemma Ord_odiff [simp,TC]:
    "[| Ord(i);  Ord(j) |] ==> Ord(i--j)"
apply (unfold odiff_def)
apply (blast intro: Ord_ordertype Diff_subset well_ord_subset well_ord_Memrel)
done

lemma raw_oadd_ordertype_Diff:
   "i \<le> j
    ==> raw_oadd(i,j--i) = ordertype(i+(j-i), radd(i,Memrel(j),j-i,Memrel(j)))"
apply (simp add: raw_oadd_def odiff_def)
apply (safe dest!: le_subset_iff [THEN iffD1])
apply (rule sum_ord_iso_cong [THEN ordertype_eq])
apply (erule id_ord_iso_Memrel)
apply (rule ordertype_ord_iso [THEN ord_iso_sym])
apply (blast intro: well_ord_radd Diff_subset well_ord_subset well_ord_Memrel)+
done

lemma oadd_odiff_inverse: "i \<le> j ==> i ++ (j--i) = j"
by (simp add: lt_Ord le_Ord2 oadd_def ordify_def raw_oadd_ordertype_Diff
              ordertype_sum_Diff ordertype_Memrel lt_Ord2 [THEN Ord_succD])

(*By oadd_inject, the difference between i and j is unique.  Note that we get
  i++j = k  ==>  j = k--i.  *)
lemma odiff_oadd_inverse: "[| Ord(i); Ord(j) |] ==> (i++j) -- i = j"
apply (rule oadd_inject)
apply (blast intro: oadd_odiff_inverse oadd_le_self)
apply (blast intro: Ord_ordertype Ord_oadd Ord_odiff)+
done

lemma odiff_lt_mono2: "[| i<j;  k \<le> i |] ==> i--k < j--k"
apply (rule_tac i = k in oadd_lt_cancel2)
apply (simp add: oadd_odiff_inverse)
apply (subst oadd_odiff_inverse)
apply (blast intro: le_trans leI, assumption)
apply (simp (no_asm_simp) add: lt_Ord le_Ord2)
done

subsection{*Ordinal Multiplication*}

lemma Ord_omult [simp,TC]:
    "[| Ord(i);  Ord(j) |] ==> Ord(i**j)"
apply (unfold omult_def)
apply (blast intro: Ord_ordertype well_ord_rmult well_ord_Memrel)
done

subsubsection{*A useful unfolding law *}

lemma pred_Pair_eq:
 "[| a \<in> A;  b \<in> B |] ==> pred(A*B, <a,b>, rmult(A,r,B,s)) =
                      pred(A,a,r)*B \<union> ({a} * pred(B,b,s))"
apply (unfold pred_def, blast)
done

lemma ordertype_pred_Pair_eq:
     "[| a \<in> A;  b \<in> B;  well_ord(A,r);  well_ord(B,s) |] ==>
         ordertype(pred(A*B, <a,b>, rmult(A,r,B,s)), rmult(A,r,B,s)) =
         ordertype(pred(A,a,r)*B + pred(B,b,s),
                  radd(A*B, rmult(A,r,B,s), B, s))"
apply (simp (no_asm_simp) add: pred_Pair_eq)
apply (rule ordertype_eq [symmetric])
apply (rule prod_sum_singleton_ord_iso)
apply (simp_all add: pred_subset well_ord_rmult [THEN well_ord_subset])
apply (blast intro: pred_subset well_ord_rmult [THEN well_ord_subset]
             elim!: predE)
done

lemma ordertype_pred_Pair_lemma:
    "[| i'<i;  j'<j |]
     ==> ordertype(pred(i*j, <i',j'>, rmult(i,Memrel(i),j,Memrel(j))),
                   rmult(i,Memrel(i),j,Memrel(j))) =
         raw_oadd (j**i', j')"
apply (unfold raw_oadd_def omult_def)
apply (simp add: ordertype_pred_Pair_eq lt_pred_Memrel ltD lt_Ord2
                 well_ord_Memrel)
apply (rule trans)
 apply (rule_tac [2] ordertype_ord_iso
                      [THEN sum_ord_iso_cong, THEN ordertype_eq])
  apply (rule_tac [3] ord_iso_refl)
apply (rule id_bij [THEN ord_isoI, THEN ordertype_eq])
apply (elim SigmaE sumE ltE ssubst)
apply (simp_all add: well_ord_rmult well_ord_radd well_ord_Memrel
                     Ord_ordertype lt_Ord lt_Ord2)
apply (blast intro: Ord_trans)+
done

lemma lt_omult:
 "[| Ord(i);  Ord(j);  k<j**i |]
  ==> \<exists>j' i'. k = j**i' ++ j' & j'<j & i'<i"
apply (unfold omult_def)
apply (simp add: ordertype_pred_unfold well_ord_rmult well_ord_Memrel)
apply (safe elim!: ltE)
apply (simp add: ordertype_pred_Pair_lemma ltI raw_oadd_eq_oadd
            omult_def [symmetric] Ord_in_Ord' [of _ i] Ord_in_Ord' [of _ j])
apply (blast intro: ltI)
done

lemma omult_oadd_lt:
     "[| j'<j;  i'<i |] ==> j**i' ++ j'  <  j**i"
apply (unfold omult_def)
apply (rule ltI)
 prefer 2
 apply (simp add: Ord_ordertype well_ord_rmult well_ord_Memrel lt_Ord2)
apply (simp add: ordertype_pred_unfold well_ord_rmult well_ord_Memrel lt_Ord2)
apply (rule bexI [of _ i'])
apply (rule bexI [of _ j'])
apply (simp add: ordertype_pred_Pair_lemma ltI omult_def [symmetric])
apply (simp add: lt_Ord lt_Ord2 raw_oadd_eq_oadd)
apply (simp_all add: lt_def)
done

lemma omult_unfold:
     "[| Ord(i);  Ord(j) |] ==> j**i = (\<Union>j'\<in>j. \<Union>i'\<in>i. {j**i' ++ j'})"
apply (rule subsetI [THEN equalityI])
apply (rule lt_omult [THEN exE])
apply (erule_tac [3] ltI)
apply (simp_all add: Ord_omult)
apply (blast elim!: ltE)
apply (blast intro: omult_oadd_lt [THEN ltD] ltI)
done

subsubsection{*Basic laws for ordinal multiplication *}

text{*Ordinal multiplication by zero *}

lemma omult_0 [simp]: "i**0 = 0"
apply (unfold omult_def)
apply (simp (no_asm_simp))
done

lemma omult_0_left [simp]: "0**i = 0"
apply (unfold omult_def)
apply (simp (no_asm_simp))
done

text{*Ordinal multiplication by 1 *}

lemma omult_1 [simp]: "Ord(i) ==> i**1 = i"
apply (unfold omult_def)
apply (rule_tac s1="Memrel(i)"
       in ord_isoI [THEN ordertype_eq, THEN trans])
apply (rule_tac c = snd and d = "%z.<0,z>"  in lam_bijective)
apply (auto elim!: snd_type well_ord_Memrel ordertype_Memrel)
done

lemma omult_1_left [simp]: "Ord(i) ==> 1**i = i"
apply (unfold omult_def)
apply (rule_tac s1="Memrel(i)"
       in ord_isoI [THEN ordertype_eq, THEN trans])
apply (rule_tac c = fst and d = "%z.<z,0>" in lam_bijective)
apply (auto elim!: fst_type well_ord_Memrel ordertype_Memrel)
done

text{*Distributive law for ordinal multiplication and addition *}

lemma oadd_omult_distrib:
     "[| Ord(i);  Ord(j);  Ord(k) |] ==> i**(j++k) = (i**j)++(i**k)"
apply (simp add: oadd_eq_if_raw_oadd)
apply (simp add: omult_def raw_oadd_def)
apply (rule ordertype_eq [THEN trans])
apply (rule prod_ord_iso_cong [OF ordertype_ord_iso [THEN ord_iso_sym]
                                  ord_iso_refl])
apply (simp_all add: well_ord_rmult well_ord_radd well_ord_Memrel
                     Ord_ordertype)
apply (rule sum_prod_distrib_ord_iso [THEN ordertype_eq, THEN trans])
apply (rule_tac [2] ordertype_eq)
apply (rule_tac [2] sum_ord_iso_cong [OF ordertype_ord_iso ordertype_ord_iso])
apply (simp_all add: well_ord_rmult well_ord_radd well_ord_Memrel
                     Ord_ordertype)
done

lemma omult_succ: "[| Ord(i);  Ord(j) |] ==> i**succ(j) = (i**j)++i"
by (simp del: oadd_succ add: oadd_1 [of j, symmetric] oadd_omult_distrib)

text{*Associative law *}

lemma omult_assoc:
    "[| Ord(i);  Ord(j);  Ord(k) |] ==> (i**j)**k = i**(j**k)"
apply (unfold omult_def)
apply (rule ordertype_eq [THEN trans])
apply (rule prod_ord_iso_cong [OF ord_iso_refl
                                  ordertype_ord_iso [THEN ord_iso_sym]])
apply (blast intro: well_ord_rmult well_ord_Memrel)+
apply (rule prod_assoc_ord_iso
             [THEN ord_iso_sym, THEN ordertype_eq, THEN trans])
apply (rule_tac [2] ordertype_eq)
apply (rule_tac [2] prod_ord_iso_cong [OF ordertype_ord_iso ord_iso_refl])
apply (blast intro: well_ord_rmult well_ord_Memrel Ord_ordertype)+
done

text{*Ordinal multiplication with limit ordinals *}

lemma omult_UN:
     "[| Ord(i);  !!x. x \<in> A ==> Ord(j(x)) |]
      ==> i ** (\<Union>x\<in>A. j(x)) = (\<Union>x\<in>A. i**j(x))"
by (simp (no_asm_simp) add: Ord_UN omult_unfold, blast)

lemma omult_Limit: "[| Ord(i);  Limit(j) |] ==> i**j = (\<Union>k\<in>j. i**k)"
by (simp add: Limit_is_Ord [THEN Ord_in_Ord] omult_UN [symmetric]
              Union_eq_UN [symmetric] Limit_Union_eq)

subsubsection{*Ordering/monotonicity properties of ordinal multiplication *}

(*As a special case we have "[| 0<i;  0<j |] ==> 0 < i**j" *)
lemma lt_omult1: "[| k<i;  0<j |] ==> k < i**j"
apply (safe elim!: ltE intro!: ltI Ord_omult)
apply (force simp add: omult_unfold)
done

lemma omult_le_self: "[| Ord(i);  0<j |] ==> i \<le> i**j"
by (blast intro: all_lt_imp_le Ord_omult lt_omult1 lt_Ord2)

lemma omult_le_mono1:
  assumes kj: "k \<le> j" and i: "Ord(i)" shows "k**i \<le> j**i"
proof -
  have o: "Ord(k)" "Ord(j)" by (rule lt_Ord [OF kj] le_Ord2 [OF kj])+
  show ?thesis using i
  proof (induct i rule: trans_induct3)
    case 0 thus ?case
      by simp
  next
    case (succ i) thus ?case
      by (simp add: o kj omult_succ oadd_le_mono)
  next
    case (limit l)
    thus ?case
      by (auto simp add: o kj omult_Limit le_implies_UN_le_UN)
  qed
qed

lemma omult_lt_mono2: "[| k<j;  0<i |] ==> i**k < i**j"
apply (rule ltI)
apply (simp (no_asm_simp) add: omult_unfold lt_Ord2)
apply (safe elim!: ltE intro!: Ord_omult)
apply (force simp add: Ord_omult)
done

lemma omult_le_mono2: "[| k \<le> j;  Ord(i) |] ==> i**k \<le> i**j"
apply (rule subset_imp_le)
apply (safe elim!: ltE dest!: Ord_succD intro!: Ord_omult)
apply (simp add: omult_unfold)
apply (blast intro: Ord_trans)
done

lemma omult_le_mono: "[| i' \<le> i;  j' \<le> j |] ==> i'**j' \<le> i**j"
by (blast intro: le_trans omult_le_mono1 omult_le_mono2 Ord_succD elim: ltE)

lemma omult_lt_mono: "[| i' \<le> i;  j'<j;  0<i |] ==> i'**j' < i**j"
by (blast intro: lt_trans1 omult_le_mono1 omult_lt_mono2 Ord_succD elim: ltE)

lemma omult_le_self2:
  assumes i: "Ord(i)" and j: "0<j" shows "i \<le> j**i"
proof -
  have oj: "Ord(j)" by (rule lt_Ord2 [OF j])
  show ?thesis using i
  proof (induct i rule: trans_induct3)
    case 0 thus ?case
      by simp
  next
    case (succ i)
    have "j \<times>\<times> i ++ 0 < j \<times>\<times> i ++ j"
      by (rule oadd_lt_mono2 [OF j])
    with succ.hyps show ?case
      by (simp add: oj j omult_succ ) (rule lt_trans1)
  next
    case (limit l)
    hence "l = (\<Union>x\<in>l. x)"
      by (simp add: Union_eq_UN [symmetric] Limit_Union_eq)
    also have "... \<le> (\<Union>x\<in>l. j**x)"
      by (rule le_implies_UN_le_UN) (rule limit.hyps)
    finally have "l \<le> (\<Union>x\<in>l. j**x)" .
    thus ?case using limit.hyps by (simp add: oj omult_Limit)
  qed
qed

text{*Further properties of ordinal multiplication *}

lemma omult_inject: "[| i**j = i**k;  0<i;  Ord(j);  Ord(k) |] ==> j=k"
apply (rule Ord_linear_lt)
prefer 4 apply assumption
apply auto
apply (force dest: omult_lt_mono2 simp add: lt_not_refl)+
done

subsection{*The Relation @{term Lt}*}

lemma wf_Lt: "wf(Lt)"
apply (rule wf_subset)
apply (rule wf_Memrel)
apply (auto simp add: Lt_def Memrel_def lt_def)
done

lemma irrefl_Lt: "irrefl(A,Lt)"
by (auto simp add: Lt_def irrefl_def)

lemma trans_Lt: "trans[A](Lt)"
apply (simp add: Lt_def trans_on_def)
apply (blast intro: lt_trans)
done

lemma part_ord_Lt: "part_ord(A,Lt)"
by (simp add: part_ord_def irrefl_Lt trans_Lt)

lemma linear_Lt: "linear(nat,Lt)"
apply (auto dest!: not_lt_imp_le simp add: Lt_def linear_def le_iff)
apply (drule lt_asym, auto)
done

lemma tot_ord_Lt: "tot_ord(nat,Lt)"
by (simp add: tot_ord_def linear_Lt part_ord_Lt)

lemma well_ord_Lt: "well_ord(nat,Lt)"
by (simp add: well_ord_def wf_Lt wf_imp_wf_on tot_ord_Lt)

end


(*  Title:       Noninterference Security in Communicating Sequential Processes
    Author:      Pasquale Noce
                 Security Certification Specialist at Arjowiggins Security - Gep S.p.A.
                 pasquale dot noce at arjowiggins-it dot com
                 pasquale dot noce dot lavoro at gmail dot com
*)

header "Noninterference in CSP"

theory CSPNoninterference
imports Main
begin

text {*
\null

An extension of classical noninterference security for deterministic state machines, as introduced
by Goguen and Meseguer \cite{R2} and elegantly formalized by Rushby \cite{R3}, to nondeterministic
systems should satisfy two fundamental requirements: it should be based on a mathematically precise
theory of nondeterminism, and should be equivalent to (or at least not weaker than) the classical
notion in the degenerate deterministic case.

The purpose of this section is to formulate a definition of noninterference security that meet these
requirements, applying to the concept of process as formalized by Hoare in his remarkable theory of
Communicating Sequential Processes (CSP) \cite{R1}. The general case of a possibly intransitive
noninterference policy will be considered.

Throughout this paper, the salient points of definitions and proofs are commented; for additional
information see Isabelle documentation, particularly \cite{R5}, \cite{R6}, \cite{R7}, and \cite{R8}.
*}

subsection "Processes"

text {*
It is convenient to represent CSP processes by means of a type definition including a type variable,
which stands for the process alphabet. Type @{text process} shall then be isomorphic to the subset
of the product type of failures sets and divergences sets comprised of the pairs that satisfy the
properties enunciated in \cite{R1}, section 3.9. Such subset shall be shown to contain process
\emph{STOP}, which proves that it is nonempty.

Property \emph{C5} is not considered as it is entailed by \emph{C7}. Moreover, the formalization of
properties \emph{C2} and \emph{C6} only takes into account event lists \emph{t} containing a single
item. Such formulation is equivalent to the original one, since the truth of \emph{C2} and \emph{C6}
for a singleton list \emph{t} immediately derives from that for a generic list, and conversely:

\begin{itemize}

\item
the truth of \emph{C2} and \emph{C6} for a generic nonempty list \emph{t} results from the repeated
application of \emph{C2} and \emph{C6} for a singleton list;

\item
the truth of \emph{C2} for \emph{t} matching the empty list is implied by property \emph{C3};

\item
the truth of \emph{C6} for \emph{t} matching the empty list is a tautology.

\end{itemize}

The advantage of the proposed formulation is that it facilitates the task to prove that pairs of
failures and divergences sets defined inductively indeed be processes, viz. be included in the set
of pairs isomorphic to type @{text process}, since the introduction rules in such inductive
definitions will typically construct process traces by appending one item at a time.

In what follows, the concept of process is formalized according to the previous considerations.

\null
*}

type_synonym 'a failure = "'a list \<times> 'a set"

type_synonym 'a process_prod = "'a failure set \<times> 'a list set"

definition process_prop_1 :: "'a process_prod \<Rightarrow> bool" where
"process_prop_1 P \<equiv> ([], {}) \<in> fst P"

definition process_prop_2 :: "'a process_prod \<Rightarrow> bool" where
"process_prop_2 P \<equiv> \<forall>xs x X. (xs @ [x], X) \<in> fst P \<longrightarrow> (xs, {}) \<in> fst P"

definition process_prop_3 :: "'a process_prod \<Rightarrow> bool" where
"process_prop_3 P \<equiv> \<forall>xs X Y. (xs, Y) \<in> fst P \<and> X \<subseteq> Y \<longrightarrow> (xs, X) \<in> fst P"

definition process_prop_4 :: "'a process_prod \<Rightarrow> bool" where
"process_prop_4 P \<equiv> \<forall>xs x X. (xs, X) \<in> fst P \<longrightarrow>
  (xs @ [x], {}) \<in> fst P \<or> (xs, insert x X) \<in> fst P"

definition process_prop_5 :: "'a process_prod \<Rightarrow> bool" where
"process_prop_5 P \<equiv> \<forall>xs x. xs \<in> snd P \<longrightarrow> xs @ [x] \<in> snd P"

definition process_prop_6 :: "'a process_prod \<Rightarrow> bool" where
"process_prop_6 P \<equiv> \<forall>xs X. xs \<in> snd P \<longrightarrow> (xs, X) \<in> fst P"

definition process_set :: "'a process_prod set" where
"process_set \<equiv> {P.
  process_prop_1 P \<and>
  process_prop_2 P \<and>
  process_prop_3 P \<and>
  process_prop_4 P \<and>
  process_prop_5 P \<and>
  process_prop_6 P}"

typedef 'a process = "process_set :: 'a process_prod set"
by (rule_tac x = "({(xs, X). xs = []}, {})" in exI, simp add:
  process_set_def
  process_prop_1_def
  process_prop_2_def
  process_prop_3_def
  process_prop_4_def
  process_prop_5_def
  process_prop_6_def)

text {*
\null

Here below are the definitions of some functions acting on processes. Functions @{text failures},
@{text traces}, and @{text deterministic} match the homonymous notions defined in \cite{R1}. As for
the other ones:

\begin{itemize}

\item
@{text "futures P xs"} matches the failures set of process \emph{P / xs};

\item
@{text "refusals P xs"} matches the refusals set of process \emph{P / xs};

\item
@{text "next_events P xs"} matches the event set (\emph{P / xs})\textsuperscript{0}.

\end{itemize}

\null
*}

definition failures :: "'a process \<Rightarrow> 'a failure set" where
"failures P \<equiv> fst (Rep_process P)"

definition futures :: "'a process \<Rightarrow> 'a list \<Rightarrow> 'a failure set" where
"futures P xs \<equiv> {(ys, Y). (xs @ ys, Y) \<in> failures P}"

definition traces :: "'a process \<Rightarrow> 'a list set" where
"traces P \<equiv> Domain (failures P)"

definition refusals :: "'a process \<Rightarrow> 'a list \<Rightarrow> 'a set set" where
"refusals P xs \<equiv> failures P `` {xs}"

definition next_events :: "'a process \<Rightarrow> 'a list \<Rightarrow> 'a set" where
"next_events P xs \<equiv> {x. xs @ [x] \<in> traces P}"

definition deterministic :: "'a process \<Rightarrow> bool" where
"deterministic P \<equiv>
  \<forall>xs \<in> traces P. \<forall>X. X \<in> refusals P xs = (X \<inter> next_events P xs = {})"

text {*
\null

In what follows, properties @{text process_prop_2} and @{text process_prop_3} of processes are put
into the form of introduction rules, which will turn out to be useful in subsequent proofs.
Particularly, the more general formulation of @{text process_prop_2} as given in \cite{R1} (section
3.9, property \emph{C2}) is restored, and it is expressed in terms of both functions
@{text failures} and @{text futures}.

\null
*}

lemma process_rule_2: "(xs @ [x], X) \<in> failures P \<Longrightarrow> (xs, {}) \<in> failures P"
proof (simp add: failures_def)
  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)
  thus "(xs @ [x], X) \<in> fst ?P' \<Longrightarrow> (xs, {}) \<in> fst ?P'" by blast
qed

lemma process_rule_3: "(xs, Y) \<in> failures P \<Longrightarrow> X \<subseteq> Y \<Longrightarrow> (xs, X) \<in> failures P"
proof (simp add: failures_def)
  have "Rep_process P \<in> process_set" (is "?P' \<in> _") by (rule Rep_process)
  hence "\<forall>xs X Y. (xs, Y) \<in> fst ?P' \<and> X \<subseteq> Y \<longrightarrow> (xs, X) \<in> fst ?P'"
   by (simp add: process_set_def process_prop_3_def)
  thus "(xs, Y) \<in> fst ?P' \<Longrightarrow> X \<subseteq> Y \<Longrightarrow> (xs, X) \<in> fst ?P'" by blast
qed

lemma process_rule_2_failures [rule_format]:
 "(xs @ xs', X) \<in> failures P \<longrightarrow> (xs, {}) \<in> failures P"
proof (induction xs' arbitrary: X rule: rev_induct, rule_tac [!] impI, simp)
  fix X
  assume "(xs, X) \<in> failures P"
  moreover have "{} \<subseteq> X" ..
  ultimately show "(xs, {}) \<in> failures P" by (rule process_rule_3)
next
  fix x xs' X
  assume "\<And>X. (xs @ xs', X) \<in> failures P \<longrightarrow> (xs, {}) \<in> failures P"
  hence "(xs @ xs', {}) \<in> failures P \<longrightarrow> (xs, {}) \<in> failures P" .
  moreover assume "(xs @ xs' @ [x], X) \<in> failures P"
  hence "((xs @ xs') @ [x], X) \<in> failures P" by simp
  hence "(xs @ xs', {}) \<in> failures P" by (rule process_rule_2)
  ultimately show "(xs, {}) \<in> failures P" ..
qed

lemma process_rule_2_futures:
 "(ys @ ys', Y) \<in> futures P xs \<Longrightarrow> (ys, {}) \<in> futures P xs"
by (simp add: futures_def, simp only: append_assoc [symmetric], rule process_rule_2_failures)

subsection "Noninterference"

text {*
In the classical theory of noninterference, a deterministic state machine is considered to be secure
just in case, for any trace of the machine and any action occurring next, the observable effect of
the action, i.e. the produced output, is compatible with the assigned noninterference policy.

Thus, by analogy, it seems reasonable to regard a process as being noninterference-secure just in
case, for any of its traces and any event occurring next, the observable effect of the event, i.e.
the set of the possible futures of the process, is compatible with a given noninterference policy.

More precisely, let @{text "sinks I D u xs"} be the set of the security domains of the events within
event list @{text xs} that may be affected by domain @{text u} according to interference relation
@{text I}, where @{text D} is the mapping of events into their domains. Since the general case of a
possibly intransitive relation @{text I} is considered, function @{text sinks} has to be defined
recursively, similarly to what happens for function \emph{sources} in \cite{R3}. However,
contrariwise to function \emph{sources}, function @{text sinks} takes into account the influence of
the input domain on the input event list, so that the recursive decomposition of the latter has to
be performed by item appending rather than prepending.

Furthermore, let @{text "ipurge_tr I D u xs"} be the sublist of event list @{text xs} obtained by
recursively deleting the events that may be affected by domain @{text u} as detected via function
@{text sinks}, and @{text "ipurge_ref I D u xs X"} be the subset of refusal @{text X} whose elements
may not be affected by either @{text u} or any domain in @{text "sinks I D u xs"}.

Then, a process @{text P} is secure just in case, for each event list @{text xs} and each
@{text "(y # ys, Y), (zs, Z) \<in> futures P xs"}, both of the following conditions are satisfied:

\begin{itemize}

\item
@{text "(ipurge_tr I D (D y) ys, ipurge_ref I D (D y) ys Y) \<in> futures P xs"}.
\\Otherwise, the absence of event @{text y} after @{text xs} would affect the possibility for pair
@{text "(ipurge_tr I D (D y) ys, ipurge_ref I D (D y) ys Y)"} to occur as a future of @{text xs},
although its components, except for the deletion of @{text y}, are those of possible future
@{text "(y # ys, Y)"} deprived of any event allowed to be affected by @{text y}.

\item
@{text "(y # ipurge_tr I D (D y) zs, ipurge_ref I D (D y) zs Z)"}
\\@{text "\<in> futures P xs"}.
\\Otherwise, the presence of event @{text y} after @{text xs} would affect the possibility for pair
@{text "(y # ipurge_tr I D (D y) zs, ipurge_ref I D (D y) zs Z)"} to occur as a future of
@{text xs}, although its components, except for the addition of @{text y}, are those of possible
future @{text "(zs, Z)"} deprived of any event allowed to be affected by @{text y}.

\end{itemize}

Observe that this definition of security, henceforth referred to as
\emph{CSP noninterference security}, does not rest on the supposition that noninterference policy
@{text I} be reflexive, even though any policy of practical significance will be such.

Moreover, this simpler formulation is equivalent to the one obtained by restricting the range of
event list @{text xs} to the traces of process @{text P}. In fact, for each @{text zs}, @{text Z},
@{text "(zs, Z) \<in> futures P xs"} just in case @{text "(xs @ zs, Z) \<in> failures P"}, which by virtue
of rule @{text process_rule_2_failures} implies that @{text xs} is a trace of @{text P}. Therefore,
formula @{text "(zs, Z) \<in> futures P xs"} is invariably false in case @{text xs} is not a trace of
@{text P}.

Here below are the formal counterparts of the definitions discussed so far.

\null
*}

function sinks :: "('d \<times> 'd) set \<Rightarrow> ('a \<Rightarrow> 'd) \<Rightarrow> 'd \<Rightarrow> 'a list \<Rightarrow> 'd set" where
"sinks _ _ _ [] = {}" |
"sinks I D u (xs @ [x]) = (if (u, D x) \<in> I \<or> (\<exists>v \<in> sinks I D u xs. (v, D x) \<in> I)
  then insert (D x) (sinks I D u xs)
  else sinks I D u xs)"
proof (atomize_elim, simp_all add: split_paired_all)
qed (rule rev_cases, rule disjI1, assumption, simp)
termination by lexicographic_order

function ipurge_tr :: "('d \<times> 'd) set \<Rightarrow> ('a \<Rightarrow> 'd) \<Rightarrow> 'd \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"ipurge_tr _ _ _ [] = []" |
"ipurge_tr I D u (xs @ [x]) = (if D x \<in> sinks I D u (xs @ [x])
  then ipurge_tr I D u xs
  else ipurge_tr I D u xs @ [x])"
proof (atomize_elim, simp_all add: split_paired_all)
qed (rule rev_cases, rule disjI1, assumption, simp)
termination by lexicographic_order

definition ipurge_ref ::
 "('d \<times> 'd) set \<Rightarrow> ('a \<Rightarrow> 'd) \<Rightarrow> 'd \<Rightarrow> 'a list \<Rightarrow> 'a set \<Rightarrow> 'a set" where
"ipurge_ref I D u xs X \<equiv>
  {x \<in> X. (u, D x) \<notin> I \<and> (\<forall>v \<in> sinks I D u xs. (v, D x) \<notin> I)}"

definition secure :: "'a process \<Rightarrow> ('d \<times> 'd) set \<Rightarrow> ('a \<Rightarrow> 'd) \<Rightarrow> bool" where
"secure P I D \<equiv>
  \<forall>xs y ys Y zs Z. (y # ys, Y) \<in> futures P xs \<and> (zs, Z) \<in> futures P xs \<longrightarrow>
  (ipurge_tr I D (D y) ys, ipurge_ref I D (D y) ys Y) \<in> futures P xs \<and>
  (y # ipurge_tr I D (D y) zs, ipurge_ref I D (D y) zs Z) \<in> futures P xs"

text {*
\null

The continuation of this section is dedicated to the demonstration of some lemmas concerning
functions @{text sinks}, @{text ipurge_tr}, and @{text ipurge_ref} which will turn out to be useful
in subsequent proofs.

\null
*}

lemma sinks_cons_same:
  assumes R: "refl I"
  shows "sinks I D (D x) (x # xs) = insert (D x) (sinks I D (D x) xs)"
proof (rule rev_induct, simp)
  have A: "[x] = [] @ [x]" by simp
  have "sinks I D (D x) [x] = (if (D x, D x) \<in> I \<or> (\<exists>v \<in> {}. (v, D x) \<in> I)
    then insert (D x) {}
    else {})"
   by (subst A, simp only: sinks.simps)
  moreover have "(D x, D x) \<in> I" using R by (simp add: refl_on_def)
  ultimately show "sinks I D (D x) [x] = {D x}" by simp
next
  fix x' xs
  assume A: "sinks I D (D x) (x # xs) = insert (D x) (sinks I D (D x) xs)"
  show "sinks I D (D x) (x # xs @ [x']) =
    insert (D x) (sinks I D (D x) (xs @ [x']))"
  proof (cases "(D x, D x') \<in> I \<or> (\<exists>v \<in> sinks I D (D x) xs. (v, D x') \<in> I)",
   simp_all (no_asm_simp))
    case True
    hence "(D x, D x') \<in> I \<or> (\<exists>v \<in> sinks I D (D x) (x # xs). (v, D x') \<in> I)"
     using A by simp
    hence "sinks I D (D x) ((x # xs) @ [x']) =
      insert (D x') (sinks I D (D x) (x # xs))"
     by (simp only: sinks.simps if_True)
    thus "sinks I D (D x) (x # xs @ [x']) =
      insert (D x) (insert (D x') (sinks I D (D x) xs))"
     using A by (simp add: insert_commute)
  next
    case False
    hence "\<not> ((D x, D x') \<in> I \<or> (\<exists>v \<in> sinks I D (D x) (x # xs). (v, D x') \<in> I))"
     using A by simp
    hence "sinks I D (D x) ((x # xs) @ [x']) = sinks I D (D x) (x # xs)"
     by (simp only: sinks.simps if_False)
    thus "sinks I D (D x) (x # xs @ [x']) = insert (D x) (sinks I D (D x) xs)"
     using A by simp
  qed
qed

lemma ipurge_tr_cons_same:
  assumes R: "refl I"
  shows "ipurge_tr I D (D x) (x # xs) = ipurge_tr I D (D x) xs"
proof (induction xs rule: rev_induct, simp)
  have A: "[x] = [] @ [x]" by simp
  have "ipurge_tr I D (D x) [x] = (if D x \<in> sinks I D (D x) ([] @ [x])
    then []
    else [] @ [x])"
   by (subst A, simp only: ipurge_tr.simps)
  moreover have "sinks I D (D x) [x] = {D x}"
   using R by (simp add: sinks_cons_same)
  ultimately show "ipurge_tr I D (D x) [x] = []" by simp
next
  fix x' xs
  assume A: "ipurge_tr I D (D x) (x # xs) = ipurge_tr I D (D x) xs"
  show "ipurge_tr I D (D x) (x # xs @ [x']) = ipurge_tr I D (D x) (xs @ [x'])"
  proof (cases "D x' \<in> sinks I D (D x) (x # xs @ [x'])")
    assume B: "D x' \<in> sinks I D (D x) (x # xs @ [x'])"
    hence "D x' \<in> sinks I D (D x) ((x # xs) @ [x'])" by simp
    hence "ipurge_tr I D (D x) ((x # xs) @ [x']) = ipurge_tr I D (D x) (x # xs)"
     by (simp only: ipurge_tr.simps if_True)
    hence C: "ipurge_tr I D (D x) (x # xs @ [x']) = ipurge_tr I D (D x) xs"
     using A by simp
    have "D x' = D x \<or> D x' \<in> sinks I D (D x) (xs @ [x'])"
     using R and B by (simp add: sinks_cons_same)
    moreover {
      assume "D x' = D x"
      hence "(D x, D x') \<in> I" using R by (simp add: refl_on_def)
      hence "ipurge_tr I D (D x) (xs @ [x']) = ipurge_tr I D (D x) xs" by simp
    }
    moreover {
      assume "D x' \<in> sinks I D (D x) (xs @ [x'])"
      hence "ipurge_tr I D (D x) (xs @ [x']) = ipurge_tr I D (D x) xs" by simp
    }
    ultimately have D: "ipurge_tr I D (D x) (xs @ [x']) = ipurge_tr I D (D x) xs"
     by blast
    show ?thesis using C and D by simp
  next
    assume B: "D x' \<notin> sinks I D (D x) (x # xs @ [x'])"
    hence "D x' \<notin> sinks I D (D x) ((x # xs) @ [x'])" by simp
    hence "ipurge_tr I D (D x) ((x # xs) @ [x']) =
      ipurge_tr I D (D x) (x # xs) @ [x']"
     by (simp only: ipurge_tr.simps if_False)
    hence "ipurge_tr I D (D x) (x # xs @ [x']) = ipurge_tr I D (D x) xs @ [x']"
     using A by simp
    moreover have "\<not> (D x' = D x \<or> D x' \<in> sinks I D (D x) (xs @ [x']))"
     using R and B by (simp add: sinks_cons_same)
    hence "ipurge_tr I D (D x) (xs @ [x']) = ipurge_tr I D (D x) xs @ [x']"
     by simp
    ultimately show ?thesis by simp
  qed
qed

lemma sinks_cons_nonint:
  assumes A: "(u, D x) \<notin> I"
  shows "sinks I D u (x # xs) = sinks I D u xs"
proof (rule rev_induct, simp)
  have "sinks I D u [x] = sinks I D u ([] @ [x])" by simp
  hence "sinks I D u [x] = (if (u, D x) \<in> I \<or> (\<exists>v \<in> {}. (v, D x) \<in> I)
    then insert (D x) {}
    else {})"
   by (simp only: sinks.simps)
  thus "sinks I D u [x] = {}" using A by simp
next
  fix xs x'
  assume B: "sinks I D u (x # xs) = sinks I D u xs" (is "?d' = ?d")
  have "x # xs @ [x'] = (x # xs) @ [x']" by simp
  hence C: "sinks I D u (x # xs @ [x']) =
    (if (u, D x') \<in> I \<or> (\<exists>v \<in> ?d'. (v, D x') \<in> I)
    then insert (D x') ?d'
    else ?d')"
   by (simp only: sinks.simps)
  show "sinks I D u (x # xs @ [x']) = sinks I D u (xs @ [x'])"
  proof (cases "(u, D x') \<in> I \<or> (\<exists>v \<in> ?d. (v, D x') \<in> I)")
    assume "(u, D x') \<in> I \<or> (\<exists>v \<in> ?d. (v, D x') \<in> I)"
    moreover with B and C have "sinks I D u (x # xs @ [x']) =
      insert (D x') ?d"
     by simp
    ultimately show ?thesis by simp
  next
    assume "\<not> ((u, D x') \<in> I \<or> (\<exists>v \<in> ?d. (v, D x') \<in> I))"
    moreover with B and C have "sinks I D u (x # xs @ [x']) = ?d" by simp
    ultimately show ?thesis by simp
  qed
qed

lemma sinks_empty [rule_format]:
 "sinks I D u xs = {} \<longrightarrow> ipurge_tr I D u xs = xs"
proof (rule rev_induct, simp, rule impI)
  fix x xs
  assume A: "sinks I D u (xs @ [x]) = {}"
  moreover have "sinks I D u xs \<subseteq> sinks I D u (xs @ [x])"
   by (simp add: subset_insertI)
  ultimately have "sinks I D u xs = {}" by simp
  moreover assume "sinks I D u xs = {} \<longrightarrow> ipurge_tr I D u xs = xs"
  ultimately have "ipurge_tr I D u xs = xs" by (rule rev_mp)
  thus "ipurge_tr I D u (xs @ [x]) = xs @ [x]" using A by simp
qed

lemma ipurge_ref_eq:
  assumes A: "D x \<in> sinks I D u (xs @ [x])"
  shows "ipurge_ref I D u (xs @ [x]) X =
    ipurge_ref I D u xs {x' \<in> X. (D x, D x') \<notin> I}"
proof (rule equalityI, rule_tac [!] subsetI, simp_all add: ipurge_ref_def del: sinks.simps,
 (erule conjE)+, (erule_tac [2] conjE)+)
  fix y
  assume B: "\<forall>v \<in> sinks I D u (xs @ [x]). (v, D y) \<notin> I"
  show "(D x, D y) \<notin> I \<and> (\<forall>v \<in> sinks I D u xs. (v, D y) \<notin> I)"
  proof (rule conjI, rule_tac [2] ballI)
    show "(D x, D y) \<notin> I" using B and A ..
  next
    fix v
    assume "v \<in> sinks I D u xs"
    hence "v \<in> sinks I D u (xs @ [x])" by simp
    with B show "(v, D y) \<notin> I" ..
  qed
next
  fix y
  assume
    B: "(D x, D y) \<notin> I" and
    C: "\<forall>v \<in> sinks I D u xs. (v, D y) \<notin> I"
  show "\<forall>v \<in> sinks I D u (xs @ [x]). (v, D y) \<notin> I"
  proof (rule ballI, cases "(u, D x) \<in> I \<or> (\<exists>v \<in> sinks I D u xs. (v, D x) \<in> I)")
    fix v
    case True
    moreover assume "v \<in> sinks I D u (xs @ [x])"
    ultimately have "v = D x \<or> v \<in> sinks I D u xs" by simp
    moreover {
      assume "v = D x"
      with B have "(v, D y) \<notin> I" by simp
    }
    moreover {
      assume "v \<in> sinks I D u xs"
      with C have "(v, D y) \<notin> I" ..
    }
    ultimately show "(v, D y) \<notin> I" by blast
  next
    fix v
    case False
    moreover assume "v \<in> sinks I D u (xs @ [x])"
    ultimately have "v \<in> sinks I D u xs" by simp
    with C show "(v, D y) \<notin> I" ..
  qed
qed

end


theory Chisholm_E imports E                 (*Christoph Benzmüller & Xavier Parent, 2019*)

begin (* Chisholm Example *)
consts go::\<sigma> tell::\<sigma> kill::\<sigma>

  nitpick_params [user_axioms,expect=genuine,show_all,format=2] (*settings for the model finder*)

(*It ought to be that Jones goes to assist his neighbors.*)
  abbreviation  "D1 \<equiv> \<^bold>\<circle><go>"
(*It ought to be that if Jones goes, then he tells them he is coming.*)
  abbreviation  "D2w \<equiv> \<^bold>\<circle><go \<^bold>\<rightarrow> tell>"
  abbreviation  "D2n \<equiv> go \<^bold>\<rightarrow> \<^bold>\<circle><tell>"
(*If Jones doesn't go, then he ought not tell them he is coming.*)
  abbreviation  "D3w \<equiv> \<^bold>\<circle><\<^bold>\<not>go \<^bold>\<rightarrow> \<^bold>\<not>tell>"
  abbreviation  "D3n \<equiv> \<^bold>\<not>go \<^bold>\<rightarrow> \<^bold>\<circle><\<^bold>\<not>tell>"
(*Jones doesn't go. (This is encoded as a locally valid statement.)*)
  abbreviation  "D4 \<equiv> \<^bold>\<not>go"

(*** Chisholm_A ***)
 (* All-wide scoping is not leading to a dependent set of the axioms.*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D2w \<^bold>\<and> D3w) \<^bold>\<rightarrow> D4\<rfloor>"   nitpick oops (*countermodel*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D2w \<^bold>\<and> D4)  \<^bold>\<rightarrow> D3w\<rfloor>"  by blast  (*proof*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D3w \<^bold>\<and> D4)  \<^bold>\<rightarrow> D2w\<rfloor>"  nitpick oops (*countermodel*)
 lemma "\<lfloor>(D2w \<^bold>\<and> D3w \<^bold>\<and> D4)  \<^bold>\<rightarrow> D1\<rfloor>"   nitpick oops (*countermodel*)
 (* Chisholm_A is thus an inadequate modeling. *)

 (* Consistency *)
 lemma "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" nitpick [satisfy] oops (*Consistent? Yes*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows False nitpick oops (*Inconsistent? No*)
 (* Queries *)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><\<^bold>\<not>tell>\<rfloor>\<^sub>l" nitpick oops (*Should James not tell? No*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><tell>\<rfloor>\<^sub>l"  using assms by auto (*Should James tell? Yes*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><kill>\<rfloor>\<^sub>l"  nitpick oops (*Should James kill? No*)

(*** Chisholm_B ***)
 (* All-narrow scoping is leading to a dependent set of the axioms.*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D2n \<^bold>\<and> D3n) \<^bold>\<rightarrow> D4\<rfloor>"   nitpick oops (*countermodel*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D2n \<^bold>\<and> D4)  \<^bold>\<rightarrow> D3n\<rfloor>"  nitpick oops  (*countermodel*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D3n \<^bold>\<and> D4)  \<^bold>\<rightarrow> D2n\<rfloor>"  by blast  (*proof*)
 lemma "\<lfloor>(D2n \<^bold>\<and> D3n \<^bold>\<and> D4)  \<^bold>\<rightarrow> D1\<rfloor>"   nitpick oops (*countermodel*)
 (* Chisholm_B is thus an inadequate modeling. *)

 (* Consistency *)
 lemma "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" nitpick [satisfy] oops (*Consistent? Yes*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows False nitpick oops (*Inconsistent? No*)
 (* Queries *)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><\<^bold>\<not>tell>\<rfloor>\<^sub>l" using assms by auto (*Should James not tell? Yes*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><tell>\<rfloor>\<^sub>l"  using assms by auto (*Should James tell? Yes*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><kill>\<rfloor>\<^sub>l"  using assms by smt (*Should James kill? Yes*)

(*** Chisholm_C ***)
 (* Wide-narrow scoping is leading to independence of the axioms.*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D2w \<^bold>\<and> D3n) \<^bold>\<rightarrow> D4\<rfloor>"   nitpick oops (*countermodel*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D2w \<^bold>\<and> D4)  \<^bold>\<rightarrow> D3n\<rfloor>"  nitpick oops (*countermodel*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D3n \<^bold>\<and> D4)  \<^bold>\<rightarrow> D2w\<rfloor>"  nitpick oops (*countermodel*)
 lemma "\<lfloor>(D2w \<^bold>\<and> D3n \<^bold>\<and> D4)  \<^bold>\<rightarrow> D1\<rfloor>"   nitpick oops (*countermodel*)
 (* Chisholm_C is thus fine from this perspective. *)

 (* Consistency *)
 lemma "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" nitpick [satisfy] oops (*Consistent? Yes*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows False nitpick oops (*Inconsistent? No*)
 (* Queries *)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><\<^bold>\<not>tell>\<rfloor>\<^sub>l" using assms by auto (*Should James not tell? Yes*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><tell>\<rfloor>\<^sub>l"  using assms by blast (*Should James tell? Yes*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><kill>\<rfloor>\<^sub>l"  using assms by blast (*Should James kill? Yes*)

(*** Chisholm_D ***)
 (* Narrow-wide scoping is leading to a dependent set of the axioms.*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D2n \<^bold>\<and> D3w) \<^bold>\<rightarrow> D4\<rfloor>"   nitpick oops (*countermodel*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D2n \<^bold>\<and> D4)  \<^bold>\<rightarrow> D3w\<rfloor>"  by blast  (*proof*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D3w \<^bold>\<and> D4)  \<^bold>\<rightarrow> D2n\<rfloor>"  by blast  (*proof*)
 lemma "\<lfloor>(D2n \<^bold>\<and> D3w \<^bold>\<and> D4)  \<^bold>\<rightarrow> D1\<rfloor>"   nitpick oops (*countermodel*)
 (* Chisholm_D is thus an inadequate modeling. *)

 (* Consistency *)
 lemma "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" nitpick [satisfy] oops (*Consistent? Yes*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows False nitpick oops (*Inconsistent? No*)
 (* Queries *)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><\<^bold>\<not>tell>\<rfloor>\<^sub>l" nitpick oops (*Should James not tell? No*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><tell>\<rfloor>\<^sub>l"  using assms by blast (*Should James tell? Yes*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><kill>\<rfloor>\<^sub>l"  nitpick oops (*Should James kill? No*)
end


(*  Title:      HOL/HOLCF/Compact_Basis.thy
    Author:     Brian Huffman
*)

section \<open>A compact basis for powerdomains\<close>

theory Compact_Basis
imports Universal
begin

default_sort bifinite

subsection \<open>A compact basis for powerdomains\<close>

definition "pd_basis = {S::'a compact_basis set. finite S \<and> S \<noteq> {}}"

typedef 'a pd_basis = "pd_basis :: 'a compact_basis set set"
  unfolding pd_basis_def
  apply (rule_tac x="{_}" in exI)
  apply simp
  done

lemma finite_Rep_pd_basis [simp]: "finite (Rep_pd_basis u)"
by (insert Rep_pd_basis [of u, unfolded pd_basis_def]) simp

lemma Rep_pd_basis_nonempty [simp]: "Rep_pd_basis u \<noteq> {}"
by (insert Rep_pd_basis [of u, unfolded pd_basis_def]) simp

text \<open>The powerdomain basis type is countable.\<close>

lemma pd_basis_countable: "\<exists>f::'a pd_basis \<Rightarrow> nat. inj f"
proof -
  obtain g :: "'a compact_basis \<Rightarrow> nat" where "inj g"
    using compact_basis.countable ..
  hence image_g_eq: "\<And>A B. g ` A = g ` B \<longleftrightarrow> A = B"
    by (rule inj_image_eq_iff)
  have "inj (\<lambda>t. set_encode (g ` Rep_pd_basis t))"
    by (simp add: inj_on_def set_encode_eq image_g_eq Rep_pd_basis_inject)
  thus ?thesis by - (rule exI)
  (* FIXME: why doesn't ".." or "by (rule exI)" work? *)
qed

subsection \<open>Unit and plus constructors\<close>

definition
  PDUnit :: "'a compact_basis \<Rightarrow> 'a pd_basis" where
  "PDUnit = (\<lambda>x. Abs_pd_basis {x})"

definition
  PDPlus :: "'a pd_basis \<Rightarrow> 'a pd_basis \<Rightarrow> 'a pd_basis" where
  "PDPlus t u = Abs_pd_basis (Rep_pd_basis t \<union> Rep_pd_basis u)"

lemma Rep_PDUnit:
  "Rep_pd_basis (PDUnit x) = {x}"
unfolding PDUnit_def by (rule Abs_pd_basis_inverse) (simp add: pd_basis_def)

lemma Rep_PDPlus:
  "Rep_pd_basis (PDPlus u v) = Rep_pd_basis u \<union> Rep_pd_basis v"
unfolding PDPlus_def by (rule Abs_pd_basis_inverse) (simp add: pd_basis_def)

lemma PDUnit_inject [simp]: "(PDUnit a = PDUnit b) = (a = b)"
unfolding Rep_pd_basis_inject [symmetric] Rep_PDUnit by simp

lemma PDPlus_assoc: "PDPlus (PDPlus t u) v = PDPlus t (PDPlus u v)"
unfolding Rep_pd_basis_inject [symmetric] Rep_PDPlus by (rule Un_assoc)

lemma PDPlus_commute: "PDPlus t u = PDPlus u t"
unfolding Rep_pd_basis_inject [symmetric] Rep_PDPlus by (rule Un_commute)

lemma PDPlus_absorb: "PDPlus t t = t"
unfolding Rep_pd_basis_inject [symmetric] Rep_PDPlus by (rule Un_absorb)

lemma pd_basis_induct1:
  assumes PDUnit: "\<And>a. P (PDUnit a)"
  assumes PDPlus: "\<And>a t. P t \<Longrightarrow> P (PDPlus (PDUnit a) t)"
  shows "P x"
apply (induct x, unfold pd_basis_def, clarify)
apply (erule (1) finite_ne_induct)
apply (cut_tac a=x in PDUnit)
apply (simp add: PDUnit_def)
apply (drule_tac a=x in PDPlus)
apply (simp add: PDUnit_def PDPlus_def
  Abs_pd_basis_inverse [unfolded pd_basis_def])
done

lemma pd_basis_induct:
  assumes PDUnit: "\<And>a. P (PDUnit a)"
  assumes PDPlus: "\<And>t u. \<lbrakk>P t; P u\<rbrakk> \<Longrightarrow> P (PDPlus t u)"
  shows "P x"
apply (induct x rule: pd_basis_induct1)
apply (rule PDUnit, erule PDPlus [OF PDUnit])
done

subsection \<open>Fold operator\<close>

definition
  fold_pd ::
    "('a compact_basis \<Rightarrow> 'b::type) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a pd_basis \<Rightarrow> 'b"
  where "fold_pd g f t = semilattice_set.F f (g ` Rep_pd_basis t)"

lemma fold_pd_PDUnit:
  assumes "semilattice f"
  shows "fold_pd g f (PDUnit x) = g x"
proof -
  from assms interpret semilattice_set f by (rule semilattice_set.intro)
  show ?thesis by (simp add: fold_pd_def Rep_PDUnit)
qed

lemma fold_pd_PDPlus:
  assumes "semilattice f"
  shows "fold_pd g f (PDPlus t u) = f (fold_pd g f t) (fold_pd g f u)"
proof -
  from assms interpret semilattice_set f by (rule semilattice_set.intro)
  show ?thesis by (simp add: image_Un fold_pd_def Rep_PDPlus union)
qed

end


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

  Project: Development of Security Protocols by Refinement

  Module:  Refinement/Keys.thy (Isabelle/HOL 2016-1)
  ID:      $Id: Keys.thy 132773 2016-12-09 15:30:22Z csprenge $
  Author:  Christoph Sprenger, ETH Zurich <sprenger@inf.ethz.ch>

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

  Copyright (c) 2012-2016 Christoph Sprenger
  Licence: LGPL

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

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

theory Keys imports Agents begin

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

datatype ltkey =    \<comment> \<open>long-term keys\<close>
  sharK "agent"     \<comment> \<open>key shared with server\<close>
| publK "agent"     \<comment> \<open>agent's public key\<close>
| privK "agent"     \<comment> \<open>agent's private key\<close>

datatype key =
  sesK "fresh_t"   \<comment> \<open>session key\<close>
| ltK "ltkey"      \<comment> \<open>long-term key\<close>

abbreviation
  shrK :: "agent \<Rightarrow> key" where
  "shrK A \<equiv> ltK (sharK A)"

abbreviation
  pubK :: "agent \<Rightarrow> key" where
  "pubK A \<equiv> ltK (publK A)"

abbreviation
  priK :: "agent \<Rightarrow> key" where
  "priK A \<equiv> ltK (privK A)"

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

(*holds because invKey is injective*)

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

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

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

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

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

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

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

lemma sym_sesK: "sesK f \<in> symKeys"   \<comment> \<open>All session keys are symmetric\<close>
by (simp add: symKeys_def)

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

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

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

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

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

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

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

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

lemma sesK_notin_image_shrK [simp]: "sesK K \<notin> shrK`AA"
by (auto)

lemma shrK_notin_image_sesK [simp]: "shrK K \<notin> sesK`AA"
by (auto)

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

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

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_49
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun butlast :: "'a list => 'a list" where
  "butlast (nil2) = nil2"
| "butlast (cons2 z (nil2)) = nil2"
| "butlast (cons2 z (cons2 x2 x3)) =
     cons2 z (butlast (cons2 x2 x3))"

fun butlastConcat :: "'a list => 'a list => 'a list" where
  "butlastConcat y (nil2) = butlast y"
| "butlastConcat y (cons2 z2 x2) = x y (butlast (cons2 z2 x2))"

theorem property0 :
  "((butlast (x xs ys)) = (butlastConcat xs ys))"
  oops

end


(*  Title:      Containers/Containers_Auxiliary.thy
    Author:     Andreas Lochbihler, KIT *)

theory Containers_Auxiliary imports
  "HOL-Library.Monad_Syntax"
begin

chapter \<open>An executable linear order on sets\<close>
text_raw \<open>\label{chapter:linear:order:set}\<close>

section \<open>Auxiliary definitions\<close>

lemma insert_bind_set: "insert a A \<bind> f = f a \<union> (A \<bind> f)"
by(auto simp add: Set.bind_def)

lemma set_bind_iff:
  "set (List.bind xs f) = Set.bind (set xs) (set \<circ> f)"
by(induct xs)(simp_all add: insert_bind_set)

lemma set_bind_conv_fold: "set xs \<bind> f = fold ((\<union>) \<circ> f) xs {}"
by(induct xs rule: rev_induct)(simp_all add: insert_bind_set)

lemma card_gt_1D:
  assumes "card A > 1"
  shows "\<exists>x y. x \<in> A \<and> y \<in> A \<and> x \<noteq> y"
proof(rule ccontr)
  from assms have "A \<noteq> {}" by auto
  then obtain x where "x \<in> A" by auto
  moreover
  assume "\<not> ?thesis"
  ultimately have "A = {x}" by auto
  with assms show False by simp
qed

lemma card_eq_1_iff: "card A = 1 \<longleftrightarrow> (\<exists>x. A = {x})"
proof
  assume card: "card A = 1"
  hence [simp]: "finite A" using card_gt_0_iff[of A] by simp
  have "A = {THE x. x \<in> A}"
  proof(intro equalityI subsetI)
    fix x
    assume x: "x \<in> A"
    hence "(THE x. x \<in> A) = x"
    proof(rule the_equality)
      fix x'
      assume x': "x' \<in> A"
      show "x' = x"
      proof(rule ccontr)
        assume neq: "x' \<noteq> x"
        from x x' have eq: "A = insert x (insert x' (A - {x, x'}))" by auto
        have "card A = 2 + card (A - {x, x'})" using neq by(subst eq)(simp)
        with card show False by simp
      qed
    qed
    thus "x \<in> {THE x. x \<in> A}" by simp
  next
    fix x
    assume "x \<in> {THE x. x \<in> A}"
    hence x: "x = (THE x. x \<in> A)" by simp
    from card have "A \<noteq> {}" by auto
    then obtain x' where x': "x' \<in> A" by blast
    thus "x \<in> A" unfolding x
    proof(rule theI)
      fix x
      assume x: "x \<in> A"
      show "x = x'"
      proof(rule ccontr)
        assume neq: "x \<noteq> x'"
        from x x' have eq: "A = insert x (insert x' (A - {x, x'}))" by auto
        have "card A = 2 + card (A - {x, x'})" using neq by(subst eq)(simp)
        with card show False by simp
      qed
    qed
  qed
  thus "\<exists>x. A = {x}" ..
qed auto

lemma card_eq_Suc_0_ex1: "card A = Suc 0 \<longleftrightarrow> (\<exists>!x. x \<in> A)"
by(auto simp only: One_nat_def[symmetric] card_eq_1_iff)

context linorder begin

lemma sorted_last: "\<lbrakk> sorted xs; x \<in> set xs \<rbrakk> \<Longrightarrow> x \<le> last xs"
by(cases xs rule: rev_cases)(auto simp add: sorted_append)

end

lemma empty_filter_conv: "[] = filter P xs \<longleftrightarrow> (\<forall>x\<in>set xs. \<not> P x)"
by(auto dest: sym simp add: filter_empty_conv)

definition ID :: "'a \<Rightarrow> 'a" where "ID = id"

lemma ID_code [code, code_unfold]: "ID = (\<lambda>x. x)"
by(simp add: ID_def id_def)

lemma ID_Some: "ID (Some x) = Some x"
by(simp add: ID_def)

lemma ID_None: "ID None = None"
by(simp add: ID_def)

text \<open>lexicographic order on pairs\<close>

context
  fixes leq_a :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubseteq>\<^sub>a" 50)
  and less_a :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubset>\<^sub>a" 50)
  and leq_b :: "'b \<Rightarrow> 'b \<Rightarrow> bool" (infix "\<sqsubseteq>\<^sub>b" 50)
  and less_b :: "'b \<Rightarrow> 'b \<Rightarrow> bool" (infix "\<sqsubset>\<^sub>b" 50)
begin

definition less_eq_prod :: "('a \<times> 'b) \<Rightarrow> ('a \<times> 'b) \<Rightarrow> bool" (infix "\<sqsubseteq>" 50)
where "less_eq_prod = (\<lambda>(x1, x2) (y1, y2). x1 \<sqsubset>\<^sub>a y1 \<or> x1 \<sqsubseteq>\<^sub>a y1 \<and> x2 \<sqsubseteq>\<^sub>b y2)"

definition less_prod :: "('a \<times> 'b) \<Rightarrow> ('a \<times> 'b) \<Rightarrow> bool" (infix "\<sqsubset>" 50)
where "less_prod = (\<lambda>(x1, x2) (y1, y2). x1 \<sqsubset>\<^sub>a y1 \<or> x1 \<sqsubseteq>\<^sub>a y1 \<and> x2 \<sqsubset>\<^sub>b y2)"

lemma less_eq_prod_simps [simp]:
  "(x1, x2) \<sqsubseteq> (y1, y2) \<longleftrightarrow> x1 \<sqsubset>\<^sub>a y1 \<or> x1 \<sqsubseteq>\<^sub>a y1 \<and> x2 \<sqsubseteq>\<^sub>b y2"
by(simp add: less_eq_prod_def)

lemma less_prod_simps [simp]:
  "(x1, x2) \<sqsubset> (y1, y2) \<longleftrightarrow> x1 \<sqsubset>\<^sub>a y1 \<or> x1 \<sqsubseteq>\<^sub>a y1 \<and> x2 \<sqsubset>\<^sub>b y2"
by(simp add: less_prod_def)

end

context
  fixes leq_a :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubseteq>\<^sub>a" 50)
  and less_a :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubset>\<^sub>a" 50)
  and leq_b :: "'b \<Rightarrow> 'b \<Rightarrow> bool" (infix "\<sqsubseteq>\<^sub>b" 50)
  and less_b :: "'b \<Rightarrow> 'b \<Rightarrow> bool" (infix "\<sqsubset>\<^sub>b" 50)
  assumes lin_a: "class.linorder leq_a less_a"
  and lin_b: "class.linorder leq_b less_b"
begin

abbreviation (input) less_eq_prod' :: "('a \<times> 'b) \<Rightarrow> ('a \<times> 'b) \<Rightarrow> bool" (infix "\<sqsubseteq>" 50)
where "less_eq_prod' \<equiv> less_eq_prod leq_a less_a leq_b"

abbreviation (input) less_prod' :: "('a \<times> 'b) \<Rightarrow> ('a \<times> 'b) \<Rightarrow> bool" (infix "\<sqsubset>" 50)
where "less_prod' \<equiv> less_prod leq_a less_a less_b"

lemma linorder_prod:
  "class.linorder (\<sqsubseteq>) (\<sqsubset>)"
proof -
  interpret a: linorder "(\<sqsubseteq>\<^sub>a)" "(\<sqsubset>\<^sub>a)" by(fact lin_a)
  interpret b: linorder "(\<sqsubseteq>\<^sub>b)" "(\<sqsubset>\<^sub>b)" by(fact lin_b)
  show ?thesis by unfold_locales auto
qed

end

hide_const less_eq_prod' less_prod'

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_regexp_PlusCommutative
imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype A = X | Y

datatype R
         = Nil | Eps | Atom "A" | Plus "R" "R" | Seq "R" "R" | Star "R"

fun seq :: "R => R => R" where
"seq x y =
   (case x of
      Nil => Nil
      | other =>
          (case y of
             Nil => Nil
             | other =>
                 (case x of
                    Eps => y
                    | other =>
                        (case y of
                           Eps => x
                           | other => Seq x y))))"

fun plus :: "R => R => R" where
"plus x y =
   (case x of
      Nil => y
      | other =>
          (case y of
             Nil => x
             | other => Plus x y))"

fun eqA :: "A => A => bool" where
"eqA (X) (X) = True"
| "eqA (X) (Y) = False"
| "eqA (Y) (X) = False"
| "eqA (Y) (Y) = True"

fun eps :: "R => bool" where
"eps x =
   (case x of
      Eps => True
      | Plus p q => ((eps p) | (eps q))
      | Seq r q2 => ((eps r) & (eps q2))
      | Star y => True
      | other => False)"

fun epsR :: "R => R" where
"epsR x = (if eps x then Eps else Nil)"

fun step :: "R => A => R" where
"step x y =
   (case x of
      Atom a => (if eqA a y then Eps else Nil)
      | Plus p q => plus (step p y) (step q y)
      | Seq r q2 => plus (seq (step r y) q2) (seq (epsR r) (step q2 y))
      | Star p2 => seq (step p2 y) x
      | other => Nil)"

fun recognise :: "R => A list => bool" where
"recognise x (nil2) = eps x"
| "recognise x (cons2 z xs) = recognise (step x z) xs"

theorem property0 :
  "((recognise (Plus p q) s) = (recognise (Plus q p) s))"
  oops

end