theory Design_generated_generated imports "../Toy_Library"   "../Toy_Library_Static" begin

(* 1 ************************************ 0 + 1 *)
section \<open>Class Model: Introduction\<close>

(* 2 ************************************ 1 + 1 *)
text \<open>
  For certain concepts like classes and class-types, only a generic
  definition for its resulting semantics can be given. Generic means,
  there is a function outside HOL that ``compiles'' a concrete,
  closed-world class diagram into a ``theory'' of this data model,
  consisting of a bunch of definitions for classes, accessors, method,
  casts, and tests for actual types, as well as proofs for the
  fundamental properties of these operations in this concrete data
  model. \<close>

(* 3 ************************************ 2 + 1 *)
section \<open>Class Model: The Construction of the Object Universe\<close>

(* 4 ************************************ 3 + 1 *)
text \<open>
   Our data universe  consists in the concrete class diagram just of node's,
and implicitly of the class object. Each class implies the existence of a class
type defined for the corresponding object representations as follows: \<close>

(* 5 ************************************ 4 + 10 *)
datatype ty\<E>\<X>\<T>\<^sub>A\<^sub>t\<^sub>o\<^sub>m = mk\<E>\<X>\<T>\<^sub>A\<^sub>t\<^sub>o\<^sub>m "oid" "oid list option" "int option" "bool option" "nat option" "unit option"
datatype ty\<^sub>A\<^sub>t\<^sub>o\<^sub>m = mk\<^sub>A\<^sub>t\<^sub>o\<^sub>m "ty\<E>\<X>\<T>\<^sub>A\<^sub>t\<^sub>o\<^sub>m" "int option"
datatype ty\<E>\<X>\<T>\<^sub>M\<^sub>o\<^sub>l\<^sub>e\<^sub>c\<^sub>u\<^sub>l\<^sub>e = mk\<E>\<X>\<T>\<^sub>M\<^sub>o\<^sub>l\<^sub>e\<^sub>c\<^sub>u\<^sub>l\<^sub>e_\<^sub>A\<^sub>t\<^sub>o\<^sub>m "ty\<^sub>A\<^sub>t\<^sub>o\<^sub>m"
                        | mk\<E>\<X>\<T>\<^sub>M\<^sub>o\<^sub>l\<^sub>e\<^sub>c\<^sub>u\<^sub>l\<^sub>e "oid" "oid list option" "int option" "bool option" "nat option" "unit option"
datatype ty\<^sub>M\<^sub>o\<^sub>l\<^sub>e\<^sub>c\<^sub>u\<^sub>l\<^sub>e = mk\<^sub>M\<^sub>o\<^sub>l\<^sub>e\<^sub>c\<^sub>u\<^sub>l\<^sub>e "ty\<E>\<X>\<T>\<^sub>M\<^sub>o\<^sub>l\<^sub>e\<^sub>c\<^sub>u\<^sub>l\<^sub>e"
datatype ty\<E>\<X>\<T>\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n = mk\<E>\<X>\<T>\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n_\<^sub>M\<^sub>o\<^sub>l\<^sub>e\<^sub>c\<^sub>u\<^sub>l\<^sub>e "ty\<^sub>M\<^sub>o\<^sub>l\<^sub>e\<^sub>c\<^sub>u\<^sub>l\<^sub>e"
                        | mk\<E>\<X>\<T>\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n_\<^sub>A\<^sub>t\<^sub>o\<^sub>m "ty\<^sub>A\<^sub>t\<^sub>o\<^sub>m"
                        | mk\<E>\<X>\<T>\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n "oid" "nat option" "unit option"
datatype ty\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n = mk\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n "ty\<E>\<X>\<T>\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n" "oid list option" "int option" "bool option"
datatype ty\<E>\<X>\<T>\<^sub>G\<^sub>a\<^sub>l\<^sub>a\<^sub>x\<^sub>y = mk\<E>\<X>\<T>\<^sub>G\<^sub>a\<^sub>l\<^sub>a\<^sub>x\<^sub>y_\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n "ty\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n"
                        | mk\<E>\<X>\<T>\<^sub>G\<^sub>a\<^sub>l\<^sub>a\<^sub>x\<^sub>y_\<^sub>M\<^sub>o\<^sub>l\<^sub>e\<^sub>c\<^sub>u\<^sub>l\<^sub>e "ty\<^sub>M\<^sub>o\<^sub>l\<^sub>e\<^sub>c\<^sub>u\<^sub>l\<^sub>e"
                        | mk\<E>\<X>\<T>\<^sub>G\<^sub>a\<^sub>l\<^sub>a\<^sub>x\<^sub>y_\<^sub>A\<^sub>t\<^sub>o\<^sub>m "ty\<^sub>A\<^sub>t\<^sub>o\<^sub>m"
                        | mk\<E>\<X>\<T>\<^sub>G\<^sub>a\<^sub>l\<^sub>a\<^sub>x\<^sub>y "oid"
datatype ty\<^sub>G\<^sub>a\<^sub>l\<^sub>a\<^sub>x\<^sub>y = mk\<^sub>G\<^sub>a\<^sub>l\<^sub>a\<^sub>x\<^sub>y "ty\<E>\<X>\<T>\<^sub>G\<^sub>a\<^sub>l\<^sub>a\<^sub>x\<^sub>y" "nat option" "unit option"
datatype ty\<E>\<X>\<T>\<^sub>T\<^sub>o\<^sub>y\<^sub>A\<^sub>n\<^sub>y = mk\<E>\<X>\<T>\<^sub>T\<^sub>o\<^sub>y\<^sub>A\<^sub>n\<^sub>y_\<^sub>G\<^sub>a\<^sub>l\<^sub>a\<^sub>x\<^sub>y "ty\<^sub>G\<^sub>a\<^sub>l\<^sub>a\<^sub>x\<^sub>y"
                        | mk\<E>\<X>\<T>\<^sub>T\<^sub>o\<^sub>y\<^sub>A\<^sub>n\<^sub>y_\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n "ty\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n"
                        | mk\<E>\<X>\<T>\<^sub>T\<^sub>o\<^sub>y\<^sub>A\<^sub>n\<^sub>y_\<^sub>M\<^sub>o\<^sub>l\<^sub>e\<^sub>c\<^sub>u\<^sub>l\<^sub>e "ty\<^sub>M\<^sub>o\<^sub>l\<^sub>e\<^sub>c\<^sub>u\<^sub>l\<^sub>e"
                        | mk\<E>\<X>\<T>\<^sub>T\<^sub>o\<^sub>y\<^sub>A\<^sub>n\<^sub>y_\<^sub>A\<^sub>t\<^sub>o\<^sub>m "ty\<^sub>A\<^sub>t\<^sub>o\<^sub>m"
                        | mk\<E>\<X>\<T>\<^sub>T\<^sub>o\<^sub>y\<^sub>A\<^sub>n\<^sub>y "oid"
datatype ty\<^sub>T\<^sub>o\<^sub>y\<^sub>A\<^sub>n\<^sub>y = mk\<^sub>T\<^sub>o\<^sub>y\<^sub>A\<^sub>n\<^sub>y "ty\<E>\<X>\<T>\<^sub>T\<^sub>o\<^sub>y\<^sub>A\<^sub>n\<^sub>y"

(* 6 ************************************ 14 + 1 *)
text \<open>
   Now, we construct a concrete ``universe of ToyAny types'' by injection into a
sum type containing the class types. This type of ToyAny will be used as instance
for all respective type-variables. \<close>

(* 7 ************************************ 15 + 1 *)
datatype \<AA> = in\<^sub>A\<^sub>t\<^sub>o\<^sub>m "ty\<^sub>A\<^sub>t\<^sub>o\<^sub>m"
                        | in\<^sub>M\<^sub>o\<^sub>l\<^sub>e\<^sub>c\<^sub>u\<^sub>l\<^sub>e "ty\<^sub>M\<^sub>o\<^sub>l\<^sub>e\<^sub>c\<^sub>u\<^sub>l\<^sub>e"
                        | in\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n "ty\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n"
                        | in\<^sub>G\<^sub>a\<^sub>l\<^sub>a\<^sub>x\<^sub>y "ty\<^sub>G\<^sub>a\<^sub>l\<^sub>a\<^sub>x\<^sub>y"
                        | in\<^sub>T\<^sub>o\<^sub>y\<^sub>A\<^sub>n\<^sub>y "ty\<^sub>T\<^sub>o\<^sub>y\<^sub>A\<^sub>n\<^sub>y"

(* 8 ************************************ 16 + 1 *)
text \<open>
   Having fixed the object universe, we can introduce type synonyms that exactly correspond
to Toy types. Again, we exploit that our representation of Toy is a ``shallow embedding'' with a
one-to-one correspondance of Toy-types to types of the meta-language HOL. \<close>

(* 9 ************************************ 17 + 5 *)
type_synonym Atom = "\<langle>\<langle>ty\<^sub>A\<^sub>t\<^sub>o\<^sub>m\<rangle>\<^sub>\<bottom>\<rangle>\<^sub>\<bottom>"
type_synonym Molecule = "\<langle>\<langle>ty\<^sub>M\<^sub>o\<^sub>l\<^sub>e\<^sub>c\<^sub>u\<^sub>l\<^sub>e\<rangle>\<^sub>\<bottom>\<rangle>\<^sub>\<bottom>"
type_synonym Person = "\<langle>\<langle>ty\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n\<rangle>\<^sub>\<bottom>\<rangle>\<^sub>\<bottom>"
type_synonym Galaxy = "\<langle>\<langle>ty\<^sub>G\<^sub>a\<^sub>l\<^sub>a\<^sub>x\<^sub>y\<rangle>\<^sub>\<bottom>\<rangle>\<^sub>\<bottom>"
type_synonym ToyAny = "\<langle>\<langle>ty\<^sub>T\<^sub>o\<^sub>y\<^sub>A\<^sub>n\<^sub>y\<rangle>\<^sub>\<bottom>\<rangle>\<^sub>\<bottom>"

(* 10 ************************************ 22 + 1 *)
section \<open>Class Model: The Accessors\<close>

(* 11 ************************************ 23 + 3 *)
definition "oid\<^sub>A\<^sub>t\<^sub>o\<^sub>m_0___boss = 0"
definition "oid\<^sub>M\<^sub>o\<^sub>l\<^sub>e\<^sub>c\<^sub>u\<^sub>l\<^sub>e_0___boss = 0"
definition "oid\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n_0___boss = 0"

(* 12 ************************************ 26 + 2 *)
definition "switch\<^sub>2_01 = (\<lambda> [x0 , x1] \<Rightarrow> (x0 , x1))"
definition "switch\<^sub>2_10 = (\<lambda> [x0 , x1] \<Rightarrow> (x1 , x0))"

(* 13 ************************************ 28 + 1 *)
section \<open>Instance\<close>

(* 14 ************************************ 29 + 3 *)
definition "oid1 = 1"
definition "oid2 = 2"
definition "inst_assoc1 = (\<lambda>oid_class to_from oid. ((case (deref_assocs_list ((to_from::oid list list \<Rightarrow> oid list \<times> oid list)) ((oid::oid)) ((the ((((map_of_list ([(oid\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n_0___boss , (List.map ((\<lambda>(x , y). [x , y]) o switch\<^sub>2_01) ([[[oid1] , [oid2]]])))]))) ((oid_class::oid))))))) of Nil \<Rightarrow> None
    | l \<Rightarrow> (Some (l)))::oid list option))"

(* 15 ************************************ 32 + 0 *)

(* 16 ************************************ 32 + 1 *)
section \<open>Instance\<close>

(* 17 ************************************ 33 + 2 *)
definition "oid3 = 3"
definition "inst_assoc3 = (\<lambda>oid_class to_from oid. ((case (deref_assocs_list ((to_from::oid list list \<Rightarrow> oid list \<times> oid list)) ((oid::oid)) ((the ((((map_of_list ([]))) ((oid_class::oid))))))) of Nil \<Rightarrow> None
    | l \<Rightarrow> (Some (l)))::oid list option))"

(* 18 ************************************ 35 + 0 *)

(* 19 ************************************ 35 + 1 *)
section \<open>Instance\<close>

(* 20 ************************************ 36 + 5 *)
definition "oid4 = 4"
definition "oid5 = 5"
definition "oid6 = 6"
definition "oid7 = 7"
definition "inst_assoc4 = (\<lambda>oid_class to_from oid. ((case (deref_assocs_list ((to_from::oid list list \<Rightarrow> oid list \<times> oid list)) ((oid::oid)) ((the ((((map_of_list ([(oid\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n_0___boss , (List.map ((\<lambda>(x , y). [x , y]) o switch\<^sub>2_01) ([[[oid7] , [oid6]] , [[oid6] , [oid1]] , [[oid4] , [oid5]]])))]))) ((oid_class::oid))))))) of Nil \<Rightarrow> None
    | l \<Rightarrow> (Some (l)))::oid list option))"

(* 21 ************************************ 41 + 0 *)

(* 22 ************************************ 41 + 1 *)
section \<open>State (Floor 2)\<close>

