(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)

theory ArchVSpaceLookup_AI
imports
  SubMonad_AI
  "Lib.Crunch_Instances_NonDet"
begin

definition
  "lookup_walk cs m ref p \<equiv> {(r, q). \<exists>h. ref = h @ r \<and> (r, q) \<in> cs\<^sup>* `` m \<and> (([], q),h, p) \<in> cs\<^sup>*}"

definition
  "trans_depends kh cs f \<equiv> \<forall>q h p. (([],q),h,p) \<in> cs = (\<exists>obj. obj = kh q \<and> f obj p h)"

definition
  "lookup_leaf ptr cs =  {(ref,p). (([],ptr),ref, p) \<in> cs^*}"

definition
lookup_refs ::"'c \<Rightarrow> ('c \<Rightarrow> 'b \<Rightarrow> 'a list \<Rightarrow> bool) \<Rightarrow> ('a list \<times> 'b) set"
where "lookup_refs obj f \<equiv> {(h,p). f obj p h}"

definition
lookupable_refs :: "(('a list \<times> 'b) \<times> 'a list \<times> 'b) set \<Rightarrow> 'a list set \<Rightarrow> ('a list \<times> 'b) set \<Rightarrow> ('a list \<times> 'b) set"
where  "lookupable_refs cs refs m \<equiv> {(ref, p). \<exists>tref href. href\<in>refs \<and> ref=tref@href \<and> (tref,p)\<in>cs^* `` m}"

definition
  "reachable vset \<equiv> (\<lambda>(ref, p). p) ` vset"

locale wellformed_lookup =
  fixes cs :: "(('c list \<times> 'a) \<times> 'c list \<times> 'a) set" and kh and f
  assumes trans_depends: "trans_depends kh cs f"
  assumes lookup1_is_append:
      "((r , q), rs, p) \<in> cs \<Longrightarrow> \<exists>ref. rs = ref # r"
  assumes lookup1_append:
      "((ra @ b, q), r @ b, p) \<in> cs \<Longrightarrow> ((ra, q), r, p) \<in> cs"
  assumes lookup1_cut:
      "((ra, q), r, p) \<in> cs \<Longrightarrow> ((ra @ b, q), r @ b, p) \<in> cs"
  assumes graph_inject:
      "\<And>p q obj ref. \<lbrakk>f obj p ref; f obj q ref\<rbrakk> \<Longrightarrow> p = q"
  assumes graph_single_step:
      "\<And>p obj ref. \<lbrakk>f obj p ref\<rbrakk> \<Longrightarrow> \<exists>r. ref = [r]"

context wellformed_lookup
begin

lemma lookup_refs_lookup1:
  "lookup_refs (kh ptr) f = {(h,p). (([],ptr),h,p) \<in> cs}"
  apply (insert  trans_depends)
  apply (clarsimp simp: trans_depends_def lookup_refs_def)
  done

lemma lookupable_refs_reach_self:
  "(rs, ptr) \<in> lookupable_refs cs {ref. (ref, ptr) \<in> cs\<^sup>* `` rset} refs
  \<Longrightarrow> \<exists>rs'. (rs', ptr) \<in> cs^* `` rset"
  apply (clarsimp simp: lookupable_refs_def Image_def)
  apply fastforce
  done

lemma lookup1_append_singleton:
  "((a, b), ref # a, q) \<in> cs \<Longrightarrow> (([], b), [ref], q) \<in> cs"
  apply (rule lookup1_append)
  apply fastforce
  done

lemma lookup1_cut_singleton:
  "(([], b), [ref], q) \<in> cs \<Longrightarrow> ((a, b), ref # a, q) \<in> cs "
  apply (drule lookup1_cut)
  apply fastforce
  done

lemma trans_dependsD:
  "(([],p), ref, q ) \<in> cs \<Longrightarrow> f (kh p) q ref"
  apply (insert trans_depends)
  apply (simp add: trans_depends_def)
  done

lemma trans_depends_eq:
  "(([],q),h,p) \<in> cs = f (kh q) p h"
  apply (insert trans_depends)
  apply (clarsimp simp: trans_depends_def)
  done

lemma lookup_empty_refl:
  "((a, p), [], q) \<in> cs\<^sup>* \<Longrightarrow> a = [] \<and> p = q"
  apply (erule rtranclE)
   apply simp
  apply (case_tac y)
  apply (clarsimp dest!: lookup1_is_append)
  done

lemma lookup_empty_refl_eq[simp]:
  "((a, p), [], q) \<in> cs\<^sup>* \<longleftrightarrow> a = [] \<and> p = q"
  using lookup_empty_refl by auto

lemma lookup1_same_leaf:
  "\<lbrakk>(a, refs, p) \<in> cs; (a, refs, q) \<in> cs\<rbrakk> \<Longrightarrow> p = q"
  apply (case_tac a)
  apply clarsimp
  apply (frule lookup1_is_append)
  apply clarsimp
  apply (drule lookup1_append_singleton)
  apply (drule lookup1_append_singleton)
  apply (clarsimp dest!: trans_dependsD)
  apply (drule graph_inject)
  apply simp+
  done

