theory InferVar
  imports WTLemma
begin

    (* ##### TO MOVE *)

lemma add_rem_use_env: "add_use_env (rem_use_env r_s x) x (r_s x) = r_s"
  apply (case_tac "\<forall> x'. add_use_env (rem_use_env r_s x) x (r_s x) x' = r_s x'")
   apply (auto)
  apply (simp add: add_use_env_def)
  apply (case_tac "x = x'")
   apply (auto)
  apply (simp add: rem_use_env_def)
  done

lemma max_aff_leq: "\<lbrakk> aff_leq a1 ax; aff_leq a2 ax \<rbrakk> \<Longrightarrow> aff_leq (max_aff a1 a2) ax"
  apply (case_tac a1)
    apply (auto)
   apply (case_tac a2)
     apply (auto)
  apply (case_tac a2)
    apply (auto)
  done

    (* ##### extended environment definitions *)
    (* schema types *)

type_synonym p_var = nat
type_synonym t_var = nat

datatype s_perm = SPerm p_perm | SVar p_var

datatype s_aff = AffConst p_aff | AffVar p_var

datatype x_perm = XPerm s_perm | XType nat | XComp x_perm x_perm | XLift x_perm s_perm | XIfZero x_perm x_perm

datatype s_type =
   IntScheme | UnitScheme | BoolScheme
  | VarScheme t_var
  | ArrayScheme s_type
  | PairScheme s_type s_type s_perm
  | FunScheme s_type s_type s_perm s_aff
  | ChanScheme s_type c_end

definition pure_fun_s where
  "pure_fun_s t1 t2 a = FunScheme t1 t2 (SPerm UsePerm) a"

    (* schema perm envs *)

type_synonym perm_var_env = "res_id \<Rightarrow> x_perm"

definition empty_var_env where
  "empty_var_env = (\<lambda> x. XPerm (SPerm NoPerm))"

definition one_var_env where
  "one_var_env x q = (\<lambda> x'. if x' = x then q else XPerm (SPerm NoPerm))"

definition add_var_env where
  "add_var_env r_s x q = (\<lambda> x'. if x' = x then q else r_s x)"

definition rem_var_env where
  "rem_var_env r_s x = (\<lambda> x'. if x' = x then XPerm (SPerm NoPerm) else r_s x')"

definition comp_var_env where
  "comp_var_env r_s r_x = (\<lambda> x. if r_s x = XPerm (SPerm NoPerm) \<and> r_x x = XPerm (SPerm NoPerm) then XPerm (SPerm NoPerm) else XComp (r_s x) (r_x x))"

definition lift_var_env where
  "lift_var_env r_s r = (\<lambda> x. if r_s x = XPerm (SPerm NoPerm) then r_s x else XLift (r_s x) r)"

definition ifz_var_env where
  "ifz_var_env r r_s = (\<lambda> x. if r_s x = XPerm (SPerm NoPerm) then XPerm (SPerm NoPerm) else XIfZero r (r_s x))"

    (* solution substitution *)

type_synonym 'a subst_env = "('a, nat) gen_env"

type_synonym type_subst = "s_type subst_env"
type_synonym dir_type_subst = "p_type subst_env"

type_synonym perm_subst = "nat \<Rightarrow> p_perm"

fun sol_subst_aff where
  "sol_subst_aff p_sub (AffConst a) = a"
| "sol_subst_aff p_sub (AffVar x) = as_aff (p_sub x)"

fun sol_subst_perm :: "perm_subst \<Rightarrow> s_perm \<Rightarrow> p_perm" where
  "sol_subst_perm p_sub (SPerm p) = p"
| "sol_subst_perm p_sub (SVar x) = p_sub x"

fun dir_subst_permx :: "dir_type_subst \<Rightarrow> perm_subst \<Rightarrow> x_perm \<Rightarrow> p_perm" where
  "dir_subst_permx t_sub p_sub (XPerm p) = (sol_subst_perm p_sub p)"
| "dir_subst_permx t_sub p_sub (XType a) = (case t_sub a of
    None \<Rightarrow> NoPerm
    | Some tau \<Rightarrow> as_perm (req_type tau))"
| "dir_subst_permx t_sub p_sub (XComp p1 p2) = union_perm (dir_subst_permx t_sub p_sub p1) (dir_subst_permx t_sub p_sub p2)"
| "dir_subst_permx t_sub p_sub (XLift p q) = (if sol_subst_perm p_sub q = OwnPerm \<and>
  dir_subst_permx t_sub p_sub p \<noteq> NoPerm then OwnPerm else dir_subst_permx t_sub p_sub p)"
| "dir_subst_permx t_sub p_sub (XIfZero p q) = (if dir_subst_permx t_sub p_sub p = NoPerm then NoPerm else dir_subst_permx t_sub p_sub q)"

definition dir_subst_penv :: "dir_type_subst \<Rightarrow> perm_subst \<Rightarrow> perm_var_env \<Rightarrow> perm_use_env" where
  "dir_subst_penv t_sub p_sub r_s = (\<lambda> x. dir_subst_permx t_sub p_sub (r_s x))"

fun dir_subst_type :: "dir_type_subst \<Rightarrow> perm_subst \<Rightarrow> s_type \<Rightarrow> p_type \<Rightarrow> bool" where
  "dir_subst_type t_sub p_sub IntScheme tau' = (tau' = IntTy)"
| "dir_subst_type t_sub p_sub UnitScheme tau' = (tau' = UnitTy)"
| "dir_subst_type t_sub p_sub BoolScheme tau' = (tau' = BoolTy)"
| "dir_subst_type t_sub p_sub (VarScheme a) tau' = (t_sub a = Some tau')"
| "dir_subst_type t_sub p_sub (ArrayScheme tau) tau' = (\<exists> tau_x.
  dir_subst_type t_sub p_sub tau tau_x \<and> tau' = ArrayTy tau_x)"
| "dir_subst_type t_sub p_sub (PairScheme t1 t2 p) tau' = (\<exists> t1_x t2_x.
  dir_subst_type t_sub p_sub t1 t1_x \<and> dir_subst_type t_sub p_sub t2 t2_x \<and>
  tau' = PairTy t1_x t2_x (sol_subst_perm p_sub p))"
| "dir_subst_type t_sub p_sub (FunScheme t1 t2 p q) tau' = (\<exists> t1_x t2_x.
  dir_subst_type t_sub p_sub t1 t1_x \<and> dir_subst_type t_sub p_sub t2 t2_x \<and>
  tau' = FunTy t1_x t2_x (sol_subst_perm p_sub p) (sol_subst_aff p_sub q))"
| "dir_subst_type t_sub p_sub (ChanScheme tau c_end) tau' = (\<exists> tau_x.
  dir_subst_type t_sub p_sub tau tau_x \<and> tau' = ChanTy tau_x c_end)"

definition dir_subst_tenv :: "dir_type_subst \<Rightarrow> nat res_env => pt_env" where
  "dir_subst_tenv t_sub env_v = (\<lambda> x. case env_v x of
    None \<Rightarrow> None
    | Some a \<Rightarrow> t_sub a)"

fun full_subst_type_f :: "dir_type_subst \<Rightarrow> perm_subst \<Rightarrow> p_type \<Rightarrow> s_type \<Rightarrow> p_type" where
  "full_subst_type_f t_sub p_sub tau_n IntScheme = IntTy"
| "full_subst_type_f t_sub p_sub tau_n UnitScheme = UnitTy"
| "full_subst_type_f t_sub p_sub tau_n BoolScheme = BoolTy"
| "full_subst_type_f t_sub p_sub tau_n (VarScheme x) = (case t_sub x of
    None \<Rightarrow> tau_n
    | Some tau \<Rightarrow> tau
  )"
| "full_subst_type_f t_sub p_sub tau_n (ArrayScheme tau) = ArrayTy (full_subst_type_f t_sub p_sub tau_n tau)"
| "full_subst_type_f t_sub p_sub tau_n (PairScheme t1 t2 p) =
    PairTy (full_subst_type_f t_sub p_sub tau_n t1) (full_subst_type_f t_sub p_sub tau_n t2) (sol_subst_perm p_sub p)"
| "full_subst_type_f t_sub p_sub tau_n (FunScheme t1 t2 p q) = FunTy (full_subst_type_f t_sub p_sub tau_n t1)
  (full_subst_type_f t_sub p_sub tau_n t2) (sol_subst_perm p_sub p) (sol_subst_aff p_sub q)"
| "full_subst_type_f t_sub p_sub tau_n (ChanScheme tau c_end) = ChanTy (full_subst_type_f t_sub p_sub tau_n tau) c_end"

definition full_subst_type where
  "full_subst_type t_sub p_sub tau_n tau_v = full_subst_type_f t_sub p_sub tau_n tau_v"

