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

datatype Nat = Z | S "Nat"

fun le :: "Nat => Nat => bool" where
"le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

theorem property0 :
  "((let y2 :: Nat = (if le y z then z else y)
     in (if le x y2 then x else y2)) =
      (if le x z then
         (let x3 :: Nat = (if le x y then x else y)
          in % (y4 :: Nat) => (if le x3 y4 then y4 else x3))
         x
         else
         (let x2 :: Nat = (if le x y then x else y)
          in % (y3 :: Nat) => (if le x2 y3 then y3 else x2))
         z))"
  oops

end


theory RRLoopTwo
(* Second instance of the RRLoop: note that here the infrastructure type gets re-defined.
   Corresponding definitions are defined again for the new type. They co-exist with
   the previous definitions. This is possible thanks to Isabelle's overloading and
   theory name spacing possibilities! *)
imports hcKripkeOne FMap (* "/Applications/Isabelle2018.app/Isabelle/src/HOL/Hoare/Hoare_Logic" *)
begin
(* a simple definition of data and instantiating
the generic types of the Hoare logic to pairs of owner and data as
basic data type for specification. This enables the unique marking
(modulo insider impersonation) of data within the system.
The manipulation of the data (using simple while language) can thus
be modelled but additionally taking the ownership into account. We use
eval below and anchor the access control in restricing base functions
for the basic com type *)
(* taken over from previous level:
datatype action = get | move | eval |put
typedecl actor
type_synonym identity = string
consts Actor :: "string => actor"
type_synonym policy = "((actor => bool) * action set)"

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

datatype location = Location nat
*)

type_synonym data = string
  (* Inspired by Myers DLM mode: first is the owner of a data item, second is the
     set of all actors that may access the data item *)
type_synonym dlm = "actor * actor set"
  (* the following type constructors are from Hoare_logic:
     bexp and assn are just synonyms for set, and
     com is a simple datatype repesenting while command language
     over some basic 'a \<Rightarrow> 'a functions, while 'a sem is
     just the type of relations 'a \<Rightarrow> 'a \<Rightarrow> bool representing relational
     semantics *)

type_synonym acond = "(dlm * data) set"
(*
type_synonym aassn = "(dlm * data) assn"
type_synonym acom = "(dlm * data) com"
type_synonym asem = "(dlm * data) sem"
*)

datatype igraph = Lgraph "(location * location)set" "location \<Rightarrow> identity set"
                         "actor \<Rightarrow> (string set * string set)"  "location \<Rightarrow> acond"
datatype infrastructure =
         Infrastructure "igraph"
                        "[igraph ,location] \<Rightarrow> policy 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 set)"
where  "agra(Lgraph g a c l) = a"
primrec cgra :: "igraph \<Rightarrow> (actor \<Rightarrow> string set * string set)"
where  "cgra(Lgraph g a c l) = c"
primrec lgra :: "igraph \<Rightarrow> (location \<Rightarrow> acond)"
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> (agra g y)}"

primrec graphI :: "infrastructure \<Rightarrow> igraph"
where "graphI (Infrastructure g d) = g"
primrec delta :: "[infrastructure, igraph, location] \<Rightarrow> policy set"
where "delta (Infrastructure g d) = d"
primrec tspace :: "[infrastructure, actor ] \<Rightarrow> string set * string set"
  where "tspace (Infrastructure g d) = cgra g"
primrec lspace :: "[infrastructure, location ] \<Rightarrow> acond"
where "lspace (Infrastructure g d) = lgra g"
definition credentials :: "string set * string set \<Rightarrow> string set"
  where  "credentials lxl \<equiv> (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 set * string set \<Rightarrow> string set"
  where  "roles lxl \<equiv> (snd lxl)"
definition role :: "[igraph, actor * string] \<Rightarrow> bool"
  where "role G ac \<equiv> snd ac \<in> roles(cgra G (fst ac))"

definition owner :: "dlm * data \<Rightarrow> actor" where "owner d \<equiv> fst(fst d)"

definition owns :: "[igraph, location, actor, dlm * data] \<Rightarrow> bool"
  where "owns G l a d \<equiv> owner d = a"

definition readers :: "dlm * data \<Rightarrow> actor set"
  where "readers d \<equiv> snd (fst d)"

definition has_access :: "[igraph, location, actor, dlm * data] \<Rightarrow> bool"
where "has_access G l a d \<equiv> owns G l a d \<or> a \<in> readers d"

definition actor_can_delete ::   "[infrastructure, actor, location] \<Rightarrow> bool"
where actor_can_delete_def: "actor_can_delete I h l \<equiv>
                   (\<forall> as n. ((h, as), n) \<notin> (lgra (graphI I) l))"

