theory IO_out2_STIT imports Main                (*Paul Meder, 2018*)
begin
  typedecl i (* "type for possible worlds" *)
  type_synonym e = "(i\<Rightarrow>bool)"

  consts a1::"i \<Rightarrow> i \<Rightarrow> bool" a2::"i \<Rightarrow> i \<Rightarrow> bool"   (* Relation for agents: a1 & a2 *)
  consts r_box :: "i\<Rightarrow>i\<Rightarrow>bool"  (infixr "rbox" 70)  (* Relation R_Box *)
  consts r_agt :: "i\<Rightarrow>i\<Rightarrow>bool" (infixr "ragt" 70)  (* Relation R_Agt *)
  consts r_G :: "i\<Rightarrow>i\<Rightarrow>bool"    (infixr "rG" 70 )  (* Relation R_G *)
  consts r_H :: "i\<Rightarrow>i\<Rightarrow>bool"    (infixr "rH" 70 )   (* Relation R_H *)
  consts r_45 :: "i\<Rightarrow>i\<Rightarrow>bool" (infixr "r45" 70)   (* relation for a modal logic K45 *)
  consts aw :: i   (*actual world *)

  definition knot :: "e\<Rightarrow>e" ("\<^bold>\<not>_"[52]53) where "\<^bold>\<not>\<phi> \<equiv> \<lambda>w. \<not>\<phi>(w) " (* Negation *)
  definition kor :: "e\<Rightarrow>e\<Rightarrow>e" (infixr "\<^bold>\<or>"50) where "\<phi>\<^bold>\<or>\<psi> \<equiv> \<lambda>w. \<phi>(w) \<or> \<psi>(w)"  (* Disjunction *)
  definition kand :: "e\<Rightarrow>e\<Rightarrow>e" (infixr "\<^bold>\<and>"51) where "\<phi>\<^bold>\<and>\<psi> \<equiv> \<lambda>w. \<phi>(w) \<and> \<psi>(w)" (* Conjunction *)
  definition kimp :: "e\<Rightarrow>e\<Rightarrow>e" (infixr "\<^bold>\<supset>" 49) where "\<phi>\<^bold>\<supset>\<psi> \<equiv> \<lambda>w. \<phi>(w) \<longrightarrow> \<psi>(w)" (* Implication *)

  definition k45box :: "e\<Rightarrow>e" ("\<^bold>\<box>\<^sub>l") where " \<^bold>\<box>\<^sub>l \<phi> \<equiv> \<lambda>w. \<forall>v. w r45 v \<longrightarrow> \<phi>(v)" (*\<box> for Modal logic K45*)
  definition k45dia :: "e\<Rightarrow>e" ("\<^bold>\<diamond>\<^sub>l") where "\<^bold>\<diamond>\<^sub>l \<phi> \<equiv> \<^bold>\<not> \<^bold>\<box>\<^sub>l( \<^bold>\<not> \<phi>) " (* Dual operator for \<box> *)

  definition kbox :: "e\<Rightarrow>e" ("\<^bold>\<box>") where "\<^bold>\<box>\<phi> \<equiv> \<lambda>w. \<forall>v. w rbox v \<longrightarrow> \<phi>(v)" (* \<box> for T-STIT logic*)
  definition kdia :: "e\<Rightarrow>e" ("\<^bold>\<diamond>") where "\<^bold>\<diamond> \<phi> \<equiv> \<^bold>\<not> \<^bold>\<box>( \<^bold>\<not> \<phi>) " (* Dual *)
  definition kcstit :: "(i\<Rightarrow>i\<Rightarrow>bool)\<Rightarrow>e\<Rightarrow>e" ("_ cstit _") where "r cstit \<phi> \<equiv> \<lambda>w. \<forall>v. r w v \<longrightarrow> \<phi>(v) " (* STIT [i]  *)
  definition kgstit :: "e\<Rightarrow>e" ("gstit _") where "gstit \<phi> \<equiv> \<lambda>w. \<forall>v. w ragt v \<longrightarrow> \<phi>(v)" (*Group STIT [Agt]*)

  definition kvalid :: "e\<Rightarrow>bool" ("\<lfloor>_\<rfloor>" [8]109) where "\<lfloor>p\<rfloor> \<equiv> \<forall>w. p(w)" (* Validity *)
  definition actual :: "e \<Rightarrow> bool" ("\<lfloor>_\<rfloor>\<^sub>l"[7]105) where "\<lfloor>\<phi>\<rfloor>\<^sub>l \<equiv> \<phi>(aw)" (* Validity for actual world *)

  definition ktrue  :: "e" ("\<^bold>\<top>") where "\<^bold>\<top> \<equiv> \<lambda>w. True" (* Tautology *)
  definition kfalse :: "e" ("\<^bold>\<bottom>") where "\<^bold>\<bottom> \<equiv> \<lambda>w. False"  (* Falsum *)

  definition kfuture :: "e\<Rightarrow>e" ("F _") where "F \<phi> \<equiv> \<lambda>w. \<forall>v. w rG v \<longrightarrow> \<phi>(v)"
  definition kpast :: "e\<Rightarrow>e" ("H _") where "H \<phi> \<equiv> \<lambda>w. \<forall>v. w rH v \<longrightarrow> \<phi>(v)"
 (* P - dual of the past tense operator H
    P\<phi> stands for '\<phi> has been true at some point in the past ' *)
  definition kpastpoint :: "e\<Rightarrow>e" ("P _")
    where "P \<phi> \<equiv> \<^bold>\<not> H \<^bold>\<not> \<phi>"
  definition kdstit :: "(i\<Rightarrow>i\<Rightarrow>bool)\<Rightarrow>e\<Rightarrow>e" ("_ dstit _") where "r dstit \<phi> \<equiv> (r cstit \<phi>)  \<^bold>\<and> \<^bold>\<not> \<^bold>\<box> \<phi>"

  definition union_set :: "(e\<Rightarrow>bool)\<Rightarrow>(e\<Rightarrow>bool)\<Rightarrow>(e\<Rightarrow>bool)"  ("_ \<^bold>\<union> _")
  where "A \<^bold>\<union> B \<equiv> \<lambda>w. (A w) \<or> (B w)"

  named_theorems Defs
  declare knot_def[Defs] kor_def[Defs] kand_def[Defs] kimp_def[Defs] kvalid_def[Defs]
          kbox_def[Defs] kdia_def[Defs] kcstit_def[Defs] kdstit_def[Defs] kgstit_def[Defs]
          kfuture_def[Defs] kpast_def[Defs] kpastpoint_def[Defs] ktrue_def[Defs] kfalse_def[Defs]
             union_set_def[Defs]
          k45box_def[Defs] k45dia_def[Defs]

 (* Subset for relations *)
 abbreviation subset_rel :: "(i\<Rightarrow>i\<Rightarrow>bool)\<Rightarrow>(i\<Rightarrow>i\<Rightarrow>bool)\<Rightarrow>bool"  ("_ \<^bold>\<subseteq> _")
   where "r1 \<^bold>\<subseteq> r2 \<equiv> \<forall>w. \<forall>v. (r1 w v) \<longrightarrow> (r2 w v) "
 (* Composition of 2 relations *)
 abbreviation comp_rel :: "(i\<Rightarrow>i\<Rightarrow>bool)\<Rightarrow>(i\<Rightarrow>i\<Rightarrow>bool)\<Rightarrow>(i\<Rightarrow>i\<Rightarrow>bool)"  ("_ \<^bold>\<circ> _")
   where "r1 \<^bold>\<circ> r2 \<equiv> \<lambda>w. \<lambda>v. \<exists>u.( (r1 w u) \<and> (r2 u v))"
 (* Intersection between 2 relations *)
 abbreviation intersection_rel :: "(i\<Rightarrow>i\<Rightarrow>bool)\<Rightarrow>(i\<Rightarrow>i\<Rightarrow>bool)\<Rightarrow>(i\<Rightarrow>i\<Rightarrow>bool)"  ("_ \<^bold>\<inter> _")
  where "r1 \<^bold>\<inter> r2 \<equiv> \<lambda>w. \<lambda>v. (r1 w v) \<and> (r2 w v)"
 (* Reflexive relation *)
 abbreviation reflexive
   where "reflexive r \<equiv> (\<forall>x. r x x)"
 (* Symmetric relation *)
 abbreviation symmetric
   where "symmetric r \<equiv> (\<forall>x y. r x y \<longrightarrow> r y x)"
 (* Transitive relation *)
 abbreviation transitive
   where "transitive r \<equiv> (\<forall>x y z. ((r x y) \<and> (r y z) \<longrightarrow> (r x z)))"
 (* Serial relation *)
 abbreviation serial
   where "serial r \<equiv> (\<forall>w. \<exists>v. r w v)"
 (* Inverse relation *)
 abbreviation inverse :: "(i\<Rightarrow>i\<Rightarrow>bool)\<Rightarrow>(i\<Rightarrow>i\<Rightarrow>bool)\<Rightarrow>bool"
  where "inverse r s \<equiv> \<forall>w. \<forall>v. (r w v) \<longleftrightarrow> (s v w)"
 abbreviation euclidean
   where "euclidean rel \<equiv> (\<forall>x y z. ((rel x y) \<and> (rel x z) \<longrightarrow> (rel y z)))"

 (* Abbrevations for conditions on the relations *)
 abbreviation axC1
   where "axC1 r \<equiv> r \<^bold>\<subseteq> r_box"
 abbreviation axC2 :: "(i\<Rightarrow>i\<Rightarrow>bool)\<Rightarrow>(i\<Rightarrow>i\<Rightarrow>bool)\<Rightarrow>bool"
   where "axC2 r s \<equiv> ( \<forall>w. \<forall>v. ((w rbox w) \<and> (v rbox v)
                                  \<and> (w rbox v) \<and> (v rbox w))
                         \<longrightarrow> (\<exists>x. r w x \<and> s v x))"
 abbreviation axC3 :: "(i\<Rightarrow>i\<Rightarrow>bool)\<Rightarrow>(i\<Rightarrow>i\<Rightarrow>bool)\<Rightarrow>bool"
   where "axC3 r s \<equiv> (\<forall>w.\<forall>v. (w ragt v) = (r w v \<and> s w v))"

axiomatization where
  (* r45 fulfills transitivity and euclideaness *)
 (* ax_reflex_r45 : "reflexive r_45" *)
  ax_trans_r45 : "transitive r_45" and
  ax_euclidean_r45 : "euclidean r_45"

lemma  "\<lfloor> ( \<^bold>\<box>\<^sub>l\<phi>)  \<^bold>\<supset> ( \<^bold>\<box>\<^sub>l ( \<^bold>\<box>\<^sub>l \<phi>))\<rfloor>"
  by (smt ax_trans_r45 k45box_def kimp_def kvalid_def)