(* 23 ************************************ 42 + 1 *)
locale state_\<sigma>\<^sub>1 =
fixes "oid1" :: "nat"
fixes "oid2" :: "nat"
fixes "oid4" :: "nat"
fixes "oid5" :: "nat"
fixes "oid6" :: "nat"
fixes "oid7" :: "nat"
assumes distinct_oid: "(distinct ([oid1 , oid2 , oid4 , oid5 , oid6 , oid7]))"
fixes "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n1\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n" :: "ty\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n"
fixes "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n1" :: "\<cdot>Person"
assumes X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n1_def: "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n1 = (\<lambda>_. \<lfloor>\<lfloor>X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n1\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n\<rfloor>\<rfloor>)"
fixes "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n2\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n" :: "ty\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n"
fixes "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n2" :: "\<cdot>Person"
assumes X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n2_def: "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n2 = (\<lambda>_. \<lfloor>\<lfloor>X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n2\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n\<rfloor>\<rfloor>)"
fixes "\<sigma>\<^sub>1_object0\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n" :: "ty\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n"
fixes "\<sigma>\<^sub>1_object0" :: "\<cdot>Person"
assumes \<sigma>\<^sub>1_object0_def: "\<sigma>\<^sub>1_object0 = (\<lambda>_. \<lfloor>\<lfloor>\<sigma>\<^sub>1_object0\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n\<rfloor>\<rfloor>)"
fixes "\<sigma>\<^sub>1_object1\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n" :: "ty\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n"
fixes "\<sigma>\<^sub>1_object1" :: "\<cdot>Person"
assumes \<sigma>\<^sub>1_object1_def: "\<sigma>\<^sub>1_object1 = (\<lambda>_. \<lfloor>\<lfloor>\<sigma>\<^sub>1_object1\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n\<rfloor>\<rfloor>)"
fixes "\<sigma>\<^sub>1_object2\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n" :: "ty\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n"
fixes "\<sigma>\<^sub>1_object2" :: "\<cdot>Person"
assumes \<sigma>\<^sub>1_object2_def: "\<sigma>\<^sub>1_object2 = (\<lambda>_. \<lfloor>\<lfloor>\<sigma>\<^sub>1_object2\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n\<rfloor>\<rfloor>)"
fixes "\<sigma>\<^sub>1_object4\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n" :: "ty\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n"
fixes "\<sigma>\<^sub>1_object4" :: "\<cdot>Person"
assumes \<sigma>\<^sub>1_object4_def: "\<sigma>\<^sub>1_object4 = (\<lambda>_. \<lfloor>\<lfloor>\<sigma>\<^sub>1_object4\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n\<rfloor>\<rfloor>)"
begin
definition "\<sigma>\<^sub>1 = (state.make ((Map.empty (oid4 \<mapsto> (in\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n (\<sigma>\<^sub>1_object0\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n))) (oid5 \<mapsto> (in\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n (\<sigma>\<^sub>1_object1\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n))) (oid6 \<mapsto> (in\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n (\<sigma>\<^sub>1_object2\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n))) (oid1 \<mapsto> (in\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n (X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n1\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n))) (oid7 \<mapsto> (in\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n (\<sigma>\<^sub>1_object4\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n))) (oid2 \<mapsto> (in\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n (X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n2\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n))))) ((map_of_list ([(oid\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n_0___boss , (List.map ((\<lambda>(x , y). [x , y]) o switch\<^sub>2_01) ([[[oid4] , [oid5]] , [[oid6] , [oid1]] , [[oid1] , [oid2]] , [[oid7] , [oid6]]])))]))))"

lemma perm_\<sigma>\<^sub>1 : "\<sigma>\<^sub>1 = (state.make ((Map.empty (oid2 \<mapsto> (in\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n (X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n2\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n))) (oid7 \<mapsto> (in\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n (\<sigma>\<^sub>1_object4\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n))) (oid1 \<mapsto> (in\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n (X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n1\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n))) (oid6 \<mapsto> (in\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n (\<sigma>\<^sub>1_object2\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n))) (oid5 \<mapsto> (in\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n (\<sigma>\<^sub>1_object1\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n))) (oid4 \<mapsto> (in\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n (\<sigma>\<^sub>1_object0\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n))))) ((assocs (\<sigma>\<^sub>1))))"
  apply(simp add: \<sigma>\<^sub>1_def)
  apply(subst (1) fun_upd_twist, metis distinct_oid distinct_length_2_or_more)
  apply(subst (2) fun_upd_twist, metis distinct_oid distinct_length_2_or_more)
  apply(subst (1) fun_upd_twist, metis distinct_oid distinct_length_2_or_more)
  apply(subst (3) fun_upd_twist, metis distinct_oid distinct_length_2_or_more)
  apply(subst (2) fun_upd_twist, metis distinct_oid distinct_length_2_or_more)
  apply(subst (1) fun_upd_twist, metis distinct_oid distinct_length_2_or_more)
  apply(subst (4) fun_upd_twist, metis distinct_oid distinct_length_2_or_more)
  apply(subst (3) fun_upd_twist, metis distinct_oid distinct_length_2_or_more)
  apply(subst (2) fun_upd_twist, metis distinct_oid distinct_length_2_or_more)
  apply(subst (1) fun_upd_twist, metis distinct_oid distinct_length_2_or_more)
  apply(subst (5) fun_upd_twist, metis distinct_oid distinct_length_2_or_more)
  apply(subst (4) fun_upd_twist, metis distinct_oid distinct_length_2_or_more)
  apply(subst (3) fun_upd_twist, metis distinct_oid distinct_length_2_or_more)
  apply(subst (2) fun_upd_twist, metis distinct_oid distinct_length_2_or_more)
  apply(subst (1) fun_upd_twist, metis distinct_oid distinct_length_2_or_more)
by(simp)
end

(* 24 ************************************ 43 + 1 *)
section \<open>Instance\<close>

(* 25 ************************************ 44 + 2 *)
definition "oid8 = 8"
definition "inst_assoc8 = (\<lambda>oid_class to_from oid. ((case (deref_assocs_list ((to_from::oid list list \<Rightarrow> oid list \<times> oid list)) ((oid::oid)) ((the ((((map_of_list ([]))) ((oid_class::oid))))))) of Nil \<Rightarrow> None
    | l \<Rightarrow> (Some (l)))::oid list option))"

(* 26 ************************************ 46 + 0 *)

(* 27 ************************************ 46 + 1 *)
section \<open>State (Floor 2)\<close>

(* 28 ************************************ 47 + 1 *)
locale state_\<sigma>\<^sub>1' =
fixes "oid1" :: "nat"
fixes "oid2" :: "nat"
fixes "oid3" :: "nat"
fixes "oid8" :: "nat"
assumes distinct_oid: "(distinct ([oid1 , oid2 , oid3 , oid8]))"
fixes "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n1\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n" :: "ty\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n"
fixes "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n1" :: "\<cdot>Person"
assumes X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n1_def: "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n1 = (\<lambda>_. \<lfloor>\<lfloor>X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n1\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n\<rfloor>\<rfloor>)"
fixes "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n2\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n" :: "ty\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n"
fixes "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n2" :: "\<cdot>Person"
assumes X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n2_def: "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n2 = (\<lambda>_. \<lfloor>\<lfloor>X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n2\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n\<rfloor>\<rfloor>)"
fixes "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n3\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n" :: "ty\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n"
fixes "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n3" :: "\<cdot>Person"
assumes X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n3_def: "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n3 = (\<lambda>_. \<lfloor>\<lfloor>X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n3\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n\<rfloor>\<rfloor>)"
fixes "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n4\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n" :: "ty\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n"
fixes "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n4" :: "\<cdot>Person"
assumes X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n4_def: "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n4 = (\<lambda>_. \<lfloor>\<lfloor>X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n4\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n\<rfloor>\<rfloor>)"
begin
definition "\<sigma>\<^sub>1' = (state.make ((Map.empty (oid1 \<mapsto> (in\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n (X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n1\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n))) (oid2 \<mapsto> (in\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n (X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n2\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n))) (oid3 \<mapsto> (in\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n (X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n3\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n))) (oid8 \<mapsto> (in\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n (X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n4\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n))))) ((map_of_list ([(oid\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n_0___boss , (List.map ((\<lambda>(x , y). [x , y]) o switch\<^sub>2_01) ([[[oid1] , [oid2]]])))]))))"

