(*  Title:      HOL/Imperative_HOL/ex/List_Sublist.thy
    Author:     Lukas Bulwahn, TU Muenchen
*)

section \<open>Slices of lists\<close>

theory List_Sublist
imports "HOL-Library.Multiset"
begin

lemma nths_split: "i \<le> j \<and> j \<le> k \<Longrightarrow> nths xs {i..<j} @ nths xs {j..<k} = nths xs {i..<k}"
apply (induct xs arbitrary: i j k)
apply simp
apply (simp only: nths_Cons)
apply simp
apply safe
apply simp
apply (erule_tac x="0" in meta_allE)
apply (erule_tac x="j - 1" in meta_allE)
apply (erule_tac x="k - 1" in meta_allE)
apply (subgoal_tac "0 \<le> j - 1 \<and> j - 1 \<le> k - 1")
apply simp
apply (subgoal_tac "{ja. Suc ja < j} = {0..<j - Suc 0}")
apply (subgoal_tac "{ja. j \<le> Suc ja \<and> Suc ja < k} = {j - Suc 0..<k - Suc 0}")
apply (subgoal_tac "{j. Suc j < k} = {0..<k - Suc 0}")
apply simp
apply fastforce
apply fastforce
apply fastforce
apply fastforce
apply (erule_tac x="i - 1" in meta_allE)
apply (erule_tac x="j - 1" in meta_allE)
apply (erule_tac x="k - 1" in meta_allE)
apply (subgoal_tac " {ja. i \<le> Suc ja \<and> Suc ja < j} = {i - 1 ..<j - 1}")
apply (subgoal_tac " {ja. j \<le> Suc ja \<and> Suc ja < k} = {j - 1..<k - 1}")
apply (subgoal_tac "{j. i \<le> Suc j \<and> Suc j < k} = {i - 1..<k - 1}")
apply (subgoal_tac " i - 1 \<le> j - 1 \<and> j - 1 \<le> k - 1")
apply simp
apply fastforce
apply fastforce
apply fastforce
apply fastforce
done

lemma nths_update1: "i \<notin> inds \<Longrightarrow> nths (xs[i := v]) inds = nths xs inds"
apply (induct xs arbitrary: i inds)
apply simp
apply (case_tac i)
apply (simp add: nths_Cons)
apply (simp add: nths_Cons)
done

lemma nths_update2: "i \<in> inds \<Longrightarrow> nths (xs[i := v]) inds = (nths xs inds)[(card {k \<in> inds. k < i}):= v]"
proof (induct xs arbitrary: i inds)
  case Nil thus ?case by simp
