(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Rel
  imports Agent
begin

consts eqvt :: "(('a::pt_name) \<times> ('a::pt_name)) set \<Rightarrow> bool"
defs eqvt_def: "eqvt Rel \<equiv> (\<forall>x (perm::name prm). x \<in> Rel \<longrightarrow> perm \<bullet> x \<in> Rel)"

lemma eqvtRelI:
  fixes Rel  :: "('a::pt_name \<times> 'a) set"
  and   P    :: 'a
  and   Q    :: 'a
  and   perm :: "name prm"

  assumes "eqvt Rel"
  and     "(P, Q) \<in> Rel"

  shows "(perm \<bullet> P, perm \<bullet> Q) \<in> Rel"
using assms
by(auto simp add: eqvt_def)

lemma eqvtRelE:
  fixes Rel  :: "('a::pt_name \<times> 'a) set"
  and   P    :: 'a
  and   Q    :: 'a
  and   perm :: "name prm"

  assumes "eqvt Rel"
  and     "(perm \<bullet> P, perm \<bullet> Q) \<in> Rel"

  shows "(P, Q) \<in> Rel"
proof -
  have "rev perm \<bullet> (perm \<bullet> P) = P" and "rev perm \<bullet> (perm \<bullet> Q) = Q"
    by(simp add: pt_rev_pi[OF pt_name_inst, OF at_name_inst])+
  with assms show ?thesis
    by(force dest: eqvtRelI[of _ _ _ "rev perm"])
qed

lemma eqvtTrans[intro]:
  fixes Rel  :: "('a::pt_name \<times> 'a) set"
  and   Rel' :: "('a \<times> 'a) set"

  assumes EqvtRel:  "eqvt Rel"
  and     EqvtRel': "eqvt Rel'"

  shows "eqvt (Rel O Rel')"
using assms
by(force simp add: eqvt_def)

lemma eqvtUnion[intro]:
  fixes Rel  :: "('a::pt_name \<times> 'a) set"
  and   Rel' :: "('a \<times> 'a) set"

  assumes EqvtRel:  "eqvt Rel"
  and     EqvtRel': "eqvt Rel'"

  shows "eqvt (Rel \<union> Rel')"
using assms
by(force simp add: eqvt_def)

definition substClosed :: "(pi \<times> pi) set \<Rightarrow> (pi \<times> pi) set" where
  "substClosed Rel \<equiv> {(P, Q) | P Q. \<forall>\<sigma>. (P[<\<sigma>>], Q[<\<sigma>>]) \<in> Rel}"

lemma eqvtSubstClosed:
  fixes Rel :: "(pi \<times> pi) set"

  assumes eqvtRel: "eqvt Rel"

  shows "eqvt (substClosed Rel)"
proof(simp add: eqvt_def substClosed_def, auto)
  fix P Q perm s

  assume "\<forall>s. (P[<s>], Q[<s>]) \<in> Rel"
  hence "(P[<(rev (perm::name prm) \<bullet> s)>], Q[<(rev perm \<bullet> s)>]) \<in> Rel" by simp
  with eqvtRel have "(perm \<bullet> (P[<(rev perm \<bullet> s)>]), perm \<bullet> (Q[<(rev perm \<bullet> s)>])) \<in> Rel"
    by(rule eqvtRelI)
  thus "((perm \<bullet> P)[<s>], (perm \<bullet> Q)[<s>]) \<in> Rel"
    by(simp add: name_per_rev)
qed

lemma substClosedSubset:
  fixes Rel  :: "(pi \<times> pi) set"

  shows "substClosed Rel \<subseteq> Rel"
proof(auto simp add: substClosed_def)
  fix P Q
  assume "\<forall>s. (P[<s>], Q[<s>]) \<in> Rel"
  hence "(P[<[]>], Q[<[]>]) \<in> Rel" by blast
  thus "(P, Q) \<in> Rel" by simp
qed

lemma partUnfold:
  fixes P   :: pi
  and   Q   :: pi
  and   \<sigma>   :: "(name \<times> name) list"
  and   Rel :: "(pi \<times> pi) set"

  assumes "(P, Q) \<in> substClosed Rel"

  shows "(P[<\<sigma>>], Q[<\<sigma>>]) \<in> substClosed Rel"
using assms
proof(auto simp add: substClosed_def)
  fix \<sigma>'
  assume "\<forall>\<sigma>. (P[<\<sigma>>], Q[<\<sigma>>]) \<in> Rel"
  hence "(P[<(\<sigma>@\<sigma>')>], Q[<(\<sigma>@\<sigma>')>]) \<in> Rel" by blast
  thus "((P[<\<sigma>>])[<\<sigma>'>], (Q[<\<sigma>>])[<\<sigma>'>]) \<in> Rel"
    by simp
qed

inductive_set bangRel :: "(pi \<times> pi) set \<Rightarrow> (pi \<times> pi) set"
for Rel :: "(pi \<times> pi) set"
where
  BRBang: "(P, Q) \<in> Rel \<Longrightarrow> (!P, !Q) \<in> bangRel Rel"
| BRPar: "(R, T) \<in> Rel \<Longrightarrow> (P, Q) \<in> (bangRel Rel) \<Longrightarrow> (R \<parallel> P, T \<parallel> Q) \<in> (bangRel Rel)"
| BRRes: "(P, Q) \<in> bangRel Rel \<Longrightarrow> (<\<nu>a>P, <\<nu>a>Q) \<in> bangRel Rel"

inductive_cases BRBangCases': "(P, !Q) \<in> bangRel Rel"
inductive_cases BRParCases': "(P, Q \<parallel> !Q) \<in> bangRel Rel"
inductive_cases BRResCases': "(P, <\<nu>x>Q) \<in> bangRel Rel"

lemma eqvtBangRel:
  fixes Rel :: "(pi \<times> pi) set"

  assumes eqvtRel: "eqvt Rel"

  shows "eqvt(bangRel Rel)"
proof(simp add: eqvt_def, auto)
  fix P Q perm
  assume "(P, Q) \<in> bangRel Rel"
  thus "((perm::name prm) \<bullet> P, perm \<bullet> Q) \<in> bangRel Rel"
  proof(induct)
    fix P Q
    assume "(P, Q) \<in> Rel"
    with eqvtRel have "(perm \<bullet> P, perm \<bullet> Q) \<in> Rel"
      by(rule eqvtRelI)
    thus "(perm \<bullet> !P, perm \<bullet> !Q) \<in> bangRel Rel"
      by(force intro: BRBang)
  next
    fix P Q R T
    assume R: "(R, T) \<in> Rel"
    assume BR: "(perm \<bullet> P, perm \<bullet> Q) \<in> bangRel Rel"

    from eqvtRel R have "(perm \<bullet> R, perm \<bullet> T) \<in> Rel"
      by(rule eqvtRelI)

    with BR show "(perm \<bullet> (R \<parallel> P), perm \<bullet> (T \<parallel> Q)) \<in> bangRel Rel"
      by(force intro: BRPar)
  next
    fix P Q a
    assume "(perm \<bullet> P, perm \<bullet> Q) \<in> bangRel Rel"
    thus "(perm \<bullet> <\<nu>a>P, perm \<bullet> <\<nu>a>Q) \<in> bangRel Rel"
      by(force intro: BRRes)
  qed
qed

lemma BRBangCases[consumes 1, case_names BRBang]:
  fixes P   :: pi
  and   Q   :: pi
  and   Rel :: "(pi \<times> pi) set"
  and   F   :: "pi \<Rightarrow> bool"

  assumes "(P, !Q) \<in> bangRel Rel"
  and     "\<And>P. (P, Q) \<in> Rel \<Longrightarrow> F (!P)"

  shows "F P"
using assms
by(induct rule: BRBangCases', auto simp add: pi.inject)

lemma BRParCases[consumes 1, case_names BRPar]:
  fixes P   :: pi
  and   Q   :: pi
  and   Rel :: "(pi \<times> pi) set"
  and   F   :: "pi \<Rightarrow> bool"

  assumes "(P, Q \<parallel> !Q) \<in> bangRel Rel"
  and     "\<And>P R. \<lbrakk>(P, Q) \<in> Rel; (R, !Q) \<in> bangRel Rel\<rbrakk> \<Longrightarrow> F (P \<parallel> R)"

  shows "F P"
using assms
by(induct rule: BRParCases', auto simp add: pi.inject)

lemma bangRelSubset:
  fixes Rel  :: "(pi \<times> pi) set"
  and   Rel' :: "(pi \<times> pi) set"

  assumes "(P, Q) \<in> bangRel Rel"
  and     "\<And>P Q. (P, Q) \<in> Rel \<Longrightarrow> (P, Q) \<in> Rel'"

  shows "(P, Q) \<in> bangRel Rel'"
using assms
by(induct rule:  bangRel.induct) (auto intro: BRBang BRPar BRRes)

lemma bangRelSymetric:
  fixes P   :: pi
  and   Q   :: pi
  and   Rel :: "(pi \<times> pi) set"

  assumes A:   "(P, Q) \<in> bangRel Rel"
  and     Sym: "\<And>P Q. (P, Q) \<in> Rel \<Longrightarrow> (Q, P) \<in> Rel"

  shows "(Q, P) \<in> bangRel Rel"
proof -
  from A show ?thesis
  proof(induct)
    fix P Q
    assume "(P, Q) \<in> Rel"
    hence "(Q, P) \<in> Rel" by(rule Sym)
    thus "(!Q, !P) \<in> bangRel Rel" by(rule BRBang)
  next
    fix P Q R T
    assume RRelT: "(R, T) \<in> Rel"
    assume IH: "(Q, P) \<in> bangRel Rel"
    from RRelT have "(T, R) \<in> Rel" by(rule Sym)
    thus "(T \<parallel> Q, R \<parallel> P) \<in> bangRel Rel" using IH by(rule BRPar)
  next
    fix P Q a
    assume "(Q, P) \<in> bangRel Rel"
    thus "(<\<nu>a>Q, <\<nu>a>P) \<in> bangRel Rel" by(rule BRRes)
  qed
qed

primrec resChain :: "name list \<Rightarrow> pi \<Rightarrow> pi" where
   base: "resChain [] P = P"
 | step: "resChain (x#xs) P = <\<nu>x>(resChain xs P)"

lemma resChainPerm[simp]:
  fixes perm :: "name prm"
  and   lst  :: "name list"
  and   P    :: pi

  shows "perm \<bullet> (resChain lst P) = resChain (perm \<bullet> lst) (perm \<bullet> P)"
by(induct_tac lst, auto)

lemma resChainFresh:
  fixes a   :: name
  and   lst :: "name list"
  and   P   :: pi

  assumes "a \<sharp> (lst, P)"

  shows "a \<sharp> (resChain lst P)"
using assms apply(induct_tac lst)
apply(simp add: fresh_prod)
by(simp add: fresh_prod name_fresh_abs)

end


theory nat_pow_one
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) y = y"
| "plus (S n) y = S (plus n y)"

fun mult :: "Nat => Nat => Nat" where
"mult (Z) y = Z"
| "mult (S n) y = plus y (mult n y)"

fun pow :: "Nat => Nat => Nat" where
"pow x (Z) = S Z"
| "pow x (S m) = mult x (pow x m)"

(*hipster plus mult pow *)

theorem x0 :
  "!! (x :: Nat) . (pow (S Z) x) = (S Z)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory simple_memory_machine
imports "branches/Morpheus/generalized_control_flow_graph" loc_can_do
begin

datatype 'val simp_mem_state = FreeSMM | UninitSMM | StoredSMM "'val"

datatype simp_mem_state_finite = FreeSMMf | UninitSMMf | StoredSMMf

type_synonym ('loc,'val) node = "'loc \<Rightarrow> 'val simp_mem_state"

type_synonym 'loc node_finite = "'loc \<Rightarrow> simp_mem_state_finite"

locale one_loc_locale =
  fixes loc :: "'loc"

declare[[show_types = false]]
declare[[show_sorts = false]]

locale simple_location_machine_one_loc_locale =
       one_loc_locale where loc = "loc :: 'loc" for loc

context simple_location_machine_one_loc_locale
begin
definition SMM_loc where
 "SMM_loc ::
   ('val simp_mem_state,('thread, 'loc,'val) access,'val simp_mem_state)
   generalized_control_flow_graph \<equiv>
 \<lparr>Instructions = (UNIV :: 'val simp_mem_state set),
  Directions = (UNIV :: ('thread, 'loc,'val) access set),
  edgeTyping =  (\<lambda> n. case n of FreeSMM \<Rightarrow>
                      {\<lambda> p. (case p of (Alloc t l) \<Rightarrow> (if l = loc then 1 else 0)
                          | _ \<Rightarrow> 0) }
                    | UninitSMM \<Rightarrow>
                      {\<lambda>p. case p of (Free t l) \<Rightarrow> (if l = loc then 1 else 0)
                          | (Write t l v) \<Rightarrow> (if l = loc then 1 else 0)
                          | _ \<Rightarrow> 0 }
                    | StoredSMM v \<Rightarrow>
                      {\<lambda>p. case p of (Free t l) \<Rightarrow> (if l = loc then 1 else 0)
                          | (Read t l v') \<Rightarrow> (if (l = loc) \<and> (v = v') then 1 else 0)
                          | (Write t l v') \<Rightarrow> (if l = loc then 1 else 0)
                          | (ARW t l v' v'') \<Rightarrow> (if l = loc then 1 else 0)
                          | _ \<Rightarrow> 0 }),
  Nodes = (UNIV :: 'val simp_mem_state set),
  Edges = (\<lambda> n. case n of FreeSMM \<Rightarrow>
                      {p. (case p of (Alloc t l,m) \<Rightarrow> ((m = UninitSMM) \<and> l = loc)
                          | _ \<Rightarrow> False) }
                    | UninitSMM \<Rightarrow>
                      {p. case p of (Free t l,m) \<Rightarrow> ((m = FreeSMM) \<and> l = loc)
                          | (Write t l v,m) \<Rightarrow> ((m = StoredSMM v) \<and> l = loc)
                          | _ \<Rightarrow> False }
                    | StoredSMM v \<Rightarrow>
                      {p. case p of (Free t l,m) \<Rightarrow> ((m = FreeSMM) \<and> l = loc)
                          | (Read t l v',m) \<Rightarrow> (v' = v \<and> m = n \<and> l = loc)
                          | (Write t l v',m) \<Rightarrow> ((m = StoredSMM v') \<and> l = loc)
                          | (ARW t l v' v'',m) \<Rightarrow> ((*(v' = v) \<and>*) (m = StoredSMM v'') \<and> l = loc)
                          | _ \<Rightarrow> False }),
  labeling = \<lambda> l. l
    \<rparr>"

lemma SMM_Loc_UnboundedGeneralizedControlFlowGraph:
"UnboundedGeneralizedControlFlowGraph (Instructions SMM_loc) (Directions SMM_loc)
     (edgeTyping SMM_loc) (Nodes SMM_loc) (Edges SMM_loc) (labeling SMM_loc)"
apply (auto simp add: SMM_loc_def UnboundedGeneralizedControlFlowGraph_def)
apply (case_tac n,auto)
apply (rule ext)
apply (case_tac d)
apply (simp_all)
apply (rule ext)
apply (case_tac d)
apply (simp_all)
apply (rule ext)
apply (case_tac d)
apply (auto)
done

interpretation UnboundedGeneralizedControlFlowGraph
 where Nodes = "Nodes SMM_loc"
 and Instructions = "Instructions SMM_loc"
 and Directions = "Directions SMM_loc"
 and Edges = "Edges SMM_loc"
 and edgeTyping = "edgeTyping SMM_loc"
 and labeling = "labeling SMM_loc"
by (rule SMM_Loc_UnboundedGeneralizedControlFlowGraph)

end
(*
locale simple_location_machine_one_loc_finite_locale =
        one_loc_locale where loc = "loc :: 'loc" for loc

context simple_location_machine_one_loc_finite_locale
begin
print_context
(* Why can't we do sublocale simple_location_machine_locale  in 2015 but can in 2016? *)
*)

definition SMM_loc_finite where
  "SMM_loc_finite ::
    (simp_mem_state_finite,('thread, 'loc,'val) access,simp_mem_state_finite)
    generalized_control_flow_graph \<equiv>
   \<lparr>Instructions = (UNIV :: simp_mem_state_finite set),
  Directions = (UNIV :: ('thread, 'loc,'val) access set),
  edgeTyping =  (\<lambda> n. case n of FreeSMMf \<Rightarrow>
                      {\<lambda> p. (case p of (Alloc t l) \<Rightarrow> 1
                          | _ \<Rightarrow> 0) }
                    | UninitSMMf \<Rightarrow>
                      {\<lambda>p. case p of (Free t l) \<Rightarrow> 1
                          | (Write t l v) \<Rightarrow> 1
                          | _ \<Rightarrow> 0 }
                    | StoredSMMf \<Rightarrow>
                      {\<lambda>p. case p of (Free t l) \<Rightarrow> 1
                          | (Read t l v') \<Rightarrow> 1
                          | (Write t l v') \<Rightarrow> 1
                          | (ARW t l v' v'') \<Rightarrow> 1
                          | _ \<Rightarrow> 0 }),
  Nodes = (UNIV :: simp_mem_state_finite set),
  Edges = (\<lambda> n. case n of FreeSMMf \<Rightarrow>
                      {p. (case p of (Alloc t l,m) \<Rightarrow> (m = UninitSMMf)
                          | _ \<Rightarrow> False) }
                    | UninitSMMf \<Rightarrow>
                      {p. case p of (Free t l,m) \<Rightarrow> (m = FreeSMMf)
                          | (Write t l v,m) \<Rightarrow> (m = StoredSMMf )
                          | _ \<Rightarrow> False }
                    | StoredSMMf \<Rightarrow>
                      {p. case p of (Free t l,m) \<Rightarrow> (m = FreeSMMf)
                          | (Read t l v',m) \<Rightarrow> (m = n)
                          | (Write t l v',m) \<Rightarrow> (m = StoredSMMf)
                          | (ARW t l v' v'', m) \<Rightarrow> (m = StoredSMMf)
                          | _ \<Rightarrow> False }),
  labeling = \<lambda> l. l
    \<rparr>"

lemma SMM_loc_finite_UnboundedGeneralizedControlFlowGraph:
"UnboundedGeneralizedControlFlowGraph (Instructions SMM_loc_finite)
     (Directions SMM_loc_finite) (edgeTyping SMM_loc_finite) (Nodes SMM_loc_finite)
     (Edges SMM_loc_finite) (labeling SMM_loc_finite)"
apply (auto simp add: SMM_loc_finite_def UnboundedGeneralizedControlFlowGraph_def)
apply (case_tac n,auto)
apply (rule ext)
apply (case_tac d)
apply (simp_all)
apply (rule ext)
apply (case_tac d)
apply (simp_all)
apply (rule ext)
apply (case_tac d)
apply (auto)
done

(*  I need to learn what the limitations on multiple interpretations are. --ELG *)
interpretation UnboundedGeneralizedControlFlowGraph
 where Nodes = "Nodes SMM_loc_finite"
 and Instructions = "Instructions SMM_loc_finite"
 and Directions = "Directions SMM_loc_finite"
 and Edges = "Edges SMM_loc_finite"
 and edgeTyping = "edgeTyping SMM_loc_finite"
 and labeling = "labeling SMM_loc_finite"
apply  (rule SMM_loc_finite_UnboundedGeneralizedControlFlowGraph)
done

term SMM_loc_finite
term "get_loc (a::('thread, 'loc,'val) access)"
(*
term "more_update SMM_loc_finite"

term  "generalized_control_flow_graph.more_update \<lparr> Participants = (UNIV :: 'loc set),
Interpretation =
  (\<lambda> ((n::'loc \<Rightarrow> simp_mem_state_finite),(s::'loc \<Rightarrow> 'val option)).
   \<lambda> (a::('thread, 'loc,'val) access).
   \<lambda> ((m::'loc \<Rightarrow> simp_mem_state_finite),(t::'loc \<Rightarrow> 'val option)).
     (\<forall> (thisloc::'loc).
               (case n thisloc of FreeSMMf \<Rightarrow>
                 (case (a::('thread, 'loc,'val) access) of Alloc th loc \<Rightarrow>
                     ((loc = thisloc) \<and> (m loc = UninitSMMf) \<and> (t loc = None)) \<or>
                     ((loc \<noteq> thisloc) \<and> (m loc = n loc) \<and> (t loc = s loc))
                   | _ \<Rightarrow> False)
                 | UninitSMMf \<Rightarrow>
                  (case (a::('thread, 'loc,'val) access) of Free th loc \<Rightarrow>
                     ((loc = thisloc) \<and> (m loc = FreeSMMf) \<and> (t loc = None)) \<or>
                     ((loc \<noteq> thisloc) \<and> (m loc = n loc) \<and> (t loc = s loc))
                   | Write th loc v \<Rightarrow>
                     ((loc = thisloc) \<and> (m loc = StoredSMMf) \<and> (t loc = Some v)) \<or>
                     ((loc \<noteq> thisloc) \<and> (m loc = n loc) \<and> (t loc = s loc))
                   | _ \<Rightarrow> False)
                 | StoredSMMf \<Rightarrow>
                  (case (a::('thread, 'loc,'val) access) of Free th loc \<Rightarrow>
                     ((loc = thisloc) \<and> (m loc = FreeSMMf) \<and> (t loc = None)) \<or>
                     ((loc \<noteq> thisloc) \<and> (m loc = n loc) \<and> (t loc = s loc))
                   | Write th loc v \<Rightarrow>
                     ((loc = thisloc) \<and> (m loc = StoredSMMf) \<and> (t loc = Some v)) \<or>
                     ((loc \<noteq> thisloc) \<and> (m loc = n loc) \<and> (t loc = s loc))
                   | Read th loc v \<Rightarrow>
                     ((loc = thisloc) \<and> (m loc = StoredSMMf) \<and>
                                        (s loc = Some v) \<and> (t loc = Some v)) \<or>
                     ((loc \<noteq> thisloc) \<and> (m loc = n loc) \<and> (t loc = s loc))
                   | _ \<Rightarrow> False)))) \<rparr>"

term "SMM_loc_finite \<lparr> Participants = (UNIV :: 'loc set),
Interpretation =
  (\<lambda> ((n::'loc \<Rightarrow> simp_mem_state_finite),(s::'loc \<Rightarrow> 'val option)).
   \<lambda> (a::('thread, 'loc,'val) access).
   \<lambda> ((m::'loc \<Rightarrow> simp_mem_state_finite),(t::'loc \<Rightarrow> 'val option)).
     (\<forall> (thisloc::'loc).
               (case n thisloc of FreeSMMf \<Rightarrow>
                 (case (a::('thread, 'loc,'val) access) of Alloc th loc \<Rightarrow>
                     ((loc = thisloc) \<and> (m loc = UninitSMMf) \<and> (t loc = None)) \<or>
                     ((loc \<noteq> thisloc) \<and> (m loc = n loc) \<and> (t loc = s loc))
                   | _ \<Rightarrow> False)
                 | UninitSMMf \<Rightarrow>
                  (case (a::('thread, 'loc,'val) access) of Free th loc \<Rightarrow>
                     ((loc = thisloc) \<and> (m loc = FreeSMMf) \<and> (t loc = None)) \<or>
                     ((loc \<noteq> thisloc) \<and> (m loc = n loc) \<and> (t loc = s loc))
                   | Write th loc v \<Rightarrow>
                     ((loc = thisloc) \<and> (m loc = StoredSMMf) \<and> (t loc = Some v)) \<or>
                     ((loc \<noteq> thisloc) \<and> (m loc = n loc) \<and> (t loc = s loc))
                   | _ \<Rightarrow> False)
                 | StoredSMMf \<Rightarrow>
                  (case (a::('thread, 'loc,'val) access) of Free th loc \<Rightarrow>
                     ((loc = thisloc) \<and> (m loc = FreeSMMf) \<and> (t loc = None)) \<or>
                     ((loc \<noteq> thisloc) \<and> (m loc = n loc) \<and> (t loc = s loc))
                   | Write th loc v \<Rightarrow>
                     ((loc = thisloc) \<and> (m loc = StoredSMMf) \<and> (t loc = Some v)) \<or>
                     ((loc \<noteq> thisloc) \<and> (m loc = n loc) \<and> (t loc = s loc))
                   | Read th loc v \<Rightarrow>
                     ((loc = thisloc) \<and> (m loc = StoredSMMf) \<and>
                                        (s loc = Some v) \<and> (t loc = Some v)) \<or>
                     ((loc \<noteq> thisloc) \<and> (m loc = n loc) \<and> (t loc = s loc))
                   | _ \<Rightarrow> False)))) \<rparr>"
*)
definition SMM_loc_finite_interp where
(*
'instr = simp_mem_state_finite
'dir = ('thread, 'loc,'val option) access
'node = simp_mem_state_finite
'participant = 'loc
'state = 'loc \<Rightarrow> 'val option
*)
  "SMM_loc_finite_interp  ::
    (simp_mem_state_finite,('thread, 'loc,'val) access,simp_mem_state_finite,'loc,'loc \<Rightarrow> 'val option)
    generalized_control_flow_graph_interpretation \<equiv>
\<lparr> Instructions = Instructions (SMM_loc_finite :: (simp_mem_state_finite,('thread, 'loc,'val) access,simp_mem_state_finite)
    generalized_control_flow_graph),
Directions = Directions (SMM_loc_finite :: (simp_mem_state_finite,('thread, 'loc,'val) access,simp_mem_state_finite)
    generalized_control_flow_graph),
edgeTyping = edgeTyping (SMM_loc_finite :: (simp_mem_state_finite,('thread, 'loc,'val) access,simp_mem_state_finite)
    generalized_control_flow_graph),
Nodes = Nodes (SMM_loc_finite :: (simp_mem_state_finite,('thread, 'loc,'val) access,simp_mem_state_finite)
    generalized_control_flow_graph),
Edges = Edges (SMM_loc_finite :: (simp_mem_state_finite,('thread, 'loc,'val) access,simp_mem_state_finite)
    generalized_control_flow_graph),
labeling = labeling (SMM_loc_finite :: (simp_mem_state_finite,('thread, 'loc,'val) access,simp_mem_state_finite)
    generalized_control_flow_graph),
Participants = (UNIV :: 'loc set),
Interpretation =
  (\<lambda> ((n::'loc \<Rightarrow> simp_mem_state_finite),(s::'loc \<Rightarrow> 'val option)).
   \<lambda> (a::('thread, 'loc,'val) access).
   \<lambda> ((m::'loc \<Rightarrow> simp_mem_state_finite),(t::'loc \<Rightarrow> 'val option)).
     case a of Alloc th loc \<Rightarrow>
         ((\<forall> otherloc. (otherloc \<noteq> loc) \<longrightarrow>
             ((n otherloc = m otherloc) \<and> (s otherloc = t otherloc))) \<and>
          (n loc = FreeSMMf) \<and> (m loc = UninitSMMf) \<and> (t loc = None))
      | Free th loc \<Rightarrow>
        ((\<forall> otherloc. (otherloc \<noteq> loc) \<longrightarrow>
            ((n otherloc = m otherloc) \<and> (s otherloc = t otherloc))) \<and>
         ((n loc = UninitSMMf) \<or> (n loc = StoredSMMf)) \<and> (m loc = FreeSMMf) \<and>
         (t loc = None))
      | Read th loc v \<Rightarrow>
        ((\<forall> otherloc. (otherloc \<noteq> loc) \<longrightarrow>
            ((n otherloc = m otherloc) \<and> (s otherloc = t otherloc))) \<and>
         (n loc = StoredSMMf) \<and> (m loc = StoredSMMf) \<and>
         (s loc = Some v) \<and> (t loc = Some v))
      | Write th loc v \<Rightarrow>
        ((\<forall> otherloc. (otherloc \<noteq> loc) \<longrightarrow>
            ((n otherloc = m otherloc) \<and> (s otherloc = t otherloc))) \<and>
         ((n loc = StoredSMMf) \<or> (n loc = UninitSMMf)) \<and> (m loc = StoredSMMf) \<and>
         (t loc = Some v))
      | ARW th loc v v' \<Rightarrow>
        ((\<forall> otherloc. (otherloc \<noteq> loc) \<longrightarrow>
            ((n otherloc = m otherloc) \<and> (s otherloc = t otherloc))) \<and>
         (n loc = StoredSMMf) \<and> (m loc = StoredSMMf) \<and>
         (s loc = Some v) \<and> (t loc = Some v'))
(*
     (\<forall> (thisloc::'loc).
               (case n thisloc of FreeSMMf \<Rightarrow>
                 (case (a::('thread, 'loc,'val) access) of Alloc th loc \<Rightarrow>
                     ((loc = thisloc) \<and> (m loc = UninitSMMf) \<and> (t loc = None)) \<or>
                     ((loc \<noteq> thisloc) \<and> (m loc = n loc) \<and> (t loc = s loc))
                   | _ \<Rightarrow> False)
                 | UninitSMMf \<Rightarrow>
                  (case (a::('thread, 'loc,'val) access) of Free th loc \<Rightarrow>
                     ((loc = thisloc) \<and> (m loc = FreeSMMf) \<and> (t loc = None)) \<or>
                     ((loc \<noteq> thisloc) \<and> (m loc = n loc) \<and> (t loc = s loc))
                   | Write th loc v \<Rightarrow>
                     ((loc = thisloc) \<and> (m loc = StoredSMMf) \<and> (t loc = Some v)) \<or>
                     ((loc \<noteq> thisloc) \<and> (m loc = n loc) \<and> (t loc = s loc))
                   | _ \<Rightarrow> False)
                 | StoredSMMf \<Rightarrow>
                  (case (a::('thread, 'loc,'val) access) of Free th loc \<Rightarrow>
                     ((loc = thisloc) \<and> (m loc = FreeSMMf) \<and> (t loc = None)) \<or>
                     ((loc \<noteq> thisloc) \<and> (m loc = n loc) \<and> (t loc = s loc))
                   | Write th loc v \<Rightarrow>
                     ((loc = thisloc) \<and> (m loc = StoredSMMf) \<and> (t loc = Some v)) \<or>
                     ((loc \<noteq> thisloc) \<and> (m loc = n loc) \<and> (t loc = s loc))
                   | Read th loc v \<Rightarrow>
                     ((loc = thisloc) \<and> (m loc = StoredSMMf) \<and>
                                        (s loc = Some v) \<and> (t loc = Some v)) \<or>
                     ((loc \<noteq> thisloc) \<and> (m loc = n loc) \<and> (t loc = s loc))
                   | _ \<Rightarrow> False)))
*)
)
                \<rparr>"

lemma SMM_loc_finite_interp_UnboundedGeneralizedControlFlowGraphInterpretation:
"UnboundedGeneralizedControlFlowGraphInterpretation (Instructions SMM_loc_finite_interp)
     (Directions SMM_loc_finite_interp) (edgeTyping SMM_loc_finite_interp)
     (Nodes SMM_loc_finite_interp) (Edges SMM_loc_finite_interp)
     (labeling SMM_loc_finite_interp) (Participants SMM_loc_finite_interp)
     (Interpretation SMM_loc_finite_interp)"
apply (simp add: UnboundedGeneralizedControlFlowGraphInterpretation_def
                 SMM_loc_finite_interp_def)
apply (rule conjI)
 apply (rule SMM_loc_finite_UnboundedGeneralizedControlFlowGraph)
apply (simp add: UnboundedGeneralizedControlFlowGraphInterpretation_axioms_def
                      SMM_loc_finite_def)
apply (rule conjI)
 apply clarify
 apply (case_tac "d", simp_all)
apply clarsimp
apply (case_tac "d", simp_all)
    apply (case_tac "n p", simp_all)
      apply (case_tac "p = x12", simp_all)
     apply (case_tac "p = x12", simp_all)
    apply (case_tac "p = x12", simp_all)
   apply (case_tac "n p", simp_all)
     apply (case_tac "p = x22", simp_all)
    apply (case_tac "p = x22", simp_all)
   apply (case_tac "p = x22", simp_all)
  apply (case_tac "n p", simp_all)
    apply (case_tac "p = x32", simp_all)
   apply (case_tac "p = x32", simp_all)
  apply (case_tac "p = x32", simp_all)
 apply (case_tac "n p", simp_all)
    apply (case_tac "p = x42", simp_all)
   apply (case_tac "p = x42", simp_all)
  apply (case_tac "p = x42", simp_all)
apply (case_tac "n p", simp_all)
  apply (case_tac "p = x52", simp_all)
 apply (case_tac "p = x52", simp_all)
apply (case_tac "p = x52", simp_all)
done

interpretation UnboundedGeneralizedControlFlowGraphInterpretation
 where Nodes = "Nodes SMM_loc_finite_interp"
 and Instructions = "Instructions SMM_loc_finite_interp"
 and Directions = "Directions SMM_loc_finite_interp"
 and Edges = "Edges SMM_loc_finite_interp"
 and edgeTyping = "edgeTyping SMM_loc_finite_interp"
 and labeling = "labeling SMM_loc_finite_interp"
 and Participants = "Participants SMM_loc_finite_interp"
 and Interpretation = "Interpretation SMM_loc_finite_interp"
apply (rule SMM_loc_finite_interp_UnboundedGeneralizedControlFlowGraphInterpretation)
done

(* end (* context *) *)

(*
definition SMM_locs_finite :: "('loc \<Rightarrow> simp_mem_state_finite,('thread, 'loc,'val) access,
                         'loc \<Rightarrow> simp_mem_state_finite) generalized_control_flow_graph" where
 "SMM_locs_finite \<equiv> \<lparr> Instructions = (UNIV :: 'loc node_finite set),
  Directions = (UNIV :: ('thread, 'loc,'val) access set),
  edgeTyping =
 (\<lambda> i:: ('loc \<Rightarrow> simp_mem_state_finite).
   (\<Union>l\<in>UNIV. (edgeTyping((simple_location_machine_one_loc_finite_locale.SMM_loc_finite l)) (i l)))),
  Nodes = (UNIV :: 'loc node_finite set),
  Edges = ((\<lambda> n. \<Union> loc\<in>UNIV. (\<lambda> (a,m). (a,(\<lambda> l. (if l = loc then m else n l)))) `
           (Edges(simple_location_machine_one_loc_finite_locale.SMM_loc_finite loc) (n loc)))
          ::('loc \<Rightarrow> simp_mem_state_finite) \<Rightarrow>
           (('thread, 'loc, 'val) access \<times> ('loc \<Rightarrow> simp_mem_state_finite)) set),
  labeling = \<lambda> l. l
    \<rparr>"

interpretation UnboundedGeneralizedControlFlowGraph
 where Nodes = "Nodes SMM_locs_finite"
 and Instructions = "Instructions SMM_locs_finite"
 and Directions = "Directions SMM_locs_finite"
 and Edges = "Edges SMM_locs_finite"
 and edgeTyping = "edgeTyping SMM_locs_finite"
 and labeling = "labeling SMM_locs_finite"
apply (unfold_locales)
apply (clarsimp  simp add: SMM_locs_finite_def)
apply (clarsimp  simp add: SMM_locs_finite_def)
prefer 2
apply (clarsimp  simp add: SMM_locs_finite_def)
apply (simp only: SMM_locs_finite_def)
apply (subgoal_tac "(\<lambda>d. card {m \<in> UNIV.
                    (d, m)
                    \<in> (\<Union>loc. (\<lambda>(a, m). (a, \<lambda>l. if l = loc then m else n l)) `
                       Edges (simple_location_machine_one_loc_finite_locale.SMM_loc_finite loc) (n loc))
                        })
         \<in> (\<lambda>i. \<Union>l. edgeTyping (simple_location_machine_one_loc_finite_locale.SMM_loc_finite l) (i l)) n")
apply simp

apply simp

(* New, from Elsa *)
apply (simp only: simple_location_machine_one_loc_finite_locale.SMM_loc_finite_def)
oops

definition SMM_locs :: "('loc \<Rightarrow> 'val simp_mem_state,('thread, 'loc,'val) access,
                         'loc \<Rightarrow> 'val simp_mem_state) generalized_control_flow_graph" where
 "SMM_locs \<equiv> \<lparr> Instructions = (UNIV :: ('loc,'val) node set),
  Directions = (UNIV :: ('thread, 'loc,'val) access set),
  edgeTyping =  (\<lambda> i:: ('loc \<Rightarrow> 'val simp_mem_state).
   (\<Union>l\<in>UNIV. (edgeTyping((simple_location_machine_one_loc_locale.SMM_loc l)) (i l))))
(* (\<lambda> i:: ('loc \<Rightarrow> 'val simp_mem_state).{dn.
       (\<exists> loc::'loc. (dn::(('thread, 'loc, 'val) access \<Rightarrow> nat)) \<in>
          (edgeTyping((simple_location_machine_one_loc_locale.SMM_loc loc)*),
  (*
  case a of acc\<Rightarrow>num | (\<forall> loc. (if loc = get_loc(acc) then a
    \<in> edgeTyping(SMM_loc loc) (n loc) else m loc = n loc))})
    *)
  Nodes = (UNIV :: ('loc,'val) node set),
  Edges = ((\<lambda> n. \<Union> loc\<in>UNIV. (\<lambda> (a,m). (a,(\<lambda> l. (if l = loc then m else n l)))) `
           (Edges(simple_location_machine_one_loc_locale.SMM_loc loc) (n loc)))
          ::('loc \<Rightarrow> 'val simp_mem_state) \<Rightarrow>
           (('thread, 'loc, 'val) access \<times> ('loc \<Rightarrow>'val simp_mem_state)) set
(* {(a,m) . (\<exists> loc . ((a,m loc) \<in>
    Edges(simple_location_machine_one_loc_locale.SMM_loc loc) (n loc)) \<and>
    (\<forall> loc' . (loc' \<noteq> loc) \<longrightarrow> (m loc' = n loc')))}
*)
          ),
  labeling = \<lambda> l. l
    \<rparr>"

interpretation UnboundedGeneralizedControlFlowGraph
 where Nodes = "Nodes SMM_locs"
 and Instructions = "Instructions SMM_locs"
 and Directions = "Directions SMM_locs"
 and Edges = "Edges SMM_locs"
 and edgeTyping = "edgeTyping SMM_locs"
 and labeling = "labeling SMM_locs"
apply (unfold_locales)
apply (clarsimp  simp add: SMM_locs_def)
apply (clarsimp  simp add: SMM_locs_def)
prefer 2
apply (clarsimp  simp add: SMM_locs_def)
apply (simp only: SMM_locs_def)
apply (subgoal_tac "(\<lambda>d. card {m \<in> UNIV.
                    (d, m)
                    \<in> (\<Union>loc. (\<lambda>(a, m). (a, \<lambda>l. if l = loc then m else n l)) `
                       Edges (simple_location_machine_one_loc_locale.SMM_loc loc) (n loc))
                        })
         \<in> (\<lambda>i. \<Union>l. edgeTyping (simple_location_machine_one_loc_locale.SMM_loc l) (i l)) n")
apply simp

apply simp

(* New, from Elsa *)
apply (simp only: simple_location_machine_one_loc_locale.SMM_loc_def)
oops
*)
term "Trsys"

term "Edges (simple_location_machine_one_loc_locale.SMM_loc loc)"
term "(Edges SMM_loc_finite_interp)"

lemma "\<exists>s. rtrancl3p (\<lambda>n d m. (d, m) \<in> Edges SMM_loc_finite n) FreeSMMf [Alloc t l] s"
apply (rule_tac ?r = "(\<lambda>n d m. (d, m) \<in> Edges SMM_loc_finite n)"
             and ?x1.0 = "FreeSMMf" in rtrancl3p.induct)

apply (rule_tac x = "" in exI)
thm exI
sorry
definition l_can_do_SMM where
  "l_can_do_SMM l a =
   (\<exists> s. (*Trsys*) Auxiliary.rtrancl3p
         (\<lambda> (n::simp_mem_state_finite). \<lambda> d. \<lambda> m. ((d::('thread, 'loc,'val) access),m) \<in>
          (Edges SMM_loc_finite_interp) n)
         FreeSMMf
         (List.rev (a#l)) s)"

interpretation loc_can_do where
  l_can_do = "l_can_do_SMM"
apply (unfold_locales)
apply (simp add: l_can_do_SMM_def SMM_loc_finite_interp_def)
apply (erule rtrancl3p.induct)

prefer 2
apply (simp add: l_can_do_SMM_def)
oops

(*
interpretation loc_can_do where
  l_can_do = "l_can_do_SMM"
proof
 fix t::"'thread" and l::"'loc"
 show "l_can_do_SMM [] (Alloc t l)"
 proof (simp add: l_can_do_SMM_def Edges_def SMM_loc_def del: List.append.simps, simp)
  show " \<exists>s. rtrancl3p
         (\<lambda>n d m.
             (d, m)
             \<in> (case n of
                 FreeSMM \<Rightarrow>
                   {p. case p of (Alloc t l, m) \<Rightarrow> m = UninitSMM(*  \<and> l = loc *) | (_, m) \<Rightarrow> False}
                 | UninitSMM \<Rightarrow>
                     {p. case p of (Write t l v, m) \<Rightarrow> m = StoredSMM v(*  \<and> l = loc *)
                         | (Free t l, m) \<Rightarrow> m = FreeSMM(*  \<and> l = loc *) | (_, m) \<Rightarrow> False}
                 | StoredSMM v \<Rightarrow>
                     {p. case p of (Read t l v', m) \<Rightarrow> v' = v \<and> m = n(*  \<and> l = loc *)
                         | (Write t l v', m) \<Rightarrow> m = StoredSMM v'(*  \<and> l = loc *)
                         | (Free t l, m) \<Rightarrow> m = FreeSMM(*  \<and> l = loc *) | (_, m) \<Rightarrow> False}))
         FreeSMM ([] @ [Alloc t l]) s"
  proof (rule_tac x="UninitSMM" in exI)
  show "rtrancl3p
     (\<lambda>n d m.
         (d, m)
         \<in> (case n of
             FreeSMM \<Rightarrow>
               {p. case p of (Alloc t l, m) \<Rightarrow> m = UninitSMM(*  \<and> l = loc *) | (_, m) \<Rightarrow> False}
             | UninitSMM \<Rightarrow>
                 {p. case p of (Write t l v, m) \<Rightarrow> m = StoredSMM v(*  \<and> l = loc *)
                     | (Free t l, m) \<Rightarrow> m = FreeSMM(*  \<and> l = loc *) | (_, m) \<Rightarrow> False}
             | StoredSMM v \<Rightarrow>
                 {p. case p of (Read t l v', m) \<Rightarrow> v' = v \<and> m = n(*  \<and> l = loc *)
                     | (Write t l v', m) \<Rightarrow> m = StoredSMM v'(*  \<and> l = loc *)
                     | (Free t l, m) \<Rightarrow> m = FreeSMM(*  \<and> l = loc *) | (_, m) \<Rightarrow> False}))
     FreeSMM ([] @ [Alloc t l]) UninitSMM "
  proof (rule_tac a' = "FreeSMM" in rtrancl3p_step)
   show
   "rtrancl3p
     (\<lambda>n d m.
         (d, m)
         \<in> (case n of
             FreeSMM \<Rightarrow>
               {p. case p of (Alloc t l, m) \<Rightarrow> m = UninitSMM(*  \<and> l = loc *) | (_, m) \<Rightarrow> False}
             | UninitSMM \<Rightarrow>
                 {p. case p of (Write t l v, m) \<Rightarrow> m = StoredSMM v(*  \<and> l = loc *)
                     | (Free t l, m) \<Rightarrow> m = FreeSMM(*  \<and> l = loc *) | (_, m) \<Rightarrow> False}
             | StoredSMM v \<Rightarrow>
                 {p. case p of (Read t l v', m) \<Rightarrow> v' = v \<and> m = n(*  \<and> l = loc *)
                     | (Write t l v', m) \<Rightarrow> m = StoredSMM v'(*  \<and> l = loc *)
                     | (Free t l, m) \<Rightarrow> m = FreeSMM(*  \<and> l = loc *) | (_, m) \<Rightarrow> False}))
     FreeSMM [] FreeSMM"
     by simp
     next
     show "(Alloc t l, UninitSMM)
    \<in> (case FreeSMM of
        FreeSMM \<Rightarrow> {p. case p of (Alloc t l, m) \<Rightarrow> m = UninitSMM(*  \<and> l = loc *) | (_, m) \<Rightarrow> False}
        | UninitSMM \<Rightarrow>
            {p. case p of (Write t l v, m) \<Rightarrow> m = StoredSMM v(*  \<and> l = loc *)
                | (Free t l, m) \<Rightarrow> m = FreeSMM(*  \<and> l = loc *) | (_, m) \<Rightarrow> False}
        | StoredSMM v \<Rightarrow>
            {p. case p of (Read t l v', m) \<Rightarrow> v' = v \<and> m = FreeSMM(*  \<and> l = loc *)
                | (Write t l v', m) \<Rightarrow> m = StoredSMM v'(*  \<and> l = loc *)
                | (Free t l, m) \<Rightarrow> m = FreeSMM(*  \<and> l = loc *) | (_, m) \<Rightarrow> False})"
     proof simp

     *)
end


theory Bounded_Copy_Convert
  imports Main HOL.Finite_Set
          "../Util/Enum_Nat" "../Core/Update" "../Single_Use/Single_Use" "../Decomposition/Decompose_Update"
          "../Composition/Convert_Monoid_SST" "../Type/Monoid_SST_Type"
begin

definition valid_vars :: "'k::enum boundedness \<Rightarrow> ('y \<times> nat option) set"  where
  "valid_vars B = (UNIV :: 'y set) \<times> (insert None (Some ` {k. k < length (Enum.enum :: 'k list)}))"

lemma valid_vars_eq_range:
  "(valid_vars B :: ('y \<times> nat option) set) = range (to_nat B)"
proof
  show "(valid_vars B :: ('y \<times> nat option) set) \<subseteq> range (to_nat B)" proof (rule subsetI, rule range_eqI)
    fix yk
    assume *: "yk \<in> (valid_vars B :: ('y \<times> nat option) set)"
    then show "yk = to_nat B (to_enum B yk)"
      by (cases yk rule: index_cases, simp_all add: valid_vars_def inj_image_mem_iff nat_enum_iso)
  qed
next
  show "range (to_nat B) \<subseteq> (valid_vars B :: ('y \<times> nat option) set)"
  proof
    fix yk :: "'y \<times> nat option"
    assume "yk \<in> range (to_nat B)"
    then obtain xk where "to_nat B xk = yk" by blast
    then show "yk \<in> valid_vars B" unfolding valid_vars_def by (cases xk rule: index_cases, auto simp add: enum_nat_less)
  qed
qed

lemma valid_vars_finite[simp]:
  "finite (valid_vars B :: ('y::finite \<times> nat option) set)"
  unfolding valid_vars_def by simp

lemma valid_vars_None[simp]:
  "(y::'y::enum, None) \<in> valid_vars (B :: 'k::enum boundedness)"
  unfolding valid_vars_def by simp

lemma valid_vars_Some[simp]:
  fixes B :: "'k::enum boundedness"
  assumes "boundedness B K"
  assumes "k < K"
  shows "(y::'y::enum, Some k) \<in> valid_vars B"
  using assms unfolding boundedness_def valid_vars_def by simp

lemma distinct_count_list_le_1:
  assumes "distinct xs"
  shows "count_list xs a \<le> Suc 0"
using assms proof (induct xs)
  case Nil
  then show ?case by simp
next
  case (Cons x xs)
  then show ?case by (cases "x = a", simp_all)
qed

definition update_index_vars where
  "update_index_vars m = concat (map (\<lambda>y. valuate (synthesize_shuffle_nat (\<pi>\<^sub>1 m) y)) Enum.enum)"

lemma update_index_vars_set:
  "set (update_index_vars m) = (\<Union>y\<in>UNIV. set (valuate (synthesize_shuffle_nat (\<pi>\<^sub>1 m) y)))"
  unfolding update_index_vars_def
  by (simp add: enum_UNIV)

lemma sum_count_list_concat_map:
  assumes "distinct xs"
  shows "(\<Sum>x\<in>set xs. count_list (f x) a) = count_list (concat (map f xs)) a"
  using assms by (induct xs, simp_all)

(* disjointness BEGIN *)

lemma distinct_post_index_vars:
  "distinct (valuate (give_index_row s ys xs))"
proof (induct xs)
  case Nil
  then show ?case by simp
next
  case (Cons x xs)
  then show ?case proof (auto)
    assume "(x, Some (calc_index s ys xs x)) \<in> set (valuate (give_index_row s ys xs))"
    then have "calc_index s ys xs x < calc_index s ys xs x"
      by (rule give_index_row_position_lt)
    then show False by simp
  qed
qed

lemma post_index_vars_seek_contr:
  assumes "y0 \<in> set ys"
  assumes "(x0, Some k0) \<in> set (valuate (give_index_row s (seek y0 ys) (s y0)))"
  assumes "(x0, Some k0) \<in> set (valuate (give_index_row s ys (s y1)))"
  shows "False"
proof -
  have "k0 < calc_index s (seek y0 ys) (s y0) x0"
    using assms(2) by (rule give_index_row_position_lt)
  also have "... \<le> calc_index_rows s ys x0"
    using assms(1) by (rule calc_index_rows_seek)
  finally have "k0 < calc_index_rows s ys x0" .
  also have "k0 \<ge> calc_index_rows s ys x0"
    using assms(3) by (rule give_index_row_position_ge)
  finally show False by simp
qed

lemma seek_twice:
  assumes "y0 \<noteq> y1"
  shows "seek y0 (seek y1 ys) = seek y0 ys
       \<or> seek y1 (seek y0 ys) = seek y1 ys"
  using assms by (induct ys, simp_all)

lemma seek_length_le:
  "length (seek y ys) \<le> length ys"
  by (induct ys, auto)

lemma seek_in_neq:
  assumes "y2 \<in> set ys"
  shows "seek y1 (seek y2 ys) \<noteq> ys"
proof -
  have "length (seek y1 (seek y2 ys)) \<le> length (seek y2 ys)"
    by (simp add: seek_length_le)
  also have "... < length ys" using assms
    by (induct ys, auto)
  finally show ?thesis by auto
qed

lemma post_index_vars_not_in_two_rows_aux:
  assumes neq: "y1 \<noteq> y2"
  assumes y1: "y1 \<in> set ys"
  assumes y2: "y2 \<in> set ys"
  assumes in1: "(x0, Some k0) \<in> set (valuate (give_index_row s (seek y1 ys) (s y1)))"
  assumes in2: "(x0, Some k0) \<in> set (valuate (give_index_row s (seek y2 ys) (s y2)))"
  assumes *: "seek y1 (seek y2 ys) = seek y1 ys"
  shows False
proof -
  have 1: "(x0, Some k0) \<in> set (valuate (give_index_row s (seek y1 (seek y2 ys)) (s y1)))"
    using in1 * by simp
  have in_y1: "y1 \<in> set (seek y2 ys)" using neq y1 y2 * proof (induct ys)
    case Nil
    then show ?case by simp
  next
    case (Cons a ys)
    then show ?case by (cases "a = y1"; cases "a = y2", simp_all add: seek_in_neq)
  qed
  show False using post_index_vars_seek_contr in_y1 1 in2 by fast
qed

lemma post_index_vars_not_in_two_rows:
  assumes neq: "y1 \<noteq> y2"
  assumes y1: "y1 \<in> set ys"
  assumes y2: "y2 \<in> set ys"
  assumes in1: "(x0, Some k0) \<in> set (valuate (give_index_row s (seek y1 ys) (s y1)))"
  assumes in2: "(x0, Some k0) \<in> set (valuate (give_index_row s (seek y2 ys) (s y2)))"
  shows False
  using seek_twice[OF neq] proof
  assume *: "seek y1 (seek y2 ys) = seek y1 ys"
  show False using post_index_vars_not_in_two_rows_aux[OF assms *] by simp
next
  assume *: "seek y2 (seek y1 ys) = seek y2 ys"
  show False using post_index_vars_not_in_two_rows_aux[OF neq[symmetric] y2 y1 in2 in1 *] by simp
qed

lemma synthesize_shuffle_nat_not_contain_two_rows:
  assumes neq: "y0 \<noteq> y1"
  assumes "(x0, k0) \<in> set (valuate (synthesize_shuffle_nat s y0))"
  assumes "(x0, k0) \<in> set (valuate (synthesize_shuffle_nat s y1))"
  shows False
proof (cases k0)
  case None
  then show ?thesis using assms
    by (simp add: synthesize_shuffle_nat_def post_index_vars_does_not_contain_None)
next
  case (Some k)
  have y0: "y0 \<in> set Enum.enum" by (simp add: enum_UNIV)
  have y1: "y1 \<in> set Enum.enum" by (simp add: enum_UNIV)
  have in1: "(x0, Some k) \<in> set (valuate (give_index_row s (seek y0 Enum.enum) (s y0)))" using assms by (simp add: synthesize_shuffle_nat_def Some)
  have in2: "(x0, Some k) \<in> set (valuate (give_index_row s (seek y1 Enum.enum) (s y1)))" using assms by (simp add: synthesize_shuffle_nat_def Some)
  show ?thesis using post_index_vars_not_in_two_rows[OF neq y0 y1 in1 in2] by simp
qed

lemma distinct_synthesize_shuffle_nat:
  fixes m :: "('y::enum, 'b) update"
  fixes B :: "'k::enum boundedness"
  assumes "distinct ys"
  shows "distinct (concat (map (\<lambda>y. valuate (synthesize_shuffle_nat s y)) ys))"
  using assms proof (induct ys)
  case Nil
  then show ?case by simp
next
  case (Cons y0 ys)
  have y_notin_ys: "y0 \<notin> set ys" using Cons.prems by simp
  have distinct_ys: "distinct ys" using Cons.prems by simp
  then have distinct_rest: "distinct (concat (map (\<lambda>y. valuate (synthesize_shuffle_nat s y)) ys))"
    using Cons.hyps by simp
  have distinct_row: "distinct (valuate (synthesize_shuffle_nat s y0))"
    using distinct_post_index_vars by (simp add: synthesize_shuffle_nat_def post_index_vars_does_not_contain_None distinct_post_index_vars)
  show ?case proof (simp add: valuate_hat_alpha Cons post_index_vars_does_not_contain_None y_notin_ys distinct_row distinct_rest, auto)
    fix x k y
    assume y0: "(x, k) \<in> set (valuate (synthesize_shuffle_nat s y0))"
    assume y: "(x, k) \<in> set (valuate (synthesize_shuffle_nat s y))"
    assume ys: "y \<in> set ys"
    have neq: "y \<noteq> y0" using y_notin_ys ys by auto
    show False using synthesize_shuffle_nat_not_contain_two_rows[OF neq y y0] by simp
  qed
qed

lemma distinct_index_vars:
  "distinct (update_index_vars m)"
  unfolding update_index_vars_def
  by (rule distinct_synthesize_shuffle_nat[OF enum_distinct])

(* END disjointness *)

lemma count_alpha_synthesize_shuffle_nat:
  fixes s :: "('y::enum) shuffle"
  shows "count_alpha (synthesize_shuffle_nat s) yk \<le> 1"
proof (cases yk rule: index_cases)
  case (VarNone y)
  then show ?thesis
    apply (simp add: count_list_valuate[symmetric] count_list_my_simp VarNone sum.distrib count_alpha_def synthesize_shuffle_nat_def
                      post_index_vars_does_not_contain_None del: count_list.simps)
    apply (simp add: kronecker_def)
    done
next
  case (VarSome y k)
  show ?thesis
    apply (simp add: count_alpha_def UNIV_enum sum_count_list_concat_map[OF enum_distinct])
    apply (rule distinct_count_list_le_1)
    apply (rule distinct_synthesize_shuffle_nat)
    apply (rule enum_distinct)
    done
qed

lemma to_enum_apsnd: "to_enum B = apsnd (map_option nat_to_enum)"
  by (rule ext, case_tac x rule: index_cases, simp_all)

lemma inj_on_map_option:
  assumes "inj_on f A"
  shows "inj_on (map_option f) (insert None (Some ` A))"
  using assms by (auto simp add: inj_on_def)

lemma count_list_inj_on:
  assumes "inj_on f A"
  assumes "a \<in> A"
  assumes "set xs \<subseteq> A"
  shows "count_list (map f xs) (f a) = count_list xs a"
  using assms(3) proof (induct xs)
  case Nil
  then show ?case by simp
next
  case (Cons x xs)
  then show ?case using assms(1-2) by (simp add: inj_on_def)
qed

lemma embed_single_inj: "inj (embed_single x)" unfolding inj_on_def by simp

lemma to_enum_inj_on: "inj_on (to_enum B) (valid_vars B :: ('y::enum \<times> nat option) set)"
  apply (simp only: valid_vars_def inj_on_apsnd to_enum_apsnd)
  apply (rule inj_on_map_option)
  apply (rule inj_nat_to_enum)
  done

lemma to_nat_inj: "inj (to_nat B :: ('y \<times> 'k::enum option \<Rightarrow> 'y \<times> nat option))"
  unfolding inj_on_def
proof (intro ballI, rule impI)
  fix x y :: "'y \<times> 'k option"
  assume "to_nat B x = to_nat B y"
  then show "x = y"
    apply (cases x rule: index_cases; cases y rule: index_cases; simp_all)
    using inj_enum_to_nat unfolding inj_on_def by auto
qed

lemma count_list_embed_single:
  "count_list (map (embed_single x) u) (Inl (x, y, z)) = count_list u (y, z)"
proof -
  have *: "Inl (x, y, z) = embed_single x (y, z)" by simp
  show ?thesis
    apply (simp add: * del: embed_single.simps)
    apply (rule count_list_inj_on[where A="UNIV"], simp_all add: embed_single_inj)
    done
qed

lemma count_list_to_enum:
  assumes "boundedness B K"
  assumes "list_all (index_less_than K) u"
  shows "count_list (map (to_enum B) u) (y, z) = count_list u (to_nat B (y, z))"
proof -
  have "count_list (map (to_enum B) u) (y, z)
      = count_list (map (to_nat B) (map (to_enum B) u)) (to_nat B (y, z))"
    by (rule count_list_inj_on[where A=UNIV, symmetric], simp_all add: to_nat_inj)
  moreover have "map (to_nat B) (map (to_enum B) u) = u"
    using assms(2) proof (induct u)
    case Nil
    then show ?case by simp
  next
    case (Cons a u)
    then show ?case proof (cases a rule: index_cases)
      case (VarNone y)
      then show ?thesis using Cons by simp
    next
      case (VarSome y k)
      then show ?thesis using Cons assms(1) unfolding boundedness_def by (simp add: nat_enum_iso)
    qed
  qed
  ultimately show ?thesis by simp
qed

lemma synthesize_shuffle_nat_index_less_than:
  assumes "bounded_shuffle K s"
  shows "list_all (index_less_than K) (valuate (synthesize_shuffle_nat s xk))"
  by (simp add: synthesize_shuffle_nat_def, rule bounded_shuffle_index_less_than, rule assms)

lemma count_alpha_iota_le_1:
  fixes \<alpha> :: "'x \<Rightarrow> 'y::enum shuffle"
  assumes "boundedness (B :: 'k::enum boundedness) k"
  assumes "bounded_shuffle k (\<alpha> x)"
  shows "count_alpha (\<iota> B \<alpha> x :: ('y, 'x \<times> ('y, 'k::enum) index + 'b) update) (Inl (x, y0, z0) :: 'x \<times> ('y, 'k::enum) index + 'b) \<le> 1"
  apply (simp add: \<iota>_def synthesize_def count_alpha_def valuate_hat_alpha map_alpha_apply count_list_my_simp del: map_map count_list.simps to_enum.simps)
  apply (simp add: count_list_embed_single del: map_map to_enum.simps)
  apply (simp add: count_list_to_enum[OF assms(1) synthesize_shuffle_nat_index_less_than[OF assms(2)]] del: to_enum.simps)
  apply (simp add: UNIV_enum sum_count_list_concat_map[OF enum_distinct])
  apply (rule distinct_count_list_le_1)
  apply (rule distinct_synthesize_shuffle_nat[OF enum_distinct])
  done

lemma embed_single_notin:
  assumes "x \<noteq> x0"
  shows "Inl (x0, y0, z0) \<notin> set (map (embed_single x) u)"
  using assms by (induct u, simp_all)

lemma count_alpha_iota_x_neq_x0_eq_0:
  fixes \<alpha> :: "'x \<Rightarrow> 'y::enum shuffle"
  assumes "x \<noteq> x0"
  assumes "boundedness (B :: 'k::enum boundedness) k"
  assumes "bounded_shuffle k (\<alpha> x)"
  shows "count_alpha (\<iota> B \<alpha> x :: ('y, 'x \<times> ('y, 'k::enum) index + 'b) update) (Inl (x0, y0, z0) :: 'x \<times> ('y, 'k::enum) index + 'b) = 0"
  apply (simp add: \<iota>_def synthesize_def count_alpha_def valuate_hat_alpha map_alpha_apply del: map_map to_enum.simps)
  apply (rule allI)
  apply (rule count_notin)
  apply (rule embed_single_notin)
  apply (rule assms(1))
  done

lemma count_list_inr_list_Inl: "count_list (valuate (hat_alpha inr_list w)) (Inl xyz) = 0"
  by (induct w rule: xa_induct, simp_all)

lemma count_alpha_inr_list: "count_alpha (inr_list \<star> a) (Inl xyz) = 0"
  unfolding count_alpha_def map_alpha_def by (simp add: count_list_inr_list_Inl)

lemma count_alpha_hat_homU_eta_hat:
  fixes msst :: "('q::finite, 'x::finite, 'y::enum, 'a, 'b) MSST"
  fixes B1 :: "'k::enum boundedness"
  fixes B2 :: "'l::enum boundedness"
  assumes bc_msst: "bounded_copy_SST k msst"
  assumes boundedness_l: "boundedness B2 l"
  assumes bc_type: "bctype l msst \<gamma>"
  assumes reach: "reachable (convert_MSST B2 msst) (q1, \<beta>)"
  assumes tail: "u \<in> tails (SST.eta_hat msst (q1, w) x)"
  shows "count_alpha (hat_homU (\<iota> B2 (Rep_alpha B2 \<beta>)) u) (Inl (x0, y0, z0))
       \<le> count_list u (Inl x0) * l"
using tail proof (induct u rule: xa_induct)
case Nil
  then show ?case by (simp add: idU_def count_alpha_def)
next
  case (Var x' xs)
  then show ?case proof -
    have xs: "xs \<in> tails (SST.eta_hat msst (q1, w) x)" proof -
      obtain ys where "ys @ Inl x' # xs = SST.eta_hat msst (q1, w) x"
        using Var.prems unfolding tails_def by auto
      then have body: "SST.eta_hat msst (q1, w) x = (ys @ [Inl x']) @ xs" by simp
      show ?thesis unfolding tails_def by (simp, rule exI[where x="ys @ [Inl x']"], rule body)
    qed
    note IH = Var.hyps(1)[OF xs]
    have rep: "Rep_alpha B2 \<beta> x' \<in> \<gamma> (q1, x')"
      by (rule condition_of_convert_MSST_reachable_state[OF boundedness_l bc_type reach])
    have "reachable msst q1" using reach by (rule reachable_convert)
    then have bs: "bounded_shuffle l (Rep_alpha B2 \<beta> x')"
      using bc_type rep by (simp add: bctype_bounded)
    note bc = hat_homU_iota_bounded_copy_tail[OF boundedness_l bc_type reach xs]
    show ?thesis proof (cases "x' = x0")
      case True
      then show ?thesis proof -
        have x: "count_alpha (\<iota> B2 (Rep_alpha B2 \<beta>) x0) (Inl (x0, y0, z0)) \<le> 1"
          apply (rule count_alpha_iota_le_1[OF boundedness_l])
          using bs by (simp add: True)
        show ?thesis by (simp del: Rep_alpha.simps add: True count_alpha_le_1_bounded_copy[OF x IH bc])
      qed
    next
      case False
      then show ?thesis proof -
        have x: "count_alpha (\<iota> B2 (Rep_alpha B2 \<beta>) x') (Inl (x0, y0, z0)) = 0"
          apply (rule count_alpha_iota_x_neq_x0_eq_0[OF False boundedness_l])
          using bs by simp
        show ?thesis by (simp del: Rep_alpha.simps add: False count_alpha_0_comp_count_alpha_n[OF x IH])
      qed
    qed
  qed
next
  case (Alpha a xs)
  then show ?case proof -
    have xs: "xs \<in> tails (SST.eta_hat msst (q1, w) x)" proof -
      obtain ys where "ys @ Inr a # xs = SST.eta_hat msst (q1, w) x"
        using Alpha.prems unfolding tails_def by auto
      then have body: "SST.eta_hat msst (q1, w) x = (ys @ [Inr a]) @ xs" by simp
      show ?thesis unfolding tails_def by (simp, rule exI[where x="ys @ [Inr a]"], rule body)
    qed
    note IH = Alpha.hyps(1)[OF xs]
    have a: "count_alpha (inr_list \<star> a) (Inl (x0, y0, z0)) = 0" by (simp add: count_alpha_inr_list)
    show ?thesis by (simp del: Rep_alpha.simps add: count_alpha_0_comp_count_alpha_n[OF a IH ])
  qed
qed

lemma sum_decompose_to_nat:
  fixes m :: "('y::enum, 'b) update"
  fixes B :: "'k::enum boundedness"
  shows "(\<Sum>xk\<in>UNIV. count_list (\<pi>\<^sub>2 B m xk) a)
       = (\<Sum>xk\<in>valid_vars B. count_list (\<pi>\<^sub>2' m xk) a)"
proof -
  have "(\<Sum>xk\<in>UNIV. count_list (\<pi>\<^sub>2 B m xk) a)
      = (\<Sum>xk\<in>range (to_nat B). count_list (\<pi>\<^sub>2' m xk) a)"
    unfolding resolve_store_def
    by (simp add: compS_apply sum.reindex to_nat_inj)
  also have "... = (\<Sum>xk\<in>valid_vars B. count_list (\<pi>\<^sub>2' m xk) a)"
    by (simp add: valid_vars_eq_range)
  finally show ?thesis .
qed

lemma sum_decompose_first_step:
  fixes m :: "('y::enum, 'b) update"
  fixes B :: "'k::enum boundedness"
  assumes "boundedness B K"
  assumes "bounded K m"
  shows "(\<Sum>(x, k)\<in>valid_vars B. count_list (\<pi>\<^sub>2' m (x, k)) a)
       = (\<Sum>(x, k)\<in>set (update_index_vars m).
            count_list (\<pi>\<^sub>2' m (x, k)) a)"
proof (simp add: update_index_vars_set, rule sum.mono_neutral_right, auto)
  fix x0 k0 y
  assume *: "(x0, k0) \<in> set (valuate (synthesize_shuffle_nat (\<pi>\<^sub>1 m) y))"
  show "(x0, k0) \<in> valid_vars B"
  proof (cases k0)
    case None
    then show ?thesis by simp
  next
    case (Some k)
    have "bounded_shuffle K (\<pi>\<^sub>1 m)" using assms(2) by (rule resolve_bounded)
    then show ?thesis using assms(1) * bounded_shuffle_less_than
      apply (simp add: Some synthesize_shuffle_nat_def) by fastforce
  qed
next
  fix x0 k0
  assume asm: "\<forall>y. (x0, k0) \<notin> set (valuate (synthesize_shuffle_nat (\<pi>\<^sub>1 m) y))"
  show "count_list (\<pi>\<^sub>2' m (x0, k0)) a = 0"
  proof (cases k0)
    case None
    then have "(x0, None) \<notin> set (valuate (synthesize_shuffle_nat (\<pi>\<^sub>1 m) x0))" using asm by simp
    then show ?thesis by (simp add: synthesize_shuffle_nat_def None)
  next
    case (Some k)
    obtain y0 where y0: "lookup_rec m x0 k Enum.enum
         = lookup_row (\<pi>\<^sub>1 m) x0 k (seek y0 Enum.enum) (scan_pair (m y0))"
      using enum_distinct enum_ne_Nil lookup_rec_distinct by fast
    moreover have "(x0, k0) \<notin> set (valuate (synthesize_shuffle_nat (\<pi>\<^sub>1 m) y0))"
      using asm by simp
    ultimately show "count_list (\<pi>\<^sub>2' m (x0, k0)) a = 0"
      by (simp add: Some there_doesnt_exist_corresponding_string synthesize_shuffle_nat_def)
  qed
qed

lemma sum_UNION_eq_sum_sum_list:
  assumes "distinct ys"
  assumes "distinct (concat (map f ys))"
  shows "(\<Sum>x\<in>(\<Union>y\<in>set ys. set (f y)). g x) = (\<Sum>y\<in>set ys. \<Sum>x\<leftarrow>f y. g x)"
  using assms  by (induct ys, simp_all add: sum.union_disjoint sum.distinct_set_conv_list)

lemma count_list_sum_list_concat_map:
  "(\<Sum>x\<leftarrow>xs. count_list (g x) a) = count_list (concat (map g xs)) a"
  by (induct xs, simp_all)

lemma resolve_inverse_nat_valuate:
  "concat (map (\<pi>\<^sub>2' m) (valuate (synthesize_shuffle_nat (\<pi>\<^sub>1 m) x))) = valuate (m x)"
proof -
  have "(\<pi>\<^sub>2' m \<odot> (valuate o synthesize_shuffle_nat (\<pi>\<^sub>1 m))) x = valuate (m x)"
    by (simp add: valuate_map_alpha[symmetric] resolve_inverse_nat)
  then show ?thesis by (simp add: compS_apply)
qed

lemma sum_decompose:
  fixes m :: "('y::enum, 'b) update"
  fixes B :: "'k::enum boundedness"
  assumes "boundedness B K"
  assumes "bounded K m"
  shows "(\<Sum>yk\<in>UNIV. count_list (\<pi>\<^sub>2 B m yk) a)
       = (\<Sum>y\<in>UNIV. count_list (valuate (m y)) a)" (is "?from = ?to")
proof -
  let ?vars = "\<lambda>y. valuate (synthesize_shuffle_nat (\<pi>\<^sub>1 m) y)"
  let ?resolve = "\<lambda>xk. \<pi>\<^sub>2' m xk"
  let ?count = "\<lambda>xk. count_list (?resolve xk) a"
  have "?from = (\<Sum>xk::'y \<times> nat option\<in>valid_vars B. ?count xk)"
    by (simp add: sum_decompose_to_nat)
  also have "... = (\<Sum>xk\<in>(\<Union>y\<in>UNIV. set (?vars y)). ?count xk)"
    using sum_decompose_first_step[OF assms] by (simp add: update_index_vars_set)
  also have "... = (\<Sum>y\<in>UNIV. \<Sum>xk\<leftarrow>?vars y. ?count xk)"
    apply (simp only: UNIV_enum)
    apply (rule sum_UNION_eq_sum_sum_list[OF enum_distinct])
    apply (rule distinct_synthesize_shuffle_nat[OF enum_distinct])
    done
  also have "... = (\<Sum>y\<in>UNIV. count_list (concat (map ?resolve (?vars y))) a)"
    by (simp add: count_list_sum_list_concat_map)
  also have "... = ?to"
    using resolve_inverse_nat_valuate by (simp add: compS_apply resolve_inverse_nat_valuate)
  finally show ?thesis .
qed

theorem convert_MSST_bounded:
  fixes msst :: "('q::finite, 'x::finite, 'y::enum, 'a, 'b) MSST"
  fixes B1 :: "'k::enum boundedness"
  fixes B2 :: "'l::enum boundedness"
  assumes bc_msst: "bounded_copy_SST k msst"
  assumes boundedness_k: "boundedness B1 k"
  assumes boundedness_l: "boundedness B2 l"
  assumes bc_type: "bctype l msst \<gamma>"
  shows "bounded_copy_SST (k * l) (convert_MSST B2 msst)"
  unfolding bounded_copy_SST_def bounded_def
proof (intro allI, rule impI)
  fix w qb
  assume "reachable (convert_MSST B2 msst) qb"
  then have r_pair: "reachable (convert_MSST B2 msst) (fst qb, snd qb)" by simp
  then have r_fst: "reachable msst (fst qb)" by (rule reachable_convert)
  have l0: "0 < l" using assms length_enum_gt_0 unfolding boundedness_def by simp
  have k0: "0 < k" using assms length_enum_gt_0 unfolding boundedness_def by simp

  show "\<forall>y. count_var (SST.eta_hat (convert_MSST B2 msst) (qb, w)) y \<le> k * l"
  proof (cases "length w")
    case 0
    then show ?thesis
      apply simp unfolding count_var_def idU_def
      apply (simp)
      apply (simp only: count_list.simps)
      apply (simp add: k0 l0 Suc_leI)
      done
  next
    case (Suc nat)
    then have w_gt_0: "0 < length w" by simp
    note mado = convert_\<eta>_hat_gt_0[OF boundedness_l bc_type r_pair w_gt_0, simplified]
    then show ?thesis proof (auto simp add: mado count_var_def H'_def prod.case_eq_if delta_convert_MSST_simp eta_convert_MSST_simp)
      fix x0 y0 z0
      have "(\<Sum>xyz\<in>UNIV. count_list (extract_variables (\<pi>\<^sub>2 B2 (hat_homU (\<iota> B2 (Rep_alpha B2 (snd qb)))
                                                          (SST.eta_hat msst (fst qb, w) (fst xyz))) (snd xyz)))
           (x0, y0, z0))
          = (\<Sum>(x, yk)\<in>UNIV. count_list (extract_variables (\<pi>\<^sub>2 B2 (hat_homU (\<iota> B2 (Rep_alpha B2 (snd qb))) (SST.eta_hat msst (fst qb, w) x)) yk))
           (x0, y0, z0))" (is "?lhs = _")
        by (simp add: prod.case_eq_if)
      also have "... = (\<Sum>x\<in>UNIV. \<Sum>yk\<in>UNIV. count_list (extract_variables (\<pi>\<^sub>2 B2 (hat_homU (\<iota> B2 (Rep_alpha B2 (snd qb))) (SST.eta_hat msst (fst qb, w) x)) yk))
           (x0, y0, z0))"
        apply (simp only: UNIV_Times_UNIV[symmetric])
        apply (rule sum.Sigma[symmetric], simp_all)
        done
      also have "... = (\<Sum>x\<in>UNIV. \<Sum>y\<in>UNIV. count_list (valuate (hat_homU (\<iota> B2 (Rep_alpha B2 (snd qb))) (SST.eta_hat msst (fst qb, w) x) y))
           (Inl (x0, y0, z0)))"
        by (simp add: count_list_extract_variables sum_decompose[OF boundedness_l hat_homU_iota_bounded_copy[OF boundedness_l bc_type r_pair]])
      also have "... = (\<Sum>x\<in>UNIV. count_alpha (hat_homU (\<iota> B2 (Rep_alpha B2 (snd qb))) (SST.eta_hat msst (fst qb, w) x)) (Inl (x0, y0, z0)))"
        unfolding count_alpha_def by simp
      also have "... \<le> k * l" proof -
        have body: "\<And>x. count_alpha (hat_homU (\<iota> B2 (Rep_alpha B2 (snd qb))) (SST.eta_hat msst (fst qb, w) x)) (Inl (x0, y0, z0))
                    \<le> count_list (extract_variables (SST.eta_hat msst (fst qb, w) x)) x0 * l" proof -
          fix x
          have tail: "SST.eta_hat msst (fst qb, w) x \<in> tails (SST.eta_hat msst (fst qb, w) x)"
            unfolding tails_def by auto
          show "count_alpha (hat_homU (\<iota> B2 (Rep_alpha B2 (snd qb))) (SST.eta_hat msst (fst qb, w) x)) (Inl (x0, y0, z0))
                    \<le> count_list (extract_variables (SST.eta_hat msst (fst qb, w) x)) x0 * l"
            by (simp add: count_list_extract_variables count_alpha_hat_homU_eta_hat[OF bc_msst boundedness_l bc_type r_pair tail])
        qed
        have "(\<Sum>x\<in>UNIV. count_alpha (hat_homU (\<iota> B2 (Rep_alpha B2 (snd qb))) (SST.eta_hat msst (fst qb, w) x)) (Inl (x0, y0, z0)))
            \<le> (\<Sum>x\<in>UNIV. count_list (extract_variables (SST.eta_hat msst (fst qb, w) x)) x0 * l)"
          by (simp add: body sum_mono)
        also have "... = (\<Sum>x\<in>UNIV. count_list (extract_variables (SST.eta_hat msst (fst qb, w) x)) x0) * l"
          by (simp add: sum_distrib_right)
        also have "... = count_var (SST.eta_hat msst (fst qb, w)) x0 * l"
          unfolding count_var_def by simp
        also have "... \<le> k * l" proof -
          have "bounded k (SST.eta_hat msst (fst qb, w))"
            using bc_msst r_fst unfolding bounded_copy_SST_def by auto
          then have "count_var (SST.eta_hat msst (fst qb, w)) x0 \<le> k"
            by (simp add: bounded_def)
          then show ?thesis by simp
        qed
        finally show ?thesis .
      qed
      finally show "?lhs \<le> k * l" .
    qed
  qed
qed

end


header {* \subsection{Link implementation to CISK: the specific separation kernel is an interpretation of the generic model.\label{sect:link_to_CISK}} *}

theory Link_separation_kernel_model_to_CISK
  imports Separation_kernel_model
begin

text {* We show that the separation kernel instantiation satisfies the
specification of CISK.
*}

theorem CISK_proof_obligations_satisfied:
  shows
    "Controllable_Interruptible_Separation_Kernel
      rstep
      routput_f
      (\<up>s0)
      rcurrent
      rcswitch
      rkinvolved
      rifp
      rvpeq
      rAS_set
      rinvariant
      rprecondition
      raborting
      rwaiting
      rset_error_code"
proof (unfold_locales)
  --"show that rvpeq is equivalence relation"
  show "\<forall> a b c u. (rvpeq u a b \<and> rvpeq u b c) \<longrightarrow> rvpeq u a c"
   and "\<forall> a b u. rvpeq u a b \<longrightarrow> rvpeq u b a"
   and "\<forall> a u. rvpeq u a a"
    using inst_vpeq_rel by metis+
  --"show output consistency"
  show "\<forall> a s t. rvpeq (rcurrent s) s t \<and> rcurrent s = rcurrent t \<longrightarrow> routput_f s a = routput_f t a"
    using inst_output_consistency by metis
  --"show reflexivity of ifp"
  show "\<forall> u . rifp u u"
    using inst_ifp_refl by metis
  --"show step consistency"
  show "\<forall>s t u a. rvpeq u s t \<and> rvpeq (rcurrent s) s t \<and> True \<and> rprecondition s (rcurrent s) a \<and> True \<and> rprecondition t (rcurrent t) a \<and> rcurrent s = rcurrent t \<longrightarrow>
              rvpeq u (rstep s a) (rstep t a)"
    using inst_weakly_step_consistent by blast
  --"show step atomicity"
  show "\<forall> s a . rcurrent (rstep s a) = rcurrent s"
    using inst_step_atomicity by metis
  show " \<forall>a s u. \<not> rifp (rcurrent s) u \<and> True \<and> rprecondition s (rcurrent s) a \<longrightarrow> rvpeq u s (rstep s a)"
    using inst_local_respect by blast
  --"show cswitch is independent of state"
  show "\<forall>n s t. rcurrent s = rcurrent t \<longrightarrow> rcurrent (rcswitch n s) = rcurrent (rcswitch n t)"
    using inst_cswitch_independent_of_state by metis
  --"show cswitch consistency"
  show "\<forall>u s t n. rvpeq u s t \<longrightarrow> rvpeq u (rcswitch n s) (rcswitch n t)"
    using inst_cswitch_consistency by metis
  --"Show the empt action sequence is in @{term AS_set}"
  show "[] \<in> rAS_set"
    unfolding rAS_set_def
    by auto
  --"The invariant for the initial state, already encoded in @{term rstate_t}"
  show "True"
    by auto
  --"Step function of the invariant, already encoded in @{term rstate_t}"
  show "\<forall>s n. True \<longrightarrow> True"
    by auto
  --"The precondition does not change with a context switch"
  show "\<forall>s d n a. rprecondition s d a \<longrightarrow> rprecondition (rcswitch n s) d a"
    using precondition_after_cswitch by blast
  --"The precondition holds for the first action of each action sequence"
  show "\<forall>s d aseq. True \<and> aseq \<in> rAS_set \<and> aseq \<noteq> [] \<longrightarrow> rprecondition s d (hd aseq)"
    using prec_first_IPC_action prec_first_EV_WAIT_action prec_first_EV_SIGNAL_action
    unfolding rAS_set_def is_sub_seq_def
    by auto
  --"The precondition holds for the next action in an action sequence, assuming the sequence is not aborted or delayed"
  show "\<forall>s a a'. (\<exists>aseq\<in>rAS_set. is_sub_seq a a' aseq) \<and> True \<and> rprecondition s (rcurrent s) a \<and> \<not> raborting s (rcurrent s) a \<and> \<not> rwaiting s (rcurrent s) a \<longrightarrow>
             rprecondition (rstep s a) (rcurrent s) a'"
    using prec_after_IPC_step prec_after_EV_SIGNAL_step prec_after_EV_WAIT_step
    unfolding rAS_set_def is_sub_seq_def
    by auto
  --"Steps of other domains do not influence the precondition"
  show "\<forall>s d a a'. rcurrent s \<noteq> d \<and> rprecondition s d a \<longrightarrow> rprecondition (rstep s a') d a"
    using prec_dom_independent by blast
  --"The invariant"
  show "\<forall>s a. True \<longrightarrow> True"
    by auto
  --"Aborting does not depend on a context switch"
  show "\<forall>n s. raborting (rcswitch n s) = raborting s"
    using aborting_switch_independent by auto
  --"Aborting does not depend on actions of other domains"
  show "\<forall>s a d. rcurrent s \<noteq> d \<longrightarrow> raborting (rstep s a) d = raborting s d"
    using aborting_dom_independent by auto
  --"Aborting is consistent"
  show "\<forall>s t u. rvpeq u s t \<longrightarrow> raborting s u = raborting t u"
    using raborting_consistent by auto
  --"Waiting does not depend on a context switch"
  show "\<forall>n s. rwaiting (rcswitch n s) = rwaiting s"
    using waiting_switch_independent by auto
  --"Waiting is consistent"
  show "\<forall>s t u a. rvpeq (rcurrent s) s t \<and> (\<forall> d \<in> rkinvolved a . rvpeq d s t)
         \<and> rvpeq u s t
         \<longrightarrow> rwaiting s u a = rwaiting t u a"
    unfolding Kernel.involved_def
    using waiting_consistent by auto
  --"Domains that are involved in an action may influence the domain of the action"
  show "\<forall>s a. \<forall> d \<in> rkinvolved a. rprecondition s (rcurrent s) a \<longrightarrow> rifp d (rcurrent s)"
    using involved_ifp by blast
  --"An action that is waiting does not change the state"
  show "\<forall>s a. rwaiting s (rcurrent s) a \<longrightarrow> rstep s a = s"
    using spec_of_waiting by blast
  --"Proof obligations for @{term set_error_code}. Right now, they are all trivial"
  show "\<forall>s d a' a. rcurrent s \<noteq> d \<and> raborting s d a \<longrightarrow> raborting (rset_error_code s a') d a"
    unfolding rset_error_code_def
    by auto
  show "\<forall>s t u a. rvpeq u s t \<longrightarrow> rvpeq u (rset_error_code s a) (rset_error_code t a)"
    unfolding rset_error_code_def
    by auto
  show "\<forall>s u a. \<not> rifp (rcurrent s) u \<longrightarrow> rvpeq u s (rset_error_code s a)"
    unfolding rset_error_code_def
    by (metis `\<forall>a u. rvpeq u a a`)
  show "\<forall>s a. rcurrent (rset_error_code s a) = rcurrent s"
    unfolding rset_error_code_def
    by auto
  show "\<forall>s d a a'. rprecondition s d a \<and> raborting s (rcurrent s) a' \<longrightarrow> rprecondition (rset_error_code s a') d a"
    unfolding rset_error_code_def
    by auto
  show "\<forall>s d a' a. rcurrent s \<noteq> d \<and> rwaiting s d a \<longrightarrow> rwaiting (rset_error_code s a') d a"
    unfolding rset_error_code_def
    by auto
qed

text {* Now we can instantiate CISK with some initial state, interrupt function, etc. *}

interpretation Inst:
  Controllable_Interruptible_Separation_Kernel
    rstep           -- "step function, without program stack"
    routput_f       -- "output function"
    "\<up>s0"           -- "initial state"
    rcurrent        -- "returns the currently active domain"
    rcswitch        -- "switches the currently active domain"
    "(op =) 42"     -- "interrupt function (yet unspecified)"
    rkinvolved      -- "returns a set of threads involved in the give action"
    rifp            -- "information flow policy"
    rvpeq           -- "view partitioning"
    rAS_set         -- "the set of valid action sequences"
    rinvariant      -- "the state invariant"
    rprecondition   -- "the precondition for doing an action"
    raborting       -- "condition under which an action is aborted"
    rwaiting        -- "condition under which an action is delayed"
    rset_error_code -- "updates the state. Has no meaning in the current model."
using CISK_proof_obligations_satisfied by auto

text {* The main theorem: the instantiation implements the information flow policy @{term ifp}. *}
theorem risecure:
  "Inst.isecure"
using Inst.unwinding_implies_isecure_CISK
by blast

end


theory AnalBinds
imports Launchbury.Terms "Launchbury.HOLCF-Utils" Launchbury.Env
begin

locale ExpAnalysis =
  fixes exp :: "exp \<Rightarrow> 'a::cpo \<rightarrow> 'b::pcpo"
begin

fun AnalBinds :: "heap \<Rightarrow> (var \<Rightarrow> 'a\<^sub>\<bottom>) \<rightarrow> (var \<Rightarrow> 'b)"
  where "AnalBinds [] = (\<Lambda> ae. \<bottom>)"
      | "AnalBinds ((x,e)#\<Gamma>) = (\<Lambda> ae. (AnalBinds \<Gamma>\<cdot>ae)(x := fup\<cdot>(exp e)\<cdot>(ae x)))"

lemma AnalBinds_Nil_simp[simp]: "AnalBinds []\<cdot>ae = \<bottom>" by simp

lemma AnalBinds_Cons[simp]:
  "AnalBinds ((x,e)#\<Gamma>)\<cdot>ae = (AnalBinds \<Gamma>\<cdot>ae)(x := fup\<cdot>(exp e)\<cdot>(ae x))"
  by simp

lemmas AnalBinds.simps[simp del]

lemma AnalBinds_not_there: "x \<notin> domA \<Gamma> \<Longrightarrow> (AnalBinds \<Gamma>\<cdot>ae) x = \<bottom>"
  by (induction \<Gamma> rule: AnalBinds.induct) auto

lemma AnalBinds_cong:
  assumes "ae f|` domA \<Gamma> = ae' f|` domA \<Gamma>"
  shows "AnalBinds \<Gamma>\<cdot>ae = AnalBinds \<Gamma>\<cdot>ae'"
using env_restr_eqD[OF assms]
by (induction \<Gamma> rule: AnalBinds.induct) (auto split: if_splits)

lemma AnalBinds_lookup: "(AnalBinds \<Gamma>\<cdot>ae) x = (case map_of \<Gamma> x of Some e \<Rightarrow> fup\<cdot>(exp e)\<cdot>(ae x) | None \<Rightarrow> \<bottom>)"
  by (induction \<Gamma> rule: AnalBinds.induct) auto

lemma AnalBinds_delete_bot: "ae x = \<bottom> \<Longrightarrow> AnalBinds (delete x \<Gamma>)\<cdot>ae = AnalBinds \<Gamma>\<cdot>ae"
  by (auto simp add: AnalBinds_lookup split:option.split simp add: delete_conv)

lemma AnalBinds_delete_below: "AnalBinds (delete x \<Gamma>)\<cdot>ae \<sqsubseteq> AnalBinds \<Gamma>\<cdot>ae"
  by (auto intro: fun_belowI simp add: AnalBinds_lookup split:option.split)

lemma AnalBinds_delete_lookup[simp]: "(AnalBinds (delete x \<Gamma>)\<cdot>ae) x = \<bottom>"
  by (auto  simp add: AnalBinds_lookup split:option.split)

lemma AnalBinds_delete_to_fun_upd: "AnalBinds (delete x \<Gamma>)\<cdot>ae = (AnalBinds \<Gamma>\<cdot>ae)(x := \<bottom>)"
  by (auto  simp add: AnalBinds_lookup split:option.split)

lemma edom_AnalBinds: "edom (AnalBinds \<Gamma>\<cdot>ae) \<subseteq> domA \<Gamma> \<inter> edom ae"
  by (induction \<Gamma> rule: AnalBinds.induct) (auto  simp add: edom_def)

end

end


theory TopoS_Composition_Theory_impl
imports TopoS_Interface_impl TopoS_Composition_Theory
begin

section{*Composition Theory -- List Implementation*}

text{*Several invariants may apply to one policy. *}

(*the packed network model record from the list implementation*)
term "X::('v::vertex, 'a) TopoS_packed"

subsection{*Generating instantiated (configured) network security invariants*}

  --"a configured network security invariant in list implementaion"
  (*very minimal version, no eval, ...*)
  record ('v) SecurityInvariant =
    implc_type :: string
    implc_description :: string
    implc_sinvar ::"('v) list_graph \<Rightarrow> bool"
    implc_offending_flows ::"('v) list_graph \<Rightarrow> ('v \<times> 'v) list list"
    implc_isIFS :: "bool"

  text{* Test if this definition is compliant with the formal definition on sets. *}
  definition SecurityInvariant_complies_formal_def ::
    "('v) SecurityInvariant \<Rightarrow> 'v TopoS_Composition_Theory.SecurityInvariant_configured \<Rightarrow> bool" where
    "SecurityInvariant_complies_formal_def impl spec \<equiv>
      (\<forall> G. wf_list_graph G \<longrightarrow> implc_sinvar impl G = c_sinvar spec (list_graph_to_graph G)) \<and>
      (\<forall> G. wf_list_graph G \<longrightarrow> set`set (implc_offending_flows impl G) = c_offending_flows spec (list_graph_to_graph G)) \<and>
      (implc_isIFS impl = c_isIFS spec)"

  fun new_configured_list_SecurityInvariant ::
    "('v::vertex, 'a) TopoS_packed \<Rightarrow> ('v::vertex, 'a) TopoS_Params \<Rightarrow> string \<Rightarrow>
        ('v SecurityInvariant)" where
      "new_configured_list_SecurityInvariant m C description =
        (let nP = nm_node_props m C in
         \<lparr>
            implc_type = nm_name m,
            implc_description = description,
            implc_sinvar = (\<lambda>G. (nm_sinvar m) G nP),
            implc_offending_flows = (\<lambda>G. (nm_offending_flows m) G nP),
            implc_isIFS = nm_receiver_violation m
          \<rparr>)"

  text{* the @{term TopoS_Composition_Theory.new_configured_SecurityInvariant} must give a
         result if we have the SecurityInvariant modelLibrary*}
  lemma TopoS_modelLibrary_yields_new_configured_SecurityInvariant:
    assumes NetModelLib: "TopoS_modelLibrary m sinvar_spec"
    and     nPdef:       "nP = nm_node_props m C"
    and formalSpec:      "Spec = \<lparr>
                              c_sinvar = (\<lambda>G. sinvar_spec G nP),
                              c_offending_flows = (\<lambda>G. SecurityInvariant_withOffendingFlows.set_offending_flows sinvar_spec G nP),
                              c_isIFS = nm_receiver_violation m
                            \<rparr>"
    shows "new_configured_SecurityInvariant (sinvar_spec, nm_default m, nm_receiver_violation m, nP) = Some Spec"
    proof -
      from NetModelLib have NetModel: "SecurityInvariant sinvar_spec (nm_default m) (nm_receiver_violation m)"
        by(simp add: TopoS_modelLibrary_def TopoS_List_Impl_def)

      have Spec: "\<lparr>c_sinvar = \<lambda>G. sinvar_spec G nP,
             c_offending_flows = \<lambda>G. SecurityInvariant_withOffendingFlows.set_offending_flows sinvar_spec G nP,
             c_isIFS = nm_receiver_violation m\<rparr> = Spec"
      by(simp add: formalSpec)
      show ?thesis
        unfolding new_configured_SecurityInvariant.simps
        by(simp add: NetModel Spec)
    qed
    thm TopoS_modelLibrary_yields_new_configured_SecurityInvariant[simplified] (*todo fold in Spec*)

  (* The new_* functions comply, i.e. we can instance network security models that are executable. *)
  lemma new_configured_list_SecurityInvariant_complies:
    assumes NetModelLib: "TopoS_modelLibrary m sinvar_spec"
    and     nPdef:       "nP = nm_node_props m C"
    and formalSpec:      "Spec = new_configured_SecurityInvariant (sinvar_spec, nm_default m, nm_receiver_violation m, nP)"
    and implSpec:        "Impl = new_configured_list_SecurityInvariant m C description"
    shows "SecurityInvariant_complies_formal_def Impl (the Spec)"
    proof -
      from TopoS_modelLibrary_yields_new_configured_SecurityInvariant[OF NetModelLib nPdef]
      have SpecUnfolded: "new_configured_SecurityInvariant (sinvar_spec, nm_default m, nm_receiver_violation m, nP) =
        Some \<lparr>c_sinvar = \<lambda>G. sinvar_spec G nP,
             c_offending_flows = \<lambda>G. SecurityInvariant_withOffendingFlows.set_offending_flows sinvar_spec G nP,
             c_isIFS = nm_receiver_violation m\<rparr>" by simp

      from NetModelLib show ?thesis
        apply(simp add: SpecUnfolded formalSpec implSpec Let_def)
        apply(simp add: SecurityInvariant_complies_formal_def_def)
        apply(simp add: TopoS_modelLibrary_def TopoS_List_Impl_def)
        apply(simp add: nPdef)
        done
    qed

  corollary new_configured_list_SecurityInvariant_complies':
    "\<lbrakk> TopoS_modelLibrary m sinvar_spec \<rbrakk> \<Longrightarrow>
    SecurityInvariant_complies_formal_def (new_configured_list_SecurityInvariant m C description)
      (the (new_configured_SecurityInvariant (sinvar_spec, nm_default m, nm_receiver_violation m, nm_node_props m C)))"
    by(blast dest: new_configured_list_SecurityInvariant_complies)

  --"From"
  thm new_configured_SecurityInvariant_sound
  --"we get that @{const new_configured_list_SecurityInvariant} has all the necessary properties (modulo @{const SecurityInvariant_complies_formal_def})"

subsection{*About security invariants*}

   text{*specification and implementation comply. *}
   type_synonym 'v security_models_spec_impl="('v SecurityInvariant \<times> 'v TopoS_Composition_Theory.SecurityInvariant_configured) list"

   definition get_spec :: "'v security_models_spec_impl \<Rightarrow> ('v TopoS_Composition_Theory.SecurityInvariant_configured) list" where
    "get_spec M \<equiv> [snd m. m \<leftarrow> M]"
   definition get_impl :: "'v security_models_spec_impl \<Rightarrow> ('v SecurityInvariant) list" where
    "get_impl M \<equiv> [fst m. m \<leftarrow> M]"

subsection{*Calculating offending flows*}
  fun implc_get_offending_flows :: "('v) SecurityInvariant list \<Rightarrow> 'v list_graph \<Rightarrow> (('v \<times> 'v) list list)" where
    "implc_get_offending_flows [] G = []"  |
    "implc_get_offending_flows (m#Ms) G = (implc_offending_flows m G)@(implc_get_offending_flows Ms G)"

  lemma implc_get_offending_flows_fold:
    "implc_get_offending_flows M G = fold (\<lambda>m accu. accu@(implc_offending_flows m G)) M []"
    proof-
    { fix accu
      have "accu@(implc_get_offending_flows M G) = fold (\<lambda>m accu. accu@(implc_offending_flows m G)) M accu"
      apply(induction M arbitrary: accu)
       apply(simp_all)
      by(metis append_eq_appendI) }
    from this[where accu2="[]"] show ?thesis by simp
  qed

  lemma implc_get_offending_flows_Un: "set`set (implc_get_offending_flows M G) = (\<Union>m\<in>set M. set`set (implc_offending_flows m G))"
    apply(induction M)
     apply(simp_all)
    by (metis image_Un)

  lemma implc_get_offending_flows_map_concat: "(implc_get_offending_flows M G) = concat [implc_offending_flows m G. m \<leftarrow> M]"
    apply(induction M)
     by(simp_all)

  theorem implc_get_offending_flows_complies:
    assumes a1: "\<forall> (m_impl, m_spec) \<in> set M. SecurityInvariant_complies_formal_def m_impl m_spec"
    and     a2: "wf_list_graph G"
    shows   "set`set (implc_get_offending_flows (get_impl M) G) = (get_offending_flows (get_spec M) (list_graph_to_graph G))"
    proof -
      from a1 have "\<forall> (m_impl, m_spec) \<in> set M. set ` set (implc_offending_flows m_impl G) = c_offending_flows m_spec (list_graph_to_graph G)"
        apply(simp add: SecurityInvariant_complies_formal_def_def)
        using a2 by blast
      hence "\<forall> m \<in> set M. set ` set (implc_offending_flows (fst m) G) = c_offending_flows (snd m) (list_graph_to_graph G)" by fastforce
      thus ?thesis
        by(simp add: get_impl_def get_spec_def implc_get_offending_flows_Un get_offending_flows_def)
   qed

subsection{*Accessors*}
  definition get_IFS :: "'v SecurityInvariant list \<Rightarrow> 'v SecurityInvariant list" where
    "get_IFS M \<equiv> [m \<leftarrow> M. implc_isIFS m]"
  definition get_ACS :: "'v SecurityInvariant list \<Rightarrow> 'v SecurityInvariant list" where
    "get_ACS M \<equiv> [m \<leftarrow> M. \<not> implc_isIFS m]"

  lemma get_IFS_get_ACS_complies:
  assumes a: "\<forall> (m_impl, m_spec) \<in> set M. SecurityInvariant_complies_formal_def m_impl m_spec"
    shows "\<forall> (m_impl, m_spec) \<in> set (zip (get_IFS (get_impl M)) (TopoS_Composition_Theory.get_IFS (get_spec M))).
      SecurityInvariant_complies_formal_def m_impl m_spec"
    and "\<forall> (m_impl, m_spec) \<in> set (zip (get_ACS (get_impl M)) (TopoS_Composition_Theory.get_ACS (get_spec M))).
      SecurityInvariant_complies_formal_def m_impl m_spec"
    proof -
      from a have "\<forall> (m_impl, m_spec) \<in> set M. implc_isIFS m_impl = c_isIFS m_spec"
        apply(simp add: SecurityInvariant_complies_formal_def_def) by fastforce
      hence set_zip_IFS: "set (zip (filter implc_isIFS (get_impl M)) (filter c_isIFS (get_spec M))) \<subseteq> set M"
        apply(simp add: get_impl_def get_spec_def)
        apply(induction M)
         apply(simp_all)
        by force
      from set_zip_IFS a show "\<forall> (m_impl, m_spec) \<in> set (zip (get_IFS (get_impl M)) (TopoS_Composition_Theory.get_IFS (get_spec M))).
          SecurityInvariant_complies_formal_def m_impl m_spec"
        apply(simp add: get_IFS_def get_ACS_def
          TopoS_Composition_Theory.get_IFS_def TopoS_Composition_Theory.get_ACS_def) by blast
      next
      from a have "\<forall> (m_impl, m_spec) \<in> set M. implc_isIFS m_impl = c_isIFS m_spec"
        apply(simp add: SecurityInvariant_complies_formal_def_def) by fastforce
      hence set_zip_ACS: "set (zip [m\<leftarrow>get_impl M . \<not> implc_isIFS m] [m\<leftarrow>get_spec M . \<not> c_isIFS m]) \<subseteq> set M"
        apply(simp add: get_impl_def get_spec_def)
        apply(induction M)
         apply(simp_all)
        by force
      from this a show "\<forall> (m_impl, m_spec) \<in> set (zip (get_ACS (get_impl M)) (TopoS_Composition_Theory.get_ACS (get_spec M))).
        SecurityInvariant_complies_formal_def m_impl m_spec"
        apply(simp add: get_IFS_def get_ACS_def
          TopoS_Composition_Theory.get_IFS_def TopoS_Composition_Theory.get_ACS_def) by fast
     qed

   lemma get_IFS_get_ACS_select_simps:
    assumes a1: "\<forall> (m_impl, m_spec) \<in> set M. SecurityInvariant_complies_formal_def m_impl m_spec"
    shows "\<forall> (m_impl, m_spec) \<in> set (zip (get_IFS (get_impl M)) (TopoS_Composition_Theory.get_IFS (get_spec M))). SecurityInvariant_complies_formal_def m_impl m_spec" (is "\<forall> (m_impl, m_spec) \<in> set ?zippedIFS. SecurityInvariant_complies_formal_def m_impl m_spec")
    and   "(get_impl (zip (TopoS_Composition_Theory_impl.get_IFS (get_impl M)) (TopoS_Composition_Theory.get_IFS (get_spec M)))) = TopoS_Composition_Theory_impl.get_IFS (get_impl M)"
    and   "(get_spec (zip (TopoS_Composition_Theory_impl.get_IFS (get_impl M)) (TopoS_Composition_Theory.get_IFS (get_spec M)))) = TopoS_Composition_Theory.get_IFS (get_spec M)"
    and   "\<forall> (m_impl, m_spec) \<in> set (zip (get_ACS (get_impl M)) (TopoS_Composition_Theory.get_ACS (get_spec M))). SecurityInvariant_complies_formal_def m_impl m_spec" (is "\<forall> (m_impl, m_spec) \<in> set ?zippedACS. SecurityInvariant_complies_formal_def m_impl m_spec")
    and   "(get_impl (zip (TopoS_Composition_Theory_impl.get_ACS (get_impl M)) (TopoS_Composition_Theory.get_ACS (get_spec M)))) = TopoS_Composition_Theory_impl.get_ACS (get_impl M)"
    and   "(get_spec (zip (TopoS_Composition_Theory_impl.get_ACS (get_impl M)) (TopoS_Composition_Theory.get_ACS (get_spec M)))) = TopoS_Composition_Theory.get_ACS (get_spec M)"
    proof -
        from get_IFS_get_ACS_complies(1)[OF a1]
        show "\<forall> (m_impl, m_spec) \<in> set (?zippedIFS). SecurityInvariant_complies_formal_def m_impl m_spec" by simp
      next
        from a1 show "(get_impl ?zippedIFS) = TopoS_Composition_Theory_impl.get_IFS (get_impl M)"
          apply(simp add: TopoS_Composition_Theory_impl.get_IFS_def get_spec_def get_impl_def TopoS_Composition_Theory.get_IFS_def)
          apply(induction M)
           apply(simp)
          apply(simp)
          apply(rule conjI)
           apply(clarify)
           using SecurityInvariant_complies_formal_def_def apply (auto)[1]
          apply(clarify)
          using SecurityInvariant_complies_formal_def_def apply (auto)[1]
          done
      next
        from a1 show "(get_spec ?zippedIFS) = TopoS_Composition_Theory.get_IFS (get_spec M)"
          apply(simp add: TopoS_Composition_Theory_impl.get_IFS_def get_spec_def get_impl_def TopoS_Composition_Theory.get_IFS_def)
          apply(induction M)
           apply(simp)
          apply(simp)
          apply(rule conjI)
           apply(clarify)
           using SecurityInvariant_complies_formal_def_def apply (auto)[1]
          apply(clarify)
          using SecurityInvariant_complies_formal_def_def apply (auto)[1]
          done
      next
        from get_IFS_get_ACS_complies(2)[OF a1]
        show "\<forall> (m_impl, m_spec) \<in> set (?zippedACS). SecurityInvariant_complies_formal_def m_impl m_spec" by simp
      next
        from a1 show "(get_impl ?zippedACS) = TopoS_Composition_Theory_impl.get_ACS (get_impl M)"
          apply(simp add: TopoS_Composition_Theory_impl.get_ACS_def get_spec_def get_impl_def TopoS_Composition_Theory.get_ACS_def)
          apply(induction M)
           apply(simp)
          apply(simp)
          apply(rule conjI)
           apply(clarify)
           using SecurityInvariant_complies_formal_def_def apply (auto)[1]
          apply(clarify)
          using SecurityInvariant_complies_formal_def_def apply (auto)[1]
          done
      next
        from a1 show "(get_spec ?zippedACS) = TopoS_Composition_Theory.get_ACS (get_spec M)"
          apply(simp add: TopoS_Composition_Theory_impl.get_ACS_def get_spec_def get_impl_def TopoS_Composition_Theory.get_ACS_def)
          apply(induction M)
           apply(simp)
          apply(simp)
          apply(rule conjI)
           apply(clarify)
           using SecurityInvariant_complies_formal_def_def apply (auto)[1]
          apply(clarify)
          using SecurityInvariant_complies_formal_def_def apply (auto)[1]
          done
      qed

   thm get_IFS_get_ACS_select_simps

subsection{*All security requirements fulfilled*}
   definition all_security_requirements_fulfilled :: "'v SecurityInvariant list \<Rightarrow> 'v list_graph \<Rightarrow> bool" where
      "all_security_requirements_fulfilled M G \<equiv> \<forall>m \<in> set M. (implc_sinvar m) G"

  lemma all_security_requirements_fulfilled_complies:
    "\<lbrakk> \<forall> (m_impl, m_spec) \<in> set M. SecurityInvariant_complies_formal_def m_impl m_spec;
       wf_list_graph (G::('v::vertex) list_graph) \<rbrakk> \<Longrightarrow>
    all_security_requirements_fulfilled (get_impl M) G \<longleftrightarrow> TopoS_Composition_Theory.all_security_requirements_fulfilled (get_spec M) (list_graph_to_graph G)"
    apply(simp add: all_security_requirements_fulfilled_def TopoS_Composition_Theory.all_security_requirements_fulfilled_def)
    apply(simp add: get_impl_def get_spec_def)
    using SecurityInvariant_complies_formal_def_def by fastforce

subsection{*generate valid topology*}
  value "concat [[1::int,2,3], [4,6,5]]"

  fun generate_valid_topology :: "'v SecurityInvariant list \<Rightarrow> 'v list_graph \<Rightarrow> ('v list_graph)" where
    "generate_valid_topology M G = delete_edges G (concat (implc_get_offending_flows M G))"

  lemma generate_valid_topology_complies:
    "\<lbrakk> \<forall> (m_impl, m_spec) \<in> set M. SecurityInvariant_complies_formal_def m_impl m_spec;
       wf_list_graph (G::('v list_graph)) \<rbrakk> \<Longrightarrow>
       list_graph_to_graph (generate_valid_topology (get_impl M) G) =
       TopoS_Composition_Theory.generate_valid_topology (get_spec M) (list_graph_to_graph G)"
    apply(subst generate_valid_topology_def_alt)
    apply(drule(1) implc_get_offending_flows_complies)
    apply(simp)
    apply(simp add: delete_edges_correct[symmetric])
    apply(simp add: list_graph_to_graph_def FiniteGraph.delete_edges_simp2)
    apply(simp)
    by blast

subsection{*generate valid topology*}
  text{*tuned for invariants where we don't want to calculate all offending flows*}

  text{*Theoretic foundations: The algorithm @{const generate_valid_topology_SOME} picks
        ONE offending flow non-deterministically.
        This is sound: @{thm generate_valid_topology_SOME_sound}.
        However, this non-deterministic choice is hard to implement.
        To pick one offending flow deterministically, we have implemented @{const minimalize_offending_overapprox}.
        It gives back one offending flow:
          @{thm SecurityInvariant_preliminaries.minimalize_offending_overapprox_gives_back_an_offending_flow}
        The good thing about this function is, that it does not need to construct the complete
        @{const SecurityInvariant_withOffendingFlows.set_offending_flows}. Therefore,
        it can be used for security invariants which may have an exponential number of offending flows.
        The corresponding algorithm that uses this function is @{const TopoS_Composition_Theory.generate_valid_topology_some}.
        It is also sound: @{thm generate_valid_topology_some_sound}.*}

  fun generate_valid_topology_some :: "'v SecurityInvariant list \<Rightarrow> 'v list_graph \<Rightarrow> ('v list_graph)" where
    "generate_valid_topology_some [] G = G" |
    "generate_valid_topology_some (m#Ms) G = (if implc_sinvar m G
      then generate_valid_topology_some Ms G
      else delete_edges (generate_valid_topology_some Ms G) (minimalize_offending_overapprox (implc_sinvar m) (edgesL G) [] G)
      )"

  thm TopoS_Composition_Theory.generate_valid_topology_some_sound

  lemma generate_valid_topology_some_complies:
    "\<lbrakk> \<forall> (m_impl, m_spec) \<in> set M. SecurityInvariant_complies_formal_def m_impl m_spec;
       wf_list_graph (G::('v::vertex list_graph)) \<rbrakk> \<Longrightarrow>
       list_graph_to_graph (generate_valid_topology_some (get_impl M) G) =
       TopoS_Composition_Theory.generate_valid_topology_some (get_spec M) (edgesL G) (list_graph_to_graph G)"
    proof(induction M)
    case Nil thus ?case by(simp add: get_spec_def get_impl_def)
    next
    case (Cons m M)
      obtain m_impl m_spec where m: "m = (m_impl, m_spec)" by(cases m) blast
      from m have m_impl: "get_impl ((m_impl, m_spec) # M) = m_impl # (get_impl M)" by (simp add: get_impl_def)
      from m have m_spec: "get_spec ((m_impl, m_spec) # M) = m_spec # (get_spec M)" by (simp add: get_spec_def)

      from Cons.prems(1) m have complies_formal_def: "SecurityInvariant_complies_formal_def m_impl m_spec" by simp
      with Cons.prems(2) have impl_spec: "implc_sinvar m_impl G \<longleftrightarrow> c_sinvar m_spec (list_graph_to_graph G)"
        by (simp add: SecurityInvariant_complies_formal_def_def)

      from complies_formal_def
      have "\<And>G nP. wf_list_graph G \<Longrightarrow>
        (\<lambda>G nP. (c_sinvar m_spec) G) (list_graph_to_graph G) nP = (\<lambda>G nP. (implc_sinvar m_impl) G) G nP"
        by (simp add: SecurityInvariant_complies_formal_def_def)

      from minimalize_offending_overapprox_spec_impl[OF Cons.prems(2),
          of "(\<lambda>G nP. (c_sinvar m_spec) G)" "(\<lambda>G nP. (implc_sinvar m_impl) G)", OF this]
        (*TODO: because of funny type, horribly complex instantiation*)
      have "TopoS_Interface_impl.minimalize_offending_overapprox (implc_sinvar m_impl) fs keeps G =
            TopoS_withOffendingFlows.minimalize_offending_overapprox (c_sinvar m_spec) fs keeps (list_graph_to_graph G)"
        for fs keeps by simp
      from this[of "(edgesL G)"  "[]"] have minimalize_offending_overapprox_spec:
         "TopoS_Interface_impl.minimalize_offending_overapprox (implc_sinvar m_impl) (edgesL G) [] G =
          TopoS_withOffendingFlows.minimalize_offending_overapprox (c_sinvar m_spec) (edgesL G) [] (list_graph_to_graph G)" .

      from Cons show ?case
        apply(simp)
        apply(simp add: m m_impl m_spec)
        apply(intro conjI impI)
          apply (simp add: impl_spec; fail)
         apply (simp add: impl_spec; fail)
        apply(simp add: delete_edges_correct[symmetric])
        apply(simp add: list_graph_to_graph_def FiniteGraph.delete_edges_simp2)
        apply(simp add: minimalize_offending_overapprox_spec)
        by (simp add: list_graph_to_graph_def)
    qed

(*
subsection{*generate valid topology*}
  text{*tuned for invariants where we don't want to calculate all offending flows*}

  fun generate_valid_topology_SOME :: "'v SecurityInvariant list \<Rightarrow> 'v list_graph \<Rightarrow> ('v list_graph)" where
    "generate_valid_topology_SOME [] G = G" |
    "generate_valid_topology_SOME (m#Ms) G = (if implc_sinvar m G
      then generate_valid_topology_SOME Ms G
      else delete_edges (generate_valid_topology_SOME Ms G) (minimalize_offending_overapprox (implc_sinvar m) (edgesL G) [] G)
      )"

  thm TopoS_Composition_Theory.generate_valid_topology_SOME_sound

  (*TODO: show conformance to generate_valid_topology_some_sound*)
  (*TODO: won't work because of the SOME!
    I will probably have to show something like
       all_security_requirements_fulfilled (get_impl M) (generate_valid_topology_SOME (get_impl M) G)
    How can I do this without copy&pasting the proof of the spec?*)
  lemma generate_valid_topology_SOME_complies:
    "\<lbrakk> \<forall> (m_impl, m_spec) \<in> set M. SecurityInvariant_complies_formal_def m_impl m_spec;
       wf_list_graph (G::('v list_graph)) \<rbrakk> \<Longrightarrow>
       list_graph_to_graph (generate_valid_topology_SOME (get_impl M) G) =
       TopoS_Composition_Theory.generate_valid_topology_SOME (get_spec M) (list_graph_to_graph G)"
    proof(induction M)
    case Nil thus ?case by(simp add: get_spec_def get_impl_def)
    next
    case (Cons m M)
      obtain m_impl m_spec where m: "m = (m_impl, m_spec)" by(cases m) blast
      from m have m_impl: "get_impl ((m_impl, m_spec) # M) = m_impl # (get_impl M)" by (simp add: get_impl_def)
      from m have m_spec: "get_spec ((m_impl, m_spec) # M) = m_spec # (get_spec M)" by (simp add: get_spec_def)

      from Cons.prems(1) m have complies_formal_def:  "SecurityInvariant_complies_formal_def m_impl m_spec" by simp
      with Cons.prems(2) have impl_spec: "implc_sinvar m_impl G \<longleftrightarrow>  c_sinvar m_spec (list_graph_to_graph G)"
        by (simp add: SecurityInvariant_complies_formal_def_def)

      (*from minimalize_offending_overapprox_gives_some_offending_flow
      have "set (minimalize_offending_overapprox (implc_sinvar m_impl) (edgesL G) [] G)
        \<in> SecurityInvariant_withOffendingFlows.set_offending_flows (c_sinvar_m_spec_bound_to_nP) (list_graph_to_graph G) nP" sorry
      *)

      have my_todo: "set (minimalize_offending_overapprox (implc_sinvar m_impl) (edgesL G) [] G)
        \<in> c_offending_flows m_spec (list_graph_to_graph G)" sorry

      from my_todo[simplified list_graph_to_graph_def] have how_do_i_solve_this:
      "set (minimalize_offending_overapprox (implc_sinvar m_impl) (edgesL G) [] G) =
       (SOME F. F \<in> c_offending_flows m_spec \<lparr>nodes = set (nodesL G), edges = set (edgesL G)\<rparr>)" sorry

      from Cons show ?case
        apply(simp)
        apply(simp add: m m_impl m_spec)
        apply(intro conjI impI)
          apply (simp add: impl_spec; fail)
         apply (simp add: impl_spec; fail)
        apply(simp add: delete_edges_correct[symmetric])
        apply(simp add: list_graph_to_graph_def FiniteGraph.delete_edges_simp2)
        using how_do_i_solve_this by simp
    qed
*)

end