lemma  "\<lfloor> (\<^bold>\<diamond>\<^sub>l\<phi>)  \<^bold>\<supset> ( \<^bold>\<box>\<^sub>l(\<^bold>\<diamond>\<^sub>l \<phi>))\<rfloor>"
  by (smt ax_euclidean_r45 k45box_def k45dia_def kimp_def knot_def kvalid_def)

axiomatization where
  (* rbox is an equivalence relation between the worlds in W *)
  ax_refl_rbox: "reflexive r_box" and
  ax_sym_rbox : "symmetric r_box" and
  ax_trans_rbox : "transitive r_box" and

  (* ragt is an equivalence relation between the worlds in W *)
  ax_refl_ragt: "reflexive r_agt" and
  ax_sym_ragt: "symmetric r_agt" and
  ax_trans_ragt: "transitive r_agt" and

  (* every r is an equivalence relation between the worlds in W *)
  ax_refl_a1:  "reflexive a1" and
  ax_sym_a1: "symmetric a1" and
  ax_trans_a1:  "transitive a1" and

  ax_refl_a2:  "reflexive a2" and
  ax_sym_a2: "symmetric a2" and
  ax_trans_a2:  "transitive a2" and

  (*  rG and rH are binary relations between worlds in W  such that
    rG is serial and transitive,
    rH is the inverse relation of rG *)
 (* ax_ser_rG: "serial r_G" and *)
  ax_trans_rG: "transitive r_G" and
  ax_inverse_rG_rH: "inverse r_G r_H"
lemma ax_1: "\<exists>w. w=w" by simp (* W is a nonempty set of possible worlds *)

axiomatization where
  axC1_a1: "axC1 a1"

axiomatization where
  axC1_a2: "axC1 a2"

axiomatization where
  axC2_a1_a2 : "axC2 a1 a2 "

axiomatization where
  axC3_a1_a2 : "axC3 a1 a2 "

lemma True nitpick [satisfy,user_axioms,show_all] oops

axiomatization where
  ax_C4 : "\<forall>w. \<forall>v. \<forall>u. ((w rG u) \<and> (w rG v))
           \<longrightarrow> ((u rG v) \<or> (v rG u) \<or> (u=v))"

lemma True nitpick [satisfy,user_axioms,show_all] oops

axiomatization where
  ax_C5 : "\<forall>w. \<forall>v. \<forall>u. ((w rH u) \<and> (w rH v))
           \<longrightarrow> ((u rH v) \<or> (v rH u) \<or> (u=v))"

lemma True nitpick [satisfy,user_axioms,show_all] oops

axiomatization where
  ax_C6 : "(r_G \<^bold>\<circ> r_box) \<^bold>\<subseteq> (r_agt \<^bold>\<circ> r_G)"

axiomatization where
  ax_C7 : "\<forall>w.\<forall>v. (w rbox v) \<longrightarrow> \<not> (w rG v)"

lemma True nitpick [satisfy,user_axioms,show_all] oops

(* Some Test *)

consts a::e b::e x::e y::e
(* K = {(a, [a1 cstit x])}, A = {a} *)
(* [a1 cstit x] \<in> out2(K,a) *)
lemma "\<lfloor> ((a \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit x)) \<^bold>\<and> (a)) \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit x) \<rfloor> \<and> \<lfloor>(a1 cstit x)\<^bold>\<supset> (a1 cstit x) \<rfloor>"
  by (simp add: kand_def kimp_def kvalid_def)

(* WO rule of I/O STIT logic with out2 *)
(*  x \<in> out2(K,A) *)
lemma "\<lfloor> ((a \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit x)) \<^bold>\<and> (a)) \<^bold>\<supset> \<^bold>\<box>\<^sub>l(x) \<rfloor> \<and> \<lfloor>(a1 cstit x)\<^bold>\<supset> (x) \<rfloor>"
  using ax_refl_a1 k45box_def kand_def kcstit_def kimp_def kvalid_def by auto
(* \<^bold>\<diamond>[a1 cstit x] \<in> out2(K,A) *)
lemma "\<lfloor> ((a \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit x)) \<^bold>\<and> (a)) \<^bold>\<supset> \<^bold>\<box>\<^sub>l(\<^bold>\<diamond>(a1 cstit x)) \<rfloor> \<and> \<lfloor>(a1 cstit x)\<^bold>\<supset> (\<^bold>\<diamond>(a1 cstit x)) \<rfloor>"
   using ax_refl_rbox k45box_def kand_def kbox_def kdia_def kimp_def knot_def kvalid_def by auto
(* [a1 cstit (x\<or>y)] \<in> out2(K,A) *)
lemma "\<lfloor>((a \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit (x)))\<^bold>\<and>(a)) \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit (x\<^bold>\<or>y)) \<rfloor> \<and> \<lfloor>(a1 cstit x)\<^bold>\<supset> (a1 cstit (x\<^bold>\<or>y))\<rfloor>"
  by (simp add: k45box_def kand_def kcstit_def kimp_def kor_def kvalid_def)

(* SI rule for I/O STIT with out2 *)
(* [a1 cstit x] \<in> out2(K,{a\<and>b}) *)
lemma "\<lfloor> ((a \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit x)) \<^bold>\<and> (a \<^bold>\<and> b)) \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit x) \<rfloor> \<and> \<lfloor>(a1 cstit x)\<^bold>\<supset> (a1 cstit x) \<rfloor>"
  by (simp add: kand_def kimp_def kvalid_def)

definition "G \<equiv> (\<lambda>X. X=(a, (a1 cstit x)))" declare G_def[Defs]
definition "A \<equiv>(\<lambda>X. X=a)" declare A_def[Defs]
definition "G_Box \<equiv> \<lambda>x. \<exists>y z. ( (x=(y \<^bold>\<supset> \<^bold>\<box>\<^sub>lz)) \<and> G(y,z)) " declare G_Box_def[Defs]

lemma "G_Box(a \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit x))"
  by (simp add: G_Box_def G_def)

lemma "(G_Box \<^bold>\<union> A)(a)"
  by (simp add: A_def union_set_def)

(*lemma "G_L G (a1 cstit x)"
  by (simp add: G_L_def G_def)*)

(* Sledgehammer times out / Nitpick no counter model *)
lemma "out2 G (a1 cstit x)"
  nitpick[user_axioms,show_all] oops

lemma "\<lfloor> ((a \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit x)) \<^bold>\<and> (a)) \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit x) \<rfloor>"
  by (simp add: kand_def kimp_def kvalid_def)
consts z::e

(* K = {(a, [a1 cstit x])} A = {a} *)
definition "K \<equiv> (\<lambda>X. X= (a, (a1 cstit x))) " declare K_def[Defs]
(* WO rule of I/O STIT logic with out1 *)
(*out1 *)
(* [a1 cstit x] \<in> out1(K,a)  - timeout*)
lemma "out1 K a (a1 cstit x)"   nitpick[user_axioms,show_all] oops
(*  x \<in> out1(K,a)  - timeout*)
lemma "out1 K a x" nitpick[user_axioms,show_all] oops
(* \<^bold>\<diamond>[a1 cstit x] \<in> out1(K,a)  - timeout*)
lemma "out1 K a (\<^bold>\<diamond>(a1 cstit x))"  nitpick[user_axioms,show_all] oops
(* [a1 cstit (x\<or>y)] \<in> out1(K,a)  - timeout*)
lemma "out1 K a (a1 cstit (x\<^bold>\<or>y))" nitpick[user_axioms,show_all] oops

(* SI rule for I/O STIT with out1 *)
(* [a1 cstit x] \<in> out1(K,{a\<and>b})  - timeout*)
lemma "out1 K (a \<^bold>\<and> b) (a1 cstit x)" nitpick[user_axioms,show_all] oops

(* M = {(a, [a1 cstit x]), (a, [a1 cstit y])} *)
definition "M \<equiv> (\<lambda>X. X= (a, (a1 cstit x)) \<or> X=(a, (a1 cstit y))) " declare M_def[Defs]
(* AND rule for I/O STIT  with out1*)
(* [a1 cstit x] \<in> out1(M,a)  - timeout*)
lemma "out1 M a ((a1 cstit x)\<^bold>\<and>(a1 cstit y))"  nitpick[user_axioms,show_all] oops
(* [a1 cstit (x\<and>y)] \<in> out2(M,a) - timeout  *)
lemma "out1 M a (a1 cstit (x\<^bold>\<and>y))"  nitpick[user_axioms,show_all] oops

(* OR rule for I/O STIT with out1*)
(* T = {(a, [a1 cstit x]), (b, [a1 cstit x]))} *)
definition "T \<equiv> (\<lambda>X. X= (a, (a1 cstit x)) \<or> X= (b, (a1 cstit x)))" declare T_def[Defs]

(* [a1 cstit x] \<in> out1(T,{a \<or> b})? No, countermodel*)
lemma "out1 T (a \<^bold>\<or> b) (a1 cstit x)"  nitpick[user_axioms,show_all] oops

(* K = {(a, [a1 cstit x])}, A = {a} *)
(* [a1 cstit x] \<in> out2(K,a) *)
lemma "\<lfloor> ((a \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit x)) \<^bold>\<and> (a)) \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit x) \<rfloor> \<and> \<lfloor>(a1 cstit x)\<^bold>\<supset> (a1 cstit x) \<rfloor>"
  by (simp add: kand_def kimp_def kvalid_def)

(* WO rule of I/O STIT logic with out2 *)
(*  x \<in> out2(K,A) *)
lemma "\<lfloor> ((a \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit x)) \<^bold>\<and> (a)) \<^bold>\<supset> \<^bold>\<box>\<^sub>l(x) \<rfloor> \<and> \<lfloor>(a1 cstit x)\<^bold>\<supset> (x) \<rfloor>"
  using ax_refl_a1 k45box_def kand_def kcstit_def kimp_def kvalid_def by auto
(* \<^bold>\<diamond>[a1 cstit x] \<in> out2(K,A) *)
lemma "\<lfloor> ((a \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit x)) \<^bold>\<and> (a)) \<^bold>\<supset> \<^bold>\<box>\<^sub>l(\<^bold>\<diamond>(a1 cstit x)) \<rfloor> \<and> \<lfloor>(a1 cstit x)\<^bold>\<supset> (\<^bold>\<diamond>(a1 cstit x)) \<rfloor>"
   using ax_refl_rbox k45box_def kand_def kbox_def kdia_def kimp_def knot_def kvalid_def by auto
(* [a1 cstit (x\<or>y)] \<in> out2(K,A) *)
lemma "\<lfloor>((a \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit (x)))\<^bold>\<and>(a)) \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit (x\<^bold>\<or>y)) \<rfloor> \<and> \<lfloor>(a1 cstit x)\<^bold>\<supset> (a1 cstit (x\<^bold>\<or>y))\<rfloor>"
  by (simp add: k45box_def kand_def kcstit_def kimp_def kor_def kvalid_def)