lemma perm_\<sigma>\<^sub>1' : "\<sigma>\<^sub>1' = (state.make ((Map.empty (oid8 \<mapsto> (in\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n (X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n4\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n))) (oid3 \<mapsto> (in\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n (X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n3\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n))) (oid2 \<mapsto> (in\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n (X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n2\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n))) (oid1 \<mapsto> (in\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n (X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n1\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n))))) ((assocs (\<sigma>\<^sub>1'))))"
  apply(simp add: \<sigma>\<^sub>1'_def)
  apply(subst (1) fun_upd_twist, metis distinct_oid distinct_length_2_or_more)
  apply(subst (2) fun_upd_twist, metis distinct_oid distinct_length_2_or_more)
  apply(subst (1) fun_upd_twist, metis distinct_oid distinct_length_2_or_more)
  apply(subst (3) fun_upd_twist, metis distinct_oid distinct_length_2_or_more)
  apply(subst (2) fun_upd_twist, metis distinct_oid distinct_length_2_or_more)
  apply(subst (1) fun_upd_twist, metis distinct_oid distinct_length_2_or_more)
by(simp)
end

(* 29 ************************************ 48 + 1 *)
section \<open>Transition (Floor 2)\<close>

(* 30 ************************************ 49 + 1 *)
locale transition_\<sigma>\<^sub>1_\<sigma>\<^sub>1' =
fixes "oid1" :: "nat"
fixes "oid2" :: "nat"
fixes "oid3" :: "nat"
fixes "oid4" :: "nat"
fixes "oid5" :: "nat"
fixes "oid6" :: "nat"
fixes "oid7" :: "nat"
fixes "oid8" :: "nat"
assumes distinct_oid: "(distinct ([oid1 , oid2 , oid3 , oid4 , oid5 , oid6 , oid7 , oid8]))"
fixes "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n1\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n" :: "ty\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n"
fixes "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n1" :: "\<cdot>Person"
assumes X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n1_def: "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n1 = (\<lambda>_. \<lfloor>\<lfloor>X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n1\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n\<rfloor>\<rfloor>)"
fixes "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n2\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n" :: "ty\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n"
fixes "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n2" :: "\<cdot>Person"
assumes X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n2_def: "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n2 = (\<lambda>_. \<lfloor>\<lfloor>X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n2\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n\<rfloor>\<rfloor>)"
fixes "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n3\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n" :: "ty\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n"
fixes "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n3" :: "\<cdot>Person"
assumes X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n3_def: "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n3 = (\<lambda>_. \<lfloor>\<lfloor>X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n3\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n\<rfloor>\<rfloor>)"
fixes "\<sigma>\<^sub>1_object0\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n" :: "ty\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n"
fixes "\<sigma>\<^sub>1_object0" :: "\<cdot>Person"
assumes \<sigma>\<^sub>1_object0_def: "\<sigma>\<^sub>1_object0 = (\<lambda>_. \<lfloor>\<lfloor>\<sigma>\<^sub>1_object0\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n\<rfloor>\<rfloor>)"
fixes "\<sigma>\<^sub>1_object1\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n" :: "ty\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n"
fixes "\<sigma>\<^sub>1_object1" :: "\<cdot>Person"
assumes \<sigma>\<^sub>1_object1_def: "\<sigma>\<^sub>1_object1 = (\<lambda>_. \<lfloor>\<lfloor>\<sigma>\<^sub>1_object1\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n\<rfloor>\<rfloor>)"
fixes "\<sigma>\<^sub>1_object2\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n" :: "ty\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n"
fixes "\<sigma>\<^sub>1_object2" :: "\<cdot>Person"
assumes \<sigma>\<^sub>1_object2_def: "\<sigma>\<^sub>1_object2 = (\<lambda>_. \<lfloor>\<lfloor>\<sigma>\<^sub>1_object2\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n\<rfloor>\<rfloor>)"
fixes "\<sigma>\<^sub>1_object4\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n" :: "ty\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n"
fixes "\<sigma>\<^sub>1_object4" :: "\<cdot>Person"
assumes \<sigma>\<^sub>1_object4_def: "\<sigma>\<^sub>1_object4 = (\<lambda>_. \<lfloor>\<lfloor>\<sigma>\<^sub>1_object4\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n\<rfloor>\<rfloor>)"
fixes "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n4\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n" :: "ty\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n"
fixes "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n4" :: "\<cdot>Person"
assumes X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n4_def: "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n4 = (\<lambda>_. \<lfloor>\<lfloor>X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n4\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n\<rfloor>\<rfloor>)"

assumes \<sigma>\<^sub>1: "(state_\<sigma>\<^sub>1 (oid1) (oid2) (oid4) (oid5) (oid6) (oid7) (X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n1\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n) (X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n1) (X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n2\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n) (X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n2) (\<sigma>\<^sub>1_object0\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n) (\<sigma>\<^sub>1_object0) (\<sigma>\<^sub>1_object1\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n) (\<sigma>\<^sub>1_object1) (\<sigma>\<^sub>1_object2\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n) (\<sigma>\<^sub>1_object2) (\<sigma>\<^sub>1_object4\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n) (\<sigma>\<^sub>1_object4))"

assumes \<sigma>\<^sub>1': "(state_\<sigma>\<^sub>1' (oid1) (oid2) (oid3) (oid8) (X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n1\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n) (X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n1) (X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n2\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n) (X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n2) (X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n3\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n) (X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n3) (X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n4\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n) (X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n4))"
begin
interpretation state_\<sigma>\<^sub>1: state_\<sigma>\<^sub>1 "oid1" "oid2" "oid4" "oid5" "oid6" "oid7" "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n1\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n" "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n1" "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n2\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n" "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n2" "\<sigma>\<^sub>1_object0\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n" "\<sigma>\<^sub>1_object0" "\<sigma>\<^sub>1_object1\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n" "\<sigma>\<^sub>1_object1" "\<sigma>\<^sub>1_object2\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n" "\<sigma>\<^sub>1_object2" "\<sigma>\<^sub>1_object4\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n" "\<sigma>\<^sub>1_object4"
by(rule \<sigma>\<^sub>1)

interpretation state_\<sigma>\<^sub>1': state_\<sigma>\<^sub>1' "oid1" "oid2" "oid3" "oid8" "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n1\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n" "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n1" "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n2\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n" "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n2" "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n3\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n" "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n3" "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n4\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n" "X\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n4"
by(rule \<sigma>\<^sub>1')
end

end


(*  Title:      HOL/HOLCF/IOA/NTP/Impl.thy
    Author:     Tobias Nipkow & Konrad Slind
*)

section \<open>The implementation\<close>

theory Impl
imports Sender Receiver Abschannel
begin

type_synonym 'm impl_state
  = "'m sender_state * 'm receiver_state * 'm packet multiset * bool multiset"
  (*  sender_state   *  receiver_state   *    srch_state      * rsch_state *)

definition
  impl_ioa :: "('m action, 'm impl_state)ioa" where
  impl_def: "impl_ioa == (sender_ioa \<parallel> receiver_ioa \<parallel> srch_ioa \<parallel> rsch_ioa)"

definition sen :: "'m impl_state => 'm sender_state" where "sen = fst"
definition rec :: "'m impl_state => 'm receiver_state" where "rec = fst \<circ> snd"
definition srch :: "'m impl_state => 'm packet multiset" where "srch = fst \<circ> snd \<circ> snd"
definition rsch :: "'m impl_state => bool multiset" where "rsch = snd \<circ> snd \<circ> snd"

definition
  hdr_sum :: "'m packet multiset => bool => nat" where
  "hdr_sum M b == countm M (%pkt. hdr(pkt) = b)"

(* Lemma 5.1 *)
definition
  "inv1(s) ==
     (!b. count (rsent(rec s)) b = count (srcvd(sen s)) b + count (rsch s) b)
   & (!b. count (ssent(sen s)) b
          = hdr_sum (rrcvd(rec s)) b + hdr_sum (srch s) b)"

(* Lemma 5.2 *)
definition
  "inv2(s) ==
  (rbit(rec(s)) = sbit(sen(s)) &
   ssending(sen(s)) &
   count (rsent(rec s)) (~sbit(sen s)) <= count (ssent(sen s)) (~sbit(sen s)) &
   count (ssent(sen s)) (~sbit(sen s)) <= count (rsent(rec s)) (sbit(sen s)))
   |
  (rbit(rec(s)) = (~sbit(sen(s))) &
   rsending(rec(s)) &
   count (ssent(sen s)) (~sbit(sen s)) <= count (rsent(rec s)) (sbit(sen s)) &
   count (rsent(rec s)) (sbit(sen s)) <= count (ssent(sen s)) (sbit(sen s)))"

(* Lemma 5.3 *)
definition
  "inv3(s) ==
   rbit(rec(s)) = sbit(sen(s))
   --> (!m. sq(sen(s))=[] | m ~= hd(sq(sen(s)))
        -->  count (rrcvd(rec s)) (sbit(sen(s)),m)
             + count (srch s) (sbit(sen(s)),m)
            <= count (rsent(rec s)) (~sbit(sen s)))"

(* Lemma 5.4 *)
definition "inv4(s) == rbit(rec(s)) = (~sbit(sen(s))) --> sq(sen(s)) ~= []"

subsection \<open>Invariants\<close>

declare le_SucI [simp]

lemmas impl_ioas =
  impl_def sender_ioa_def receiver_ioa_def srch_ioa_thm [THEN eq_reflection]
  rsch_ioa_thm [THEN eq_reflection]

lemmas "transitions" =
  sender_trans_def receiver_trans_def srch_trans_def rsch_trans_def

lemmas [simp] =
  ioa_triple_proj starts_of_par trans_of_par4 in_sender_asig
  in_receiver_asig in_srch_asig in_rsch_asig

declare let_weak_cong [cong]

lemma [simp]:
  "a:actions(sender_asig)
  | a:actions(receiver_asig)
  | a:actions(srch_asig)
  | a:actions(rsch_asig)"
  by (induct a) simp_all

declare split_paired_All [simp del]

(* Three Simp_sets in different sizes
----------------------------------------------

1) simpset() does not unfold the transition relations
2) ss unfolds transition relations
3) renname_ss unfolds transitions and the abstract channel *)

ML \<open>
val ss = simpset_of (@{context} addsimps @{thms "transitions"});
val rename_ss = simpset_of (put_simpset ss @{context} addsimps @{thms unfold_renaming});

fun tac ctxt =
  asm_simp_tac (put_simpset ss ctxt
    |> Simplifier.add_cong @{thm conj_cong} |> Splitter.add_split @{thm if_split})
fun tac_ren ctxt =
  asm_simp_tac (put_simpset rename_ss ctxt
    |> Simplifier.add_cong @{thm conj_cong} |> Splitter.add_split @{thm if_split})
\<close>

subsubsection \<open>Invariant 1\<close>

lemma raw_inv1: "invariant impl_ioa inv1"

apply (unfold impl_ioas)
apply (rule invariantI)
apply (simp add: inv1_def hdr_sum_def srcvd_def ssent_def rsent_def rrcvd_def)

apply (simp (no_asm) del: trans_of_par4 add: imp_conjR inv1_def)

txt \<open>Split proof in two\<close>
apply (rule conjI)

(* First half *)
apply (simp add: Impl.inv1_def split del: if_split)
apply (induct_tac a)

apply (tactic "EVERY1[tac @{context}, tac @{context}, tac @{context}, tac @{context}]")
apply (tactic "tac @{context} 1")
apply (tactic "tac_ren @{context} 1")

txt \<open>5 + 1\<close>

apply (tactic "tac @{context} 1")
apply (tactic "tac_ren @{context} 1")

txt \<open>4 + 1\<close>
apply (tactic \<open>EVERY1[tac @{context}, tac @{context}, tac @{context}, tac @{context}]\<close>)

txt \<open>Now the other half\<close>
apply (simp add: Impl.inv1_def split del: if_split)
apply (induct_tac a)
apply (tactic "EVERY1 [tac @{context}, tac @{context}]")

txt \<open>detour 1\<close>
apply (tactic "tac @{context} 1")
apply (tactic "tac_ren @{context} 1")
apply (rule impI)
apply (erule conjE)+
apply (simp (no_asm_simp) add: hdr_sum_def Multiset.count_def Multiset.countm_nonempty_def
  split: if_split)
txt \<open>detour 2\<close>
apply (tactic "tac @{context} 1")
apply (tactic "tac_ren @{context} 1")
apply (rule impI)
apply (erule conjE)+
apply (simp add: Impl.hdr_sum_def Multiset.count_def Multiset.countm_nonempty_def
  Multiset.delm_nonempty_def split: if_split)
apply (rule allI)
apply (rule conjI)
apply (rule impI)
apply hypsubst
apply (rule pred_suc [THEN iffD1])
apply (drule less_le_trans)
apply (cut_tac eq_packet_imp_eq_hdr [unfolded Packet.hdr_def, THEN countm_props])
apply assumption
apply assumption

apply (rule countm_done_delm [THEN mp, symmetric])
apply (rule refl)
apply (simp (no_asm_simp) add: Multiset.count_def)

apply (rule impI)
apply (simp add: neg_flip)
apply hypsubst
apply (rule countm_spurious_delm)
apply (simp (no_asm))

apply (tactic "EVERY1 [tac @{context}, tac @{context}, tac @{context},
  tac @{context}, tac @{context}, tac @{context}]")

done

subsubsection \<open>INVARIANT 2\<close>

lemma raw_inv2: "invariant impl_ioa inv2"

  apply (rule invariantI1)
  txt \<open>Base case\<close>
  apply (simp add: inv2_def receiver_projections sender_projections impl_ioas)

  apply (simp (no_asm_simp) add: impl_ioas split del: if_split)
  apply (induct_tac "a")

  txt \<open>10 cases. First 4 are simple, since state doesn't change\<close>

  ML_prf \<open>val tac2 = asm_full_simp_tac (put_simpset ss @{context} addsimps [@{thm inv2_def}])\<close>

  txt \<open>10 - 7\<close>
  apply (tactic "EVERY1 [tac2,tac2,tac2,tac2]")
  txt \<open>6\<close>
  apply (tactic \<open>forward_tac @{context} [rewrite_rule @{context} [@{thm Impl.inv1_def}]
                               (@{thm raw_inv1} RS @{thm invariantE}) RS conjunct1] 1\<close>)

  txt \<open>6 - 5\<close>
  apply (tactic "EVERY1 [tac2,tac2]")

  txt \<open>4\<close>
  apply (tactic \<open>forward_tac @{context} [rewrite_rule @{context} [@{thm Impl.inv1_def}]
                                (@{thm raw_inv1} RS @{thm invariantE}) RS conjunct1] 1\<close>)
  apply (tactic "tac2 1")

  txt \<open>3\<close>
  apply (tactic \<open>forward_tac @{context} [rewrite_rule @{context} [@{thm Impl.inv1_def}]
    (@{thm raw_inv1} RS @{thm invariantE})] 1\<close>)

  apply (tactic "tac2 1")
  apply (tactic \<open>fold_goals_tac @{context} [rewrite_rule @{context} [@{thm Packet.hdr_def}]
    (@{thm Impl.hdr_sum_def})]\<close>)
  apply arith

  txt \<open>2\<close>
  apply (tactic "tac2 1")
  apply (tactic \<open>forward_tac @{context} [rewrite_rule @{context} [@{thm Impl.inv1_def}]
                               (@{thm raw_inv1} RS @{thm invariantE}) RS conjunct1] 1\<close>)
  apply (intro strip)
  apply (erule conjE)+
  apply simp

  txt \<open>1\<close>
  apply (tactic "tac2 1")
  apply (tactic \<open>forward_tac @{context} [rewrite_rule @{context} [@{thm Impl.inv1_def}]
                               (@{thm raw_inv1} RS @{thm invariantE}) RS conjunct2] 1\<close>)
  apply (intro strip)
  apply (erule conjE)+
  apply (tactic \<open>fold_goals_tac @{context}
    [rewrite_rule @{context} [@{thm Packet.hdr_def}] (@{thm Impl.hdr_sum_def})]\<close>)
  apply simp

  done

subsubsection \<open>INVARIANT 3\<close>

lemma raw_inv3: "invariant impl_ioa inv3"

  apply (rule invariantI)
  txt \<open>Base case\<close>
  apply (simp add: Impl.inv3_def receiver_projections sender_projections impl_ioas)

  apply (simp (no_asm_simp) add: impl_ioas split del: if_split)
  apply (induct_tac "a")

  ML_prf \<open>val tac3 = asm_full_simp_tac (put_simpset ss @{context} addsimps [@{thm inv3_def}])\<close>

  txt \<open>10 - 8\<close>

  apply (tactic "EVERY1[tac3,tac3,tac3]")

  apply (tactic "tac_ren @{context} 1")
  apply (intro strip, (erule conjE)+)
  apply hypsubst
  apply (erule exE)
  apply simp

  txt \<open>7\<close>
  apply (tactic "tac3 1")
  apply (tactic "tac_ren @{context} 1")
  apply force

  txt \<open>6 - 3\<close>

  apply (tactic "EVERY1[tac3,tac3,tac3,tac3]")

  txt \<open>2\<close>
  apply (tactic "asm_full_simp_tac (put_simpset ss @{context}) 1")
  apply (simp (no_asm) add: inv3_def)
  apply (intro strip, (erule conjE)+)
  apply (rule imp_disjL [THEN iffD1])
  apply (rule impI)
  apply (tactic \<open>forward_tac @{context} [rewrite_rule @{context} [@{thm Impl.inv2_def}]
    (@{thm raw_inv2} RS @{thm invariantE})] 1\<close>)
  apply simp
  apply (erule conjE)+
  apply (rule_tac j = "count (ssent (sen s)) (~sbit (sen s))" and
    k = "count (rsent (rec s)) (sbit (sen s))" in le_trans)
  apply (tactic \<open>forward_tac @{context} [rewrite_rule @{context} [@{thm inv1_def}]
                                (@{thm raw_inv1} RS @{thm invariantE}) RS conjunct2] 1\<close>)
  apply (simp add: hdr_sum_def Multiset.count_def)
  apply (rule add_le_mono)
  apply (rule countm_props)
  apply (simp (no_asm))
  apply (rule countm_props)
  apply (simp (no_asm))
  apply assumption

  txt \<open>1\<close>
  apply (tactic "tac3 1")
  apply (intro strip, (erule conjE)+)
  apply (rule imp_disjL [THEN iffD1])
  apply (rule impI)
  apply (tactic \<open>forward_tac @{context} [rewrite_rule @{context} [@{thm Impl.inv2_def}]
    (@{thm raw_inv2} RS @{thm invariantE})] 1\<close>)
  apply simp
  done

subsubsection \<open>INVARIANT 4\<close>

lemma raw_inv4: "invariant impl_ioa inv4"

  apply (rule invariantI)
  txt \<open>Base case\<close>
  apply (simp add: Impl.inv4_def receiver_projections sender_projections impl_ioas)

  apply (simp (no_asm_simp) add: impl_ioas split del: if_split)
  apply (induct_tac "a")

  ML_prf \<open>val tac4 =  asm_full_simp_tac (put_simpset ss @{context} addsimps [@{thm inv4_def}])\<close>

  txt \<open>10 - 2\<close>

  apply (tactic "EVERY1[tac4,tac4,tac4,tac4,tac4,tac4,tac4,tac4,tac4]")

  txt \<open>2 b\<close>

  apply (intro strip, (erule conjE)+)
  apply (tactic \<open>forward_tac @{context} [rewrite_rule @{context} [@{thm Impl.inv2_def}]
                               (@{thm raw_inv2} RS @{thm invariantE})] 1\<close>)
  apply simp

  txt \<open>1\<close>
  apply (tactic "tac4 1")
  apply (intro strip, (erule conjE)+)
  apply (rule ccontr)
  apply (tactic \<open>forward_tac @{context} [rewrite_rule @{context} [@{thm Impl.inv2_def}]
                               (@{thm raw_inv2} RS @{thm invariantE})] 1\<close>)
  apply (tactic \<open>forward_tac @{context} [rewrite_rule @{context} [@{thm Impl.inv3_def}]
                               (@{thm raw_inv3} RS @{thm invariantE})] 1\<close>)
  apply simp
  apply (rename_tac m, erule_tac x = "m" in allE)
  apply simp
  done

text \<open>rebind them\<close>

lemmas inv1 = raw_inv1 [THEN invariantE, unfolded inv1_def]
  and inv2 = raw_inv2 [THEN invariantE, unfolded inv2_def]
  and inv3 = raw_inv3 [THEN invariantE, unfolded inv3_def]
  and inv4 = raw_inv4 [THEN invariantE, unfolded inv4_def]

end


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

theory While_SPMF imports
  MFMC_Countable.Rel_PMF_Characterisation
  "HOL-Types_To_Sets.Types_To_Sets"
  "HOL-Library.Complete_Partial_Order2"
begin

text \<open>
  This theory defines a probabilistic while combinator for discrete (sub-)probabilities and
  formalises rules for probabilistic termination similar to those by Hurd \cite{Hurd2002TPHOLs}
  and McIver and Morgan \cite{McIverMorgan2005}.
\<close>

section \<open>Miscellaneous library additions\<close>

fun map_option_set :: "('a \<Rightarrow> 'b option set) \<Rightarrow> 'a option \<Rightarrow> 'b option set"
where
  "map_option_set f None = {None}"
| "map_option_set f (Some x) = f x"

lemma None_in_map_option_set:
  "None \<in> map_option_set f x \<longleftrightarrow> None \<in> Set.bind (set_option x) f \<or> x = None"
by(cases x) simp_all

lemma None_in_map_option_set_None [intro!]: "None \<in> map_option_set f None"
by simp

lemma None_in_map_option_set_Some [intro!]: "None \<in> f x \<Longrightarrow> None \<in> map_option_set f (Some x)"
by simp

lemma Some_in_map_option_set [intro!]: "Some y \<in> f x \<Longrightarrow> Some y \<in> map_option_set f (Some x)"
by simp

lemma map_option_set_singleton [simp]: "map_option_set (\<lambda>x. {f x}) y = {Option.bind y f}"
by(cases y) simp_all

lemma Some_eq_bind_conv: "Some y = Option.bind x f \<longleftrightarrow> (\<exists>z. x = Some z \<and> f z = Some y)"
by(cases x) auto

lemma map_option_set_bind: "map_option_set f (Option.bind x g) = map_option_set (map_option_set f \<circ> g) x"
by(cases x) simp_all

lemma Some_in_map_option_set_conv: "Some y \<in> map_option_set f x \<longleftrightarrow> (\<exists>z. x = Some z \<and> Some y \<in> f z)"
by(cases x) auto

interpretation rel_spmf_characterisation by unfold_locales(rule rel_pmf_measureI)
hide_fact (open) rel_pmf_measureI

lemma Sup_conv_fun_lub: "Sup = fun_lub Sup"
  by(auto simp add: Sup_fun_def fun_eq_iff fun_lub_def intro: arg_cong[where f=Sup])

lemma le_conv_fun_ord: "(\<le>) = fun_ord (\<le>)"
  by(auto simp add: fun_eq_iff fun_ord_def le_fun_def)

lemmas parallel_fixp_induct_2_1 = parallel_fixp_induct_uc[
  of _ _ _ _ "case_prod" _ "curry" "\<lambda>x. x" _ "\<lambda>x. x",
  where P="\<lambda>f g. P (curry f) g",
  unfolded case_prod_curry curry_case_prod curry_K,
  OF _ _ _ _ _ _ refl refl]
  for P

lemma monotone_Pair:
  "\<lbrakk> monotone ord orda f; monotone ord ordb g \<rbrakk>
  \<Longrightarrow> monotone ord (rel_prod orda ordb) (\<lambda>x. (f x, g x))"
by(simp add: monotone_def)

lemma cont_Pair:
  "\<lbrakk> cont lub ord luba orda f; cont lub ord lubb ordb g \<rbrakk>
  \<Longrightarrow> cont lub ord (prod_lub luba lubb) (rel_prod orda ordb) (\<lambda>x. (f x, g x))"
by(rule contI)(auto simp add: prod_lub_def image_image dest!: contD)

lemma mcont_Pair:
  "\<lbrakk> mcont lub ord luba orda f; mcont lub ord lubb ordb g \<rbrakk>
  \<Longrightarrow> mcont lub ord (prod_lub luba lubb) (rel_prod orda ordb) (\<lambda>x. (f x, g x))"
by(rule mcontI)(simp_all add: monotone_Pair mcont_mono cont_Pair)

lemma mono2mono_emeasure_spmf [THEN lfp.mono2mono]:
  shows monotone_emeasure_spmf:
  "monotone (ord_spmf (=)) (\<le>) (\<lambda>p. emeasure (measure_spmf p))"
  by(rule monotoneI le_funI ord_spmf_eqD_emeasure)+

lemma cont_emeasure_spmf: "cont lub_spmf (ord_spmf (=)) Sup (\<le>) (\<lambda>p. emeasure (measure_spmf p))"
  by (rule contI) (simp add: emeasure_lub_spmf fun_eq_iff image_comp)

lemma mcont2mcont_emeasure_spmf [THEN lfp.mcont2mcont, cont_intro]:
  shows mcont_emeasure_spmf: "mcont lub_spmf (ord_spmf (=)) Sup (\<le>) (\<lambda>p. emeasure (measure_spmf p))"
  by(simp add: mcont_def monotone_emeasure_spmf cont_emeasure_spmf)

lemma mcont2mcont_emeasure_spmf' [THEN lfp.mcont2mcont, cont_intro]:
  shows mcont_emeasure_spmf': "mcont lub_spmf (ord_spmf (=)) Sup (\<le>) (\<lambda>p. emeasure (measure_spmf p) A)"
  using mcont_emeasure_spmf[unfolded Sup_conv_fun_lub le_conv_fun_ord]
  by(subst (asm) mcont_fun_lub_apply) blast

lemma mcont_bind_pmf [cont_intro]:
  assumes g: "\<And>y. mcont luba orda lub_spmf (ord_spmf (=)) (g y)"
  shows "mcont luba orda lub_spmf (ord_spmf (=)) (\<lambda>x. bind_pmf p (\<lambda>y. g y x))"
using mcont_bind_spmf[where f="\<lambda>_. spmf_of_pmf p" and g=g, OF _ assms] by(simp)

lemma ennreal_less_top_iff: "x < \<top> \<longleftrightarrow> x \<noteq> (\<top> :: ennreal)"
  by(cases x) simp_all

lemma type_definition_Domainp:
  fixes Rep Abs A T
  assumes type: "type_definition Rep Abs A"
  assumes T_def: "T \<equiv> (\<lambda>(x::'a) (y::'b). x = Rep y)"
  shows "Domainp T = (\<lambda>x. x \<in> A)"
proof -
  interpret type_definition Rep Abs A by(rule type)
  show ?thesis unfolding Domainp_iff[abs_def] T_def fun_eq_iff by(metis Abs_inverse Rep)
qed

context includes lifting_syntax begin

lemma weight_spmf_parametric [transfer_rule]:
  "(rel_spmf A ===> (=)) weight_spmf weight_spmf"
by(simp add: rel_fun_def rel_spmf_weightD)

lemma lossless_spmf_parametric [transfer_rule]:
  "(rel_spmf A ===> (=)) lossless_spmf lossless_spmf"
by(simp add: rel_fun_def lossless_spmf_def rel_spmf_weightD)

lemma UNIV_parametric_pred: "rel_pred R UNIV UNIV"
  by(auto intro!: rel_predI)
end

lemma bind_spmf_spmf_of_set:
  "\<And>A. \<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow> bind_spmf (spmf_of_set A) = bind_pmf (pmf_of_set A)"
by(simp add: spmf_of_set_def fun_eq_iff del: spmf_of_pmf_pmf_of_set)

lemma set_pmf_bind_spmf: "set_pmf (bind_spmf M f) = set_pmf M \<bind> map_option_set (set_pmf \<circ> f)"
by(auto 4 3 simp add: bind_spmf_def split: option.splits intro: rev_bexI)

lemma set_pmf_spmf_of_set:
  "set_pmf (spmf_of_set A) = (if finite A \<and> A \<noteq> {} then Some ` A else {None})"
by(simp add: spmf_of_set_def spmf_of_pmf_def del: spmf_of_pmf_pmf_of_set)

definition measure_measure_spmf :: "'a spmf \<Rightarrow> 'a set \<Rightarrow> real"
where [simp]: "measure_measure_spmf p = measure (measure_spmf p)"

lemma measure_measure_spmf_parametric [transfer_rule]:
  includes lifting_syntax shows
  "(rel_spmf A ===> rel_pred A ===> (=)) measure_measure_spmf measure_measure_spmf"
unfolding measure_measure_spmf_def[abs_def] by(rule measure_spmf_parametric)

lemma of_nat_le_one_cancel_iff [simp]:
  fixes n :: nat shows "real n \<le> 1 \<longleftrightarrow> n \<le> 1"
by linarith

lemma of_int_ceiling_less_add_one [simp]: "of_int \<lceil>r\<rceil> < r + 1"
  by linarith

lemma lessThan_subset_Collect: "{..<x} \<subseteq> Collect P \<longleftrightarrow> (\<forall>y<x. P y)"
  by(auto simp add: lessThan_def)

lemma spmf_ub_tight:
  assumes ub: "\<And>x. spmf p x \<le> f x"
  and sum: "(\<integral>\<^sup>+ x. f x \<partial>count_space UNIV) = weight_spmf p"
  shows "spmf p x = f x"
proof -
  have [rule_format]: "\<forall>x. f x \<le> spmf p x"
  proof(rule ccontr)
    assume "\<not> ?thesis"
    then obtain x where x: "spmf p x < f x" by(auto simp add: not_le)
    have *: "(\<integral>\<^sup>+ y. ennreal (f y) * indicator (- {x}) y \<partial>count_space UNIV) \<noteq> \<top>"
      by(rule neq_top_trans[where y="weight_spmf p"], simp)(auto simp add: sum[symmetric] intro!: nn_integral_mono split: split_indicator)

    have "weight_spmf p = \<integral>\<^sup>+ y. spmf p y \<partial>count_space UNIV"
      by(simp add: nn_integral_spmf space_measure_spmf measure_spmf.emeasure_eq_measure)
    also have "\<dots> = (\<integral>\<^sup>+ y. ennreal (spmf p y) * indicator (- {x}) y \<partial>count_space UNIV) +
      (\<integral>\<^sup>+ y. spmf p y * indicator {x} y \<partial>count_space UNIV)"
      by(subst nn_integral_add[symmetric])(auto intro!: nn_integral_cong split: split_indicator)
    also have "\<dots> \<le> (\<integral>\<^sup>+ y. ennreal (f y) * indicator (- {x}) y \<partial>count_space UNIV) + spmf p x"
      using ub by(intro add_mono nn_integral_mono)(auto split: split_indicator intro: ennreal_leI)
    also have "\<dots> < (\<integral>\<^sup>+ y. ennreal (f y) * indicator (- {x}) y \<partial>count_space UNIV) + (\<integral>\<^sup>+ y. f y * indicator {x} y \<partial>count_space UNIV)"
      using * x by(simp add: ennreal_less_iff)
    also have "\<dots> = (\<integral>\<^sup>+ y. ennreal (f y) \<partial>count_space UNIV)"
      by(subst nn_integral_add[symmetric])(auto intro: nn_integral_cong split: split_indicator)
    also have "\<dots> = weight_spmf p" using sum by simp
    finally show False by simp
  qed
  from this[of x] ub[of x] show ?thesis by simp
qed

section \<open>Probabilistic while loop\<close>

locale loop_spmf =
  fixes guard :: "'a \<Rightarrow> bool"
  and body :: "'a \<Rightarrow> 'a spmf"
begin

context notes [[function_internals]] begin

partial_function (spmf) while :: "'a \<Rightarrow> 'a spmf"
where "while s = (if guard s then bind_spmf (body s) while else return_spmf s)"

end

lemma while_fixp_induct [case_names adm bottom step]:
  assumes "spmf.admissible P"
  and "P (\<lambda>while. return_pmf None)"
  and "\<And>while'. P while' \<Longrightarrow> P (\<lambda>s. if guard s then body s \<bind> while' else return_spmf s)"
  shows "P while"
  using assms by(rule while.fixp_induct)

lemma while_simps:
  "guard s \<Longrightarrow> while s = bind_spmf (body s) while"
  "\<not> guard s \<Longrightarrow> while s = return_spmf s"
by(rewrite while.simps; simp; fail)+

end

lemma while_spmf_parametric [transfer_rule]:
  includes lifting_syntax shows
  "((S ===> (=)) ===> (S ===> rel_spmf S) ===> S ===> rel_spmf S) loop_spmf.while loop_spmf.while"
unfolding loop_spmf.while_def[abs_def]
apply(rule rel_funI)
apply(rule rel_funI)
apply(rule fixp_spmf_parametric[OF loop_spmf.while.mono loop_spmf.while.mono])
subgoal premises [transfer_rule] by transfer_prover
done

lemma loop_spmf_while_cong:
  "\<lbrakk> guard = guard'; \<And>s. guard' s \<Longrightarrow> body s = body' s \<rbrakk>
  \<Longrightarrow> loop_spmf.while guard body = loop_spmf.while guard' body'"
unfolding loop_spmf.while_def[abs_def] by(simp cong: if_cong)

section \<open>Rules for probabilistic termination\<close>

context loop_spmf begin

subsection \<open>0/1 termination laws\<close>

lemma termination_0_1_immediate:
  assumes p: "\<And>s. guard s \<Longrightarrow> spmf (map_spmf guard (body s)) False \<ge> p"
  and p_pos: "0 < p"
  and lossless: "\<And>s. guard s \<Longrightarrow> lossless_spmf (body s)"
  shows "lossless_spmf (while s)"
proof -
  have "\<forall>s. lossless_spmf (while s)"
  proof(rule ccontr)
    assume "\<not> ?thesis"
    then obtain s where s: "\<not> lossless_spmf (while s)" by blast
    hence True: "guard s" by(simp add: while.simps split: if_split_asm)

    from p[OF this] have p_le_1: "p \<le> 1" using pmf_le_1 by(rule order_trans)
    have new_bound: "p * (1 - k) + k \<le> weight_spmf (while s)"
      if k: "0 \<le> k" "k \<le> 1" and k_le: "\<And>s. k \<le> weight_spmf (while s)" for k s
    proof(cases "guard s")
      case False
      have "p * (1 - k) + k \<le> 1 * (1 - k) + k" using p_le_1 k by(intro mult_right_mono add_mono; simp)
      also have "\<dots> \<le> 1" by simp
      finally show ?thesis using False by(simp add: while.simps)
    next
      case True
      let ?M = "\<lambda>s. measure_spmf (body s)"
      have bounded: "\<bar>\<integral> s''. weight_spmf (while s'') \<partial>?M s'\<bar> \<le> 1" for s'
        using integral_nonneg_AE[of "\<lambda>s''. weight_spmf (while s'')" "?M s'"]
        by(auto simp add: weight_spmf_nonneg weight_spmf_le_1 intro!: measure_spmf.nn_integral_le_const integral_real_bounded)
      have "p \<le> measure (?M s) {s'. \<not> guard s'}" using p[OF True]
        by(simp add: spmf_conv_measure_spmf measure_map_spmf vimage_def)
      hence "p * (1 - k) + k \<le> measure (?M s) {s'. \<not> guard s'} * (1 - k) + k"
        using k by(intro add_mono mult_right_mono)(simp_all)
      also have "\<dots> = \<integral> s'. indicator {s'. \<not> guard s'} s' * (1 - k) +  k \<partial>?M s"
        using True by(simp add: ennreal_less_top_iff lossless lossless_weight_spmfD)
      also have "\<dots> = \<integral> s'. indicator {s'. \<not> guard s'} s' + indicator {s'. guard s'} s' * k \<partial>?M s"
        by(rule Bochner_Integration.integral_cong)(simp_all split: split_indicator)
      also have "\<dots> = \<integral> s'. indicator {s'. \<not> guard s'} s' + indicator {s'. guard s'} s' * \<integral> s''. k \<partial>?M s' \<partial>?M s"
        by(rule Bochner_Integration.integral_cong)(auto simp add: lossless lossless_weight_spmfD split: split_indicator)
      also have "\<dots> \<le> \<integral> s'. indicator {s'. \<not> guard s'} s' + indicator {s'. guard s'} s' * \<integral> s''. weight_spmf (while s'') \<partial>?M s' \<partial>?M s"
        using k bounded
        by(intro integral_mono integrable_add measure_spmf.integrable_const_bound[where B=1] add_mono mult_left_mono)
          (simp_all add: weight_spmf_nonneg weight_spmf_le_1 mult_le_one k_le split: split_indicator)
      also have "\<dots> = \<integral>s'. (if \<not> guard s' then 1 else \<integral> s''. weight_spmf (while s'') \<partial>?M s') \<partial>?M s"
        by(rule Bochner_Integration.integral_cong)(simp_all split: split_indicator)
      also have "\<dots> = \<integral> s'. weight_spmf (while s') \<partial>measure_spmf (body s)"
        by(rule Bochner_Integration.integral_cong; simp add: while.simps weight_bind_spmf o_def)
      also have "\<dots> = weight_spmf (while s)" using True
        by(simp add: while.simps weight_bind_spmf o_def)
      finally show ?thesis .
    qed

    define k where "k \<equiv> INF s. weight_spmf (while s)"
    define k' where "k' \<equiv> p * (1 - k) + k"
    from s have "weight_spmf (while s) < 1"
      using weight_spmf_le_1[of "while s"] by(simp add: lossless_spmf_def)
    then have "k < 1"
      unfolding k_def by(rewrite cINF_less_iff)(auto intro!: bdd_belowI2 weight_spmf_nonneg)

    have "0 \<le> k" unfolding k_def by(auto intro: cINF_greatest simp add: weight_spmf_nonneg)
    moreover from \<open>k < 1\<close> have "k \<le> 1" by simp
    moreover have "k \<le> weight_spmf (while s)" for s unfolding k_def
      by(rule cINF_lower)(auto intro!: bdd_belowI2 weight_spmf_nonneg)
    ultimately have "\<And>s. k' \<le> weight_spmf (while s)"
      unfolding k'_def by(rule new_bound)
    hence "k' \<le> k" unfolding k_def by(auto intro: cINF_greatest)
    also have "k < k'" using p_pos \<open>k < 1\<close> by(auto simp add: k'_def)
    finally show False by simp
  qed
  thus ?thesis by blast
qed

primrec iter :: "nat \<Rightarrow> 'a \<Rightarrow> 'a spmf"
where
  "iter 0 s = return_spmf s"
| "iter (Suc n) s = (if guard s then bind_spmf (body s) (iter n) else return_spmf s)"

lemma iter_unguarded [simp]: "\<not> guard s \<Longrightarrow> iter n s = return_spmf s"
  by(induction n) simp_all

lemma iter_bind_iter: "bind_spmf (iter m s) (iter n) = iter (m + n) s"
  by(induction m arbitrary: s) simp_all

lemma iter_Suc2: "iter (Suc n) s = bind_spmf (iter n s) (\<lambda>s. if guard s then body s else return_spmf s)"
  using iter_bind_iter[of n s 1, symmetric]
  by(simp del: iter.simps)(rule bind_spmf_cong; simp cong: bind_spmf_cong)

lemma lossless_iter: "(\<And>s. guard s \<Longrightarrow> lossless_spmf (body s)) \<Longrightarrow> lossless_spmf (iter n s)"
  by(induction n arbitrary: s) simp_all

lemma iter_mono_emeasure1:
  "emeasure (measure_spmf (iter n s)) {s. \<not> guard s} \<le> emeasure (measure_spmf (iter (Suc n) s)) {s. \<not> guard s}"
  (is "?lhs \<le> ?rhs")
proof(cases "guard s")
  case True
  have "?lhs = emeasure (measure_spmf (bind_spmf (iter n s) return_spmf)) {s. \<not> guard s}" by simp
  also have "\<dots> = \<integral>\<^sup>+ s'. emeasure (measure_spmf (return_spmf s')) {s. \<not> guard s} \<partial>measure_spmf (iter n s)"
    by(simp del: bind_return_spmf add: measure_spmf_bind o_def emeasure_bind[where N="measure_spmf _"] space_measure_spmf Pi_def space_subprob_algebra)
  also have "\<dots> \<le> \<integral>\<^sup>+ s'. emeasure (measure_spmf (if guard s' then body s' else return_spmf s')) {s. \<not> guard s} \<partial>measure_spmf (iter n s)"
    by(rule nn_integral_mono)(simp add: measure_spmf_return_spmf)
  also have "\<dots> = ?rhs"
    by(simp add: iter_Suc2 measure_spmf_bind o_def emeasure_bind[where N="measure_spmf _"] space_measure_spmf Pi_def space_subprob_algebra del: iter.simps)
  finally show ?thesis .
qed simp

lemma weight_while_conv_iter:
  "weight_spmf (while s) = (SUP n. measure (measure_spmf (iter n s)) {s. \<not> guard s})"
  (is "?lhs = ?rhs")
proof(rule antisym)
  have "emeasure (measure_spmf (while s)) UNIV \<le> (SUP n. emeasure (measure_spmf (iter n s)) {s. \<not> guard s})"
    (is "_ \<le> (SUP n. ?f n s)")
  proof(induction arbitrary: s rule: while_fixp_induct)
    case adm show ?case by simp
    case bottom show ?case by simp
    case (step while')
    show ?case (is "?lhs' \<le> ?rhs'")
    proof(cases "guard s")
      case True
      have inc: "incseq ?f" by(rule incseq_SucI le_funI iter_mono_emeasure1)+

      from True have "?lhs' = \<integral>\<^sup>+ s'. emeasure (measure_spmf (while' s')) UNIV \<partial>measure_spmf (body s)"
        by(simp add: measure_spmf_bind o_def emeasure_bind[where N="measure_spmf _"] space_measure_spmf Pi_def space_subprob_algebra)
      also have "\<dots> \<le> \<integral>\<^sup>+ s'. (SUP n. ?f n s') \<partial>measure_spmf (body s)"
        by(rule nn_integral_mono)(rule step.IH)
      also have "\<dots> = (SUP n. \<integral>\<^sup>+ s'. ?f n s' \<partial>measure_spmf (body s))" using inc
        by(subst nn_integral_monotone_convergence_SUP) simp_all
      also have "\<dots> = (SUP n. ?f (Suc n) s)" using True
        by(simp add: measure_spmf_bind o_def emeasure_bind[where N="measure_spmf _"] space_measure_spmf Pi_def space_subprob_algebra)
      also have "\<dots> \<le> (SUP n. ?f n s)"
        by(rule SUP_mono)(auto intro: exI[where x="Suc _"])
      finally show ?thesis .
    next
      case False
      then have "?lhs' = emeasure (measure_spmf (iter 0 s)) {s. \<not> guard s}"
        by(simp add: measure_spmf_return_spmf)
      also have \<open>\<dots> \<le> ?rhs'\<close> by(rule SUP_upper) simp
      finally show ?thesis .
    qed
  qed
  also have "\<dots> = ennreal (SUP n. measure (measure_spmf (iter n s)) {s. \<not> guard s})"
    by(subst ennreal_SUP)(fold measure_spmf.emeasure_eq_measure, auto simp add: not_less measure_spmf.subprob_emeasure_le_1 intro!: exI[where x="1"])
  also have "0 \<le> (SUP n. measure (measure_spmf (iter n s)) {s. \<not> guard s})"
    by(rule cSUP_upper2)(auto intro!: bdd_aboveI[where M=1] simp add: measure_spmf.subprob_measure_le_1)
  ultimately show "?lhs \<le> ?rhs" by(simp add: measure_spmf.emeasure_eq_measure space_measure_spmf)

  show "?rhs \<le> ?lhs"
  proof(rule cSUP_least)
    show "measure (measure_spmf (iter n s)) {s. \<not> guard s} \<le> weight_spmf (while s)" (is "?f n s \<le> _") for n
    proof(induction n arbitrary: s)
      case 0 show ?case
        by(simp add: measure_spmf_return_spmf measure_return while_simps split: split_indicator)
    next
      case (Suc n)
      show ?case
      proof(cases "guard s")
        case True
        have "?f (Suc n) s = \<integral>\<^sup>+ s'. ?f n s' \<partial>measure_spmf (body s)"
          using True unfolding measure_spmf.emeasure_eq_measure[symmetric]
          by(simp add: measure_spmf_bind o_def emeasure_bind[where N="measure_spmf _"] space_measure_spmf Pi_def space_subprob_algebra)
        also have "\<dots> \<le> \<integral>\<^sup>+ s'. weight_spmf (while s') \<partial>measure_spmf (body s)"
          by(rule nn_integral_mono ennreal_leI Suc.IH)+
        also have "\<dots> = weight_spmf (while s)"
          using True unfolding measure_spmf.emeasure_eq_measure[symmetric] space_measure_spmf
          by(simp add: while_simps measure_spmf_bind o_def emeasure_bind[where N="measure_spmf _"] space_measure_spmf Pi_def space_subprob_algebra)
        finally show ?thesis by(simp)
      next
        case False then show ?thesis
          by(simp add: measure_spmf_return_spmf measure_return while_simps split: split_indicator)
      qed
    qed
  qed simp
qed

lemma termination_0_1:
  assumes p: "\<And>s. guard s \<Longrightarrow> p \<le> weight_spmf (while s)"
    and p_pos: "0 < p"
    and lossless: "\<And>s. guard s \<Longrightarrow> lossless_spmf (body s)"
  shows "lossless_spmf (while s)"
  unfolding lossless_spmf_def
proof(rule antisym)
  let ?X = "{s. \<not> guard s}"
  show "weight_spmf (while s) \<le> 1" by(rule weight_spmf_le_1)

  define p' where "p' \<equiv> p / 2"
  have p'_pos: "p' > 0" and "p' < p" using p_pos by(simp_all add: p'_def)

  have "\<exists>n. p' < measure (measure_spmf (iter n s)) ?X" if "guard s" for s using p[OF that] \<open>p' < p\<close>
    unfolding weight_while_conv_iter
    by(subst (asm) le_cSUP_iff)(auto intro!: measure_spmf.subprob_measure_le_1)
  then obtain N where p': "p' \<le> measure (measure_spmf (iter (N s) s)) ?X" if "guard s" for s
    using p by atomize_elim(rule choice, force dest: order.strict_implies_order)

  interpret fuse: loop_spmf guard "\<lambda>s. iter (N s) s" .

  have "1 = weight_spmf (fuse.while s)"
    by(rule lossless_weight_spmfD[symmetric])
      (rule fuse.termination_0_1_immediate; auto simp add: spmf_map vimage_def intro: p' p'_pos lossless_iter lossless)
  also have "\<dots> \<le> (\<Squnion>n. measure (measure_spmf (iter n s)) ?X)"
    unfolding fuse.weight_while_conv_iter
  proof(rule cSUP_least)
    fix n
    have "emeasure (measure_spmf (fuse.iter n s)) ?X \<le> (SUP n. emeasure (measure_spmf (iter n s)) ?X)"
    proof(induction n arbitrary: s)
      case 0 show ?case by(auto intro!: SUP_upper2[where i=0])
    next
      case (Suc n)
      have inc: "incseq (\<lambda>n s'. emeasure (measure_spmf (iter n s')) ?X)"
        by(rule incseq_SucI le_funI iter_mono_emeasure1)+

      have "emeasure (measure_spmf (fuse.iter (Suc n) s)) ?X = emeasure (measure_spmf (iter (N s) s \<bind> fuse.iter n)) ?X"
        by simp
      also have "\<dots> = \<integral>\<^sup>+ s'. emeasure (measure_spmf (fuse.iter n s')) ?X \<partial>measure_spmf (iter (N s) s)"
        by(simp add: measure_spmf_bind o_def emeasure_bind[where N="measure_spmf _"] space_measure_spmf Pi_def space_subprob_algebra)
      also have "\<dots> \<le> \<integral>\<^sup>+ s'. (SUP n. emeasure (measure_spmf (iter n s')) ?X) \<partial>measure_spmf (iter (N s) s)"
        by(rule nn_integral_mono Suc.IH)+
      also have "\<dots> = (SUP n. \<integral>\<^sup>+ s'. emeasure (measure_spmf (iter n s')) ?X \<partial>measure_spmf (iter (N s) s))"
        by(rule nn_integral_monotone_convergence_SUP[OF inc]) simp
      also have "\<dots> = (SUP n. emeasure (measure_spmf (bind_spmf (iter (N s) s) (iter n))) ?X)"
        by(simp add: measure_spmf_bind o_def emeasure_bind[where N="measure_spmf _"] space_measure_spmf Pi_def space_subprob_algebra)
      also have "\<dots> = (SUP n. emeasure (measure_spmf (iter (N s + n) s)) ?X)" by(simp add: iter_bind_iter)
      also have "\<dots> \<le> (SUP n. emeasure (measure_spmf (iter n s)) ?X)" by(rule SUP_mono) auto
      finally show ?case .
    qed
    also have "\<dots> = ennreal (SUP n. measure (measure_spmf (iter n s)) ?X)"
      by(subst ennreal_SUP)(fold measure_spmf.emeasure_eq_measure, auto simp add: not_less measure_spmf.subprob_emeasure_le_1 intro!: exI[where x="1"])
    also have "0 \<le> (SUP n. measure (measure_spmf (iter n s)) ?X)"
      by(rule cSUP_upper2)(auto intro!: bdd_aboveI[where M=1] simp add: measure_spmf.subprob_measure_le_1)
    ultimately show "measure (measure_spmf (fuse.iter n s)) ?X \<le> \<dots>"
      by(simp add: measure_spmf.emeasure_eq_measure)
  qed simp
  finally show  "1 \<le> weight_spmf (while s)" unfolding weight_while_conv_iter .
qed

end

lemma termination_0_1_immediate_invar:
  fixes I :: "'s \<Rightarrow> bool"
  assumes p: "\<And>s. \<lbrakk> guard s; I s \<rbrakk> \<Longrightarrow> spmf (map_spmf guard (body s)) False \<ge> p"
  and p_pos: "0 < p"
  and lossless: "\<And>s. \<lbrakk> guard s; I s \<rbrakk> \<Longrightarrow> lossless_spmf (body s)"
  and invar: "\<And>s s'. \<lbrakk> s' \<in> set_spmf (body s); I s; guard s \<rbrakk> \<Longrightarrow> I s'"
  and I: "I s"
  shows "lossless_spmf (loop_spmf.while guard body s)"
  including lifting_syntax
proof -
  { assume "\<exists>(Rep :: 's' \<Rightarrow> 's) Abs. type_definition Rep Abs {s. I s}"
    then obtain Rep :: "'s' \<Rightarrow> 's" and Abs where td: "type_definition Rep Abs {s. I s}" by blast
    then interpret td: type_definition Rep Abs "{s. I s}" .
    define cr where "cr \<equiv> \<lambda>x y. x = Rep y"
    have [transfer_rule]: "bi_unique cr" "right_total cr" using td cr_def by(rule typedef_bi_unique typedef_right_total)+
    have [transfer_domain_rule]: "Domainp cr = I" using type_definition_Domainp[OF td cr_def] by simp

    define guard' where "guard' \<equiv> (Rep ---> id) guard"
    have [transfer_rule]: "(cr ===> (=)) guard guard'" by(simp add: rel_fun_def cr_def guard'_def)
    define body1 where "body1 \<equiv> \<lambda>s. if guard s then body s else return_pmf None"
    define body1' where "body1' \<equiv> (Rep ---> map_spmf Abs) body1"
    have [transfer_rule]: "(cr ===> rel_spmf cr) body1 body1'"
      by(auto simp add: rel_fun_def body1'_def body1_def cr_def spmf_rel_map td.Rep[simplified] invar td.Abs_inverse intro!: rel_spmf_reflI)
    define s' where "s' \<equiv> Abs s"
    have [transfer_rule]: "cr s s'" by(simp add: s'_def cr_def I td.Abs_inverse)

    have "\<And>s. guard' s \<Longrightarrow> p \<le> spmf (map_spmf guard' (body1' s)) False"
      by(transfer fixing: p)(simp add: body1_def p)
    moreover note p_pos
    moreover have "\<And>s. guard' s \<Longrightarrow> lossless_spmf (body1' s)" by transfer(simp add: lossless body1_def)
    ultimately have "lossless_spmf (loop_spmf.while guard' body1' s')" by(rule loop_spmf.termination_0_1_immediate)
    hence "lossless_spmf (loop_spmf.while guard body1 s)" by transfer }
  from this[cancel_type_definition] I show ?thesis by(auto cong: loop_spmf_while_cong)
qed

lemma termination_0_1_invar:
  fixes I :: "'s \<Rightarrow> bool"
  assumes p: "\<And>s. \<lbrakk> guard s; I s \<rbrakk> \<Longrightarrow> p \<le> weight_spmf (loop_spmf.while guard body s)"
    and p_pos: "0 < p"
    and lossless: "\<And>s. \<lbrakk> guard s; I s \<rbrakk> \<Longrightarrow> lossless_spmf (body s)"
    and invar: "\<And>s s'. \<lbrakk> s' \<in> set_spmf (body s); I s; guard s \<rbrakk> \<Longrightarrow> I s'"
    and I: "I s"
  shows "lossless_spmf (loop_spmf.while guard body s)"
  including lifting_syntax
proof-
  { assume "\<exists>(Rep :: 's' \<Rightarrow> 's) Abs. type_definition Rep Abs {s. I s}"
    then obtain Rep :: "'s' \<Rightarrow> 's" and Abs where td: "type_definition Rep Abs {s. I s}" by blast
    then interpret td: type_definition Rep Abs "{s. I s}" .
    define cr where "cr \<equiv> \<lambda>x y. x = Rep y"
    have [transfer_rule]: "bi_unique cr" "right_total cr" using td cr_def by(rule typedef_bi_unique typedef_right_total)+
    have [transfer_domain_rule]: "Domainp cr = I" using type_definition_Domainp[OF td cr_def] by simp

    define guard' where "guard' \<equiv> (Rep ---> id) guard"
    have [transfer_rule]: "(cr ===> (=)) guard guard'" by(simp add: rel_fun_def cr_def guard'_def)
    define body1 where "body1 \<equiv> \<lambda>s. if guard s then body s else return_pmf None"
    define body1' where "body1' \<equiv> (Rep ---> map_spmf Abs) body1"
    have [transfer_rule]: "(cr ===> rel_spmf cr) body1 body1'"
      by(auto simp add: rel_fun_def body1'_def body1_def cr_def spmf_rel_map td.Rep[simplified] invar td.Abs_inverse intro!: rel_spmf_reflI)
    define s' where "s' \<equiv> Abs s"
    have [transfer_rule]: "cr s s'" by(simp add: s'_def cr_def I td.Abs_inverse)

    interpret loop_spmf guard' body1' .

    note UNIV_parametric_pred[transfer_rule]
    have "\<And>s. guard' s \<Longrightarrow> p \<le> weight_spmf (while s)"
      unfolding measure_measure_spmf_def[symmetric] space_measure_spmf
      by(transfer fixing: p)(simp add: body1_def p[simplified space_measure_spmf] cong: loop_spmf_while_cong)
    moreover note p_pos
    moreover have "\<And>s. guard' s \<Longrightarrow> lossless_spmf (body1' s)" by transfer(simp add: lossless body1_def)
    ultimately have "lossless_spmf (while s')" by(rule termination_0_1)
    hence "lossless_spmf (loop_spmf.while guard body1 s)" by transfer }
  from this[cancel_type_definition] I show ?thesis by(auto cong: loop_spmf_while_cong)
qed

subsection \<open>Variant rule\<close>

context loop_spmf begin

lemma termination_variant:
  fixes bound :: nat
  assumes bound: "\<And>s. guard s \<Longrightarrow> f s \<le> bound"
  and step: "\<And>s. guard s \<Longrightarrow> p \<le> spmf (map_spmf (\<lambda>s'. f s' < f s) (body s)) True"
  and p_pos: "0 < p"
  and lossless: "\<And>s. guard s \<Longrightarrow> lossless_spmf (body s)"
  shows "lossless_spmf (while s)"
proof -
  define p' and n where "p' \<equiv> min p 1" and "n \<equiv> bound + 1"
  have p'_pos: "0 < p'" and p'_le_1: "p' \<le> 1"
    and step': "guard s \<Longrightarrow> p' \<le> measure (measure_spmf (body s)) {s'. f s' < f s}" for s
    using p_pos step[of s] by(simp_all add: p'_def spmf_map vimage_def)
  have "p' ^ n \<le> weight_spmf (while s)" if "f s < n" for s using that
  proof(induction n arbitrary: s)
    case 0 thus ?case by simp
  next
    case (Suc n)
    show ?case
    proof(cases "guard s")
      case False
      hence "weight_spmf (while s) = 1" by(simp add: while.simps)
      thus ?thesis using p'_le_1 p_pos
        by simp(meson less_eq_real_def mult_le_one p'_pos power_le_one zero_le_power)
    next
      case True
      let ?M = "measure_spmf (body s)"
      have "p' ^ Suc n \<le> (\<integral> s'. indicator {s'. f s' < f s} s' \<partial>?M) * p' ^ n"
        using step'[OF True] p'_pos by(simp add: mult_right_mono)
      also have "\<dots> = (\<integral> s'. indicator {s'. f s' < f s} s' * p' ^ n \<partial>?M)" by simp
      also have "\<dots> \<le> (\<integral> s'. indicator {s'. f s' < f s} s' * weight_spmf (while s') \<partial>?M)"
        using Suc.prems p'_le_1 p'_pos
        by(intro integral_mono)(auto simp add: Suc.IH power_le_one weight_spmf_le_1 split: split_indicator intro!: measure_spmf.integrable_const_bound[where B=1])
      also have "\<dots> \<le> \<dots> + (\<integral> s'. indicator {s'. f s' \<ge> f s} s' * weight_spmf (while s') \<partial>?M)"
        by(simp add: integral_nonneg_AE weight_spmf_nonneg)
      also have "\<dots> = \<integral> s'. weight_spmf (while s') \<partial>?M"
        by(subst Bochner_Integration.integral_add[symmetric])
          (auto intro!: Bochner_Integration.integral_cong measure_spmf.integrable_const_bound[where B=1] weight_spmf_le_1 split: split_indicator)
      also have "\<dots> = weight_spmf (while s)"
        using True by(subst (1 2) while.simps)(simp add: weight_bind_spmf o_def)
      finally show ?thesis .
    qed
  qed
  moreover have "0 < p' ^ n" using p'_pos by simp
  ultimately show ?thesis using lossless
  proof(rule termination_0_1_invar)
    show "f s < n" if "guard s" "guard s \<longrightarrow> f s < n" for s using that by simp
    show "guard s \<longrightarrow> f s < n" using bound[of s] by(auto simp add: n_def)
    show "guard s' \<longrightarrow> f s' < n" for s' using bound[of s'] by(clarsimp simp add: n_def)
  qed
qed

end

lemma termination_variant_invar:
  fixes bound :: nat and I :: "'s \<Rightarrow> bool"
  assumes bound: "\<And>s. \<lbrakk> guard s; I s \<rbrakk> \<Longrightarrow> f s \<le> bound"
  and step: "\<And>s. \<lbrakk> guard s; I s \<rbrakk> \<Longrightarrow> p \<le> spmf (map_spmf (\<lambda>s'. f s' < f s) (body s)) True"
  and p_pos: "0 < p"
  and lossless: "\<And>s. \<lbrakk> guard s; I s \<rbrakk> \<Longrightarrow> lossless_spmf (body s)"
  and invar: "\<And>s s'. \<lbrakk> s' \<in> set_spmf (body s); I s; guard s \<rbrakk> \<Longrightarrow> I s'"
  and I: "I s"
  shows "lossless_spmf (loop_spmf.while guard body s)"
  including lifting_syntax
proof -
  { assume "\<exists>(Rep :: 's' \<Rightarrow> 's) Abs. type_definition Rep Abs {s. I s}"
    then obtain Rep :: "'s' \<Rightarrow> 's" and Abs where td: "type_definition Rep Abs {s. I s}" by blast
    then interpret td: type_definition Rep Abs "{s. I s}" .
    define cr where "cr \<equiv> \<lambda>x y. x = Rep y"
    have [transfer_rule]: "bi_unique cr" "right_total cr" using td cr_def by(rule typedef_bi_unique typedef_right_total)+
    have [transfer_domain_rule]: "Domainp cr = I" using type_definition_Domainp[OF td cr_def] by simp

    define guard' where "guard' \<equiv> (Rep ---> id) guard"
    have [transfer_rule]: "(cr ===> (=)) guard guard'" by(simp add: rel_fun_def cr_def guard'_def)
    define body1 where "body1 \<equiv> \<lambda>s. if guard s then body s else return_pmf None"
    define body1' where "body1' \<equiv> (Rep ---> map_spmf Abs) body1"
    have [transfer_rule]: "(cr ===> rel_spmf cr) body1 body1'"
      by(auto simp add: rel_fun_def body1'_def body1_def cr_def spmf_rel_map td.Rep[simplified] invar td.Abs_inverse intro!: rel_spmf_reflI)
    define s' where "s' \<equiv> Abs s"
    have [transfer_rule]: "cr s s'" by(simp add: s'_def cr_def I td.Abs_inverse)
    define f' where "f' \<equiv> (Rep ---> id) f"
    have [transfer_rule]: "(cr ===> (=)) f f'" by(simp add: rel_fun_def cr_def f'_def)

    have "\<And>s. guard' s \<Longrightarrow> f' s \<le> bound" by(transfer fixing: bound)(rule bound)
    moreover have "\<And>s. guard' s \<Longrightarrow> p \<le> spmf (map_spmf (\<lambda>s'. f' s' < f' s) (body1' s)) True"
      by(transfer fixing: p)(simp add: step body1_def)
    note this p_pos
    moreover have "\<And>s. guard' s \<Longrightarrow> lossless_spmf (body1' s)"
      by transfer(simp add: body1_def lossless)
    ultimately have "lossless_spmf (loop_spmf.while guard' body1' s')" by(rule loop_spmf.termination_variant)
    hence "lossless_spmf (loop_spmf.while guard body1 s)" by transfer }
  from this[cancel_type_definition] I show ?thesis by(auto cong: loop_spmf_while_cong)
qed

end


(*
(C) Copyright Andreas Viktor Hess, DTU, 2020
(C) Copyright Sebastian A. Mödersheim, DTU, 2020
(C) Copyright Achim D. Brucker, University of Exeter, 2020
(C) Copyright Anders Schlichtkrull, DTU, 2020

All Rights Reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

- Redistributions of source code must retain the above copyright
  notice, this list of conditions and the following disclaimer.

- Redistributions in binary form must reproduce the above copyright
  notice, this list of conditions and the following disclaimer in the
  documentation and/or other materials provided with the distribution.

- Neither the name of the copyright holder nor the names of its
  contributors may be used to endorse or promote products
  derived from this software without specific prior written
  permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)

(*  Title:      Term_Variants.thy
    Author:     Andreas Viktor Hess, DTU
    Author:     Sebastian A. Mödersheim, DTU
    Author:     Achim D. Brucker, University of Exeter
    Author:     Anders Schlichtkrull, DTU
*)

section\<open>Term Variants\<close>
theory Term_Variants
  imports Stateful_Protocol_Composition_and_Typing.Intruder_Deduction
begin

fun term_variants where
  "term_variants P (Var x) = [Var x]"
| "term_variants P (Fun f T) = (
  let S = product_lists (map (term_variants P) T)
  in map (Fun f) S@concat (map (\<lambda>g. map (Fun g) S) (P f)))"

inductive term_variants_pred where
  term_variants_Var:
  "term_variants_pred P (Var x) (Var x)"
| term_variants_P:
  "\<lbrakk>length T = length S; \<And>i. i < length T \<Longrightarrow> term_variants_pred P (T ! i) (S ! i); g \<in> set (P f)\<rbrakk>
   \<Longrightarrow> term_variants_pred P (Fun f T) (Fun g S)"
| term_variants_Fun:
  "\<lbrakk>length T = length S; \<And>i. i < length T \<Longrightarrow> term_variants_pred P (T ! i) (S ! i)\<rbrakk>
   \<Longrightarrow> term_variants_pred P (Fun f T) (Fun f S)"

lemma term_variants_pred_inv:
  assumes "term_variants_pred P (Fun f T) (Fun h S)"
  shows "length T = length S"
    and "\<And>i. i < length T \<Longrightarrow> term_variants_pred P (T ! i) (S ! i)"
    and "f \<noteq> h \<Longrightarrow> h \<in> set (P f)"
using assms by (auto elim: term_variants_pred.cases)

lemma term_variants_pred_inv':
  assumes "term_variants_pred P (Fun f T) t"
  shows "is_Fun t"
    and "length T = length (args t)"
    and "\<And>i. i < length T \<Longrightarrow> term_variants_pred P (T ! i) (args t ! i)"
    and "f \<noteq> the_Fun t \<Longrightarrow> the_Fun t \<in> set (P f)"
    and "P \<equiv> (\<lambda>_. [])(g := [h]) \<Longrightarrow> f \<noteq> the_Fun t \<Longrightarrow> f = g \<and> the_Fun t = h"
using assms by (auto elim: term_variants_pred.cases)

lemma term_variants_pred_inv'':
  assumes "term_variants_pred P t (Fun f T)"
  shows "is_Fun t"
    and "length T = length (args t)"
    and "\<And>i. i < length T \<Longrightarrow> term_variants_pred P (args t ! i) (T ! i)"
    and "f \<noteq> the_Fun t \<Longrightarrow> f \<in> set (P (the_Fun t))"
    and "P \<equiv> (\<lambda>_. [])(g := [h]) \<Longrightarrow> f \<noteq> the_Fun t \<Longrightarrow> f = h \<and> the_Fun t = g"
using assms by (auto elim: term_variants_pred.cases)

lemma term_variants_pred_inv_Var:
  "term_variants_pred P (Var x) t \<longleftrightarrow> t = Var x"
  "term_variants_pred P t (Var x) \<longleftrightarrow> t = Var x"
by (auto intro: term_variants_Var elim: term_variants_pred.cases)

lemma term_variants_pred_inv_const:
  "term_variants_pred P (Fun c []) t \<longleftrightarrow> ((\<exists>g \<in> set (P c). t = Fun g []) \<or> (t = Fun c []))"
by (auto intro: term_variants_P term_variants_Fun elim: term_variants_pred.cases)

lemma term_variants_pred_refl: "term_variants_pred P t t"
by (induct t) (auto intro: term_variants_pred.intros)

lemma term_variants_pred_refl_inv:
  assumes st: "term_variants_pred P s t"
    and P: "\<forall>f. \<forall>g \<in> set (P f). f = g"
  shows "s = t"
  using st P
proof (induction s t rule: term_variants_pred.induct)
case (term_variants_Var P x) thus ?case by blast
next
  case (term_variants_P T S P g f)
  hence "T ! i = S ! i" when i: "i < length T" for i using i by blast
  hence "T = S" using term_variants_P.hyps(1) by (simp add: nth_equalityI)
  thus ?case using term_variants_P.prems term_variants_P.hyps(3) by fast
next
  case (term_variants_Fun T S P f)
  hence "T ! i = S ! i" when i: "i < length T" for i using i by blast
  hence "T = S" using term_variants_Fun.hyps(1) by (simp add: nth_equalityI)
  thus ?case by fast
qed

lemma term_variants_pred_const:
  assumes "b \<in> set (P a)"
  shows "term_variants_pred P (Fun a []) (Fun b [])"
using term_variants_P[of "[]" "[]"] assms by simp

lemma term_variants_pred_const_cases:
  "P a \<noteq> [] \<Longrightarrow> term_variants_pred P (Fun a []) t \<longleftrightarrow>
                 (t = Fun a [] \<or> (\<exists>b \<in> set (P a). t = Fun b []))"
  "P a = [] \<Longrightarrow> term_variants_pred P (Fun a []) t \<longleftrightarrow> t = Fun a []"
using term_variants_pred_inv_const[of P] by auto

lemma term_variants_pred_param:
  assumes "term_variants_pred P t s"
    and fg: "f = g \<or> g \<in> set (P f)"
  shows "term_variants_pred P (Fun f (S@t#T)) (Fun g (S@s#T))"
proof -
  have 1: "length (S@t#T) = length (S@s#T)" by simp

  have "term_variants_pred P (T ! i) (T ! i)" "term_variants_pred P (S ! i) (S ! i)" for i
    by (metis term_variants_pred_refl)+
  hence 2: "term_variants_pred P ((S@t#T) ! i) ((S@s#T) ! i)" for i
    by (simp add: assms nth_Cons' nth_append)

  show ?thesis by (metis term_variants_Fun[OF 1 2] term_variants_P[OF 1 2] fg)
qed

lemma term_variants_pred_Cons:
  assumes t: "term_variants_pred P t s"
    and T: "term_variants_pred P (Fun f T) (Fun f S)"
    and fg: "f = g \<or> g \<in> set (P f)"
  shows "term_variants_pred P (Fun f (t#T)) (Fun g (s#S))"
proof -
  have 1: "length (t#T) = length (s#S)"
       and "\<And>i. i < length T \<Longrightarrow> term_variants_pred P (T ! i) (S ! i)"
    using term_variants_pred_inv[OF T] by simp_all
  hence 2: "\<And>i. i < length (t#T) \<Longrightarrow> term_variants_pred P ((t#T) ! i) ((s#S) ! i)"
    by (metis t One_nat_def diff_less length_Cons less_Suc_eq less_imp_diff_less nth_Cons'
              zero_less_Suc)

  show ?thesis using 1 2 fg by (auto intro: term_variants_pred.intros)
qed

lemma term_variants_pred_dense:
  fixes P Q::"'a set" and fs gs::"'a list"
  defines "P_fs x \<equiv> if x \<in> P then fs else []"
    and "P_gs x \<equiv> if x \<in> P then gs else []"
    and "Q_fs x \<equiv> if x \<in> Q then fs else []"
  assumes ut: "term_variants_pred P_fs u t"
    and g: "g \<in> Q" "g \<in> set gs"
  shows "\<exists>s. term_variants_pred P_gs u s \<and> term_variants_pred Q_fs s t"
proof -
  define F where "F \<equiv> \<lambda>(P::'a set) (fs::'a list) x. if x \<in> P then fs else []"

  show ?thesis using ut g P_fs_def unfolding P_gs_def Q_fs_def
  proof (induction P_fs u t arbitrary: g gs rule: term_variants_pred.induct)
    case (term_variants_Var P h x) thus ?case
      by (auto intro: term_variants_pred.term_variants_Var)
  next
    case (term_variants_P T S P' h' h g gs)
    note hyps = term_variants_P.hyps(1,2,4,5,6,7)
    note IH = term_variants_P.hyps(3)

    have "\<exists>s. term_variants_pred (F P gs) (T ! i) s \<and> term_variants_pred (F Q fs) s (S ! i)"
      when i: "i < length T" for i
      using IH[OF i hyps(4,5,6)] unfolding F_def by presburger
    then obtain U where U:
        "length T = length U" "\<And>i. i < length T \<Longrightarrow> term_variants_pred (F P gs) (T ! i) (U ! i)"
        "length U = length S" "\<And>i. i < length U \<Longrightarrow> term_variants_pred (F Q fs) (U ! i) (S ! i)"
      using hyps(1) Skolem_list_nth[of _ "\<lambda>i s. term_variants_pred (F P gs) (T ! i) s \<and>
                                                term_variants_pred (F Q fs) s (S ! i)"]
      by moura

    show ?case
      using term_variants_pred.term_variants_P[OF U(1,2), of g h]
            term_variants_pred.term_variants_P[OF U(3,4), of h' g]
            hyps(3)[unfolded hyps(6)] hyps(4,5)
      unfolding F_def by force
  next
    case (term_variants_Fun T S P' h' g gs)
    note hyps = term_variants_Fun.hyps(1,2,4,5,6)
    note IH = term_variants_Fun.hyps(3)

    have "\<exists>s. term_variants_pred (F P gs) (T ! i) s \<and> term_variants_pred (F Q fs) s (S ! i)"
      when i: "i < length T" for i
      using IH[OF i hyps(3,4,5)] unfolding F_def by presburger
    then obtain U where U:
        "length T = length U" "\<And>i. i < length T \<Longrightarrow> term_variants_pred (F P gs) (T ! i) (U ! i)"
        "length U = length S" "\<And>i. i < length U \<Longrightarrow> term_variants_pred (F Q fs) (U ! i) (S ! i)"
      using hyps(1) Skolem_list_nth[of _ "\<lambda>i s. term_variants_pred (F P gs) (T ! i) s \<and>
                                                term_variants_pred (F Q fs) s (S ! i)"]
      by moura

    thus ?case
      using term_variants_pred.term_variants_Fun[OF U(1,2)]
            term_variants_pred.term_variants_Fun[OF U(3,4)]
      unfolding F_def by meson
  qed
qed

lemma term_variants_pred_dense':
  assumes ut: "term_variants_pred ((\<lambda>_. [])(a := [b])) u t"
  shows "\<exists>s. term_variants_pred ((\<lambda>_. [])(a := [c])) u s \<and>
             term_variants_pred ((\<lambda>_. [])(c := [b])) s t"
using ut term_variants_pred_dense[of "{a}" "[b]" u t c "{c}" "[c]"]
unfolding fun_upd_def by simp

lemma term_variants_pred_eq_case:
  fixes t s::"('a,'b) term"
  assumes "term_variants_pred P t s" "\<forall>f \<in> funs_term t. P f = []"
  shows "t = s"
using assms
proof (induction P t s rule: term_variants_pred.induct)
  case (term_variants_Fun T S P f) thus ?case
    using subtermeq_imp_funs_term_subset[OF Fun_param_in_subterms[OF nth_mem], of _ T f]
          nth_equalityI[of T S]
    by blast
qed (simp_all add: term_variants_pred_refl)

lemma term_variants_pred_subst:
  assumes "term_variants_pred P t s"
  shows "term_variants_pred P (t \<cdot> \<delta>) (s \<cdot> \<delta>)"
using assms
proof (induction P t s rule: term_variants_pred.induct)
  case (term_variants_P T S P f g)
  have 1: "length (map (\<lambda>t. t \<cdot> \<delta>) T) = length (map (\<lambda>t. t \<cdot> \<delta>) S)"
    using term_variants_P.hyps
    by simp

  have 2: "term_variants_pred P ((map (\<lambda>t. t \<cdot> \<delta>) T) ! i) ((map (\<lambda>t. t \<cdot> \<delta>) S) ! i)"
    when "i < length (map (\<lambda>t. t \<cdot> \<delta>) T)" for i
    using term_variants_P that
    by fastforce

  show ?case
    using term_variants_pred.term_variants_P[OF 1 2 term_variants_P.hyps(3)]
    by fastforce
next
  case (term_variants_Fun T S P f)
  have 1: "length (map (\<lambda>t. t \<cdot> \<delta>) T) = length (map (\<lambda>t. t \<cdot> \<delta>) S)"
    using term_variants_Fun.hyps
    by simp

  have 2: "term_variants_pred P ((map (\<lambda>t. t \<cdot> \<delta>) T) ! i) ((map (\<lambda>t. t \<cdot> \<delta>) S) ! i)"
    when "i < length (map (\<lambda>t. t \<cdot> \<delta>) T)" for i
    using term_variants_Fun that
    by fastforce

  show ?case
    using term_variants_pred.term_variants_Fun[OF 1 2]
    by fastforce
qed (simp add: term_variants_pred_refl)

lemma term_variants_pred_subst':
  fixes t s::"('a,'b) term" and \<delta>::"('a,'b) subst"
  assumes "term_variants_pred P (t \<cdot> \<delta>) s"
    and "\<forall>x \<in> fv t \<union> fv s. (\<exists>y. \<delta> x = Var y) \<or> (\<exists>f. \<delta> x = Fun f [] \<and> P f = [])"
  shows "\<exists>u. term_variants_pred P t u \<and> s = u \<cdot> \<delta>"
using assms
proof (induction P "t \<cdot> \<delta>" s arbitrary: t rule: term_variants_pred.induct)
  case (term_variants_Var P x g) thus ?case using term_variants_pred_refl by fast
next
  case (term_variants_P T S P g f) show ?case
  proof (cases t)
    case (Var x) thus ?thesis
      using term_variants_P.hyps(4,5) term_variants_P.prems
      by fastforce
  next
    case (Fun h U)
    hence 1: "h = f" "T = map (\<lambda>s. s \<cdot> \<delta>) U" "length U = length T"
      using term_variants_P.hyps(5) by simp_all
    hence 2: "T ! i = U ! i \<cdot> \<delta>" when "i < length T" for i
      using that by simp

    have "\<forall>x \<in> fv (U ! i) \<union> fv (S ! i). (\<exists>y. \<delta> x = Var y) \<or> (\<exists>f. \<delta> x = Fun f [] \<and> P f = [])"
      when "i < length U" for i
      using that Fun term_variants_P.prems term_variants_P.hyps(1) 1(3)
      by force
    hence IH: "\<forall>i < length U. \<exists>u. term_variants_pred P (U ! i) u \<and> S ! i = u \<cdot> \<delta>"
      by (metis 1(3) term_variants_P.hyps(3)[OF _ 2])

    have "\<exists>V. length U = length V \<and> S = map (\<lambda>v. v \<cdot> \<delta>) V \<and>
               (\<forall>i < length U. term_variants_pred P (U ! i) (V ! i))"
      using term_variants_P.hyps(1) 1(3) subst_term_list_obtain[OF IH] by metis
    then obtain V where V: "length U = length V" "S = map (\<lambda>v. v \<cdot> \<delta>) V"
                           "\<And>i. i < length U \<Longrightarrow> term_variants_pred P (U ! i) (V ! i)"
      by moura

    have "term_variants_pred P (Fun f U) (Fun g V)"
      by (metis term_variants_pred.term_variants_P[OF V(1,3) term_variants_P.hyps(4)])
    moreover have "Fun g S = Fun g V \<cdot> \<delta>" using V(2) by simp
    ultimately show ?thesis using term_variants_P.hyps(1,4) Fun 1 by blast
  qed
next
  case (term_variants_Fun T S P f t) show ?case
  proof (cases t)
    case (Var x)
    hence "T = []" "P f = []" using term_variants_Fun.hyps(4) term_variants_Fun.prems by fastforce+
    thus ?thesis using term_variants_pred_refl Var term_variants_Fun.hyps(1,4) by fastforce
  next
    case (Fun h U)
    hence 1: "h = f" "T = map (\<lambda>s. s \<cdot> \<delta>) U" "length U = length T"
      using term_variants_Fun.hyps(4) by simp_all
    hence 2: "T ! i = U ! i \<cdot> \<delta>" when "i < length T" for i
      using that by simp

    have "\<forall>x \<in> fv (U ! i) \<union> fv (S ! i). (\<exists>y. \<delta> x = Var y) \<or> (\<exists>f. \<delta> x = Fun f [] \<and> P f = [])"
      when "i < length U" for i
      using that Fun term_variants_Fun.prems term_variants_Fun.hyps(1) 1(3)
      by force
    hence IH: "\<forall>i < length U. \<exists>u. term_variants_pred P (U ! i) u \<and> S ! i = u \<cdot> \<delta>"
      by (metis 1(3) term_variants_Fun.hyps(3)[OF _ 2 ])

    have "\<exists>V. length U = length V \<and> S = map (\<lambda>v. v \<cdot> \<delta>) V \<and>
               (\<forall>i < length U. term_variants_pred P (U ! i) (V ! i))"
      using term_variants_Fun.hyps(1) 1(3) subst_term_list_obtain[OF IH] by metis
    then obtain V where V: "length U = length V" "S = map (\<lambda>v. v \<cdot> \<delta>) V"
                           "\<And>i. i < length U \<Longrightarrow> term_variants_pred P (U ! i) (V ! i)"
      by moura

    have "term_variants_pred P (Fun f U) (Fun f V)"
      by (metis term_variants_pred.term_variants_Fun[OF V(1,3)])
    moreover have "Fun f S = Fun f V \<cdot> \<delta>" using V(2) by simp
    ultimately show ?thesis using term_variants_Fun.hyps(1) Fun 1 by blast
  qed
qed

lemma term_variants_pred_iff_in_term_variants:
  fixes t::"('a,'b) term"
  shows "term_variants_pred P t s \<longleftrightarrow> s \<in> set (term_variants P t)"
    (is "?A t s \<longleftrightarrow> ?B t s")
proof
  define U where "U \<equiv> \<lambda>P (T::('a,'b) term list). product_lists (map (term_variants P) T)"

  have a:
      "g \<in> set (P f) \<Longrightarrow> set (map (Fun g) (U P T)) \<subseteq> set (term_variants P (Fun f T))"
      "set (map (Fun f) (U P T)) \<subseteq> set (term_variants P (Fun f T))"
    for f P g and T::"('a,'b) term list"
    using term_variants.simps(2)[of P f T]
    unfolding U_def Let_def by auto

  have b: "\<exists>S \<in> set (U P T). s = Fun f S \<or> (\<exists>g \<in> set (P f). s = Fun g S)"
    when "s \<in> set (term_variants P (Fun f T))" for P T f s
    using that by (cases "P f") (auto simp add: U_def Let_def)

  have c: "length T = length S" when "S \<in> set (U P T)" for S P T
    using that unfolding U_def
    by (simp add: in_set_product_lists_length)

  show "?A t s \<Longrightarrow> ?B t s"
  proof (induction P t s rule: term_variants_pred.induct)
    case (term_variants_P T S P g f)
    note hyps = term_variants_P.hyps
    note IH = term_variants_P.IH

    have "S \<in> set (U P T)"
      using IH hyps(1) product_lists_in_set_nth'[of _ S]
      unfolding U_def by simp
    thus ?case using a(1)[of _ P, OF hyps(3)] by auto
  next
    case (term_variants_Fun T S P f)
    note hyps = term_variants_Fun.hyps
    note IH = term_variants_Fun.IH

    have "S \<in> set (U P T)"
      using IH hyps(1) product_lists_in_set_nth'[of _ S]
      unfolding U_def by simp
    thus ?case using a(2)[of f P T] by (cases "P f") auto
  qed (simp add: term_variants_Var)

  show "?B t s \<Longrightarrow> ?A t s"
  proof (induction P t arbitrary: s rule: term_variants.induct)
    case (2 P f T)
    obtain S where S:
        "s = Fun f S \<or> (\<exists>g \<in> set (P f). s = Fun g S)"
        "S \<in> set (U P T)" "length T = length S"
      using c b[OF "2.prems"] by moura

    have "\<forall>i < length T. term_variants_pred P (T ! i) (S ! i)"
      using "2.IH" S product_lists_in_set_nth by (fastforce simp add: U_def)
    thus ?case using S by (auto intro: term_variants_pred.intros)
  qed (simp add: term_variants_Var)
qed

lemma term_variants_pred_finite:
  "finite {s. term_variants_pred P t s}"
using term_variants_pred_iff_in_term_variants[of P t]
by simp

lemma term_variants_pred_fv_eq:
  assumes "term_variants_pred P s t"
  shows "fv s = fv t"
using assms
by (induct rule: term_variants_pred.induct)
   (metis, metis fv_eq_FunI, metis fv_eq_FunI)

lemma (in intruder_model) term_variants_pred_wf_trms:
  assumes "term_variants_pred P s t"
    and "\<And>f g. g \<in> set (P f) \<Longrightarrow> arity f = arity g"
    and "wf\<^sub>t\<^sub>r\<^sub>m s"
  shows "wf\<^sub>t\<^sub>r\<^sub>m t"
using assms
apply (induction rule: term_variants_pred.induct, simp)
by (metis (no_types) wf_trmI wf_trm_arity in_set_conv_nth wf_trm_param_idx)+

lemma term_variants_pred_funs_term:
  assumes "term_variants_pred P s t"
    and "f \<in> funs_term t"
  shows "f \<in> funs_term s \<or> (\<exists>g \<in> funs_term s. f \<in> set (P g))"
  using assms
proof (induction rule: term_variants_pred.induct)
  case (term_variants_P T S P g h) thus ?case
  proof (cases "f = g")
    case False
    then obtain s where "s \<in> set S" "f \<in> funs_term s"
      using funs_term_subterms_eq(1)[of "Fun g S"] term_variants_P.prems by auto
    thus ?thesis
      using term_variants_P.IH term_variants_P.hyps(1) in_set_conv_nth[of s S] by force
  qed simp
next
  case (term_variants_Fun T S P h) thus ?case
  proof (cases "f = h")
    case False
    then obtain s where "s \<in> set S" "f \<in> funs_term s"
      using funs_term_subterms_eq(1)[of "Fun h S"] term_variants_Fun.prems by auto
    thus ?thesis
      using term_variants_Fun.IH term_variants_Fun.hyps(1) in_set_conv_nth[of s S] by force
  qed simp
qed fast

end