definition atI :: "[identity, igraph, location] \<Rightarrow> bool" ("_ @\<^bsub>(_)\<^esub> _" 50)
where "a @\<^bsub>G\<^esub> l \<equiv> a \<in> (agra G l)"

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)"

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> ((agra g) l) &  n \<notin> ((agra g) l') then
                     ((agra g)(l := (agra g l) - {n}))(l' := (insert n (agra g l')))
                     else (agra g))(cgra g)(lgra g)"
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_data : "G = graphI I \<Longrightarrow> h @\<^bsub>G\<^esub> l \<Longrightarrow>  l \<in> nodes G \<Longrightarrow> l' \<in> nodes G \<Longrightarrow>
        enables I l (Actor h) get \<Longrightarrow>
       ((Actor h', hs), n) \<in> lgra G l' \<Longrightarrow> Actor h \<in> hs \<or> h = h' \<Longrightarrow>
        I' = Infrastructure
                   (Lgraph (gra G)(agra G)(cgra G)
                   ((lgra G)(l := (lgra G l)  \<union> {((Actor h', hs), n)})))
                   (delta I)
         \<Longrightarrow> I \<rightarrow>\<^sub>n I'"
| process : "G = graphI I \<Longrightarrow> h @\<^bsub>G\<^esub> l \<Longrightarrow> l \<in> nodes G \<Longrightarrow>
        enables I l (Actor h) eval \<Longrightarrow>
       ((Actor h', hs), n) \<in> lgra G l \<Longrightarrow> Actor h \<in> hs \<or> h = h' \<Longrightarrow>
        I' = Infrastructure
                   (Lgraph (gra G)(agra G)(cgra G)
                   ((lgra G)(l := ((lgra G l)  - {(y, x). x = n}
                    \<union> {f ((Actor h', hs), n)}))))
                   (delta I)
         \<Longrightarrow> I \<rightarrow>\<^sub>n I'"
| del_data : "G = graphI I \<Longrightarrow> h \<in> actors_graph G \<Longrightarrow> l \<in> nodes G \<Longrightarrow>
       ((Actor h, hs), n) \<in> lgra G l \<Longrightarrow>
        I' = Infrastructure
                   (Lgraph (gra G)(agra G)(cgra G)
                   ((lgra G)(l := (lgra G l) - {(y, x). x = n })))
                   (delta I)
         \<Longrightarrow> I \<rightarrow>\<^sub>n I'"
| put : "G = graphI I \<Longrightarrow> h @\<^bsub>G\<^esub> l \<Longrightarrow> l \<in> nodes G \<Longrightarrow>
        enables I l (Actor h) put \<Longrightarrow>
        I' = Infrastructure
                  (Lgraph (gra G)(agra G)(cgra G)
                          ((lgra G)(l := (lgra G l) \<union> {((Actor h, hs), n)})))
                   (delta I)
          \<Longrightarrow> I \<rightarrow>\<^sub>n I'"
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>*)"

end

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

(* general scheme for map over finite sets.
   This would be a useful provision for the Finite_Set library: everyone needs
   a simple map on Finite Sets all the time!
definition fmap :: "['a \<Rightarrow> 'b, 'a set] \<Rightarrow> 'b set"
  where "fmap f S = Finite_Set.fold (\<lambda> x y. insert (f x) y) {} S"

lemma fmap_lem_map[rule_format]: "finite S \<Longrightarrow> n \<in> S \<longrightarrow> (f n) \<in> (fmap f S)"
  apply (erule_tac F = S in finite_induct)
   apply simp
  apply clarify
  apply (simp add: fmap_def)
  apply (subgoal_tac "comp_fun_commute (\<lambda>x::'a. insert (f x))")
   apply (drule_tac A = "F" in Finite_Set.comp_fun_commute.fold_insert)
     apply assumption+
   apply (erule ssubst)
   apply (erule disjE)
  apply force+
apply (simp add: comp_fun_commute_def)
by force

lemma fmap_lem_map_rev[rule_format]: "finite S \<Longrightarrow> inj f \<Longrightarrow> (f n) \<in> (fmap f S) \<longrightarrow> n \<in> S"
  apply (erule_tac F = S in finite_induct)
   apply (simp add: fmap_def)
  apply clarify
  apply (simp add: fmap_def)
  apply (subgoal_tac "comp_fun_commute (\<lambda>x::'a. insert (f x))")
   apply (drule_tac A = "F" and z = "{}" in Finite_Set.comp_fun_commute.fold_insert)
     apply assumption+
   apply (subgoal_tac "f n \<in> insert (f x) (Finite_Set.fold (\<lambda>x::'a. insert (f x)) {} F)")
    prefer 2
    apply simp
   apply (subgoal_tac "f n = f x")
    prefer 2
    apply simp
   apply (erule injD, assumption)
apply (simp add: comp_fun_commute_def)
by force

lemma fold_one: "Finite_Set.fold (\<lambda>x::'a. insert (f x)) {} {n} = {f n}"
  thm Finite_Set.comp_fun_commute.fold_insert
  apply (subgoal_tac "comp_fun_commute (\<lambda>x::'a. insert (f x))")
   apply (drule_tac A = "{}" in Finite_Set.comp_fun_commute.fold_insert)
     apply simp+
  apply (simp add: comp_fun_commute_def)
by force

lemma fmap_lem_one: "fmap f {a} = {f a}"
by (simp add: fmap_def fold_one)

lemma fmap_lem[rule_format]: "finite S \<Longrightarrow> \<forall> n. (fmap f (insert n S)) = (insert (f n) (fmap f S))"
  thm finite.induct
  apply (erule_tac F = S in finite_induct)
   apply (rule allI)
   apply (simp add: fmap_def)
   apply (rule fold_one)
(* *)
  apply (subgoal_tac "comp_fun_commute (\<lambda>x::'a. insert (f x))")
   apply (rule allI)
   apply (drule_tac x = x in spec)
   apply (erule ssubst)
   apply (subgoal_tac "fmap f (insert n (insert x F)) = insert (f n) (fmap f (insert x F))")
  apply (erule ssubst)
    apply (subgoal_tac "fmap f (insert x F) = insert (f x) (fmap f F)")
     apply simp
    apply (drule_tac A = "F" in Finite_Set.comp_fun_commute.fold_insert)
      apply assumption
     apply assumption
    apply (unfold fmap_def, assumption)
   apply (case_tac "n \<in> insert x F")
    defer
    apply (drule_tac A = "insert x F" in Finite_Set.comp_fun_commute.fold_insert)
     apply simp
  apply assumption+
  apply (simp add: comp_fun_commute_def)
  apply force
(* n \<in> insert x F *)
  apply (simp add: Finite_Set.comp_fun_commute.fold_rec)
  apply (subgoal_tac "Finite_Set.fold (\<lambda>x::'a. insert (f x)) {} (insert n (insert x F)) =
                     Finite_Set.fold (\<lambda>x::'a. insert (f x)) {} (insert x F)")
   prefer 2
   apply (subgoal_tac "insert n (insert x F) = insert x F")
    apply simp
  apply blast
  apply (erule ssubst)
  apply (rule Finite_Set.comp_fun_commute.fold_rec)
apply (simp add: comp_fun_commute_def)
   apply force
  by simp

lemma insert_delete: "x \<notin> S \<Longrightarrow> (insert x S) - {x} = S"
by simp

lemma fmap_lem_del[rule_format]: "finite S \<Longrightarrow> inj f \<Longrightarrow> \<forall> n \<in> S. fmap f (S - {n}) = (fmap f S) - {f n}"
  apply (erule_tac F = S in finite_induct)
   apply (rule ballI)
   apply (simp add: fmap_def)
(* *)
  apply (subgoal_tac "comp_fun_commute (\<lambda>x::'a. insert (f x))")
   apply (rule ballI)
apply simp
   apply (erule disjE)
(* n = x *)
    apply simp
    apply (drule_tac A = "F" and z = "{}" in Finite_Set.comp_fun_commute.fold_insert)
      apply assumption+
    apply (unfold fmap_def)
    apply (rotate_tac -1)
  apply (erule ssubst)
  apply (rule sym)
    apply (rule insert_delete)
    apply (erule contrapos_nn)
  apply (rule fmap_lem_map_rev, assumption, assumption)
  apply (simp add: fmap_def)
(* n \<in> F *)
    apply (frule_tac A = "F" and z = "{}" in Finite_Set.comp_fun_commute.fold_insert, assumption, assumption)
   apply (rotate_tac -1)
   apply (erule ssubst)
  apply (subgoal_tac "insert (f x) (Finite_Set.fold (\<lambda>x::'a. insert (f x)) {} F) - {f n} =
                      insert (f x) ((Finite_Set.fold (\<lambda>x::'a. insert (f x)) {} F) - {f n})")
   apply (rotate_tac -1)
   apply (erule ssubst)
   apply (drule_tac x = n in bspec,assumption)
   apply (rotate_tac -1)
   apply (erule subst)
    apply (drule_tac A = "F - {n}" and z = "{}" and x = x in Finite_Set.comp_fun_commute.fold_insert)
      apply simp+
    apply (subgoal_tac "insert x (F - {n}) = insert x F - {n}")
     apply simp
    apply blast
   apply (subgoal_tac "f x \<noteq> f n")
    apply force
   apply (subgoal_tac "x \<noteq> n")
  apply (rotate_tac -1)
  apply (erule contrapos_nn)
    apply (erule injD, assumption)
  apply blast
apply (simp add: comp_fun_commute_def)
by force

thm finite_induct

lemma fmap_empty1: "(fmap f {} = S) \<Longrightarrow> (S = {})"
  by (simp add: fmap_def)

lemma fmap_empty2: "S = {} \<Longrightarrow> fmap f {} = S"
  by (simp add: fmap_def)

lemma fmap_empty: "(fmap f {} = S) = (S = {})"
proof
  show "fmap f {} = S \<Longrightarrow> S = {}"
    by (erule fmap_empty1)
next show  "S = {} \<Longrightarrow> fmap f {} = S"
    by (erule fmap_empty2)
qed

lemma fmap_empty3: "fmap f {} = {}"
  by (simp add: fmap_def)

lemma fmap_empty4[rule_format]: "finite S \<Longrightarrow> fmap f S = {} \<longrightarrow> S = {}"
  apply (erule_tac F = S in finite_induct)
  apply simp
  apply (simp add: fmap_def)
  apply (subgoal_tac "Finite_Set.fold (\<lambda>x::'a. insert (f x)) {} ({x}) \<noteq> {}")
  apply (subgoal_tac "Finite_Set.fold (\<lambda>x::'a. insert (f x)) {} ({x}) \<subseteq>
                      Finite_Set.fold (\<lambda>x::'a. insert (f x)) {} (insert x F)")
    apply blast
  apply (subst fold_one)
   apply (subgoal_tac "comp_fun_commute (\<lambda>x::'a. insert (f x))")
  thm Finite_Set.comp_fun_commute.fold_insert
   apply (drule_tac A = "F" and z = "{}" in Finite_Set.comp_fun_commute.fold_insert)
     apply simp
     apply simp
  apply (erule ssubst)
    apply simp
     apply (simp add: comp_fun_commute_def)
     apply force
    apply (subst fold_one)
  by simp

lemma insert_delete0: "x \<in> A \<Longrightarrow> A = insert x (A - {x})"
  by auto

lemma fmap_inj[rule_format]:
  assumes "finite S" and "inj f"
  shows "\<forall> S'. finite S' \<longrightarrow> fmap f S = fmap f S' \<longrightarrow> S = S'"
  using assms
proof (erule_tac F = S in finite_induct, clarify)
  show "\<And>S'::'a set. inj f \<Longrightarrow> finite S \<Longrightarrow> inj f \<Longrightarrow> finite S' \<Longrightarrow>
        fmap f {} = fmap f S' \<Longrightarrow> {} = S'"
    apply (rule sym)
    apply (rule_tac f = f in fmap_empty4)
    apply assumption
by (erule fmap_empty1)
next show "\<And>(x::'a) F::'a set.
       inj f \<Longrightarrow>
       finite F \<Longrightarrow>
       x \<notin> F \<Longrightarrow>
       \<forall>S'::'a set. finite S' \<longrightarrow> fmap f F = fmap f S' \<longrightarrow> F = S' \<Longrightarrow>
       \<forall>S'::'a set. finite S' \<longrightarrow> fmap f (insert x F) = fmap f S' \<longrightarrow> insert x F = S'"
  proof (clarify)
    fix x F S'
    assume a0: "inj f"
       and a1: "finite F"
       and a1a: "x \<notin> F"
       and a2: "\<forall>S'::'a set. finite S' \<longrightarrow> fmap f F = fmap f S' \<longrightarrow> F = S'"
       and a3: "finite S'"
       and a4: "fmap f (insert x F) = fmap f S'"
    show "insert x F = S'"
    proof -
      have a5: "insert (f x) (fmap f F) = fmap f S'"
        by (insert fmap_lem[of F f x], drule meta_mp, rule a1, erule subst, rule a4)
      have a6: "f x \<in> fmap f S'" by (insert a5, erule subst, simp)
      have a6a: "x \<in> S'" by (rule fmap_lem_map_rev, rule a3, rule a0, rule a6)
      have a7: "fmap f S' = insert (f x) ((fmap f S') - {f x})"
        by (insert insert_delete0[of "f x" "(fmap f S')"],drule meta_mp, rule a6)
      have a8: "insert (f x) (fmap f F) = insert (f x) ((fmap f S') - {f x})"
        by (subst a5, subst a7, rule refl)
      have a9: "f x \<notin> (fmap f F)" using a0 a1 a1a
        apply (rule_tac P = "f x \<in> fmap f F" in notI, subgoal_tac "x \<in> F")
          apply (rule notE, rule a1a, assumption)
        by (rule fmap_lem_map_rev)
      have a10: "f x \<notin> ((fmap f S') - {f x})" by simp
      have a11: "fmap f F = ((fmap f S') - {f x})" by (insert a8 a9 a10, force)
      have a12: "x \<in> S' \<Longrightarrow> fmap f F = fmap f (S' - {x})"
        apply (insert fmap_lem_del[of S' f x])
        apply (drule meta_mp)
         apply (rule a3)
        apply (drule meta_mp)
         apply (rule a0)
        apply (drule meta_mp, assumption)
        apply (erule ssubst)
        by (rule a11)
(*      have a13: "x \<notin> S' \<Longrightarrow> f x \<notin> fmap f S'"
        by (erule contrapos_nn, rule fmap_lem_map_rev, rule a3, rule a0)
      have a14: "x \<notin> S' \<Longrightarrow> fmap f F = (fmap f S')"
        by (insert a13, drule meta_mp, assumption, subst a11, simp) *)
      show "insert x F = S'"
        apply (insert a6a)
         apply (insert a2)
         apply (drule_tac x = "S' - {x}" in spec)
         apply (drule mp)
          apply (simp add: a3)
         apply (drule mp)
          apply (erule a12)
         apply (erule ssubst)
        apply (rule sym)
        by (erule insert_delete0)
    qed
  qed
qed

lemma fmap_inj0: "inj f \<Longrightarrow> inj_on (fmap f){S. finite S}"
  apply (rule inj_onI)
  apply (rule fmap_inj)
  by simp+

lemma fmap_lem_map_rev0[rule_format]: "finite S \<Longrightarrow> (\<forall>y\<in>S. f y \<noteq> f n) \<longrightarrow> (f n) \<in> (fmap f S) \<longrightarrow> n \<in> S"
  apply (erule_tac F = S in finite_induct)
   apply (simp add: fmap_def)
  apply clarify
  apply (simp add: fmap_def)
  apply (subgoal_tac "comp_fun_commute (\<lambda>x::'a. insert (f x))")
   apply (drule_tac A = "F" and z = "{}" in Finite_Set.comp_fun_commute.fold_insert)
     apply assumption+
   apply (subgoal_tac "f n \<in> insert (f x) (Finite_Set.fold (\<lambda>x::'a. insert (f x)) {} F)")
    prefer 2
    apply simp
   apply (subgoal_tac "f n = f x")
  apply simp
    apply simp
apply (simp add: comp_fun_commute_def)
by force

lemma fmap_lem_map_rev1: "finite S \<Longrightarrow> (\<forall>y\<in>S. f y \<noteq> f n) \<Longrightarrow> (f n) \<in> (fmap f S) \<Longrightarrow> n \<in> S"
  apply (erule fmap_lem_map_rev0)
  apply (drule bspec, assumption, assumption)
  by assumption

lemma fmap_lem_del_set1[rule_format]: "finite S \<Longrightarrow>
                        \<forall> n \<in> S. fmap f (S - {y. f y = f n}) = (fmap f S) - {f n}"
  apply (erule_tac F = S in finite_induct)
   apply (rule ballI)
   apply (simp add: fmap_def)
(* *)
  apply (subgoal_tac "comp_fun_commute (\<lambda>x::'a. insert (f x))")
   apply (rule ballI)
   prefer 2
apply (simp add: comp_fun_commute_def)
   apply force
(* *)
  apply (case_tac "n = x")
   apply (simp add: fmap_def)
   apply (frule_tac A = "F" and z = "{}" in Finite_Set.comp_fun_commute.fold_insert)
     apply assumption+
   apply (rotate_tac -1)
  apply (erule ssubst)
(* *)
    apply simp
    apply (case_tac "\<exists> y \<in> F. f y = f x")
     apply (erule bexE)
     apply (drule_tac x = y in bspec, assumption)
     apply simp+
   apply (subgoal_tac "F - {y::'a. f y = f x} = F - {x}")
    prefer 2
  apply blast
  apply (rotate_tac -1)
  apply (erule ssubst)
   apply simp
  apply (subgoal_tac "(f x) \<notin> Finite_Set.fold (\<lambda>x::'a. insert (f x)) {} F ")
    apply simp
   apply (erule contrapos_nn)
   apply (rule fmap_lem_map_rev1, assumption, assumption)
   apply (simp add: fmap_def)
(* *)
  apply (subgoal_tac "n \<in> F")
   apply (drule_tac x = n in bspec, assumption)
  apply (frule_tac f = f and n = x in fmap_lem)
   apply (rotate_tac -1)
   apply (erule ssubst)
(* *)
  apply (case_tac "f x = f n")
    apply simp
  apply simp
   apply (subgoal_tac "insert (f x) (fmap f F) - {f n} = insert (f x) ((fmap f F) - {f n})")
    prefer 2
    apply force
  apply (rotate_tac -1)
   apply (erule ssubst)
   apply (subgoal_tac "insert x F - {y::'a. f y = f n} = insert x (F - {y::'a. f y = f n})")
    prefer 2
    apply force
  apply (rotate_tac -1)
   apply (erule ssubst)
   apply (subgoal_tac "finite (F - {y::'a. f y = f n})")
    apply (rotate_tac -1)
  apply (drule_tac S = "(F - {y::'a. f y = f n})" and f = f and n = x in fmap_lem)
    apply simp
   apply simp
by (simp add: comp_fun_commute_def)
*)

definition ref_map :: "[RRLoopTwo.infrastructure,
                        [RRLoopOne.igraph, RRLoopOne.location] \<Rightarrow> policy set]
                        \<Rightarrow> RRLoopOne.infrastructure"
  where "ref_map I lp = RRLoopOne.Infrastructure
                                 (RRLoopOne.Lgraph
                                        (RRLoopTwo.gra (graphI I))(RRLoopTwo.agra (graphI I))
                                        (RRLoopTwo.cgra (graphI I))
                                        (\<lambda> l. fmap snd (RRLoopTwo.lgra (graphI I) l)))
                                                                         lp"
(* archive, older approaches that are similar:
 (\<lambda> l. Finite_Set.fold (\<lambda> x y. insert (snd x) y){}(RRLoopTwo.lgra (graphI I) l)))
(\<lambda> l. {x. ? y. (y,x) \<in> (RRLoopTwo.lgra (graphI I) l)}))
*)

lemma delta_invariant: "\<forall> z z'. z \<rightarrow>\<^sub>n z' \<longrightarrow>  delta(z) = delta(z')"
  apply clarify
  apply (erule state_transition_in.cases)
  by simp+
end


theory IICF_MS_Array_List
imports
  "../Intf/IICF_List" IICF_Array
begin

  (* TODO: Move *)
  lemma hfref_bassnI:
    assumes "\<And>x. \<lbrakk>P x; rdomp (fst A) x\<rbrakk> \<Longrightarrow> fa x \<le> SPEC Q"
    assumes "(fc,fa)\<in>[P]\<^sub>a A \<rightarrow> R"
    shows "(fc,fa)\<in>[P]\<^sub>a A \<rightarrow> b_assn R Q"
  proof (cases A)
    case [simp]: (Pair Apre Apost)
    then show ?thesis
      apply sepref_to_hoare
      apply clarsimp
      apply (rule htriple_pure_preI)
      supply [vcg_rules] = assms(2)[to_hnr, THEN hn_refineD,unfolded autoref_tag_defs hn_ctxt_def, simplified]
      apply vcg
      apply (frule (1) order_trans[OF _ assms(1)])
      subgoal by (auto simp: pure_part_def rdomp_def)
      subgoal by vcg
      done

  qed

  definition "ms_irel M N \<equiv> br (\<lambda>(l,xs). take l xs) (\<lambda>(l,xs). l\<le>N \<and> N = length xs \<and> N<M)"

  definition "ms_empty N \<equiv> RETURN (0::nat,replicate N init)"
  definition "ms_is_empty \<equiv> \<lambda>(l,_). RETURN (l=0)"
  definition "ms_length \<equiv> \<lambda>(l,_). RETURN l"
  definition "ms_push_back \<equiv> \<lambda>(l,xs) x. ASSERT (l < length xs) \<then> RETURN (l+1,xs[l:=x])"
  definition "ms_last \<equiv> \<lambda>(l,xs). ASSERT (0<l \<and> l\<le>length xs) \<then> RETURN (xs!(l-1))"
  definition "ms_butlast \<equiv> \<lambda>(l,xs). ASSERT (l>0) \<then> RETURN (l-1,xs)"
  definition "ms_get \<equiv> \<lambda>(l,xs) i. ASSERT (i<length xs) \<then> RETURN (xs!i)"
  definition "ms_set \<equiv> \<lambda>(l,xs) i x. ASSERT (i<length xs) \<then> RETURN (l,xs[i:=x])"

  context begin

    private method ms_prove_refine =
      (unfold ms_irel_def curry0_def;
        intro nres_relI fun_relI frefI;
        simp?;
        refine_vcg?;
        (auto simp: in_br_conv)
      )

    lemma ms_empty_correct: "N<M \<Longrightarrow> (ms_empty N,mop_list_empty) \<in> \<langle>ms_irel M N\<rangle>nres_rel"
      unfolding ms_empty_def by ms_prove_refine

    lemma ms_is_empty_correct: "(ms_is_empty,mop_list_is_empty) \<in> ms_irel M N \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
      unfolding ms_is_empty_def by ms_prove_refine

    lemma ms_length_correct: "(ms_length,mop_list_length) \<in> ms_irel M N \<rightarrow> \<langle>nat_rel\<rangle>nres_rel"
      unfolding ms_length_def by ms_prove_refine

    lemma ms_push_back_correct: "(uncurry ms_push_back,uncurry mop_list_append)
      \<in> [\<lambda>(xs,x). length xs < N]\<^sub>f (ms_irel M N \<times>\<^sub>r Id) \<rightarrow> \<langle>ms_irel M N\<rangle>nres_rel"
      unfolding ms_push_back_def
      supply [simp] = take_update_last
      by ms_prove_refine

    lemma ms_last_correct: "(ms_last,mop_list_last)\<in>ms_irel M N \<rightarrow> \<langle>Id\<rangle>nres_rel"
      unfolding ms_last_def supply [simp] = last_take_nth_conv by ms_prove_refine

    lemma ms_butlast_correct: "(ms_butlast,mop_list_butlast)\<in>ms_irel M N \<rightarrow> \<langle>ms_irel M N\<rangle>nres_rel"
      unfolding ms_butlast_def supply [simp] = butlast_take by ms_prove_refine

    lemma ms_get_correct: "(ms_get,mop_list_get)\<in>ms_irel M N \<rightarrow> nat_rel \<rightarrow> \<langle>Id\<rangle>nres_rel"
      unfolding ms_get_def by ms_prove_refine

    lemma ms_set_correct: "(ms_set,mop_list_set)\<in>ms_irel M N \<rightarrow> nat_rel \<rightarrow> Id \<rightarrow> \<langle>ms_irel M N\<rangle>nres_rel"
      unfolding ms_set_def by ms_prove_refine

  end

  type_synonym ('l,'a) marl = "'l word \<times> 'a ptr"

  context
    fixes M :: nat
    defines "M \<equiv> max_snat (LENGTH ('l::len2))"
  begin

    lemma ms_irel_prenorm[fcomp_prenorm_simps]:
      assumes "((l,xs),xs')\<in>ms_irel M N"
      shows "length xs = N" "l=length xs'" "length xs'\<le>N" "N < M"
      using assms
      unfolding ms_irel_def
      by (auto simp: in_br_conv)

    abbreviation "marl2_assn \<equiv> snat_assn' TYPE('l) \<times>\<^sub>a array_assn id_assn"

    sepref_definition marl_empty_impl [llvm_inline] is "ms_empty" :: "(snat_assn' TYPE('l))\<^sup>k \<rightarrow>\<^sub>a marl2_assn"
      unfolding ms_empty_def
      supply [sepref_import_param] = IdI[of init]
      apply (annot_snat_const "TYPE('l)")
      apply (rewrite array_fold_custom_replicate)
      by sepref

    definition [simp]: "marl_empty_aux (N::nat) \<equiv> op_list_empty"

    sepref_decl_op marl_empty: marl_empty_aux :: "nat_rel \<rightarrow> \<langle>A\<rangle>list_rel" .

    lemma ms_empty_correct': "(ms_empty,RETURN o op_marl_empty)
      \<in> [\<lambda>N. N<M]\<^sub>f\<^sub>d nat_rel \<rightarrow> (\<lambda>N. \<langle>ms_irel M N\<rangle>nres_rel)"
      apply (rule frefI) using ms_empty_correct by auto

    (*
    definition "marl_assn' TYPE('l) N A \<equiv> hr_comp (hr_comp marl2_assn (ms_irel (max_snat LENGTH('l)) N))
                                     (\<langle>the_pure A\<rangle>list_rel)"
    *)

    definition "marl_assn' TYPE('l) A \<equiv> hrr_comp nat_rel
                                    (\<lambda>N. hr_comp marl2_assn (ms_irel M N))
                                    (\<lambda>_. \<langle>the_pure A\<rangle>list_rel)"

    lemmas [fcomp_norm_unfold] = marl_assn'_def[symmetric, folded M_def]

    lemma marl_assn'_fold'[fcomp_norm_unfold]:
      "hr_comp (hr_comp (snat_assn \<times>\<^sub>a array_assn id_assn) (ms_irel M N)) (\<langle>the_pure A\<rangle>list_rel)
        = marl_assn' TYPE('l) A N"
      unfolding marl_assn'_def
      unfolding hrr_comp_def
      apply (auto simp: fun_eq_iff sep_algebra_simps pred_lift_extract_simps)
      unfolding non_dep_def by metis+

    sepref_decl_impl marl_empty: marl_empty_impl.refine[FCOMP ms_empty_correct'] by simp

    sepref_definition marl_is_empty_impl [llvm_inline] is ms_is_empty :: "marl2_assn\<^sup>k \<rightarrow>\<^sub>a bool1_assn"
      unfolding ms_is_empty_def
      apply (annot_snat_const "TYPE('l)")
      apply sepref_dbg_keep
      done

    sepref_decl_impl (ismop) marl_is_empty_impl.refine[FCOMP ms_is_empty_correct[of M]] .

    sepref_definition marl_length_impl [llvm_inline] is ms_length :: "marl2_assn\<^sup>k \<rightarrow>\<^sub>a snat_assn' TYPE('l)"
      unfolding ms_length_def
      by sepref
    sepref_decl_impl (ismop) marl_length_impl.refine[FCOMP ms_length_correct[of M]] .

    sepref_definition marl_push_back_impl [llvm_code] is
      "uncurry ms_push_back" :: "[\<lambda>((l,a),_). length a < M ]\<^sub>a marl2_assn\<^sup>d*\<^sub>aid_assn\<^sup>k \<rightarrow> marl2_assn"
      unfolding ms_push_back_def M_def
      apply (annot_snat_const "TYPE('l)")
      apply sepref_dbg_keep
      done

    sepref_decl_impl (ismop) marl_push_back_impl.refine[FCOMP ms_push_back_correct[where M=M]]
      by (parametricity add: IdI[of N])

    sepref_definition marl_last_impl [llvm_code] is
      "ms_last" :: "marl2_assn\<^sup>k \<rightarrow>\<^sub>a id_assn"
      unfolding ms_last_def M_def
      apply (annot_snat_const "TYPE('l)")
      apply sepref_dbg_keep
      done
    sepref_decl_impl (ismop) marl_last_impl.refine[FCOMP ms_last_correct[where M=M]] .

    sepref_definition marl_butlast_impl [llvm_code] is
      "ms_butlast" :: "marl2_assn\<^sup>d \<rightarrow>\<^sub>a marl2_assn"
      unfolding ms_butlast_def M_def
      apply (annot_snat_const "TYPE('l)")
      apply sepref_dbg_keep
      done
    sepref_decl_impl (ismop) marl_butlast_impl.refine[FCOMP ms_butlast_correct[where M=M]] .

    sepref_definition marl_get_impl [llvm_inline] is
      "uncurry ms_get" :: "marl2_assn\<^sup>k *\<^sub>a (snat_assn' TYPE('l))\<^sup>k \<rightarrow>\<^sub>a id_assn"
      unfolding ms_get_def M_def
      apply sepref_dbg_keep
      done
    sepref_decl_impl (ismop) marl_get_impl.refine[FCOMP ms_get_correct[where M=M]] .

    sepref_definition marl_set_impl [llvm_inline] is
      "uncurry2 ms_set" :: "marl2_assn\<^sup>d *\<^sub>a (snat_assn' TYPE('l))\<^sup>k *\<^sub>a id_assn\<^sup>k \<rightarrow>\<^sub>a marl2_assn"
      unfolding ms_set_def M_def
      apply sepref_dbg_keep
      done
    sepref_decl_impl (ismop) marl_set_impl.refine[FCOMP ms_set_correct[where M=M]] .
  end

  lemma fold_marl_empty:
    "[] = op_marl_empty N"
    "RETURN [] = mop_marl_empty N"
    "op_list_empty = op_marl_empty N"
    "mop_list_empty = mop_marl_empty N"
    by auto

  (* TODO: Move *)
  lemma snat_rel_imp_less_max_snat:
    "\<lbrakk>(x,n)\<in>snat_rel' TYPE('l::len2); L = LENGTH('l)\<rbrakk> \<Longrightarrow> n<max_snat L"
    by (auto simp: snat_rel_def snat.rel_def in_br_conv)

  schematic_goal [sepref_frame_free_rules]: "MK_FREE (marl_assn' TYPE('l::len2) A N) ?f"
    unfolding marl_assn'_fold'[symmetric]
    by sepref_dbg_side

  lemma bind_assoc_tagged: "bind$(bind$m$f)$g = bind$m$(\<lambda>\<^sub>2x. bind$(f$x)$g)"
    unfolding autoref_tag_defs by simp

  find_theorems name: beta

experiment begin

  sepref_definition test is "\<lambda>N. (do {
    let x = op_marl_empty N;
    RETURN (x@[1::nat])
  })" :: "[\<lambda>N. N\<ge>10]\<^sub>a\<^sub>d (snat_assn' TYPE(64))\<^sup>k \<rightarrow> marl_assn' TYPE(64) (snat_assn' TYPE(64))"
    apply (annot_snat_const "TYPE(64)")
    supply [simp] = snat_rel_imp_less_max_snat
    by sepref

end

end


section \<open>Type Safety of Boogie expressions\<close>

theory TypeSafety
imports Semantics Typing Util
begin

fun expr_is_defined :: "var_context \<Rightarrow> 'a nstate \<Rightarrow> expr \<Rightarrow> bool"
  where
     "expr_is_defined \<Lambda> ns (Var x) = (lookup_var \<Lambda> ns x \<noteq> None)"
   | "expr_is_defined \<Lambda> ns (BVar i) = (binder_state ns i \<noteq> None)"
   | "expr_is_defined \<Lambda> ns (Lit l) = True"
   | "expr_is_defined \<Lambda> ns (UnOp uop e) = expr_is_defined \<Lambda> ns e"
   | "expr_is_defined \<Lambda> ns (e1 \<guillemotleft>bop\<guillemotright> e2) = ((expr_is_defined \<Lambda> ns e1) \<and> (expr_is_defined \<Lambda> ns e2))"
   | "expr_is_defined \<Lambda> ns (FunExp f tys e) = ((list_all closed tys) \<and> (list_all (expr_is_defined \<Lambda> ns) e))"
   | "expr_is_defined \<Lambda> ns (CondExp cond thn els) = ( (expr_is_defined \<Lambda> ns cond) \<and>
                                                      (expr_is_defined \<Lambda> ns thn) \<and>
                                                      (expr_is_defined \<Lambda> ns els) )"
   | "expr_is_defined \<Lambda> ns (Old e) = expr_is_defined \<Lambda> ns e"
   | "expr_is_defined \<Lambda> ns (Forall ty e) = ((closed ty) \<and> (\<forall>w. (expr_is_defined \<Lambda> (full_ext_env ns w) e)))"
   | "expr_is_defined \<Lambda> ns (Exists ty e) =  ((closed ty) \<and> (\<forall>w. (expr_is_defined \<Lambda> (full_ext_env ns w) e)))"
   | "expr_is_defined \<Lambda> ns (ForallT e) = expr_is_defined \<Lambda> ns e"
   | "expr_is_defined \<Lambda> ns (ExistsT e) = expr_is_defined \<Lambda> ns e"

lemma unop_type_correct: "\<lbrakk> unop_type uop arg_ty = Some ret_ty; type_of_val A v' = TPrim arg_ty;
                         (unop_eval_val uop v') = Some v  \<rbrakk> \<Longrightarrow>
                       type_of_val A v = TPrim ret_ty"
  by (cases uop; rule lit_val_elim[where v=v']; auto)

lemma unop_progress: "\<lbrakk> unop_type uop arg_ty = Some ret_ty; type_of_val A v' = TPrim arg_ty\<rbrakk> \<Longrightarrow>
                       \<exists>v. (unop_eval_val uop v') = Some v "
  by (cases uop; rule lit_val_elim[where v=v']; auto)

lemma binop_type_correct:
 "\<lbrakk> binop_type bop = Some (targs, ret_ty);
    type_of_val  A v1 = (TPrim left_ty); type_of_val A v2 = (TPrim right_ty);
    (left_ty, right_ty) \<in> targs;
    (binop_eval_val bop v1 v2) = Some v  \<rbrakk> \<Longrightarrow>
    type_of_val A v = TPrim ret_ty"
  by (cases bop; rule lit_val_elim[where v=v1]; rule lit_val_elim[where v=v2]; auto)

lemma binop_progress:
 "\<lbrakk> binop_type bop = Some (targs, ret_ty);
    type_of_val  A v1 = TPrim left_ty; type_of_val A v2 = TPrim right_ty;
   (left_ty, right_ty) \<in> targs \<rbrakk> \<Longrightarrow>
    \<exists>v. (binop_eval_val bop v1 v2) = Some v "
  by (cases bop; rule lit_val_elim[where v=v1]; rule lit_val_elim[where v=v2]; auto)

lemma binop_realdiv_type_correct:
 "\<lbrakk> (binop_eval_val RealDiv v1 v2) = Some v  \<rbrakk> \<Longrightarrow>
    type_of_val A v = TPrim TReal"
  by (rule lit_val_elim[where v=v1]; rule lit_val_elim[where v=v2]; auto)

lemma binop_realdiv_progress:
 "\<lbrakk> type_of_val A v1 = TPrim TInt \<or> type_of_val A v1 = TPrim TReal;
    type_of_val A v2 = TPrim TInt \<or> type_of_val A v2 = TPrim TReal \<rbrakk> \<Longrightarrow>
    \<exists>v. binop_eval_val RealDiv v1 v2  = Some v"
  by (rule lit_val_elim[where v=v1]; rule lit_val_elim[where v=v2]; auto)

lemma binop_poly_type_correct:
 "\<lbrakk> binop_poly_type bop; binop_eval_val bop v1 v2 = Some v \<rbrakk> \<Longrightarrow> type_of_val A v = TPrim TBool"
  by (cases bop; rule lit_val_elim[where v=v1]; rule lit_val_elim[where v=v2]; auto)

text\<open>check whether the free variables of a type are at smaller than some value\<close>
fun wf_ty :: "nat \<Rightarrow> ty \<Rightarrow> bool"
  where
   "wf_ty n (TVar i) = (i < n)"
 | "wf_ty n (TPrim p) = True"
 | "wf_ty n (TCon tcon_id ty_args) = list_all (wf_ty n) ty_args"

primrec wf_expr :: "nat \<Rightarrow> expr \<Rightarrow> bool"
  where
    "wf_expr k (Var x) = True"
  | "wf_expr k (BVar i) = True"
  | "wf_expr k (Lit l) = True"
  | "wf_expr k (UnOp uop e) = wf_expr k e"
  | "wf_expr k (e1 \<guillemotleft>bop\<guillemotright> e2) = (wf_expr k e1 \<and> wf_expr k e2)"
  | "wf_expr k (FunExp f ty_args args) = ((list_all (wf_ty k) ty_args) \<and> (list_all (wf_expr k) args))"
  | "wf_expr k (CondExp cond e1 e2) = (wf_expr k cond \<and> wf_expr k e1 \<and> wf_expr k e2)"
  | "wf_expr k (Old e) = wf_expr k e"
  | "wf_expr k (Forall ty e) = ((wf_ty k ty) \<and> (wf_expr k e))"
  | "wf_expr k (Exists ty e) = ((wf_ty k ty) \<and> (wf_expr k e))"
  | "wf_expr k (ExistsT e) = (wf_expr (k+1) e)"
  | "wf_expr k (ForallT e) = (wf_expr (k+1) e)"

text \<open>A function declaration is well-formed, if the free type variables in the specified types are
captured by the type parameters of the function\<close>

fun wf_fdecl :: "(nat \<times> ty list \<times> ty) \<Rightarrow> bool"
  where
    "wf_fdecl (n, args_ty, ret_ty) = ((list_all (wf_ty n) args_ty) \<and> (wf_ty n ret_ty))"

lemma closed_instantiate: "list_all closed \<Omega> \<Longrightarrow> wf_ty (length \<Omega>) \<tau> \<Longrightarrow> closed (instantiate \<Omega> \<tau>)"
  by (induction \<tau>) (auto simp: list_all_iff)

lemma msubst_msubst:
  assumes "wf_ty (length ts2) t" and
          "list_all (wf_ty (length ts1)) ts2" and
          "list_all closed ts1"
  shows "msubstT ts1 (msubstT ts2 t) = msubstT (map (msubstT ts1) ts2) t"
  using assms
  oops

lemma instantiate_msubst_opt:
  assumes "wf_ty (length ts) \<tau>"
  shows "instantiate \<Omega> (msubstT_opt ts \<tau>) = instantiate (map (instantiate \<Omega>) ts) \<tau>"
  using assms
proof (induction \<tau>)
  case (TVar x)
  hence "x < length ts" by simp
  hence "msubstT_opt ts (TVar x) = ts ! x" by (simp add: msubstT_opt_def)
  thus ?case using \<open>x < length ts\<close> by simp
next
  case (TPrim x)
  then show ?case by (simp add: msubstT_opt_def)
next
  case (TCon x1a x2a)
  thus ?case
  apply (simp add: msubstT_opt_def)
  by (metis (no_types, lifting) in_set_conv_nth list_all_length)
qed

lemma map_of_list_all:
  assumes Map:"map_of xs k = Some x" and
          Pred:"list_all (P \<circ> snd) xs"
  shows "P x"
proof -
  from Map obtain i where "(i,x) \<in> set xs"
    by (meson map_of_SomeD)
  with Pred show ?thesis
    by (metis comp_apply in_set_conv_nth list_all_length snd_conv)
qed

lemma map_map:
  assumes "map f (map g xs) = ys"
  shows "map (f \<circ> g) xs = ys"
  using assms
  by auto

definition state_well_typed :: "'a absval_ty_fun \<Rightarrow> var_context \<Rightarrow> rtype_env \<Rightarrow> 'a nstate \<Rightarrow> bool"
  where "state_well_typed A \<Lambda> \<Omega> ns \<equiv>
         state_typ_wf A \<Omega> (local_state ns) (snd \<Lambda>) \<and>
         state_typ_wf A \<Omega> (global_state ns) (fst \<Lambda>) \<and>
         state_typ_wf A \<Omega> (old_global_state ns) (fst \<Lambda>) \<and>
         (binder_state ns = Map.empty)"

lemma state_well_typed_lookup:
  assumes "state_well_typed A \<Lambda> \<Omega> ns" and
          "lookup_var_ty \<Lambda> x = Some \<tau>"
        shows "\<exists>v. lookup_var \<Lambda> ns x = Some v \<and>type_of_val A v = instantiate \<Omega> \<tau>"
  using assms
  unfolding state_well_typed_def
  using state_typ_wf_lookup lookup_var_ty_decl_Some
  by blast

lemma state_well_typed_lookup_old:
  assumes "state_well_typed A \<Lambda> \<Omega> ns" and
          "lookup_var_ty \<Lambda> x = Some \<tau>"
  shows "\<exists>v. lookup_var \<Lambda> (ns\<lparr>global_state := old_global_state ns\<rparr>) x = Some v \<and> type_of_val A v = instantiate \<Omega> \<tau>"
  apply (rule state_typ_wf_lookup)
  using assms
  unfolding state_well_typed_def
  by auto

lemma old_global_switch_wt:
  assumes "state_well_typed A \<Lambda> \<Omega> n_s"
  shows "state_well_typed A \<Lambda> \<Omega> (n_s\<lparr>global_state := old_global_state n_s\<rparr>)"
  using assms
  unfolding state_well_typed_def
  by simp

text \<open>Type preservation theorem\<close>

theorem preservation:
  assumes
          "list_all closed \<Omega>" and
          "\<forall> k \<tau>'. ((fst \<Delta>) k = Some \<tau>') \<longrightarrow> (\<exists>v. (lookup_var \<Lambda> n_s k = Some v) \<and> type_of_val A v = instantiate \<Omega> \<tau>')" and
          "\<forall> k \<tau>'. ((fst \<Delta>) k = Some \<tau>') \<longrightarrow> (\<exists>v. (lookup_var \<Lambda> (n_s\<lparr>global_state := old_global_state n_s\<rparr>) k = Some v) \<and> type_of_val A v = instantiate \<Omega> \<tau>')" and
          "\<forall> i \<tau>'. ((snd \<Delta>) i = Some \<tau>') \<longrightarrow> (\<exists>v. binder_state n_s i = Some v \<and> type_of_val A v = instantiate \<Omega> \<tau>')" and
          Wf_\<Gamma>:"fun_interp_wf A F \<Gamma>" and
          Wf_F:"list_all (wf_fdecl \<circ> snd) F"
  shows "F, \<Delta> \<turnstile> e : \<tau> \<Longrightarrow> wf_expr (length \<Omega>) e \<Longrightarrow> A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e,n_s\<rangle> \<Down> v \<Longrightarrow> type_of_val A v = instantiate \<Omega> \<tau>" and
        "F, \<Delta> \<turnstile> es [:] ts \<Longrightarrow> list_all (wf_expr (length \<Omega>)) es \<Longrightarrow> A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>es,n_s\<rangle> [\<Down>] vs \<Longrightarrow>
          map (type_of_val A) vs = (map (instantiate \<Omega>) ts)"
  using assms
proof (induction arbitrary: v n_s \<Omega> and vs n_s \<Omega> rule: typing_typing_list.inducts)
  case (TypVar \<Delta> x ty)
  then show ?case by fastforce
next
  case (TypBVar \<Delta> x ty)
  then show ?case
    by (metis RedBVar expr_eval_determ(1))
next
case (TypPrim l prim_ty \<Delta>)
  then show ?case by fastforce
next
  case (TypUnOp \<Delta> e arg_ty uop ret_ty)
  from this obtain v' where
     "A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e,n_s\<rangle> \<Down> v'" and "unop_eval_val uop v' = Some v" by auto
  moreover from this have "type_of_val A v' = TPrim arg_ty" using TypUnOp by auto
  ultimately show ?case using \<open>unop_type uop arg_ty = Some ret_ty\<close> unop_type_correct by fastforce
next
  case (TypBinOpMono bop targs ret_ty \<Delta> e1 left_ty e2 right_ty)
  from this obtain v1 v2 where
     "A, \<Lambda>, \<Gamma>, \<Omega> \<turnstile> \<langle>e1, n_s\<rangle> \<Down> v1" and "A, \<Lambda>, \<Gamma>, \<Omega> \<turnstile> \<langle>e2, n_s\<rangle> \<Down> v2" and
     E:"binop_eval_val bop v1 v2 = Some v"
    by auto
  moreover from this have T1:"type_of_val A v1 = TPrim left_ty" and
    T2:"type_of_val A v2 = TPrim right_ty" using TypBinOpMono by auto
  ultimately show ?case using \<open>(left_ty, right_ty) \<in> targs\<close> \<open>binop_type bop = Some (targs, ret_ty)\<close> binop_type_correct
    using TypBinOpMono.hyps(2)
    by fastforce
next
  case (TypBinopPoly bop \<Delta> e1 ty1 e2 ty2 ty_inst)
  from this obtain v1 v2 where
     E:"binop_eval_val bop v1 v2 = Some v" by auto
  thus ?case using  \<open>binop_poly_type bop\<close> binop_poly_type_correct by fastforce
next
  case (TypFunExp f n_ty_params args_ty ret_ty ty_params args \<Delta>)
  from this obtain vargs fi where
     RedArgs:"A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>args, n_s\<rangle> [\<Down>] vargs" and Mem\<Gamma>:"\<Gamma> f = Some fi" and
    "fi (map (instantiate \<Omega>) ty_params) vargs = Some v"
    by auto
  with TypFunExp have FunSingleWf:"fun_interp_single_wf A (n_ty_params, args_ty, ret_ty) fi"
    using fun_interp_wf_def by (metis (mono_tags, lifting) option.inject)
  have A1:"length (map (instantiate \<Omega>) ty_params) = n_ty_params" using TypFunExp
    using length_map by simp
  have Wf_args_ty:"list_all (wf_ty n_ty_params) args_ty" using Wf_F \<open>map_of F f = Some (n_ty_params, args_ty, ret_ty)\<close>
    by (meson map_of_list_all wf_fdecl.simps)
  have Wf_ret_ty:"wf_ty n_ty_params ret_ty" using Wf_F \<open>map_of F f = Some (n_ty_params, args_ty, ret_ty)\<close>
    by (meson map_of_list_all wf_fdecl.simps)
  have A3:"length vargs = length args_ty"
    using RedArgs TypFunExp.hyps(2) red_exprs_length by fastforce
  have A4:"list_all closed (map (instantiate \<Omega>) ty_params)"
    using TypFunExp.prems(1) TypFunExp.prems(3) closed_instantiate wf_ty.simps(3) by fastforce
  have "list_all (wf_expr (length \<Omega>)) args" using TypFunExp by simp
  have InstMSubst:"(map (instantiate \<Omega>) (map (msubstT_opt ty_params) args_ty)) = map (instantiate (map (instantiate \<Omega>) ty_params)) args_ty"
    using Wf_args_ty \<open>length ty_params = n_ty_params\<close>
    apply simp
    apply rule
    apply (rule instantiate_msubst_opt)
    by (simp add: list.pred_set)
  have
   "map (type_of_val A) vargs = (map (instantiate \<Omega>) (map (msubstT_opt ty_params) args_ty))"
    using RedArgs TypFunExp \<open>list_all (wf_expr (length \<Omega>)) args\<close>
    using Wf_F by blast
  hence "type_of_val A v = instantiate (map (instantiate \<Omega>) ty_params) ret_ty"
    apply (simp only: InstMSubst)
    using FunSingleWf A1 A3 A4
    apply auto
    by (metis (no_types, lifting) A1 \<open>fi (map (instantiate \<Omega>) ty_params) vargs = Some v\<close> option.inject)
  thus ?case using TypFunExp.IH(1)
    by (simp add: TypFunExp.hyps(1) Wf_ret_ty instantiate_msubst_opt)
next
  case (TypCondExp \<Delta> cond thn ty els)
  thus ?case by auto
next
  case (TypOld \<Delta> e ty)
  from TypOld have RedE:"A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e, n_s\<lparr>global_state := old_global_state n_s \<rparr>\<rangle> \<Down> v" by auto
  show ?case
    apply (rule TypOld.IH(2))
    using TypOld.prems apply simp
          apply (rule RedE)
    using TypOld.prems by auto
next
  case (TypForall \<Delta> ty e)
  then show ?case by (auto dest: forall_red)
next
case (TypExists \<Delta> ty e)
  then show ?case by (auto dest: exists_red)
next
  case (TypForallT \<Delta> e)
  then show ?case using msubst_ty_forallT by (auto dest: forallt_red_bool)
next
  case (TypExistsT \<Delta> e)
  then show ?case using msubst_ty_existsT by (auto dest: existst_red_bool)
next
  case (TypListNil \<Delta>)
  then show ?case by auto
next
  case (TypListCons \<Delta> e ty es tys)
  from \<open>A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>(e # es),n_s\<rangle> [\<Down>] vs\<close> have A0:"A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e, n_s\<rangle> \<Down> hd vs"
    using cons_exp_elim by blast
  moreover from \<open>A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>(e # es),n_s\<rangle> [\<Down>] vs\<close> have "A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>es, n_s\<rangle> [\<Down>] tl vs"
   using cons_exp_elim by blast
  with A0 TypListCons have A1:"type_of_val A (hd vs) = instantiate \<Omega> ty" and
                        A2:"map (type_of_val A) (tl vs) = map (instantiate \<Omega>) tys" by auto
  moreover have "(hd vs) # (tl vs) = vs" using \<open>A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>(e # es),n_s\<rangle> [\<Down>] vs\<close>
      using cons_exp_elim list.collapse by blast
  ultimately show ?case
    by (metis list.simps(9))
qed

lemma instantiate_shift: "wf_ty (length \<Omega>) \<tau> \<Longrightarrow> instantiate (t#\<Omega>) (shiftT 1 0 \<tau>) = instantiate \<Omega> \<tau>"
  by (induction \<tau>) (auto simp add: list_all_iff)

lemma instantiate_shift_wf: "wf_ty (length \<Omega>) \<tau> \<Longrightarrow> wf_ty (Suc (length \<Omega>)) (shiftT 1 0 \<tau>)"
  by (induction \<tau>) (auto simp add: list_all_iff)

lemma lookup_only_local_global:
  assumes "local_state ns = local_state ns'" and
          "global_state ns = global_state ns'"
  shows "lookup_var \<Lambda> ns x = lookup_var \<Lambda> ns' x"
  using assms
  by (metis lookup_var_def)

(* TODO: find a better solution *)
lemma helper_lemma_old_state:
  assumes "\<forall>k \<tau>. M k = Some \<tau> \<longrightarrow> (\<exists>v. lookup_var \<Lambda> (n_s\<lparr>global_state := old_global_state n_s\<rparr>) k = Some v \<and> type_of_val A v = instantiate \<Omega> \<tau>)"
  shows "  \<forall>k \<tau>. M k = Some \<tau> \<longrightarrow>
                (\<exists>v. lookup_var \<Lambda> ((full_ext_env n_s w)\<lparr>global_state := old_global_state (full_ext_env n_s w)\<rparr>) k = Some v \<and> type_of_val A v = instantiate \<Omega> \<tau>)"
proof (rule allI, rule allI, rule impI)
  fix k \<tau>
  assume "M k = Some \<tau>"
  from this obtain v where Lookup:"lookup_var \<Lambda> (n_s\<lparr>global_state := old_global_state n_s\<rparr>) k = Some v" and Typ:"type_of_val A v = instantiate \<Omega> \<tau>" using assms
    by auto
  have Aux1:"old_global_state (full_ext_env n_s w) = old_global_state n_s"
    by simp
  have Aux2:"\<And>n_s gs. lookup_var \<Lambda> ((full_ext_env n_s w)\<lparr>global_state := gs\<rparr>) k = lookup_var \<Lambda> (n_s\<lparr>global_state := gs\<rparr>) k"
    apply (rule lookup_only_local_global)
     apply simp
    apply simp
    done
  show "(\<exists>v. lookup_var \<Lambda> ((full_ext_env n_s w)\<lparr>global_state := old_global_state (full_ext_env n_s w)\<rparr>) k = Some v \<and> type_of_val A v = instantiate \<Omega> \<tau>)"
    apply (rule exI[where ?x=v])
    apply (rule conjI)
     apply (simp only: Aux1)
     apply (simp add: Aux2 del: full_ext_env.simps)
     apply (rule Lookup)
    apply (rule Typ)
    done
qed

text \<open>Type progress theorem\<close>

theorem progress:
  assumes
          Closed_\<Omega>:"list_all closed \<Omega>" and
          "\<forall> k \<tau>'. ((fst \<Delta>) k = Some \<tau>') \<longrightarrow> wf_ty (length \<Omega>) \<tau>'" and
          "\<forall> i \<tau>'. ((snd \<Delta>) i = Some \<tau>') \<longrightarrow> wf_ty (length \<Omega>) \<tau>'" and
          "\<forall> k \<tau>'. ((fst \<Delta>) k = Some \<tau>') \<longrightarrow> (\<exists>v. (lookup_var \<Lambda> n_s k = Some v) \<and> type_of_val A v = instantiate \<Omega> \<tau>')"
          "\<forall> k \<tau>'. ((fst \<Delta>) k = Some \<tau>') \<longrightarrow> (\<exists>v. (lookup_var \<Lambda> (n_s\<lparr>global_state := old_global_state n_s\<rparr>) k = Some v) \<and> type_of_val A v = instantiate \<Omega> \<tau>')" and
          "\<forall> i \<tau>'. ((snd \<Delta>) i = Some \<tau>') \<longrightarrow> (\<exists>v. binder_state n_s i = Some v \<and> type_of_val A v = instantiate \<Omega> \<tau>')" and
          Wf_\<Gamma>:"fun_interp_wf A F \<Gamma>" and
          Wf_F:"list_all (wf_fdecl \<circ> snd) F"
  shows "F, \<Delta> \<turnstile> e : \<tau> \<Longrightarrow> wf_expr (length \<Omega>) e \<Longrightarrow>  \<exists>v. A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e,n_s\<rangle> \<Down> v" and
        "F, \<Delta> \<turnstile> es [:] ts \<Longrightarrow> list_all (wf_expr (length \<Omega>)) es \<Longrightarrow>  \<exists>vs. A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>es,n_s\<rangle> [\<Down>] vs"
  using assms
proof (induction arbitrary: n_s \<Lambda> \<Omega> and n_s \<Lambda> \<Omega> rule: typing_typing_list.inducts)
case (TypVar \<Delta> x ty)
  show ?case
    apply (rule exI[where ?x="the (lookup_var \<Lambda> n_s x)"])
    using TypVar(2)
    by (metis RedVar TypVar.hyps TypVar.prems(5) option.distinct(1) option.exhaust_sel)
next
case (TypBVar \<Delta> x ty)
  show ?case
    apply (rule exI[where ?x="the (binder_state n_s x)"])
    using TypBVar(2)
    by (metis RedBVar TypBVar.hyps TypBVar.prems(7) option.distinct(1) option.exhaust_sel)
next
  case (TypPrim l prim_ty \<Delta>)
  then show ?case by (auto intro: RedLit)
next
  case (TypUnOp \<Delta> e arg_ty uop ret_ty)
  have "\<exists>a. A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e,n_s\<rangle> \<Down> a"
     apply (rule TypUnOp.IH) using TypUnOp.prems by auto
  from this obtain v' where RedE:"A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e,n_s\<rangle> \<Down> v'" by auto
  hence "type_of_val A v' = TPrim arg_ty"
    using TypUnOp preservation(1)[OF \<open>list_all closed \<Omega>\<close> TypUnOp.prems(5) TypUnOp.prems(6) TypUnOp.prems(7) Wf_\<Gamma> Wf_F]
    by fastforce
  thus ?case using \<open>unop_type uop arg_ty = Some ret_ty\<close> unop_progress RedE RedUnOp
    by (metis (full_types))
next
  case (TypBinOpMono bop targs ret_ty \<Delta> e1 left_ty e2 right_ty)
  have "\<exists>a. A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e1,n_s\<rangle> \<Down> a"
    apply (rule TypBinOpMono.IH) using TypBinOpMono.prems by auto
  moreover have "\<exists>a. A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e2,n_s\<rangle> \<Down> a"
    apply (rule TypBinOpMono.IH) using TypBinOpMono.prems by auto
  ultimately  obtain v1 v2 where RedLeft:"A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e1,n_s\<rangle> \<Down> v1" and  RedRight:"A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e2,n_s\<rangle> \<Down> v2"
    by auto
  moreover from RedLeft have "type_of_val A v1 = TPrim left_ty"
    using TypBinOpMono.IH TypBinOpMono.prems preservation(1)[OF \<open>list_all closed \<Omega>\<close> TypBinOpMono.prems(5) TypBinOpMono.prems(6) TypBinOpMono.prems(7) Wf_\<Gamma> Wf_F]
    by fastforce
  moreover from RedRight have "type_of_val A v2 = TPrim right_ty"
    using TypBinOpMono.IH TypBinOpMono.prems preservation(1)[OF \<open>list_all closed \<Omega>\<close> TypBinOpMono.prems(5) TypBinOpMono.prems(6) TypBinOpMono.prems(7) Wf_\<Gamma> Wf_F]
    by fastforce
  ultimately show ?case using \<open>binop_type bop = Some (targs, ret_ty)\<close> \<open>(left_ty, right_ty) \<in> targs\<close> binop_progress RedBinOp
    by metis
next
  case (TypBinopPoly bop \<Delta> e1 ty1 e2 ty2 ty_inst)
  have "\<exists>a. A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e1,n_s\<rangle> \<Down> a"
    apply (rule TypBinopPoly.IH) using TypBinopPoly.prems by auto
  moreover have "\<exists>a. A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e2,n_s\<rangle> \<Down> a"
    apply (rule TypBinopPoly.IH) using TypBinopPoly.prems by auto
  ultimately  obtain v1 v2 where RedLeft:"A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e1,n_s\<rangle> \<Down> v1" and  RedRight:"A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e2,n_s\<rangle> \<Down> v2"
    by auto
  show ?case
    apply (cases bop; rule exI; rule RedBinOp[OF RedLeft RedRight])
    using \<open>binop_poly_type bop\<close> by auto
next
  case (TypFunExp f n_ty_params args_ty ret_ty ty_params args \<Delta>)
  have "\<exists>vargs. A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>args, n_s\<rangle> [\<Down>] vargs"
    apply (rule TypFunExp.IH)
    using TypFunExp.prems by auto
  from this obtain vargs where
     RedArgs:"A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>args, n_s\<rangle> [\<Down>] vargs" by fastforce
  have Wf_args_ty:"list_all (wf_ty n_ty_params) args_ty" using Wf_F \<open>map_of F f = Some (n_ty_params, args_ty, ret_ty)\<close>
    by (meson map_of_list_all wf_fdecl.simps)
  have InstMSubst:"(map (instantiate \<Omega>) (map (msubstT_opt ty_params) args_ty)) = map (instantiate (map (instantiate \<Omega>) ty_params)) args_ty"
    using Wf_args_ty \<open>length ty_params = n_ty_params\<close>
    apply simp
    apply rule
    apply (rule instantiate_msubst_opt)
    by (simp add: list.pred_set)
  from \<open>map_of F f = Some (n_ty_params, args_ty, ret_ty)\<close> Wf_\<Gamma> obtain fi where
       Mem: "\<Gamma> f = Some fi" and
       FunSingleWf:"fun_interp_single_wf A (n_ty_params, args_ty, ret_ty) fi"
    using fun_interp_wf_def by blast
  from RedArgs have
    "map (type_of_val A) vargs = map (instantiate \<Omega>) (map (msubstT_opt ty_params) args_ty)"
    using preservation(2)[OF \<open>list_all closed \<Omega>\<close> TypFunExp.prems(5) TypFunExp.prems(6) TypFunExp.prems(7) Wf_\<Gamma> Wf_F] TypFunExp.prems TypFunExp.IH
    by auto
  hence "map (type_of_val A) vargs = map (instantiate (map (instantiate \<Omega>) ty_params)) args_ty"
    by (simp only: InstMSubst)
  moreover from \<open>length args = length args_ty\<close> and RedArgs have "length vargs = length args_ty"
    using red_exprs_length by fastforce
  moreover have "list_all closed (map (instantiate \<Omega>) ty_params)"
    using TypFunExp.prems(1) \<open>list_all closed \<Omega>\<close> closed_instantiate wf_ty.simps(3) by fastforce
  ultimately have "\<exists>v. fi (map (instantiate \<Omega>) ty_params) vargs = Some v" using FunSingleWf \<open>length ty_params = n_ty_params\<close>
    fun_interp_single_wf.simps length_map by blast
  with RedArgs show ?case by (metis Mem RedFunOp)
next
  case (TypCondExp \<Delta> cond thn ty els)
  hence RedCond: "\<exists>v. A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>cond,n_s\<rangle> \<Down> v" and
        RedThn: "\<exists>v. A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>thn,n_s\<rangle> \<Down> v" and
        RedElse: "\<exists>v. A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>els,n_s\<rangle> \<Down> v"
    by auto

  moreover from RedCond obtain b where
       "A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>cond,n_s\<rangle> \<Down> BoolV b"
    using preservation(1)[OF \<open>list_all closed \<Omega>\<close> TypCondExp.prems(5) TypCondExp.prems(6) TypCondExp.prems(7)
                             Wf_\<Gamma> Wf_F \<open>F,\<Delta> \<turnstile> cond : TPrim TBool\<close>]
          \<open>wf_expr _ _\<close>
    by (metis instantiate.simps(2) type_of_val_bool_elim wf_expr.simps(7))

  ultimately show ?case
    by (metis (full_types) RedCondExpFalse RedCondExpTrue)
next
  case (TypOld \<Delta> e ty)
  have "\<exists>a. A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e,n_s\<lparr>global_state := old_global_state n_s\<rparr>\<rangle> \<Down> a"
    apply (rule TypOld.IH)
    using TypOld.prems by auto
  thus ?case
    by (auto intro: RedOld)
next
  case (TypForall \<Delta> ty e)
  have lookup_ext_1: "\<And>ns w. (old_global_state (full_ext_env ns w)) = old_global_state ns"
    by simp
  thm TypForall.IH(2)
  let ?ns'f = "\<lambda>w. full_ext_env n_s w"

  have lookup_aux:"\<And> b x. lookup_var \<Lambda> (n_s\<lparr> binder_state := b \<rparr>) x  = lookup_var \<Lambda> n_s x"  by (simp only: lookup_var_binder_upd)

  have AuxOld:"\<And>w. \<forall>k \<tau>'. fst (fst \<Delta>, ext_env (snd \<Delta>) ty) k = Some \<tau>' \<longrightarrow>
           (\<exists>v. lookup_var \<Lambda> ((full_ext_env n_s w)\<lparr>global_state := old_global_state (full_ext_env n_s w)\<rparr>) k = Some v \<and> type_of_val A v = instantiate \<Omega> \<tau>')"
    apply (rule helper_lemma_old_state)
    using TypForall.prems(6) apply simp
    done
  have RedBody:"\<And>w. type_of_val A w = instantiate \<Omega> ty \<Longrightarrow> \<exists>v'. A, \<Lambda>, \<Gamma>, \<Omega> \<turnstile> \<langle>e, ?ns'f w\<rangle> \<Down> v'"
    apply (rule TypForall.IH(2)[OF _ _ _ _ _ AuxOld])
    using TypForall.prems lookup_aux by auto

  have EnvCorres:"\<And>w. type_of_val A w = instantiate \<Omega> ty \<Longrightarrow> \<forall>k \<tau>'. (snd (fst \<Delta>, ext_env (snd \<Delta>) ty)) k = Some \<tau>' \<longrightarrow>
                (\<exists>v. binder_state (full_ext_env n_s w) k = Some v \<and> type_of_val A v = instantiate \<Omega> \<tau>')"
    using TypForall.prems(7)
    by simp
  have RedBodyTy:"\<And>w v'. type_of_val A w = instantiate \<Omega> ty \<Longrightarrow> A, \<Lambda>, \<Gamma>, \<Omega> \<turnstile> \<langle>e, full_ext_env n_s w\<rangle> \<Down> v' \<Longrightarrow>
        type_of_val A v' = TPrim TBool"
    using preservation(1)[OF \<open>list_all closed \<Omega>\<close> _ AuxOld EnvCorres Wf_\<Gamma> Wf_F _ _ ]
          TypForall.IH(1) TypForall.prems
    by (metis fst_conv instantiate.simps(2) lookup_full_ext_env_same wf_expr.simps(9))
  show ?case
  proof (cases "\<forall> w. type_of_val A w = instantiate \<Omega> ty \<longrightarrow> A, \<Lambda>, \<Gamma>, \<Omega> \<turnstile> \<langle>e, full_ext_env n_s w\<rangle> \<Down> LitV (LBool True)")
    case True
    show ?thesis
      using RedForAllTrue True by blast
  next
    case False
    from this obtain w where
       "type_of_val A w = instantiate \<Omega> ty" and "\<not> (A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e, full_ext_env n_s w\<rangle> \<Down> LitV (LBool True))"
      by auto
    moreover from this RedBody RedBodyTy obtain w' where "A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e, full_ext_env n_s w\<rangle> \<Down> w'"
      and "type_of_val A w' = TPrim (TBool)"
    by fastforce
    ultimately show ?thesis
      by (metis (full_types) RedForAllFalse type_of_val_bool_elim)
  qed
next
  case (TypExists \<Delta> ty e)
  (*  proof is almost identical to TypForall, TODO: re-use proof *)
  have lookup_aux:"\<And> b x. lookup_var \<Lambda> (n_s\<lparr> binder_state := b \<rparr>) x  = lookup_var \<Lambda> n_s x"  by (simp only: lookup_var_binder_upd)
    have AuxOld:"\<And>w. \<forall>k \<tau>'. fst (fst \<Delta>, ext_env (snd \<Delta>) ty) k = Some \<tau>' \<longrightarrow>
           (\<exists>v. lookup_var \<Lambda> ((full_ext_env n_s w)\<lparr>global_state := old_global_state (full_ext_env n_s w)\<rparr>) k = Some v \<and> type_of_val A v = instantiate \<Omega> \<tau>')"
    apply (rule helper_lemma_old_state)
    using TypExists.prems(6) apply simp
    done
  have RedBody:"\<And>w. type_of_val A w = instantiate \<Omega> ty \<Longrightarrow> \<exists>v'. A, \<Lambda>, \<Gamma>, \<Omega> \<turnstile> \<langle>e, full_ext_env n_s w\<rangle> \<Down> v'"
    apply (rule TypExists.IH(2)[OF _ _ _ _ _ AuxOld])
    using TypExists.prems lookup_aux by auto
  have EnvCorres:"\<And>w. type_of_val A w = instantiate \<Omega> ty \<Longrightarrow> \<forall>k \<tau>'. (snd (fst \<Delta>, ext_env (snd \<Delta>) ty)) k = Some \<tau>' \<longrightarrow>
                (\<exists>v. binder_state (full_ext_env n_s w) k = Some v \<and> type_of_val A v = instantiate \<Omega> \<tau>')"
    using TypExists.prems(7)
    by simp
  have RedBodyTy:"\<And>w v'. type_of_val A w = instantiate \<Omega> ty \<Longrightarrow> A, \<Lambda>, \<Gamma>, \<Omega> \<turnstile> \<langle>e, full_ext_env n_s w\<rangle> \<Down> v' \<Longrightarrow>
        type_of_val A v' = TPrim TBool"
    using preservation(1)[OF \<open>list_all closed \<Omega>\<close> _ AuxOld EnvCorres Wf_\<Gamma> Wf_F]
          TypExists.IH(1) TypExists.prems
    by (metis fst_conv instantiate.simps(2) lookup_full_ext_env_same wf_expr.simps(10))
  show ?case
  proof (cases "\<forall> w. type_of_val A w = instantiate \<Omega> ty \<longrightarrow> A, \<Lambda>, \<Gamma>, \<Omega> \<turnstile> \<langle>e, full_ext_env n_s w\<rangle> \<Down> LitV (LBool False)")
    case True
    show ?thesis
      using RedExistsFalse True by blast
  next
    case False
    from this obtain w where
       "type_of_val A w = instantiate \<Omega> ty" and "\<not> (A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e, full_ext_env n_s w\<rangle> \<Down> LitV (LBool False))"
      by auto
    moreover from this RedBody RedBodyTy obtain w' where "A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e, full_ext_env n_s w\<rangle> \<Down> w'"
      and "type_of_val A w' = TPrim (TBool)"
    by fastforce
    ultimately show ?thesis
      by (metis (full_types) RedExistsTrue type_of_val_bool_elim)
  qed
next
  case (TypForallT \<Delta> e)
  have RedBody:"\<And>t. closed t \<Longrightarrow> (\<exists>v. A,\<Lambda>,\<Gamma>,t#\<Omega> \<turnstile> \<langle>e, n_s\<rangle> \<Down> v)"
    apply (rule TypForallT.IH)
    using TypForallT.prems apply simp_all
    using instantiate_shift_wf apply fastforce
    using instantiate_shift_wf apply fastforce
    using instantiate_shift apply auto
    done

  have Closed\<Omega>Ext: "\<And>t. closed t \<Longrightarrow> list_all closed (t#\<Omega>)"
    using \<open>list_all closed \<Omega>\<close> by simp

  have RedBodyTy:"\<And>t v. closed t \<Longrightarrow> A,\<Lambda>,\<Gamma>, t#\<Omega> \<turnstile> \<langle>e, n_s\<rangle> \<Down> v \<Longrightarrow> type_of_val A v = instantiate (t#\<Omega>) (TPrim TBool)"
    apply (rule preservation(1)[where ?\<Delta>="(shift_env 1 0 (fst \<Delta>), shift_env 1 0 (snd \<Delta>))" and ?n_s="n_s"])
          apply (simp add: \<open>list_all closed \<Omega>\<close>)
    using TypForallT.prems instantiate_shift
          apply fastforce
    using TypForallT.prems instantiate_shift
          apply fastforce
    using TypForallT.prems instantiate_shift
         apply fastforce
        apply (rule Wf_\<Gamma>)
        apply (rule Wf_F)
      apply (rule TypForallT.IH(1))
    using TypForallT.prems apply simp_all
   done
  show ?case
  proof (cases "\<forall>t. closed t \<longrightarrow> A,\<Lambda>,\<Gamma>,t#\<Omega> \<turnstile> \<langle>e, n_s\<rangle> \<Down> LitV (LBool True)")
    case True
    show ?thesis
      using RedForallT_True True by blast
  next
    case False
    from this obtain t where "closed t" and "\<not>(A,\<Lambda>,\<Gamma>,t#\<Omega> \<turnstile> \<langle>e, n_s\<rangle> \<Down> LitV (LBool True))" by auto
    moreover from this RedBody RedBodyTy obtain w' where "A,\<Lambda>,\<Gamma>,(t#\<Omega>) \<turnstile> \<langle>e, n_s\<rangle> \<Down> w'"
      and "type_of_val A w' = TPrim (TBool)" by fastforce
    ultimately show ?thesis
      by (metis (full_types) RedForallT_False type_of_val_bool_elim)
  qed
next
  case (TypExistsT \<Delta> e)
  (* proof is almost identical to TypForallT, TODO: re-use proof *)

  have RedBody:"\<And>t. closed t \<Longrightarrow> (\<exists>v. A,\<Lambda>,\<Gamma>,t#\<Omega> \<turnstile> \<langle>e, n_s\<rangle> \<Down> v)"
    apply (rule TypExistsT.IH)
    using TypExistsT.prems
    apply simp_all
    using instantiate_shift_wf apply fastforce
    using instantiate_shift_wf apply fastforce
    using instantiate_shift by auto

  have Closed\<Omega>Ext: "\<And>t. closed t \<Longrightarrow> list_all closed (t#\<Omega>)"
    using \<open>list_all closed \<Omega>\<close> by simp

  have RedBodyTy:"\<And>t v. closed t \<Longrightarrow> A,\<Lambda>,\<Gamma>,t#\<Omega> \<turnstile> \<langle>e, n_s\<rangle> \<Down> v \<Longrightarrow> type_of_val A v = instantiate (t#\<Omega>) (TPrim TBool)"
    apply (rule preservation(1)[where ?\<Delta>="(shift_env 1 0 (fst \<Delta>), shift_env 1 0 (snd \<Delta>))" and ?n_s="n_s"])
          apply (simp add: \<open>list_all closed \<Omega>\<close>)
    using TypExistsT.prems instantiate_shift
          apply fastforce
    using TypExistsT.prems instantiate_shift
          apply fastforce
    using TypExistsT.prems instantiate_shift
         apply fastforce
        apply (rule Wf_\<Gamma>)
        apply (rule Wf_F)
      apply (rule TypExistsT.IH(1))
    using TypExistsT.prems apply simp_all
    done
  show ?case
  proof (cases "\<forall>t. closed t \<longrightarrow> A,\<Lambda>,\<Gamma>,t#\<Omega> \<turnstile> \<langle>e, n_s\<rangle> \<Down> LitV (LBool False)")
    case True
    show ?thesis
      using RedExistsT_False True by blast
  next
    case False
    from this obtain t where "closed t" and "\<not>(A,\<Lambda>,\<Gamma>,t#\<Omega> \<turnstile> \<langle>e, n_s\<rangle> \<Down> LitV (LBool False))" by auto
    moreover from this RedBody RedBodyTy obtain w' where "A,\<Lambda>,\<Gamma>,(t#\<Omega>) \<turnstile> \<langle>e, n_s\<rangle> \<Down> w'"
      and "type_of_val A w' = TPrim TBool" by fastforce
    ultimately show ?thesis
     by (metis (full_types) RedExistsT_True type_of_val_bool_elim)
  qed
next
  case (TypListNil \<Delta>)
  show ?case
    by (auto intro: RedExpListNil)
next
  case (TypListCons \<Delta> e ty es tys)
  hence "\<exists>v. A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e,n_s\<rangle> \<Down> v" and "\<exists>vs. A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>es,n_s\<rangle> [\<Down>] vs"
    by auto
  from this obtain v vargs where
      "A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e, n_s\<rangle> \<Down> v" and "A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>es, n_s\<rangle> [\<Down>] vargs" by auto
  thus ?case by (auto intro: RedExpListCons)
qed

text \<open>We combine type preservation and type progress to get a top-level type safety theorem\<close>

corollary type_safety_top_level:
  assumes "F, (lookup_var_ty \<Lambda>, Map.empty) \<turnstile> e : \<tau>" and
          ClosedEnv:"list_all closed \<Omega>" and
          Wf_\<Gamma>:"fun_interp_wf A F \<Gamma>" and
          Wf_\<Lambda>: "\<forall>x \<tau>. lookup_var_ty \<Lambda> x = Some \<tau> \<longrightarrow> wf_ty (length \<Omega>) \<tau>" and
          Wf_F:"list_all (wf_fdecl \<circ> snd) F" and
          State_wt:"state_well_typed A \<Lambda> \<Omega> n_s" and
          "wf_expr (length \<Omega>) e"
        shows "\<exists>v. (A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e,n_s\<rangle> \<Down> v) \<and> type_of_val A v = instantiate \<Omega> \<tau>"
proof -
  let ?\<Delta> = "(lookup_var_ty \<Lambda>, Map.empty)"
  have "\<exists>v. A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e,n_s\<rangle> \<Down> v"
    apply (rule progress[where ?\<Delta>="(lookup_var_ty \<Lambda>, Map.empty)"])
             apply (rule ClosedEnv)
    using Wf_\<Lambda> apply simp
           apply simp
    using state_well_typed_lookup[OF State_wt]
          apply simp
    using state_well_typed_lookup_old[OF State_wt]
         apply simp
        apply simp
    using assms
    by auto
  from this obtain v where RedE:"A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e,n_s\<rangle> \<Down> v"
    by auto
  moreover have "type_of_val A v = instantiate \<Omega> \<tau>"
    apply (rule preservation[where ?\<Delta>="(lookup_var_ty \<Lambda>, Map.empty)"])
    apply (rule ClosedEnv)
    using state_well_typed_lookup[OF State_wt]
    apply fastforce
    using state_well_typed_lookup_old[OF State_wt]
    apply fastforce
    using assms RedE by auto
  ultimately show ?thesis
    by auto
qed

end


section \<open>Two approaches that failed \label{sec:two-approaches-that}\<close>

(*<*) theory Failure imports RealRandVar begin (*>*)

text\<open>
Defining Lebesgue integration can be quite involved, judging by the
process in \ref{sec:stepwise-approach} that imitates Bauer's way
\<^cite>\<open>"Bauer"\<close>.  So it is quite tempting to try cutting a corner. The
following two alternative approaches back up my experience that this
almost never pays in formalization. The theory that seems most complex
at first sight is often the one that is closest to formal reasoning
and deliberately avoids ``hand-waving''.
\<close>

subsection \<open>A closed expression \label{sec:closed-expression}\<close>

text \<open>
  In contrast, Billingsley's definition \<^cite>\<open>\<open>p.~172\<close> in "Billingsley86"\<close> is
  strikingly short. For nonnegative measurable functions $f$:

  \begin{quote}

  $\int f d\mu = \mathit{sup} \sum_i \big[ \mathit{inf}_{\omega \in A_i} f(w) \big] \mu(A_i).$

  The supremum here extends over all finite decompositions $\{A_i\}$ of
  $\Omega$ into $\mathcal{F}$-sets.\footnote{The $\mathcal{F}$-sets are just the measurable sets of a measure
  space.}

  \end{quote}

  Like the definition, the proofs of the essential properties are also
  rather
  short, about three pages in the textbook for almost all the theorems
  in \ref{sec:stepwise-approach}; and a proof of uniqueness is obsolete
  for a closed expression like this. Therefore, I found this approach
  quite tempting. It turns out, however, that it is unfortunately not
  well suited for formalization, at least with the background we use.

  A complication shared by all possible styles of definition is the lack
  of infinite values in our theory, combined with the lack of partial
  functions in HOL. Like the sum operator in
  \ref{sec:measure-spaces}, the integral has to be defined
  indirectly. The classical way to do this employs predicates, invoking \<open>\<epsilon>\<close>
  to choose the value that satisfies the condition:

  \<open>\<integral> f dM \<equiv> (\<epsilon> i. is_integral M f i)\<close>

  To sensibly apply this principle, the predicate has to be \<open>\<epsilon>\<close>-free to supply the information if the integral is
  defined or not. Now the above definition contains up to three additional
  \<open>\<epsilon>\<close> when formalized naively in HOL, namely in the supremum,
  infimum and sum operators. The sum is over a finite set, so it can
  be replaced by a total function. For nonnegative functions, the
  infimum can also be shown to exist everywhere, but, like the
  supremum,  must
  itself be replaced by a predicate.

  Also note that predicates require a proof of uniqueness, thus losing
  the prime advantage of a closed formula anyway. In this case,
  uniqueness can be reduced to uniqueness of the supremum/infimum. The
  problem is that neither suprema nor infima come predefined in
  Isabelle/Isar as of yet. It is an easy task to make up for this ---
  and I did --- but a much harder one to establish all the properties
  needed for reasoning with the defined entities.

  A lot of such reasoning is necessary to deduce from the above definition
  (or a formal version of it, as just outlined) the basic behavior of
  integration, which includes additivity, monotonicity and especially the
  integral of simple functions. It turns out that the brevity of the
  proofs in the textbook stems from a severely informal style that
  assumes ample background knowledge. Formalizing all this knowledge
  started to become overwhelming when the idea of a contrarian approach
  emerged.
\<close>

subsection \<open>A one-step inductive definition \label{sec:one-step}\<close>

text \<open>
  This idea was sparked by the following note: ``(\ldots) the integral
  is uniquely determined by certain simple properties it is natural to
  require of it'' \<^cite>\<open>\<open>p.~175\<close> in "Billingsley86"\<close>. Billingsley goes on
  discussing exactly those properties that are so hard to derive
  from his definition. So why not simply define integration using
  these properties? That is the gist of an inductive set definition, like
  the one we have seen in \ref{sec:sigma}. This time a functional operator is
  to be defined, but it can be represented as a set of pairs, where
  the first component is the function and the second its integral.
  To cut a long story short, here is the definition.\<close>

inductive_set
  integral_set:: "('a set set * ('a set \<Rightarrow> real)) \<Rightarrow> (('a \<Rightarrow> real) * real) set"
  for M :: "'a set set * ('a set \<Rightarrow> real)"
  where
    char: "\<lbrakk>f = \<chi> A; A \<in> measurable_sets M\<rbrakk> \<Longrightarrow> (f,measure M A) \<in> integral_set M"
  | add: "\<lbrakk>f = (\<lambda>w. g w + h w); (g,x) \<in> integral_set M; (h,y) \<in> integral_set M\<rbrakk>
    \<Longrightarrow> (f,(x + y)) \<in> integral_set M"
  | times: "\<lbrakk>f = (\<lambda>w. a*g w); (g,x) \<in> integral_set M\<rbrakk> \<Longrightarrow> (f,a*x) \<in> integral_set M"
  | mon_conv: "\<lbrakk>u\<up>f; \<And>n. (u n, x n) \<in> integral_set M; x\<up>y\<rbrakk>
    \<Longrightarrow> (f,y) \<in> integral_set M"

  text \<open>The technique is also encountered in the \<open>Finite_Set\<close> theory from the Isabelle library. It is used there
    to define the \<open>sum\<close> function, which calculates a sum
    indexed over a finite set and is employed in
    \ref{sec:stepwise-approach}. The definition here is much more
    intricate though.

    An obvious advantage of this approach is that almost all
    important properties are gained without effort. The
    introduction rule \<open>mon_conv\<close> corresponds to what is known as
    the Monotone Convergence Theorem in scientific literature; negative functions are also provided for via
    the \<open>times\<close> rule.
    To be precise,
    there is exactly one important theorem missing ---
    uniqueness. That is, every function appears in at most one pair.

    From uniqueness together with the introduction rules, all the
    other statements about integration, monotonicity for example,
    could be derived. On the other hand, monotonicity implies
    uniqueness. Much to my regret, none of these two could be proven.
    The proof would basically amount to a double induction to show
    that an integral gained via one rule is the same when derived by
    another. A lot of effort was spent trying to strengthen the
    induction hypothesis or reduce the goal to a simpler case. All of
    this was in vain though, and it seems that the hypothesis would
    have to be strengthened as far as to include the concept of
    integration in the first place, which in a way defeats the
    advantages of the approach.\<close>

  (*<*)end  (*>*)


(* @SUITE modules *)

theory "moduletype"
imports "../Modules"
begin

declare[[show_types,show_sorts]]
moduletype MT1 where
  f1 :: "(int*unit,string) procedure"
and f2 :: "(bool*unit,real) procedure"

print_theorems

(* Checking constants *)
term "MT1::module_type"
term "MT1.f1 :: module \<Rightarrow> (int*unit,string) procedure"
term "MT1.f2 :: module \<Rightarrow> (bool*unit,real) procedure"

(* Checking lemmas *)
lemma "has_module_type (M\<Colon>module) MT1 \<Longrightarrow>
    get_proc_in_module M [''f1''] =
    Some (mk_procedure_untyped (MT1.f1 M))"
    by (rule MT1.f1)

lemma "has_module_type (M\<Colon>module) MT1 \<Longrightarrow>
    get_proc_in_module M [''f2''] =
    Some (mk_procedure_untyped (MT1.f2 M))"
    by (rule MT1.f2)

moduletype MT2(M1:MT1) where
  g1 :: "(int*unit,string) procedure"
and g2 :: "(bool*unit,real) procedure"

print_theorems

term "MT2::module_type"
(* TODO: getters *)

(* TODO: check getter lemmas *)

end