lemma lookup_ref_step:
  "((ref, ptr), ref', p) \<in> cs\<^sup>* \<Longrightarrow> \<exists>r. ref' = r @ ref"
  proof (induct "length ref'" arbitrary: ref' ref ptr p)
  case 0
    assume xs: "0 = length ref'"
      and  "((ref, ptr), ref', p) \<in> cs\<^sup>*"
  thus ?case
    apply simp
    done
  next
  case Suc
  show ?case
    apply (cut_tac Suc.prems Suc.hyps(2))
    apply (erule rtranclE)
     apply fastforce
    apply (case_tac y)
    apply (case_tac ref')
     apply clarsimp
    apply simp
    apply (drule Suc.hyps(1)[rotated])
     apply (clarsimp dest!: lookup1_is_append )+
    done
  qed

lemma lookup_trancl_append_1: (* This is true because the lengh of the lookup is always increased by 1 *)
  "((ra @ [b], q), r @ [b], p) \<in> cs\<^sup>*
  \<Longrightarrow> ((ra, q), r, p) \<in> cs\<^sup>*"
  proof (induct "length r - length ra" arbitrary: ra r q p)
  case 0
    assume "0 = length r - length ra"
    and "((ra @ [b], q), r @ [b], p) \<in> cs\<^sup>*"
  thus ?case
    apply simp
    apply (erule rtranclE)
     apply simp
    apply (case_tac y)
    apply simp
    apply (frule lookup_ref_step)
    apply (clarsimp dest!: lookup1_is_append)
    done
  next
  case Suc
  show ?case
    apply (insert Suc.prems Suc.hyps(2))
    apply (erule rtranclE)
     apply simp
    apply (case_tac y)
    apply clarsimp
    apply (frule lookup_ref_step)
    apply clarsimp
    apply (drule Suc.hyps(1)[where r = "a @ b" for a b, rotated,simplified])
     apply (clarsimp dest!: lookup1_is_append)
    apply (drule lookup1_append[where ra = "a @ b" for a b, simplified])
    apply (erule rtrancl.intros)
    apply simp
    done
  qed

lemma lookup_trancl_append:
  "((ra @ ref, b), r @ ref, p) \<in> cs^* \<Longrightarrow> ((ra, b), r, p) \<in> cs^*"
  proof (induct "length ref" arbitrary: ref ra r b p)
  case 0
  assume "((ra @ ref, b), r @ ref, p) \<in> cs ^*"
     and " 0 = length ref"
  thus ?case
    by simp
  next
  case Suc
  have t: "\<And>a b c. a @ b # c = (a @ [b]) @ c"
    by auto
  show ?case
    apply (insert Suc.prems Suc.hyps(2))
    apply (case_tac ref)
     apply clarsimp+
    apply (subst(asm) t)
    apply (subst(asm) t[where a = r])
    apply (frule(1) Suc.hyps(1)[rotated])
    apply (drule lookup_trancl_append_1)
    apply fastforce
    done
  qed

lemma lookup_leaf_from_lookup:
  assumes neq: "ref' \<noteq> ref"
  shows "\<lbrakk>((ref, p), ref', q) \<in> cs\<^sup>* \<rbrakk>
  \<Longrightarrow> \<exists>r ptr. ref' = r @ ref \<and> (([],p),[last r],ptr) \<in> cs \<and> (r,q) \<in> lookup_leaf p cs"
  apply (frule lookup_ref_step)
  apply clarsimp
  apply (erule converse_rtranclE)
   apply (insert neq)
   apply clarsimp
  apply (case_tac y)
  apply (rule conjI)
   apply clarsimp
   apply (rename_tac r mref ptr)
   apply (rule_tac x = ptr in exI)
   subgoal ex
    apply (clarsimp dest!: lookup_ref_step)
    apply (rule_tac ra = "[]" and b = ref in lookup1_append)
    apply (frule lookup1_is_append)
    apply clarsimp
    done
  apply (clarsimp simp: lookup_leaf_def)
  apply (rule converse_rtrancl_into_rtrancl)
  apply (rule ex)
      apply simp+
  apply (rule_tac ref = ref in lookup_trancl_append)
  apply (frule lookup_ref_step)
  apply (clarsimp dest!: lookup1_is_append)
  done

lemma lookupE:
  assumes rcl: "((ref, p), ref', q) \<in> cs\<^sup>*"
  assumes eq: "\<lbrakk>ref' = ref; p = q\<rbrakk> \<Longrightarrow> P ref' ref p q cs"
  and neq: "\<And>r ptr. \<lbrakk>ref' \<noteq> ref; ref' = r @ ref;  (([],p),[last r],ptr) \<in> cs; (r,q) \<in> lookup_leaf p cs\<rbrakk> \<Longrightarrow> P ref' ref p q cs"
  shows "P ref' ref p q cs"
  apply (insert rcl)
  apply (case_tac "ref' = ref")
   apply (rule eq)
    apply simp
   apply (erule rtranclE)
    apply simp
   apply (clarsimp dest!: lookup1_is_append lookup_ref_step)
  apply (frule(1) lookup_leaf_from_lookup)
  apply (elim disjE conjE exE)
  apply (rule neq)
   apply simp+
  done

lemma lookup_forwardE:
  assumes rcl: "(([], p), ref, q) \<in> cs\<^sup>*"
  assumes eq: "\<lbrakk>ref = []; p = q\<rbrakk> \<Longrightarrow> P ref p q cs"
  and neq1: "\<And>r. \<lbrakk>ref = [r]; (([], p), [r], q) \<in> cs\<rbrakk> \<Longrightarrow> P ref p q cs"
  and neq: "\<And>r ptr ref'. \<lbrakk>ref \<noteq> []; ref = r @ [ref'];  (([],p),[ref'],ptr) \<in> cs; (([], ptr), r, q) \<in> cs\<^sup>*\<rbrakk> \<Longrightarrow> P ref p q cs"
  shows "P ref p q cs"
  apply (insert rcl)
  apply (erule converse_rtranclE)
   apply (rule eq)
    apply (simp add: eq)
   apply simp
  apply clarsimp
  apply (frule lookup_ref_step)
  apply (frule lookup1_is_append)
  apply (elim exE)+
  apply (case_tac r)
   apply (rule neq1)
    apply simp
   apply clarsimp
   apply (erule rtranclE, simp)
   apply (clarsimp dest!: lookup1_is_append)
  apply clarsimp
  apply (drule lookup_trancl_append[where ra = "[]" and r = "h # g" for h g,simplified])
  apply (drule neq[rotated 2])
    apply simp+
  done

lemma lookup_rtrancl_stepD:
  "(([],p), [r], q) \<in> cs^* \<Longrightarrow> (([],p),[r],q) \<in> cs"
  apply (erule rtranclE)
  apply simp
  apply clarsimp
  apply (frule lookup_ref_step)
  apply clarsimp
  apply (erule rtranclE)
   apply simp
  apply (clarsimp dest!: lookup_ref_step lookup1_is_append)
  done

lemma lookup_rtrancl_stepsD:
  "(([], p), r @ [ref'], q) \<in> cs\<^sup>* \<Longrightarrow> \<exists>ptr. (([],p),[ref'],ptr) \<in> cs \<and> (([], ptr), r, q) \<in> cs\<^sup>*"
  apply (erule lookup_forwardE)
  apply clarsimp+
  apply force+
  done

lemma lookup_trancl_cut_1:
  (* This is true because the lengh of the lookup is always increased by 1 *)
  "((ra, q), r, p) \<in> cs\<^sup>* \<Longrightarrow> ((ra @ [b], q), r @ [b], p) \<in> cs\<^sup>*"
    proof (induct "length r - length ra" arbitrary: ra r q p)
  case 0
    assume " 0 = length r - length ra"
    and "((ra , q), r , p) \<in> cs\<^sup>*"
  thus ?case
    apply simp
    apply (frule lookup_ref_step)
    apply clarsimp
    apply (erule rtranclE)
     apply simp
    apply (case_tac y)
    apply simp
    apply (frule lookup_ref_step)
    apply (clarsimp dest!: lookup1_is_append)
    done
  next
  case Suc
  show ?case
    apply (insert Suc.prems Suc.hyps(2))
    apply (erule rtranclE)
     apply simp
    apply (case_tac y)
    apply clarsimp
    apply (frule lookup_ref_step)
    apply clarsimp
    apply (drule Suc.hyps(1)[where r = "a @ b" for a b, rotated,simplified])
     apply (clarsimp dest!: lookup1_is_append)
    apply (erule rtrancl.intros)
    apply (frule lookup1_cut)
    apply simp
    done
  qed

lemma lookup_trancl_cut:
  "((ra, b), r, p) \<in> cs\<^sup>* \<Longrightarrow> ((ra @ ref, b), r @ ref, p) \<in> cs\<^sup>*"
  proof (induct "length ref" arbitrary: ref ra r b p)
  case 0
  assume "((ra, b), r, p) \<in> cs\<^sup>*"
     and " 0 = length ref"
  thus ?case
    by simp
  next
  case Suc
  have t: "\<And>a b c. a @ b # c = (a @ [b]) @ c"
    by auto
  show ?case
    apply (insert Suc.prems Suc.hyps(2))
    apply (case_tac ref rule: rev_cases)
     apply clarsimp+
    apply (frule(1) Suc.hyps(1)[rotated])
    apply (drule lookup_trancl_cut_1)
        apply (drule lookup_trancl_cut_1)
    apply fastforce
    done
  qed

lemma empty_lookup_walk:
  "lookup_walk cs m [] p = {ptr. ptr \<in> m \<and> fst ptr = [] \<and> snd ptr = p }"
  by (fastforce simp: lookup_walk_def)

lemma lookup_walk_stepI1:
  "\<lbrakk>p \<in> lookup_walk cs m ref ptr; (([], ptr), [q], ptr') \<in> cs\<rbrakk> \<Longrightarrow> p \<in> lookup_walk cs m (q # ref) ptr'"
  apply (clarsimp simp: lookup_walk_def)
  apply (rule conjI, fastforce)
  apply (erule rtrancl_into_rtrancl)
  apply (erule lookup1_cut[where ra = "[]" and r = "[q]", simplified])
  done

lemma lookup_walk_stepsI1:
  "\<lbrakk>p \<in> lookup_walk cs m ref ptr; (([], ptr), refs, ptr') \<in> cs^*\<rbrakk> \<Longrightarrow> p \<in> lookup_walk cs m (refs @ ref) ptr'"
  apply (clarsimp simp: lookup_walk_def)
  apply (rule conjI, fastforce)
  apply (erule rtrancl_trans)
  apply (erule lookup_trancl_cut[where ra = "[]" and r = "refs", simplified])
  done

lemma lookup_walk_stepI2:
  "\<lbrakk>(ref, ptr) \<in> lookup_walk cs m ref ptr; (([], ptr), [q], ptr') \<in> cs\<rbrakk>
  \<Longrightarrow> (q#ref,ptr') \<in> lookup_walk cs m (q # ref) ptr'"
  apply (clarsimp simp: lookup_walk_def Image_def)
  apply (erule bexI[rotated])
  apply (erule rtrancl_into_rtrancl)
  apply (drule lookup1_cut)
  apply fastforce
  done

lemma lookup_walk_step_hdD:
  "(refs, p) \<in> lookup_walk cs m refs p \<Longrightarrow> (refs, p)\<in> m \<or> (\<exists>y. (tl refs,y) \<in> lookup_walk cs m (tl refs) y \<and> (([],y), [hd refs], p) \<in> cs)"
  apply (clarsimp simp: lookup_walk_def del: disjCI)
  apply (erule rtranclE)
   apply simp
  apply (rule disjI2)
  apply (case_tac y, clarsimp)
  apply (frule lookup1_is_append)
  apply clarsimp
  apply (intro conjI exI)
   apply fastforce
  apply (erule lookup1_append_singleton)
  done

lemma lookup_walk_stepD:
  "p \<in> lookup_walk cs m (ref # refs) q
  \<Longrightarrow> p = (ref # refs, q)
      \<or> (\<exists>ptr r. r @ (fst p) = refs \<and> p \<in> lookup_walk cs m refs ptr \<and> (([],ptr),[ref], q) \<in> cs)"
  apply (clarsimp simp: lookup_walk_def del: disjCI)
  apply (erule rtranclE)
   apply clarsimp
  apply (case_tac ya, clarsimp del: disjCI)
  apply (frule lookup1_is_append)
  apply (clarsimp del: disjCI)
  apply (rule conjI)
   apply force
  apply (intro exI conjI)
   apply force
  apply (erule lookup1_append_singleton)
  done

lemma reachable_walk:
  "(ref, p) \<in> (cs^* `` m) \<Longrightarrow> (ref, p) \<in> lookup_walk cs m ref p"
  by (clarsimp simp: lookup_walk_def)

lemma lookup_trans_eq:
  "((refs, b), refs, p) \<in> cs\<^sup>* \<Longrightarrow> b = p"
  by (erule lookup_trancl_append[where ra = "[]" and r = "[]" , simplified])

lemma lookup1_same_parent:
  "\<lbrakk>(a, refs, p) \<in> cs; (b, refs, q) \<in> cs\<rbrakk> \<Longrightarrow> fst a = fst b"
  apply (insert trans_depends)
  apply (case_tac a,case_tac b)
  apply (clarsimp dest!: lookup1_is_append)
  done

lemma lookupable_is_unique:
 "\<lbrakk>(sref, refs, p) \<in> cs^*; (sref, refs, q) \<in> cs^* \<rbrakk>
 \<Longrightarrow> p = q"
  proof (induct "length refs - length (fst sref)" arbitrary: p q sref refs)
  case 0
  thus ?case
    apply (insert "local.0.prems" "local.0.hyps")
    apply (cases sref, simp)
    apply (case_tac "fst sref = refs")
     apply (clarsimp dest!: lookup_trans_eq)
    apply clarsimp
    apply (drule lookup_leaf_from_lookup[rotated])
     apply simp
    apply clarsimp
    done
  next
  case Suc
  show ?case
    apply (insert Suc.prems Suc.hyps(2))
    apply (erule rtranclE, simp)
    apply (erule rtranclE, simp)
    apply (frule_tac a = y and b = ya in lookup1_same_parent)
     apply simp
    apply (case_tac y, clarsimp)
    apply (drule(1) Suc.hyps(1)[rotated])
     apply (fastforce dest!: lookup1_is_append)
   apply clarsimp
   apply (erule(1) lookup1_same_leaf)
   done
  qed

lemma lookup_walk_reduce:
  "(ref, ptr) \<in> lookup_walk cs m refs q
  \<Longrightarrow> (ref, ptr) \<in> lookup_walk cs m ref ptr"
  by (clarsimp simp: lookup_walk_def)

lemma lookup_walk_trivial:
  "a \<in> lookup_walk cs m ref ptr
  \<Longrightarrow> (ref, ptr) \<in> lookup_walk cs m ref ptr"
  apply (clarsimp simp: lookup_walk_def Image_def)
  apply (erule bexI[rotated])
  apply (erule rtrancl_trans)
  apply clarsimp
  apply (drule_tac ref = x in lookup_trancl_cut)
  apply clarsimp
  done

lemma lookup_walk_imp_reachable:
  "p \<in> lookup_walk cs m r ptr \<Longrightarrow> (r, ptr) \<in> cs^* `` m"
  apply (clarsimp simp: lookup_walk_def Image_def)
  apply (erule bexI[rotated])
  apply (erule rtrancl_trans)
  apply (erule lookup_trancl_cut[where ra = "[]", simplified])
  done

lemma lookup_trancl_walk:
  "(([], pa), ref, rptr) \<in> cs\<^sup>* \<Longrightarrow> (ref, rptr) \<in> lookup_walk cs {([],pa)} ref rptr"
  by (clarsimp simp: lookup_walk_def)

lemma lookup1_eq_ref:
  "(ref, ptr) \<in> lookup_walk cs m ref p \<Longrightarrow> p = ptr"
  by (clarsimp simp: lookup_walk_def)

lemma lookup_walk_decomp:
  "(a, ptr) \<in> lookup_walk cs rset r rptr \<Longrightarrow>
  \<exists>h. r = h @ a \<and> (h,rptr) \<in> lookup_walk cs ({([], ptr)}) h rptr"
  apply (clarsimp simp: lookup_walk_def)
  done

lemma lookup_walk_decomp_more:
  "(h @ [b],rptr) \<in> lookup_walk cs ({([], ptr)}) (h @ [b]) rptr \<Longrightarrow>
    \<exists>p. (([], ptr), [b], p) \<in> cs \<and> (([], p), h, rptr) \<in> cs\<^sup>*"
  apply (clarsimp simp: lookup_walk_def)
  apply (erule converse_rtranclE)
   apply clarsimp
  apply clarsimp
  apply (frule lookup1_is_append)
  apply clarsimp
  apply (frule lookup_ref_step)
  apply (intro exI conjI)
   apply force
  apply (rule lookup_trancl_append)
  apply force
  done

lemma lookupable_refs_set:
  shows "lookupable_refs cs refs (lookup_refs a f)
    \<subseteq> lookupable_refs cs refs (lookup_refs a f - lookup_refs b f) \<union> lookupable_refs cs refs (lookup_refs b f)"
  apply (fastforce simp: lookupable_refs_def Image_def)
  done

lemma in_lookupable_refsI:
  "\<lbrakk>(ref, ptr) \<in> cs\<^sup>* `` rset; f obj b a ; ((a, b), refs, rptr) \<in> cs\<^sup>*\<rbrakk> \<Longrightarrow>
  (refs @ ref, rptr) \<in> lookupable_refs cs {ref. (ref, ptr) \<in> cs\<^sup>* `` rset} (lookup_refs obj f)"
  apply (clarsimp simp: lookupable_refs_def Image_def)
  apply (intro exI conjI)
    apply fastforce
   apply fastforce
  apply (clarsimp simp: lookup_refs_def)
  apply fastforce
  done

(* The main result for this locale *)
theorem khupd_graph_subset:
  assumes wlcs: "wellformed_lookup cs' (kh(ptr := obj)) f"
  shows "(refs, p) \<in> cs'^* `` rset \<Longrightarrow> \<exists>sref. (sref, p) \<in> cs^* `` rset \<union> lookupable_refs cs
      {ref. (ref, ptr) \<in> cs^* `` rset} (lookup_refs obj f)"
  proof (induct "length refs" arbitrary: refs p)
   case 0
   note "0.prems" "0.hyps"
   thus ?case
    apply clarsimp
    apply (erule rtranclE, fastforce)
    apply (clarsimp dest!: wellformed_lookup.lookup1_is_append[OF wlcs])
    done
   next
   case Suc
   thus ?case
    apply (insert Suc.hyps(2) Suc.prems)
    apply (clarsimp del: disjCI)
    apply (erule rtranclE)
     apply fastforce
    apply (case_tac y, clarsimp del: disjCI)
    apply (rename_tac ref mptr)
    apply (frule  wellformed_lookup.lookup1_is_append[OF wlcs])
    apply (clarsimp del: disjCI)
    apply (drule Suc.hyps(1))
     apply (fastforce simp: Image_def)
    apply clarsimp
    apply (case_tac "mptr = ptr")
     apply (elim disjE)
      apply (rule_tac x = "refa # sref" in exI)
      apply (rule disjI2)
      apply (clarsimp simp: lookupable_refs_def lookup_refs_def)
      apply (drule wellformed_lookup.lookup1_append_singleton[OF wlcs])
      apply (clarsimp dest!:wellformed_lookup.trans_dependsD[OF wlcs])
      apply ((rule exI | rule conjI | force)+)[1]
     apply clarsimp
     apply (clarsimp simp: lookupable_refs_def)
     apply (intro disjI2 exI conjI | force)+
      apply (drule wellformed_lookup.lookup1_append_singleton[OF wlcs])
      apply (clarsimp dest!:wellformed_lookup.trans_dependsD[OF wlcs])
      apply (fastforce simp: Image_def lookup_refs_def)
    apply (clarsimp simp: Image_def)
    apply (drule wellformed_lookup.lookup1_append_singleton[OF wlcs])
    apply (clarsimp dest!:wellformed_lookup.trans_dependsD[OF wlcs])
    apply (rule exI)
    apply (elim disjE)
     apply (rule disjI1)
     apply (clarsimp simp: Image_def trans_depends_eq[symmetric])
     apply ((intro conjI bexI
              | simp add: obj_at_def
              | erule lookup1_cut_singleton
              | erule rtrancl_into_rtrancl)+)[1]
    apply (rule disjI2)
    apply (clarsimp simp: lookupable_refs_def Image_def trans_depends_eq[symmetric])
    apply (intro conjI exI)
      apply (rule_tac x = "(aa,ba)" in bexI)
       apply simp+
    apply (clarsimp simp: lookup_refs_def)
    apply ((intro conjI exI bexI
              | simp add: obj_at_def
              | erule lookup1_cut_singleton
              | erule rtrancl_into_rtrancl)+)[1]
    done
   qed
end

lemma lookup_bound_estimate:
  assumes wlcs: "wellformed_lookup cs kh f"
  and   wlcs': "wellformed_lookup cs' kh' f"
  and bound: "\<And>p. lookup_refs (kh' p) f \<subseteq> lookup_refs (kh p) f"
  shows "(refs, p) \<in> cs'^* `` rset \<Longrightarrow> (refs, p) \<in> cs^* `` rset"
  apply (clarsimp simp: Image_def)
  apply (erule_tac x = "(a,b)" in bexI[rotated])
  apply (induct refs arbitrary: p)
   apply (erule rtranclE)
   apply (clarsimp dest!: wellformed_lookup.lookup1_is_append[OF wlcs'])+
  apply (erule rtranclE)
   apply simp
  apply (rule_tac b = y in rtrancl_into_rtrancl)
   apply (clarsimp dest!: wellformed_lookup.lookup1_is_append[OF wlcs'])
  apply (case_tac y,clarsimp)
  apply (frule wellformed_lookup.lookup_ref_step[OF wlcs'])
  apply clarsimp
  apply (frule wellformed_lookup.lookup1_is_append[OF wlcs'])
  apply clarsimp
  apply (rule  wellformed_lookup.lookup1_cut[OF wlcs,where ra = "[]" and r = "[a]" for a,simplified])
  apply (drule wellformed_lookup.lookup1_append[OF wlcs', where ra = "[]" and r = "[a]" for a, simplified])
  apply (simp add: wellformed_lookup.trans_depends_eq[OF wlcs] wellformed_lookup.trans_depends_eq[OF wlcs'])
  apply (insert bound)
  apply (clarsimp simp: lookup_refs_def)
  apply fastforce
  done

lemma trans_depends_vs_walk:
  assumes wlcs: "wellformed_lookup cs kh f"
    and   wlcs': "wellformed_lookup cs' kh' f"
    and stick: "\<And>r q. (r, q) \<in> lookup_walk cs m ref p \<Longrightarrow> kh' q = kh q"
  shows "lookup_walk cs m ref p \<subseteq> lookup_walk cs' m ref p"
  apply (subgoal_tac "\<forall>r q. (r, q) \<in> lookup_walk cs m ref p \<longrightarrow> kh' q = kh q")
  prefer 2
    apply (clarsimp simp: stick)
  proof (induct ref arbitrary: p)
  case Nil
  show ?case
    by (simp add: wellformed_lookup.empty_lookup_walk[OF wlcs]
                  wellformed_lookup.empty_lookup_walk[OF wlcs'])
  next
  case Cons
  show ?case
    apply clarsimp
    apply (frule wellformed_lookup.lookup_walk_stepD[OF wlcs])
    apply (elim disjE)
     apply clarsimp
     apply (drule wellformed_lookup.lookup_walk_step_hdD[OF wlcs])
     apply (erule disjE)
      apply (fastforce simp: lookup_walk_def Image_def)
     apply clarsimp
     apply (rule wellformed_lookup.lookup_walk_stepI2[OF wlcs'])
      apply (erule subsetD[OF Cons.hyps, rotated])
      apply clarsimp
      apply (drule(1) wellformed_lookup.lookup_walk_stepI1[OF wlcs])
      apply (insert Cons.prems, fastforce)
     apply (drule(1) wellformed_lookup.lookup_walk_stepI1[OF wlcs])
     apply (clarsimp simp: wellformed_lookup.trans_depends_eq[OF wlcs] wellformed_lookup.trans_depends_eq[OF wlcs'])
    apply (elim exE conjE)
    apply (rule wellformed_lookup.lookup_walk_stepI1[OF wlcs'])
     apply (erule subsetD[OF Cons.hyps,rotated])
     apply clarsimp
      apply (drule(1) wellformed_lookup.lookup_walk_stepI1[OF wlcs])
      apply (insert Cons.prems, fastforce)
    apply clarsimp
    apply (drule_tac ptr = ptr in wellformed_lookup.lookup_walk_trivial[OF wlcs])
    apply (drule(1) wellformed_lookup.lookup_walk_stepI1[OF wlcs])
    apply (clarsimp simp: wellformed_lookup.trans_depends_eq[OF wlcs] wellformed_lookup.trans_depends_eq[OF wlcs'])
    done
  qed

locale wellformed_order_lookup = wellformed_lookup +
  fixes ev :: "'b\<Rightarrow>nat" and rset
  assumes lookup1_increase: "\<And>p q r ref. \<lbrakk>(ref,p) \<in> cs^* `` rset; (([],p),[r],q) \<in> cs \<rbrakk> \<Longrightarrow> ev (kh p) < ev (kh q)"

context wellformed_order_lookup
begin
lemma lookup1_increaseD:
  "\<lbrakk>(ref,p) \<in> cs^* `` rset; (([],p),[r],q) \<in> cs\<rbrakk> \<Longrightarrow> ev (kh p) < ev (kh q)"
  apply (insert lookup1_increase)
  apply (fastforce)
  done

lemma lookup_walk_distinct_strong:
  "(ref, ptr) \<in> lookup_walk cs rset (r @ ref) q \<Longrightarrow> (ev (kh ptr)) < (ev (kh q)) \<or> r = []"
  proof (induct "length r" arbitrary: ref ptr q r)
  case 0
  show ?case
    apply (insert "local.0")
    by clarsimp
  next
  case Suc
  show ?case
    apply (insert Suc.prems Suc.hyps(2))
    apply (case_tac r, simp)
    apply clarsimp
    apply (drule lookup_walk_stepD)
    apply (elim disjE, clarsimp)
    apply clarsimp
    apply (frule Suc.hyps(1)[rotated])
     apply fastforce
    apply (elim disjE)
     apply (frule lookup_walk_imp_reachable)
     apply (drule(1) lookup1_increaseD)
     apply clarsimp
    apply (frule lookup_walk_imp_reachable)
    apply (drule(1) lookup1_increaseD)
    apply (clarsimp dest!:lookup1_eq_ref)
    done
  qed

lemma lookup1_trans_increase:
  "\<lbrakk>(ref,p) \<in> cs^* `` rset; ((a,p),b,q) \<in> cs^+ \<rbrakk> \<Longrightarrow> ev (kh p) < ev (kh q)"
  apply (drule reachable_walk)
  apply (frule lookup_ref_step[OF trancl_into_rtrancl])
  apply clarsimp
  apply (drule lookup_walk_stepsI1)
   apply (rule lookup_trancl_append)
   apply force
  apply (drule lookup_walk_distinct_strong)
  apply clarsimp
  apply (erule tranclE)
   apply (clarsimp dest!: lookup1_is_append lookup_ref_step trancl_into_rtrancl)+
  done

lemma lookup_walk_unique:
  "(ref', ptr) \<in> lookup_walk cs rset ref ptr \<Longrightarrow> ref = ref'"
  proof (induct "length ref" arbitrary: ref ptr ref')
  case 0
  show ?case
    apply (insert "local.0")
    by (clarsimp simp:empty_lookup_walk)
  next
  case Suc
  show ?case
    apply (insert Suc.prems Suc.hyps(2))
    apply (case_tac ref)
     apply simp
    apply clarsimp
    apply (drule lookup_walk_stepD)
    apply (elim disjE, clarsimp)
    apply clarsimp
    apply (frule lookup_walk_distinct_strong)
    apply (frule lookup_walk_imp_reachable)
    apply (drule(1) lookup1_increaseD)
    apply (clarsimp dest!: lookup1_eq_ref)
    done
  qed

lemma lookup_walk_unique_from_root:
  "\<lbrakk>(([], ptr), b, ptr) \<in> cs^*; (ref,ptr) \<in> cs^* `` rset\<rbrakk> \<Longrightarrow> b = []"
  apply (subgoal_tac "b @ ref = ref")
   apply simp
  apply (rule lookup_walk_unique)
  apply (simp add: lookup_walk_def)
  done

lemma  lookup_walk_kh_upd:
  "\<lbrakk>wellformed_order_lookup cs' (kh(ptr := obj)) f ev rset; (q, ptr) \<in> lookup_walk cs rset q ptr \<rbrakk>
    \<Longrightarrow> (q, ptr) \<in> lookup_walk cs' rset q ptr"
  apply (case_tac q)
   apply (clarsimp simp: empty_lookup_walk)
   apply (fastforce simp: lookup_walk_def Image_def)
  apply clarsimp
  apply (frule lookup_walk_step_hdD)
   apply (elim disjE)
   apply (fastforce simp: lookup_walk_def Image_def)
  apply (clarsimp simp: Image_def)
  apply (cut_tac m = rset and ref = list and p = y
          in trans_depends_vs_walk[OF local.wellformed_lookup_axioms])
    apply (erule wellformed_order_lookup.axioms)
   apply clarsimp
   apply (drule_tac p = "(r, ptr)" in lookup_walk_stepI1[rotated])
    apply simp
   apply (clarsimp dest!: lookup_walk_unique)
   apply (drule lookup_walk_decomp)
   apply simp
  apply (rule wellformed_lookup.lookup_walk_stepI2)
    apply (erule wellformed_order_lookup.axioms)
   apply fastforce
  apply (subst wellformed_lookup.trans_depends_eq)
   apply (erule wellformed_order_lookup.axioms)
  apply (subgoal_tac "y \<noteq> ptr")
   apply (simp add: trans_depends_eq)
  apply clarsimp
   apply (drule_tac p = "(list, ptr)" in lookup_walk_stepI1[rotated])
   apply simp
  apply (clarsimp dest!: lookup_walk_unique)
  done

lemma lookup_walk_path_distinct:
  "h \<noteq> [] \<Longrightarrow> (q, ptr) \<in> lookup_walk cs rset (h @ q) rptr \<Longrightarrow> ptr \<noteq> rptr"
  apply (rule ccontr)
  apply clarsimp
  apply (drule lookup_walk_unique)
  apply simp
  done

(*
   This lemma should not be used out side of this locale.
   Please use kpupd_wellformed_order_lookup instead.
*)
lemma khupd_wellform_order_lookup_pref:
  assumes wlos: "wellformed_order_lookup cs' (kh(ptr := obj)) f ev rset"
  shows "cs'^* `` rset \<subseteq> cs^* `` rset \<union> lookupable_refs cs
      {ref. (ref, ptr) \<in> cs^* `` rset} (lookup_refs obj f)"
  proof -
  have wlcs: "wellformed_lookup cs' (kh(ptr := obj)) f"
   by (intro wellformed_order_lookup.axioms[OF wlos])
  have kh_upd_dummy[simp]:
     "(kh(ptr := obj, ptr := kh ptr)) = kh"
  by auto
  have l: "\<And>ys y q.  ys @ y # q = (ys @ [y]) @ q"
  by auto
  show ?thesis
  apply (rule subsetI)
  apply (clarsimp del: disjCI)
  apply (rename_tac r rptr ref p)
  apply (erule rtranclE)
   apply (fastforce simp: wellformed_lookup.empty_lookup_walk[OF wlcs] Image_def)
  apply (insert wlcs)
  apply (drule wellformed_lookup.reachable_walk)
   apply (simp add: Image_def)
   apply fastforce
  apply (case_tac "\<exists>q. (q, ptr) \<in> lookup_walk cs' rset r rptr")
   apply (clarsimp del: disjCI)
   apply (frule_tac ptr = ptr in wellformed_lookup.lookup_walk_reduce[OF wlcs])
   apply (drule_tac obj = "kh ptr" and ptr = ptr and cs' = cs in wellformed_order_lookup.lookup_walk_kh_upd[rotated -1,OF _ wlos])
    apply simp
    apply (rule wellformed_order_lookup_axioms)
   apply (frule_tac rptr = rptr in wellformed_lookup.lookup_walk_decomp[OF wlcs])
   apply (clarsimp del: disjCI)
   apply (rule_tac xs = h in rev_cases)
    apply (clarsimp simp: wellformed_lookup.empty_lookup_walk[OF wlcs])
    apply (simp add: lookup_walk_def)
   apply (rule disjI2)
   apply clarsimp
   apply (drule wellformed_lookup.lookup_walk_decomp_more[OF wlcs])
   apply clarsimp
   apply (drule wellformed_lookup.lookup_trancl_walk[OF wlcs])
   apply (drule_tac ref = q in wellformed_lookup.lookup_walk_reduce[OF wlcs])
   apply (drule_tac c="(ys, rptr)" in subsetD[OF trans_depends_vs_walk,rotated -1])
      apply (rule wlcs)
     apply (rule local.wellformed_lookup_axioms)
    apply clarsimp
    apply (drule_tac ref = r in wellformed_lookup.lookup_walk_reduce[OF wlcs])
    apply (frule_tac ptr = ptr in wellformed_order_lookup.lookup_walk_unique_from_root
                 [OF wlos _ wellformed_lookup.lookup_walk_imp_reachable[OF wlcs],rotated])
     apply (erule converse_rtrancl_into_rtrancl)
     apply (drule wellformed_lookup.lookup_walk_imp_reachable[OF wlcs])+
     apply (clarsimp simp: Image_def)
     apply (rule wellformed_lookup.lookup_trancl_cut[OF wlcs, where ra = "[]",simplified])
     apply simp
    apply simp
   apply (subst l)
   apply (rule in_lookupable_refsI)
     apply (clarsimp dest!: lookup_walk_imp_reachable)
    apply (drule wellformed_lookup.trans_dependsD[OF wlcs])
    apply simp
   apply (rule lookup_trancl_cut[where ra ="[]",simplified])
   apply (clarsimp dest!: lookup_walk_imp_reachable)
   apply simp
  apply (cut_tac m = rset and ref=r and p = rptr
          in trans_depends_vs_walk[OF wlcs local.wellformed_lookup_axioms])
   apply clarsimp
  apply (drule subsetD)
   apply (rule wellformed_lookup.reachable_walk[OF wlcs])
   apply (clarsimp simp: Image_def)
   apply (erule bexI[rotated])
   apply (erule(1) rtrancl_into_rtrancl)
  apply (simp add: lookup_walk_imp_reachable)
  done
  qed

lemma lookupable_refs_reachable:
  "lookupable_refs cs {ref. (ref, ptr) \<in> cs\<^sup>* `` rset} (lookup_refs (kh ptr) f)
   \<subseteq> cs\<^sup>* `` rset"
   apply (clarsimp simp: lookupable_refs_def Image_def lookup_refs_lookup1)
   apply (erule bexI[rotated])
   apply (erule rtrancl_trans)
   apply (frule lookup1_is_append)
   apply clarsimp
   apply (erule converse_rtrancl_into_rtrancl[OF lookup1_cut_singleton])
   apply (drule lookup_trancl_cut)
   apply force
   done

lemma khupd_wellformed_order_lookup_private:
  assumes well_order:
    "\<And>nref np stepref nq sref. \<lbrakk>(nref,np) \<in> cs^* `` (lookup_refs obj f); (([],np),[stepref],nq) \<in> cs; (sref, ptr)\<in> cs^* `` rset\<rbrakk>
    \<Longrightarrow> ev (kh np) < ev (kh nq)"
  and well_order_as_parent:
    "\<And>nref np sref. \<lbrakk>(nref,np) \<in> lookup_refs obj f; (sref, ptr)\<in> cs^* `` rset\<rbrakk> \<Longrightarrow> ev (obj) < ev (kh np)"
  and well_order_as_leaf:
    "\<And>p r sref. \<lbrakk>((r, p), sref, ptr) \<in> cs^+ ;(r, p) \<in> cs^* `` rset\<rbrakk> \<Longrightarrow> ev (kh p) < ev (obj)"
  and wlcs: "wellformed_lookup cs' (kh(ptr := obj)) f"
  shows "ev (kh ptr) \<le> ev obj \<Longrightarrow> wellformed_order_lookup cs' (kh(ptr := obj)) f ev rset"
  apply (intro wellformed_order_lookup.intro[OF wlcs])
  apply (intro wellformed_order_lookup_axioms.intro)
  apply (drule khupd_graph_subset[OF wlcs])
  apply (clarsimp simp: wellformed_lookup.trans_depends_eq[OF wlcs])
  apply (elim disjE)
   apply (clarsimp split: if_splits)
    apply (cut_tac nref = "[r]" and np = q in well_order_as_parent)
      apply (clarsimp simp: Image_def lookup_refs_def)
     apply (fastforce simp: Image_def)
    apply clarsimp
   apply (clarsimp simp: trans_depends_eq[symmetric])
   apply (intro conjI impI)
    apply (rule well_order_as_leaf[rotated])
     apply (fastforce simp: Image_def)
    apply (rule r_into_trancl')
    apply (rule lookup1_cut_singleton)
    apply force
   apply (rule lookup1_increase)
    apply (clarsimp simp: Image_def)
    apply (erule bexI[rotated])
    apply simp
   apply simp
  apply (clarsimp simp: lookupable_refs_def split: if_splits)
   apply (cut_tac nref = "[r]" and np = q in well_order_as_parent)
     apply (clarsimp simp: Image_def lookup_refs_def)
    apply (fastforce simp: Image_def)
   apply clarsimp
  apply (clarsimp simp: trans_depends_eq[symmetric])
  apply (intro conjI impI)
   apply clarsimp
   apply (frule well_order_as_parent)
    apply fastforce
   apply (drule well_order[rotated])
     apply fastforce+
  apply (frule well_order[rotated])
    apply (fastforce)+
  done

lemma khupd_wellformed_order_lookup:
  assumes well_order:
    "\<And>nref np stepref nq sref. \<lbrakk>(nref,np) \<in> cs^* `` (lookup_refs obj f - lookup_refs (kh ptr) f); (([],np),[stepref],nq) \<in> cs; (sref, ptr)\<in> cs^* `` rset\<rbrakk>
    \<Longrightarrow> ev (kh np) < ev (kh nq)"
  and well_order_as_parent:
    "\<And>nref np sref. \<lbrakk>(nref,np) \<in> (lookup_refs obj f - lookup_refs (kh ptr) f); (sref, ptr)\<in> cs^* `` rset\<rbrakk> \<Longrightarrow> ev (obj) < ev (kh np)"
  and well_order_as_leaf:
    "\<And>p r sref. \<lbrakk>((r, p), sref, ptr) \<in> cs^+ ;(r, p) \<in> cs^* `` rset\<rbrakk> \<Longrightarrow> ev (kh p) < ev (obj)"
  and wlcs: "wellformed_lookup cs' (kh(ptr := obj)) f"
  shows "ev (kh ptr) = ev obj \<Longrightarrow> wellformed_order_lookup cs' (kh(ptr := obj)) f ev rset"
  apply (rule khupd_wellformed_order_lookup_private[OF _ _ well_order_as_leaf wlcs])
       apply clarsimp
       apply (case_tac "(a,b) \<in> lookup_refs (kh ptr) f")
        apply (rule lookup1_increaseD)
         apply (clarsimp simp: Image_def)
         apply (erule bexI[rotated])
         apply (erule rtrancl_trans)
         apply (rule converse_rtrancl_into_rtrancl)
          apply (simp add: lookup_refs_lookup1)
          apply (drule_tac b = sref in lookup1_cut[where q = ptr])
          apply fastforce
         apply (erule lookup_trancl_cut)
        apply simp
       apply (rule well_order, fastforce+)
     apply clarsimp
     apply (case_tac "(nref,np) \<in> lookup_refs (kh ptr) f")
      apply (clarsimp simp: Image_def lookup_refs_lookup1)
      apply (frule lookup1_is_append)
      apply clarsimp
      apply (erule subst)
       apply (rule lookup1_trans_increase)
       apply (clarsimp simp: Image_def)
       apply (erule bexI[rotated])
        apply (simp add: lookup_refs_lookup1)+
       apply fastforce
      apply (rule well_order_as_parent,fastforce+)
   done

(* The main result for this locale *)
theorem khupd_graph_subset:
  assumes wlos: "wellformed_order_lookup cs' (kh(ptr := obj)) f ev rset"
  shows "cs'^* `` rset \<subseteq> cs^* `` rset \<union> lookupable_refs cs
      {ref. (ref, ptr) \<in> cs^* `` rset} (lookup_refs obj f - lookup_refs (kh ptr) f)"
  proof -
  have set_plus_mono: "\<And>a b c d. \<lbrakk>a \<subseteq> b \<union> c; c \<subseteq> d\<rbrakk> \<Longrightarrow> a \<subseteq> b \<union> d"
    by auto
  show ?thesis
    apply (insert khupd_wellform_order_lookup_pref[OF wlos])
    apply (drule set_plus_mono)
     apply (rule_tac b = "kh ptr" in lookupable_refs_set)
    apply (cut_tac ptr = ptr in lookupable_refs_reachable)
    apply fastforce
    done
  qed
end

context Arch begin global_naming X64

locale_abbrev "vs_lookup_leaf ptr s \<equiv> lookup_leaf ptr (vs_lookup1 s)"

primrec vsref_of :: "vs_ref \<Rightarrow> word64"
where
  "vsref_of (VSRef x _ ) = x"

definition
  vs_ref_lvl_arch :: "arch_kernel_obj \<Rightarrow> nat"
where
  "vs_ref_lvl_arch atype \<equiv> case aa_type atype of
      AASIDPool \<Rightarrow> 1
    | APageMapL4 \<Rightarrow> 2
    | APDPointerTable \<Rightarrow> 3
    | APageDirectory \<Rightarrow> 4
    | APageTable \<Rightarrow> 5
    | _ \<Rightarrow> 6"

definition
  "vs_ref_lvl obj_opt \<equiv> case_option 7 (arch_obj_fun_lift vs_ref_lvl_arch 7) obj_opt"

lemma vs_ref_lvl_arch_obj [simp]:
  "vs_ref_lvl (Some (ArchObj aobj)) = vs_ref_lvl_arch aobj"
  by (simp add: vs_ref_lvl_def)

lemma vs_ref_lvl_arch_simps [simp]:
  "vs_ref_lvl_arch (ASIDPool ap) = 1"
  "vs_ref_lvl_arch (PageMapL4 pm) = 2"
  "vs_ref_lvl_arch (PDPointerTable pdpt) = 3"
  "vs_ref_lvl_arch (PageDirectory pd) = 4"
  "vs_ref_lvl_arch (PageTable pt) = 5"
  "vs_ref_lvl_arch (DataPage dev sz) = 6"
  by (auto simp: vs_ref_lvl_arch_def aa_type_def)

definition
  "vs_lookup1_on_heap_obj \<equiv> \<lambda>obj q h. (\<exists>ko. obj = Some ko \<and> (\<exists>r. h = [r] \<and> (r, q) \<in> vs_refs ko))"

definition
  "vs_lookup_pages1_on_heap_obj \<equiv> \<lambda>obj q h. (\<exists>ko. obj = Some ko \<and> (\<exists>r. h = [r] \<and> (r, q) \<in> vs_refs_pages ko))"

sublocale vs_lookup1_wellformed:
  wellformed_lookup "vs_lookup1 s" "kheap s" vs_lookup1_on_heap_obj
  apply unfold_locales
       apply (clarsimp simp: trans_depends_def vs_lookup1_def obj_at_def vs_lookup1_on_heap_obj_def)+
   apply (clarsimp simp: vs_refs_def up_ucast_inj_eq graph_of_def
                  split: kernel_object.splits arch_kernel_obj.splits)
  apply (clarsimp simp: vs_lookup1_on_heap_obj_def)
  done

lemmas vs_lookup1_is_wellformed_lookup
  = vs_lookup1_wellformed.wellformed_lookup_axioms

sublocale vs_lookup_pages1_wellformed:
  wellformed_lookup "vs_lookup_pages1 s" "kheap s" vs_lookup_pages1_on_heap_obj
  apply unfold_locales
       apply (clarsimp simp: trans_depends_def vs_lookup_pages1_def obj_at_def vs_lookup_pages1_on_heap_obj_def)+
   apply (clarsimp simp: vs_refs_pages_def up_ucast_inj_eq graph_of_def
                  split: kernel_object.splits arch_kernel_obj.splits)
  apply (clarsimp simp: vs_lookup_pages1_on_heap_obj_def)
  done

lemmas vs_lookup_pages1_is_wellformed_lookup
  = vs_lookup_pages1_wellformed.wellformed_lookup_axioms

lemma vs_refs_pages_vs_ref_lvl:
  "\<lbrakk> ko_at (ArchObj aobj) p s; (r, q) \<in> vs_refs_pages (ArchObj aobj); valid_vspace_obj aobj s \<rbrakk>
     \<Longrightarrow> vs_ref_lvl (kheap s p) < vs_ref_lvl (kheap s q)"
  apply (cases aobj;
         clarsimp simp: vs_refs_pages_def graph_of_def ball_ran_eq obj_at_def
                        pte_ref_pages_def pde_ref_pages_def pdpte_ref_pages_def pml4e_ref_pages_def
                 split: if_splits pte.splits pde.splits pdpte.splits pml4e.splits;
         match premises in H [thin]: "\<forall>i. P (t i)" and J: "t i = v" for P t i v \<Rightarrow>
                              \<open>insert spec[where x=i, OF H]\<close>
                         \<bar> H [thin]: "\<forall>i \<in> S. P (t i)" and J: "t i = v" for P S t i v \<Rightarrow>
                              \<open>insert bspec[where x=i, OF H]\<close>)
  by (auto simp: obj_at_def data_at_def)

lemmas vs_refs_vs_ref_lvl = vs_refs_pages_vs_ref_lvl[OF _ vs_refs_vs_refs_pages]

lemma vs_lookup1_wellformed_order:
  "valid_vspace_objs s
    \<Longrightarrow> wellformed_order_lookup (vs_lookup1 s) (kheap s) vs_lookup1_on_heap_obj
                                vs_ref_lvl (vs_asid_refs (x64_asid_table (arch_state s)))"
  apply (intro wellformed_order_lookup.intro vs_lookup1_wellformed.wellformed_lookup_axioms
               wellformed_order_lookup_axioms.intro)
  apply (simp only: vs_lookup_def2[symmetric])
  apply (clarsimp simp add: vs_lookup1_def)
  apply (case_tac ko; (clarsimp simp: vs_refs_def; fail)?; rename_tac ako; clarsimp)
  apply (frule (2) valid_vspace_objsD)
  apply (case_tac ako; clarsimp simp: vs_refs_def)
     apply (drule (1) graph_of_in_ranD; clarsimp simp: obj_at_def)
    apply (match premises in "(i,_) \<in> graph_of _" for i \<Rightarrow>
            \<open>match premises in H[thin]: "\<forall>i. P i" for P \<Rightarrow> \<open>insert spec[where x=i, OF H]\<close>
                             \<bar> H[thin]: "\<forall>i\<in>_. P i" for P \<Rightarrow> \<open>insert bspec[where x=i, OF H]\<close>\<close>;
           fastforce simp: graph_of_def obj_at_def
                           pde_ref_def pdpte_ref_def pml4e_ref_def
                    split: pde.splits pdpte.splits pml4e.splits if_splits)+
  done

lemma vs_lookup_pages1_wellformed_order:
  "\<lbrakk> valid_vspace_objs s; valid_asid_table (x64_asid_table (arch_state s)) s \<rbrakk>
    \<Longrightarrow> wellformed_order_lookup (vs_lookup_pages1 s) (kheap s) vs_lookup_pages1_on_heap_obj
                                vs_ref_lvl (vs_asid_refs (x64_asid_table (arch_state s)))"
  apply (intro wellformed_order_lookup.intro vs_lookup_pages1_wellformed.wellformed_lookup_axioms
               wellformed_order_lookup_axioms.intro)
  apply (simp only: vs_lookup_pages_def2[symmetric])
  apply (clarsimp simp add: vs_lookup_pages1_def)
  apply (case_tac ko; (clarsimp simp: vs_refs_pages_def; fail)?; rename_tac ako; clarsimp)
  apply (frule (3) valid_vspace_objsD')
  apply (case_tac ako; clarsimp simp: vs_refs_pages_def)
      apply (drule (1) graph_of_in_ranD; clarsimp simp: obj_at_def)
     apply (match premises in "(x,y) \<in> graph_of f" for f x y \<Rightarrow>
             \<open>match premises in H[thin]: "\<forall>i. P i" for P \<Rightarrow> \<open>insert spec[where x=x, OF H]\<close>
                              \<bar> H[thin]: "\<forall>i\<in>_. P i" for P \<Rightarrow> \<open>insert bspec[where x=x, OF H]\<close>\<close>;
            fastforce simp: graph_of_def obj_at_def data_at_def
                            pte_ref_pages_def pde_ref_pages_def pdpte_ref_pages_def pml4e_ref_pages_def
                     split: pte.splits pde.splits pdpte.splits pml4e.splits if_splits)+
  done

definition
  refs_diff :: "(kernel_object option \<Rightarrow> 'b \<Rightarrow> 'a list \<Rightarrow> bool)
                  \<Rightarrow> arch_kernel_obj \<Rightarrow> 64 word \<Rightarrow> 'c abstract_state_scheme \<Rightarrow> ('a list \<times> 'b) set"
where
  "refs_diff lf obj ptr s = (lookup_refs (Some (ArchObj obj)) lf - lookup_refs (kheap s ptr) lf)"

end

end


(*  Title:      HOL/Bali/AxExample.thy
    Author:     David von Oheimb
*)

subsection \<open>Example of a proof based on the Bali axiomatic semantics\<close>

theory AxExample
imports AxSem Example
begin

definition
  arr_inv :: "st \<Rightarrow> bool" where
 "arr_inv = (\<lambda>s. \<exists>obj a T el. globs s (Stat Base) = Some obj \<and>
                              values obj (Inl (arr, Base)) = Some (Addr a) \<and>
                              heap s a = Some \<lparr>tag=Arr T 2,values=el\<rparr>)"

lemma arr_inv_new_obj:
"\<And>a. \<lbrakk>arr_inv s; new_Addr (heap s)=Some a\<rbrakk> \<Longrightarrow> arr_inv (gupd(Inl a\<mapsto>x) s)"
apply (unfold arr_inv_def)
apply (force dest!: new_AddrD2)
done

lemma arr_inv_set_locals [simp]: "arr_inv (set_locals l s) = arr_inv s"
apply (unfold arr_inv_def)
apply (simp (no_asm))
done

lemma arr_inv_gupd_Stat [simp]:
  "Base \<noteq> C \<Longrightarrow> arr_inv (gupd(Stat C\<mapsto>obj) s) = arr_inv s"
apply (unfold arr_inv_def)
apply (simp (no_asm_simp))
done

lemma ax_inv_lupd [simp]: "arr_inv (lupd(x\<mapsto>y) s) = arr_inv s"
apply (unfold arr_inv_def)
apply (simp (no_asm))
done

declare if_split_asm [split del]
declare lvar_def [simp]

ML \<open>
fun inst1_tac ctxt s t xs st =
  (case AList.lookup (op =) (rev (Term.add_var_names (Thm.prop_of st) [])) s of
    SOME i => PRIMITIVE (Rule_Insts.read_instantiate ctxt [(((s, i), Position.none), t)] xs) st
  | NONE => Seq.empty);

fun ax_tac ctxt =
  REPEAT o resolve_tac ctxt [allI] THEN'
  resolve_tac ctxt
    @{thms ax_Skip ax_StatRef ax_MethdN ax_Alloc ax_Alloc_Arr ax_SXAlloc_Normal ax_derivs.intros(8-)};
\<close>

theorem ax_test: "tprg,({}::'a triple set)\<turnstile>
  {Normal (\<lambda>Y s Z::'a. heap_free four s \<and> \<not>initd Base s \<and> \<not> initd Ext s)}
  .test [Class Base].
  {\<lambda>Y s Z. abrupt s = Some (Xcpt (Std IndOutBound))}"
apply (unfold test_def arr_viewed_from_def)
apply (tactic "ax_tac @{context} 1" (*;;*))
defer (* We begin with the last assertion, to synthesise the intermediate
         assertions, like in the fashion of the weakest
         precondition. *)
apply  (tactic "ax_tac @{context} 1" (* Try *))
defer
apply    (tactic \<open>inst1_tac @{context} "Q"
                 "\<lambda>Y s Z. arr_inv (snd s) \<and> tprg,s\<turnstile>catch SXcpt NullPointer" []\<close>)
prefer 2
apply    simp
apply   (rule_tac P' = "Normal (\<lambda>Y s Z. arr_inv (snd s))" in conseq1)
prefer 2
apply    clarsimp
apply   (rule_tac Q' = "(\<lambda>Y s Z. Q Y s Z)\<leftarrow>=False\<down>=\<diamondsuit>" and Q = Q for Q in conseq2)
prefer 2
apply    simp
apply   (tactic "ax_tac @{context} 1" (* While *))
prefer 2
apply    (rule ax_impossible [THEN conseq1], clarsimp)
apply   (rule_tac P' = "Normal P" and P = P for P in conseq1)
prefer 2
apply    clarsimp
apply   (tactic "ax_tac @{context} 1")
apply   (tactic "ax_tac @{context} 1" (* AVar *))
prefer 2
apply    (rule ax_subst_Val_allI)
apply    (tactic \<open>inst1_tac @{context} "P'" "\<lambda>a. Normal (PP a\<leftarrow>x)" ["PP", "x"]\<close>)
apply    (simp del: avar_def2 peek_and_def2)
apply    (tactic "ax_tac @{context} 1")
apply   (tactic "ax_tac @{context} 1")
      (* just for clarification: *)
apply   (rule_tac Q' = "Normal (\<lambda>Var:(v, f) u ua. fst (snd (avar tprg (Intg 2) v u)) = Some (Xcpt (Std IndOutBound)))" in conseq2)
prefer 2
apply    (clarsimp simp add: split_beta)
apply   (tactic "ax_tac @{context} 1" (* FVar *))
apply    (tactic "ax_tac @{context} 2" (* StatRef *))
apply   (rule ax_derivs.Done [THEN conseq1])
apply   (clarsimp simp add: arr_inv_def inited_def in_bounds_def)
defer
apply  (rule ax_SXAlloc_catch_SXcpt)
apply  (rule_tac Q' = "(\<lambda>Y (x, s) Z. x = Some (Xcpt (Std NullPointer)) \<and> arr_inv s) \<and>. heap_free two" in conseq2)
prefer 2
apply   (simp add: arr_inv_new_obj)
apply  (tactic "ax_tac @{context} 1")
apply  (rule_tac C = "Ext" in ax_Call_known_DynT)
apply     (unfold DynT_prop_def)
apply     (simp (no_asm))
apply    (intro strip)
apply    (rule_tac P' = "Normal P" and P = P for P in conseq1)
apply     (tactic "ax_tac @{context} 1" (* Methd *))
apply     (rule ax_thin [OF _ empty_subsetI])
apply     (simp (no_asm) add: body_def2)
apply     (tactic "ax_tac @{context} 1" (* Body *))
(* apply       (rule_tac [2] ax_derivs.Abrupt) *)
defer
apply      (simp (no_asm))
apply      (tactic "ax_tac @{context} 1") (* Comp *)
            (* The first statement in the  composition
                 ((Ext)z).vee = 1; Return Null
                will throw an exception (since z is null). So we can handle
                Return Null with the Abrupt rule *)
apply       (rule_tac [2] ax_derivs.Abrupt)

apply      (rule ax_derivs.Expr) (* Expr *)
apply      (tactic "ax_tac @{context} 1") (* Ass *)
prefer 2
apply       (rule ax_subst_Var_allI)
apply       (tactic \<open>inst1_tac @{context} "P'" "\<lambda>a vs l vf. PP a vs l vf\<leftarrow>x \<and>. p" ["PP", "x", "p"]\<close>)
apply       (rule allI)
apply       (tactic \<open>simp_tac (@{context} delloop "split_all_tac" delsimps [@{thm peek_and_def2}, @{thm heap_def2}, @{thm subst_res_def2}, @{thm normal_def2}]) 1\<close>)
apply       (rule ax_derivs.Abrupt)
apply      (simp (no_asm))
apply      (tactic "ax_tac @{context} 1" (* FVar *))
apply       (tactic "ax_tac @{context} 2", tactic "ax_tac @{context} 2", tactic "ax_tac @{context} 2")
apply      (tactic "ax_tac @{context} 1")
apply     (tactic \<open>inst1_tac @{context} "R" "\<lambda>a'. Normal ((\<lambda>Vals:vs (x, s) Z. arr_inv s \<and> inited Ext (globs s) \<and> a' \<noteq> Null \<and> vs = [Null]) \<and>. heap_free two)" []\<close>)
apply     fastforce
prefer 4
apply    (rule ax_derivs.Done [THEN conseq1],force)
apply   (rule ax_subst_Val_allI)
apply   (tactic \<open>inst1_tac @{context} "P'" "\<lambda>a. Normal (PP a\<leftarrow>x)" ["PP", "x"]\<close>)
apply   (simp (no_asm) del: peek_and_def2 heap_free_def2 normal_def2 o_apply)
apply   (tactic "ax_tac @{context} 1")
prefer 2
apply   (rule ax_subst_Val_allI)
apply    (tactic \<open>inst1_tac @{context} "P'" "\<lambda>aa v. Normal (QQ aa v\<leftarrow>y)" ["QQ", "y"]\<close>)
apply    (simp del: peek_and_def2 heap_free_def2 normal_def2)
apply    (tactic "ax_tac @{context} 1")
apply   (tactic "ax_tac @{context} 1")
apply  (tactic "ax_tac @{context} 1")
apply  (tactic "ax_tac @{context} 1")
(* end method call *)
apply (simp (no_asm))
    (* just for clarification: *)
apply (rule_tac Q' = "Normal ((\<lambda>Y (x, s) Z. arr_inv s \<and> (\<exists>a. the (locals s (VName e)) = Addr a \<and> obj_class (the (globs s (Inl a))) = Ext \<and>
 invocation_declclass tprg IntVir s (the (locals s (VName e))) (ClassT Base)
     \<lparr>name = foo, parTs = [Class Base]\<rparr> = Ext)) \<and>. initd Ext \<and>. heap_free two)"
  in conseq2)
prefer 2
apply  clarsimp
apply (tactic "ax_tac @{context} 1")
apply (tactic "ax_tac @{context} 1")
defer
apply  (rule ax_subst_Var_allI)
apply  (tactic \<open>inst1_tac @{context} "P'" "\<lambda>vf. Normal (PP vf \<and>. p)" ["PP", "p"]\<close>)
apply  (simp (no_asm) del: split_paired_All peek_and_def2 initd_def2 heap_free_def2 normal_def2)
apply  (tactic "ax_tac @{context} 1" (* NewC *))
apply  (tactic "ax_tac @{context} 1" (* ax_Alloc *))
     (* just for clarification: *)
apply  (rule_tac Q' = "Normal ((\<lambda>Y s Z. arr_inv (store s) \<and> vf=lvar (VName e) (store s)) \<and>. heap_free three \<and>. initd Ext)" in conseq2)
prefer 2
apply   (simp add: invocation_declclass_def dynmethd_def)
apply   (unfold dynlookup_def)
apply   (simp add: dynmethd_Ext_foo)
apply   (force elim!: arr_inv_new_obj atleast_free_SucD atleast_free_weaken)
     (* begin init *)
apply  (rule ax_InitS)
apply     force
apply    (simp (no_asm))
apply   (tactic \<open>simp_tac (@{context} delloop "split_all_tac") 1\<close>)
apply   (rule ax_Init_Skip_lemma)
apply  (tactic \<open>simp_tac (@{context} delloop "split_all_tac") 1\<close>)
apply  (rule ax_InitS [THEN conseq1] (* init Base *))
apply      force
apply     (simp (no_asm))
apply    (unfold arr_viewed_from_def)
apply    (rule allI)
apply    (rule_tac P' = "Normal P" and P = P for P in conseq1)
apply     (tactic \<open>simp_tac (@{context} delloop "split_all_tac") 1\<close>)
apply     (tactic "ax_tac @{context} 1")
apply     (tactic "ax_tac @{context} 1")
apply     (rule_tac [2] ax_subst_Var_allI)
apply      (tactic \<open>inst1_tac @{context} "P'" "\<lambda>vf l vfa. Normal (P vf l vfa)" ["P"]\<close>)
apply     (tactic \<open>simp_tac (@{context} delloop "split_all_tac" delsimps [@{thm split_paired_All}, @{thm peek_and_def2}, @{thm heap_free_def2}, @{thm initd_def2}, @{thm normal_def2}, @{thm supd_lupd}]) 2\<close>)
apply      (tactic "ax_tac @{context} 2" (* NewA *))
apply       (tactic "ax_tac @{context} 3" (* ax_Alloc_Arr *))
apply       (tactic "ax_tac @{context} 3")
apply      (tactic \<open>inst1_tac @{context} "P" "\<lambda>vf l vfa. Normal (P vf l vfa\<leftarrow>\<diamondsuit>)" ["P"]\<close>)
apply      (tactic \<open>simp_tac (@{context} delloop "split_all_tac") 2\<close>)
apply      (tactic "ax_tac @{context} 2")
apply     (tactic "ax_tac @{context} 1" (* FVar *))
apply      (tactic "ax_tac @{context} 2" (* StatRef *))
apply     (rule ax_derivs.Done [THEN conseq1])
apply     (tactic \<open>inst1_tac @{context} "Q" "\<lambda>vf. Normal ((\<lambda>Y s Z. vf=lvar (VName e) (snd s)) \<and>. heap_free four \<and>. initd Base \<and>. initd Ext)" []\<close>)
apply     (clarsimp split del: if_split)
apply     (frule atleast_free_weaken [THEN atleast_free_weaken])
apply     (drule initedD)
apply     (clarsimp elim!: atleast_free_SucD simp add: arr_inv_def)
apply    force
apply   (tactic \<open>simp_tac (@{context} delloop "split_all_tac") 1\<close>)
apply   (rule ax_triv_Init_Object [THEN peek_and_forget2, THEN conseq1])
apply     (rule wf_tprg)
apply    clarsimp
apply   (tactic \<open>inst1_tac @{context} "P" "\<lambda>vf. Normal ((\<lambda>Y s Z. vf = lvar (VName e) (snd s)) \<and>. heap_free four \<and>. initd Ext)" []\<close>)
apply   clarsimp
apply  (tactic \<open>inst1_tac @{context} "PP" "\<lambda>vf. Normal ((\<lambda>Y s Z. vf = lvar (VName e) (snd s)) \<and>. heap_free four \<and>. Not \<circ> initd Base)" []\<close>)
apply  clarsimp
     (* end init *)
apply (rule conseq1)
apply (tactic "ax_tac @{context} 1")
apply clarsimp
done

(*
while (true) {
  if (i) {throw xcpt;}
  else i=j
}
*)
lemma Loop_Xcpt_benchmark:
 "Q = (\<lambda>Y (x,s) Z. x \<noteq> None \<longrightarrow> the_Bool (the (locals s i))) \<Longrightarrow>
  G,({}::'a triple set)\<turnstile>{Normal (\<lambda>Y s Z::'a. True)}
  .lab1\<bullet> While(Lit (Bool True)) (If(Acc (LVar i)) (Throw (Acc (LVar xcpt))) Else
        (Expr (Ass (LVar i) (Acc (LVar j))))). {Q}"
apply (rule_tac P' = "Q" and Q' = "Q\<leftarrow>=False\<down>=\<diamondsuit>" in conseq12)
apply  safe
apply  (tactic "ax_tac @{context} 1" (* Loop *))
apply   (rule ax_Normal_cases)
prefer 2
apply    (rule ax_derivs.Abrupt [THEN conseq1], clarsimp simp add: Let_def)
apply   (rule conseq1)
apply    (tactic "ax_tac @{context} 1")
apply   clarsimp
prefer 2
apply  clarsimp
apply (tactic "ax_tac @{context} 1" (* If *))
apply  (tactic
  \<open>inst1_tac @{context} "P'" "Normal (\<lambda>s.. (\<lambda>Y s Z. True)\<down>=Val (the (locals s i)))" []\<close>)
apply  (tactic "ax_tac @{context} 1")
apply  (rule conseq1)
apply   (tactic "ax_tac @{context} 1")
apply  clarsimp
apply (rule allI)
apply (rule ax_escape)
apply auto
apply  (rule conseq1)
apply   (tactic "ax_tac @{context} 1" (* Throw *))
apply   (tactic "ax_tac @{context} 1")
apply   (tactic "ax_tac @{context} 1")
apply  clarsimp
apply (rule_tac Q' = "Normal (\<lambda>Y s Z. True)" in conseq2)
prefer 2
apply  clarsimp
apply (rule conseq1)
apply  (tactic "ax_tac @{context} 1")
apply  (tactic "ax_tac @{context} 1")
prefer 2
apply   (rule ax_subst_Var_allI)
apply   (tactic \<open>inst1_tac @{context} "P'" "\<lambda>b Y ba Z vf. \<lambda>Y (x,s) Z. x=None \<and> snd vf = snd (lvar i s)" []\<close>)
apply   (rule allI)
apply   (rule_tac P' = "Normal P" and P = P for P in conseq1)
prefer 2
apply    clarsimp
apply   (tactic "ax_tac @{context} 1")
apply   (rule conseq1)
apply    (tactic "ax_tac @{context} 1")
apply   clarsimp
apply  (tactic "ax_tac @{context} 1")
apply clarsimp
done

end


section\<open>The Axiom of Replacement in $M[G]$\<close>
theory Replacement_Axiom
  imports
    Least Relative_Univ Separation_Axiom Renaming_Auto
begin

rename "renrep1" src "[p,P,leq,o,\<rho>,\<tau>]" tgt "[V,\<tau>,\<rho>,p,\<alpha>,P,leq,o]"

definition renrep_fn :: "i \<Rightarrow> i" where
  "renrep_fn(env) \<equiv> sum(renrep1_fn,id(length(env)),6,8,length(env))"

definition
  renrep :: "[i,i] \<Rightarrow> i" where
  "renrep(\<phi>,env) = ren(\<phi>)`(6#+length(env))`(8#+length(env))`renrep_fn(env)"

lemma renrep_type [TC]:
  assumes "\<phi>\<in>formula" "env \<in> list(M)"
  shows "renrep(\<phi>,env) \<in> formula"
  unfolding renrep_def renrep_fn_def renrep1_fn_def
  using assms renrep1_thm(1) ren_tc
  by simp

lemma arity_renrep:
  assumes  "\<phi>\<in>formula" "arity(\<phi>)\<le> 6#+length(env)" "env \<in> list(M)"
  shows "arity(renrep(\<phi>,env)) \<le> 8#+length(env)"
  unfolding  renrep_def renrep_fn_def renrep1_fn_def
  using assms renrep1_thm(1) arity_ren
  by simp

lemma renrep_sats :
  assumes  "arity(\<phi>) \<le> 6 #+ length(env)"
          "[P,leq,o,p,\<rho>,\<tau>] @ env \<in> list(M)"
    "V \<in> M" "\<alpha> \<in> M"
    "\<phi>\<in>formula"
  shows "sats(M, \<phi>, [p,P,leq,o,\<rho>,\<tau>] @ env) \<longleftrightarrow> sats(M, renrep(\<phi>,env), [V,\<tau>,\<rho>,p,\<alpha>,P,leq,o] @ env)"
  unfolding  renrep_def renrep_fn_def renrep1_fn_def
  by (rule sats_iff_sats_ren,insert assms, auto simp add:renrep1_thm(1)[of _ M,simplified]
        renrep1_thm(2)[simplified,where p=p and \<alpha>=\<alpha>])

rename "renpbdy1" src "[\<rho>,p,\<alpha>,P,leq,o]" tgt "[\<rho>,p,x,\<alpha>,P,leq,o]"

definition renpbdy_fn :: "i \<Rightarrow> i" where
  "renpbdy_fn(env) \<equiv> sum(renpbdy1_fn,id(length(env)),6,7,length(env))"

definition
  renpbdy :: "[i,i] \<Rightarrow> i" where
  "renpbdy(\<phi>,env) = ren(\<phi>)`(6#+length(env))`(7#+length(env))`renpbdy_fn(env)"

lemma
  renpbdy_type [TC]: "\<phi>\<in>formula \<Longrightarrow> env\<in>list(M) \<Longrightarrow> renpbdy(\<phi>,env) \<in> formula"
  unfolding renpbdy_def renpbdy_fn_def renpbdy1_fn_def
  using  renpbdy1_thm(1) ren_tc
  by simp

lemma  arity_renpbdy: "\<phi>\<in>formula \<Longrightarrow> arity(\<phi>) \<le> 6 #+ length(env) \<Longrightarrow> env\<in>list(M) \<Longrightarrow> arity(renpbdy(\<phi>,env)) \<le> 7 #+ length(env)"
  unfolding renpbdy_def renpbdy_fn_def renpbdy1_fn_def
  using  renpbdy1_thm(1) arity_ren
  by simp

lemma
  sats_renpbdy: "arity(\<phi>) \<le> 6 #+ length(nenv) \<Longrightarrow> [\<rho>,p,x,\<alpha>,P,leq,o,\<pi>] @ nenv \<in> list(M) \<Longrightarrow> \<phi>\<in>formula \<Longrightarrow>
       sats(M, \<phi>, [\<rho>,p,\<alpha>,P,leq,o] @ nenv) \<longleftrightarrow> sats(M, renpbdy(\<phi>,nenv), [\<rho>,p,x,\<alpha>,P,leq,o] @ nenv)"
  unfolding renpbdy_def renpbdy_fn_def renpbdy1_fn_def
  by (rule sats_iff_sats_ren,auto simp add: renpbdy1_thm(1)[of _ M,simplified]
                                            renpbdy1_thm(2)[simplified,where \<alpha>=\<alpha> and x=x])

rename "renbody1" src "[x,\<alpha>,P,leq,o]" tgt "[\<alpha>,x,m,P,leq,o]"

definition renbody_fn :: "i \<Rightarrow> i" where
  "renbody_fn(env) \<equiv> sum(renbody1_fn,id(length(env)),5,6,length(env))"

definition
  renbody :: "[i,i] \<Rightarrow> i" where
  "renbody(\<phi>,env) = ren(\<phi>)`(5#+length(env))`(6#+length(env))`renbody_fn(env)"

lemma
  renbody_type [TC]: "\<phi>\<in>formula \<Longrightarrow> env\<in>list(M) \<Longrightarrow> renbody(\<phi>,env) \<in> formula"
  unfolding renbody_def renbody_fn_def renbody1_fn_def
  using  renbody1_thm(1) ren_tc
  by simp

lemma  arity_renbody: "\<phi>\<in>formula \<Longrightarrow> arity(\<phi>) \<le> 5 #+ length(env) \<Longrightarrow> env\<in>list(M) \<Longrightarrow>
  arity(renbody(\<phi>,env)) \<le> 6 #+ length(env)"
  unfolding renbody_def renbody_fn_def renbody1_fn_def
  using  renbody1_thm(1) arity_ren
  by simp

lemma
  sats_renbody: "arity(\<phi>) \<le> 5 #+ length(nenv) \<Longrightarrow> [\<alpha>,x,m,P,leq,o] @ nenv \<in> list(M) \<Longrightarrow> \<phi>\<in>formula \<Longrightarrow>
       sats(M, \<phi>, [x,\<alpha>,P,leq,o] @ nenv) \<longleftrightarrow> sats(M, renbody(\<phi>,nenv), [\<alpha>,x,m,P,leq,o] @ nenv)"
  unfolding renbody_def renbody_fn_def renbody1_fn_def
  by (rule sats_iff_sats_ren, auto simp add:renbody1_thm(1)[of _ M,simplified]
                                            renbody1_thm(2)[where \<alpha>=\<alpha> and m=m,simplified])

context G_generic
begin

lemma pow_inter_M:
  assumes
    "x\<in>M" "y\<in>M"
  shows
    "powerset(##M,x,y) \<longleftrightarrow> y = Pow(x) \<inter> M"
  using assms by auto

schematic_goal sats_prebody_fm_auto:
  assumes
    "\<phi>\<in>formula" "[P,leq,one,p,\<rho>,\<pi>] @ nenv \<in>list(M)"  "\<alpha>\<in>M" "arity(\<phi>) \<le> 2 #+ length(nenv)"
  shows
    "(\<exists>\<tau>\<in>M. \<exists>V\<in>M. is_Vset(##M,\<alpha>,V) \<and> \<tau>\<in>V \<and> sats(M,forces(\<phi>),[p,P,leq,one,\<rho>,\<tau>] @ nenv))
   \<longleftrightarrow> sats(M,?prebody_fm,[\<rho>,p,\<alpha>,P,leq,one] @ nenv)"
  apply (insert assms; (rule sep_rules is_Vset_iff_sats[OF _ _ _ _ _ nonempty[simplified]] | simp))
   apply (rule sep_rules is_Vset_iff_sats is_Vset_iff_sats[OF _ _ _ _ _ nonempty[simplified]] | simp)+
        apply (rule nonempty[simplified])
       apply (simp_all)
    apply (rule length_type[THEN nat_into_Ord], blast)+
  apply ((rule sep_rules | simp))
    apply ((rule sep_rules | simp))
      apply ((rule sep_rules | simp))
       apply ((rule sep_rules | simp))
      apply ((rule sep_rules | simp))
     apply ((rule sep_rules | simp))
    apply ((rule sep_rules | simp))
   apply (rule renrep_sats[simplified])
       apply (insert assms)
       apply(auto simp add: renrep_type definability)
proof -
  from assms
  have "nenv\<in>list(M)" by simp
  with \<open>arity(\<phi>)\<le>_\<close> \<open>\<phi>\<in>_\<close>
  show "arity(forces(\<phi>)) \<le> succ(succ(succ(succ(succ(succ(length(nenv)))))))"
    using arity_forces_le by simp
qed

(* The formula synthesized above *)
synthesize_notc "prebody_fm" from_schematic sats_prebody_fm_auto

lemma prebody_fm_type [TC]:
  assumes "\<phi>\<in>formula"
    "env \<in> list(M)"
  shows "prebody_fm(\<phi>,env)\<in>formula"
proof -
  from \<open>\<phi>\<in>formula\<close>
  have "forces(\<phi>)\<in>formula" by simp
  then
  have "renrep(forces(\<phi>),env)\<in>formula"
    using \<open>env\<in>list(M)\<close> by simp
  then show ?thesis unfolding prebody_fm_def by simp
qed

lemmas new_fm_defs = fm_defs is_transrec_fm_def is_eclose_fm_def mem_eclose_fm_def
  finite_ordinal_fm_def is_wfrec_fm_def  Memrel_fm_def eclose_n_fm_def is_recfun_fm_def is_iterates_fm_def
  iterates_MH_fm_def is_nat_case_fm_def quasinat_fm_def pre_image_fm_def restriction_fm_def

lemma sats_prebody_fm:
  assumes
    "[P,leq,one,p,\<rho>] @ nenv \<in>list(M)" "\<phi>\<in>formula" "\<alpha>\<in>M" "arity(\<phi>) \<le> 2 #+ length(nenv)"
  shows
    "sats(M,prebody_fm(\<phi>,nenv),[\<rho>,p,\<alpha>,P,leq,one] @ nenv) \<longleftrightarrow>
     (\<exists>\<tau>\<in>M. \<exists>V\<in>M. is_Vset(##M,\<alpha>,V) \<and> \<tau>\<in>V \<and> sats(M,forces(\<phi>),[p,P,leq,one,\<rho>,\<tau>] @ nenv))"
  unfolding prebody_fm_def using assms sats_prebody_fm_auto by force

lemma arity_prebody_fm:
  assumes
    "\<phi>\<in>formula" "\<alpha>\<in>M" "env \<in> list(M)" "arity(\<phi>) \<le> 2 #+ length(env)"
  shows
    "arity(prebody_fm(\<phi>,env))\<le>6 #+ length(env)"
  unfolding prebody_fm_def is_HVfrom_fm_def is_powapply_fm_def
  using assms new_fm_defs nat_simp_union
    arity_renrep[of "forces(\<phi>)"] arity_forces_le[simplified] pred_le by auto

definition
  body_fm' :: "[i,i]\<Rightarrow>i" where
  "body_fm'(\<phi>,env) \<equiv> Exists(Exists(And(pair_fm(0,1,2),renpbdy(prebody_fm(\<phi>,env),env))))"

lemma body_fm'_type[TC]: "\<phi>\<in>formula \<Longrightarrow> env\<in>list(M) \<Longrightarrow> body_fm'(\<phi>,env)\<in>formula"
  unfolding body_fm'_def using prebody_fm_type
  by simp

lemma arity_body_fm':
  assumes
    "\<phi>\<in>formula" "\<alpha>\<in>M" "env\<in>list(M)" "arity(\<phi>) \<le> 2 #+ length(env)"
  shows
    "arity(body_fm'(\<phi>,env))\<le>5  #+ length(env)"
  unfolding body_fm'_def
  using assms new_fm_defs nat_simp_union arity_prebody_fm pred_le  arity_renpbdy[of "prebody_fm(\<phi>,env)"]
  by auto

lemma sats_body_fm':
  assumes
    "\<exists>t p. x=\<langle>t,p\<rangle>" "x\<in>M" "[\<alpha>,P,leq,one,p,\<rho>] @ nenv \<in>list(M)" "\<phi>\<in>formula" "arity(\<phi>) \<le> 2 #+ length(nenv)"
  shows
    "sats(M,body_fm'(\<phi>,nenv),[x,\<alpha>,P,leq,one] @ nenv) \<longleftrightarrow>
     sats(M,renpbdy(prebody_fm(\<phi>,nenv),nenv),[fst(x),snd(x),x,\<alpha>,P,leq,one] @ nenv)"
  using assms fst_snd_closed[OF \<open>x\<in>M\<close>] unfolding body_fm'_def
  by (auto)

definition
  body_fm :: "[i,i]\<Rightarrow>i" where
  "body_fm(\<phi>,env) \<equiv> renbody(body_fm'(\<phi>,env),env)"

lemma body_fm_type [TC]: "env\<in>list(M) \<Longrightarrow> \<phi>\<in>formula \<Longrightarrow>  body_fm(\<phi>,env)\<in>formula"
  unfolding body_fm_def by simp

lemma sats_body_fm:
  assumes
    "\<exists>t p. x=\<langle>t,p\<rangle>" "[\<alpha>,x,m,P,leq,one] @ nenv \<in>list(M)"
    "\<phi>\<in>formula" "arity(\<phi>) \<le> 2 #+ length(nenv)"
  shows
    "sats(M,body_fm(\<phi>,nenv),[\<alpha>,x,m,P,leq,one] @ nenv) \<longleftrightarrow>
     sats(M,renpbdy(prebody_fm(\<phi>,nenv),nenv),[fst(x),snd(x),x,\<alpha>,P,leq,one] @ nenv)"
  using assms sats_body_fm' sats_renbody[OF _ assms(2), symmetric] arity_body_fm'
  unfolding body_fm_def
  by auto

lemma sats_renpbdy_prebody_fm:
  assumes
    "\<exists>t p. x=\<langle>t,p\<rangle>" "x\<in>M" "[\<alpha>,m,P,leq,one] @ nenv \<in>list(M)"
    "\<phi>\<in>formula" "arity(\<phi>) \<le> 2 #+ length(nenv)"
  shows
    "sats(M,renpbdy(prebody_fm(\<phi>,nenv),nenv),[fst(x),snd(x),x,\<alpha>,P,leq,one] @ nenv) \<longleftrightarrow>
     sats(M,prebody_fm(\<phi>,nenv),[fst(x),snd(x),\<alpha>,P,leq,one] @ nenv)"
  using assms fst_snd_closed[OF \<open>x\<in>M\<close>]
    sats_renpbdy[OF arity_prebody_fm _ prebody_fm_type, of concl:M, symmetric]
  by force

lemma body_lemma:
  assumes
    "\<exists>t p. x=\<langle>t,p\<rangle>" "x\<in>M" "[x,\<alpha>,m,P,leq,one] @ nenv \<in>list(M)"
    "\<phi>\<in>formula" "arity(\<phi>) \<le> 2 #+ length(nenv)"
  shows
    "sats(M,body_fm(\<phi>,nenv),[\<alpha>,x,m,P,leq,one] @ nenv) \<longleftrightarrow>
  (\<exists>\<tau>\<in>M. \<exists>V\<in>M. is_Vset(\<lambda>a. (##M)(a),\<alpha>,V) \<and> \<tau> \<in> V \<and> (snd(x) \<tturnstile> \<phi> ([fst(x),\<tau>]@nenv)))"
  using assms sats_body_fm[of x \<alpha> m nenv] sats_renpbdy_prebody_fm[of x \<alpha>]
    sats_prebody_fm[of "snd(x)" "fst(x)"] fst_snd_closed[OF \<open>x\<in>M\<close>]
  by (simp, simp flip: setclass_iff,simp)

lemma Replace_sats_in_MG:
  assumes
    "c\<in>M[G]" "env \<in> list(M[G])"
    "\<phi> \<in> formula" "arity(\<phi>) \<le> 2 #+ length(env)"
    "univalent(##M[G], c, \<lambda>x v. (M[G] , [x,v]@env \<Turnstile> \<phi>) )"
  shows
    "{v. x\<in>c, v\<in>M[G] \<and> (M[G] , [x,v]@env \<Turnstile> \<phi>)} \<in> M[G]"
proof -
  let ?R = "\<lambda> x v . v\<in>M[G] \<and> (M[G] , [x,v]@env \<Turnstile> \<phi>)"
  from \<open>c\<in>M[G]\<close>
  obtain \<pi>' where "val(G, \<pi>') = c" "\<pi>' \<in> M"
    using GenExt_def by auto
  then
  have "domain(\<pi>')\<times>P\<in>M" (is "?\<pi>\<in>M")
    using cartprod_closed P_in_M domain_closed by simp
  from \<open>val(G, \<pi>') = c\<close>
  have "c \<subseteq> val(G,?\<pi>)"
    using def_val[of G ?\<pi>] one_in_P one_in_G[OF generic] elem_of_val
      domain_of_prod[OF one_in_P, of "domain(\<pi>')"] by force
  from \<open>env \<in> _\<close>
  obtain nenv where "nenv\<in>list(M)" "env = map(val(G),nenv)"
    using map_val by auto
  then
  have "length(nenv) = length(env)" by simp
  define f where "f(\<rho>p) \<equiv> \<mu> \<alpha>. \<alpha>\<in>M \<and> (\<exists>\<tau>\<in>M. \<tau> \<in> Vset(\<alpha>) \<and>
        (snd(\<rho>p) \<tturnstile> \<phi> ([fst(\<rho>p),\<tau>] @ nenv)))" (is "_ \<equiv> \<mu> \<alpha>. ?P(\<rho>p,\<alpha>)") for \<rho>p
  have "f(\<rho>p) = (\<mu> \<alpha>. \<alpha>\<in>M \<and> (\<exists>\<tau>\<in>M. \<exists>V\<in>M. is_Vset(##M,\<alpha>,V) \<and> \<tau>\<in>V \<and>
        (snd(\<rho>p) \<tturnstile> \<phi> ([fst(\<rho>p),\<tau>] @ nenv))))" (is "_ = (\<mu> \<alpha>. \<alpha>\<in>M \<and> ?Q(\<rho>p,\<alpha>))") for \<rho>p
    unfolding f_def using Vset_abs Vset_closed Ord_Least_cong[of "?P(\<rho>p)" "\<lambda> \<alpha>. \<alpha>\<in>M \<and> ?Q(\<rho>p,\<alpha>)"]
    by (simp, simp del:setclass_iff)
  moreover
  have "f(\<rho>p) \<in> M" for \<rho>p
    unfolding f_def using Least_closed[of "?P(\<rho>p)"] by simp
  ultimately
  have 1:"least(##M,\<lambda>\<alpha>. ?Q(\<rho>p,\<alpha>),f(\<rho>p))" for \<rho>p
    using least_abs[of "\<lambda>\<alpha>. \<alpha>\<in>M \<and> ?Q(\<rho>p,\<alpha>)" "f(\<rho>p)"] least_conj
    by (simp flip: setclass_iff)
  have "Ord(f(\<rho>p))" for \<rho>p unfolding f_def by simp
  define QQ where "QQ\<equiv>?Q"
  from 1
  have "least(##M,\<lambda>\<alpha>. QQ(\<rho>p,\<alpha>),f(\<rho>p))" for \<rho>p
    unfolding QQ_def .
  from \<open>arity(\<phi>) \<le> _\<close> \<open>length(nenv) = _\<close>
  have "arity(\<phi>) \<le> 2 #+ length(nenv)"
    by simp
  moreover
  note assms \<open>nenv\<in>list(M)\<close> \<open>?\<pi>\<in>M\<close>
  moreover
  have "\<rho>p\<in>?\<pi> \<Longrightarrow> \<exists>t p. \<rho>p=\<langle>t,p\<rangle>" for \<rho>p
    by auto
  ultimately
  have body:"M , [\<alpha>,\<rho>p,m,P,leq,one] @ nenv \<Turnstile> body_fm(\<phi>,nenv) \<longleftrightarrow> ?Q(\<rho>p,\<alpha>)"
    if "\<rho>p\<in>?\<pi>" "\<rho>p\<in>M" "m\<in>M" "\<alpha>\<in>M" for \<alpha> \<rho>p m
    using that P_in_M leq_in_M one_in_M body_lemma[of \<rho>p \<alpha> m nenv \<phi>] by simp
  let ?f_fm="least_fm(body_fm(\<phi>,nenv),1)"
  {
    fix \<rho>p m
    assume asm: "\<rho>p\<in>M" "\<rho>p\<in>?\<pi>" "m\<in>M"
    note inM = this P_in_M leq_in_M one_in_M \<open>nenv\<in>list(M)\<close>
    with body
    have body':"\<And>\<alpha>. \<alpha> \<in> M \<Longrightarrow> (\<exists>\<tau>\<in>M. \<exists>V\<in>M. is_Vset(\<lambda>a. (##M)(a), \<alpha>, V) \<and> \<tau> \<in> V \<and>
          (snd(\<rho>p) \<tturnstile> \<phi> ([fst(\<rho>p),\<tau>] @ nenv))) \<longleftrightarrow>
          M, Cons(\<alpha>, [\<rho>p, m, P, leq, one] @ nenv) \<Turnstile> body_fm(\<phi>,nenv)" by simp
    from inM
    have "M , [\<rho>p,m,P,leq,one] @ nenv \<Turnstile> ?f_fm \<longleftrightarrow> least(##M, QQ(\<rho>p), m)"
      using sats_least_fm[OF body', of 1] unfolding QQ_def
      by (simp, simp flip: setclass_iff)
  }
  then
  have "M, [\<rho>p,m,P,leq,one] @ nenv \<Turnstile> ?f_fm \<longleftrightarrow> least(##M, QQ(\<rho>p), m)"
    if "\<rho>p\<in>M" "\<rho>p\<in>?\<pi>" "m\<in>M" for \<rho>p m using that by simp
  then
  have "univalent(##M, ?\<pi>, \<lambda>\<rho>p m. M , [\<rho>p,m] @ ([P,leq,one] @ nenv) \<Turnstile> ?f_fm)"
    unfolding univalent_def by (auto intro:unique_least)
  moreover from \<open>length(_) = _\<close> \<open>env \<in> _\<close>
  have "length([P,leq,one] @ nenv) = 3 #+ length(env)" by simp
  moreover from \<open>arity(_) \<le> 2 #+ length(nenv)\<close>
    \<open>length(_) = length(_)\<close>[symmetric] \<open>nenv\<in>_\<close> \<open>\<phi>\<in>_\<close>
  have "arity(?f_fm) \<le> 5 #+ length(env)"
    unfolding body_fm_def  new_fm_defs least_fm_def
    using arity_forces arity_renrep arity_renbody arity_body_fm' nonempty
    by (simp add: pred_Un Un_assoc, simp add: Un_assoc[symmetric] nat_union_abs1 pred_Un)
      (auto simp add: nat_simp_union, rule pred_le, auto intro:leI)
  moreover from \<open>\<phi>\<in>formula\<close> \<open>nenv\<in>list(M)\<close>
  have "?f_fm\<in>formula" by simp
  moreover
  note inM = P_in_M leq_in_M one_in_M \<open>nenv\<in>list(M)\<close> \<open>?\<pi>\<in>M\<close>
  ultimately
  obtain Y where "Y\<in>M"
    "\<forall>m\<in>M. m \<in> Y \<longleftrightarrow> (\<exists>\<rho>p\<in>M. \<rho>p \<in> ?\<pi> \<and> M, [\<rho>p,m] @ ([P,leq,one] @ nenv) \<Turnstile> ?f_fm)"
    using replacement_ax[of ?f_fm "[P,leq,one] @ nenv"]
    unfolding strong_replacement_def by auto
  with \<open>least(_,QQ(_),f(_))\<close> \<open>f(_) \<in> M\<close> \<open>?\<pi>\<in>M\<close>
    \<open>_ \<Longrightarrow> _ \<Longrightarrow> _ \<Longrightarrow> M,_ \<Turnstile> ?f_fm \<longleftrightarrow> least(_,_,_)\<close>
  have "f(\<rho>p)\<in>Y" if "\<rho>p\<in>?\<pi>" for \<rho>p
    using that transitivity[OF _ \<open>?\<pi>\<in>M\<close>]
    by (clarsimp, rule_tac x="\<langle>x,y\<rangle>" in bexI, auto)
  moreover
  have "{y\<in>Y. Ord(y)} \<in> M"
    using \<open>Y\<in>M\<close> separation_ax sats_ordinal_fm trans_M
      separation_cong[of "##M" "\<lambda>y. sats(M,ordinal_fm(0),[y])" "Ord"]
      separation_closed by simp
  then
  have "\<Union> {y\<in>Y. Ord(y)} \<in> M" (is "?sup \<in> M")
    using Union_closed by simp
  then
  have "{x\<in>Vset(?sup). x \<in> M} \<in> M"
    using Vset_closed by simp
  moreover
  have "{one} \<in> M"
    using one_in_M singletonM by simp
  ultimately
  have "{x\<in>Vset(?sup). x \<in> M} \<times> {one} \<in> M" (is "?big_name \<in> M")
    using cartprod_closed by simp
  then
  have "val(G,?big_name) \<in> M[G]"
    by (blast intro:GenExtI)
  {
    fix v x
    assume "x\<in>c"
    moreover
    note \<open>val(G,\<pi>')=c\<close> \<open>\<pi>'\<in>M\<close>
    moreover
    from calculation
    obtain \<rho> p where "\<langle>\<rho>,p\<rangle>\<in>\<pi>'"  "val(G,\<rho>) = x" "p\<in>G" "\<rho>\<in>M"
      using elem_of_val_pair'[of \<pi>' x G] by blast
    moreover
    assume "v\<in>M[G]"
    then
    obtain \<sigma> where "val(G,\<sigma>) = v" "\<sigma>\<in>M"
      using GenExtD by auto
    moreover
    assume "sats(M[G], \<phi>, [x,v] @ env)"
    moreover
    note \<open>\<phi>\<in>_\<close> \<open>nenv\<in>_\<close> \<open>env = _\<close> \<open>arity(\<phi>)\<le> 2 #+ length(env)\<close>
    ultimately
    obtain q where "q\<in>G" "q \<tturnstile> \<phi> ([\<rho>,\<sigma>]@nenv)"
      using truth_lemma[OF \<open>\<phi>\<in>_\<close> generic, symmetric, of "[\<rho>,\<sigma>] @ nenv"]
      by auto
    with \<open>\<langle>\<rho>,p\<rangle>\<in>\<pi>'\<close> \<open>\<langle>\<rho>,q\<rangle>\<in>?\<pi> \<Longrightarrow> f(\<langle>\<rho>,q\<rangle>)\<in>Y\<close>
    have "f(\<langle>\<rho>,q\<rangle>)\<in>Y"
      using generic unfolding M_generic_def filter_def by blast
    let ?\<alpha>="succ(rank(\<sigma>))"
    note \<open>\<sigma>\<in>M\<close>
    moreover from this
    have "?\<alpha> \<in> M"
      using rank_closed cons_closed by (simp flip: setclass_iff)
    moreover
    have "\<sigma> \<in> Vset(?\<alpha>)"
      using Vset_Ord_rank_iff by auto
    moreover
    note \<open>q \<tturnstile> \<phi> ([\<rho>,\<sigma>] @ nenv)\<close>
    ultimately
    have "?P(\<langle>\<rho>,q\<rangle>,?\<alpha>)" by (auto simp del: Vset_rank_iff)
    moreover
    have "(\<mu> \<alpha>. ?P(\<langle>\<rho>,q\<rangle>,\<alpha>)) = f(\<langle>\<rho>,q\<rangle>)"
      unfolding f_def by simp
    ultimately
    obtain \<tau> where "\<tau>\<in>M" "\<tau> \<in> Vset(f(\<langle>\<rho>,q\<rangle>))" "q \<tturnstile> \<phi> ([\<rho>,\<tau>] @ nenv)"
      using LeastI[of "\<lambda> \<alpha>. ?P(\<langle>\<rho>,q\<rangle>,\<alpha>)" ?\<alpha>] by auto
    with \<open>q\<in>G\<close> \<open>\<rho>\<in>M\<close> \<open>nenv\<in>_\<close> \<open>arity(\<phi>)\<le> 2 #+ length(nenv)\<close>
    have "M[G], map(val(G),[\<rho>,\<tau>] @ nenv) \<Turnstile> \<phi>"
      using truth_lemma[OF \<open>\<phi>\<in>_\<close> generic, of "[\<rho>,\<tau>] @ nenv"] by auto
    moreover from \<open>x\<in>c\<close> \<open>c\<in>M[G]\<close>
    have "x\<in>M[G]" using transitivity_MG by simp
    moreover
    note \<open>M[G],[x,v] @ env\<Turnstile> \<phi>\<close> \<open>env = map(val(G),nenv)\<close> \<open>\<tau>\<in>M\<close> \<open>val(G,\<rho>)=x\<close>
      \<open>univalent(##M[G],_,_)\<close> \<open>x\<in>c\<close> \<open>v\<in>M[G]\<close>
    ultimately
    have "v=val(G,\<tau>)"
      using GenExtI[of \<tau> G] unfolding univalent_def by (auto)
    from \<open>\<tau> \<in> Vset(f(\<langle>\<rho>,q\<rangle>))\<close> \<open>Ord(f(_))\<close>  \<open>f(\<langle>\<rho>,q\<rangle>)\<in>Y\<close>
    have "\<tau> \<in> Vset(?sup)"
      using Vset_Ord_rank_iff lt_Union_iff[of _ "rank(\<tau>)"] by auto
    with \<open>\<tau>\<in>M\<close>
    have "val(G,\<tau>) \<in> val(G,?big_name)"
      using domain_of_prod[of one "{one}" "{x\<in>Vset(?sup). x \<in> M}" ] def_val[of G ?big_name]
        one_in_G[OF generic] one_in_P  by (auto simp del: Vset_rank_iff)
    with \<open>v=val(G,\<tau>)\<close>
    have "v \<in> val(G,{x\<in>Vset(?sup). x \<in> M} \<times> {one})"
      by simp
  }
  then
  have "{v. x\<in>c, ?R(x,v)} \<subseteq> val(G,?big_name)" (is "?repl\<subseteq>?big")
    by blast
  with \<open>?big_name\<in>M\<close>
  have "?repl = {v\<in>?big. \<exists>x\<in>c. sats(M[G], \<phi>, [x,v] @ env )}" (is "_ = ?rhs")
  proof(intro equalityI subsetI)
    fix v
    assume "v\<in>?repl"
    with \<open>?repl\<subseteq>?big\<close>
    obtain x where "x\<in>c" "M[G], [x, v] @ env \<Turnstile> \<phi>" "v\<in>?big"
      using subsetD by auto
    with \<open>univalent(##M[G],_,_)\<close> \<open>c\<in>M[G]\<close>
    show "v \<in> ?rhs"
      unfolding univalent_def
      using transitivity_MG ReplaceI[of "\<lambda> x v. \<exists>x\<in>c. M[G], [x, v] @ env \<Turnstile> \<phi>"] by blast
  next
    fix v
    assume "v\<in>?rhs"
    then
    obtain x where
      "v\<in>val(G, ?big_name)" "M[G], [x, v] @ env \<Turnstile> \<phi>" "x\<in>c"
      by blast
    moreover from this \<open>c\<in>M[G]\<close>
    have "v\<in>M[G]" "x\<in>M[G]"
      using transitivity_MG GenExtI[OF \<open>?big_name\<in>_\<close>,of G] by auto
    moreover from calculation \<open>univalent(##M[G],_,_)\<close>
    have "?R(x,y) \<Longrightarrow> y = v" for y
      unfolding univalent_def by auto
    ultimately
    show "v\<in>?repl"
      using ReplaceI[of ?R x v c]
      by blast
  qed
  moreover
  let ?\<psi> = "Exists(And(Member(0,2#+length(env)),\<phi>))"
  have "v\<in>M[G] \<Longrightarrow> (\<exists>x\<in>c. M[G], [x,v] @ env \<Turnstile> \<phi>) \<longleftrightarrow> M[G], [v] @ env @ [c] \<Turnstile> ?\<psi>"
    "arity(?\<psi>) \<le> 2 #+ length(env)" "?\<psi>\<in>formula"
    for v
  proof -
    fix v
    assume "v\<in>M[G]"
    with \<open>c\<in>M[G]\<close>
    have "nth(length(env)#+1,[v]@env@[c]) = c"
      using  \<open>env\<in>_\<close>nth_concat[of v c "M[G]" env]
      by auto
    note inMG= \<open>nth(length(env)#+1,[v]@env@[c]) = c\<close> \<open>c\<in>M[G]\<close> \<open>v\<in>M[G]\<close> \<open>env\<in>_\<close>
    show "(\<exists>x\<in>c. M[G], [x,v] @ env \<Turnstile> \<phi>) \<longleftrightarrow> M[G], [v] @ env @ [c] \<Turnstile> ?\<psi>"
    proof
      assume "\<exists>x\<in>c. M[G], [x, v] @ env \<Turnstile> \<phi>"
      then obtain x where
        "x\<in>c" "M[G], [x, v] @ env \<Turnstile> \<phi>" "x\<in>M[G]"
        using transitivity_MG[OF _ \<open>c\<in>M[G]\<close>]
        by auto
      with \<open>\<phi>\<in>_\<close> \<open>arity(\<phi>)\<le>2#+length(env)\<close> inMG
      show "M[G], [v] @ env @ [c] \<Turnstile> Exists(And(Member(0, 2 #+ length(env)), \<phi>))"
        using arity_sats_iff[of \<phi> "[c]" _ "[x,v]@env"]
        by auto
    next
      assume "M[G], [v] @ env @ [c] \<Turnstile> Exists(And(Member(0, 2 #+ length(env)), \<phi>))"
      with inMG
      obtain x where
        "x\<in>M[G]" "x\<in>c" "M[G], [x,v]@env@[c] \<Turnstile> \<phi>"
        by auto
      with \<open>\<phi>\<in>_\<close> \<open>arity(\<phi>)\<le>2#+length(env)\<close> inMG
      show "\<exists>x\<in>c. M[G], [x, v] @ env\<Turnstile> \<phi>"
        using arity_sats_iff[of \<phi> "[c]" _ "[x,v]@env"]
        by auto
    qed
  next
    from \<open>env\<in>_\<close> \<open>\<phi>\<in>_\<close>
    show "arity(?\<psi>)\<le>2#+length(env)"
      using pred_mono[OF _ \<open>arity(\<phi>)\<le>2#+length(env)\<close>] lt_trans[OF _ le_refl]
      by (auto simp add:nat_simp_union)
  next
    from \<open>\<phi>\<in>_\<close>
    show "?\<psi>\<in>formula" by simp
  qed
  moreover from this
  have "{v\<in>?big. \<exists>x\<in>c. M[G], [x,v] @ env \<Turnstile> \<phi>} = {v\<in>?big. M[G], [v] @ env @ [c] \<Turnstile>  ?\<psi>}"
    using transitivity_MG[OF _ GenExtI, OF _ \<open>?big_name\<in>M\<close>]
    by simp
  moreover from calculation and \<open>env\<in>_\<close> \<open>c\<in>_\<close> \<open>?big\<in>M[G]\<close>
  have "{v\<in>?big. M[G] , [v] @ env @ [c] \<Turnstile> ?\<psi>} \<in> M[G]"
    using Collect_sats_in_MG by auto
  ultimately
  show ?thesis by simp
qed

theorem strong_replacement_in_MG:
  assumes
    "\<phi>\<in>formula" and "arity(\<phi>) \<le> 2 #+ length(env)" "env \<in> list(M[G])"
  shows
    "strong_replacement(##M[G],\<lambda>x v. sats(M[G],\<phi>,[x,v] @ env))"
proof -
  let ?R="\<lambda>x y . M[G], [x, y] @ env \<Turnstile> \<phi>"
  {
    fix A
    let ?Y="{v . x \<in> A, v\<in>M[G] \<and> ?R(x,v)}"
    assume 1: "(##M[G])(A)"
      "\<forall>x[##M[G]]. x \<in> A \<longrightarrow> (\<forall>y[##M[G]]. \<forall>z[##M[G]]. ?R(x,y) \<and> ?R(x,z) \<longrightarrow> y = z)"
    then
    have "univalent(##M[G], A, ?R)" "A\<in>M[G]"
      unfolding univalent_def by simp_all
    with assms \<open>A\<in>_\<close>
    have "(##M[G])(?Y)"
      using Replace_sats_in_MG by auto
    have "b \<in> ?Y \<longleftrightarrow> (\<exists>x[##M[G]]. x \<in> A \<and> ?R(x,b))" if "(##M[G])(b)" for b
    proof(rule)
      from \<open>A\<in>_\<close>
      show "\<exists>x[##M[G]]. x \<in> A \<and> ?R(x,b)" if "b \<in> ?Y"
        using that transitivity_MG by auto
    next
      show "b \<in> ?Y" if "\<exists>x[##M[G]]. x \<in> A \<and> ?R(x,b)"
      proof -
        from \<open>(##M[G])(b)\<close>
        have "b\<in>M[G]" by simp
        with that
        obtain x where "(##M[G])(x)" "x\<in>A" "b\<in>M[G] \<and> ?R(x,b)"
          by blast
        moreover from this 1 \<open>(##M[G])(b)\<close>
        have "x\<in>M[G]" "z\<in>M[G] \<and> ?R(x,z) \<Longrightarrow> b = z" for z
          by auto
        ultimately
        show ?thesis
          using ReplaceI[of "\<lambda> x y. y\<in>M[G] \<and> ?R(x,y)"] by auto
      qed
    qed
    then
    have "\<forall>b[##M[G]]. b \<in> ?Y \<longleftrightarrow> (\<exists>x[##M[G]]. x \<in> A \<and> ?R(x,b))"
      by simp
    with \<open>(##M[G])(?Y)\<close>
    have " (\<exists>Y[##M[G]]. \<forall>b[##M[G]]. b \<in> Y \<longleftrightarrow> (\<exists>x[##M[G]]. x \<in> A \<and> ?R(x,b)))"
      by auto
  }
  then show ?thesis unfolding strong_replacement_def univalent_def
    by auto
qed

end (* context G_generic *)

end