next
  case (Cons x xs)
  thus ?case
  proof (cases i)
    case 0 with Cons show ?thesis by (simp add: nths_Cons)
  next
    case (Suc i')
    with Cons show ?thesis
      apply simp
      apply (simp add: nths_Cons)
      apply auto
      apply (auto simp add: nat.split)
      apply (simp add: card_less_Suc[symmetric])
      apply (simp add: card_less_Suc2)
      done
  qed
qed

lemma nths_update: "nths (xs[i := v]) inds = (if i \<in> inds then (nths xs inds)[(card {k \<in> inds. k < i}) := v] else nths xs inds)"
by (simp add: nths_update1 nths_update2)

lemma nths_take: "nths xs {j. j < m} = take m xs"
apply (induct xs arbitrary: m)
apply simp
apply (case_tac m)
apply simp
apply (simp add: nths_Cons)
done

lemma nths_take': "nths xs {0..<m} = take m xs"
apply (induct xs arbitrary: m)
apply simp
apply (case_tac m)
apply simp
apply (simp add: nths_Cons nths_take)
done

lemma nths_all[simp]: "nths xs {j. j < length xs} = xs"
apply (induct xs)
apply simp
apply (simp add: nths_Cons)
done

lemma nths_all'[simp]: "nths xs {0..<length xs} = xs"
apply (induct xs)
apply simp
apply (simp add: nths_Cons)
done

lemma nths_single: "a < length xs \<Longrightarrow> nths xs {a} = [xs ! a]"
apply (induct xs arbitrary: a)
apply simp
apply(case_tac aa)
apply simp
apply (simp add: nths_Cons)
apply simp
apply (simp add: nths_Cons)
done

lemma nths_is_Nil: "\<forall>i \<in> inds. i \<ge> length xs \<Longrightarrow> nths xs inds = []"
apply (induct xs arbitrary: inds)
apply simp
apply (simp add: nths_Cons)
apply auto
apply (erule_tac x="{j. Suc j \<in> inds}" in meta_allE)
apply auto
done

lemma nths_Nil': "nths xs inds = [] \<Longrightarrow> \<forall>i \<in> inds. i \<ge> length xs"
apply (induct xs arbitrary: inds)
apply simp
apply (simp add: nths_Cons)
apply (auto split: if_splits)
apply (erule_tac x="{j. Suc j \<in> inds}" in meta_allE)
apply (case_tac x, auto)
done

lemma nths_Nil[simp]: "(nths xs inds = []) = (\<forall>i \<in> inds. i \<ge> length xs)"
apply (induct xs arbitrary: inds)
apply simp
apply (simp add: nths_Cons)
apply auto
apply (erule_tac x="{j. Suc j \<in> inds}" in meta_allE)
apply (case_tac x, auto)
done

lemma nths_eq_subseteq: " \<lbrakk> inds' \<subseteq> inds; nths xs inds = nths ys inds \<rbrakk> \<Longrightarrow> nths xs inds' = nths ys inds'"
apply (induct xs arbitrary: ys inds inds')
apply simp
apply (drule sym, rule sym)
apply (simp add: nths_Nil, fastforce)
apply (case_tac ys)
apply (simp add: nths_Nil, fastforce)
apply (auto simp add: nths_Cons)
apply (erule_tac x="list" in meta_allE)
apply (erule_tac x="{j. Suc j \<in> inds}" in meta_allE)
apply (erule_tac x="{j. Suc j \<in> inds'}" in meta_allE)
apply fastforce
apply (erule_tac x="list" in meta_allE)
apply (erule_tac x="{j. Suc j \<in> inds}" in meta_allE)
apply (erule_tac x="{j. Suc j \<in> inds'}" in meta_allE)
apply fastforce
done

lemma nths_eq: "\<lbrakk> \<forall>i \<in> inds. ((i < length xs) \<and> (i < length ys)) \<or> ((i \<ge> length xs ) \<and> (i \<ge> length ys)); \<forall>i \<in> inds. xs ! i = ys ! i \<rbrakk> \<Longrightarrow> nths xs inds = nths ys inds"
apply (induct xs arbitrary: ys inds)
apply simp
apply (rule sym, simp add: nths_Nil)
apply (case_tac ys)
apply (simp add: nths_Nil)
apply (auto simp add: nths_Cons)
apply (erule_tac x="list" in meta_allE)
apply (erule_tac x="{j. Suc j \<in> inds}" in meta_allE)
apply fastforce
apply (erule_tac x="list" in meta_allE)
apply (erule_tac x="{j. Suc j \<in> inds}" in meta_allE)
apply fastforce
done

lemma nths_eq_samelength: "\<lbrakk> length xs = length ys; \<forall>i \<in> inds. xs ! i = ys ! i \<rbrakk> \<Longrightarrow> nths xs inds = nths ys inds"
by (rule nths_eq, auto)

lemma nths_eq_samelength_iff: "length xs = length ys \<Longrightarrow> (nths xs inds = nths ys inds) = (\<forall>i \<in> inds. xs ! i = ys ! i)"
apply (induct xs arbitrary: ys inds)
apply simp
apply (rule sym, simp add: nths_Nil)
apply (case_tac ys)
apply (simp add: nths_Nil)
apply (auto simp add: nths_Cons)
apply (case_tac i)
apply auto
apply (case_tac i)
apply auto
done

section \<open>Another nths function\<close>

function nths' :: "nat \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "nths' n m [] = []"
| "nths' n 0 xs = []"
| "nths' 0 (Suc m) (x#xs) = (x#nths' 0 m xs)"
| "nths' (Suc n) (Suc m) (x#xs) = nths' n m xs"
by pat_completeness auto
termination by lexicographic_order

subsection \<open>Proving equivalence to the other nths command\<close>

lemma nths'_nths: "nths' n m xs = nths xs {j. n \<le> j \<and> j < m}"
apply (induct xs arbitrary: n m)
apply simp
apply (case_tac n)
apply (case_tac m)
apply simp
apply (simp add: nths_Cons)
apply (case_tac m)
apply simp
apply (simp add: nths_Cons)
done

lemma "nths' n m xs = nths xs {n..<m}"
apply (induct xs arbitrary: n m)
apply simp
apply (case_tac n, case_tac m)
apply simp
apply simp
apply (simp add: nths_take')
apply (case_tac m)
apply simp
apply (simp add: nths_Cons nths'_nths)
done

subsection \<open>Showing equivalence to use of drop and take for definition\<close>

lemma "nths' n m xs = take (m - n) (drop n xs)"
apply (induct xs arbitrary: n m)
apply simp
apply (case_tac m)
apply simp
apply (case_tac n)
apply simp
apply simp
done

subsection \<open>General lemma about nths\<close>

lemma nths'_Nil[simp]: "nths' i j [] = []"
by simp

lemma nths'_Cons[simp]: "nths' i (Suc j) (x#xs) = (case i of 0 \<Rightarrow> (x # nths' 0 j xs) | Suc i' \<Rightarrow>  nths' i' j xs)"
by (cases i) auto

lemma nths'_Cons2[simp]: "nths' i j (x#xs) = (if (j = 0) then [] else ((if (i = 0) then [x] else []) @ nths' (i - 1) (j - 1) xs))"
apply (cases j)
apply auto
apply (cases i)
apply auto
done

lemma nths_n_0: "nths' n 0 xs = []"
by (induct xs, auto)

lemma nths'_Nil': "n \<ge> m \<Longrightarrow> nths' n m xs = []"
apply (induct xs arbitrary: n m)
apply simp
apply (case_tac m)
apply simp
apply (case_tac n)
apply simp
apply simp
done

lemma nths'_Nil2: "n \<ge> length xs \<Longrightarrow> nths' n m xs = []"
apply (induct xs arbitrary: n m)
apply simp
apply (case_tac m)
apply simp
apply (case_tac n)
apply simp
apply simp
done

lemma nths'_Nil3: "(nths' n m xs = []) = ((n \<ge> m) \<or> (n \<ge> length xs))"
apply (induct xs arbitrary: n m)
apply simp
apply (case_tac m)
apply simp
apply (case_tac n)
apply simp
apply simp
done

lemma nths'_notNil: "\<lbrakk> n < length xs; n < m \<rbrakk> \<Longrightarrow> nths' n m xs \<noteq> []"
apply (induct xs arbitrary: n m)
apply simp
apply (case_tac m)
apply simp
apply (case_tac n)
apply simp
apply simp
done

lemma nths'_single: "n < length xs \<Longrightarrow> nths' n (Suc n) xs = [xs ! n]"
apply (induct xs arbitrary: n)
apply simp
apply simp
apply (case_tac n)
apply (simp add: nths_n_0)
apply simp
done

lemma nths'_update1: "i \<ge> m \<Longrightarrow> nths' n m (xs[i:=v]) = nths' n m xs"
apply (induct xs arbitrary: n m i)
apply simp
apply simp
apply (case_tac i)
apply simp
apply simp
done

lemma nths'_update2: "i < n \<Longrightarrow> nths' n m (xs[i:=v]) = nths' n m xs"
apply (induct xs arbitrary: n m i)
apply simp
apply simp
apply (case_tac i)
apply simp
apply simp
done

lemma nths'_update3: "\<lbrakk>n \<le> i; i < m\<rbrakk> \<Longrightarrow> nths' n m (xs[i := v]) = (nths' n m xs)[i - n := v]"
proof (induct xs arbitrary: n m i)
  case Nil thus ?case by auto
next
  case (Cons x xs)
  thus ?case
    apply -
    apply auto
    apply (cases i)
    apply auto
    apply (cases i)
    apply auto
    done
qed

lemma "\<lbrakk> nths' i j xs = nths' i j ys; n \<ge> i; m \<le> j \<rbrakk> \<Longrightarrow> nths' n m xs = nths' n m ys"
proof (induct xs arbitrary: i j ys n m)
  case Nil
  thus ?case
    apply -
    apply (rule sym, drule sym)
    apply (simp add: nths'_Nil)
    apply (simp add: nths'_Nil3)
    apply arith
    done
next
  case (Cons x xs i j ys n m)
  note c = this
  thus ?case
  proof (cases m)
    case 0 thus ?thesis by (simp add: nths_n_0)
  next
    case (Suc m')
    note a = this
    thus ?thesis
    proof (cases n)
      case 0 note b = this
      show ?thesis
      proof (cases ys)
        case Nil  with a b Cons.prems show ?thesis by (simp add: nths'_Nil3)
      next
        case (Cons y ys)
        show ?thesis
        proof (cases j)
          case 0 with a b Cons.prems show ?thesis by simp
        next
          case (Suc j') with a b Cons.prems Cons show ?thesis
            apply -
            apply (simp, rule Cons.hyps [of "0" "j'" "ys" "0" "m'"], auto)
            done
        qed
      qed
    next
      case (Suc n')
      show ?thesis
      proof (cases ys)
        case Nil with Suc a Cons.prems show ?thesis by (auto simp add: nths'_Nil3)
      next
        case (Cons y ys) with Suc a Cons.prems show ?thesis
          apply -
          apply simp
          apply (cases j)
          apply simp
          apply (cases i)
          apply simp
          apply (rule_tac j="nat" in Cons.hyps [of "0" _ "ys" "n'" "m'"])
          apply simp
          apply simp
          apply simp
          apply simp
          apply (rule_tac i="nata" and j="nat" in Cons.hyps [of _ _ "ys" "n'" "m'"])
          apply simp
          apply simp
          apply simp
          done
      qed
    qed
  qed
qed

lemma length_nths': "j \<le> length xs \<Longrightarrow> length (nths' i j xs) = j - i"
by (induct xs arbitrary: i j, auto)

lemma nths'_front: "\<lbrakk> i < j; i < length xs \<rbrakk> \<Longrightarrow> nths' i j xs = xs ! i # nths' (Suc i) j xs"
apply (induct xs arbitrary: i j)
apply simp
apply (case_tac j)
apply simp
apply (case_tac i)
apply simp
apply simp
done

lemma nths'_back: "\<lbrakk> i < j; j \<le> length xs \<rbrakk> \<Longrightarrow> nths' i j xs = nths' i (j - 1) xs @ [xs ! (j - 1)]"
apply (induct xs arbitrary: i j)
apply simp
apply simp
done

(* suffices that j \<le> length xs and length ys *)
lemma nths'_eq_samelength_iff: "length xs = length ys \<Longrightarrow> (nths' i j xs  = nths' i j ys) = (\<forall>i'. i \<le> i' \<and> i' < j \<longrightarrow> xs ! i' = ys ! i')"
proof (induct xs arbitrary: ys i j)
  case Nil thus ?case by simp
next
  case (Cons x xs)
  thus ?case
    apply -
    apply (cases ys)
    apply simp
    apply simp
    apply auto
    apply (case_tac i', auto)
    apply (erule_tac x="Suc i'" in allE, auto)
    apply (erule_tac x="i' - 1" in allE, auto)
    apply (erule_tac x="Suc i'" in allE, auto)
    done
qed

lemma nths'_all[simp]: "nths' 0 (length xs) xs = xs"
by (induct xs, auto)

lemma nths'_nths': "nths' n m (nths' i j xs) = nths' (i + n) (min (i + m) j) xs"
by (induct xs arbitrary: i j n m) (auto simp add: min_diff)

lemma nths'_append: "\<lbrakk> i \<le> j; j \<le> k \<rbrakk> \<Longrightarrow>(nths' i j xs) @ (nths' j k xs) = nths' i k xs"
by (induct xs arbitrary: i j k) auto

lemma nth_nths': "\<lbrakk> k < j - i; j \<le> length xs \<rbrakk> \<Longrightarrow> (nths' i j xs) ! k = xs ! (i + k)"
apply (induct xs arbitrary: i j k)
apply simp
apply (case_tac k)
apply auto
done

lemma set_nths': "set (nths' i j xs) = {x. \<exists>k. i \<le> k \<and> k < j \<and> k < List.length xs \<and> x = xs ! k}"
apply (simp add: nths'_nths)
apply (simp add: set_nths)
apply auto
done

lemma all_in_set_nths'_conv: "(\<forall>j. j \<in> set (nths' l r xs) \<longrightarrow> P j) = (\<forall>k. l \<le> k \<and> k < r \<and> k < List.length xs \<longrightarrow> P (xs ! k))"
unfolding set_nths' by blast

lemma ball_in_set_nths'_conv: "(\<forall>j \<in> set (nths' l r xs). P j) = (\<forall>k. l \<le> k \<and> k < r \<and> k < List.length xs \<longrightarrow> P (xs ! k))"
unfolding set_nths' by blast

lemma mset_nths:
assumes l_r: "l \<le> r \<and> r \<le> List.length xs"
assumes left: "\<forall> i. i < l \<longrightarrow> (xs::'a list) ! i = ys ! i"
assumes right: "\<forall> i. i \<ge> r \<longrightarrow> (xs::'a list) ! i = ys ! i"
assumes multiset: "mset xs = mset ys"
  shows "mset (nths' l r xs) = mset (nths' l r ys)"
proof -
  from l_r have xs_def: "xs = (nths' 0 l xs) @ (nths' l r xs) @ (nths' r (List.length xs) xs)" (is "_ = ?xs_long")
    by (simp add: nths'_append)
  from multiset have length_eq: "List.length xs = List.length ys" by (rule mset_eq_length)
  with l_r have ys_def: "ys = (nths' 0 l ys) @ (nths' l r ys) @ (nths' r (List.length ys) ys)" (is "_ = ?ys_long")
    by (simp add: nths'_append)
  from xs_def ys_def multiset have "mset ?xs_long = mset ?ys_long" by simp
  moreover
  from left l_r length_eq have "nths' 0 l xs = nths' 0 l ys"
    by (auto simp add: length_nths' nth_nths' intro!: nth_equalityI)
  moreover
  from right l_r length_eq have "nths' r (List.length xs) xs = nths' r (List.length ys) ys"
    by (auto simp add: length_nths' nth_nths' intro!: nth_equalityI)
  ultimately show ?thesis by (simp add: mset_append)
qed

end


section \<open>Set Associative Cache\<close>

theory CM_SaSpec
  imports Main CM_SecurityModel
begin

subsection \<open>Data type, Basic components\<close>

(*Basic data structures*)
type_synonym tagmask = nat
type_synonym setbits = nat
type_synonym setindex = nat
type_synonym wayindex = nat

datatype cachehit = Hit | Miss

datatype event = SA_READ

(*Memory blocks*)
record memory_request =
  tag :: tagmask
  index :: setbits

(*Cache structure*)
record cache_line =
  ca_tag :: tagmask
  ca_set :: setindex
  ca_way :: wayindex
  valid :: bool

type_synonym cache = "(cache_line set) list"

type_synonym mapping = "setbits \<rightharpoonup> setindex"

(*State Machine*)
record state =
  sram :: cache
  maps :: mapping

subsection \<open>Set Associative cache model specifications\<close>

definition replace_policy :: "cache_line set \<Rightarrow> cache_line"
  where "replace_policy cs \<equiv> SOME l. l \<in> cs"

definition probe_line :: "cache_line set \<Rightarrow> memory_request \<Rightarrow> bool"
  where "probe_line cs mr \<equiv> \<exists>b. b \<in> cs \<and> ca_tag b = tag mr \<and> valid b"

definition replace_line :: "cache_line \<Rightarrow> memory_request \<Rightarrow> cache_line"
  where "replace_line cl mr \<equiv> cl\<lparr>ca_tag := tag mr, valid := True\<rparr>"

definition sa_read :: "state \<Rightarrow> memory_request \<Rightarrow> state set" where
  "sa_read s mr \<equiv>
      let redir_set = the ((maps s) (index mr));
          redir_ca = (sram s) ! redir_set in
      if probe_line redir_ca mr then {s}
      else let r_line = replace_policy redir_ca;
               newset = insert (replace_line r_line mr) (redir_ca - {r_line}) in
           {s\<lparr>sram := list_update (sram s) redir_set newset\<rparr>}"

subsection \<open>Instantiation\<close>

record cache_NE =
  ca_N :: "cache set"
  ca_E :: "cache set"
  map_conf :: "mapping"
  mem_req :: "(memory_request \<times> real) set"

consts cache_comp :: cache_NE

definition cache_comp_witness :: "cache_NE"
  where "cache_comp_witness \<equiv> \<lparr>ca_N = {[{(\<lparr>ca_tag = 1, ca_set = 0, ca_way = 0, valid = True\<rparr>)}]},
                               ca_E = {[{(\<lparr>ca_tag = 1, ca_set = 0, ca_way = 0, valid = True\<rparr>)}]},
                               map_conf = (\<lambda>t. if t = 0 then Some 0 else None),
                               mem_req = {(\<lparr>tag = 0, index = 0\<rparr>, 1)}\<rparr>"

specification (cache_comp)
  caN_finite: "finite (ca_N cache_comp)"
  caN_nonempty: "(ca_N cache_comp) \<noteq> {}"

  ca_length: "\<forall>c \<in> (ca_N cache_comp). length c > 0"
  ca_length2: "\<forall>c1 c2. c1 \<in> (ca_N cache_comp) \<and> c2 \<in> (ca_N cache_comp) \<and> c1 \<noteq> c2 \<longrightarrow> length c1 = length c2"
  ca_finite: "\<forall>c \<in> (ca_N cache_comp). finite (set c)"
  ca_set_nonempty: "\<forall>c \<in> (ca_N cache_comp). (\<forall>l < length c. c!l \<noteq> {})"
  ca_set_finite: "\<forall>c \<in> (ca_N cache_comp). (\<forall>l < length c. finite (c!l))"
  ca_set_num: "\<forall>c \<in> (ca_N cache_comp). (\<forall>l < length c. \<forall>e \<in> (c!l). ca_set e = l)"
  ca_way_num: "\<forall>c \<in> (ca_N cache_comp). (\<forall>l1 l2. l1 < length c \<and> l2 < length c \<and> l1 \<noteq> l2 \<longrightarrow> card(c!l1) = card(c!l2))"
  ca_way_num2: "\<forall>c \<in> (ca_N cache_comp). (\<forall>l < length c. \<forall>e1 e2. e1 \<in> (c!l) \<and> e2 \<in> (c!l) \<and> e1 \<noteq> e2 \<longrightarrow> ca_way e1 \<noteq> ca_way e2)"

  caE_init: "(ca_E cache_comp) \<subseteq> (ca_N cache_comp)"
  caE_nonempty: "(ca_E cache_comp) \<noteq> {}"

  map_range: "\<forall>c \<in> (ca_N cache_comp). (\<forall>i. (map_conf cache_comp) i \<noteq> None \<longrightarrow> the ((map_conf cache_comp) i) < length c)"
  map_diff: "\<forall>i j. i \<noteq> j \<and> (map_conf cache_comp) i \<noteq> None \<and> (map_conf cache_comp) j \<noteq> None \<longrightarrow> the ((map_conf cache_comp) i) \<noteq> the ((map_conf cache_comp) j)"

  mem_finite: "finite (mem_req cache_comp)"
  mem_nonempty: "card (mem_req cache_comp) > 0"
  mem_unique: "\<forall>i j. i \<in> (mem_req cache_comp) \<and> j \<in> (mem_req cache_comp) \<and> i \<noteq> j \<longrightarrow> index (fst i) \<noteq> index (fst j)"
  mem_positive: "\<forall>i \<in> (mem_req cache_comp). snd i > 0"
  mem_sum_one: "folds (\<lambda>t p. snd t + p) 0 (mem_req cache_comp) = 1"
  mem_occupy: "\<forall>i \<in> (mem_req cache_comp). \<forall>c \<in> (ca_E cache_comp). \<forall>l < length c. \<forall>e \<in> (c!l). tag (fst i) \<noteq> ca_tag e"
  mem_mapping: "\<forall>i \<in> (mem_req cache_comp). (map_conf cache_comp) (index (fst i)) \<noteq> None"

  apply(intro exI[of _ cache_comp_witness])
  unfolding cache_comp_witness_def by auto

(*state N*)
consts state_N :: "state set"

definition state_N_witness :: "state set"
  where "state_N_witness \<equiv> {t. \<exists>c \<in> (ca_N cache_comp). t = \<lparr>sram = c, maps = (map_conf cache_comp)\<rparr>}"

specification (state_N)
  state_N_init: "state_N = state_N_witness"
  by simp

lemma stateN_finite: "finite state_N"
  proof -
    {
      have "\<forall>c \<in> (ca_N cache_comp). finite {t. \<exists>c \<in> (ca_N cache_comp). t = \<lparr>sram = c, maps = (map_conf cache_comp)\<rparr>}"
        using caN_finite by auto
      then show ?thesis
        using state_N_init state_N_witness_def by auto
    }
  qed

lemma stateN_nonempty: "state_N \<noteq> {}"
  using state_N_init state_N_witness_def caN_nonempty
  by blast

(*state E*)
consts state_E :: "state set"

definition state_E_witness :: "state set"
  where "state_E_witness \<equiv> {t. \<exists>c \<in> (ca_E cache_comp). t = \<lparr>sram = c, maps = (map_conf cache_comp)\<rparr>}"

specification (state_E)
  state_E_init: "state_E = state_E_witness"
  by simp

lemma stateE_nonempty: "state_E \<noteq> {}"
  using state_E_init state_E_witness_def caE_nonempty
  by blast

lemma stateE_subset: "state_E \<subseteq> state_N"
  using state_N_init state_N_witness_def state_E_init state_E_witness_def
  by (smt Collect_mono_iff caE_init subset_eq)

(*Observation*)
definition sa_read_observe :: "state \<Rightarrow> memory_request \<Rightarrow> ((setindex \<times> cachehit) \<times> real) set" where
  "sa_read_observe s mr \<equiv>
      let redir_set = the ((maps s) (index mr));
          redir_ca = (sram s) ! redir_set in
      if probe_line redir_ca mr then {((redir_set, Hit), 1)}
      else {((redir_set, Miss), 1)}"

lemma mem_cache_miss:
  "\<forall>i \<in> mem_req cache_comp. \<forall>s0 \<in> state_E. sa_read_observe s0 (fst i) = {((the ((maps s0) (index (fst i))), Miss), 1)}"
  proof -
    {
      fix i
      assume t0: "i \<in> mem_req cache_comp"
      have "\<forall>s0 \<in> state_E. sa_read_observe s0 (fst i) = {((the (maps s0 (index (fst i))), Miss), 1)}"
      proof -
        {
          fix s0
          assume t1: "s0 \<in> state_E"
          have "sa_read_observe s0 (fst i) = {((the (maps s0 (index (fst i))), Miss), 1)}"
          proof -
            {
              let ?redir_set = "the ((maps s0) (index (fst i)))"
              have exi_redir: "?redir_set < length (sram s0)"
                using state_E_init unfolding state_E_witness_def using mem_mapping
                by (smt caE_init map_range mem_Collect_eq state.select_convs(1) state.select_convs(2) subsetD t0 t1)
              let ?redir_ca = "(sram s0) ! ?redir_set"
              have "sram s0 \<in> ca_E cache_comp"
                using state_E_init unfolding state_E_witness_def
                proof -
                  assume "state_E = {t. \<exists>c\<in>ca_E cache_comp. t = \<lparr>sram = c, maps = map_conf cache_comp\<rparr>}"
                  then have "state_E = {s. \<exists>Cs. Cs \<in> ca_E cache_comp \<and> s = \<lparr>sram = Cs, maps = map_conf cache_comp\<rparr>}"
                    by (simp add: Bex_def_raw)
                  then have "\<exists>Cs. Cs \<in> ca_E cache_comp \<and> s0 = \<lparr>sram = Cs, maps = map_conf cache_comp\<rparr>"
                    using t1 by blast
                  then show ?thesis
                    by force
                qed
              then have setowned: "\<forall>i \<in> (mem_req cache_comp). \<forall>l < length (sram s0). \<forall>e \<in> ((sram s0)!l). tag (fst i) \<noteq> ca_tag e"
                using mem_occupy by auto
              then have "\<nexists>b. b \<in> ?redir_ca \<and> ca_tag b = tag (fst i) \<and> valid b"
                using exi_redir t0 by force
              then have c: "\<not> probe_line ?redir_ca (fst i)"
                unfolding probe_line_def by blast
              then have "sa_read_observe s0 (fst i) = {((?redir_set, Miss), 1)}"
                unfolding sa_read_observe_def Let_def by auto
            }
            then show ?thesis by blast
          qed
        }
        then show ?thesis by blast
      qed
    }
    then show ?thesis by blast
  qed

(*pmf instantiate*)
definition execution :: "memory_request \<Rightarrow> state \<Rightarrow> event \<Rightarrow> ((setindex \<times> cachehit) \<times> real) set"
  where "execution mr s e \<equiv> sa_read_observe s mr"

lemma read_finite:
  "\<forall>e. \<forall>mr \<in> mem_req cache_comp. \<forall>s \<in> state_N. finite (execution (fst mr) s e)"
  unfolding execution_def sa_read_observe_def Let_def
  by simp

lemma read_nonempty:
  "\<forall>e. \<forall>mr \<in> mem_req cache_comp. \<forall>s \<in> state_N. execution (fst mr) s e \<noteq> {}"
  unfolding execution_def sa_read_observe_def Let_def
  by auto

lemma read_unique:
  "\<forall>e. \<forall>mr \<in> mem_req cache_comp. \<forall>s \<in> state_N. \<forall>m n. m \<in> (execution (fst mr) s e) \<and> n \<in> (execution (fst mr) s e) \<and> m \<noteq> n \<longrightarrow> fst m \<noteq> fst n"
  unfolding execution_def sa_read_observe_def Let_def
  by auto

lemma read_positive:
  "\<forall>e. \<forall>mr \<in> mem_req cache_comp. \<forall>s \<in> state_N. \<forall>d \<in> (execution (fst mr) s e). snd d \<ge> 0"
  unfolding execution_def sa_read_observe_def Let_def
  by auto

lemma read_sum_one:
  "\<forall>e. \<forall>mr \<in> mem_req cache_comp. \<forall>s \<in> state_N. folds (\<lambda>t p. snd t + p) 0 (execution (fst mr) s e) = 1"
  using read_positive
  proof -
    {
      fix mm :: memory_request and ss :: state and ee :: event
      have "folds (\<lambda>t p. snd t + p) 0 (execution mm ss ee) = 1"
        unfolding execution_def sa_read_observe_def Let_def by simp
    }
    then show ?thesis by blast
  qed

interpretation CM state_N state_E "mem_req cache_comp" execution
  apply standard
  using mem_finite mem_nonempty mem_unique mem_positive mem_sum_one
        read_finite read_nonempty read_unique read_positive read_sum_one
        stateN_finite stateN_nonempty stateE_nonempty stateE_subset
  by auto

subsection \<open>Proofs of Correctness\<close>

lemma one_changed:
  "\<forall>i \<in> mem_req cache_comp. \<forall>s0 \<in> state_E.
    card ((sram (the_elem (sa_read s0 (fst i))))!(the ((maps s0) (index (fst i)))) \<inter> (sram s0)!(the ((maps s0) (index (fst i))))) =
    card ((sram s0)!(the ((maps s0) (index (fst i))))) - 1"
  proof -
    {
      fix i assume t0: "i \<in> mem_req cache_comp"
      have "\<forall>s0 \<in> state_E. card ((sram (the_elem (sa_read s0 (fst i))))!(the ((maps s0) (index (fst i)))) \<inter> (sram s0)!(the ((maps s0) (index (fst i))))) =
                           card ((sram s0)!(the ((maps s0) (index (fst i))))) - 1"
      proof -
        {
          fix s0 assume t1: "s0 \<in> state_E"
          have "card ((sram (the_elem (sa_read s0 (fst i))))!(the ((maps s0) (index (fst i)))) \<inter> (sram s0)!(the ((maps s0) (index (fst i))))) =
                card ((sram s0)!(the ((maps s0) (index (fst i))))) - 1"
          proof -
            {
              let ?redir_set = "the ((maps s0) (index (fst i)))"
              have exi_redir: "?redir_set < length (sram s0)"
                using state_E_init unfolding state_E_witness_def using mem_mapping
                by (smt caE_init map_range mem_Collect_eq state.select_convs(1) state.select_convs(2) subsetD t0 t1)
              let ?redir_ca = "(sram s0) ! ?redir_set"
              have t2: "sram s0 \<in> ca_E cache_comp"
                using state_E_init unfolding state_E_witness_def
                proof -
                  assume "state_E = {t. \<exists>c\<in>ca_E cache_comp. t = \<lparr>sram = c, maps = map_conf cache_comp\<rparr>}"
                  then have "state_E = {s. \<exists>Cs. Cs \<in> ca_E cache_comp \<and> s = \<lparr>sram = Cs, maps = map_conf cache_comp\<rparr>}"
                    by (simp add: Bex_def_raw)
                  then have "\<exists>Cs. Cs \<in> ca_E cache_comp \<and> s0 = \<lparr>sram = Cs, maps = map_conf cache_comp\<rparr>"
                    using t1 by blast
                  then show ?thesis
                    by force
                qed
              then have setowned: "\<forall>i \<in> (mem_req cache_comp). \<forall>l < length (sram s0). \<forall>e \<in> ((sram s0)!l). tag (fst i) \<noteq> ca_tag e"
                using mem_occupy by auto
              then have probe_fails: "\<nexists>b. b \<in> ?redir_ca \<and> ca_tag b = tag (fst i) \<and> valid b"
                using exi_redir t0 by force
              then have c: "\<not> probe_line ?redir_ca (fst i)"
                unfolding probe_line_def by blast
              let ?r_line = "replace_policy ?redir_ca"
              have t3: "?r_line \<in> ?redir_ca"
                unfolding replace_policy_def
                using caE_init ca_set_nonempty exi_redir some_in_eq t2 by blast
              then have tag_diff: "ca_tag ?r_line \<noteq> tag (fst i)"
                using exi_redir setowned t0 by force
              let ?r_line' = "replace_line ?r_line (fst i)"
              have tag_same: "ca_tag ?r_line' = tag (fst i)"
                unfolding replace_line_def by simp
              let ?newset = "insert ?r_line' (?redir_ca - {?r_line})"
              have t4: "?r_line' \<notin> ?redir_ca"
                by (metis (full_types) exi_redir setowned t0 tag_same)
              then have "?newset \<inter> ?redir_ca = ?redir_ca - {?r_line}"
                by auto
              then have re: "card (?newset \<inter> ?redir_ca) = card ?redir_ca - 1"
                using caE_init ca_set_finite exi_redir subsetD t2 t3 by fastforce
              have "sa_read s0 (fst i) = {s0\<lparr>sram := list_update (sram s0) ?redir_set ?newset\<rparr>}"
                unfolding sa_read_def Let_def using c by auto
              then have "the_elem (sa_read s0 (fst i)) = s0\<lparr>sram := list_update (sram s0) ?redir_set ?newset\<rparr>"
                unfolding the_elem_def by auto
              then have "(sram (the_elem (sa_read s0 (fst i))))!?redir_set = ?newset"
                using exi_redir by simp
              then show ?thesis
                using re by simp
            }
          qed
        }
        then show ?thesis by blast
      qed
    }
    then show ?thesis by blast
  qed

lemma remain_same:
  "\<forall>i \<in> mem_req cache_comp. \<forall>s0 \<in> state_E. \<forall>l \<noteq> the ((maps s0) (index (fst i))). (sram s0)!l = (sram (the_elem (sa_read s0 (fst i))))!l"
  proof -
    {
      fix i assume t0: "i \<in> mem_req cache_comp"
      have "\<forall>s0 \<in> state_E. \<forall>l \<noteq> the ((maps s0) (index (fst i))). (sram s0)!l = (sram (the_elem (sa_read s0 (fst i))))!l"
      proof -
        {
          fix s0 assume t1: "s0 \<in> state_E"
          have "\<forall>l \<noteq> the ((maps s0) (index (fst i))). (sram s0)!l = (sram (the_elem (sa_read s0 (fst i))))!l"
          proof -
            {
              fix l assume t2: "l \<noteq> the ((maps s0) (index (fst i)))"
              have "(sram s0)!l = (sram (the_elem (sa_read s0 (fst i))))!l"
              proof -
                {
                  let ?redir_set = "the ((maps s0) (index (fst i)))"
                  have exi_redir: "?redir_set < length (sram s0)"
                    using state_E_init unfolding state_E_witness_def using mem_mapping
                    by (smt caE_init map_range mem_Collect_eq state.select_convs(1) state.select_convs(2) subsetD t0 t1)
                  let ?redir_ca = "(sram s0) ! ?redir_set"
                  have "sram s0 \<in> ca_E cache_comp"
                    using state_E_init unfolding state_E_witness_def
                    proof -
                      assume "state_E = {t. \<exists>c\<in>ca_E cache_comp. t = \<lparr>sram = c, maps = map_conf cache_comp\<rparr>}"
                      then have "state_E = {s. \<exists>Cs. Cs \<in> ca_E cache_comp \<and> s = \<lparr>sram = Cs, maps = map_conf cache_comp\<rparr>}"
                        by (simp add: Bex_def_raw)
                      then have "\<exists>Cs. Cs \<in> ca_E cache_comp \<and> s0 = \<lparr>sram = Cs, maps = map_conf cache_comp\<rparr>"
                        using t1 by blast
                      then show ?thesis
                        by force
                    qed
                  then have setowned: "\<forall>i \<in> (mem_req cache_comp). \<forall>l < length (sram s0). \<forall>e \<in> ((sram s0)!l). tag (fst i) \<noteq> ca_tag e"
                    using mem_occupy by auto
                  then have "\<nexists>b. b \<in> ?redir_ca \<and> ca_tag b = tag (fst i) \<and> valid b"
                      using exi_redir t0 by force
                  then have c: "\<not> probe_line ?redir_ca (fst i)"
                    unfolding probe_line_def by blast
                  let ?r_line = "replace_policy ?redir_ca"
                  let ?newset = "insert (replace_line ?r_line (fst i)) (?redir_ca - {?r_line})"
                  have "sa_read s0 (fst i) = {s0\<lparr>sram := list_update (sram s0) ?redir_set ?newset\<rparr>}"
                    unfolding sa_read_def Let_def using c by auto
                  then show ?thesis using t2
                    by auto
                }
              qed
            }
            then show ?thesis by blast
          qed
        }
        then show ?thesis by blast
      qed
    }
    then show ?thesis by blast
  qed

subsection \<open>Proofs of Security Model\<close>

lemma read_not_zero:
  "\<forall>e. \<forall>mr \<in> mem_req cache_comp. \<forall>s \<in> state_E. \<forall>d \<in> execution (fst mr) s e. snd d = 1"
  using mem_cache_miss unfolding execution_def
  by auto

lemma read_not_uniform:
  assumes mem_len: "card (mem_req cache_comp) > 1"
    shows "\<forall>e. \<forall>mr \<in> mem_req cache_comp. \<forall>s \<in> state_E. \<forall>d \<in> execution (fst mr) s e.
            snd d \<noteq> folds (\<lambda>t p. snd t + p) 0 {u. u \<in> makeDist s e \<and> snd (fst u) = fst d}"
  proof -
    {
      show ?thesis using mem_len
      proof -
        {
          fix e
          have "\<forall>mr \<in> mem_req cache_comp. \<forall>s \<in> state_E. \<forall>d \<in> execution (fst mr) s e.
                 snd d \<noteq> folds (\<lambda>t p. snd t + p) 0 {u. u \<in> makeDist s e \<and> snd (fst u) = fst d}"
          proof -
            {
              fix mr assume t0: "mr \<in> mem_req cache_comp"
              have "\<forall>s \<in> state_E. \<forall>d \<in> execution (fst mr) s e.
                     snd d \<noteq> folds (\<lambda>t p. snd t + p) 0 {u. u \<in> makeDist s e \<and> snd (fst u) = fst d}"
              proof -
                {
                  fix s assume t1: "s \<in> state_E"
                  have "\<forall>d \<in> execution (fst mr) s e.
                         snd d \<noteq> folds (\<lambda>t p. snd t + p) 0 {u. u \<in> makeDist s e \<and> snd (fst u) = fst d}"
                  proof -
                    {
                      fix d assume t2: "d \<in> execution (fst mr) s e"
                      have emr: "execution (fst mr) s e = {((the ((maps s) (index (fst mr))), Miss), 1)}"
                        unfolding execution_def using mem_cache_miss
                        using t0 t1 by blast
                      then have valued: "d = ((the ((maps s) (index (fst mr))), Miss), 1)"
                        using t2 by blast
                      have exi_redir: "the ((maps s) (index (fst mr))) < length (sram s)"
                        using state_E_init unfolding state_E_witness_def using mem_mapping
                        by (smt caE_init map_range mem_Collect_eq state.select_convs(1) state.select_convs(2) subset_eq t0 t1)
                      have "\<exists>m \<in> mem_req cache_comp. m \<noteq> mr"
                        using mem_len by (metis dual_order.strict_implies_not_eq inputdist_nonempty is_singletonI' is_singleton_altdef)
                      then obtain m where am: "m \<in> mem_req cache_comp \<and> m \<noteq> mr" by auto
                      then have em: "execution (fst m) s e = {((the ((maps s) (index (fst m))), Miss), 1)}"
                        unfolding execution_def using mem_cache_miss t1 by blast
                      have diff: "the ((maps s) (index (fst m))) \<noteq> the ((maps s) (index (fst mr)))"
                        using mem_mapping map_diff
                        by (smt am mem_Collect_eq mem_unique state.ext_inject state.surjective state_E_init state_E_witness_def t0 t1)
                      have makedist_m: "((fst m, (the ((maps s) (index (fst m))), Miss)), snd m) \<in> makeDist s e"
                        unfolding makeDist_def using am em by auto
                      have makedist_msub: "((fst m, (the ((maps s) (index (fst m))), Miss)), snd m) \<in>
                                          {u. u \<in> makeDist s e \<and> snd (fst u) \<noteq> (the ((maps s) (index (fst mr))), Miss)}"
                        using diff makedist_m valued by auto
                      have makedist_msub_value: "snd m > 0"
                        using inputdist_positive am by blast
                      have makedist_msub_finite: "finite {u. u \<in> makeDist s e \<and> snd (fst u) \<noteq> (the ((maps s) (index (fst mr))), Miss)}"
                        using jodist_finite stateE_subset t1 by auto
                      have makedist_msub_nonempty: "{u. u \<in> makeDist s e \<and> snd (fst u) \<noteq> (the ((maps s) (index (fst mr))), Miss)} \<noteq> {}"
                        using makedist_msub by blast
                      have makedist_msub_e: "\<forall>u \<in> {u. u \<in> makeDist s e \<and> snd (fst u) \<noteq> (the ((maps s) (index (fst mr))), Miss)}. snd u \<ge> 0"
                        using jodist_positive stateE_subset t1 by fastforce
                      have makedist_msub_ne: "folds (\<lambda>t p. snd t + p) 0 {u. u \<in> makeDist s e \<and> snd (fst u) \<noteq> (the ((maps s) (index (fst mr))), Miss)} > 0"
                        using folds_plus_non_negative2[where ?P = "snd" and
                                                             ?w = "{u. u \<in> makeDist s e \<and> snd (fst u) \<noteq> (the ((maps s) (index (fst mr))), Miss)}" and
                                                             ?d = "((fst m, (the ((maps s) (index (fst m))), Miss)), snd m)"]
                              makedist_msub_finite makedist_msub_nonempty makedist_msub_e
                              makedist_msub makedist_msub_value by auto
                      have makedist_sum: "folds (\<lambda>t p. snd t + p) 0 (makeDist s e) = 1"
                        using jodist_sum_one stateE_subset t1 by blast
                      have makedist_sub: "makeDist s e = {u. u \<in> makeDist s e \<and> snd (fst u) = (the ((maps s) (index (fst mr))), Miss)} \<union>
                                         {u. u \<in> makeDist s e \<and> snd (fst u) \<noteq> (the ((maps s) (index (fst mr))), Miss)}"
                        by auto
                      have makedist_sub_dis: "{u. u \<in> makeDist s e \<and> snd (fst u) = (the ((maps s) (index (fst mr))), Miss)} \<inter>
                                              {u. u \<in> makeDist s e \<and> snd (fst u) \<noteq> (the ((maps s) (index (fst mr))), Miss)} = {}"
                        by auto
                      have makedist_msub_finite2: "finite {u. u \<in> makeDist s e \<and> snd (fst u) = (the ((maps s) (index (fst mr))), Miss)}"
                        using jodist_finite stateE_subset t1 by auto
                      have makedist_sub_sum: "folds (\<lambda>t p. snd t + p) 0 ({u. u \<in> makeDist s e \<and> snd (fst u) = (the ((maps s) (index (fst mr))), Miss)} \<union>
                                                                         {u. u \<in> makeDist s e \<and> snd (fst u) \<noteq> (the ((maps s) (index (fst mr))), Miss)}) =
                                              folds (\<lambda>t p. snd t + p) (folds (\<lambda>t p. snd t + p) 0 {u. u \<in> makeDist s e \<and> snd (fst u) = (the ((maps s) (index (fst mr))), Miss)})
                                              {u. u \<in> makeDist s e \<and> snd (fst u) \<noteq> (the ((maps s) (index (fst mr))), Miss)}"
                        using plus_comp_fun_commute_P.fold_set_union_disj[where ?P = "snd" and
                                                                                ?A = "{u. u \<in> makeDist s e \<and> snd (fst u) = (the ((maps s) (index (fst mr))), Miss)}" and
                                                                                ?B = "{u. u \<in> makeDist s e \<and> snd (fst u) \<noteq> (the ((maps s) (index (fst mr))), Miss)}" and
                                                                                ?z = 0]
                        using makedist_msub_finite makedist_msub_finite2 makedist_sub_dis by auto
                      have "folds (\<lambda>t p. snd t + p) (folds (\<lambda>t p. snd t + p) 0 {u. u \<in> makeDist s e \<and> snd (fst u) = (the ((maps s) (index (fst mr))), Miss)})
                            {u. u \<in> makeDist s e \<and> snd (fst u) \<noteq> (the ((maps s) (index (fst mr))), Miss)} =
                            folds (\<lambda>t p. snd t + p) 0 {u. u \<in> makeDist s e \<and> snd (fst u) = (the ((maps s) (index (fst mr))), Miss)} +
                            folds (\<lambda>t p. snd t + p) 0 {u. u \<in> makeDist s e \<and> snd (fst u) \<noteq> (the ((maps s) (index (fst mr))), Miss)}"
                        proof -
                          have "\<forall>r ra P. r + folds (\<lambda>p. (+) (snd (p::(memory_request \<times> nat \<times> cachehit) \<times> real))) ra P = folds (\<lambda>p. (+) (snd p)) (r + ra) P \<or> infinite P"
                            by (metis (no_types) plus_comp_fun_commute_P.fold_fun_left_comm snd_conv)
                          then show ?thesis
                            by (smt makedist_msub_finite)
                        qed
                      then have "folds (\<lambda>t p. snd t + p) 0 (makeDist s e) =
                                 folds (\<lambda>t p. snd t + p) 0 {u. u \<in> makeDist s e \<and> snd (fst u) = (the ((maps s) (index (fst mr))), Miss)} +
                                 folds (\<lambda>t p. snd t + p) 0 {u. u \<in> makeDist s e \<and> snd (fst u) \<noteq> (the ((maps s) (index (fst mr))), Miss)}"
                        using makedist_sub makedist_sub_sum by presburger
                      then have "folds (\<lambda>t p. snd t + p) 0 {u. u \<in> makeDist s e \<and> snd (fst u) = (the ((maps s) (index (fst mr))), Miss)} < 1"
                        using makedist_sum makedist_msub_ne by linarith
                      then have ?thesis
                        using emr by auto
                    }
                    then show ?thesis by blast
                  qed
                }
                then show ?thesis by blast
              qed
            }
            then show ?thesis by blast
          qed
        }
        then show ?thesis by blast
      qed
    }
  qed

end


theory RRC_3T
imports OpSem
begin

datatype PC =
  L1
| L2
| L3

consts t1 :: T
consts t2 :: T
consts t3 :: T
consts x :: L
consts y :: L

definition "thrdsvars \<equiv>  y \<noteq> x \<and> t1 \<noteq> t2 \<and>
                         t1 \<noteq> t3 \<and>
                         t2 \<noteq> t3 "

record mp_state =
  pc :: "T \<Rightarrow> PC"
  state :: surrey_state
  a :: V
  b :: V
  r1 :: V

definition
  "update_pc t nv pcf \<equiv> pcf (t := nv)"

definition
  "locals_id s s' \<equiv> a s = a s' \<and> b s = b s' \<and> r1 s = r1 s'"

definition prog :: "T \<Rightarrow>  mp_state \<Rightarrow> mp_state \<Rightarrow> bool " where
"prog t s s' \<equiv>
(
if t = t1
then
  if (pc s) t = L1
    then
      pc s' = update_pc t L2 (pc s) \<and>
      ((state s) [x := 1]\<^sub>t (state s')) \<and>
      locals_id s s'
  else
if (pc s) t = L2
then
      pc s' = update_pc t L3 (pc s) \<and>
      ((state s) [y :=\<^sup>R 1]\<^sub>t (state s')) \<and>
      locals_id s s'
else
    False
else
if t = t2
then
  if (pc s) t = L1
    then
      pc s' = update_pc t L2 (pc s) \<and>
      ((state s) [r1 s' \<leftarrow>\<^sup>A y]\<^sub>t (state s')) \<and>
      a s' = a s \<and> b s' = b s
  else
  if (pc s) t = L2
    then
      pc s' = update_pc t L3 (pc s) \<and>
      ((state s) [x := 2]\<^sub>t (state s')) \<and>
      locals_id s s'
  else
    False
else
if t = t3
then
  if (pc s) t = L1
    then
      pc s' = update_pc t L2 (pc s) \<and>
      ((state s) [a s' \<leftarrow> x]\<^sub>t (state s')) \<and>
      r1 s' = r1 s \<and> b s' = b s
  else
  if (pc s) t = L2
    then
      pc s' = update_pc t L3 (pc s) \<and>
      ((state s) [b s' \<leftarrow> x]\<^sub>t (state s')) \<and>
      r1 s' = r1 s \<and> a s' = a s
  else
    False
else
  False
)"

definition prog_inv :: "T \<Rightarrow> PC \<Rightarrow> mp_state \<Rightarrow> bool " where
"prog_inv t p s \<equiv>
  if t = t1
  then let t' = t2 in
    (case p of
          L1 \<Rightarrow> [\<zero>\<^sub>x 1]\<^sub>0 (state s) \<and> \<not>[y \<approx>\<^sub>t' 1] (state s) \<and> ([\<zero>\<^sub>x 2]\<^sub>0  (state s) \<longrightarrow> [x =\<^sub>t 0] (state s))
        | L2 \<Rightarrow> \<not>[y \<approx>\<^sub>t' 1] (state s) \<and> ([\<zero>\<^sub>x 2]\<^sub>0  (state s) \<longrightarrow> [x =\<^sub>t 1] (state s))
        | L3 \<Rightarrow> True
    )
  else
    if t = t2 then
      (case p of
          L1 \<Rightarrow> [\<zero>\<^sub>x 2]\<^sub>0 (state s) \<and>  [y = 1]\<^sub>t\<lparr>x = 1\<rparr> (state s)
        | L2 \<Rightarrow> (r1 s = 1 \<longrightarrow> [x =\<^sub>t 1](state s) \<and> enc_t (state s) t x 1) \<and> [\<zero>\<^sub>x 2]\<^sub>0 (state s)
        | L3 \<Rightarrow> (r1 s = 1 \<longrightarrow> [1 \<hookrightarrow>\<^sub>x 2](state s))
      )
  else
    if t = t3 then
      (case p of
          L1 \<Rightarrow> True
        | L2 \<Rightarrow> enc_t (state s) t x (a s)
        | L3 \<Rightarrow> ((a s) \<noteq> (b s) \<longrightarrow> [(a s) \<leadsto>\<^sub>x (b s)](state s))
      )
  else
    False
"

(*initial_state \<sigma> I*)
definition init_map  :: "(L \<Rightarrow> V) \<Rightarrow> bool" where
  "init_map \<phi> \<equiv> \<phi> x = 0 \<and> \<phi> y = 0"

definition init_s  :: "surrey_state  \<Rightarrow> bool"
  where
    "init_s ss \<equiv> \<exists> \<phi>. initial_state ss \<phi> \<and> init_map \<phi>"

definition init  :: "mp_state  \<Rightarrow> bool"
  where
    "init s \<equiv> (pc s) t1 = L1
      \<and> (pc s) t2 = L1 \<and> (pc s) t3 = L1  \<and>
      a s = 0  \<and> b s = 0  \<and> r1 s = 0
    \<and> init_s (state s) \<and> thrdsvars"

definition "global s \<equiv> init_val (state s) x 0 \<and> init_val (state s) y 0 \<and> wfs (state s) \<and> [\<one>\<^sub>x 1] (state s) \<and> [\<one>\<^sub>x 2] (state s)"

lemmas prog_simp  =
  prog_def
  prog_inv_def
  init_def
  init_s_def
  init_map_def

lemmas mp_simps [simp]  =
  locals_id_def
  update_pc_def
  thrdsvars_def

lemma goal:
  assumes "prog_inv t1 L3 s"
  and "prog_inv t2 L3 s"
  and "prog_inv t3 L3 s"
  and "global s"
  and "thrdsvars"
shows "r1 s = 1 \<and> a s = 2 \<longrightarrow> b s \<noteq> 1"
  using assms
  apply(simp add: prog_inv_def global_def)
  using d_vorder_one_way pvord_to_dvord by fastforce

lemma init_global : "init s  \<Longrightarrow>  thrdsvars \<Longrightarrow> global s"
  apply (simp add: global_def init_val_def prog_simp)
  apply (elim conjE, intro conjI)
  apply(unfold writes_on_def value_def initial_state_def mo_def, simp)
    apply auto[2]
  using initial_state_def initial_wfs
  apply blast
  apply (metis (no_types, lifting) amo_def n_not_Suc_n p_vorder_def value_def write_record.ext_inject write_record.surjective writes_on_var)
  using p_vorder_def value_def write_record.ext_inject write_record.surjective writes_on_var
  by (metis amo_def zero_neq_numeral)

lemma init_inv : "init s  \<Longrightarrow>  thrdsvars \<Longrightarrow> prog_inv t1 L1 s \<and>
                                             prog_inv t2 L1 s \<and>
                                             prog_inv t3 L1 s"
  apply(frule_tac init_global[where s=s], simp)
  apply(simp add: init_def global_def prog_inv_def init_s_def init_map_def initial_state_def)
  apply(simp_all add: value_def initial_state_def init_map_def init_val_def opsem_def)
  apply(elim conjE, intro conjI)
  apply(unfold writes_on_def)
      apply simp+
  apply safe
  apply auto[2]
      apply(simp add: c_obs_def visible_writes_def value_def p_obs_def)
  apply(unfold writes_on_def d_obs_def)
     apply(simp add: c_obs_def visible_writes_def value_def)
    apply auto
  apply(simp add: c_obs_def d_obs_t_def d_obs_def value_def lastWr_def visible_writes_def)
  apply(unfold writes_on_def)
    apply auto
  apply (smt Collect_cong lastWr_def last_write_write_on mem_Collect_eq own_ModView snd_conv writes_on_def)
  by (metis One_nat_def null_def not_p_obs_implies_c_obs old.prod.exhaust p_obs_def prod.collapse value_def var_def visible_var write_record.select_convs(1) zero_neq_one)

lemma global_inv:
  assumes "global s"
   and "thrdsvars"
   and "prog_inv t ((pc s) t) s"
   and "prog t s s'"
   and "t = t1 \<or> t = t2 \<or> t = t3"
 shows "global s'"
  using assms
  apply(unfold global_def prog_def prog_inv_def thrdsvars_def)
  apply (elim disjE)
   apply simp+
    apply(cases "pc s t1", simp+)
  apply(intro conjI)
  using init_val_pres apply blast
  using init_val_pres apply auto[1]
  using wfs_preserved apply blast
       apply(elim conjE)
       apply (simp add: amo_intro_step no_val_def)
  apply (metis amo_Wr_diff_val_pres n_not_Suc_n numeral_2_eq_2)
    apply(cases "pc s t1", simp+)
        apply(elim conjE)
  apply(intro conjI)
  using init_val_pres apply blast
  using init_val_pres apply blast
  using wfs_preserved apply blast
  apply (metis amo_WrR_pres)
  apply (metis amo_WrR_pres)
     apply simp+
  apply (smt PC.simps(8) amo_RdA_pres amo_Wr_diff_val_pres amo_intro_step global_def init_val_pres locals_id_def n_not_Suc_n no_val_def wfs_preserved zero_neq_numeral)
  by (metis amo_RdX_pres init_val_pres wfs_preserved)

lemma t1_local :
  assumes "prog_inv t1 ((pc s) t1) s"
    and "global s"
  and "thrdsvars"
  and "prog t1 s s'"
shows  "prog_inv t1 ((pc s') t1) s'"
  using assms
  apply (simp add: prog_simp global_def)
  apply(elim conjE)
  apply(cases "pc s t1")
    apply simp+
    apply(elim conjE, intro conjI)
  using not_p_obs_WrX_diff_var_pres
  using d_obs_WrX_set  apply blast
    apply clarsimp
    apply (meson d_obs_WrX_set no_val_def p_vorder_WrX_p_vorder)
    by simp+

lemma t1_global :
  assumes "prog_inv t1 ((pc s) t1) s"
   and "global s"
   and "t = t2 \<or> t = t3"
   and "prog_inv t ((pc s) t) s"
  and "thrdsvars"
  and "prog t s s'"
shows  "prog_inv t1 ((pc s') t1) s'"
  using assms
  apply(elim disjE)
  apply(simp add: prog_simp global_def)
   apply(cases "pc s t2")
  apply(cases "pc s t1", simp)
  apply (metis no_val_RdA_pres dobs_RdA_pres not_pobs_RdA_pres)
      apply simp+
      apply(cases "pc s t1", simp)
  using dobs_RdA_pres not_pobs_RdA_pres apply blast
      apply simp
      apply(cases "pc s t1", simp)
      apply simp+
    apply(cases "pc s t1", simp)
  apply (intro conjI)
  apply (metis One_nat_def nat.inject no_val_WrX_diff_val_pres numeral_2_eq_2 zero_neq_one)
  using not_p_obs_WrX_diff_var_pres apply blast
      apply clarsimp
      apply auto
  using WrX_no_val   apply auto[2]
  using not_p_obs_WrX_diff_var_pres apply blast
  using WrX_no_val apply blast
   using not_p_obs_WrX_diff_var_pres apply blast
   using WrX_no_val apply auto[1]
  apply(simp add: prog_simp global_def)
   apply(cases "pc s t3")
     apply(cases "pc s t1", simp)
  apply (meson dobs_RdX_pres no_val_Rdx_pres no_val_def not_pobs_RdX_pres p_vorder_RdX_p_vorder)
    apply(cases "pc s t1")
        apply simp+
  apply (meson dobs_RdX_pres no_val_def not_pobs_RdX_pres p_vorder_RdX_p_vorder)
  apply auto[2]
    apply(cases "pc s t1", simp_all)
   apply (meson dobs_RdX_pres no_val_Rdx_pres no_val_def not_pobs_RdX_pres p_vorder_RdX_p_vorder)
    apply(cases "pc s t1", simp)
   apply (smt PC.simps(8) dobs_RdX_pres fun_upd_other mp_simps(2) no_val_def not_pobs_RdX_pres p_vorder_RdX_p_vorder)
   by simp+

lemma t2_local :
  assumes "prog_inv t2 ((pc s) t2) s"
  and "global s"
  and "thrdsvars"
  and "prog t2 s s'"
shows  "prog_inv t2 ((pc s') t2) s'"
  using assms
  apply (simp add: prog_simp global_def)
  apply(case_tac "pc s t2")
    apply simp+
    apply(elim conjE, intro conjI)
     apply(intro impI conjI)
      apply simp
  using c_obs_RdA_d_obs
  apply blast
     apply simp
  using c_obs_RdA_d_obs d_obs_enc wfs_preserved apply blast
  using amo_def amo_intro_step no_val_def zero_neq_numeral
  using no_val_RdA_pres apply auto[1]
   apply (simp add: amo_intro_step no_val_def)
  using WrX_d_vorder no_val_def apply fastforce
  by simp

lemma t2_global :
  assumes "prog_inv t2 ((pc s) t2) s"
  and "global s"
   and "t = t1 \<or> t = t3"
   and "prog_inv t ((pc s) t) s"
  and "thrdsvars"
  and "prog t s s'"
shows  "prog_inv t2 ((pc s') t2) s'"
  using assms
  apply(elim disjE)
    apply (simp add: prog_simp global_def)
  apply(elim conjE)
  apply(cases "pc s t2")
    apply simp+
   apply(cases "pc s t1")
      apply(cases "pc s t2", simp)
         apply(elim conjE, intro conjI)
  apply (metis One_nat_def nat.inject no_val_WrX_diff_val_pres numeral_2_eq_2 zero_neq_one)
  using amo_Wr_diff_val_pres
  using not_p_obs_WrX_diff_var_pres not_p_obs_implies_c_obs apply auto[1]
  apply simp_all
  apply (metis c_obs_WrR_intro no_val_WrR_diff_var_pres)
    apply(cases "pc s t1", simp)
  apply (metis d_obs_def d_obs_t_def n_not_Suc_n no_val_WrX_diff_val_pres numeral_2_eq_2)
   apply(cases "pc s t1", auto)
  using no_val_WrR_diff_var_pres apply force
  apply (metis dobs_WrR_pres)
  using enc_pres apply blast
  using no_val_WrR_diff_var_pres apply force
   apply(cases "pc s t1", auto)
   apply(cases "pc s t1", auto)
  apply (metis WrX_def amo_Wr_diff_val_pres amo_intro_step isWr.simps(2) no_val_def numeral_2_eq_2 opsem_def(3) p_vorder_write_pres pvord_to_dvord)
  apply (metis assms(4) assms(6) global_def global_inv numeral_1_eq_Suc_0 numeral_One opsem_def(3) p_vorder_WrX_p_vorder pvord_to_dvord thrdsvars_def)
  apply (metis amo_WrR_pres opsem_def(3) p_vorder_WrR_p_vorder pvord_to_dvord)
  apply (metis amo_WrR_pres opsem_def(3) p_vorder_WrR_p_vorder pvord_to_dvord)
  apply (simp add: prog_simp global_def)
  apply(elim conjE)
  apply(cases "pc s t3")
    apply simp+
   apply(cases "pc s t1")
      apply(cases "pc s t2", simp)
        apply(elim conjE, intro conjI)
  using no_val_Rdx_pres apply blast
  using cobs_RdX_diff_var_pres apply blast
  apply (metis PC.simps(8) RdX_def dobs_Rd_pres enc_pres isRd.simps(1) no_val_Rdx_pres)
  using d_vorder_RdX_pres apply auto[1]
  apply(cases "pc s t2", auto)
  using no_val_Rdx_pres apply blast
  using cobs_RdX_diff_var_pres apply blast
  using no_val_Rdx_pres apply blast
  using dobs_RdX_pres apply blast
  using enc_pres apply blast
  using no_val_Rdx_pres apply blast
  using d_vorder_RdX_pres apply blast
  apply(cases "pc s t2", simp)
  using cobs_RdX_diff_var_pres no_val_Rdx_pres apply auto[1]
  apply (metis PC.simps(8) RdX_def dobs_Rd_pres enc_pres isRd.simps(1) no_val_Rdx_pres)
  using d_vorder_RdX_pres apply auto[1]
  apply(cases "pc s t2", simp)
  using cobs_RdX_diff_var_pres no_val_Rdx_pres apply auto[1]
  apply (metis PC.simps(8) RdX_def dobs_Rd_pres enc_pres isRd.simps(1) no_val_Rdx_pres)
  using d_vorder_RdX_pres by auto

lemma t3_local :
  assumes "prog_inv t3 ((pc s) t3) s"
  and "global s"
  and "thrdsvars"
  and "prog t3 s s'"
shows  "prog_inv t3 ((pc s') t3) s'"
  using assms
  apply (simp add: prog_simp global_def)
  apply(case_tac "pc s t3")
    apply simp+
  using enc_RdX_intro apply blast
   apply simp
   apply(elim conjE)
  defer
   apply simp
    using enc_Rdx_p_vorder
    by blast

lemma t3_global:
  assumes "prog_inv t3 ((pc s) t3) s"
   and "t = t1 \<or> t = t2"
   and "prog_inv t ((pc s) t) s"
  and "thrdsvars"
  and "prog t s s'"
shows  "prog_inv t3 ((pc s') t3) s'"
  using assms
  apply(elim disjE)
   apply (simp_all add: prog_simp global_def)
   apply(case_tac "pc s t1")
   apply(case_tac "pc s t3")
  apply simp+
  using enc_pres apply blast
  apply clarsimp
  using p_vorder_WrX_p_vorder
  apply blast
   apply(case_tac "pc s t3")
      apply simp+
  using enc_pres apply blast
    apply simp+
  apply(elim conjE, intro impI, simp)
  using p_vorder_WrR_p_vorder apply blast
  apply simp
   apply(case_tac "pc s t2")
   apply(case_tac "pc s t3")
  apply simp+
  using enc_pres apply blast
  apply clarsimp
  using p_vorder_RdA_p_vorder apply blast
   apply(case_tac "pc s t3")
     apply simp+
  using enc_pres apply blast
  apply simp
  using p_vorder_WrX_p_vorder apply blast
  by simp

theorem final_inv:
  assumes "wfs (state s)"
  and "global s"
  and "thrdsvars"
  and "t \<in> {t1, t2, t3}"
  and "t' \<in> {t1, t2, t3}"
  and "prog_inv t ((pc s) t) s"
  and "prog_inv t' ((pc s) t') s"
  and "prog t' s s'"
shows "prog_inv t ((pc s') t) s'"
  using assms apply (simp del: thrdsvars_def)
  by (meson t1_global t1_local t2_global t2_local t3_global t3_local)

end


section\<open>Cohen forcing notions\<close>

theory Partial_Functions_Relative
  imports
    Cardinal_Library_Relative
begin

text\<open>In this theory we introduce bounded partial functions and its relative
version; for historical reasons the relative version is based on a proper
definition of partial functions.

We note that finite partial functions are easier and are used to prove
some lemmas about finite sets in the theory
\<^theory>\<open>Transitive_Models.ZF_Library_Relative\<close>.\<close>

definition
  Fn :: "[i,i,i] \<Rightarrow> i" where
  "Fn(\<kappa>,I,J) \<equiv> \<Union>{y . d \<in> Pow(I), y=(d\<rightarrow>J) \<and> d\<prec>\<kappa>}"

lemma domain_function_lepoll :
  assumes "function(r)"
  shows "domain(r) \<lesssim> r"
proof -
  let ?f="\<lambda>x\<in>domain(r) . \<langle>x,r`x\<rangle>"
  have "\<langle>x, r ` x\<rangle> \<in> r" if "\<langle>x, y\<rangle> \<in> r" for x y
  proof -
    have "x\<in>domain(r)" using that by auto
    with assms
    show ?thesis using function_apply_Pair by auto
  qed
  then
  have "?f \<in> inj(domain(r), r)"
    by(rule_tac lam_injective,auto)
  then
  show ?thesis unfolding lepoll_def
    by force
qed

lemma function_lepoll:
  assumes "r:d\<rightarrow>J"
  shows "r \<lesssim> d"
proof -
  let ?f="\<lambda>x\<in>r . fst(x)"
  note assms Pi_iff[THEN iffD1,OF assms]
  moreover from calculation
  have "r`fst(x) = snd(x)" if "x\<in>r" for x
    using that apply_equality
    by auto
  ultimately
  have "?f\<in>inj(r,d)"
    by(rule_tac d= "\<lambda>u . \<langle>u, r`u\<rangle>" in lam_injective,auto)
  then
  show ?thesis
    unfolding lepoll_def
    by auto
qed

lemma function_eqpoll :
  assumes "r:d\<rightarrow>J"
  shows "r \<approx> d"
  using assms domain_of_fun domain_function_lepoll Pi_iff[THEN iffD1,OF assms]
    eqpollI[OF function_lepoll[OF assms]] subset_imp_lepoll
  by force

lemma Fn_char : "Fn(\<kappa>,I,J) = {f \<in> Pow(I\<times>J) . function(f) \<and> f \<prec> \<kappa>}" (is "?L=?R")
proof (intro equalityI subsetI)
  fix x
  assume "x \<in> ?R"
  moreover from this
  have "domain(x) \<in> Pow(I)" "domain(x) \<lesssim> x" "x\<prec> \<kappa>"
    using domain_function_lepoll
    by auto
  ultimately
  show "x \<in> ?L"
    unfolding Fn_def
    using lesspoll_trans1 Pi_iff
    by (auto,rule_tac rev_bexI[of "domain(x) \<rightarrow> J"],auto)
next
  fix x
  assume "x \<in> ?L"
  then
  obtain d where "x:d\<rightarrow>J" "d \<in> Pow(I)" "d\<prec>\<kappa>"
    unfolding Fn_def
    by auto
  moreover from this
  have "x\<prec>\<kappa>"
    using function_lepoll[THEN lesspoll_trans1] by auto
  moreover from calculation
  have "x \<in> Pow(I\<times>J)" "function(x)"
    using Pi_iff by auto
  ultimately
  show "x \<in> ?R" by simp
qed

lemma zero_in_Fn:
  assumes "0 < \<kappa>"
  shows "0 \<in> Fn(\<kappa>, I, J)"
  using lt_Card_imp_lesspoll assms zero_lesspoll
  unfolding Fn_def
  by (simp,rule_tac x="0\<rightarrow>J" in bexI,simp)
    (rule ReplaceI[of _ 0],simp_all)

lemma Fn_nat_eq_FiniteFun: "Fn(nat,I,J) = I -||> J"
proof (intro equalityI subsetI)
  fix x
  assume "x \<in> I -||> J"
  then
  show "x \<in> Fn(nat,I,J)"
  proof (induct)
    case emptyI
    then
    show ?case
      using zero_in_Fn ltI
      by simp
  next
    case (consI a b h)
    then
    obtain d where "h:d\<rightarrow>J" "d\<prec>nat" "d\<subseteq>I"
      unfolding Fn_def by auto
    moreover from this
    have "Finite(d)"
      using lesspoll_nat_is_Finite by simp
    ultimately
    have "h : d -||> J"
      using fun_FiniteFunI Finite_into_Fin by blast
    note \<open>h:d\<rightarrow>J\<close>
    moreover from this
    have "domain(cons(\<langle>a, b\<rangle>, h)) = cons(a,d)" (is "domain(?h) = ?d")
      and "domain(h) = d"
      using domain_of_fun by simp_all
    moreover
    note consI
    moreover from calculation
    have "cons(\<langle>a, b\<rangle>, h) \<in> cons(a,d) \<rightarrow> J"
      using fun_extend3 by simp
    moreover from \<open>Finite(d)\<close>
    have "Finite(cons(a,d))" by simp
    moreover from this
    have "cons(a,d) \<prec> nat" using Finite_imp_lesspoll_nat by simp
    ultimately
    show ?case
      unfolding Fn_def
      by (simp,rule_tac x="?d\<rightarrow>J" in bexI)
        (force dest:app_fun)+
  qed
next
  fix x
  assume "x \<in> Fn(nat,I,J)"
  then
  obtain d where "x:d\<rightarrow>J" "d \<in> Pow(I)" "d\<prec>nat"
    unfolding Fn_def
    by auto
  moreover from this
  have "Finite(d)"
    using lesspoll_nat_is_Finite by simp
  moreover from calculation
  have "d \<in> Fin(I)"
    using Finite_into_Fin[of d] Fin_mono by auto
  ultimately
  show "x \<in> I -||> J" using fun_FiniteFunI FiniteFun_mono by blast
qed

lemma Fn_nat_subset_Pow: "Fn(\<kappa>,I,J) \<subseteq> Pow(I\<times>J)"
  using Fn_char by auto

lemma FnI:
  assumes "p : d \<rightarrow> J" "d \<subseteq> I" "d \<prec> \<kappa>"
  shows "p \<in> Fn(\<kappa>,I,J)"
  using assms
  unfolding Fn_def by auto

lemma FnD[dest]:
  assumes "p \<in> Fn(\<kappa>,I,J)"
  shows "\<exists>d. p : d \<rightarrow> J \<and> d \<subseteq> I \<and> d \<prec> \<kappa>"
  using assms
  unfolding Fn_def by auto

lemma Fn_is_function: "p \<in> Fn(\<kappa>,I,J) \<Longrightarrow> function(p)"
  unfolding Fn_def using fun_is_function by auto

lemma Fn_csucc:
  assumes "Ord(\<kappa>)"
  shows "Fn(csucc(\<kappa>),I,J) = \<Union>{y . d \<in> Pow(I), y=(d\<rightarrow>J) \<and> d\<lesssim>\<kappa>}"
  using assms
  unfolding Fn_def using lesspoll_csucc by (simp)

definition
  FnleR :: "i \<Rightarrow> i \<Rightarrow> o" (infixl \<open>\<supseteq>\<close> 50) where
  "f \<supseteq> g \<equiv> g \<subseteq> f"

lemma FnleR_iff_subset [iff]: "f \<supseteq> g \<longleftrightarrow> g \<subseteq> f"
  unfolding FnleR_def ..

definition
  Fnlerel :: "i \<Rightarrow> i" where
  "Fnlerel(A) \<equiv> Rrel(\<lambda>x y. x \<supseteq> y,A)"

definition
  Fnle :: "[i,i,i] \<Rightarrow> i" where
  "Fnle(\<kappa>,I,J) \<equiv> Fnlerel(Fn(\<kappa>,I,J))"

lemma FnleI[intro]:
  assumes "p \<in> Fn(\<kappa>,I,J)" "q \<in> Fn(\<kappa>,I,J)" "p \<supseteq> q"
  shows "\<langle>p,q\<rangle> \<in> Fnle(\<kappa>,I,J)"
  using assms unfolding Fnlerel_def Fnle_def FnleR_def Rrel_def
  by auto

lemma FnleD[dest]:
  assumes "\<langle>p,q\<rangle> \<in> Fnle(\<kappa>,I,J)"
  shows "p \<in> Fn(\<kappa>,I,J)" "q \<in> Fn(\<kappa>,I,J)" "p \<supseteq> q"
  using assms unfolding Fnlerel_def Fnle_def FnleR_def Rrel_def
  by auto

definition PFun_Space_Rel :: "[i,i\<Rightarrow>o, i] \<Rightarrow> i"  ("_\<rightharpoonup>\<^bsup>_\<^esup>_")
  where "A \<rightharpoonup>\<^bsup>M\<^esup> B \<equiv> {f \<in> Pow(A\<times>B) . M(f) \<and> function(f)}"

lemma (in M_library) PFun_Space_subset_Powrel :
  assumes "M(A)" "M(B)"
  shows "A \<rightharpoonup>\<^bsup>M\<^esup> B = {f \<in> Pow\<^bsup>M\<^esup>(A\<times>B) . function(f)}"
  using Pow_rel_char assms
  unfolding PFun_Space_Rel_def
  by auto

lemma (in M_library) PFun_Space_closed :
  assumes "M(A)" "M(B)"
  shows "M(A \<rightharpoonup>\<^bsup>M\<^esup> B)"
  using assms PFun_Space_subset_Powrel separation_is_function
  by auto

lemma pfun_is_function :
  "f \<in> A\<rightharpoonup>\<^bsup>M\<^esup> B \<Longrightarrow> function(f)"
  unfolding PFun_Space_Rel_def by simp

lemma pfun_range :
  "f \<in> A \<rightharpoonup>\<^bsup>M\<^esup> B \<Longrightarrow> range(f) \<subseteq> B"
  unfolding PFun_Space_Rel_def by auto

lemma pfun_domain :
  "f \<in> A \<rightharpoonup>\<^bsup>M\<^esup> B \<Longrightarrow> domain(f) \<subseteq> A"
  unfolding PFun_Space_Rel_def by auto

lemma Un_filter_fun_space_closed:
  assumes "G \<subseteq> I \<rightarrow> J" "\<And> f g . f\<in>G \<Longrightarrow> g\<in>G \<Longrightarrow> \<exists>d\<in>I\<rightarrow> J . d \<supseteq> f \<and> d \<supseteq> g"
  shows "\<Union>G \<in> Pow(I\<times>J)" "function(\<Union>G)"
proof -
  from assms
  show "\<Union>G \<in> Pow(I\<times>J)"
    using Union_Pow_iff
    unfolding Pi_def
    by auto
next
  show "function(\<Union>G)"
    unfolding function_def
  proof(auto)
    fix B B' x y y'
    assume "B \<in> G" "\<langle>x, y\<rangle> \<in> B" "B' \<in> G" "\<langle>x, y'\<rangle> \<in> B'"
    moreover from assms this
    have "B \<in> I \<rightarrow> J" "B' \<in> I \<rightarrow> J"
      by auto
    moreover from calculation assms(2)[of B B']
    obtain d where "d \<supseteq> B"  "d \<supseteq> B'" "d\<in>I \<rightarrow> J"  "\<langle>x, y\<rangle> \<in> d" "\<langle>x, y'\<rangle> \<in> d"
      using subsetD[OF \<open>G\<subseteq>_\<close>]
      by auto
    then
    show "y=y'"
      using fun_is_function[OF \<open>d\<in>_\<close>]
      unfolding function_def
      by force
  qed
qed

lemma Un_filter_is_fun :
  assumes "G \<subseteq> I \<rightarrow> J" "\<And> f g . f\<in>G \<Longrightarrow> g\<in>G \<Longrightarrow> \<exists>d\<in>I\<rightarrow> J . d\<supseteq>f \<and> d\<supseteq>g" "G\<noteq>0"
  shows "\<Union>G \<in> I \<rightarrow> J"
  using assms Un_filter_fun_space_closed Pi_iff
proof(simp_all)
  show "I\<subseteq>domain(\<Union>G)"
  proof -
    from \<open>G\<noteq>0\<close>
    obtain f where "f\<subseteq>\<Union>G" "f\<in>G"
      by auto
    with \<open>G\<subseteq>_\<close>
    have "f\<in>I\<rightarrow>J" by auto
    then
    show ?thesis
      using subset_trans[OF _ domain_mono[OF \<open>f\<subseteq>\<Union>G\<close>],of I]
      unfolding Pi_def by auto
  qed
qed

context M_Pi
begin

lemma mem_function_space_relD:
  assumes "f \<in> function_space_rel(M,A,y)" "M(A)" "M(y)"
  shows "f \<in> A \<rightarrow> y" and "M(f)"
  using assms function_space_rel_char by simp_all

lemma pfunI :
  assumes "C\<subseteq>A" "f \<in> C \<rightarrow>\<^bsup>M\<^esup> B" "M(C)" "M(B)"
  shows "f\<in> A \<rightharpoonup>\<^bsup>M\<^esup> B"
proof -
  from assms
  have "f \<in> C\<rightarrow>B" "M(f)"
    using mem_function_space_relD
    by simp_all
  with assms
  show ?thesis
    using Pi_iff
    unfolding PFun_Space_Rel_def
    by auto
qed

lemma zero_in_PFun_rel:
  assumes "M(I)" "M(J)"
  shows "0 \<in> I \<rightharpoonup>\<^bsup>M\<^esup> J"
  using pfunI[of 0] nonempty mem_function_space_rel_abs assms
  by simp

lemma pfun_subsetI :
  assumes "f \<in> A \<rightharpoonup>\<^bsup>M\<^esup> B" "g\<subseteq>f" "M(g)"
  shows "g\<in> A \<rightharpoonup>\<^bsup>M\<^esup> B"
  using assms function_subset
  unfolding PFun_Space_Rel_def
  by auto

lemma pfun_Un_filter_closed:
  assumes "G \<subseteq>I\<rightharpoonup>\<^bsup>M\<^esup> J" "\<And> f g . f\<in>G \<Longrightarrow> g\<in>G \<Longrightarrow> \<exists>d\<in>I\<rightharpoonup>\<^bsup>M\<^esup> J . d\<supseteq>f \<and> d\<supseteq>g"
  shows "\<Union>G \<in> Pow(I\<times>J)" "function(\<Union>G)"
proof -
  from assms
  show "\<Union>G \<in> Pow(I\<times>J)"
    using Union_Pow_iff
    unfolding PFun_Space_Rel_def
    by auto
next
  show "function(\<Union>G)"
    unfolding function_def
  proof(auto)
    fix B B' x y y'
    assume "B \<in> G" "\<langle>x, y\<rangle> \<in> B" "B' \<in> G" "\<langle>x, y'\<rangle> \<in> B'"
    moreover from calculation assms
    obtain d where "d \<in> I \<rightharpoonup>\<^bsup>M\<^esup> J" "function(d)" "\<langle>x, y\<rangle> \<in> d"  "\<langle>x, y'\<rangle> \<in> d"
      using pfun_is_function
      by force
    ultimately
    show "y=y'"
      unfolding function_def
      by auto
  qed
qed

lemma pfun_Un_filter_closed'':
  assumes "G \<subseteq>I\<rightharpoonup>\<^bsup>M\<^esup> J" "\<And> f g . f\<in>G \<Longrightarrow> g\<in>G \<Longrightarrow> \<exists>d\<in>G . d\<supseteq>f \<and> d\<supseteq>g"
  shows "\<Union>G \<in> Pow(I\<times>J)" "function(\<Union>G)"
proof -
  from assms
  have "\<And> f g . f\<in>G \<Longrightarrow> g\<in>G \<Longrightarrow> \<exists>d\<in>I\<rightharpoonup>\<^bsup>M\<^esup> J . d\<supseteq>f \<and> d\<supseteq>g"
    using subsetD[OF assms(1),THEN [2] bexI]
    by force
  then
  show "\<Union>G \<in> Pow(I\<times>J)"  "function(\<Union>G)"
    using assms pfun_Un_filter_closed
    unfolding PFun_Space_Rel_def
    by auto
qed

lemma pfun_Un_filter_closed':
  assumes "G \<subseteq>I\<rightharpoonup>\<^bsup>M\<^esup> J" "\<And> f g . f\<in>G \<Longrightarrow> g\<in>G \<Longrightarrow> \<exists>d\<in>G . d\<supseteq>f \<and> d\<supseteq>g" "M(G)"
  shows "\<Union>G \<in> I\<rightharpoonup>\<^bsup>M\<^esup> J"
  using assms pfun_Un_filter_closed''
  unfolding PFun_Space_Rel_def
  by auto

lemma pfunD :
  assumes "f \<in> A\<rightharpoonup>\<^bsup>M\<^esup> B"
  shows "\<exists>C[M]. C\<subseteq>A \<and> f \<in> C\<rightarrow>B"
proof -
  note assms
  moreover from this
  have "f\<in>Pow(A\<times>B)" "function(f)" "M(f)"
    unfolding PFun_Space_Rel_def
    by simp_all
  moreover from this
  have "domain(f) \<subseteq> A" "f \<in> domain(f) \<rightarrow> B" "M(domain(f))"
    using assms Pow_iff[of f "A\<times>B"] domain_subset Pi_iff
    by auto
  ultimately
  show ?thesis by auto
qed

lemma pfunD_closed :
  assumes "f \<in> A\<rightharpoonup>\<^bsup>M\<^esup> B"
  shows "M(f)"
  using assms
  unfolding PFun_Space_Rel_def by simp

lemma pfun_singletonI :
  assumes "x \<in> A" "b \<in> B" "M(A)" "M(B)"
  shows "{\<langle>x,b\<rangle>} \<in> A\<rightharpoonup>\<^bsup>M\<^esup> B"
  using assms transM[of x A] transM[of b B]
  unfolding PFun_Space_Rel_def function_def
  by auto

lemma pfun_unionI :
  assumes "f \<in> A\<rightharpoonup>\<^bsup>M\<^esup> B" "g \<in> A\<rightharpoonup>\<^bsup>M\<^esup> B" "domain(f)\<inter>domain(g)=0"
  shows "f\<union>g \<in> A\<rightharpoonup>\<^bsup>M\<^esup> B"
  using assms
  unfolding PFun_Space_Rel_def function_def
  by blast

lemma (in M_library) pfun_restrict_eq_imp_compat:
  assumes "f \<in> I\<rightharpoonup>\<^bsup>M\<^esup> J" "g \<in> I\<rightharpoonup>\<^bsup>M\<^esup> J" "M(J)"
    "restrict(f, domain(f) \<inter> domain(g)) = restrict(g, domain(f) \<inter> domain(g))"
  shows "f \<union> g \<in> I\<rightharpoonup>\<^bsup>M\<^esup> J"
proof -
  note assms
  moreover from this
  obtain C D where "f : C \<rightarrow> J" "C \<subseteq> I" "D \<subseteq> I" "M(C)" "M(D)" "g : D \<rightarrow> J"
    using pfunD[of f] pfunD[of g] by force
  moreover from calculation
  have "f\<union>g \<in> C\<union>D \<rightarrow> J"
    using restrict_eq_imp_Un_into_Pi'[OF \<open>f\<in>C\<rightarrow>_\<close> \<open>g\<in>D\<rightarrow>_\<close>]
    by auto
  ultimately
  show ?thesis
    using pfunI[of "C\<union>D" _ "f\<union>g"] Un_subset_iff pfunD_closed function_space_rel_char
    by auto
qed

lemma FiniteFun_pfunI :
  assumes "f \<in> A-||> B" "M(A)" "M(B)"
  shows "f \<in> A \<rightharpoonup>\<^bsup>M\<^esup> B"
  using assms(1)
proof(induct)
  case emptyI
  then
  show ?case
    using assms nonempty mem_function_space_rel_abs pfunI[OF empty_subsetI, of 0]
    by simp
next
  case (consI a b h)
  note consI
  moreover from this
  have "M(a)" "M(b)" "M(h)" "domain(h) \<subseteq> A"
    using transM[OF _ \<open>M(A)\<close>] transM[OF _ \<open>M(B)\<close>]
      FinD
      FiniteFun_domain_Fin
      pfunD_closed
    by simp_all
  moreover from calculation
  have "{a}\<union>domain(h)\<subseteq>A" "M({a}\<union>domain(h))" "M(cons(<a,b>,h))" "domain(cons(<a,b>,h)) = {a}\<union>domain(h)"
    by auto
  moreover from calculation
  have "cons(<a,b>,h) \<in> {a}\<union>domain(h) \<rightarrow> B"
    using FiniteFun_is_fun[OF FiniteFun.consI, of a A b B h]
    by auto
  ultimately
  show "cons(<a,b>,h) \<in> A \<rightharpoonup>\<^bsup>M\<^esup> B"
    using assms  mem_function_space_rel_abs pfunI
    by simp_all
qed

lemma PFun_FiniteFunI :
  assumes "f \<in> A \<rightharpoonup>\<^bsup>M\<^esup> B" "Finite(f)"
  shows  "f \<in> A-||> B"
proof -
  from assms
  have "f\<in>Fin(A\<times>B)" "function(f)"
    using Finite_Fin Pow_iff
    unfolding PFun_Space_Rel_def
    by auto
  then
  show ?thesis
    using FiniteFunI by simp
qed

end \<comment> \<open>\<^locale>\<open>M_Pi\<close>\<close>

definition
  Fn_rel :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> i" (\<open>Fn\<^bsup>_\<^esup>'(_,_,_')\<close>) where
  "Fn_rel(M,\<kappa>,I,J) \<equiv> {f \<in> I\<rightharpoonup>\<^bsup>M\<^esup> J . f \<prec>\<^bsup>M\<^esup> \<kappa>}"
\<comment> \<open>Eventually we can define \<^term>\<open>Fn_rel\<close> as the relativization of \<^term>\<open>Fn\<close>\<close>

context  M_library
begin

lemma Fn_rel_subset_PFun_rel : "Fn\<^bsup>M\<^esup>(\<kappa>,I,J) \<subseteq> I\<rightharpoonup>\<^bsup>M\<^esup> J"
  unfolding Fn_rel_def by auto

lemma Fn_relI[intro]:
  assumes "f : d \<rightarrow> J" "d \<subseteq> I" "f \<prec>\<^bsup>M\<^esup> \<kappa>" "M(d)" "M(J)" "M(f)"
  shows "f \<in> Fn_rel(M,\<kappa>,I,J)"
  using assms pfunI mem_function_space_rel_abs
  unfolding Fn_rel_def
  by auto

lemma Fn_relD[dest]:
  assumes "p \<in> Fn_rel(M,\<kappa>,I,J)"
  shows "\<exists>C[M]. C\<subseteq>I \<and> p : C \<rightarrow> J \<and> p \<prec>\<^bsup>M\<^esup> \<kappa>"
  using assms pfunD
  unfolding Fn_rel_def
  by simp

lemma Fn_rel_is_function:
  assumes "p \<in> Fn_rel(M,\<kappa>,I,J)"
  shows "function(p)" "M(p)" "p \<prec>\<^bsup>M\<^esup> \<kappa>" "p\<in> I\<rightharpoonup>\<^bsup>M\<^esup> J"
  using assms
  unfolding Fn_rel_def PFun_Space_Rel_def by simp_all

lemma Fn_rel_mono:
  assumes "p \<in> Fn_rel(M,\<kappa>,I,J)" "\<kappa> \<prec>\<^bsup>M\<^esup> \<kappa>'" "M(\<kappa>)" "M(\<kappa>')"
  shows "p \<in> Fn_rel(M,\<kappa>',I,J)"
  using assms lesspoll_rel_trans[OF _ assms(2)] cardinal_rel_closed
    Fn_rel_is_function(2)[OF assms(1)]
  unfolding Fn_rel_def
  by simp

lemma Fn_rel_mono':
  assumes "p \<in> Fn_rel(M,\<kappa>,I,J)" "\<kappa> \<lesssim>\<^bsup>M\<^esup> \<kappa>'" "M(\<kappa>)" "M(\<kappa>')"
  shows "p \<in> Fn_rel(M,\<kappa>',I,J)"
proof -
  note assms
  then
  consider "\<kappa> \<prec>\<^bsup>M\<^esup> \<kappa>'"  | "\<kappa> \<approx>\<^bsup>M\<^esup> \<kappa>'"
    using lepoll_rel_iff_leqpoll_rel
    by auto
  then
  show ?thesis
  proof(cases)
    case 1
    with assms show ?thesis using Fn_rel_mono by simp
  next
    case 2
    then show ?thesis
      using assms cardinal_rel_closed Fn_rel_is_function[OF assms(1)]
        lesspoll_rel_eq_trans
      unfolding Fn_rel_def
      by simp
  qed
qed

lemma Fn_csucc:
  assumes "Ord(\<kappa>)" "M(\<kappa>)"
  shows "Fn_rel(M,(\<kappa>\<^sup>+)\<^bsup>M\<^esup>,I,J) = {p\<in> I\<rightharpoonup>\<^bsup>M\<^esup> J . p  \<lesssim>\<^bsup>M\<^esup> \<kappa>}"   (is "?L=?R")
  using assms
proof(intro equalityI)
  show "?L \<subseteq> ?R"
  proof(intro subsetI)
    fix p
    assume "p\<in>?L"
    then
    have "p \<prec>\<^bsup>M\<^esup> csucc_rel(M,\<kappa>)" "M(p)" "p\<in> I\<rightharpoonup>\<^bsup>M\<^esup> J"
      using Fn_rel_is_function by simp_all
    then
    show "p\<in>?R"
      using  assms lesspoll_rel_csucc_rel by simp
  qed
next
  show "?R\<subseteq>?L"
  proof(intro subsetI)
    fix p
    assume "p\<in>?R"
    then
    have  "p\<in> I\<rightharpoonup>\<^bsup>M\<^esup> J" "p \<lesssim>\<^bsup>M\<^esup> \<kappa>"
      using assms lesspoll_rel_csucc_rel by simp_all
    then
    show "p\<in>?L"
      using  assms lesspoll_rel_csucc_rel pfunD_closed
      unfolding Fn_rel_def
      by simp
  qed
qed

lemma Finite_imp_lesspoll_nat:
  assumes "Finite(A)"
  shows "A \<prec> nat"
  using assms subset_imp_lepoll[OF naturals_subset_nat] eq_lepoll_trans
    n_lesspoll_nat eq_lesspoll_trans
  unfolding Finite_def lesspoll_def by auto

lemma FinD_Finite :
  assumes "a\<in>Fin(A)"
  shows "Finite(a)"
  using assms
  by(induct,simp_all)

lemma Fn_rel_nat_eq_FiniteFun:
  assumes "M(I)" "M(J)"
  shows "I -||> J = Fn_rel(M,\<omega>,I,J)"
proof(intro equalityI subsetI)
  fix p
  assume "p\<in>I -||> J"
  with assms
  have "p\<in> I \<rightharpoonup>\<^bsup>M\<^esup> J" "Finite(p)"
    using FiniteFun_pfunI FinD_Finite[OF subsetD[OF FiniteFun.dom_subset,OF \<open>p\<in>_\<close>]]
    by auto
  moreover from this
  have "p \<prec>\<^bsup>M\<^esup> \<omega>"
    using Finite_lesspoll_rel_nat pfunD_closed[of p] n_lesspoll_rel_nat
    by simp
  ultimately
  show "p\<in> Fn_rel(M,\<omega>,I,J)"
    unfolding Fn_rel_def by simp
next
  fix p
  assume "p\<in> Fn_rel(M,\<omega>,I,J)"
  then
  have "p\<in> I \<rightharpoonup>\<^bsup>M\<^esup> J"  "p \<prec>\<^bsup>M\<^esup> \<omega>"
    unfolding Fn_rel_def by simp_all
  moreover from this
  have "Finite(p)"
    using Finite_cardinal_rel_Finite lesspoll_rel_nat_is_Finite_rel pfunD_closed
      cardinal_rel_closed[of p]  Finite_cardinal_rel_iff'[THEN iffD1]
    by simp
  ultimately
  show "p\<in>I -||> J"
    using PFun_FiniteFunI
    by simp
qed

lemma Fn_nat_abs:
  assumes "M(I)" "M(J)"
  shows "Fn(nat,I,J) = Fn_rel(M,\<omega>,I,J)"
  using assms Fn_rel_nat_eq_FiniteFun Fn_nat_eq_FiniteFun
  by simp

lemma Fn_rel_singletonI:
  assumes "x \<in> I" "j \<in> J" "1 \<prec>\<^bsup>M\<^esup> \<kappa>" "M(\<kappa>)" "M(I)" "M(J)"
  shows "{\<langle>x,j\<rangle>} \<in> Fn\<^bsup>M\<^esup>(\<kappa>,I,J)"
  using pfun_singletonI transM[of x] transM[of j] assms
    eq_lesspoll_rel_trans[OF singleton_eqpoll_rel_1]
  unfolding Fn_rel_def
  by auto

end \<comment> \<open>\<^locale>\<open>M_library\<close>\<close>

definition
  Fnle_rel :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> i" (\<open>Fnle\<^bsup>_\<^esup>'(_,_,_')\<close>) where
  "Fnle_rel(M,\<kappa>,I,J) \<equiv> Fnlerel(Fn\<^bsup>M\<^esup>(\<kappa>,I,J))"

abbreviation
  Fn_r_set ::  "[i,i,i,i] \<Rightarrow> i" (\<open>Fn\<^bsup>_\<^esup>'(_,_,_')\<close>) where
  "Fn_r_set(M) \<equiv> Fn_rel(##M)"

abbreviation
  Fnle_r_set ::  "[i,i,i,i] \<Rightarrow> i" (\<open>Fnle\<^bsup>_\<^esup>'(_,_,_')\<close>) where
  "Fnle_r_set(M) \<equiv> Fnle_rel(##M)"

context M_library
begin

lemma Fnle_relI[intro]:
  assumes "p \<in> Fn_rel(M,\<kappa>,I,J)" "q \<in> Fn_rel(M,\<kappa>,I,J)" "p \<supseteq> q"
  shows "\<langle>p, q\<rangle> \<in> Fnle_rel(M,\<kappa>,I,J)"
  using assms unfolding Fnlerel_def Fnle_rel_def FnleR_def Rrel_def
  by auto

lemma Fnle_relD[dest]:
  assumes "\<langle>p, q\<rangle> \<in> Fnle_rel(M,\<kappa>,I,J)"
  shows "p \<in> Fn_rel(M,\<kappa>,I,J)" "q \<in> Fn_rel(M,\<kappa>,I,J)" "p \<supseteq> q"
  using assms unfolding Fnlerel_def Fnle_rel_def FnleR_def Rrel_def
  by auto

lemma Fn_rel_closed[intro,simp]:
  assumes "M(\<kappa>)" "M(I)" "M(J)"
  shows "M(Fn\<^bsup>M\<^esup>(\<kappa>,I,J))"
  using assms separation_cardinal_rel_lesspoll_rel PFun_Space_closed
  unfolding Fn_rel_def
  by auto

lemma Fn_rel_subset_Pow:
  assumes "M(\<kappa>)" "M(I)" "M(J)"
  shows "Fn\<^bsup>M\<^esup>(\<kappa>,I,J) \<subseteq> Pow(I\<times>J)"
  unfolding Fn_rel_def PFun_Space_Rel_def
  by auto

lemma Fnle_rel_closed[intro,simp]:
  assumes "M(\<kappa>)" "M(I)" "M(J)"
  shows "M(Fnle\<^bsup>M\<^esup>(\<kappa>,I,J))"
  unfolding Fnle_rel_def Fnlerel_def Rrel_def FnleR_def
  using assms supset_separation Fn_rel_closed
  by auto

lemma zero_in_Fn_rel:
  assumes "0<\<kappa>" "M(\<kappa>)" "M(I)" "M(J)"
  shows "0 \<in> Fn\<^bsup>M\<^esup>(\<kappa>, I, J)"
  unfolding Fn_rel_def
  using zero_in_PFun_rel zero_lesspoll_rel assms
  by simp

lemma zero_top_Fn_rel:
  assumes "p\<in>Fn\<^bsup>M\<^esup>(\<kappa>, I, J)" "0<\<kappa>" "M(\<kappa>)" "M(I)" "M(J)"
  shows "\<langle>p, 0\<rangle> \<in> Fnle\<^bsup>M\<^esup>(\<kappa>, I, J)"
  using assms zero_in_Fn_rel unfolding preorder_on_def refl_def trans_on_def
  by auto

lemma preorder_on_Fnle_rel:
  assumes "M(\<kappa>)" "M(I)" "M(J)"
  shows "preorder_on(Fn\<^bsup>M\<^esup>(\<kappa>, I, J), Fnle\<^bsup>M\<^esup>(\<kappa>, I, J))"
  unfolding preorder_on_def refl_def trans_on_def
  by blast

end  \<comment> \<open>\<^locale>\<open>M_library\<close>\<close>

context M_cardinal_library
begin

lemma lesspoll_nat_imp_lesspoll_rel:
  assumes "A \<prec> \<omega>" "M(A)"
  shows "A \<prec>\<^bsup>M\<^esup> \<omega>"
proof -
  note assms
  moreover from this
  obtain f n where "f\<in>bij\<^bsup>M\<^esup>(A,n)" "n\<in>\<omega>" "A \<approx>\<^bsup>M\<^esup> n"
    using lesspoll_nat_is_Finite Finite_rel_def[of M A]
    by auto
  moreover from calculation
  have "A \<lesssim>\<^bsup>M\<^esup> \<omega>"
    using lesspoll_nat_is_Finite Infinite_imp_nats_lepoll_rel[of \<omega> n]
      nat_not_Finite eq_lepoll_rel_trans[of A n \<omega>]
    by auto
  moreover from calculation
  have "\<not> g \<in> bij\<^bsup>M\<^esup>(A,\<omega>)" for g
    using mem_bij_rel unfolding lesspoll_def by auto
  ultimately
  show ?thesis
    unfolding lesspoll_rel_def
    by auto
qed

lemma Finite_imp_lesspoll_rel_nat:
  assumes "Finite(A)" "M(A)"
  shows "A \<prec>\<^bsup>M\<^esup> \<omega>"
  using Finite_imp_lesspoll_nat assms lesspoll_nat_imp_lesspoll_rel
  by auto

end \<comment> \<open>\<^locale>\<open>M_cardinal_library\<close>\<close>

context M_cardinal_library_extra
begin

lemma InfCard_rel_lesspoll_rel_Un:
  includes Ord_dests
  assumes "InfCard_rel(M,\<kappa>)" "A \<prec>\<^bsup>M\<^esup> \<kappa>" "B \<prec>\<^bsup>M\<^esup> \<kappa>"
    and types: "M(\<kappa>)" "M(A)" "M(B)"
  shows "A \<union> B \<prec>\<^bsup>M\<^esup> \<kappa>"
proof -
  from assms
  have "|A|\<^bsup>M\<^esup> < \<kappa>" "|B|\<^bsup>M\<^esup> < \<kappa>"
    using lesspoll_rel_cardinal_rel_lt InfCard_rel_is_Card_rel
    by auto
  show ?thesis
  proof (cases "Finite(A) \<and> Finite(B)")
    case True
    with assms
    show ?thesis
      using lesspoll_rel_trans2[OF _ le_imp_lepoll_rel, of _ nat \<kappa>]
        Finite_imp_lesspoll_rel_nat[OF Finite_Un]
      unfolding InfCard_rel_def
      by simp
  next
    case False
    with types
    have "InfCard_rel(M,max(|A|\<^bsup>M\<^esup>,|B|\<^bsup>M\<^esup>))"
      using Infinite_InfCard_rel_cardinal_rel InfCard_rel_is_Card_rel
        le_trans[of nat] not_le_iff_lt[THEN iffD1, THEN leI, of "|A|\<^bsup>M\<^esup>" "|B|\<^bsup>M\<^esup>"]
      unfolding max_def InfCard_rel_def
      by auto
    with \<open>M(A)\<close> \<open>M(B)\<close>
    have "|A \<union> B|\<^bsup>M\<^esup> \<le> max(|A|\<^bsup>M\<^esup>,|B|\<^bsup>M\<^esup>)"
      using cardinal_rel_Un_le[of "max(|A|\<^bsup>M\<^esup>,|B|\<^bsup>M\<^esup>)" A B]
        not_le_iff_lt[THEN iffD1, THEN leI, of "|A|\<^bsup>M\<^esup>" "|B|\<^bsup>M\<^esup>" ]
      unfolding max_def
      by simp
    moreover from \<open>|A|\<^bsup>M\<^esup> < \<kappa>\<close> \<open>|B|\<^bsup>M\<^esup> < \<kappa>\<close>
    have "max(|A|\<^bsup>M\<^esup>,|B|\<^bsup>M\<^esup>) < \<kappa>"
      unfolding max_def
      by simp
    ultimately
    have "|A \<union> B|\<^bsup>M\<^esup> <  \<kappa>"
      using lt_trans1
      by blast
    moreover
    note \<open>InfCard_rel(M,\<kappa>)\<close>
    moreover from calculation types
    have "|A \<union> B|\<^bsup>M\<^esup> \<prec>\<^bsup>M\<^esup> \<kappa>"
      using lt_Card_rel_imp_lesspoll_rel InfCard_rel_is_Card_rel
      by simp
    ultimately
    show ?thesis
      using cardinal_rel_eqpoll_rel eq_lesspoll_rel_trans[of "A \<union> B" "|A \<union> B|\<^bsup>M\<^esup>" \<kappa>]
        eqpoll_rel_sym types
      by simp
  qed
qed

lemma Fn_rel_unionI:
  assumes "p \<in> Fn\<^bsup>M\<^esup>(\<kappa>,I,J)" "q\<in>Fn\<^bsup>M\<^esup>(\<kappa>,I,J)" "InfCard\<^bsup>M\<^esup>(\<kappa>)"
    "M(\<kappa>)" "M(I)" "M(J)" "domain(p) \<inter> domain(q) = 0"
  shows "p\<union>q \<in> Fn\<^bsup>M\<^esup>(\<kappa>,I,J)"
proof -
  note assms
  moreover from calculation
  have "p \<prec>\<^bsup>M\<^esup> \<kappa>" "q \<prec>\<^bsup>M\<^esup> \<kappa>" "M(p)" "M(q)"
    using Fn_rel_is_function by simp_all
  moreover from calculation
  have "p\<union>q \<prec>\<^bsup>M\<^esup> \<kappa>"
    using eqpoll_rel_sym cardinal_rel_eqpoll_rel InfCard_rel_lesspoll_rel_Un
    by simp_all
  ultimately
  show ?thesis
    unfolding Fn_rel_def
    using pfun_unionI cardinal_rel_eqpoll_rel eq_lesspoll_rel_trans[OF _ \<open>p\<union>q \<prec>\<^bsup>M\<^esup> _\<close>]
    by auto
qed

lemma restrict_eq_imp_compat_rel:
  assumes "p \<in> Fn\<^bsup>M\<^esup>(\<kappa>, I, J)" "q \<in> Fn\<^bsup>M\<^esup>(\<kappa>, I, J)" "InfCard\<^bsup>M\<^esup>(\<kappa>)" "M(J)" "M(\<kappa>)"
    "restrict(p, domain(p) \<inter> domain(q)) = restrict(q, domain(p) \<inter> domain(q))"
  shows "p \<union> q \<in> Fn\<^bsup>M\<^esup>(\<kappa>, I, J)"
proof -
  note assms
  moreover from calculation
  have "p \<prec>\<^bsup>M\<^esup> \<kappa>" "q \<prec>\<^bsup>M\<^esup> \<kappa>" "M(p)" "M(q)"
    using Fn_rel_is_function by simp_all
  moreover from calculation
  have "p\<union>q \<prec>\<^bsup>M\<^esup> \<kappa>"
    using InfCard_rel_lesspoll_rel_Un cardinal_rel_eqpoll_rel[THEN eqpoll_rel_sym]
    by auto
  ultimately
  show ?thesis
    unfolding Fn_rel_def
    using pfun_restrict_eq_imp_compat cardinal_rel_eqpoll_rel
      eq_lesspoll_rel_trans[OF _ \<open>p\<union>q \<prec>\<^bsup>M\<^esup> _\<close>]
    by auto
qed

lemma InfCard_rel_imp_n_lesspoll_rel :
  assumes "InfCard\<^bsup>M\<^esup>(\<kappa>)" "M(\<kappa>)" "n\<in>\<omega>"
  shows "n \<prec>\<^bsup>M\<^esup> \<kappa>"
proof -
  note assms
  moreover from this
  have "n \<prec>\<^bsup>M\<^esup> \<omega>"
    using n_lesspoll_rel_nat by simp
  ultimately
  show ?thesis
    using lesspoll_rel_trans2 Infinite_iff_lepoll_rel_nat InfCard_rel_imp_Infinite nat_into_M
    by simp
qed

lemma cons_in_Fn_rel:
  assumes "x \<notin> domain(p)" "p \<in> Fn\<^bsup>M\<^esup>(\<kappa>,I,J)" "x \<in> I" "j \<in> J" "InfCard\<^bsup>M\<^esup>(\<kappa>)"
    "M(\<kappa>)" "M(I)" "M(J)"
  shows "cons(\<langle>x,j\<rangle>, p) \<in> Fn\<^bsup>M\<^esup>(\<kappa>,I,J)"
  using assms cons_eq Fn_rel_unionI[OF Fn_rel_singletonI[of x I j J] \<open>p\<in>_\<close>]
    InfCard_rel_imp_n_lesspoll_rel
  by auto

lemma dense_dom_dense:
  assumes "x \<in> I" "InfCard\<^bsup>M\<^esup>(\<kappa>)" "M(I)" "M(J)" "z\<in>J" "M(\<kappa>)" "p\<in>Fn\<^bsup>M\<^esup>(\<kappa>, I, J)"
  shows "\<exists>d\<in>{ p \<in> Fn\<^bsup>M\<^esup>(\<kappa>, I, J) . x \<in> domain(p) }. \<langle>d,p\<rangle> \<in> Fnle\<^bsup>M\<^esup>(\<kappa>, I, J)"
proof (cases "x \<in> domain(p)")
  case True
  with \<open>x \<in> I\<close> \<open>p \<in> Fn\<^bsup>M\<^esup>(\<kappa>, I, J)\<close>
  show ?thesis by auto
next
  case False
  note \<open>p \<in> Fn\<^bsup>M\<^esup>(\<kappa>, I, J)\<close>
  moreover from this and False and assms
  have "cons(\<langle>x,z\<rangle>, p) \<in> Fn\<^bsup>M\<^esup>(\<kappa>, I, J)" "M(x)"
    using cons_in_Fn_rel by (auto dest:transM)
  ultimately
  show ?thesis using Fn_relD by blast
qed

lemma (in M_cardinal_library) domain_lepoll_rel :
  assumes "function(r)" "M(r)"
  shows "domain(r) \<lesssim>\<^bsup>M\<^esup> r"
proof -
  let ?f="\<lambda>x\<in>domain(r) . \<langle>x,r`x\<rangle>"
  have "\<langle>x, r ` x\<rangle> \<in> r" if "\<langle>x, y\<rangle> \<in> r" for x y
  proof -
    have "x\<in>domain(r)" using that by auto
    with assms
    show ?thesis using function_apply_Pair by auto
  qed
  then
  have "?f \<in> inj(domain(r), r)"
    by(rule_tac lam_injective,auto)
  moreover note assms
  moreover from calculation
  have "M(?f)"
    using lam_replacement_constant[of r] lam_replacement_identity assms
      lam_replacement_apply lam_replacement_Pair[THEN [5] lam_replacement_hcomp2]
    by(rule_tac lam_replacement_imp_lam_closed,auto dest:transM[of _ r])
  ultimately
  have "?f \<in> inj\<^bsup>M\<^esup>(domain(r),r)" using inj_rel_char
    by auto
  with \<open>M(?f)\<close>
  show ?thesis
    using lepoll_relI by simp
qed

lemma dense_surj_dense:
  assumes "x \<in> J" "InfCard\<^bsup>M\<^esup>(\<kappa>)" "M(I)" "M(J)" "M(\<kappa>)" "p\<in>Fn\<^bsup>M\<^esup>(\<kappa>, I, J)" "\<kappa> \<lesssim>\<^bsup>M\<^esup> I"
  shows "\<exists>d\<in>{ p \<in> Fn\<^bsup>M\<^esup>(\<kappa>, I, J) . x \<in> range(p) }. \<langle>d,p\<rangle> \<in> Fnle\<^bsup>M\<^esup>(\<kappa>, I, J)"
proof -
  from \<open>p \<in> _\<close> \<open>M(J)\<close> \<open>x\<in>_\<close> lesspoll_rel_def
  have "domain(p) \<subseteq> I" "M(p)" "p \<prec>\<^bsup>M\<^esup> \<kappa>" "M(x)" "function(p)"
    using pfun_domain[OF Fn_rel_is_function(4)] Fn_rel_is_function transM[of x J]
    by simp_all
  moreover from calculation assms
  have 1:"domain(p) \<prec>\<^bsup>M\<^esup> \<kappa>" "M(domain(p))" "domain(p) \<prec>\<^bsup>M\<^esup> I"
    using domain_lepoll_rel lesspoll_rel_trans1[of "domain(p)" p \<kappa>] lesspoll_rel_trans2
    by auto
  with calculation \<open>\<kappa> \<lesssim>\<^bsup>M\<^esup> I\<close> \<open>M(I)\<close> \<open>M(\<kappa>)\<close>
  have "domain(p) \<noteq> I"
  proof -
    {assume "domain(p) = I"
      with 1
      have "domain(p) \<prec>\<^bsup>M\<^esup> domain(p)"
        by auto
      with \<open>M(domain(p))\<close>
      have False
        using lesspoll_rel_irrefl[of "domain(p)"] by simp
    }
    then show ?thesis by auto
  qed
  ultimately
  obtain \<alpha> where "\<alpha> \<notin> domain(p)" "\<alpha>\<in>I"
    by force
  moreover note assms
  moreover from calculation
  have "cons(\<langle>\<alpha>,x\<rangle>, p) \<in> Fn\<^bsup>M\<^esup>(\<kappa>, I, J)"
    using InfCard_rel_Aleph_rel cons_in_Fn_rel[of \<alpha> p \<kappa> I J x]
    by auto
  ultimately
  show ?thesis
    using Fnle_relI by blast
qed

end \<comment> \<open>\<^locale>\<open>M_cardinal_library_extra\<close>\<close>

end