definition fill_tsub :: "dir_type_subst \<Rightarrow> p_type \<Rightarrow> dir_type_subst" where
  "fill_tsub t_sub tau_n = (\<lambda> x. case t_sub x of None \<Rightarrow> Some tau_n | Some tau \<Rightarrow> Some tau)"

    (* ##### lemmas *)

lemma subst_empty_var_env: "dir_subst_penv t_sub p_sub empty_var_env = empty_use_env"
  apply (case_tac "\<forall> x. dir_subst_penv t_sub p_sub empty_var_env x = empty_use_env x")
   apply (auto)
  apply (simp add: empty_var_env_def)
  apply (simp add: empty_use_env_def)
  apply (simp add: dir_subst_penv_def)
  done

lemma end_req_aff_leq_perm: "\<lbrakk> aff_leq (req_type tau) (sol_subst_perm p_sub (SVar p)) \<rbrakk> \<Longrightarrow>
  leq_perm (end_req_perm tau) (dir_subst_permx t_sub p_sub (one_var_env x (XPerm (SVar p)) x))"
  apply (simp add: one_var_env_def)
  apply (simp add: end_req_perm_def)
  apply (case_tac "req_type tau")
    apply (auto)
   apply (case_tac "sol_subst_perm p_sub (SVar p)")
     apply (auto)
  apply (case_tac "sol_subst_perm p_sub (SVar p)")
    apply (auto)
  done

lemma lift_sol_subst_penv: "lift_use_env (dir_subst_penv t_sub p_sub r_s) (sol_subst_perm p_sub r) = dir_subst_penv t_sub p_sub (lift_var_env r_s r)"
  apply (case_tac "\<forall> x. lift_use_env (dir_subst_penv t_sub p_sub r_s) (sol_subst_perm p_sub r) x = dir_subst_penv t_sub p_sub (lift_var_env r_s r) x")
  apply (auto)
  apply (simp add: dir_subst_penv_def)
  apply (simp add: lift_var_env_def)
  apply (case_tac "sol_subst_perm p_sub r")
    apply (auto)
  done

lemma lift_sol_subst_penvx: "lift_use_env (dir_subst_penv t_sub p_sub r_s) (p_sub r) = dir_subst_penv t_sub p_sub (lift_var_env r_s (SVar r))"
  apply (case_tac "\<forall> x. lift_use_env (dir_subst_penv t_sub p_sub r_s) (p_sub r) x = dir_subst_penv t_sub p_sub (lift_var_env r_s (SVar r)) x")
  apply (auto)
  apply (simp add: dir_subst_penv_def)
  apply (simp add: lift_var_env_def)
  apply (case_tac "p_sub r")
    apply (auto)
  done

lemma comp_sol_subst_penv: "dir_subst_penv t_sub p_sub (comp_var_env r_s r_x) = comp_use_env (dir_subst_penv t_sub p_sub r_s) (dir_subst_penv t_sub p_sub r_x)"
  apply (case_tac "\<forall> x. dir_subst_penv t_sub p_sub (comp_var_env r_s r_x) x = comp_use_env (dir_subst_penv t_sub p_sub r_s) (dir_subst_penv t_sub p_sub r_x) x")
   apply (auto)
  apply (simp add: comp_use_env_def)
  apply (simp add: comp_var_env_def)
  apply (simp add: dir_subst_penv_def)
  apply (case_tac "r_s x = XPerm (SPerm NoPerm) \<and> r_x x = XPerm (SPerm NoPerm)")
   apply (auto)
  done

lemma dist_comp_leq_var_env: "\<lbrakk> leq_use_env (dir_subst_penv t_sub p_sub r_x1) r_s;
  leq_use_env (dir_subst_penv t_sub p_sub r_x2) r_s \<rbrakk> \<Longrightarrow>
  leq_use_env (dir_subst_penv t_sub p_sub (comp_var_env r_x1 r_x2)) r_s"
  apply (simp add: comp_sol_subst_penv)
  apply (rule_tac dist_comp_leq_use_env)
   apply (simp_all)
  done

lemma comp_leq_var_env1: "\<lbrakk> leq_use_env r_x (dir_subst_penv t_sub p_sub r_s1) \<rbrakk> \<Longrightarrow>
  leq_use_env r_x (dir_subst_penv t_sub p_sub (comp_var_env r_s1 r_s2))"
  apply (simp add: comp_sol_subst_penv)
  apply (rule_tac comp_leq_use_env1)
  apply (simp)
  done

lemma comp_leq_var_env2: "\<lbrakk> leq_use_env r_x (dir_subst_penv t_sub p_sub r_s2) \<rbrakk> \<Longrightarrow>
  leq_use_env r_x (dir_subst_penv t_sub p_sub (comp_var_env r_s1 r_s2))"
  apply (simp add: comp_sol_subst_penv)
  apply (rule_tac comp_leq_use_env2)
  apply (simp)
  done

lemma lift_leq_var_env: "\<lbrakk> leq_use_env (dir_subst_penv t_sub p_sub r_x) (dir_subst_penv t_sub p_sub r_s) \<rbrakk> \<Longrightarrow>
  leq_use_env (dir_subst_penv t_sub p_sub r_x) (dir_subst_penv t_sub p_sub (lift_var_env r_s r))"
  apply (rule_tac t="dir_subst_penv t_sub p_sub (lift_var_env r_s r)" and s="lift_use_env (dir_subst_penv t_sub p_sub r_s) (sol_subst_perm p_sub r)" in subst)
   apply (rule_tac lift_sol_subst_penv)
  apply (rule_tac lift_leq_use_env)
  apply (simp)
  done

lemma dist_lift_leq_var_env: "\<lbrakk> leq_use_env (dir_subst_penv t_sub p_sub r_x) (dir_subst_penv t_sub p_sub r_s) \<rbrakk> \<Longrightarrow>
  leq_use_env (dir_subst_penv t_sub p_sub (lift_var_env r_x r)) (dir_subst_penv t_sub p_sub (lift_var_env r_s r))"
  apply (rule_tac t="dir_subst_penv t_sub p_sub (lift_var_env r_s r)" and s="lift_use_env (dir_subst_penv t_sub p_sub r_s) (sol_subst_perm p_sub r)" in subst)
   apply (rule_tac lift_sol_subst_penv)
  apply (rule_tac t="dir_subst_penv t_sub p_sub (lift_var_env r_x r)" and s="lift_use_env (dir_subst_penv t_sub p_sub r_x) (sol_subst_perm p_sub r)" in subst)
   apply (rule_tac lift_sol_subst_penv)
  apply (rule_tac dist_lift_leq_use_env)
  apply (simp)
  done

lemma empty_leq_var_env: "leq_use_env (dir_subst_penv t_sub p_sub empty_var_env) r_s"
  apply (simp add: dir_subst_penv_def)
  apply (simp add: empty_var_env_def)
  apply (simp add: leq_use_env_def)
  done

lemma if_zero_leq_var_env: "\<lbrakk> leq_use_env (dir_subst_penv t_sub p_sub r_x) r_s \<rbrakk> \<Longrightarrow>
  leq_use_env (dir_subst_penv t_sub p_sub (ifz_var_env q r_x)) r_s"
  apply (simp add: leq_use_env_def)
  apply (simp add: dir_subst_penv_def)
  apply (simp add: ifz_var_env_def)
  done

lemma if_zero_pos_var_env: "\<lbrakk> dir_subst_permx t_sub p_sub r \<noteq> NoPerm \<rbrakk> \<Longrightarrow> dir_subst_penv t_sub p_sub (ifz_var_env r r_s) = dir_subst_penv t_sub p_sub r_s"
  apply (case_tac "\<forall> x. dir_subst_penv t_sub p_sub (ifz_var_env r r_s) x = dir_subst_penv t_sub p_sub r_s x")
   apply (auto)
  apply (simp add: ifz_var_env_def)
  apply (simp add: dir_subst_penv_def)
  apply (auto)
  done

lemma rem_sol_subst_penv: "dir_subst_penv t_sub p_sub (rem_var_env r_s x) = rem_use_env (dir_subst_penv t_sub p_sub r_s) x"
  apply (case_tac "\<forall> x'. dir_subst_penv t_sub p_sub (rem_var_env r_s x) x' = rem_use_env (dir_subst_penv t_sub p_sub r_s) x x'")
   apply (auto)
  apply (simp add: dir_subst_penv_def)
  apply (simp add: rem_var_env_def)
  apply (simp add: rem_use_env_def)
  apply (case_tac "x = x'")
   apply (auto)
  done

    (* variable type environment lemmas *)

lemma add_sol_subst_tenv: "add_env (dir_subst_tenv (fill_tsub t_sub tau_n) env) (Var x) (full_subst_type t_sub p_sub tau_n (VarScheme a)) =
  dir_subst_tenv (fill_tsub t_sub tau_n) (add_env env (Var x) a)"
  apply (case_tac "\<forall> y. add_env (dir_subst_tenv (fill_tsub t_sub tau_n) env) (Var x) (full_subst_type t_sub p_sub tau_n (VarScheme a)) y =
  dir_subst_tenv (fill_tsub t_sub tau_n) (add_env env (Var x) a) y")
   apply (auto)
  apply (simp add: full_subst_type_def)
  apply (simp add: fill_tsub_def)
  apply (simp add: add_env_def)
  apply (simp add: dir_subst_tenv_def)
  apply (case_tac "Var x = y")
   apply (auto)
   apply (case_tac "t_sub a")
    apply (auto)
  apply (case_tac "env y")
   apply (auto)
   apply (simp add: dir_subst_tenv_def)
  apply (simp add: dir_subst_tenv_def)
  done

end


section "Insider Framework"
text \<open>In the Isabelle/HOL theory for Insiders, one expresses policies over
actions @{text \<open>get, move, eval\<close>}, and @{text \<open>put\<close>}.\<close>
subsection \<open>Actors and actions\<close>
text \<open>The theory Airinsider is an instance of the Insider framework for the case study
     of airplane insiders. Although the Isabelle Insider framework is a generic framework
     the actual semantics of the actions is specific to applications. Therefore we use here
     an "instance" of the framework in the form of a theory "Airinsider" but the main part of
     definitions and declarations is the same.\<close>
theory AirInsider
  imports MC
begin
text \<open>An actor may be enabled to
\begin{itemize}
\item @{text \<open>get\<close>} data or physical items, like keys,
\item @{text \<open>move\<close>} to a location,
\item @{text \<open>eval\<close>} a program,
\item @{text \<open>put\<close>} data at locations or physical items -- like airplanes --
``to the ground''.
\end{itemize}
The precise semantics of these actions is refined in the state transition
rules for the concrete infrastructure.
The framework abstracts from concrete data -- actions have no parameters:\<close>
datatype action = get | move | eval | put

text \<open>The human component is the {\it Actor} which is represented by an abstract
type @{text \<open>actor\<close>} and a function @{text \<open>Actor\<close>}
that creates elements of that type from identities (of type @{text \<open>string\<close>}):

We use an abstract type declaration actor that can later be instantiated by a more
      concrete type.\<close>
typedecl actor
type_synonym identity = string
consts Actor :: "identity \<Rightarrow> actor"
text \<open>Note that it would seem more natural and simpler to just
define @{text \<open>actor\<close>} as a datatype over identities with a constructor @{text \<open>Actor\<close>}
instead of a simple constant together with a type declaration like, for example,
in the Isabelle inductive approach to security protocol verification \cite{pau:97, pau:98}.
This would, however, make the constructor @{text \<open>Actor\<close>} an injective function
by the underlying foundation of datatypes therefore excluding the fine
grained modelling that is at the core of the insider definition:
In fact, it defines the function @{text \<open>Actor\<close>} to be injective
for all except insiders and explicitly enables insiders to have
different roles by identifying @{text \<open>Actor\<close>} images.

Alternatives to the type declaration do not work.

@{text \<open>context

  fixes Abs Rep actor

  assumes td: "type_definition Abs Rep actor"

begin

definition Actor where "Actor = Abs"
\<close>}
...doesn't work as an alternative to the actor @{term \<open>typedecl\<close>} because
in @{text \<open>type_definition\<close>} above the @{text \<open>actor\<close>} is a set not a type!
So can't be used for our purposes.

Trying a locale instead for polymorphic type Actor is a suggested alternative
\cite{mw:09}.

@{text
\<open>locale ACT =
  fixes Actor :: "string \<Rightarrow> 'actor"
begin ...\<close>
}
That is a nice idea and works quite far but clashes with the generic
@{text \<open>state_transition\<close>} later (it's not possible to instantiate within a locale
and outside of it we cannot instantiate @{text \<open>'a infrastructure\<close>} to state (clearly
an abstract thing as an instance is strange).\<close>

definition ID :: "[actor, string] \<Rightarrow> bool"
where "ID a s \<equiv> (a = Actor s)"

subsection \<open>Infrastructure graphs and policies\<close>
text\<open>Actors are contained in an infrastructure graph. An @{text \<open>igraph\<close>} contains
a set of location pairs representing the topology of the infrastructure
as a graph of nodes and a list of actor identities associated to each node
(location) in the graph.
Also an @{text \<open>igraph\<close>} associates actors to a pair of string sets by
a pair-valued function whose first range component is a set describing
the credentials in the possession of an actor and the second component
is a set defining the roles the actor can take on. Finally, an  @{text \<open>igraph\<close>}
assigns locations to a pair of a string that defines
the state of the component.
Corresponding projection functions for each of these components of an
@{text \<open>igraph\<close>} are provided; they are named @{text \<open>gra\<close>} for the actual set of pairs of
locations, @{text \<open>agra\<close>} for the actor map, @{text \<open>cgra\<close>} for the credentials,
and @{text \<open>lgra\<close>} for the state of a location and the data at that location.\<close>
datatype location = Location nat
datatype igraph = Lgraph "(location * location)set" "location \<Rightarrow> identity list"
                         "actor \<Rightarrow> (string list * string list)"  "location \<Rightarrow> string list"
text \<open>Atomic policies of type @{text \<open>apolicy\<close>}
describe prerequisites for actions to be granted to actors given by
pairs of predicates (conditions) and sets of (enabled) actions:\<close>
type_synonym  apolicy = "((actor \<Rightarrow> bool) * action set)"

datatype infrastructure =
         Infrastructure "igraph"
                        "[igraph, location] \<Rightarrow> apolicy set"

primrec loc :: "location \<Rightarrow> nat"
where  "loc(Location n) = n"
primrec gra :: "igraph \<Rightarrow> (location * location)set"
where  "gra(Lgraph g a c l) = g"
primrec agra :: "igraph \<Rightarrow> (location \<Rightarrow> identity list)"
where  "agra(Lgraph g a c l) = a"
primrec cgra :: "igraph \<Rightarrow> (actor \<Rightarrow> string list * string list)"
where  "cgra(Lgraph g a c l) = c"
primrec lgra :: "igraph \<Rightarrow> (location \<Rightarrow> string list)"
where  "lgra(Lgraph g a c l) = l"

definition nodes :: "igraph \<Rightarrow> location set"
where "nodes g == { x. (? y. ((x,y): gra g) | ((y,x): gra g))}"
definition actors_graph :: "igraph \<Rightarrow> identity set"
where  "actors_graph g == {x. ? y. y : nodes g \<and> x \<in> set(agra g y)}"
primrec graphI :: "infrastructure \<Rightarrow> igraph"
where "graphI (Infrastructure g d) = g"
primrec delta :: "[infrastructure, igraph, location] \<Rightarrow> apolicy set"
where "delta (Infrastructure g d) = d"
primrec tspace :: "[infrastructure, actor ] \<Rightarrow> string list * string list"
  where "tspace (Infrastructure g d) = cgra g"
primrec lspace :: "[infrastructure, location ] \<Rightarrow> string list"
where "lspace (Infrastructure g d) = lgra g"
definition credentials :: "string list * string list \<Rightarrow> string set"
  where  "credentials lxl \<equiv> set (fst lxl)"
definition has :: "[igraph, actor * string] \<Rightarrow> bool"
  where "has G ac \<equiv> snd ac \<in> credentials(cgra G (fst ac))"
definition roles :: "string list * string list \<Rightarrow> string set"
  where  "roles lxl \<equiv> set (snd lxl)"
definition role :: "[igraph, actor * string] \<Rightarrow> bool"
  where "role G ac \<equiv> snd ac \<in> roles(cgra G (fst ac))"
definition isin :: "[igraph,location, string] \<Rightarrow> bool"
  where "isin G l s \<equiv> s \<in> set(lgra G l)"

subsection \<open>Insider predicate\<close>
text \<open>The human actor's level is modelled in the Isabelle Insider framework by assigning
the individual actor's psychological disposition\footnote{Note that the determination of
the psychological state of an actor is not done using the formal system. It is up to a
psychologist to determine this. However, if for instance, an actor is classified as
@{text \<open>disgruntled\<close>} then this may have an influence on what they are allowed to do according
to a company policy and this can be formally described and reasoned about in Isabelle.}
@{text \<open>actor_state\<close>} to each actor's identity.\<close>
datatype psy_states = happy | depressed | disgruntled | angry | stressed
datatype motivations = financial | political | revenge | curious | competitive_advantage | power | peer_recognition

text \<open>The values used for the definition of the types
@{text \<open>motivations\<close>} and @{text \<open>psy_state\<close>}
are based on a taxonomy from psychological insider research \cite{nblgcww:14}.
The transition to become an insider is represented by a {\it Catalyst} that tips the insider
over the edge so he acts as an insider formalized as a ``tipping point''
predicate.\<close>
datatype actor_state = Actor_state "psy_states" "motivations set"
primrec motivation :: "actor_state \<Rightarrow> motivations set"
where "motivation  (Actor_state p m) =  m"
primrec psy_state :: "actor_state \<Rightarrow> psy_states"
where "psy_state  (Actor_state p m) = p"

definition tipping_point :: "actor_state \<Rightarrow> bool" where
  "tipping_point a \<equiv> ((motivation a \<noteq> {}) \<and> (happy \<noteq> psy_state a))"

text \<open>To embed the fact that the attacker is an insider, the actor can then
impersonate other actors. In the Isabelle Insider framework, the
predicate @{text \<open>Insider\<close>} must be used as a {\it locale} assumption
to enable impersonation for the insider:
this assumption entails that an insider @{text \<open>Actor ''Eve''\<close>} can act like
their alter ego, say @{text \<open>Actor ''Charly''\<close>} within the context of the locale.
This is realized by the predicate  @{text \<open>UasI\<close>}:
@{text \<open>UasI\<close>} and @{text \<open>UasI'\<close>} are the central predicates allowing to specify Insiders.
They define which identities can be mapped to the same role by the @{text \<open>Actor\<close>} function
(an impersonation predicate "@{text \<open>a\<close>} can act as @{text \<open>b\<close>}").
For all other identities, @{text \<open>Actor\<close>} is defined as injective on those identities.
The first one is stronger and allows substitution of the insider in any context; the second
one is parameterized over a context predicate to describe this.\<close>
definition UasI ::  "[identity, identity] \<Rightarrow> bool "
where "UasI a b \<equiv> (Actor a = Actor b) \<and> (\<forall> x y. x \<noteq> a \<and> y \<noteq> a \<and> Actor x = Actor y \<longrightarrow> x = y)"
definition UasI' ::  "[actor \<Rightarrow> bool, identity, identity] \<Rightarrow> bool "
where "UasI' P a b \<equiv> P (Actor b) \<longrightarrow> P (Actor a)"

text \<open>Two versions of Insider predicate corresponding to @{text \<open>UasI\<close>} and @{text \<open>UasI'\<close>}
exist. Under the assumption that the tipping point has been reached for a person @{text \<open>a\<close>}
then @{text \<open>a\<close>} can impersonate all @{text \<open>b\<close>} (take all of @{text \<open>b\<close>}'s "roles") where
the @{text \<open>b\<close>}'s are specified by a given set of identities.\<close>
definition Insider :: "[identity, identity set, identity \<Rightarrow> actor_state] \<Rightarrow> bool"
where "Insider a C as \<equiv> (tipping_point (as a) \<longrightarrow> (\<forall> b\<in>C. UasI a b))"
definition Insider' :: "[actor \<Rightarrow> bool, identity, identity set, identity \<Rightarrow> actor_state] \<Rightarrow> bool"
where "Insider' P a C as \<equiv> (tipping_point (as a) \<longrightarrow> (\<forall> b\<in>C. UasI' P a b \<and> inj_on Actor C))"
text \<open>The predicate @{text \<open>atI\<close>} -- mixfix syntax @{text \<open>@\<^bsub>G\<^esub>\<close>} -- expresses that an actor (identity)
      is at a certain location in an igraph.\<close>
definition atI :: "[identity, igraph, location] \<Rightarrow> bool" ("_ @\<^bsub>(_)\<^esub> _" 50)
where "a @\<^bsub>G\<^esub> l \<equiv> a \<in> set(agra G l)"
text \<open>The enables predicate is the central definition of the behaviour as given by a policy
that specifies what actions are allowed in a certain location for what actors.
Policies specify the expected behaviour of actors of an infrastructure.
They are defined by the @{text \<open>enables\<close>} predicate:
an actor @{text \<open>h\<close>} is enabled to perform an action @{text \<open>a\<close>}
in infrastructure @{text \<open>I\<close>}, at location @{text \<open>l\<close>}
if there exists a pair @{text \<open>(p,e)\<close>} in the local policy of @{text \<open>l\<close>}
(@{text \<open>delta I l\<close>} projects to the local policy) such that the action
@{text \<open>a\<close>} is a member of the action set @{text \<open>e\<close>} and the policy
predicate @{text \<open>p\<close>} holds for actor @{text \<open>h\<close>}.\<close>
definition enables :: "[infrastructure, location, actor, action] \<Rightarrow> bool"
where
"enables I l a a' \<equiv>  (\<exists> (p,e) \<in> delta I (graphI I) l. a' \<in> e \<and> p a)"
text \<open>For example, the @{text \<open>apolicy\<close>} pair @{text \<open>(\<lambda> x. True, {move})\<close>}
specifies that all actors are enabled to perform action @{text \<open>move\<close>}.\<close>

text \<open>The behaviour is the good behaviour, i.e. everything allowed by the policy of
Infrastructure @{text \<open>I\<close>}.\<close>
definition behaviour :: "infrastructure \<Rightarrow> (location * actor * action)set"
where "behaviour I \<equiv> {(t,a,a'). enables I t a a'}"

text \<open>The misbehaviour is the complement of behaviour of an Infrastructure @{text \<open>I\<close>}.\<close>
definition misbehaviour :: "infrastructure \<Rightarrow> (location * actor * action)set"
  where "misbehaviour I \<equiv> -(behaviour I)"

text \<open>We prove some basic lemmas for the predicate @{text \<open>enable\<close>}.\<close>
lemma not_enableI: "(\<forall> (p,e) \<in> delta I (graphI I) l. (\<not>(h : e) | (\<not>(p(a)))))
                     \<Longrightarrow> \<not>(enables I l a h)"
  by (simp add: enables_def, blast)

lemma not_enableI2: "\<lbrakk>\<And> p e. (p,e) \<in> delta I (graphI I) l \<Longrightarrow>
                 (\<not>(t : e) |  (\<not>(p(a)))) \<rbrakk> \<Longrightarrow> \<not>(enables I l a t)"
 by (rule not_enableI, rule ballI, auto)

lemma not_enableE: "\<lbrakk> \<not>(enables I l a t); (p,e) \<in> delta I (graphI I) l \<rbrakk>
                 \<Longrightarrow> (\<not>(t : e) |  (\<not>(p(a))))"
  by (simp add: enables_def, rule impI, force)

lemma not_enableE2: "\<lbrakk> \<not>(enables I l a t); (p,e) \<in> delta I (graphI I) l;
                     t : e \<rbrakk> \<Longrightarrow> (\<not>(p(a)))"
  by (simp add: enables_def, force)

subsection "State transition on infrastructures"
text \<open>The state transition defines how actors may act on infrastructures through actions
    within the boundaries of the policy. It is given as an inductive definition over the
    states which are infrastructures.  This state transition relation is dependent on actions but also on
    enabledness and the current state of the infrastructure.

    First we introduce some auxiliary functions dealing
    with repetitions in lists and actors moving in an @{text \<open>igraph\<close>} and some
    constructions to deal with lists of actors in locations for the semantics of action
    @{text \<open>move\<close>}.\<close>
primrec del :: "['a, 'a list] \<Rightarrow> 'a list"
where
del_nil: "del a [] = []" |
del_cons: "del a (x#ls) = (if x = a then ls else x # (del a ls))"

primrec jonce :: "['a, 'a list] \<Rightarrow> bool"
where
jonce_nil: "jonce a [] = False" |
jonce_cons: "jonce a (x#ls) = (if x = a then (a \<notin> (set ls)) else jonce a ls)"

primrec nodup :: "['a, 'a list] \<Rightarrow> bool"
  where
    nodup_nil: "nodup a [] = True" |
    nodup_step: "nodup a (x # ls) = (if x = a then (a \<notin> (set ls)) else nodup a ls)"

definition move_graph_a :: "[identity, location, location, igraph] \<Rightarrow> igraph"
where "move_graph_a n l l' g \<equiv> Lgraph (gra g)
                    (if n \<in> set ((agra g) l) &  n \<notin> set ((agra g) l') then
                     ((agra g)(l := del n (agra g l)))(l' := (n # (agra g l')))
                     else (agra g))(cgra g)(lgra g)"

text \<open>State transition relation over infrastructures (the states) defining the
   semantics of actions in systems with humans and potentially insiders.\<close>
inductive state_transition_in :: "[infrastructure, infrastructure] \<Rightarrow> bool" ("(_ \<rightarrow>\<^sub>n _)" 50)
where
  move: "\<lbrakk> G = graphI I; a @\<^bsub>G\<^esub> l; l \<in> nodes G; l' \<in> nodes G;
          (a) \<in> actors_graph(graphI I); enables I l' (Actor a) move;
         I' = Infrastructure (move_graph_a a l l' (graphI I))(delta I) \<rbrakk> \<Longrightarrow> I \<rightarrow>\<^sub>n I'"
| get : "\<lbrakk> G = graphI I; a @\<^bsub>G\<^esub> l; a' @\<^bsub>G\<^esub> l; has G (Actor a, z);
        enables I l (Actor a) get;
        I' = Infrastructure
                   (Lgraph (gra G)(agra G)
                           ((cgra G)(Actor a' :=
                                (z # (fst(cgra G (Actor a'))), snd(cgra G (Actor a')))))
                           (lgra G))
                   (delta I)
         \<rbrakk> \<Longrightarrow> I \<rightarrow>\<^sub>n I'"
| put : "\<lbrakk> G = graphI I; a @\<^bsub>G\<^esub> l; enables I l (Actor a) put;
        I' = Infrastructure
                  (Lgraph (gra G)(agra G)(cgra G)
                          ((lgra G)(l := [z])))
                   (delta I) \<rbrakk>
         \<Longrightarrow> I \<rightarrow>\<^sub>n I'"
| put_remote : "\<lbrakk> G = graphI I; enables I l (Actor a) put;
        I' = Infrastructure
                  (Lgraph (gra G)(agra G)(cgra G)
                            ((lgra G)(l := [z])))
                    (delta I) \<rbrakk>
         \<Longrightarrow> I \<rightarrow>\<^sub>n I'"

text \<open>Note that the type infrastructure can now be instantiated to the axiomatic type class
      @{text\<open>state\<close>} which enables the use of the underlying Kripke structures and CTL.
      We need to show that this infrastructure is a state as given in MC.thy\<close>
instantiation "infrastructure" :: state
begin
definition
   state_transition_infra_def: "(i \<rightarrow>\<^sub>i i') =  (i \<rightarrow>\<^sub>n (i' :: infrastructure))"

instance
  by (rule MC.class.MC.state.of_class.intro)

definition state_transition_in_refl ("(_ \<rightarrow>\<^sub>n* _)" 50)
where "s \<rightarrow>\<^sub>n* s' \<equiv> ((s,s') \<in> {(x,y). state_transition_in x y}\<^sup>*)"

text \<open>Lemmas about the auxiliary functions @{text \<open>del, jonce, nodup\<close>} are provided.\<close>
lemma del_del[rule_format]: "n \<in> set (del a S) \<longrightarrow> n \<in> set S"
  by (induct_tac S, auto)

lemma del_dec[rule_format]: "a \<in> set S \<longrightarrow> length (del a S) < length S"
  by (induct_tac S, auto)

lemma del_sort[rule_format]: "\<forall> n. (Suc n ::nat) \<le> length (l) \<longrightarrow> n \<le> length (del a (l))"
  by (induct_tac l, simp, clarify, case_tac n, simp, simp)

lemma del_jonce: "jonce a l \<longrightarrow> a \<notin> set (del a l)"
  by (induct_tac l, auto)

lemma del_nodup[rule_format]: "nodup a l \<longrightarrow> a \<notin> set(del a l)"
  by (induct_tac l, auto)

lemma nodup_up[rule_format]: "a \<in> set (del a l) \<longrightarrow> a \<in> set l"
  by (induct_tac l, auto)

lemma del_up [rule_format]: "a \<in> set (del aa l) \<longrightarrow> a \<in> set l"
  by (induct_tac l, auto)

lemma nodup_notin[rule_format]:   "a \<notin> set list \<longrightarrow> nodup a list"
  by (induct_tac list, auto)

lemma nodup_down[rule_format]: "nodup a l \<longrightarrow> nodup a (del a l)"
  by (induct_tac l, simp+, clarify, erule nodup_notin)

lemma del_notin_down[rule_format]: "a \<notin> set list \<longrightarrow> a \<notin> set (del aa list) "
  by (induct_tac list, auto)

lemma del_not_a[rule_format]: " x \<noteq> a \<longrightarrow> x \<in> set l \<longrightarrow> x \<in> set (del a l)"
  by (induct_tac l, auto)

lemma nodup_down_notin[rule_format]: "nodup a l \<longrightarrow> nodup a (del aa l)"
  by (induct_tac l, simp+, rule conjI, clarify, erule nodup_notin, (rule impI)+,
      erule del_notin_down)

lemma move_graph_eq: "move_graph_a a l l g = g"
  by (simp add: move_graph_a_def, case_tac g, force)

text \<open>Some useful properties about the invariance of the nodes, the actors, and the policy
   with respect to the  state transition are provided.\<close>
lemma delta_invariant: "\<forall> z z'. (z \<rightarrow>\<^sub>n z') \<longrightarrow>  delta(z) = delta(z')"
  by (clarify, erule state_transition_in.cases, simp+)

lemma init_state_policy0:
  assumes "\<forall> z z'. (z \<rightarrow>\<^sub>n z') \<longrightarrow>  delta(z) = delta(z')"
      and "(x,y) \<in> {(x::infrastructure, y::infrastructure). x \<rightarrow>\<^sub>n y}\<^sup>*"
    shows "delta(x) = delta(y)"
proof -
  have ind: "(x,y) \<in> {(x::infrastructure, y::infrastructure). x \<rightarrow>\<^sub>n y}\<^sup>*
             \<longrightarrow> delta(x) = delta(y)"
  proof (insert assms, erule rtrancl.induct)
    show "(\<And> a::infrastructure.
       (\<forall>(z::infrastructure)(z'::infrastructure). (z \<rightarrow>\<^sub>n z') \<longrightarrow> (delta z = delta z')) \<Longrightarrow>
       (((a, a) \<in> {(x ::infrastructure, y :: infrastructure). x \<rightarrow>\<^sub>n y}\<^sup>*) \<longrightarrow>
       (delta a = delta a)))"
    by (rule impI, rule refl)
next fix a b c
  assume a0: "\<forall>(z::infrastructure) z'::infrastructure. z \<rightarrow>\<^sub>n z' \<longrightarrow> delta z = delta z'"
     and a1: "(a, b) \<in> {(x::infrastructure, y::infrastructure). x \<rightarrow>\<^sub>n y}\<^sup>*"
     and a2: "(a, b) \<in> {(x::infrastructure, y::infrastructure). x \<rightarrow>\<^sub>n y}\<^sup>* \<longrightarrow>
         delta a = delta b"
     and a3: "(b, c) \<in> {(x::infrastructure, y::infrastructure). x \<rightarrow>\<^sub>n y}"
     show "(a, c) \<in> {(x::infrastructure, y::infrastructure). x \<rightarrow>\<^sub>n y}\<^sup>* \<longrightarrow>
       delta a = delta c"
  proof -
    have a4: "delta b = delta c" using a0 a1 a2 a3 by simp
    show ?thesis using a0 a1 a2 a3 by simp
  qed
qed
show ?thesis
  by (insert ind, insert assms(2), simp)
qed

lemma init_state_policy: "\<lbrakk> (x,y) \<in> {(x::infrastructure, y::infrastructure). x \<rightarrow>\<^sub>n y}\<^sup>* \<rbrakk> \<Longrightarrow>
                          delta(x) = delta(y)"
  by (rule init_state_policy0, rule delta_invariant)

lemma same_nodes0[rule_format]: "\<forall> z z'. z \<rightarrow>\<^sub>n z' \<longrightarrow> nodes(graphI z) = nodes(graphI z')"
  by (clarify, erule state_transition_in.cases,
       (simp add: move_graph_a_def atI_def actors_graph_def nodes_def)+)

lemma same_nodes: "(I, y) \<in> {(x::infrastructure, y::infrastructure). x \<rightarrow>\<^sub>n y}\<^sup>*
                   \<Longrightarrow> nodes(graphI y) = nodes(graphI I)"
  by (erule rtrancl_induct, rule refl, drule CollectD, simp, drule same_nodes0, simp)

lemma same_actors0[rule_format]: "\<forall> z z'. z \<rightarrow>\<^sub>n z' \<longrightarrow> actors_graph(graphI z) = actors_graph(graphI z')"
proof (clarify, erule state_transition_in.cases)
  show "\<And>(z::infrastructure) (z'::infrastructure) (G::igraph) (I::infrastructure) (a::char list)
       (l::location) (a'::char list) (za::char list) I'::infrastructure.
       z = I \<Longrightarrow>
       z' = I' \<Longrightarrow>
       G = graphI I \<Longrightarrow>
       a @\<^bsub>G\<^esub> l \<Longrightarrow>
       a' @\<^bsub>G\<^esub> l \<Longrightarrow>
       has G (Actor a, za) \<Longrightarrow>
       enables I l (Actor a) get \<Longrightarrow>
       I' =
       Infrastructure
        (Lgraph (gra G) (agra G)
          ((cgra G)(Actor a' := (za # fst (cgra G (Actor a')), snd (cgra G (Actor a'))))) (lgra G))
        (delta I) \<Longrightarrow>
       actors_graph (graphI z) = actors_graph (graphI z')"
     by (simp add: actors_graph_def nodes_def)
 next show "\<And>(z::infrastructure) (z'::infrastructure) (G::igraph) (I::infrastructure) (a::char list)
       (l::location) (I'::infrastructure) za::char list.
       z = I \<Longrightarrow>
       z' = I' \<Longrightarrow>
       G = graphI I \<Longrightarrow>
       a @\<^bsub>G\<^esub> l \<Longrightarrow>
       enables I l (Actor a) put \<Longrightarrow>
       I' = Infrastructure (Lgraph (gra G) (agra G) (cgra G) ((lgra G)(l := [za]))) (delta I) \<Longrightarrow>
       actors_graph (graphI z) = actors_graph (graphI z')"
   by (simp add: actors_graph_def nodes_def)
next show "\<And>(z::infrastructure) (z'::infrastructure) (G::igraph) (I::infrastructure) (l::location)
       (a::char list) (I'::infrastructure) za::char list.
       z = I \<Longrightarrow>
       z' = I' \<Longrightarrow>
       G = graphI I \<Longrightarrow>
       enables I l (Actor a) put \<Longrightarrow>
       I' = Infrastructure (Lgraph (gra G) (agra G) (cgra G) ((lgra G)(l := [za]))) (delta I) \<Longrightarrow>
       actors_graph (graphI z) = actors_graph (graphI z')"
    by (simp add: actors_graph_def nodes_def)
next fix z z' G I a l l' I'
  show "z = I \<Longrightarrow> z' = I' \<Longrightarrow> G = graphI I \<Longrightarrow> a @\<^bsub>G\<^esub> l \<Longrightarrow>
       l \<in> nodes G \<Longrightarrow> l' \<in> nodes G \<Longrightarrow> a \<in> actors_graph (graphI I) \<Longrightarrow>
       enables I l' (Actor a) move \<Longrightarrow>
       I' = Infrastructure (move_graph_a a l l' (graphI I)) (delta I) \<Longrightarrow>
       actors_graph (graphI z) = actors_graph (graphI z')"
  proof (rule equalityI)
    show "z = I \<Longrightarrow> z' = I' \<Longrightarrow> G = graphI I \<Longrightarrow> a @\<^bsub>G\<^esub> l \<Longrightarrow>
    l \<in> nodes G \<Longrightarrow> l' \<in> nodes G \<Longrightarrow> a \<in> actors_graph (graphI I) \<Longrightarrow>
    enables I l' (Actor a) move \<Longrightarrow>
    I' = Infrastructure (move_graph_a a l l' (graphI I)) (delta I) \<Longrightarrow>
    actors_graph (graphI z) \<subseteq> actors_graph (graphI z')"
  by (rule subsetI, simp add: actors_graph_def ,(erule exE)+, case_tac "x = a",
      rule_tac x = "l'" in exI, simp add: move_graph_a_def nodes_def atI_def,
      rule_tac x = ya in exI, rule conjI, simp add: move_graph_a_def nodes_def atI_def,
      (erule conjE)+, simp add: move_graph_a_def, rule conjI, clarify,
      simp add: move_graph_a_def nodes_def atI_def, rule del_not_a, assumption+, clarify)
next show "z = I \<Longrightarrow> z' = I' \<Longrightarrow> G = graphI I \<Longrightarrow> a @\<^bsub>G\<^esub> l \<Longrightarrow>
    l \<in> nodes G \<Longrightarrow> l' \<in> nodes G \<Longrightarrow> a \<in> actors_graph (graphI I) \<Longrightarrow>
    enables I l' (Actor a) move \<Longrightarrow>
    I' = Infrastructure (move_graph_a a l l' (graphI I)) (delta I) \<Longrightarrow>
    actors_graph (graphI z') \<subseteq> actors_graph (graphI z)"
  by (rule subsetI, simp add: actors_graph_def, (erule exE)+,
      case_tac "x = a", rule_tac x = "l" in exI, simp add: move_graph_a_def nodes_def atI_def,
      rule_tac x = ya in exI, rule conjI, simp add: move_graph_a_def nodes_def atI_def,
      (erule conjE)+, simp add: move_graph_a_def, case_tac "ya = l", simp,
      case_tac "a \<in> set (agra (graphI I) l) \<and> a \<notin> set (agra (graphI I) l')", simp,
      case_tac "l = l'", simp+, erule del_up, simp,
      case_tac "a \<in> set (agra (graphI I) l) \<and> a \<notin> set (agra (graphI I) l')", simp,
      case_tac "ya = l'", simp+)
qed
qed

lemma same_actors: "(I, y) \<in> {(x::infrastructure, y::infrastructure). x \<rightarrow>\<^sub>n y}\<^sup>*
              \<Longrightarrow> actors_graph(graphI I) = actors_graph(graphI y)"
proof (erule rtrancl_induct)
  show "actors_graph (graphI I) = actors_graph (graphI I)"
    by (rule refl)
next show "\<And>(y::infrastructure) z::infrastructure.
       (I, y) \<in> {(x::infrastructure, y::infrastructure). x \<rightarrow>\<^sub>n y}\<^sup>* \<Longrightarrow>
       (y, z) \<in> {(x::infrastructure, y::infrastructure). x \<rightarrow>\<^sub>n y} \<Longrightarrow>
       actors_graph (graphI I) = actors_graph (graphI y) \<Longrightarrow>
       actors_graph (graphI I) = actors_graph (graphI z)"
    by (drule CollectD, simp, drule same_actors0, simp)
qed

end
end


(*
    This file is a part of IsarMathLib -
    a library of formalized mathematics for Isabelle/Isar.

    Copyright (C) 2011, 2012  Slawomir Kolodynski

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

   1. Redistributions of source code must retain the above copyright notice,
   this list of conditions and the following disclaimer.
   2. 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.
   3. The name of the author may not be used to endorse or promote products
   derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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.

*)

section \<open>Topology 3\<close>

theory Topology_ZF_3 imports Topology_ZF_2 FiniteSeq_ZF

begin

text\<open>\<open>Topology_ZF_1\<close> theory describes how we can define  a topology on a product
of two topological spaces. One way to generalize that is to construct topology for a cartesian
product of $n$ topological spaces. The cartesian product approach is somewhat inconvenient though.
Another way to approach product topology on $X^n$ is to model cartesian product as sets of
sequences (of length $n$) of elements of $X$. This means that having a topology on $X$ we want
to define a toplogy on the space $n\rightarrow X$, where $n$ is a natural number (recall that
$n = \{ 0,1,...,n-1\}$ in ZF). However, this in turn can be done more generally by defining a
topology on any function space $I\rightarrow X$, where $I$ is any set of indices. This is what we
do in this theory.\<close>

subsection\<open>The base of the product topology\<close>

text\<open>In this section we define the base of the product topology.\<close>

text\<open>Suppose $\mathcal{X} = I\rightarrow \bigcup T$ is a space of functions from some index set $I$
to the carrier of a topology $T$. Then take a finite collection of open sets $W:N\rightarrow T$
indexed by $N\subseteq I$. We can define a subset of $\mathcal{X}$ that models the cartesian product of $W$.
\<close>

definition
  "FinProd(\<X>,W) \<equiv> {x\<in>\<X>. \<forall> i\<in>domain(W). x`(i) \<in> W`(i)}"

text\<open>Now we define the base of the product topology as the collection of all finite products
(in the sense defined above) of open sets.
\<close>

definition
  "ProductTopBase(I,T) \<equiv>  \<Union>N\<in>FinPow(I).{FinProd(I\<rightarrow>\<Union>T,W). W\<in>N\<rightarrow>T}"

text\<open>Finally, we define the product topology on sequences. We use the ''Seq''
prefix although the definition is good for any index sets, not only natural numbers.\<close>

definition
  "SeqProductTopology(I,T) \<equiv> {\<Union>B. B \<in> Pow(ProductTopBase(I,T))}"

text\<open>Product topology base is closed with respect to intersections.\<close>

lemma prod_top_base_inter:
  assumes A1: "T {is a topology}" and
  A2: "U \<in> ProductTopBase(I,T)"  "V \<in> ProductTopBase(I,T)"
  shows "U\<inter>V \<in> ProductTopBase(I,T)"
proof -
  let ?\<X> = "I\<rightarrow>\<Union>T"
  from A2 obtain N\<^sub>1  W\<^sub>1 N\<^sub>2 W\<^sub>2 where
    I: "N\<^sub>1 \<in> FinPow(I)"  "W\<^sub>1\<in>N\<^sub>1\<rightarrow>T"  "U = FinProd(?\<X>,W\<^sub>1)" and
    II: "N\<^sub>2 \<in> FinPow(I)"  "W\<^sub>2\<in>N\<^sub>2\<rightarrow>T"  "V = FinProd(?\<X>,W\<^sub>2)"
    using ProductTopBase_def by auto
  let ?N\<^sub>3 = "N\<^sub>1 \<union> N\<^sub>2"
  let ?W\<^sub>3 = "{\<langle>i,if i \<in> N\<^sub>1-N\<^sub>2 then W\<^sub>1`(i)
        else if i \<in> N\<^sub>2-N\<^sub>1 then  W\<^sub>2`(i)
        else (W\<^sub>1`(i)) \<inter> (W\<^sub>2`(i))\<rangle>. i \<in> ?N\<^sub>3}"
  from A1 I II have "\<forall>i \<in> N\<^sub>1 \<inter> N\<^sub>2.  (W\<^sub>1`(i) \<inter> W\<^sub>2`(i)) \<in> T"
      using apply_funtype IsATopology_def by auto
  moreover from I II have "\<forall>i\<in>N\<^sub>1-N\<^sub>2. W\<^sub>1`(i) \<in> T" and "\<forall>i\<in>N\<^sub>2-N\<^sub>1. W\<^sub>2`(i) \<in> T"
      using apply_funtype by auto
  ultimately have  "?W\<^sub>3:?N\<^sub>3\<rightarrow>T" by (rule fun_union_overlap)
  with I II have "FinProd(?\<X>,?W\<^sub>3) \<in> ProductTopBase(I,T)" using union_finpow ProductTopBase_def
    by auto
  moreover have "U\<inter>V = FinProd(?\<X>,?W\<^sub>3)"
  proof
    { fix x assume "x\<in>U" and "x\<in>V"
      with \<open>U = FinProd(?\<X>,W\<^sub>1)\<close>  \<open>W\<^sub>1\<in>N\<^sub>1\<rightarrow>T\<close> and  \<open>V = FinProd(?\<X>,W\<^sub>2)\<close>  \<open>W\<^sub>2\<in>N\<^sub>2\<rightarrow>T\<close>
      have "x\<in>?\<X>" and "\<forall>i\<in>N\<^sub>1. x`(i) \<in> W\<^sub>1`(i)" and "\<forall>i\<in>N\<^sub>2. x`(i) \<in> W\<^sub>2`(i)"
        using func1_1_L1 FinProd_def by auto
      with \<open>?W\<^sub>3:?N\<^sub>3\<rightarrow>T\<close> \<open>x\<in>?\<X>\<close> have "x \<in> FinProd(?\<X>,?W\<^sub>3)"
        using ZF_fun_from_tot_val func1_1_L1 FinProd_def by auto
    } thus "U\<inter>V \<subseteq> FinProd(?\<X>,?W\<^sub>3)" by auto
    { fix x assume "x \<in> FinProd(?\<X>,?W\<^sub>3)"
      with \<open>?W\<^sub>3:?N\<^sub>3\<rightarrow>T\<close> have "x:I\<rightarrow>\<Union>T" and III: "\<forall>i\<in>?N\<^sub>3. x`(i) \<in> ?W\<^sub>3`(i)"
        using FinProd_def func1_1_L1 by auto
     { fix i assume "i\<in>N\<^sub>1"
       with \<open>?W\<^sub>3:?N\<^sub>3\<rightarrow>T\<close> have "?W\<^sub>3`(i) \<subseteq> W\<^sub>1`(i)" using ZF_fun_from_tot_val by auto
       with III \<open>i\<in>N\<^sub>1\<close> have "x`(i) \<in> W\<^sub>1`(i)" by auto
     } with \<open>W\<^sub>1\<in>N\<^sub>1\<rightarrow>T\<close> \<open>x:I\<rightarrow>\<Union>T\<close> \<open>U = FinProd(?\<X>,W\<^sub>1)\<close>
      have "x \<in> U" using func1_1_L1 FinProd_def by auto
      moreover
      { fix i assume "i\<in>N\<^sub>2"
        with \<open>?W\<^sub>3:?N\<^sub>3\<rightarrow>T\<close> have "?W\<^sub>3`(i) \<subseteq> W\<^sub>2`(i)" using ZF_fun_from_tot_val by auto
        with III \<open>i\<in>N\<^sub>2\<close> have "x`(i) \<in> W\<^sub>2`(i)" by auto
      } with \<open>W\<^sub>2\<in>N\<^sub>2\<rightarrow>T\<close> \<open>x:I\<rightarrow>\<Union>T\<close> \<open>V = FinProd(?\<X>,W\<^sub>2)\<close> have "x\<in>V"
          using func1_1_L1 FinProd_def by auto
      ultimately have "x \<in> U\<inter>V" by simp
    } thus "FinProd(?\<X>,?W\<^sub>3) \<subseteq> U\<inter>V" by auto
  qed
    ultimately show ?thesis by simp
qed

text\<open>In the next theorem we show the collection of sets defined above as
\<open>ProductTopBase(\<X>,T)\<close> satisfies the base condition. This is a condition, defined in
\<open>Topology_ZF_1\<close> that allows to claim that this collection is a base for some topology.\<close>

theorem prod_top_base_is_base: assumes "T {is a topology}"
  shows "ProductTopBase(I,T) {satisfies the base condition}"
  using assms prod_top_base_inter inter_closed_base by simp

text\<open>The (sequence) product topology is indeed a topology on the space of sequences.
In the proof we are using the fact that $(\emptyset\rightarrow X) = \{\emptyset\}$.\<close>

theorem seq_prod_top_is_top:  assumes "T {is a topology}"
  shows
  "SeqProductTopology(I,T) {is a topology}" and
  "ProductTopBase(I,T) {is a base for} SeqProductTopology(I,T)" and
  "\<Union>SeqProductTopology(I,T) = (I\<rightarrow>\<Union>T)"
proof -
  from assms show "SeqProductTopology(I,T) {is a topology}" and
    I: "ProductTopBase(I,T) {is a base for} SeqProductTopology(I,T)"
      using prod_top_base_is_base SeqProductTopology_def Top_1_2_T1
        by auto
  from I have "\<Union>SeqProductTopology(I,T) = \<Union>ProductTopBase(I,T)"
    using Top_1_2_L5 by simp
  also have "\<Union>ProductTopBase(I,T) = (I\<rightarrow>\<Union>T)"
  proof
    show "\<Union>ProductTopBase(I,T) \<subseteq> (I\<rightarrow>\<Union>T)" using ProductTopBase_def FinProd_def
      by auto
    have "0 \<in> FinPow(I)" using empty_in_finpow by simp
    hence "{FinProd(I\<rightarrow>\<Union>T,W). W\<in>0\<rightarrow>T} \<subseteq> (\<Union>N\<in>FinPow(I).{FinProd(I\<rightarrow>\<Union>T,W). W\<in>N\<rightarrow>T})"
      by blast
    then show "(I\<rightarrow>\<Union>T) \<subseteq> \<Union>ProductTopBase(I,T)" using ProductTopBase_def FinProd_def
      by auto
  qed
  finally show "\<Union>SeqProductTopology(I,T) = (I\<rightarrow>\<Union>T)" by simp
qed

subsection\<open>Finite product of topologies\<close>

text\<open>As a special case of the space of functions $I\rightarrow X$ we can consider space of lists
of elements of $X$, i.e. space $n\rightarrow X$, where $n$ is a natural number (recall that in ZF
set theory $n=\{0,1,...,n-1\}$). Such spaces model finite cartesian products $X^n$
but are easier to deal with in formalized way (than the said products).
This section discusses natural topology defined on $n\rightarrow X$ where $X$ is a topological space.
\<close>

text\<open>When the index set is finite, the definition of \<open>ProductTopBase(I,T)\<close>
can be simplifed.\<close>

lemma fin_prod_def_nat: assumes A1: "n\<in>nat" and A2: "T {is a topology}"
  shows "ProductTopBase(n,T) = {FinProd(n\<rightarrow>\<Union>T,W). W\<in>n\<rightarrow>T}"
proof
  from A1 have "n \<in> FinPow(n)" using nat_finpow_nat fin_finpow_self by auto
  then show "{FinProd(n\<rightarrow>\<Union>T,W). W\<in>n\<rightarrow>T} \<subseteq> ProductTopBase(n,T)" using ProductTopBase_def
    by auto
  { fix B assume "B \<in> ProductTopBase(n,T)"
    then obtain N W where  "N \<in> FinPow(n)" and "W \<in> N\<rightarrow>T" and "B = FinProd(n\<rightarrow>\<Union>T,W)"
      using ProductTopBase_def by auto
    let ?W\<^sub>n = "{\<langle>i,if i\<in>N then W`(i) else \<Union>T\<rangle>. i\<in>n}"
    from A2  \<open>N \<in> FinPow(n)\<close>  \<open>W\<in>N\<rightarrow>T\<close> have "\<forall>i\<in>n. (if i\<in>N then W`(i) else \<Union>T) \<in> T"
      using apply_funtype FinPow_def IsATopology_def by auto
    then have "?W\<^sub>n:n\<rightarrow>T" by (rule ZF_fun_from_total)
    moreover have "B = FinProd(n\<rightarrow>\<Union>T,?W\<^sub>n)"
    proof
      { fix x assume "x\<in>B"
        with \<open>B = FinProd(n\<rightarrow>\<Union>T,W)\<close> have "x \<in> n\<rightarrow>\<Union>T" using FinProd_def by simp
        moreover have "\<forall>i\<in>domain(?W\<^sub>n). x`(i) \<in> ?W\<^sub>n`(i)"
        proof
          fix i assume "i \<in> domain(?W\<^sub>n)"
          with \<open>?W\<^sub>n:n\<rightarrow>T\<close> have "i\<in>n" using func1_1_L1 by simp
          with \<open>x:n\<rightarrow>\<Union>T\<close> have "x`(i) \<in> \<Union>T" using apply_funtype by blast
          with \<open>x\<in>B\<close> \<open>B = FinProd(n\<rightarrow>\<Union>T,W)\<close> \<open>W \<in> N\<rightarrow>T\<close> \<open>?W\<^sub>n:n\<rightarrow>T\<close> \<open>i\<in>n\<close>
          show "x`(i) \<in> ?W\<^sub>n`(i)" using func1_1_L1 FinProd_def ZF_fun_from_tot_val
            by simp
        qed
        ultimately have "x \<in> FinProd(n\<rightarrow>\<Union>T,?W\<^sub>n)" using FinProd_def by simp
      } thus "B \<subseteq> FinProd(n\<rightarrow>\<Union>T,?W\<^sub>n)" by auto
      next
      { fix x assume "x \<in> FinProd(n\<rightarrow>\<Union>T,?W\<^sub>n)"
        then have "x \<in> n\<rightarrow>\<Union>T" and "\<forall>i\<in>domain(?W\<^sub>n). x`(i) \<in> ?W\<^sub>n`(i)"
          using  FinProd_def by auto
        with \<open>?W\<^sub>n:n\<rightarrow>T\<close> and \<open>N \<in> FinPow(n)\<close> have "\<forall>i\<in>N. x`(i) \<in> ?W\<^sub>n`(i)"
          using func1_1_L1 FinPow_def by auto
        moreover from \<open>?W\<^sub>n:n\<rightarrow>T\<close> and \<open>N \<in> FinPow(n)\<close>
        have "\<forall>i\<in>N. ?W\<^sub>n`(i) = W`(i)"
          using ZF_fun_from_tot_val FinPow_def by auto
        ultimately have "\<forall>i\<in>N. x`(i) \<in> W`(i)" by simp
        with \<open>W \<in> N\<rightarrow>T\<close> \<open>x \<in> n\<rightarrow>\<Union>T\<close> \<open>B = FinProd(n\<rightarrow>\<Union>T,W)\<close> have "x\<in>B"
          using func1_1_L1 FinProd_def by simp
     } thus "FinProd(n\<rightarrow>\<Union>T,?W\<^sub>n) \<subseteq> B" by auto
  qed
    ultimately have "B \<in> {FinProd(n\<rightarrow>\<Union>T,W). W\<in>n\<rightarrow>T}" by auto
  } thus "ProductTopBase(n,T) \<subseteq> {FinProd(n\<rightarrow>\<Union>T,W). W\<in>n\<rightarrow>T}" by auto
qed

text\<open>A technical lemma providing a formula for finite product on one topological space.\<close>

lemma single_top_prod: assumes A1: "W:1\<rightarrow>\<tau>"
  shows "FinProd(1\<rightarrow>\<Union>\<tau>,W) = { {\<langle>0,y\<rangle>}. y \<in> W`(0)}"
proof -
  have "1 = {0}" by auto
  from A1 have "domain(W) = {0}" using func1_1_L1 by auto
  then have "FinProd(1\<rightarrow>\<Union>\<tau>,W) = {x \<in> 1\<rightarrow>\<Union>\<tau>. x`(0) \<in> W`(0)}"
    using FinProd_def by simp
  also have "{x \<in> 1\<rightarrow>\<Union>\<tau>. x`(0) \<in> W`(0)} = { {\<langle>0,y\<rangle>}. y \<in> W`(0)}"
  proof
    from \<open>1 = {0}\<close> show "{x \<in> 1\<rightarrow>\<Union>\<tau>. x`(0) \<in> W`(0)} \<subseteq> { {\<langle>0,y\<rangle>}. y \<in> W`(0)}"
      using func_singleton_pair by auto
    { fix x assume "x \<in> { {\<langle>0,y\<rangle>}. y \<in> W`(0)}"
      then obtain y where "x = {\<langle>0,y\<rangle>}" and II: "y \<in> W`(0)" by auto
      with A1 have "y \<in> \<Union>\<tau>" using apply_funtype by auto
      with \<open>x = {\<langle>0,y\<rangle>}\<close>  \<open>1 = {0}\<close> have "x:1\<rightarrow>\<Union>\<tau>" using pair_func_singleton
        by auto
      with \<open>x = {\<langle>0,y\<rangle>}\<close> II have "x \<in> {x \<in> 1\<rightarrow>\<Union>\<tau>. x`(0) \<in> W`(0)}"
        using pair_val by simp
    } thus "{ {\<langle>0,y\<rangle>}. y \<in> W`(0)} \<subseteq> {x \<in> 1\<rightarrow>\<Union>\<tau>. x`(0) \<in> W`(0)}" by auto
  qed
  finally show ?thesis by simp
qed

text\<open>Intuitively, the topological space of singleton lists valued in $X$
  is the same as $X$. However, each element of this space is a list of length one,
  i.e a set consisting of a pair $\langle 0, x\rangle$ where $x$ is an element of $X$.
  The next lemma provides a formula for the product topology in the corner case when we have
  only one factor and shows that the product topology of one space is essentially the same as
  the space.\<close>

lemma singleton_prod_top: assumes A1: "\<tau> {is a topology}"
  shows
    "SeqProductTopology(1,\<tau>) = { { {\<langle>0,y\<rangle>}. y\<in>U }. U\<in>\<tau>}" and
    "IsAhomeomorphism(\<tau>,SeqProductTopology(1,\<tau>),{\<langle>y,{\<langle>0,y\<rangle>}\<rangle>.y \<in> \<Union>\<tau>})"
proof -
  have "{0} = 1" by auto
  let ?b = "{\<langle>y,{\<langle>0,y\<rangle>}\<rangle>.y \<in> \<Union>\<tau>}"
  have "?b \<in> bij(\<Union>\<tau>,1\<rightarrow>\<Union>\<tau>)" using list_singleton_bij by blast
  with A1 have "{?b``(U). U\<in>\<tau>} {is a topology}" and "IsAhomeomorphism(\<tau>, {?b``(U). U\<in>\<tau>},?b)"
    using bij_induced_top by auto
  moreover have "\<forall>U\<in>\<tau>. ?b``(U) = { {\<langle>0,y\<rangle>}. y\<in>U }"
  proof
    fix U assume "U\<in>\<tau>"
    from \<open>?b \<in> bij(\<Union>\<tau>,1\<rightarrow>\<Union>\<tau>)\<close> have "?b:\<Union>\<tau>\<rightarrow>(1\<rightarrow>\<Union>\<tau>)" using bij_def inj_def
      by simp
    { fix y assume "y \<in> \<Union>\<tau>"
      with \<open>?b:\<Union>\<tau>\<rightarrow>(1\<rightarrow>\<Union>\<tau>)\<close> have "?b`(y) = {\<langle>0,y\<rangle>}" using ZF_fun_from_tot_val
        by simp
    } hence "\<forall>y \<in> \<Union>\<tau>. ?b`(y) = {\<langle>0,y\<rangle>}" by auto
    with  \<open>U\<in>\<tau>\<close> \<open>?b:\<Union>\<tau>\<rightarrow>(1\<rightarrow>\<Union>\<tau>)\<close> show " ?b``(U) = { {\<langle>0,y\<rangle>}. y\<in>U }"
      using func_imagedef by auto
  qed
  moreover have "ProductTopBase(1,\<tau>) = { { {\<langle>0,y\<rangle>}. y\<in>U }. U\<in>\<tau>}"
  proof
    { fix V assume "V \<in> ProductTopBase(1,\<tau>)"
      with A1 obtain W where "W:1\<rightarrow>\<tau>" and "V = FinProd(1\<rightarrow>\<Union>\<tau>,W)"
        using fin_prod_def_nat by auto
      then have "V \<in> { { {\<langle>0,y\<rangle>}. y\<in>U }. U\<in>\<tau>}" using apply_funtype single_top_prod
        by auto
    } thus "ProductTopBase(1,\<tau>) \<subseteq> { { {\<langle>0,y\<rangle>}. y\<in>U }. U\<in>\<tau>}" by auto
  { fix V assume "V \<in> { { {\<langle>0,y\<rangle>}. y\<in>U }. U\<in>\<tau>}"
    then obtain U where "U\<in>\<tau>" and "V = { {\<langle>0,y\<rangle>}. y\<in>U }" by auto
    let ?W = "{\<langle>0,U\<rangle>}"
    from \<open>U\<in>\<tau>\<close> have "?W:{0}\<rightarrow>\<tau>" using pair_func_singleton by simp
    with \<open>{0} = 1\<close> have "?W:1\<rightarrow>\<tau>" and "?W`(0) = U" using pair_val by auto
    with \<open>V = { {\<langle>0,y\<rangle>}. y\<in>U }\<close> have "V = FinProd(1\<rightarrow>\<Union>\<tau>,?W)"
      using single_top_prod by simp
    with A1 \<open>?W:1\<rightarrow>\<tau>\<close> have "V \<in> ProductTopBase(1,\<tau>)" using fin_prod_def_nat
      by auto
   } thus "{ { {\<langle>0,y\<rangle>}. y\<in>U }. U\<in>\<tau>} \<subseteq> ProductTopBase(1,\<tau>)" by auto
  qed
  ultimately have I: "ProductTopBase(1,\<tau>) {is a topology}" and
    II: "IsAhomeomorphism(\<tau>, ProductTopBase(1,\<tau>),?b)" by auto
  from A1 have "ProductTopBase(1,\<tau>) {is a base for} SeqProductTopology(1,\<tau>)"
    using seq_prod_top_is_top by simp
  with I have "ProductTopBase(1,\<tau>) = SeqProductTopology(1,\<tau>)" by (rule base_topology)
  with \<open>ProductTopBase(1,\<tau>) = { { {\<langle>0,y\<rangle>}. y\<in>U }. U\<in>\<tau>}\<close> II show
    "SeqProductTopology(1,\<tau>) = { { {\<langle>0,y\<rangle>}. y\<in>U }. U\<in>\<tau>}" and
    "IsAhomeomorphism(\<tau>,SeqProductTopology(1,\<tau>),{\<langle>y,{\<langle>0,y\<rangle>}\<rangle>.y \<in> \<Union>\<tau>})" by auto
qed

text\<open>A special corner case of \<open>finite_top_prod_homeo\<close>: a space $X$
  is homeomorphic to the space of one element lists of $X$.\<close>

theorem singleton_prod_top1: assumes A1: "\<tau> {is a topology}"
  shows "IsAhomeomorphism(SeqProductTopology(1,\<tau>),\<tau>,{\<langle>x,x`(0)\<rangle>. x\<in>1\<rightarrow>\<Union>\<tau>})"
proof -
  have "{\<langle>x,x`(0)\<rangle>. x\<in>1\<rightarrow>\<Union>\<tau>} = converse({\<langle>y,{\<langle>0,y\<rangle>}\<rangle>.y\<in>\<Union>\<tau>})"
    using list_singleton_bij by blast
  with A1 show ?thesis using singleton_prod_top homeo_inv by simp
qed

text\<open>A technical lemma describing the carrier of a (cartesian) product topology of
the (sequence) product topology of $n$ copies of topology $\tau$ and another
copy of $\tau$.\<close>

lemma finite_prod_top: assumes "\<tau> {is a topology}" and  "T = SeqProductTopology(n,\<tau>)"
  shows "(\<Union>ProductTopology(T,\<tau>)) = (n\<rightarrow>\<Union>\<tau>)\<times>\<Union>\<tau>"
  using assms Top_1_4_T1 seq_prod_top_is_top by simp

text\<open>If $U$ is a set from the base of $X^n$ and $V$ is open in $X$, then $U\times V$
is in the base of $X^{n+1}$. The next lemma is an analogue of this fact for the
function space approach.\<close>

lemma finite_prod_succ_base: assumes A1: "\<tau> {is a topology}" and A2: "n \<in> nat" and
  A3: "U \<in> ProductTopBase(n,\<tau>)" and A4: "V\<in>\<tau>"
  shows "{x \<in> succ(n)\<rightarrow>\<Union>\<tau>. Init(x) \<in> U \<and> x`(n) \<in> V} \<in> ProductTopBase(succ(n),\<tau>)"
  proof -
    let ?B = "{x \<in> succ(n)\<rightarrow>\<Union>\<tau>. Init(x) \<in> U \<and> x`(n) \<in> V}"
    from A1 A2 have "ProductTopBase(n,\<tau>) = {FinProd(n\<rightarrow>\<Union>\<tau>,W). W\<in>n\<rightarrow>\<tau>}"
      using fin_prod_def_nat by simp
    with A3 obtain W\<^sub>U where "W\<^sub>U:n\<rightarrow>\<tau>" and "U =FinProd(n\<rightarrow>\<Union>\<tau>,W\<^sub>U)" by auto
    let ?W = "Append(W\<^sub>U,V)"
    from A4 and \<open>W\<^sub>U:n\<rightarrow>\<tau>\<close> have "?W:succ(n)\<rightarrow>\<tau>" using append_props by simp
    moreover have "?B = FinProd(succ(n)\<rightarrow>\<Union>\<tau>,?W)"
    proof
      { fix x assume "x\<in>?B"
        with \<open>?W:succ(n)\<rightarrow>\<tau>\<close> have "x \<in> succ(n)\<rightarrow>\<Union>\<tau>" and "domain(?W) = succ(n)" using func1_1_L1
          by auto
        moreover from A2 A4 \<open>x\<in>?B\<close> \<open>U =FinProd(n\<rightarrow>\<Union>\<tau>,W\<^sub>U)\<close> \<open>W\<^sub>U:n\<rightarrow>\<tau>\<close> \<open>x \<in> succ(n)\<rightarrow>\<Union>\<tau>\<close>
        have "\<forall>i\<in>succ(n). x`(i) \<in> ?W`(i)" using func1_1_L1 FinProd_def init_props append_props
          by simp
        ultimately have "x \<in> FinProd(succ(n)\<rightarrow>\<Union>\<tau>,?W)" using FinProd_def by simp
      } thus "?B \<subseteq> FinProd(succ(n)\<rightarrow>\<Union>\<tau>,?W)" by auto
      next
      { fix x assume "x \<in> FinProd(succ(n)\<rightarrow>\<Union>\<tau>,?W)"
        then have "x:succ(n)\<rightarrow>\<Union>\<tau>" and I: "\<forall>i \<in> domain(?W). x`(i) \<in> ?W`(i)"
          using FinProd_def by auto
        moreover have "Init(x) \<in> U"
        proof -
          from A2 and \<open>x:succ(n)\<rightarrow>\<Union>\<tau>\<close> have "Init(x):n\<rightarrow>\<Union>\<tau>" using init_props by simp
          moreover have "\<forall>i\<in>domain(W\<^sub>U). Init(x)`(i) \<in> W\<^sub>U`(i)"
          proof -
            from A2 \<open>x \<in> FinProd(succ(n)\<rightarrow>\<Union>\<tau>,?W)\<close> \<open>?W:succ(n)\<rightarrow>\<tau>\<close> have "\<forall>i\<in>n. x`(i) \<in> ?W`(i)"
              using FinProd_def func1_1_L1 by simp
            moreover from A2 \<open>x: succ(n)\<rightarrow>\<Union>\<tau>\<close> have "\<forall>i\<in>n. Init(x)`(i) = x`(i)"
              using init_props by simp
            moreover from A4 and \<open>W\<^sub>U:n\<rightarrow>\<tau>\<close> have "\<forall>i\<in>n. ?W`(i) =  W\<^sub>U`(i)"
              using append_props by simp
            ultimately have "\<forall>i\<in>n. Init(x)`(i) \<in> W\<^sub>U`(i)" by simp
            with \<open>W\<^sub>U:n\<rightarrow>\<tau>\<close> show ?thesis using func1_1_L1 by simp
          qed
          ultimately have "Init(x) \<in> FinProd(n\<rightarrow>\<Union>\<tau>,W\<^sub>U)" using FinProd_def by simp
          with \<open>U =FinProd(n\<rightarrow>\<Union>\<tau>,W\<^sub>U)\<close> show ?thesis by simp
        qed
        moreover have "x`(n) \<in> V"
        proof -
          from \<open>?W:succ(n)\<rightarrow>\<tau>\<close> I  have "x`(n) \<in> ?W`(n)" using func1_1_L1 by simp
          moreover from A4 \<open>W\<^sub>U:n\<rightarrow>\<tau>\<close> have "?W`(n) = V" using append_props by simp
          ultimately show ?thesis by simp
        qed
        ultimately have "x\<in>?B" by simp
      } thus "FinProd(succ(n)\<rightarrow>\<Union>\<tau>,?W) \<subseteq> ?B" by auto
    qed
    moreover from A1 A2 have
      "ProductTopBase(succ(n),\<tau>) = {FinProd(succ(n)\<rightarrow>\<Union>\<tau>,W). W\<in>succ(n)\<rightarrow>\<tau>}"
      using fin_prod_def_nat by simp
    ultimately show ?thesis by auto
 qed

text\<open>If $U$ is open in $X^n$ and $V$ is open in $X$, then $U\times V$ is open in $X^{n+1}$.
The next lemma is an analogue of this fact for the function space approach.\<close>

lemma finite_prod_succ: assumes A1: "\<tau> {is a topology}" and A2: "n \<in> nat" and
  A3: "U \<in> SeqProductTopology(n,\<tau>)" and A4: "V\<in>\<tau>"
  shows "{x \<in> succ(n)\<rightarrow>\<Union>\<tau>. Init(x) \<in> U \<and> x`(n) \<in> V} \<in> SeqProductTopology(succ(n),\<tau>)"
  proof -
     from A1 have "ProductTopBase(n,\<tau>) {is a base for} SeqProductTopology(n,\<tau>)" and
      I: "ProductTopBase(succ(n),\<tau>) {is a base for} SeqProductTopology(succ(n),\<tau>)" and
      II: "SeqProductTopology(succ(n),\<tau>) {is a topology}"
        using seq_prod_top_is_top by auto
    with A3 have "\<exists>\<B> \<in> Pow(ProductTopBase(n,\<tau>)). U = \<Union>\<B>" using Top_1_2_L1 by simp
    then obtain \<B> where "\<B> \<subseteq> ProductTopBase(n,\<tau>)" and "U = \<Union>\<B>" by auto
    then have
    "{x:succ(n)\<rightarrow>\<Union>\<tau>. Init(x) \<in> U \<and> x`(n) \<in> V} = (\<Union>B\<in>\<B>.{x:succ(n)\<rightarrow>\<Union>\<tau>. Init(x) \<in> B \<and> x`(n) \<in> V})"
      by auto
    moreover from A1 A2 A4 \<open>\<B> \<subseteq> ProductTopBase(n,\<tau>)\<close> have
      "\<forall>B\<in>\<B>. ({x:succ(n)\<rightarrow>\<Union>\<tau>. Init(x) \<in> B \<and> x`(n) \<in> V} \<in> ProductTopBase(succ(n),\<tau>))"
      using finite_prod_succ_base by auto
    with I II have
      "(\<Union>B\<in>\<B>.{x:succ(n)\<rightarrow>\<Union>\<tau>. Init(x) \<in> B \<and> x`(n) \<in> V}) \<in> SeqProductTopology(succ(n),\<tau>)"
      using base_sets_open union_indexed_open by auto
    ultimately show ?thesis by simp
  qed

text\<open>In the \<open>Topology_ZF_2\<close> theory we define product topology of two topological spaces.
The next lemma explains in what sense the topology on finite lists of length $n$ of
elements of topological space $X$ can be thought as a model of the product topology on the cartesian
product of $n$ copies of that space. Namely, we show that the space of lists of length $n+1$
of elements of $X$  is homeomorphic to the product topology (as defined in \<open>Topology_ZF_2\<close>)
of two spaces: the space of lists of length $n$ and $X$. Recall that if $\mathcal{B}$ is a base
(i.e. satisfies the base condition), then the collection $\{\bigcup B| B \in Pow(\mathcal{B})\}$
is a topology (generated by $\mathcal{B}$).\<close>

theorem finite_top_prod_homeo: assumes A1: "\<tau> {is a topology}" and A2: "n \<in> nat" and
  A3: "f = {\<langle>x,\<langle>Init(x),x`(n)\<rangle>\<rangle>. x \<in> succ(n)\<rightarrow>\<Union>\<tau>}" and
  A4: "T = SeqProductTopology(n,\<tau>)" and
  A5: "S = SeqProductTopology(succ(n),\<tau>)"
shows "IsAhomeomorphism(S,ProductTopology(T,\<tau>),f)"
proof -
  let ?C = "ProductCollection(T,\<tau>)"
  let ?B = "ProductTopBase(succ(n),\<tau>)"
  from A1 A4 have "T {is a topology}" using seq_prod_top_is_top by simp
  with A1 A5  have "S {is a topology}" and " ProductTopology(T,\<tau>) {is a topology}"
        using seq_prod_top_is_top  Top_1_4_T1 by auto
  moreover
  from assms have "f \<in> bij(\<Union>S,\<Union>ProductTopology(T,\<tau>))"
    using lists_cart_prod seq_prod_top_is_top Top_1_4_T1 by simp
  then have "f: \<Union>S\<rightarrow>\<Union>ProductTopology(T,\<tau>)" using bij_is_fun by simp
  ultimately have "two_top_spaces0(S,ProductTopology(T,\<tau>),f)" using two_top_spaces0_def by simp
  moreover note \<open>f \<in> bij(\<Union>S,\<Union>ProductTopology(T,\<tau>))\<close>
  moreover from A1 A5 have "?B {is a base for} S"
    using seq_prod_top_is_top by simp
  moreover from A1 \<open>T {is a topology}\<close> have "?C {is a base for} ProductTopology(T,\<tau>)"
    using Top_1_4_T1 by auto
  moreover have  "\<forall>W\<in>?C. f-``(W) \<in> S"
  proof
      fix W assume "W\<in>?C"
      then obtain U V where "U\<in>T" "V\<in>\<tau>" and "W = U\<times>V" using ProductCollection_def by auto
      from A1 A5 \<open>f: \<Union>S\<rightarrow>\<Union>ProductTopology(T,\<tau>)\<close> have "f: (succ(n)\<rightarrow>\<Union>\<tau>)\<rightarrow>\<Union>ProductTopology(T,\<tau>)"
        using seq_prod_top_is_top by simp
      with assms \<open>W = U\<times>V\<close> \<open>U\<in>T\<close> \<open>V\<in>\<tau>\<close> show "f-``(W) \<in> S"
        using ZF_fun_from_tot_val func1_1_L15 finite_prod_succ by simp
  qed
  moreover have "\<forall>V\<in>?B. f``(V) \<in> ProductTopology(T,\<tau>)"
  proof
    fix V assume "V\<in>?B"
    with A1 A2 obtain W\<^sub>V where "W\<^sub>V \<in> succ(n)\<rightarrow>\<tau>" and "V = FinProd(succ(n)\<rightarrow>\<Union>\<tau>,W\<^sub>V)"
      using fin_prod_def_nat by auto
    let ?U = "FinProd(n\<rightarrow>\<Union>\<tau>,Init(W\<^sub>V))"
    let ?W = "W\<^sub>V`(n)"
    have "?U \<in> T"
    proof -
      from A1 A2 \<open>W\<^sub>V \<in> succ(n)\<rightarrow>\<tau>\<close> have "?U \<in> ProductTopBase(n,\<tau>)"
        using fin_prod_def_nat init_props by auto
      with A1 A4 show ?thesis using seq_prod_top_is_top base_sets_open by blast
    qed
    from A1 \<open>W\<^sub>V \<in> succ(n)\<rightarrow>\<tau>\<close> \<open>T {is a topology}\<close> \<open>?U \<in> T\<close> have "?U\<times>?W \<in> ProductTopology(T,\<tau>)"
      using apply_funtype prod_open_open_prod by simp
    moreover have "f``(V) = ?U\<times>?W"
    proof -
      from A2 \<open>W\<^sub>V: succ(n)\<rightarrow>\<tau>\<close> have "Init(W\<^sub>V): n\<rightarrow>\<tau>" and III: "\<forall>k\<in>n. Init(W\<^sub>V)`(k) = W\<^sub>V`(k)"
        using init_props by auto
      then have "domain(Init(W\<^sub>V)) = n" using func1_1_L1 by simp
      have "f``(V) = {\<langle>Init(x),x`(n)\<rangle>. x\<in>V}"
      proof -
        have "f``(V) = {f`(x). x\<in>V}"
        proof -
          from A1 A5 have "?B {is a base for} S" using seq_prod_top_is_top by simp
          with \<open>V\<in>?B\<close> have "V \<subseteq> \<Union>S" using IsAbaseFor_def by auto
          with \<open>f: \<Union>S\<rightarrow>\<Union>ProductTopology(T,\<tau>)\<close> show ?thesis using func_imagedef by simp
        qed
        moreover have "\<forall>x\<in>V. f`(x) = \<langle>Init(x),x`(n)\<rangle>"
        proof -
          from A1 A3 A5 \<open>V = FinProd(succ(n)\<rightarrow>\<Union>\<tau>,W\<^sub>V)\<close> have "V \<subseteq> \<Union>S" and
            fdef: "f = {\<langle>x,\<langle>Init(x),x`(n)\<rangle>\<rangle>. x \<in> \<Union>S}" using seq_prod_top_is_top FinProd_def
            by auto
          from \<open>f: \<Union>S\<rightarrow>\<Union>ProductTopology(T,\<tau>)\<close> fdef have "\<forall>x \<in> \<Union>S. f`(x) = \<langle>Init(x),x`(n)\<rangle>"
            by (rule ZF_fun_from_tot_val0)
          with \<open>V \<subseteq> \<Union>S\<close> show ?thesis by auto
        qed
        ultimately show ?thesis by simp
      qed
      also have "{\<langle>Init(x),x`(n)\<rangle>. x\<in>V} = ?U\<times>?W"
      proof
        { fix y assume "y \<in> {\<langle>Init(x),x`(n)\<rangle>. x\<in>V}"
          then obtain x where I: "y = \<langle>Init(x),x`(n)\<rangle>" and "x\<in>V" by auto
          with \<open>V = FinProd(succ(n)\<rightarrow>\<Union>\<tau>,W\<^sub>V)\<close> have
            "x:succ(n)\<rightarrow>\<Union>\<tau>" and II: "\<forall>k\<in>domain(W\<^sub>V). x`(k) \<in> W\<^sub>V`(k)"
            unfolding FinProd_def by auto
          with A2 \<open>W\<^sub>V: succ(n)\<rightarrow>\<tau>\<close> have IV: "\<forall>k\<in>n. Init(x)`(k) = x`(k)"
            using init_props by simp
          have "Init(x) \<in> ?U"
          proof -
            from A2 \<open>x:succ(n)\<rightarrow>\<Union>\<tau>\<close> have "Init(x): n\<rightarrow>\<Union>\<tau>" using init_props by simp
            moreover have "\<forall>k\<in>domain(Init(W\<^sub>V)). Init(x)`(k) \<in> Init(W\<^sub>V)`(k)"
            proof -
              from A2 \<open>W\<^sub>V: succ(n)\<rightarrow>\<tau>\<close> have "Init(W\<^sub>V): n\<rightarrow>\<tau>" using init_props by simp
              then have "domain(Init(W\<^sub>V)) = n" using func1_1_L1 by simp
              note III IV  \<open>domain(Init(W\<^sub>V)) = n\<close>
              moreover from II \<open>W\<^sub>V \<in> succ(n)\<rightarrow>\<tau>\<close> have "\<forall>k\<in>n. x`(k) \<in> W\<^sub>V`(k)"
                using func1_1_L1 by simp
              ultimately show ?thesis by simp
            qed
            ultimately show "Init(x) \<in> ?U" using FinProd_def by simp
          qed
          moreover from \<open>W\<^sub>V: succ(n)\<rightarrow>\<tau>\<close> II have "x`(n) \<in> ?W" using func1_1_L1 by simp
          ultimately have "\<langle>Init(x),x`(n)\<rangle> \<in> ?U\<times>?W" by simp
          with I have "y \<in> ?U\<times>?W" by simp
        } thus "{\<langle>Init(x),x`(n)\<rangle>. x\<in>V} \<subseteq> ?U\<times>?W" by auto
        { fix y assume "y \<in> ?U\<times>?W"
          then have "fst(y) \<in> ?U" and "snd(y) \<in> ?W" by auto
          with \<open>domain(Init(W\<^sub>V)) = n\<close> have "fst(y): n\<rightarrow>\<Union>\<tau>" and
            V: "\<forall>k\<in>n. fst(y)`(k) \<in> Init(W\<^sub>V)`(k)"
            using FinProd_def by auto
          from \<open>W\<^sub>V: succ(n)\<rightarrow>\<tau>\<close> have "?W \<in> \<tau>" using apply_funtype by simp
          with \<open>snd(y) \<in> ?W\<close> have "snd(y) \<in> \<Union>\<tau>" by auto
          let ?x = "Append(fst(y),snd(y))"
          have "?x\<in>V"
          proof -
            from \<open>fst(y): n\<rightarrow>\<Union>\<tau>\<close> \<open>snd(y) \<in> \<Union>\<tau>\<close> have "?x:succ(n)\<rightarrow>\<Union>\<tau>" using append_props by simp
            moreover have "\<forall>i\<in>domain(W\<^sub>V). ?x`(i) \<in> W\<^sub>V`(i)"
            proof -
              from \<open>fst(y): n\<rightarrow>\<Union>\<tau>\<close> \<open>snd(y) \<in> \<Union>\<tau>\<close>
                have "\<forall>k\<in>n. ?x`(k) = fst(y)`(k)" and "?x`(n) = snd(y)"
                using append_props by auto
              moreover from III V have "\<forall>k\<in>n. fst(y)`(k) \<in> W\<^sub>V`(k)" by simp
              moreover note \<open>snd(y) \<in> ?W\<close>
              ultimately have "\<forall>i\<in>succ(n). ?x`(i) \<in> W\<^sub>V`(i)" by simp
              with \<open>W\<^sub>V \<in> succ(n)\<rightarrow>\<tau>\<close> show ?thesis using func1_1_L1 by simp
            qed
            ultimately have "?x \<in> FinProd(succ(n)\<rightarrow>\<Union>\<tau>,W\<^sub>V)" using FinProd_def by simp
            with \<open>V = FinProd(succ(n)\<rightarrow>\<Union>\<tau>,W\<^sub>V)\<close> show "?x\<in>V" by simp
          qed
          moreover from A2 \<open>y \<in> ?U\<times>?W\<close> \<open>fst(y): n\<rightarrow>\<Union>\<tau>\<close> \<open>snd(y) \<in> \<Union>\<tau>\<close> have "y = \<langle>Init(?x),?x`(n)\<rangle>"
            using init_append append_props by auto
          ultimately have "y \<in> {\<langle>Init(x),x`(n)\<rangle>. x\<in>V}" by auto
        } thus "?U\<times>?W \<subseteq> {\<langle>Init(x),x`(n)\<rangle>. x\<in>V}" by auto
      qed
      finally show "f``(V) = ?U\<times>?W" by simp
    qed
    ultimately show "f``(V) \<in> ProductTopology(T,\<tau>)" by simp
  qed
  ultimately show ?thesis using two_top_spaces0.bij_base_open_homeo by simp
qed

end