(* SI rule for I/O STIT with out2 *)
(* [a1 cstit x] \<in> out2(K,{a\<and>b}) *)
lemma "\<lfloor> ((a \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit x)) \<^bold>\<and> (a \<^bold>\<and> b)) \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit x) \<rfloor> \<and> \<lfloor>(a1 cstit x)\<^bold>\<supset> (a1 cstit x) \<rfloor>"
  by (simp add: kand_def kimp_def kvalid_def)

(* AND rule for I/O STIT with out2 *)
(* M = {(a, [a1 cstit x]), (a, [a1 cstit y])} *)
(* ([a1 cstit (x)] \<and> [a1 cstit (y)]) \<in> out2(M,a) *)
lemma "\<lfloor> ((a \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit (x))) \<^bold>\<and> (a \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit (y))) \<^bold>\<and>(a)) \<^bold>\<supset> \<^bold>\<box>\<^sub>l((a1 cstit x)\<^bold>\<and>(a1 cstit y)) \<rfloor>
         \<and> \<lfloor>((a1 cstit x)\<^bold>\<and>(a1 cstit y)) \<^bold>\<supset> ((a1 cstit x)\<^bold>\<and>(a1 cstit y)) \<rfloor>"
  by (simp add: k45box_def kand_def kimp_def kvalid_def)
(* [a1 cstit (x\<and>y)] \<in> out2(M,a) *)
lemma "\<lfloor> ((a \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit (x))) \<^bold>\<and> (a \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit (y))) \<^bold>\<and>(a)) \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit (x\<^bold>\<and>y)) \<rfloor>
         \<and> \<lfloor>((a1 cstit x)\<^bold>\<and>(a1 cstit y)) \<^bold>\<supset> (a1 cstit (x\<^bold>\<and>y)) \<rfloor>"
  by (simp add: k45box_def kand_def kcstit_def kimp_def kvalid_def)

(* OR rule for the I/O STIT with out2 *)
(* T = {(a, [a1 cstit x]), (b, [a1 cstit x]))} *)
(* [a1 cstit x] \<in> out2(T,{a \<or> b}) *)
lemma "\<lfloor> ((a \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit x)) \<^bold>\<and> (b \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit x)) \<^bold>\<and> (a \<^bold>\<or> b)) \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit x) \<rfloor>
       \<and> \<lfloor>(a1 cstit x)\<^bold>\<supset> (a1 cstit x) \<rfloor>"
  using kand_def kimp_def kor_def kvalid_def by auto

(* ID
(*out1 *)
(* [a1 cstit x] \<in> out1(T,[a1 cstit x])? No, countermodel*)
lemma "out1 T (a1 cstit x) (a1 cstit x)"  nitpick[user_axioms,show_all] oops *)
(*out2 *)
(* [a1 cstit x] not \<in> out2(T,{[a1 cstit x]} *)
lemma  "\<lfloor> ((a \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit x)) \<^bold>\<and> (b \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit x)) \<^bold>\<and> (a1 cstit x)) \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit x) \<rfloor>
       \<and> \<lfloor>(a1 cstit x)\<^bold>\<supset> (a1 cstit x) \<rfloor>"   nitpick[user_axioms,show_all] oops
(* Cumulative Transitivity *)
definition "T1 \<equiv> (\<lambda>X. X= (a1 cstit a, a1 cstit x) \<or> X = ((a1 cstit a) \<^bold>\<and> (a1 cstit x),a1 cstit y))"
(*out1 *)
(* [a1 cstit y] \<in> out1(T1, [a1 cstit a])? No, countermodel*)
lemma "out1 T1 (a1 cstit a) (a1 cstit y)"  nitpick[user_axioms,show_all] oops
(*out2 *)
(* [a1 cstit y] \<in> out2(T1, [a1 cstit a]) *)
lemma "\<lfloor> (( (a1 cstit a ) \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit x)) \<^bold>\<and> (((a1 cstit a) \<^bold>\<and> (a1 cstit x)) \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit y))
           \<^bold>\<and> (a1 cstit a)) \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit y) \<rfloor>
       \<and> \<lfloor>((a1 cstit x) \<^bold>\<and> (a1 cstit y))\<^bold>\<supset> (a1 cstit y) \<rfloor>"  nitpick[user_axioms,show_all] oops

definition "T2 \<equiv> (\<lambda>X. X= (a1 cstit x, a1 cstit y) \<or> X = ((a1 cstit y),a1 cstit z))"
(*out1 *)
(* [a1 cstit z] \<in> out1(TT, [a1 cstit x])? No, countermodel*)
lemma "out1 T2 (a1 cstit x) (a1 cstit z)"  nitpick[user_axioms,show_all] oops
(*out2 *)
(* [a1 cstit z] \<in> out2(T2, [a1 cstit x]) *)
lemma "\<lfloor> (( (a1 cstit x ) \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit y)) \<^bold>\<and> ((a1 cstit y) \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit z))
           \<^bold>\<and> (a1 cstit x)) \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit z) \<rfloor>
       \<and> \<lfloor>((a1 cstit y) \<^bold>\<and> (a1 cstit z))\<^bold>\<supset> (a1 cstit z) \<rfloor>"  nitpick[user_axioms,show_all] oops

definition "S \<equiv> (\<lambda>X. X= (a, (a1 cstit x)) \<or> X=(a, (a2 cstit y))) "
declare S_def[Defs]
(*out1 *)
(* [gstit (x \<and> y)] \<in> out1(S,a)? Timeout*)
lemma "out1 S (a) (gstit (x \<^bold>\<and> y))" nitpick[user_axioms,show_all] oops
(*out2 *)
(* [gstit (x \<and> y)] \<in> out2(S,a) *)
lemma "\<lfloor> ((a \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit (x) )) \<^bold>\<and> (a \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a2 cstit (y) )) \<^bold>\<and>(a)) \<^bold>\<supset> \<^bold>\<box>\<^sub>l(gstit (x \<^bold>\<and> y) ) \<rfloor>
         \<and> \<lfloor>((a1 cstit x)\<^bold>\<and>(a2 cstit y)) \<^bold>\<supset> (gstit (x \<^bold>\<and> y)) \<rfloor>"
  by (simp add: axC3_a1_a2 k45box_def kand_def kcstit_def kgstit_def kimp_def kvalid_def)

definition "W \<equiv> (\<lambda>X. X= (a,gstit z))" declare W_def[Defs]
(*out1 *)
(* [a1 cstit z] \<and> [a2 cstit z] \<in> out1(W,a)? No*)
lemma "out1 W (a) ((a1 cstit z) \<^bold>\<and> (a2 cstit z))" nitpick[user_axioms,show_all] oops
(*out2 *)
(* [a1 cstit z] \<and> [a2 cstit z] \<in> out2(W,a) ?
  No, we dont have  [gstit z] \<supset> ([a1 cstit z] \<and> [a2 cstit z])   *)
lemma "\<lfloor> ((a \<^bold>\<supset> \<^bold>\<box>\<^sub>l(gstit (z)))\<^bold>\<and>(a)) \<^bold>\<supset> \<^bold>\<box>\<^sub>l((a1 cstit z)\<^bold>\<and>(a2 cstit z)) \<rfloor>
         \<and> \<lfloor>(gstit z) \<^bold>\<supset> ((a1 cstit z) \<^bold>\<and> (a2 cstit z)) \<rfloor>" unfolding Defs nitpick[user_axioms,show_all] oops

definition "L \<equiv> (\<lambda>X. X= (a, (a1 cstit x)) \<or> X=(a, (a2 cstit x))) " declare L_def[Defs]
(* [gstit x] \<in> out2(L,a) *)
lemma "\<lfloor> ((a \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a1 cstit (x) )) \<^bold>\<and> (a \<^bold>\<supset> \<^bold>\<box>\<^sub>l(a2 cstit (x) )) \<^bold>\<and>(a)) \<^bold>\<supset> \<^bold>\<box>\<^sub>l(gstit x) \<rfloor>
         \<and> \<lfloor>((a1 cstit x)\<^bold>\<and>(a2 cstit x)) \<^bold>\<supset> (gstit x) \<rfloor>"
  by (simp add: axC3_a1_a2 k45box_def kand_def kcstit_def kgstit_def kimp_def kvalid_def)

(* Some test with \<^bold>\<box>\<^sub>l and \<^bold>\<box> *)
definition "R \<equiv> (\<lambda>X. X = (a, \<^bold>\<box>x))" declare R_def[Defs]
(* \<^bold>\<box> x \<in> out1(R,a) - Timeout *)
lemma "out1 R (a) (\<^bold>\<box>x)" nitpick[user_axioms,show_all] oops
(* \<^bold>\<box> x \<in> out2(R,a) *)
lemma "\<lfloor> ((a \<^bold>\<supset> \<^bold>\<box>\<^sub>l(\<^bold>\<box> x)) \<^bold>\<and> (a))\<^bold>\<supset> \<^bold>\<box>\<^sub>l(\<^bold>\<box> x)  \<rfloor> \<and> \<lfloor> (\<^bold>\<box> x)\<^bold>\<supset> (\<^bold>\<box> x) \<rfloor>"
  by (simp add: kand_def kimp_def kvalid_def)
(* \<diamond>x \<in> out1(R,a) - Timeout *)
lemma "out1 R (a) (\<^bold>\<diamond>x)" nitpick[user_axioms,show_all] oops
(* \<diamond>x \<in> out2(R,a) *)
lemma "\<lfloor> ((a \<^bold>\<supset> \<^bold>\<box>\<^sub>l(\<^bold>\<box> x)) \<^bold>\<and> (a))\<^bold>\<supset> \<^bold>\<box>\<^sub>l(\<^bold>\<diamond> x)  \<rfloor> \<and> \<lfloor> (\<^bold>\<box> x)\<^bold>\<supset> (\<^bold>\<diamond> x) \<rfloor>"
  using ax_refl_rbox k45box_def kand_def kbox_def kdia_def kimp_def knot_def kvalid_def by auto
(* x \<in> out1(R,a) - Timeout *)
lemma "out1 R (a) (x)" nitpick[user_axioms,show_all] oops
(* x \<in> out2(R,a) *)
lemma "\<lfloor> ((a \<^bold>\<supset> \<^bold>\<box>\<^sub>l(\<^bold>\<box> x)) \<^bold>\<and> (a))\<^bold>\<supset> \<^bold>\<box>\<^sub>l( x)  \<rfloor> \<and> \<lfloor> (\<^bold>\<box> x)\<^bold>\<supset> ( x) \<rfloor>"
  by (simp add: ax_refl_rbox k45box_def kand_def kbox_def kimp_def kvalid_def)
(* (x \<^bold>\<or> y) \<in> out1(R,a) - Timeout *)
lemma "out1 R (a) (x \<^bold>\<or> y)" nitpick[user_axioms,show_all] oops
(* (x \<or> y) \<in> out2(R,a) *)
lemma "\<lfloor> ((a \<^bold>\<supset> \<^bold>\<box>\<^sub>l(\<^bold>\<box> x)) \<^bold>\<and> (a))\<^bold>\<supset> \<^bold>\<box>\<^sub>l( x \<^bold>\<or> y)  \<rfloor> \<and> \<lfloor> (\<^bold>\<box> x)\<^bold>\<supset> (x \<^bold>\<or> y) \<rfloor>"
  by (simp add: ax_refl_rbox k45box_def kand_def kbox_def kimp_def kor_def kvalid_def)
(* [a1 cstit x] \<in> out1(R,a) - Timeout *)
lemma "out1 R (a) ( a1 cstit x)" nitpick[user_axioms,show_all] oops
(* [a1 cstit x] \<in> out2(R,a) *)
lemma "\<lfloor> ((a \<^bold>\<supset> \<^bold>\<box>\<^sub>l(\<^bold>\<box> x)) \<^bold>\<and> (a))\<^bold>\<supset> \<^bold>\<box>\<^sub>l( a1 cstit x)  \<rfloor>"
  by (simp add: axC1_a1 k45box_def kand_def kbox_def kcstit_def kimp_def kvalid_def)
lemma "\<lfloor> (\<^bold>\<box> x)\<^bold>\<supset> (a1 cstit x) \<rfloor>"
  by (simp add: axC1_a1 kbox_def kcstit_def kimp_def kvalid_def)
(* [a2 cstit x] \<in> out1(R,a) - Timeout *)
lemma "out1 R (a) ( a2 cstit x)" nitpick[user_axioms,show_all] oops
(* [a2 cstit x] \<in> out2(R,a) *)
lemma "\<lfloor> ((a \<^bold>\<supset> \<^bold>\<box>\<^sub>l(\<^bold>\<box> x)) \<^bold>\<and> (a))\<^bold>\<supset> \<^bold>\<box>\<^sub>l( a2 cstit x)  \<rfloor>"
  by (simp add: axC1_a2 k45box_def kand_def kbox_def kcstit_def kimp_def kvalid_def)
lemma "\<lfloor> (\<^bold>\<box> x)\<^bold>\<supset> (a2 cstit x) \<rfloor>"
  by (simp add: axC1_a2 kbox_def kcstit_def kimp_def kvalid_def)
(* ([a1 cstit x] \<and> [a2 cstit x]) \<in> out1(R,a) - Timeout *)
lemma "out1 R (a) ((a1 cstit x) \<^bold>\<and> (a2 cstit x))" nitpick[user_axioms,show_all] oops
(* ([a1 cstit x] \<and> [a2 cstit x]) \<in> out2(R,a) *)
lemma "\<lfloor> ((a \<^bold>\<supset> \<^bold>\<box>\<^sub>l(\<^bold>\<box> x)) \<^bold>\<and> (a))\<^bold>\<supset> \<^bold>\<box>\<^sub>l((a1 cstit x) \<^bold>\<and> (a2 cstit x))  \<rfloor>"
  by (simp add: axC1_a1 axC1_a2 k45box_def kand_def kbox_def kcstit_def kimp_def kvalid_def)
lemma "\<lfloor> (\<^bold>\<box> x)\<^bold>\<supset> ((a1 cstit x) \<^bold>\<and> (a2 cstit x)) \<rfloor>"
  by (simp add: axC1_a1 axC1_a2 kand_def kbox_def kcstit_def kimp_def kvalid_def)
(* [gstit x] \<in> out1(R,a) - Timeout *)
lemma "out1 R (a) (gstit x)" nitpick[user_axioms,show_all] oops
(* [gstit x] \<in> out2(R,a) *)
lemma "\<lfloor> ((a \<^bold>\<supset> \<^bold>\<box>\<^sub>l(\<^bold>\<box> x)) \<^bold>\<and> (a))\<^bold>\<supset> \<^bold>\<box>\<^sub>l(gstit x)  \<rfloor>"
  by (simp add: axC1_a2 axC3_a1_a2 k45box_def kand_def kbox_def kgstit_def kimp_def kvalid_def)
lemma "\<lfloor> (\<^bold>\<box> x)\<^bold>\<supset> (gstit x) \<rfloor>"
  by (simp add: axC1_a1 axC3_a1_a2 kbox_def kgstit_def kimp_def kvalid_def)
end


(*  Title:      HOL/MicroJava/DFA/LBVSpec.thy
    Author:     Gerwin Klein
    Copyright   1999 Technische Universitaet Muenchen
*)

section {* The Lightweight Bytecode Verifier *}

theory LBVSpec
imports SemilatAlg Opt
begin

type_synonym 's certificate = "'s list"

primrec merge :: "'s certificate \<Rightarrow> 's binop \<Rightarrow> 's ord \<Rightarrow> 's \<Rightarrow> nat \<Rightarrow> (nat \<times> 's) list \<Rightarrow> 's \<Rightarrow> 's" where
  "merge cert f r T pc []     x = x"
| "merge cert f r T pc (s#ss) x = merge cert f r T pc ss (let (pc',s') = s in
                                  if pc'=pc+1 then s' +_f x
                                  else if s' <=_r (cert!pc') then x
                                  else T)"

definition wtl_inst :: "'s certificate \<Rightarrow> 's binop \<Rightarrow> 's ord \<Rightarrow> 's \<Rightarrow>
             's step_type \<Rightarrow> nat \<Rightarrow> 's \<Rightarrow> 's" where
"wtl_inst cert f r T step pc s \<equiv> merge cert f r T pc (step pc s) (cert!(pc+1))"

definition wtl_cert :: "'s certificate \<Rightarrow> 's binop \<Rightarrow> 's ord \<Rightarrow> 's \<Rightarrow> 's \<Rightarrow>
             's step_type \<Rightarrow> nat \<Rightarrow> 's \<Rightarrow> 's" where
"wtl_cert cert f r T B step pc s \<equiv>
  if cert!pc = B then
    wtl_inst cert f r T step pc s
  else
    if s <=_r (cert!pc) then wtl_inst cert f r T step pc (cert!pc) else T"

primrec wtl_inst_list :: "'a list \<Rightarrow> 's certificate \<Rightarrow> 's binop \<Rightarrow> 's ord \<Rightarrow> 's \<Rightarrow> 's \<Rightarrow>
                  's step_type \<Rightarrow> nat \<Rightarrow> 's \<Rightarrow> 's" where
  "wtl_inst_list []     cert f r T B step pc s = s"
| "wtl_inst_list (i#is) cert f r T B step pc s =
    (let s' = wtl_cert cert f r T B step pc s in
      if s' = T \<or> s = T then T else wtl_inst_list is cert f r T B step (pc+1) s')"

definition cert_ok :: "'s certificate \<Rightarrow> nat \<Rightarrow> 's \<Rightarrow> 's \<Rightarrow> 's set \<Rightarrow> bool" where
  "cert_ok cert n T B A \<equiv> (\<forall>i < n. cert!i \<in> A \<and> cert!i \<noteq> T) \<and> (cert!n = B)"

definition bottom :: "'a ord \<Rightarrow> 'a \<Rightarrow> bool" where
  "bottom r B \<equiv> \<forall>x. B <=_r x"

locale lbv = Semilat +
  fixes T :: "'a" ("\<top>")
  fixes B :: "'a" ("\<bottom>")
  fixes step :: "'a step_type"
  assumes top: "top r \<top>"
  assumes T_A: "\<top> \<in> A"
  assumes bot: "bottom r \<bottom>"
  assumes B_A: "\<bottom> \<in> A"

  fixes merge :: "'a certificate \<Rightarrow> nat \<Rightarrow> (nat \<times> 'a) list \<Rightarrow> 'a \<Rightarrow> 'a"
  defines mrg_def: "merge cert \<equiv> LBVSpec.merge cert f r \<top>"

  fixes wti :: "'a certificate \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a"
  defines wti_def: "wti cert \<equiv> wtl_inst cert f r \<top> step"

  fixes wtc :: "'a certificate \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a"
  defines wtc_def: "wtc cert \<equiv> wtl_cert cert f r \<top> \<bottom> step"

  fixes wtl :: "'b list \<Rightarrow> 'a certificate \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a"
  defines wtl_def: "wtl ins cert \<equiv> wtl_inst_list ins cert f r \<top> \<bottom> step"

lemma (in lbv) wti:
  "wti c pc s \<equiv> merge c pc (step pc s) (c!(pc+1))"
  by (simp add: wti_def mrg_def wtl_inst_def)

lemma (in lbv) wtc:
  "wtc c pc s \<equiv> if c!pc = \<bottom> then wti c pc s else if s <=_r c!pc then wti c pc (c!pc) else \<top>"
  by (unfold wtc_def wti_def wtl_cert_def)

lemma cert_okD1 [intro?]:
  "cert_ok c n T B A \<Longrightarrow> pc < n \<Longrightarrow> c!pc \<in> A"
  by (unfold cert_ok_def) fast

lemma cert_okD2 [intro?]:
  "cert_ok c n T B A \<Longrightarrow> c!n = B"
  by (simp add: cert_ok_def)

lemma cert_okD3 [intro?]:
  "cert_ok c n T B A \<Longrightarrow> B \<in> A \<Longrightarrow> pc < n \<Longrightarrow> c!Suc pc \<in> A"
  by (drule Suc_leI) (auto simp add: le_eq_less_or_eq dest: cert_okD1 cert_okD2)

declare Let_def [simp]

subsection "more semilattice lemmas"

lemma (in lbv) sup_top [simp, elim]:
  assumes x: "x \<in> A"
  shows "x +_f \<top> = \<top>"
proof -
  from top have "x +_f \<top> <=_r \<top>" ..
  moreover from x T_A have "\<top> <=_r x +_f \<top>" ..
  ultimately show ?thesis ..
qed

lemma (in lbv) plusplussup_top [simp, elim]:
  "set xs \<subseteq> A \<Longrightarrow> xs ++_f \<top> = \<top>"
  by (induct xs) auto

lemma (in Semilat) pp_ub1':
  assumes S: "snd`set S \<subseteq> A"
  assumes y: "y \<in> A" and ab: "(a, b) \<in> set S"
  shows "b <=_r map snd [(p', t') \<leftarrow> S . p' = a] ++_f y"
proof -
  from S have "\<forall>(x,y) \<in> set S. y \<in> A" by auto
  with semilat y ab show ?thesis by - (rule ub1')
qed

lemma (in lbv) bottom_le [simp, intro]:
  "\<bottom> <=_r x"
  by (insert bot) (simp add: bottom_def)

lemma (in lbv) le_bottom [simp]:
  "x <=_r \<bottom> = (x = \<bottom>)"
  by (blast intro: antisym_r)

subsection "merge"

lemma (in lbv) merge_Nil [simp]:
  "merge c pc [] x = x" by (simp add: mrg_def)

lemma (in lbv) merge_Cons [simp]:
  "merge c pc (l#ls) x = merge c pc ls (if fst l=pc+1 then snd l +_f x
                                        else if snd l <=_r (c!fst l) then x
                                        else \<top>)"
  by (simp add: mrg_def split_beta)

lemma (in lbv) merge_Err [simp]:
  "snd`set ss \<subseteq> A \<Longrightarrow> merge c pc ss \<top> = \<top>"
  by (induct ss) auto

lemma (in lbv) merge_not_top:
  "\<And>x. snd`set ss \<subseteq> A \<Longrightarrow> merge c pc ss x \<noteq> \<top> \<Longrightarrow>
  \<forall>(pc',s') \<in> set ss. (pc' \<noteq> pc+1 \<longrightarrow> s' <=_r (c!pc'))"
  (is "\<And>x. ?set ss \<Longrightarrow> ?merge ss x \<Longrightarrow> ?P ss")
proof (induct ss)
  show "?P []" by simp
next
  fix x ls l
  assume "?set (l#ls)" then obtain set: "snd`set ls \<subseteq> A" by simp
  assume merge: "?merge (l#ls) x"
  moreover
  obtain pc' s' where l: "l = (pc',s')" by (cases l)
  ultimately
  obtain x' where merge': "?merge ls x'" by simp
  assume "\<And>x. ?set ls \<Longrightarrow> ?merge ls x \<Longrightarrow> ?P ls" hence "?P ls" using set merge' .
  moreover
  from merge set
  have "pc' \<noteq> pc+1 \<longrightarrow> s' <=_r (c!pc')" by (simp add: l split: split_if_asm)
  ultimately
  show "?P (l#ls)" by (simp add: l)
qed

lemma (in lbv) merge_def:
  shows
  "\<And>x. x \<in> A \<Longrightarrow> snd`set ss \<subseteq> A \<Longrightarrow>
  merge c pc ss x =
  (if \<forall>(pc',s') \<in> set ss. pc'\<noteq>pc+1 \<longrightarrow> s' <=_r c!pc' then
    map snd [(p',t') \<leftarrow> ss. p'=pc+1] ++_f x
  else \<top>)"
  (is "\<And>x. _ \<Longrightarrow> _ \<Longrightarrow> ?merge ss x = ?if ss x" is "\<And>x. _ \<Longrightarrow> _ \<Longrightarrow> ?P ss x")
proof (induct ss)
  fix x show "?P [] x" by simp
next
  fix x assume x: "x \<in> A"
  fix l::"nat \<times> 'a" and ls
  assume "snd`set (l#ls) \<subseteq> A"
  then obtain l: "snd l \<in> A" and ls: "snd`set ls \<subseteq> A" by auto
  assume "\<And>x. x \<in> A \<Longrightarrow> snd`set ls \<subseteq> A \<Longrightarrow> ?P ls x"
  hence IH: "\<And>x. x \<in> A \<Longrightarrow> ?P ls x" using ls by iprover
  obtain pc' s' where [simp]: "l = (pc',s')" by (cases l)
  hence "?merge (l#ls) x = ?merge ls
    (if pc'=pc+1 then s' +_f x else if s' <=_r c!pc' then x else \<top>)"
    (is "?merge (l#ls) x = ?merge ls ?if'")
    by simp
  also have "\<dots> = ?if ls ?if'"
  proof -
    from l have "s' \<in> A" by simp
    with x have "s' +_f x \<in> A" by simp
    with x T_A have "?if' \<in> A" by auto
    hence "?P ls ?if'" by (rule IH) thus ?thesis by simp
  qed
  also have "\<dots> = ?if (l#ls) x"
    proof (cases "\<forall>(pc', s')\<in>set (l#ls). pc'\<noteq>pc+1 \<longrightarrow> s' <=_r c!pc'")
      case True
      hence "\<forall>(pc', s')\<in>set ls. pc'\<noteq>pc+1 \<longrightarrow> s' <=_r c!pc'" by auto
      moreover
      from True have
        "map snd [(p',t')\<leftarrow>ls . p'=pc+1] ++_f ?if' =
        (map snd [(p',t')\<leftarrow>l#ls . p'=pc+1] ++_f x)"
        by simp
      ultimately
      show ?thesis using True by simp
    next
      case False
      moreover
      from ls have "set (map snd [(p', t')\<leftarrow>ls . p' = Suc pc]) \<subseteq> A" by auto
      ultimately show ?thesis by auto
    qed
  finally show "?P (l#ls) x" .
qed

lemma (in lbv) merge_not_top_s:
  assumes x:  "x \<in> A" and ss: "snd`set ss \<subseteq> A"
  assumes m:  "merge c pc ss x \<noteq> \<top>"
  shows "merge c pc ss x = (map snd [(p',t') \<leftarrow> ss. p'=pc+1] ++_f x)"
proof -
  from ss m have "\<forall>(pc',s') \<in> set ss. (pc' \<noteq> pc+1 \<longrightarrow> s' <=_r c!pc')"
    by (rule merge_not_top)
  with x ss m show ?thesis by - (drule merge_def, auto split: split_if_asm)
qed

subsection "wtl-inst-list"

lemmas [iff] = not_Err_eq

lemma (in lbv) wtl_Nil [simp]: "wtl [] c pc s = s"
  by (simp add: wtl_def)

lemma (in lbv) wtl_Cons [simp]:
  "wtl (i#is) c pc s =
  (let s' = wtc c pc s in if s' = \<top> \<or> s = \<top> then \<top> else wtl is c (pc+1) s')"
  by (simp add: wtl_def wtc_def)

lemma (in lbv) wtl_Cons_not_top:
  "wtl (i#is) c pc s \<noteq> \<top> =
  (wtc c pc s \<noteq> \<top> \<and> s \<noteq> T \<and> wtl is c (pc+1) (wtc c pc s) \<noteq> \<top>)"
  by (auto simp del: split_paired_Ex)

lemma (in lbv) wtl_top [simp]:  "wtl ls c pc \<top> = \<top>"
  by (cases ls) auto

lemma (in lbv) wtl_not_top:
  "wtl ls c pc s \<noteq> \<top> \<Longrightarrow> s \<noteq> \<top>"
  by (cases "s=\<top>") auto

lemma (in lbv) wtl_append [simp]:
  "\<And>pc s. wtl (a@b) c pc s = wtl b c (pc+length a) (wtl a c pc s)"
  by (induct a) auto

lemma (in lbv) wtl_take:
  "wtl is c pc s \<noteq> \<top> \<Longrightarrow> wtl (take pc' is) c pc s \<noteq> \<top>"
  (is "?wtl is \<noteq> _ \<Longrightarrow> _")
proof -
  assume "?wtl is \<noteq> \<top>"
  hence "?wtl (take pc' is @ drop pc' is) \<noteq> \<top>" by simp
  thus ?thesis by (auto dest!: wtl_not_top simp del: append_take_drop_id)
qed

lemma take_Suc:
  "\<forall>n. n < length l \<longrightarrow> take (Suc n) l = (take n l)@[l!n]" (is "?P l")
proof (induct l)
  show "?P []" by simp
next
  fix x xs assume IH: "?P xs"
  show "?P (x#xs)"
  proof (intro strip)
    fix n assume "n < length (x#xs)"
    with IH show "take (Suc n) (x # xs) = take n (x # xs) @ [(x # xs) ! n]"
      by (cases n, auto)
  qed
qed

lemma (in lbv) wtl_Suc:
  assumes suc: "pc+1 < length is"
  assumes wtl: "wtl (take pc is) c 0 s \<noteq> \<top>"
  shows "wtl (take (pc+1) is) c 0 s = wtc c pc (wtl (take pc is) c 0 s)"
proof -
  from suc have "take (pc+1) is=(take pc is)@[is!pc]" by (simp add: take_Suc)
  with suc wtl show ?thesis by (simp add: min.absorb2)
qed

lemma (in lbv) wtl_all:
  assumes all: "wtl is c 0 s \<noteq> \<top>" (is "?wtl is \<noteq> _")
  assumes pc:  "pc < length is"
  shows  "wtc c pc (wtl (take pc is) c 0 s) \<noteq> \<top>"
proof -
  from pc have "0 < length (drop pc is)" by simp
  then  obtain i r where Cons: "drop pc is = i#r"
    by (auto simp add: neq_Nil_conv simp del: length_drop drop_eq_Nil)
  hence "i#r = drop pc is" ..
  with all have take: "?wtl (take pc is@i#r) \<noteq> \<top>" by simp
  from pc have "is!pc = drop pc is ! 0" by simp
  with Cons have "is!pc = i" by simp
  with take pc show ?thesis by (auto simp add: min.absorb2)
qed

subsection "preserves-type"

lemma (in lbv) merge_pres:
  assumes s0: "snd`set ss \<subseteq> A" and x: "x \<in> A"
  shows "merge c pc ss x \<in> A"
proof -
  from s0 have "set (map snd [(p', t')\<leftarrow>ss . p'=pc+1]) \<subseteq> A" by auto
  with x  have "(map snd [(p', t')\<leftarrow>ss . p'=pc+1] ++_f x) \<in> A"
    by (auto intro!: plusplus_closed semilat)
  with s0 x show ?thesis by (simp add: merge_def T_A)
qed

lemma pres_typeD2:
  "pres_type step n A \<Longrightarrow> s \<in> A \<Longrightarrow> p < n \<Longrightarrow> snd`set (step p s) \<subseteq> A"
  by auto (drule pres_typeD)

lemma (in lbv) wti_pres [intro?]:
  assumes pres: "pres_type step n A"
  assumes cert: "c!(pc+1) \<in> A"
  assumes s_pc: "s \<in> A" "pc < n"
  shows "wti c pc s \<in> A"
proof -
  from pres s_pc have "snd`set (step pc s) \<subseteq> A" by (rule pres_typeD2)
  with cert show ?thesis by (simp add: wti merge_pres)
qed

lemma (in lbv) wtc_pres:
  assumes pres: "pres_type step n A"
  assumes cert: "c!pc \<in> A" and cert': "c!(pc+1) \<in> A"
  assumes s: "s \<in> A" and pc: "pc < n"
  shows "wtc c pc s \<in> A"
proof -
  have "wti c pc s \<in> A" using pres cert' s pc ..
  moreover have "wti c pc (c!pc) \<in> A" using pres cert' cert pc ..
  ultimately show ?thesis using T_A by (simp add: wtc)
qed

lemma (in lbv) wtl_pres:
  assumes pres: "pres_type step (length is) A"
  assumes cert: "cert_ok c (length is) \<top> \<bottom> A"
  assumes s:    "s \<in> A"
  assumes all:  "wtl is c 0 s \<noteq> \<top>"
  shows "pc < length is \<Longrightarrow> wtl (take pc is) c 0 s \<in> A"
  (is "?len pc \<Longrightarrow> ?wtl pc \<in> A")
proof (induct pc)
  from s show "?wtl 0 \<in> A" by simp
next
  fix n assume IH: "Suc n < length is"
  then have n: "n < length is" by simp
  from IH have n1: "n+1 < length is" by simp
  assume prem: "n < length is \<Longrightarrow> ?wtl n \<in> A"
  have "wtc c n (?wtl n) \<in> A"
  using pres _ _ _ n
  proof (rule wtc_pres)
    from prem n show "?wtl n \<in> A" .
    from cert n show "c!n \<in> A" by (rule cert_okD1)
    from cert n1 show "c!(n+1) \<in> A" by (rule cert_okD1)
  qed
  also
  from all n have "?wtl n \<noteq> \<top>" by - (rule wtl_take)
  with n1 have "wtc c n (?wtl n) = ?wtl (n+1)" by (rule wtl_Suc [symmetric])
  finally  show "?wtl (Suc n) \<in> A" by simp
qed

end


(* Author: Johannes Hölzl, TU München *)

section \<open>Formalization of a Countermeasure by Koepf \& Duermuth 2009\<close>

theory Koepf_Duermuth_Countermeasure
  imports "HOL-Probability.Information" "HOL-Library.Permutation"
begin

lemma SIGMA_image_vimage:
  "snd ` (SIGMA x:f`X. f -` {x} \<inter> X) = X"
  by (auto simp: image_iff)

declare inj_split_Cons[simp]

definition extensionalD :: "'b \<Rightarrow> 'a set \<Rightarrow> ('a \<Rightarrow> 'b) set" where
  "extensionalD d A = {f. \<forall>x. x \<notin> A \<longrightarrow> f x = d}"

lemma extensionalD_empty[simp]: "extensionalD d {} = {\<lambda>x. d}"
  unfolding extensionalD_def by (simp add: set_eq_iff fun_eq_iff)

lemma funset_eq_UN_fun_upd_I:
  assumes *: "\<And>f. f \<in> F (insert a A) \<Longrightarrow> f(a := d) \<in> F A"
  and **: "\<And>f. f \<in> F (insert a A) \<Longrightarrow> f a \<in> G (f(a:=d))"
  and ***: "\<And>f x. \<lbrakk> f \<in> F A ; x \<in> G f \<rbrakk> \<Longrightarrow> f(a:=x) \<in> F (insert a A)"
  shows "F (insert a A) = (\<Union>f\<in>F A. fun_upd f a ` (G f))"
proof safe
  fix f assume f: "f \<in> F (insert a A)"
  show "f \<in> (\<Union>f\<in>F A. fun_upd f a ` G f)"
  proof (rule UN_I[of "f(a := d)"])
    show "f(a := d) \<in> F A" using *[OF f] .
    show "f \<in> fun_upd (f(a:=d)) a ` G (f(a:=d))"
    proof (rule image_eqI[of _ _ "f a"])
      show "f a \<in> G (f(a := d))" using **[OF f] .
    qed simp
  qed
next
  fix f x assume "f \<in> F A" "x \<in> G f"
  from ***[OF this] show "f(a := x) \<in> F (insert a A)" .
qed

lemma extensionalD_insert[simp]:
  assumes "a \<notin> A"
  shows "extensionalD d (insert a A) \<inter> (insert a A \<rightarrow> B) = (\<Union>f \<in> extensionalD d A \<inter> (A \<rightarrow> B). (\<lambda>b. f(a := b)) ` B)"
  apply (rule funset_eq_UN_fun_upd_I)
  using assms
  by (auto intro!: inj_onI dest: inj_onD split: if_split_asm simp: extensionalD_def)

lemma finite_extensionalD_funcset[simp, intro]:
  assumes "finite A" "finite B"
  shows "finite (extensionalD d A \<inter> (A \<rightarrow> B))"
  using assms by induct auto

lemma fun_upd_eq_iff: "f(a := b) = g(a := b') \<longleftrightarrow> b = b' \<and> f(a := d) = g(a := d)"
  by (auto simp: fun_eq_iff)

lemma card_funcset:
  assumes "finite A" "finite B"
  shows "card (extensionalD d A \<inter> (A \<rightarrow> B)) = card B ^ card A"
using \<open>finite A\<close> proof induct
  case (insert a A) thus ?case unfolding extensionalD_insert[OF \<open>a \<notin> A\<close>]
  proof (subst card_UN_disjoint, safe, simp_all)
    show "finite (extensionalD d A \<inter> (A \<rightarrow> B))" "\<And>f. finite (fun_upd f a ` B)"
      using \<open>finite B\<close> \<open>finite A\<close> by simp_all
  next
    fix f g b b' assume "f \<noteq> g" and eq: "f(a := b) = g(a := b')" and
      ext: "f \<in> extensionalD d A" "g \<in> extensionalD d A"
    have "f a = d" "g a = d"
      using ext \<open>a \<notin> A\<close> by (auto simp add: extensionalD_def)
    with \<open>f \<noteq> g\<close> eq show False unfolding fun_upd_eq_iff[of _ _ b _ _ d]
      by (auto simp: fun_upd_idem fun_upd_eq_iff)
  next
    { fix f assume "f \<in> extensionalD d A \<inter> (A \<rightarrow> B)"
      have "card (fun_upd f a ` B) = card B"
      proof (auto intro!: card_image inj_onI)
        fix b b' assume "f(a := b) = f(a := b')"
        from fun_upd_eq_iff[THEN iffD1, OF this] show "b = b'" by simp
      qed }
    then show "(\<Sum>i\<in>extensionalD d A \<inter> (A \<rightarrow> B). card (fun_upd i a ` B)) = card B * card B ^ card A"
      using insert by simp
  qed
qed simp

lemma prod_sum_distrib_lists:
  fixes P and S :: "'a set" and f :: "'a \<Rightarrow> _::semiring_0" assumes "finite S"
  shows "(\<Sum>ms\<in>{ms. set ms \<subseteq> S \<and> length ms = n \<and> (\<forall>i<n. P i (ms!i))}. \<Prod>x<n. f (ms ! x)) =
         (\<Prod>i<n. \<Sum>m\<in>{m\<in>S. P i m}. f m)"
proof (induct n arbitrary: P)
  case 0 then show ?case by (simp cong: conj_cong)
next
  case (Suc n)
  have *: "{ms. set ms \<subseteq> S \<and> length ms = Suc n \<and> (\<forall>i<Suc n. P i (ms ! i))} =
    (\<lambda>(xs, x). x#xs) ` ({ms. set ms \<subseteq> S \<and> length ms = n \<and> (\<forall>i<n. P (Suc i) (ms ! i))} \<times> {m\<in>S. P 0 m})"
    apply (auto simp: image_iff length_Suc_conv)
    apply force+
    apply (case_tac i)
    by force+
  show ?case unfolding *
    using Suc[of "\<lambda>i. P (Suc i)"]
    by (simp add: sum.reindex sum_cartesian_product'
      lessThan_Suc_eq_insert_0 prod.reindex sum_distrib_right[symmetric] sum_distrib_left[symmetric])
qed

declare space_point_measure[simp]

declare sets_point_measure[simp]

lemma measure_point_measure:
  "finite \<Omega> \<Longrightarrow> A \<subseteq> \<Omega> \<Longrightarrow> (\<And>x. x \<in> \<Omega> \<Longrightarrow> 0 \<le> p x) \<Longrightarrow>
    measure (point_measure \<Omega> (\<lambda>x. ennreal (p x))) A = (\<Sum>i\<in>A. p i)"
  unfolding measure_def
  by (subst emeasure_point_measure_finite) (auto simp: subset_eq sum_nonneg)

locale finite_information =
  fixes \<Omega> :: "'a set"
    and p :: "'a \<Rightarrow> real"
    and b :: real
  assumes finite_space[simp, intro]: "finite \<Omega>"
  and p_sums_1[simp]: "(\<Sum>\<omega>\<in>\<Omega>. p \<omega>) = 1"
  and positive_p[simp, intro]: "\<And>x. 0 \<le> p x"
  and b_gt_1[simp, intro]: "1 < b"

lemma (in finite_information) positive_p_sum[simp]: "0 \<le> sum p X"
   by (auto intro!: sum_nonneg)

sublocale finite_information \<subseteq> prob_space "point_measure \<Omega> p"
  by standard (simp add: one_ereal_def emeasure_point_measure_finite)

sublocale finite_information \<subseteq> information_space "point_measure \<Omega> p" b
  by standard simp

lemma (in finite_information) \<mu>'_eq: "A \<subseteq> \<Omega> \<Longrightarrow> prob A = sum p A"
  by (auto simp: measure_point_measure)

locale koepf_duermuth = K: finite_information keys K b + M: finite_information messages M b
    for b :: real
    and keys :: "'key set" and K :: "'key \<Rightarrow> real"
    and messages :: "'message set" and M :: "'message \<Rightarrow> real" +
  fixes observe :: "'key \<Rightarrow> 'message \<Rightarrow> 'observation"
    and n :: nat
begin

definition msgs :: "('key \<times> 'message list) set" where
  "msgs = keys \<times> {ms. set ms \<subseteq> messages \<and> length ms = n}"

definition P :: "('key \<times> 'message list) \<Rightarrow> real" where
  "P = (\<lambda>(k, ms). K k * (\<Prod>i<n. M (ms ! i)))"

end

sublocale koepf_duermuth \<subseteq> finite_information msgs P b
proof
  show "finite msgs" unfolding msgs_def
    using finite_lists_length_eq[OF M.finite_space, of n]
    by auto

  have [simp]: "\<And>A. inj_on (\<lambda>(xs, n). n # xs) A" by (force intro!: inj_onI)

  note sum_distrib_left[symmetric, simp]
  note sum_distrib_right[symmetric, simp]
  note sum_cartesian_product'[simp]

  have "(\<Sum>ms | set ms \<subseteq> messages \<and> length ms = n. \<Prod>x<length ms. M (ms ! x)) = 1"
  proof (induct n)
    case 0 then show ?case by (simp cong: conj_cong)
  next
    case (Suc n)
    then show ?case
      by (simp add: lists_length_Suc_eq lessThan_Suc_eq_insert_0
                    sum.reindex prod.reindex)
  qed
  then show "sum P msgs = 1"
    unfolding msgs_def P_def by simp
  fix x
  have "\<And> A f. 0 \<le> (\<Prod>x\<in>A. M (f x))" by (auto simp: prod_nonneg)
  then show "0 \<le> P x"
    unfolding P_def by (auto split: prod.split simp: zero_le_mult_iff)
qed auto

context koepf_duermuth
begin

definition observations :: "'observation set" where
  "observations = (\<Union>f\<in>observe ` keys. f ` messages)"

lemma finite_observations[simp, intro]: "finite observations"
  unfolding observations_def by auto

definition OB :: "'key \<times> 'message list \<Rightarrow> 'observation list" where
  "OB = (\<lambda>(k, ms). map (observe k) ms)"

definition t :: "'observation list \<Rightarrow> 'observation \<Rightarrow> nat" where
  t_def2: "t seq obs = card { i. i < length seq \<and> seq ! i = obs}"

lemma t_def: "t seq obs = length (filter ((=) obs) seq)"
  unfolding t_def2 length_filter_conv_card by (subst eq_commute) simp

lemma card_T_bound: "card ((t\<circ>OB)`msgs) \<le> (n+1)^card observations"
proof -
  have "(t\<circ>OB)`msgs \<subseteq> extensionalD 0 observations \<inter> (observations \<rightarrow> {.. n})"
    unfolding observations_def extensionalD_def OB_def msgs_def
    by (auto simp add: t_def comp_def image_iff subset_eq)
  with finite_extensionalD_funcset
  have "card ((t\<circ>OB)`msgs) \<le> card (extensionalD 0 observations \<inter> (observations \<rightarrow> {.. n}))"
    by (rule card_mono) auto
  also have "\<dots> = (n + 1) ^ card observations"
    by (subst card_funcset) auto
  finally show ?thesis .
qed

abbreviation
 "p A \<equiv> sum P A"

abbreviation
  "\<mu> \<equiv> point_measure msgs P"

abbreviation probability ("\<P>'(_') _") where
  "\<P>(X) x \<equiv> measure \<mu> (X -` x \<inter> msgs)"

abbreviation joint_probability ("\<P>'(_ ; _') _") where
  "\<P>(X ; Y) x \<equiv> \<P>(\<lambda>x. (X x, Y x)) x"

no_notation disj (infixr "|" 30)

abbreviation conditional_probability ("\<P>'(_ | _') _") where
  "\<P>(X | Y) x \<equiv> (\<P>(X ; Y) x) / \<P>(Y) (snd`x)"

notation
  entropy_Pow ("\<H>'( _ ')")

notation
  conditional_entropy_Pow ("\<H>'( _ | _ ')")

notation
  mutual_information_Pow ("\<I>'( _ ; _ ')")

lemma t_eq_imp_bij_func:
  assumes "t xs = t ys"
  shows "\<exists>f. bij_betw f {..<length xs} {..<length ys} \<and> (\<forall>i<length xs. xs ! i = ys ! (f i))"
proof -
  have "count (mset xs) = count (mset ys)"
    using assms by (simp add: fun_eq_iff count_mset t_def)
  then have "xs <~~> ys" unfolding mset_eq_perm count_inject .
  then show ?thesis by (rule permutation_Ex_bij)
qed

lemma \<P>_k: assumes "k \<in> keys" shows "\<P>(fst) {k} = K k"
proof -
  from assms have *:
      "fst -` {k} \<inter> msgs = {k}\<times>{ms. set ms \<subseteq> messages \<and> length ms = n}"
    unfolding msgs_def by auto
  show "(\<P>(fst) {k}) = K k"
    apply (simp add: \<mu>'_eq)
    apply (simp add: * P_def)
    apply (simp add: sum_cartesian_product')
    using prod_sum_distrib_lists[OF M.finite_space, of M n "\<lambda>x x. True"] \<open>k \<in> keys\<close>
    by (auto simp add: sum_distrib_left[symmetric] subset_eq prod.neutral_const)
qed

lemma fst_image_msgs[simp]: "fst`msgs = keys"
proof -
  from M.not_empty obtain m where "m \<in> messages" by auto
  then have *: "{m. set m \<subseteq> messages \<and> length m = n} \<noteq> {}"
    by (auto intro!: exI[of _ "replicate n m"])
  then show ?thesis
    unfolding msgs_def fst_image_times if_not_P[OF *] by simp
qed

lemma sum_distribution_cut:
  "\<P>(X) {x} = (\<Sum>y \<in> Y`space \<mu>. \<P>(X ; Y) {(x, y)})"
  by (subst finite_measure_finite_Union[symmetric])
     (auto simp add: disjoint_family_on_def inj_on_def
           intro!: arg_cong[where f=prob])

lemma prob_conj_imp1:
  "prob ({x. Q x} \<inter> msgs) = 0 \<Longrightarrow> prob ({x. Pr x \<and> Q x} \<inter> msgs) = 0"
  using finite_measure_mono[of "{x. Pr x \<and> Q x} \<inter> msgs" "{x. Q x} \<inter> msgs"]
  using measure_nonneg[of \<mu> "{x. Pr x \<and> Q x} \<inter> msgs"]
  by (simp add: subset_eq)

lemma prob_conj_imp2:
  "prob ({x. Pr x} \<inter> msgs) = 0 \<Longrightarrow> prob ({x. Pr x \<and> Q x} \<inter> msgs) = 0"
  using finite_measure_mono[of "{x. Pr x \<and> Q x} \<inter> msgs" "{x. Pr x} \<inter> msgs"]
  using measure_nonneg[of \<mu> "{x. Pr x \<and> Q x} \<inter> msgs"]
  by (simp add: subset_eq)

lemma simple_function_finite: "simple_function \<mu> f"
  by (simp add: simple_function_def)

lemma entropy_commute: "\<H>(\<lambda>x. (X x, Y x)) = \<H>(\<lambda>x. (Y x, X x))"
  apply (subst (1 2) entropy_simple_distributed[OF simple_distributedI[OF simple_function_finite _ refl]])
  unfolding space_point_measure
proof -
  have eq: "(\<lambda>x. (X x, Y x)) ` msgs = (\<lambda>(x, y). (y, x)) ` (\<lambda>x. (Y x, X x)) ` msgs"
    by auto
  show "- (\<Sum>x\<in>(\<lambda>x. (X x, Y x)) ` msgs. (\<P>(X ; Y) {x}) * log b (\<P>(X ; Y) {x})) =
    - (\<Sum>x\<in>(\<lambda>x. (Y x, X x)) ` msgs. (\<P>(Y ; X) {x}) * log b (\<P>(Y ; X) {x}))"
    unfolding eq
    apply (subst sum.reindex)
    apply (auto simp: vimage_def inj_on_def intro!: sum.cong arg_cong[where f="\<lambda>x. prob x * log b (prob x)"])
    done
qed simp_all

lemma (in -) measure_eq_0I: "A = {} \<Longrightarrow> measure M A = 0" by simp

lemma conditional_entropy_eq_ce_with_hypothesis:
  "\<H>(X | Y) = -(\<Sum>y\<in>Y`msgs. (\<P>(Y) {y}) * (\<Sum>x\<in>X`msgs. (\<P>(X ; Y) {(x,y)}) / (\<P>(Y) {y}) *
     log b ((\<P>(X ; Y) {(x,y)}) / (\<P>(Y) {y}))))"
  apply (subst conditional_entropy_eq[OF
    simple_distributedI[OF simple_function_finite _ refl]
    simple_distributedI[OF simple_function_finite _ refl]])
  unfolding space_point_measure
proof -
  have "- (\<Sum>(x, y)\<in>(\<lambda>x. (X x, Y x)) ` msgs. (\<P>(X ; Y) {(x, y)}) * log b ((\<P>(X ; Y) {(x, y)}) / (\<P>(Y) {y}))) =
    - (\<Sum>x\<in>X`msgs. (\<Sum>y\<in>Y`msgs. (\<P>(X ; Y) {(x, y)}) * log b ((\<P>(X ; Y) {(x, y)}) / (\<P>(Y) {y}))))"
    unfolding sum.cartesian_product
    apply (intro arg_cong[where f=uminus] sum.mono_neutral_left)
    apply (auto simp: vimage_def image_iff intro!: measure_eq_0I)
    apply metis
    done
  also have "\<dots> = - (\<Sum>y\<in>Y`msgs. (\<Sum>x\<in>X`msgs. (\<P>(X ; Y) {(x, y)}) * log b ((\<P>(X ; Y) {(x, y)}) / (\<P>(Y) {y}))))"
    by (subst sum.swap) rule
  also have "\<dots> = -(\<Sum>y\<in>Y`msgs. (\<P>(Y) {y}) * (\<Sum>x\<in>X`msgs. (\<P>(X ; Y) {(x,y)}) / (\<P>(Y) {y}) * log b ((\<P>(X ; Y) {(x,y)}) / (\<P>(Y) {y}))))"
    by (auto simp add: sum_distrib_left vimage_def intro!: sum.cong prob_conj_imp1)
  finally show "- (\<Sum>(x, y)\<in>(\<lambda>x. (X x, Y x)) ` msgs. (\<P>(X ; Y) {(x, y)}) * log b ((\<P>(X ; Y) {(x, y)}) / (\<P>(Y) {y}))) =
    -(\<Sum>y\<in>Y`msgs. (\<P>(Y) {y}) * (\<Sum>x\<in>X`msgs. (\<P>(X ; Y) {(x,y)}) / (\<P>(Y) {y}) * log b ((\<P>(X ; Y) {(x,y)}) / (\<P>(Y) {y}))))" .
qed simp_all

lemma ce_OB_eq_ce_t: "\<I>(fst ; OB) = \<I>(fst ; t\<circ>OB)"
proof -
  txt \<open>Lemma 2\<close>

  { fix k obs obs'
    assume "k \<in> keys" "K k \<noteq> 0" and obs': "obs' \<in> OB ` msgs" and obs: "obs \<in> OB ` msgs"
    assume "t obs = t obs'"
    from t_eq_imp_bij_func[OF this]
    obtain t_f where "bij_betw t_f {..<n} {..<n}" and
      obs_t_f: "\<And>i. i<n \<Longrightarrow> obs!i = obs' ! t_f i"
      using obs obs' unfolding OB_def msgs_def by auto
    then have t_f: "inj_on t_f {..<n}" "{..<n} = t_f`{..<n}" unfolding bij_betw_def by auto

    { fix obs assume "obs \<in> OB`msgs"
      then have **: "\<And>ms. length ms = n \<Longrightarrow> OB (k, ms) = obs \<longleftrightarrow> (\<forall>i<n. observe k (ms!i) = obs ! i)"
        unfolding OB_def msgs_def by (simp add: image_iff list_eq_iff_nth_eq)

      have "(\<P>(OB ; fst) {(obs, k)}) / K k =
          p ({k}\<times>{ms. (k,ms) \<in> msgs \<and> OB (k,ms) = obs}) / K k"
        apply (simp add: \<mu>'_eq) by (auto intro!: arg_cong[where f=p])
      also have "\<dots> =
          (\<Prod>i<n. \<Sum>m\<in>{m\<in>messages. observe k m = obs ! i}. M m)"
        unfolding P_def using \<open>K k \<noteq> 0\<close> \<open>k \<in> keys\<close>
        apply (simp add: sum_cartesian_product' sum_divide_distrib msgs_def ** cong: conj_cong)
        apply (subst prod_sum_distrib_lists[OF M.finite_space]) ..
      finally have "(\<P>(OB ; fst) {(obs, k)}) / K k =
            (\<Prod>i<n. \<Sum>m\<in>{m\<in>messages. observe k m = obs ! i}. M m)" . }
    note * = this

    have "(\<P>(OB ; fst) {(obs, k)}) / K k = (\<P>(OB ; fst) {(obs', k)}) / K k"
      unfolding *[OF obs] *[OF obs']
      using t_f(1) obs_t_f by (subst (2) t_f(2)) (simp add: prod.reindex)
    then have "(\<P>(OB ; fst) {(obs, k)}) = (\<P>(OB ; fst) {(obs', k)})"
      using \<open>K k \<noteq> 0\<close> by auto }
  note t_eq_imp = this

  let ?S = "\<lambda>obs. t -`{t obs} \<inter> OB`msgs"
  { fix k obs assume "k \<in> keys" "K k \<noteq> 0" and obs: "obs \<in> OB`msgs"
    have *: "((\<lambda>x. (t (OB x), fst x)) -` {(t obs, k)} \<inter> msgs) =
      (\<Union>obs'\<in>?S obs. ((\<lambda>x. (OB x, fst x)) -` {(obs', k)} \<inter> msgs))" by auto
    have df: "disjoint_family_on (\<lambda>obs'. (\<lambda>x. (OB x, fst x)) -` {(obs', k)} \<inter> msgs) (?S obs)"
      unfolding disjoint_family_on_def by auto
    have "\<P>(t\<circ>OB ; fst) {(t obs, k)} = (\<Sum>obs'\<in>?S obs. \<P>(OB ; fst) {(obs', k)})"
      unfolding comp_def
      using finite_measure_finite_Union[OF _ _ df]
      by (auto simp add: * intro!: sum_nonneg)
    also have "(\<Sum>obs'\<in>?S obs. \<P>(OB ; fst) {(obs', k)}) = real (card (?S obs)) * \<P>(OB ; fst) {(obs, k)}"
      by (simp add: t_eq_imp[OF \<open>k \<in> keys\<close> \<open>K k \<noteq> 0\<close> obs])
    finally have "\<P>(t\<circ>OB ; fst) {(t obs, k)} = real (card (?S obs)) * \<P>(OB ; fst) {(obs, k)}" .}
  note P_t_eq_P_OB = this

  { fix k obs assume "k \<in> keys" and obs: "obs \<in> OB`msgs"
    have "\<P>(t\<circ>OB | fst) {(t obs, k)} =
      real (card (t -` {t obs} \<inter> OB ` msgs)) * \<P>(OB | fst) {(obs, k)}"
      using \<P>_k[OF \<open>k \<in> keys\<close>] P_t_eq_P_OB[OF \<open>k \<in> keys\<close> _ obs] by auto }
  note CP_t_K = this

  { fix k obs assume "k \<in> keys" and obs: "obs \<in> OB`msgs"
    then have "t -`{t obs} \<inter> OB`msgs \<noteq> {}" (is "?S \<noteq> {}") by auto
    then have "real (card ?S) \<noteq> 0" by auto

    have "\<P>(fst | t\<circ>OB) {(k, t obs)} = \<P>(t\<circ>OB | fst) {(t obs, k)} * \<P>(fst) {k} / \<P>(t\<circ>OB) {t obs}"
      using finite_measure_mono[of "{x. fst x = k \<and> t (OB x) = t obs} \<inter> msgs" "{x. fst x = k} \<inter> msgs"]
      using measure_nonneg[of \<mu> "{x. fst x = k \<and> t (OB x) = t obs} \<inter> msgs"]
      by (auto simp add: vimage_def conj_commute subset_eq simp del: measure_nonneg)
    also have "(\<P>(t\<circ>OB) {t obs}) = (\<Sum>k'\<in>keys. (\<P>(t\<circ>OB|fst) {(t obs, k')}) * (\<P>(fst) {k'}))"
      using finite_measure_mono[of "{x. t (OB x) = t obs \<and> fst x = k} \<inter> msgs" "{x. fst x = k} \<inter> msgs"]
      using measure_nonneg[of \<mu> "{x. fst x = k \<and> t (OB x) = t obs} \<inter> msgs"]
      apply (simp add: sum_distribution_cut[of "t\<circ>OB" "t obs" fst])
      apply (auto intro!: sum.cong simp: subset_eq vimage_def prob_conj_imp1)
      done
    also have "\<P>(t\<circ>OB | fst) {(t obs, k)} * \<P>(fst) {k} / (\<Sum>k'\<in>keys. \<P>(t\<circ>OB|fst) {(t obs, k')} * \<P>(fst) {k'}) =
      \<P>(OB | fst) {(obs, k)} * \<P>(fst) {k} / (\<Sum>k'\<in>keys. \<P>(OB|fst) {(obs, k')} * \<P>(fst) {k'})"
      using CP_t_K[OF \<open>k\<in>keys\<close> obs] CP_t_K[OF _ obs] \<open>real (card ?S) \<noteq> 0\<close>
      by (simp only: sum_distrib_left[symmetric] ac_simps
          mult_divide_mult_cancel_left[OF \<open>real (card ?S) \<noteq> 0\<close>]
        cong: sum.cong)
    also have "(\<Sum>k'\<in>keys. \<P>(OB|fst) {(obs, k')} * \<P>(fst) {k'}) = \<P>(OB) {obs}"
      using sum_distribution_cut[of OB obs fst]
      by (auto intro!: sum.cong simp: prob_conj_imp1 vimage_def)
    also have "\<P>(OB | fst) {(obs, k)} * \<P>(fst) {k} / \<P>(OB) {obs} = \<P>(fst | OB) {(k, obs)}"
      by (auto simp: vimage_def conj_commute prob_conj_imp2)
    finally have "\<P>(fst | t\<circ>OB) {(k, t obs)} = \<P>(fst | OB) {(k, obs)}" . }
  note CP_T_eq_CP_O = this

  let ?H = "\<lambda>obs. (\<Sum>k\<in>keys. \<P>(fst|OB) {(k, obs)} * log b (\<P>(fst|OB) {(k, obs)})) :: real"
  let ?Ht = "\<lambda>obs. (\<Sum>k\<in>keys. \<P>(fst|t\<circ>OB) {(k, obs)} * log b (\<P>(fst|t\<circ>OB) {(k, obs)})) :: real"

  { fix obs assume obs: "obs \<in> OB`msgs"
    have "?H obs = (\<Sum>k\<in>keys. \<P>(fst|t\<circ>OB) {(k, t obs)} * log b (\<P>(fst|t\<circ>OB) {(k, t obs)}))"
      using CP_T_eq_CP_O[OF _ obs]
      by simp
    then have "?H obs = ?Ht (t obs)" . }
  note * = this

  have **: "\<And>x f A. (\<Sum>y\<in>t-`{x}\<inter>A. f y (t y)) = (\<Sum>y\<in>t-`{x}\<inter>A. f y x)" by auto

  { fix x
    have *: "(\<lambda>x. t (OB x)) -` {t (OB x)} \<inter> msgs =
      (\<Union>obs\<in>?S (OB x). OB -` {obs} \<inter> msgs)" by auto
    have df: "disjoint_family_on (\<lambda>obs. OB -` {obs} \<inter> msgs) (?S (OB x))"
      unfolding disjoint_family_on_def by auto
    have "\<P>(t\<circ>OB) {t (OB x)} = (\<Sum>obs\<in>?S (OB x). \<P>(OB) {obs})"
      unfolding comp_def
      using finite_measure_finite_Union[OF _ _ df]
      by (force simp add: * intro!: sum_nonneg) }
  note P_t_sum_P_O = this

  txt \<open>Lemma 3\<close>
  have "\<H>(fst | OB) = -(\<Sum>obs\<in>OB`msgs. \<P>(OB) {obs} * ?Ht (t obs))"
    unfolding conditional_entropy_eq_ce_with_hypothesis using * by simp
  also have "\<dots> = -(\<Sum>obs\<in>t`OB`msgs. \<P>(t\<circ>OB) {obs} * ?Ht obs)"
    apply (subst SIGMA_image_vimage[symmetric, of "OB`msgs" t])
    apply (subst sum.reindex)
    apply (fastforce intro!: inj_onI)
    apply simp
    apply (subst sum.Sigma[symmetric, unfolded split_def])
    using finite_space apply fastforce
    using finite_space apply fastforce
    apply (safe intro!: sum.cong)
    using P_t_sum_P_O
    by (simp add: sum_divide_distrib[symmetric] field_simps **
                  sum_distrib_left[symmetric] sum_distrib_right[symmetric])
  also have "\<dots> = \<H>(fst | t\<circ>OB)"
    unfolding conditional_entropy_eq_ce_with_hypothesis
    by (simp add: comp_def image_image[symmetric])
  finally show ?thesis
    by (subst (1 2) mutual_information_eq_entropy_conditional_entropy) simp_all
qed

theorem "\<I>(fst ; OB) \<le> real (card observations) * log b (real n + 1)"
proof -
  have "\<I>(fst ; OB) = \<H>(fst) - \<H>(fst | t\<circ>OB)"
    unfolding ce_OB_eq_ce_t
    by (rule mutual_information_eq_entropy_conditional_entropy simple_function_finite)+
  also have "\<dots> = \<H>(t\<circ>OB) - \<H>(t\<circ>OB | fst)"
    unfolding entropy_chain_rule[symmetric, OF simple_function_finite simple_function_finite] algebra_simps
    by (subst entropy_commute) simp
  also have "\<dots> \<le> \<H>(t\<circ>OB)"
    using conditional_entropy_nonneg[of "t\<circ>OB" fst] by simp
  also have "\<dots> \<le> log b (real (card ((t\<circ>OB)`msgs)))"
    using entropy_le_card[of "t\<circ>OB", OF simple_distributedI[OF simple_function_finite _ refl]] by simp
  also have "\<dots> \<le> log b (real (n + 1)^card observations)"
    using card_T_bound not_empty
    by (auto intro!: log_le simp: card_gt_0_iff of_nat_power [symmetric] simp del: of_nat_power of_nat_Suc)
  also have "\<dots> = real (card observations) * log b (real n + 1)"
    by (simp add: log_nat_power add.commute)
  finally show ?thesis  .
qed

end

end