header {* Refinement to Efficient Code *}
(*
  Author: Peter Lammich
  Inspired by previous version of Alexander Schimpf.
*)
theory LTL_to_GBA_impl
imports
  "~~/src/HOL/Library/Char_ord"
  "~~/src/HOL/Library/List_lexord"
  "~~/src/HOL/Library/Code_Char"
  LTL_to_GBA
  "../Datatype_Order_Generator/Order_Generator"
  "../CAVA_Automata/Automata_Impl"
  "../CAVA_Automata/CAVA_Base/CAVA_Code_Target"
begin

subsection {* Parametricity Setup Boilerplate *}

subsubsection {* LTL Formulas *}
derive linorder ltln

inductive_set ltln_rel for R where
  "(LTLnTrue,LTLnTrue) \<in> ltln_rel R"
| "(LTLnFalse,LTLnFalse) \<in> ltln_rel R"
| "(a,a')\<in>R \<Longrightarrow> (LTLnProp a,LTLnProp a') \<in> ltln_rel R"
| "(a,a')\<in>R \<Longrightarrow> (LTLnNProp a,LTLnNProp a') \<in> ltln_rel R"
| "\<lbrakk>(a,a')\<in>ltln_rel R; (b,b')\<in>ltln_rel R\<rbrakk>
  \<Longrightarrow> (LTLnAnd a b,LTLnAnd a' b') \<in> ltln_rel R"
| "\<lbrakk>(a,a')\<in>ltln_rel R; (b,b')\<in>ltln_rel R\<rbrakk>
  \<Longrightarrow> (LTLnOr a b,LTLnOr a' b') \<in> ltln_rel R"
| "\<lbrakk>(a,a')\<in>ltln_rel R\<rbrakk> \<Longrightarrow> (LTLnNext a,LTLnNext a') \<in> ltln_rel R"
| "\<lbrakk>(a,a')\<in>ltln_rel R; (b,b')\<in>ltln_rel R\<rbrakk>
  \<Longrightarrow> (LTLnUntil a b,LTLnUntil a' b') \<in> ltln_rel R"
| "\<lbrakk>(a,a')\<in>ltln_rel R; (b,b')\<in>ltln_rel R\<rbrakk>
  \<Longrightarrow> (LTLnRelease a b,LTLnRelease a' b') \<in> ltln_rel R"

lemmas ltln_rel_induct[induct set]
  = ltln_rel.induct[unfolded relAPP_def[of ltln_rel, symmetric]]
lemmas ltln_rel_cases[cases set]
  = ltln_rel.cases[unfolded relAPP_def[of ltln_rel, symmetric]]
lemmas ltln_rel_intros
  = ltln_rel.intros[unfolded relAPP_def[of ltln_rel, symmetric]]

inductive_simps ltln_rel_left_simps[unfolded relAPP_def[of ltln_rel, symmetric]]:
  "(LTLnTrue,z) \<in> ltln_rel R"
  "(LTLnFalse,z) \<in> ltln_rel R"
  "(LTLnProp p, z) \<in> ltln_rel R"
  "(LTLnNProp p, z) \<in> ltln_rel R"
  "(LTLnAnd a b, z) \<in> ltln_rel R"
  "(LTLnOr a b, z) \<in> ltln_rel R"
  "(LTLnNext a, z) \<in> ltln_rel R"
  "(LTLnUntil a b, z) \<in> ltln_rel R"
  "(LTLnRelease a b, z) \<in> ltln_rel R"

lemma ltln_rel_sv[relator_props]:
  assumes SV: "single_valued R"
  shows "single_valued (\<langle>R\<rangle>ltln_rel)"
proof (intro single_valuedI allI impI)
  fix x y z
  assume "(x, y) \<in> \<langle>R\<rangle>ltln_rel" "(x, z) \<in> \<langle>R\<rangle>ltln_rel"
  thus "y=z"
    apply (induction arbitrary: z)
    apply (simp (no_asm_use) only: ltln_rel_left_simps,
      blast intro: single_valuedD[OF SV])+
    done
qed

lemma ltln_rel_id[relator_props]: "\<lbrakk> R = Id \<rbrakk> \<Longrightarrow> \<langle>R\<rangle>ltln_rel = Id"
proof (intro equalityI subsetI, clarsimp_all)
  fix a b
  assume "(a,b)\<in>\<langle>Id\<rangle>ltln_rel"
  thus "a=b"
    by induction auto
next
  fix a
  show "(a,a)\<in>\<langle>Id\<rangle>ltln_rel"
    by (induction a) (auto intro: ltln_rel_intros)
qed

lemma ltln_rel_id_simp[simp]:  "\<langle>Id\<rangle>ltln_rel = Id" by (rule ltln_rel_id) simp

consts i_ltln :: "interface \<Rightarrow> interface"
lemmas [autoref_rel_intf] = REL_INTFI[of ltln_rel i_ltln]

thm ltln_rel_intros[no_vars]

lemma ltln_con_param[param, autoref_rules]:
  "(LTLnTrue, LTLnTrue) \<in> \<langle>R\<rangle>ltln_rel"
  "(LTLnFalse, LTLnFalse) \<in> \<langle>R\<rangle>ltln_rel"
  "(LTLnProp, LTLnProp) \<in> R \<rightarrow> \<langle>R\<rangle>ltln_rel"
  "(LTLnNProp, LTLnNProp) \<in> R \<rightarrow> \<langle>R\<rangle>ltln_rel"
  "(LTLnAnd, LTLnAnd) \<in> \<langle>R\<rangle>ltln_rel \<rightarrow> \<langle>R\<rangle>ltln_rel \<rightarrow> \<langle>R\<rangle>ltln_rel"
  "(LTLnOr, LTLnOr) \<in> \<langle>R\<rangle>ltln_rel \<rightarrow> \<langle>R\<rangle>ltln_rel \<rightarrow> \<langle>R\<rangle>ltln_rel"
  "(LTLnNext, LTLnNext) \<in> \<langle>R\<rangle>ltln_rel \<rightarrow> \<langle>R\<rangle>ltln_rel"
  "(LTLnUntil, LTLnUntil) \<in> \<langle>R\<rangle>ltln_rel \<rightarrow> \<langle>R\<rangle>ltln_rel \<rightarrow> \<langle>R\<rangle>ltln_rel"
  "(LTLnRelease, LTLnRelease) \<in> \<langle>R\<rangle>ltln_rel \<rightarrow> \<langle>R\<rangle>ltln_rel \<rightarrow> \<langle>R\<rangle>ltln_rel"
  by (auto intro: ltln_rel_intros)

lemma case_ltln_param[param, autoref_rules]:
  "(case_ltln,case_ltln) \<in> Rv \<rightarrow> Rv \<rightarrow> (R \<rightarrow> Rv)
                \<rightarrow> (R \<rightarrow> Rv)
                  \<rightarrow> (\<langle>R\<rangle>ltln_rel \<rightarrow> \<langle>R\<rangle>ltln_rel \<rightarrow> Rv)
                    \<rightarrow> (\<langle>R\<rangle>ltln_rel \<rightarrow> \<langle>R\<rangle>ltln_rel \<rightarrow> Rv)
                      \<rightarrow> (\<langle>R\<rangle>ltln_rel \<rightarrow> Rv)
                        \<rightarrow> (\<langle>R\<rangle>ltln_rel \<rightarrow> \<langle>R\<rangle>ltln_rel \<rightarrow> Rv)
                          \<rightarrow> (\<langle>R\<rangle>ltln_rel \<rightarrow> \<langle>R\<rangle>ltln_rel \<rightarrow> Rv) \<rightarrow> \<langle>R\<rangle>ltln_rel \<rightarrow> Rv"
  apply (clarsimp)
  apply (case_tac ai, simp_all add: ltln_rel_left_simps)
  apply (clarsimp_all)
  apply parametricity+
  done

lemma rec_ltln_param[param, autoref_rules]:
  "(rec_ltln,rec_ltln) \<in> Rv \<rightarrow> Rv \<rightarrow> (R \<rightarrow> Rv)
                \<rightarrow> (R \<rightarrow> Rv)
                  \<rightarrow> (\<langle>R\<rangle>ltln_rel \<rightarrow> \<langle>R\<rangle>ltln_rel \<rightarrow> Rv \<rightarrow> Rv \<rightarrow> Rv)
                    \<rightarrow> (\<langle>R\<rangle>ltln_rel \<rightarrow> \<langle>R\<rangle>ltln_rel \<rightarrow> Rv \<rightarrow> Rv \<rightarrow> Rv)
                      \<rightarrow> (\<langle>R\<rangle>ltln_rel \<rightarrow> Rv \<rightarrow> Rv)
                        \<rightarrow> (\<langle>R\<rangle>ltln_rel \<rightarrow> \<langle>R\<rangle>ltln_rel \<rightarrow> Rv \<rightarrow> Rv \<rightarrow> Rv)
                          \<rightarrow> (\<langle>R\<rangle>ltln_rel \<rightarrow> \<langle>R\<rangle>ltln_rel \<rightarrow> Rv \<rightarrow> Rv \<rightarrow> Rv)
                            \<rightarrow> \<langle>R\<rangle>ltln_rel \<rightarrow> Rv"
proof clarsimp
  case goal1
  from goal1(10)
  show ?case
    apply (induction)
    using goal1(1-9)
    apply simp_all
    apply parametricity+
    done
qed

lemma case_ltln_mono[refine_mono]:
  assumes "\<phi> = LTLnTrue \<Longrightarrow> a\<le>a'"
  assumes "\<phi> = LTLnFalse \<Longrightarrow> b\<le>b'"
  assumes "\<And>p. \<phi> = LTLnProp p \<Longrightarrow> c p\<le>c' p"
  assumes "\<And>p. \<phi> = LTLnNProp p \<Longrightarrow> d p\<le>d' p"
  assumes "\<And>\<mu> \<nu>. \<phi> = LTLnAnd \<mu> \<nu> \<Longrightarrow> e \<mu> \<nu>\<le>e' \<mu> \<nu>"
  assumes "\<And>\<mu> \<nu>. \<phi> = LTLnOr \<mu> \<nu> \<Longrightarrow> f \<mu> \<nu>\<le>f' \<mu> \<nu>"
  assumes "\<And>\<mu>. \<phi> = LTLnNext \<mu> \<Longrightarrow> g \<mu>\<le>g' \<mu>"
  assumes "\<And>\<mu> \<nu>. \<phi> = LTLnUntil \<mu> \<nu> \<Longrightarrow> h \<mu> \<nu>\<le>h' \<mu> \<nu>"
  assumes "\<And>\<mu> \<nu>. \<phi> = LTLnRelease \<mu> \<nu> \<Longrightarrow> i \<mu> \<nu>\<le>i' \<mu> \<nu>"
  shows "case_ltln a b c d e f g h i \<phi> \<le> case_ltln a' b' c' d' e' f' g' h' i' \<phi>"
  using assms
  apply (cases \<phi>)
  apply simp_all
  done

primrec ltln_eq where
  "ltln_eq eq LTLnTrue f \<longleftrightarrow> (case f of LTLnTrue \<Rightarrow> True | _ \<Rightarrow> False)"
| "ltln_eq eq LTLnFalse f \<longleftrightarrow> (case f of LTLnFalse \<Rightarrow> True | _ \<Rightarrow> False)"
| "ltln_eq eq (LTLnProp p) f \<longleftrightarrow> (case f of LTLnProp p' \<Rightarrow> eq p p' | _ \<Rightarrow> False)"
| "ltln_eq eq (LTLnNProp p) f \<longleftrightarrow> (case f of LTLnNProp p' \<Rightarrow> eq p p' | _ \<Rightarrow> False)"
| "ltln_eq eq (LTLnAnd \<mu> \<nu>) f
  \<longleftrightarrow> (case f of LTLnAnd \<mu>' \<nu>' \<Rightarrow> ltln_eq eq \<mu> \<mu>' \<and> ltln_eq eq \<nu> \<nu>' | _ \<Rightarrow> False)"
| "ltln_eq eq (LTLnOr \<mu> \<nu>) f
  \<longleftrightarrow> (case f of LTLnOr \<mu>' \<nu>' \<Rightarrow> ltln_eq eq \<mu> \<mu>' \<and> ltln_eq eq \<nu> \<nu>' | _ \<Rightarrow> False)"
| "ltln_eq eq (LTLnNext \<phi>) f
  \<longleftrightarrow> (case f of LTLnNext \<phi>' \<Rightarrow> ltln_eq eq \<phi> \<phi>' | _ \<Rightarrow> False)"
| "ltln_eq eq (LTLnUntil \<mu> \<nu>) f
  \<longleftrightarrow> (case f of LTLnUntil \<mu>' \<nu>' \<Rightarrow> ltln_eq eq \<mu> \<mu>' \<and> ltln_eq eq \<nu> \<nu>' | _ \<Rightarrow> False)"
| "ltln_eq eq (LTLnRelease \<mu> \<nu>) f
  \<longleftrightarrow> (case f of
    LTLnRelease \<mu>' \<nu>' \<Rightarrow> ltln_eq eq \<mu> \<mu>' \<and> ltln_eq eq \<nu> \<nu>'
  | _ \<Rightarrow> False)"

lemma ltln_eq_autoref[autoref_rules]:
  assumes EQP: "(eq,op=) \<in> R \<rightarrow> R \<rightarrow> bool_rel"
  shows "(ltln_eq eq, op=) \<in> \<langle>R\<rangle>ltln_rel \<rightarrow> \<langle>R\<rangle>ltln_rel \<rightarrow> bool_rel"
proof (intro fun_relI)
  fix \<mu>' \<mu> \<nu>' \<nu>
  assume "(\<mu>',\<mu>)\<in>\<langle>R\<rangle>ltln_rel" and "(\<nu>',\<nu>)\<in>\<langle>R\<rangle>ltln_rel"
  thus "(ltln_eq eq \<mu>' \<nu>', \<mu>=\<nu>)\<in>bool_rel"
    apply (induction arbitrary: \<nu>' \<nu>)
    apply (erule ltln_rel_cases, simp_all) []
    apply (erule ltln_rel_cases, simp_all) []
    apply (erule ltln_rel_cases,
      simp_all add: EQP[THEN fun_relD, THEN fun_relD, THEN IdD]) []
    apply (erule ltln_rel_cases,
      simp_all add: EQP[THEN fun_relD, THEN fun_relD, THEN IdD]) []
    apply (rotate_tac -1)
    apply (erule ltln_rel_cases, simp_all) []
    apply (rotate_tac -1)
    apply (erule ltln_rel_cases, simp_all) []
    apply (rotate_tac -1)
    apply (erule ltln_rel_cases, simp_all) []
    apply (rotate_tac -1)
    apply (erule ltln_rel_cases, simp_all) []
    apply (rotate_tac -1)
    apply (erule ltln_rel_cases, simp_all) []
    done
qed

lemma ltln_dflt_cmp[autoref_rules_raw]:
  assumes "PREFER_id R"
  shows
  "(dflt_cmp op \<le> op <, dflt_cmp op \<le> op <)
  \<in> \<langle>R\<rangle>ltln_rel \<rightarrow> \<langle>R\<rangle>ltln_rel \<rightarrow> comp_res_rel"
  using assms
  by simp

type_synonym
  node_name_impl = node_name

abbreviation (input) "node_name_rel \<equiv> Id :: (node_name_impl\<times>node_name) set"

lemma case_ltln_gtransfer:
  assumes
  "\<gamma> ai \<le> a"
  "\<gamma> bi \<le> b"
  "\<And>a. \<gamma> (ci a) \<le> c a"
  "\<And>a. \<gamma> (di a) \<le> d a"
  "\<And>ltln1 ltln2. \<gamma> (ei ltln1 ltln2) \<le> e ltln1 ltln2"
  "\<And>ltln1 ltln2. \<gamma> (fi ltln1 ltln2) \<le> f ltln1 ltln2"
  "\<And>ltln. \<gamma> (gi ltln) \<le> g ltln"
  "\<And>ltln1 ltln2. \<gamma> (hi ltln1 ltln2) \<le> h ltln1 ltln2"
  "\<And>ltln1 ltln2. \<gamma> (ii ltln1 ltln2) \<le> i ltln1 ltln2"
  shows "\<gamma> (case_ltln ai bi ci di ei fi gi hi ii \<phi>)
    \<le> (case_ltln a b c d e f g h i \<phi>)"
  apply (cases \<phi>)
  apply (auto intro: assms)
  done

lemmas [refine_transfer]
  = case_ltln_gtransfer[where \<gamma>=nres_of] case_ltln_gtransfer[where \<gamma>=RETURN]

lemma [refine_transfer]:
  assumes
  "ai \<noteq> dSUCCEED"
  "bi \<noteq> dSUCCEED"
  "\<And>a. ci a \<noteq> dSUCCEED"
  "\<And>a. di a \<noteq> dSUCCEED"
  "\<And>ltln1 ltln2. ei ltln1 ltln2 \<noteq> dSUCCEED"
  "\<And>ltln1 ltln2. fi ltln1 ltln2 \<noteq> dSUCCEED"
  "\<And>ltln. gi ltln \<noteq> dSUCCEED"
  "\<And>ltln1 ltln2. hi ltln1 ltln2 \<noteq> dSUCCEED"
  "\<And>ltln1 ltln2. ii ltln1 ltln2 \<noteq> dSUCCEED"
  shows "case_ltln ai bi ci di ei fi gi hi ii \<phi> \<noteq> dSUCCEED"
  apply (cases \<phi>)
  apply (simp_all add: assms)
  done

subsubsection {* Nodes *}

record 'a node_impl =
  name_impl   :: node_name_impl
  incoming_impl :: "(node_name_impl,unit) RBT_Impl.rbt"
  new_impl :: "'a frml list"
  old_impl :: "'a frml list"
  next_impl :: "'a frml list"

definition node_rel where node_rel_def_internal: "node_rel Re R \<equiv> {(
  \<lparr> name_impl = namei,
    incoming_impl = inci,
    new_impl = newi,
    old_impl = oldi,
    next_impl = nexti,
    \<dots> = morei
  \<rparr>,
  \<lparr> name = name,
    incoming = inc,
    new=new,
    old=old,
    next = next,
    \<dots> = more
  \<rparr> ) | namei name inci inc newi new oldi old nexti next morei more.
    (namei,name)\<in>node_name_rel
  \<and> (inci,inc)\<in>\<langle>node_name_rel\<rangle>dflt_rs_rel
  \<and> (newi,new)\<in>\<langle>\<langle>R\<rangle>ltln_rel\<rangle>lss.rel
  \<and> (oldi,old)\<in>\<langle>\<langle>R\<rangle>ltln_rel\<rangle>lss.rel
  \<and> (nexti,next)\<in>\<langle>\<langle>R\<rangle>ltln_rel\<rangle>lss.rel
  \<and> (morei,more)\<in>Re
  }"

lemma node_rel_def: "\<langle>Re,R\<rangle>node_rel = {(
  \<lparr> name_impl = namei,
    incoming_impl = inci,
    new_impl = newi,
    old_impl = oldi,
    next_impl = nexti,
    \<dots> = morei
  \<rparr>,
  \<lparr> name = name,
    incoming = inc,
    new=new,
    old=old,
    next = next,
    \<dots> = more
  \<rparr> ) | namei name inci inc newi new oldi old nexti next morei more.
    (namei,name)\<in>node_name_rel
  \<and> (inci,inc)\<in>\<langle>node_name_rel\<rangle>dflt_rs_rel
  \<and> (newi,new)\<in>\<langle>\<langle>R\<rangle>ltln_rel\<rangle>lss.rel
  \<and> (oldi,old)\<in>\<langle>\<langle>R\<rangle>ltln_rel\<rangle>lss.rel
  \<and> (nexti,next)\<in>\<langle>\<langle>R\<rangle>ltln_rel\<rangle>lss.rel
  \<and> (morei,more)\<in>Re
  }" by (simp add: node_rel_def_internal relAPP_def)

lemma node_rel_sv[relator_props]:
  "single_valued Re \<Longrightarrow> single_valued R \<Longrightarrow> single_valued (\<langle>Re,R\<rangle>node_rel)"
  apply (rule single_valuedI)
  apply (simp add: node_rel_def)
  apply (auto
    dest: single_valuedD lss.rel_sv[OF ltln_rel_sv] map2set_rel_sv[OF ahm_rel_sv]
    dest: single_valuedD[
      OF map2set_rel_sv[OF rbt_map_rel_sv[OF single_valued_Id single_valued_Id]]
    ])
  done

consts i_node :: "interface \<Rightarrow> interface \<Rightarrow> interface"

lemmas [autoref_rel_intf] = REL_INTFI[of node_rel i_node]

lemma [autoref_rules]: "(node_impl_ext, node_ext) \<in>
  node_name_rel
  \<rightarrow> \<langle>node_name_rel\<rangle>dflt_rs_rel
  \<rightarrow> \<langle>\<langle>R\<rangle>ltln_rel\<rangle>lss.rel
  \<rightarrow> \<langle>\<langle>R\<rangle>ltln_rel\<rangle>lss.rel
  \<rightarrow> \<langle>\<langle>R\<rangle>ltln_rel\<rangle>lss.rel
  \<rightarrow> Re
  \<rightarrow> \<langle>Re,R\<rangle>node_rel"
  unfolding node_rel_def
  by auto

term node.incoming_update

lemma [autoref_rules]:
  "(node_impl.name_impl_update,node.name_update)
  \<in> (node_name_rel \<rightarrow> node_name_rel) \<rightarrow> \<langle>Re,R\<rangle>node_rel \<rightarrow> \<langle>Re,R\<rangle>node_rel"
  "(node_impl.incoming_impl_update,node.incoming_update)
  \<in> (\<langle>node_name_rel\<rangle>dflt_rs_rel \<rightarrow> \<langle>node_name_rel\<rangle>dflt_rs_rel)
    \<rightarrow> \<langle>Re,R\<rangle>node_rel
    \<rightarrow> \<langle>Re,R\<rangle>node_rel"
  "(node_impl.new_impl_update,node.new_update)
  \<in> (\<langle>\<langle>R\<rangle>ltln_rel\<rangle>lss.rel \<rightarrow> \<langle>\<langle>R\<rangle>ltln_rel\<rangle>lss.rel) \<rightarrow> \<langle>Re,R\<rangle>node_rel \<rightarrow> \<langle>Re,R\<rangle>node_rel"
  "(node_impl.old_impl_update,node.old_update)
  \<in> (\<langle>\<langle>R\<rangle>ltln_rel\<rangle>lss.rel \<rightarrow> \<langle>\<langle>R\<rangle>ltln_rel\<rangle>lss.rel) \<rightarrow> \<langle>Re,R\<rangle>node_rel \<rightarrow> \<langle>Re,R\<rangle>node_rel"
  "(node_impl.next_impl_update,node.next_update)
  \<in> (\<langle>\<langle>R\<rangle>ltln_rel\<rangle>lss.rel \<rightarrow> \<langle>\<langle>R\<rangle>ltln_rel\<rangle>lss.rel) \<rightarrow> \<langle>Re,R\<rangle>node_rel \<rightarrow> \<langle>Re,R\<rangle>node_rel"
  "(node_impl.more_update,node.more_update)
  \<in> (Re \<rightarrow> Re) \<rightarrow> \<langle>Re,R\<rangle>node_rel \<rightarrow> \<langle>Re,R\<rangle>node_rel"
  unfolding node_rel_def
  by (auto dest: fun_relD)

term name
lemma [autoref_rules]:
  "(node_impl.name_impl,node.name)\<in>\<langle>Re,R\<rangle>node_rel \<rightarrow> node_name_rel"
  "(node_impl.incoming_impl,node.incoming)
  \<in> \<langle>Re,R\<rangle>node_rel \<rightarrow> \<langle>node_name_rel\<rangle>dflt_rs_rel"
  "(node_impl.new_impl,node.new)\<in>\<langle>Re,R\<rangle>node_rel \<rightarrow> \<langle>\<langle>R\<rangle>ltln_rel\<rangle>lss.rel"
  "(node_impl.old_impl,node.old)\<in>\<langle>Re,R\<rangle>node_rel \<rightarrow> \<langle>\<langle>R\<rangle>ltln_rel\<rangle>lss.rel"
  "(node_impl.next_impl,node.next)\<in>\<langle>Re,R\<rangle>node_rel \<rightarrow> \<langle>\<langle>R\<rangle>ltln_rel\<rangle>lss.rel"
  "(node_impl.more, node.more)\<in>\<langle>Re,R\<rangle>node_rel \<rightarrow> Re"
  unfolding node_rel_def by auto

subsection {* Massaging the Abstract Algorithm *}
text {*
  In a first step, we do some refinement steps on the abstract data structures,
  with the goal to make the algorithm more efficient.
*}

subsubsection {* Creation of the Nodes *}
text {*
  In the expand-algorithm, we replace nested conditionals by case-distinctions,
  and slightly stratify the code.
*}

abbreviation (input) "expand2 exp n ns \<phi> n1 nx1 n2 \<equiv> do {
    (nm, nds) \<leftarrow> exp (
      n\<lparr>
        new := insert n1 (new n),
        old := insert \<phi> (old n),
        next := nx1 \<union> next n \<rparr>,
      ns);
    exp (n\<lparr> name := nm, new := n2 \<union> new n, old := {\<phi>} \<union> old n \<rparr>, nds)
  }"

context begin interpretation LTL_Syntax .

definition "expand_aimpl \<equiv> REC\<^sub>T (\<lambda>expand (n,ns).
      if new n = {} then (
        if (\<exists>n'\<in>ns. old n' = old n \<and> next n' = next n) then
          RETURN (name n, upd_incoming n ns)
        else do {
          ASSERT (n \<notin> ns);
          ASSERT (name n \<notin> name`ns);
          expand (\<lparr>
            name=expand_new_name (name n),
            incoming={name n},
            new=next n,
            old={},
            next={} \<rparr>,
            insert n ns)
        }
      ) else do {
        \<phi> \<leftarrow> SPEC (\<lambda>x. x\<in>(new n));
        let n = n\<lparr> new := new n - {\<phi>} \<rparr>;
        case \<phi> of
          prop\<^sub>n(q) \<Rightarrow>
            if nprop\<^sub>n(q)\<in>old n then RETURN (name n, ns)
            else expand (n\<lparr> old := {\<phi>} \<union> old n \<rparr>, ns)
        | nprop\<^sub>n(q) \<Rightarrow>
            if prop\<^sub>n(q)\<in>old n then RETURN (name n, ns)
            else expand (n\<lparr> old := {\<phi>} \<union> old n \<rparr>, ns)
        | true\<^sub>n \<Rightarrow> expand (n\<lparr> old := {\<phi>} \<union> old n \<rparr>, ns)
        | false\<^sub>n \<Rightarrow> RETURN (name n, ns)
        | \<nu> and\<^sub>n \<mu> \<Rightarrow> expand (n\<lparr>
            new := insert \<nu> (insert \<mu> (new n)),
            old := {\<phi>} \<union> old n,
            next := next n \<rparr>, ns)
        | X\<^sub>n \<nu> \<Rightarrow> expand
            (n\<lparr> new := new n, old := {\<phi>} \<union> old n, next := insert \<nu> (next n) \<rparr>, ns)
        | \<mu> or\<^sub>n \<nu> \<Rightarrow> expand2 expand n ns \<phi> \<mu> {} {\<nu>}
        | \<mu> U\<^sub>n \<nu> \<Rightarrow> expand2 expand n ns \<phi> \<mu> {\<phi>} {\<nu>}
        | \<mu> V\<^sub>n \<nu> \<Rightarrow> expand2 expand n ns \<phi> \<nu> {\<phi>} {\<mu>,\<nu>}
        (*| _ \<Rightarrow> do {
          (nm, nds) \<leftarrow> expand (
            n\<lparr>
              new := new1 \<phi> \<union> new n,
              old := {\<phi>} \<union> old n,
              next := next1 \<phi> \<union> next n \<rparr>,
            ns);
          expand (n\<lparr> name := nm, new := new2 \<phi> \<union> new n, old := {\<phi>} \<union> old n \<rparr>, nds)
        }*)
      }
     )"

end

lemma expand_aimpl_refine:
  fixes n_ns :: "('a node \<times> _)"
  defines "R \<equiv> Id \<inter> {(_,(n,ns)). \<forall>n'\<in>ns. n > name n'}"
  defines "R' \<equiv> Id \<inter> {(_,(n,ns)). \<forall>n'\<in>ns. name n > name n'}"
  assumes [refine]: "(n_ns',n_ns)\<in>R'"
  shows "expand_aimpl n_ns' \<le> \<Down>R (expand\<^sub>T n_ns)"
  using [[goals_limit = 1]]
proof -
  have [relator_props]: "single_valued R"
    by (auto simp add: R_def intro: single_valuedI)
  have [relator_props]: "single_valued R'"
    by (auto simp add: R'_def intro: single_valuedI)

  {
    fix n :: "'a node" and ns and n' ns'
    assume "((n', ns'), (n, ns)) \<in> R'"
    hence "(RETURN (name n', ns') \<le> \<Down> R (RETURN (name n, ns)))"
      by (auto simp: R_def R'_def pw_le_iff refine_pw_simps)
  } note aux = this

  show ?thesis
    unfolding expand_aimpl_def expand\<^sub>T_def
    apply refine_rcg
    apply (simp add: R_def R'_def)
    apply (simp add: R_def R'_def)
    apply (auto simp add: R_def R'_def upd_incoming_def) []
    apply (auto simp add: R_def R'_def upd_incoming_def) []
    apply (auto simp add: R_def R'_def upd_incoming_def) []
    apply rprems
    apply (auto simp: R'_def expand_new_name_def) []
    apply (simp add: R'_def)

    apply (auto split: ltln.split) []
    apply (fastforce simp: R'_def) []
    apply (refine_rcg aux)
    apply (refine_rcg aux)
    apply (auto simp: R'_def) []
    apply (auto simp: R'_def) []

    apply (fastforce simp: R'_def) []
    apply (refine_rcg aux)
    apply (fastforce simp: R'_def) []
    apply (fastforce simp: R'_def) []
    apply (fastforce simp: R'_def) []
    apply (fastforce simp: R'_def) []
    apply (refine_rcg, rprems, (fastforce simp: R_def R'_def)+) []
    apply (fastforce simp: R'_def) []
    apply (refine_rcg, rprems, (fastforce simp: R_def R'_def)+) []
    apply (refine_rcg, rprems, (fastforce simp: R_def R'_def)+) []
    done
qed

thm create_graph_def
definition "create_graph_aimpl \<phi> = do {
  (_, nds) \<leftarrow>
  expand_aimpl
   (\<lparr>name = expand_new_name expand_init, incoming = {expand_init},
       new = {\<phi>}, old = {}, next = {}\<rparr>,
    {});
  RETURN nds
}"

lemma create_graph_aimpl_refine: "create_graph_aimpl \<phi> \<le> \<Down>Id (create_graph\<^sub>T \<phi>)"
  unfolding create_graph_aimpl_def create_graph\<^sub>T_def
  apply (refine_rcg expand_aimpl_refine)
  apply auto
  done

subsubsection {* Creation of GBA from Nodes *}

text {*
  We summarize creation of the GBA and renaming of the nodes into one step
*}
lemma create_name_gba_alt: "create_name_gba \<phi> = do {
  nds \<leftarrow> create_graph\<^sub>T \<phi>;
  ASSERT (nds_invars nds);
  RETURN (gba_rename_ext (\<lambda>_. ()) name (create_gba_from_nodes \<phi> nds))
  }"
proof -
  have [simp]: "\<And>nds. frg_V (create_gba_from_nodes \<phi> nds) = nds"
    by (auto simp: create_gba_from_nodes_def)

  show ?thesis
    unfolding create_name_gba_def create_gba_def
    by simp
qed

text {* In the following, we implement the componenents of the
  renamed GBA separately.
*}

text {* \paragraph{Successor Function} *}

definition "build_succ nds =
  FOREACH
    nds (\<lambda>q' s.
    FOREACH
      (incoming q') (\<lambda>qn s.
        if qn=expand_init then
          RETURN s
        else
          RETURN (s(qn \<mapsto> insert (name q') (the_default {} (s qn))))
    ) s
  ) Map.empty"

lemma build_succ_aux1:
  assumes [simp]: "finite nds"
  assumes [simp]: "\<And>q. q\<in>nds \<Longrightarrow> finite (incoming q)"
  shows "build_succ nds \<le> SPEC (\<lambda>r. r = (\<lambda>qn.
  dflt_None_set {qn'. \<exists>q'.
    q'\<in>nds \<and> qn' = name q' \<and> qn\<in>incoming q' \<and> qn\<noteq>expand_init
  }))"
  unfolding build_succ_def
  apply (refine_rcg refine_vcg
    FOREACH_rule[where
      I="\<lambda>it s. s = (\<lambda>qn. dflt_None_set {qn'. \<exists>q'. q'\<in>nds-it \<and> qn' = name q'
    \<and> qn\<in>incoming q' \<and> qn\<noteq>expand_init })"])

  apply (simp_all add: dflt_None_set_def) [2]
  apply (rename_tac q' it s)
  apply (rule_tac I="\<lambda>it2 s. s =
    (\<lambda>qn. dflt_None_set (
      {qn'. \<exists>q'. q'\<in>nds-it \<and> qn' = name q' \<and> qn\<in>incoming q' \<and> qn\<noteq>expand_init } \<union>
      {qn' . qn'=name q' \<and> qn\<in>incoming q' - it2 \<and> qn\<noteq>expand_init} ))"
    in FOREACH_rule)

  apply auto []

  apply (simp_all add: dflt_None_set_def)

  apply (refine_rcg refine_vcg)
  apply (auto simp: dflt_None_set_def intro!: ext) []
  apply (rule ext, (auto) [])+
  done

lemma build_succ_aux2:
  assumes NINIT: "expand_init \<notin> name`nds"
  assumes CL: "\<And>nd. nd\<in>nds \<Longrightarrow> incoming nd \<subseteq> insert expand_init (name`nds)"
  shows
  "(\<lambda>qn. dflt_None_set
    {qn'. \<exists>q'. q'\<in>nds \<and> qn' = name q' \<and> qn\<in>incoming q' \<and> qn\<noteq>expand_init })
  = (\<lambda>qn. dflt_None_set (succ_of_E
       (rename_E name {(q, q'). q \<in> nds \<and> q' \<in> nds \<and> name q \<in> incoming q'}) qn))"
  (is "(\<lambda>qn. dflt_None_set (?L qn)) = (\<lambda>qn. dflt_None_set (?R qn))")
  apply (intro ext)
  apply (fo_rule arg_cong)
proof (intro ext equalityI subsetI)
  fix qn x
  assume "x\<in>?R qn"
  thus "x\<in>?L qn" using NINIT
    by (force simp: succ_of_E_def)
next
  fix qn x
  assume XL: "x\<in>?L qn"
  show "x\<in>?R qn"
  proof (cases "qn = expand_init")
    case False
    from XL obtain q' where
      A: "q'\<in>nds" "qn\<in>incoming q'"
      and [simp]: "x=name q'"
      by auto
    from False obtain q where B: "q\<in>nds" and [simp]: "qn = name q"
      using CL A by auto

    from A B show "x\<in>?R qn"
      by (auto simp: succ_of_E_def image_def)
  next
    case True[simp]
    from XL show "x\<in>?R qn" by simp
  qed
qed

lemma build_succ_correct:
  assumes NINIT: "expand_init \<notin> name`nds"
  assumes FIN: "finite nds"
  assumes CL: "\<And>nd. nd\<in>nds \<Longrightarrow> incoming nd \<subseteq> insert expand_init (name`nds)"
  shows "build_succ nds \<le> SPEC (\<lambda>r.
    E_of_succ (\<lambda>qn. the_default {} (r qn))
    = rename_E (\<lambda>u. name u) {(q, q'). q \<in> nds \<and> q' \<in> nds \<and> name q \<in> incoming q'})"
proof -
  from FIN CL have FIN': "\<And>q. q\<in>nds \<Longrightarrow> finite (incoming q)"
    by (metis finite_imageI finite_insert infinite_super)

  note build_succ_aux1[OF FIN FIN']
  also note build_succ_aux2[OF NINIT CL]
  finally show ?thesis
    by (rule order_trans) auto
qed

text {* \paragraph{ Accepting Sets} *}

context begin interpretation LTL_Syntax .
primrec until_frmlsn :: "'a frml \<Rightarrow> ('a frml \<times> 'a frml) set" where
  "until_frmlsn (\<mu> and\<^sub>n \<psi>) = (until_frmlsn \<mu>) \<union> (until_frmlsn \<psi>)"
| "until_frmlsn (X\<^sub>n \<mu>) = until_frmlsn \<mu>"
| "until_frmlsn (\<mu> U\<^sub>n \<psi>) = insert (\<mu>, \<psi>) ((until_frmlsn \<mu>) \<union> (until_frmlsn \<psi>))"
| "until_frmlsn (\<mu> V\<^sub>n \<psi>) = (until_frmlsn \<mu>) \<union> (until_frmlsn \<psi>)"
| "until_frmlsn (\<mu> or\<^sub>n \<psi>) = (until_frmlsn \<mu>) \<union> (until_frmlsn \<psi>)"
| "until_frmlsn (true\<^sub>n) = {}"
| "until_frmlsn (false\<^sub>n) = {}"
| "until_frmlsn (prop\<^sub>n(_)) = {}"
| "until_frmlsn (nprop\<^sub>n(_)) = {}"

end

lemma until_frmlsn_correct:
  "until_frmlsn \<phi> = {(\<mu>, \<eta>). LTLnUntil \<mu> \<eta> \<in> subfrmlsn \<phi>}"
  by (induct \<phi>) auto

definition "build_F nds \<phi>
  \<equiv> (\<lambda>(\<mu>,\<eta>). name ` {q \<in> nds. (LTLnUntil \<mu> \<eta> \<in> old q \<longrightarrow> \<eta> \<in> old q)}) `
    until_frmlsn \<phi>"

lemma build_F_correct: "build_F nds \<phi> =
  {name ` A |A. \<exists>\<mu> \<eta>. A = {q \<in> nds. LTLnUntil \<mu> \<eta> \<in> old q \<longrightarrow> \<eta> \<in> old q} \<and>
                     LTLnUntil \<mu> \<eta> \<in> subfrmlsn \<phi>}"
proof -
  have "{name ` A |A. \<exists>\<mu> \<eta>. A = {q \<in> nds. LTLnUntil \<mu> \<eta> \<in> old q \<longrightarrow> \<eta> \<in> old q} \<and>
                     LTLnUntil \<mu> \<eta> \<in> subfrmlsn \<phi>}
    = (\<lambda>(\<mu>,\<eta>). name`{q\<in>nds. LTLnUntil \<mu> \<eta> \<in> old q \<longrightarrow> \<eta> \<in> old q})
      ` {(\<mu>, \<eta>). LTLnUntil \<mu> \<eta> \<in> subfrmlsn \<phi>}"
    by auto
  also have "\<dots> = (\<lambda>(\<mu>,\<eta>). name`{q\<in>nds. LTLnUntil \<mu> \<eta> \<in> old q \<longrightarrow> \<eta> \<in> old q})
      ` until_frmlsn \<phi>"
    unfolding until_frmlsn_correct ..
  finally show ?thesis
    unfolding build_F_def by simp
qed

text {* \paragraph{ Labeling Function }*}
definition "pn_props ps \<equiv> FOREACHi
  (\<lambda>it (P,N). P = {p. LTLnProp p \<in> ps - it} \<and> N = {p. LTLnNProp p \<in> ps - it})
  ps (\<lambda>p (P,N).
    case p of LTLnProp p \<Rightarrow> RETURN (insert p P,N)
    | LTLnNProp p \<Rightarrow> RETURN (P, insert p N)
    | _ \<Rightarrow> RETURN (P,N)
  ) ({},{})"

lemma pn_props_correct:
  assumes [simp]: "finite ps"
  shows "pn_props ps \<le> SPEC(\<lambda>r. r =
  ({p. LTLnProp p \<in> ps}, {p. LTLnNProp p \<in> ps}))"
  unfolding pn_props_def
  apply (refine_rcg refine_vcg)
  apply (auto split: ltln.split)
  done

definition "pn_map nds \<equiv> FOREACH nds
  (\<lambda>nd m. do {
    PN \<leftarrow> pn_props (old nd);
    RETURN (m(name nd \<mapsto> PN))
  }) Map.empty"

lemma pn_map_correct:
  assumes [simp]: "finite nds"
  assumes FIN': "\<And>nd. nd\<in>nds \<Longrightarrow> finite (old nd)"
  assumes INJ: "inj_on name nds"
  shows "pn_map nds \<le> SPEC (\<lambda>r. \<forall>qn.
    case r qn of
      None \<Rightarrow> qn \<notin> name`nds
    | Some (P,N) \<Rightarrow> qn \<in> name`nds
      \<and> P = {p. LTLnProp p \<in> old (the_inv_into nds name qn)}
      \<and> N = {p. LTLnNProp p \<in> old (the_inv_into nds name qn)}
  )"
  unfolding pn_map_def
  apply (refine_rcg refine_vcg
    FOREACH_rule[where I="\<lambda>it r. \<forall>qn.
      case r qn of
        None \<Rightarrow> qn \<notin> name`(nds - it)
      | Some (P,N) \<Rightarrow> qn \<in> name`(nds - it)
        \<and> P = {p. LTLnProp p \<in> old (the_inv_into nds name qn)}
        \<and> N = {p. LTLnNProp p \<in> old (the_inv_into nds name qn)}"]
    order_trans[OF pn_props_correct]
  )
  apply simp_all
  apply (blast dest: set_mp[THEN FIN']) []
  apply (force
    split: option.splits
    simp: the_inv_into_f_f[OF INJ] it_step_insert_iff) []
  apply (fastforce split: option.splits) []
  done

text {* \paragraph{ Assembling the Implementation } *}

definition "cr_rename_gba nds \<phi> \<equiv> do {
  let V = name ` nds;
  let V0 = name ` {q \<in> nds. expand_init \<in> incoming q};
  succmap \<leftarrow> build_succ nds;
  let E = E_of_succ (the_default {} o succmap);
  let F = build_F nds \<phi>;
  pnm \<leftarrow> pn_map nds;
  let L = (\<lambda>qn l. case pnm qn of
      None \<Rightarrow> False
    | Some (P,N) \<Rightarrow> (\<forall>p\<in>P. p\<in>(l:::\<^sub>r\<langle>Id\<rangle>fun_set_rel)) \<and> (\<forall>p\<in>N. p\<notin>l)
  );
  RETURN (\<lparr> frg_V = V, frg_E=E, frg_V0=V0, gbg_F = F, gba_L = L \<rparr>)
}"

lemma cr_rename_gba_refine:
  assumes INV: "nds_invars nds"
  assumes REL[simplified]: "(nds',nds)\<in>Id" "(\<phi>',\<phi>)\<in>Id"
  shows "cr_rename_gba nds' \<phi>'
  \<le> \<Down>Id (RETURN (gba_rename_ext (\<lambda>_. ()) name (create_gba_from_nodes \<phi> nds)))"
  unfolding RETURN_SPEC_conv
proof (rule Id_SPEC_refine)
  from INV have
    NINIT: "expand_init \<notin> name`nds"
    and FIN: "finite nds"
    and FIN': "\<And>nd. nd\<in>nds \<Longrightarrow> finite (old nd)"
    and CL: "\<And>nd. nd\<in>nds \<Longrightarrow> incoming nd \<subseteq> insert expand_init (name`nds)"
    and INJ: "inj_on name nds"
    unfolding nds_invars_def by auto
  show "cr_rename_gba nds' \<phi>'
    \<le> SPEC (\<lambda>x. x = gba_rename_ext (\<lambda>_. ()) name (create_gba_from_nodes \<phi> nds))"
    unfolding REL
    unfolding cr_rename_gba_def
    apply (refine_rcg refine_vcg
      order_trans[OF build_succ_correct[OF NINIT FIN CL]]
      order_trans[OF pn_map_correct[OF FIN FIN' INJ]]
    )
    unfolding gba_rename_ecnv_def gb_rename_ecnv_def
      fr_rename_ext_def create_gba_from_nodes_def
    apply simp
    apply (intro conjI)
    apply (simp add: comp_def)
    apply (simp add: build_F_correct)
    apply (intro ext)
    apply (drule_tac x=qn in spec)
    apply (auto simp: the_inv_into_f_f[OF INJ] split: option.split prod.split)
    done
qed

definition "create_name_gba_aimpl \<phi> \<equiv> do {
  nds \<leftarrow> create_graph_aimpl \<phi>;
  ASSERT (nds_invars nds);
  cr_rename_gba nds \<phi>
}"

lemma create_name_gba_aimpl_refine:
  "create_name_gba_aimpl \<phi> \<le> \<Down>Id (create_name_gba \<phi>)"
  unfolding create_name_gba_aimpl_def create_name_gba_alt
  apply (refine_rcg create_graph_aimpl_refine cr_rename_gba_refine)
  by auto

subsection {* Refinement to Efficient Data Structures *}

subsubsection {* Creation of GBA from Nodes *}

schematic_lemma until_frmlsn_impl_aux:
  assumes [relator_props, simp]: "R=Id"
  shows "(?c,until_frmlsn)
  \<in> \<langle>(R::(_\<times>_::linorder) set)\<rangle>ltln_rel \<rightarrow> \<langle>\<langle>R\<rangle>ltln_rel \<times>\<^sub>r \<langle>R\<rangle>ltln_rel\<rangle>dflt_rs_rel"
  unfolding until_frmlsn_def
  apply (autoref (keep_goal, trace))
  done
concrete_definition until_frmlsn_impl uses until_frmlsn_impl_aux
lemmas [autoref_rules] = until_frmlsn_impl.refine[OF PREFER_id_D]

schematic_lemma build_succ_impl_aux:
  assumes [relator_props]: "single_valued Rm" "single_valued R"
  shows "(?c,build_succ) \<in>
    \<langle>\<langle>Rm,R\<rangle>node_rel\<rangle>list_set_rel
    \<rightarrow> \<langle>\<langle>nat_rel,\<langle>nat_rel\<rangle>list_set_rel\<rangle>iam_map_rel\<rangle>nres_rel"
  unfolding build_succ_def[abs_def] expand_init_def
  using [[autoref_trace_failed_id]]
  apply (autoref (keep_goal, trace))
  done

concrete_definition build_succ_impl uses build_succ_impl_aux
lemmas [autoref_rules] = build_succ_impl.refine[OF PREFER_sv_D PREFER_sv_D]

(* TODO: Post-processing should be on by default! *)
schematic_lemma build_succ_code_aux: "RETURN ?c \<le> build_succ_impl x"
  unfolding build_succ_impl_def
  apply (refine_transfer (post))
  done

concrete_definition build_succ_code uses build_succ_code_aux
lemmas [refine_transfer] = build_succ_code.refine

schematic_lemma build_F_impl_aux:
  assumes [relator_props]:  "R = Id"
  shows "(?c,build_F) \<in>
    \<langle>\<langle>Rm,R\<rangle>node_rel\<rangle>list_set_rel \<rightarrow> \<langle>R\<rangle>ltln_rel \<rightarrow> \<langle>\<langle>nat_rel\<rangle>list_set_rel\<rangle>list_set_rel"
  unfolding build_F_def[abs_def]
  using [[autoref_trace_failed_id]]
  apply (autoref (keep_goal, trace))
  done

concrete_definition build_F_impl uses build_F_impl_aux
lemmas [autoref_rules] = build_F_impl.refine[OF PREFER_id_D]

schematic_lemma pn_map_impl_aux:
  assumes [relator_props]: "single_valued Rm"
  shows "(?c,pn_map) \<in>
    \<langle>\<langle>Rm,Id\<rangle>node_rel\<rangle>list_set_rel
    \<rightarrow> \<langle>\<langle>nat_rel,\<langle>Id\<rangle>list_set_rel \<times>\<^sub>r \<langle>Id\<rangle>list_set_rel\<rangle>iam_map_rel\<rangle>nres_rel"
  unfolding pn_map_def[abs_def] pn_props_def
  using [[autoref_trace_failed_id]]
  apply (autoref (keep_goal, trace))
  done

concrete_definition pn_map_impl uses pn_map_impl_aux
lemma pn_map_impl_autoref[autoref_rules]:
  assumes "PREFER_id R"
  assumes "PREFER single_valued Rm"
  shows "(pn_map_impl,pn_map) \<in>
    \<langle>\<langle>Rm,R\<rangle>node_rel\<rangle>list_set_rel
    \<rightarrow> \<langle>\<langle>nat_rel,\<langle>R\<rangle>list_set_rel \<times>\<^sub>r \<langle>R\<rangle>list_set_rel\<rangle>iam_map_rel\<rangle>nres_rel"
  using assms pn_map_impl.refine by simp

schematic_lemma pn_map_code_aux: "RETURN ?c \<le> pn_map_impl x"
  unfolding pn_map_impl_def
  apply (refine_transfer (post))
  done
concrete_definition pn_map_code uses pn_map_code_aux
lemmas [refine_transfer] = pn_map_code.refine

thm autoref_tyrel

schematic_lemma cr_rename_gba_impl_aux:
  assumes ID[relator_props]: "R=Id"
  assumes [relator_props]: "single_valued Rm"
  notes [autoref_tyrel del] = TYRELI[of "\<langle>nat_rel\<rangle>dflt_rs_rel"]
  shows "(?c,cr_rename_gba) \<in>
    \<langle>\<langle>Rm,R\<rangle>node_rel\<rangle>list_set_rel \<rightarrow> \<langle>R\<rangle>ltln_rel \<rightarrow> (?R::(?'c \<times> _) set)"
  unfolding ID
  unfolding cr_rename_gba_def[abs_def] expand_init_def comp_def
  using [[autoref_trace_failed_id]]
  apply (autoref (keep_goal, trace))
  done
concrete_definition cr_rename_gba_impl uses cr_rename_gba_impl_aux

thm cr_rename_gba_impl.refine

lemma cr_rename_gba_autoref[autoref_rules]:
  assumes "PREFER_id R"
  assumes "PREFER single_valued Rm"
  shows "(cr_rename_gba_impl, cr_rename_gba) \<in>
    \<langle>\<langle>Rm, R\<rangle>node_rel\<rangle>list_set_rel \<rightarrow> \<langle>R\<rangle>ltln_rel \<rightarrow>
    \<langle>gbav_impl_rel_ext unit_rel nat_rel (\<langle>R\<rangle>fun_set_rel)\<rangle>nres_rel"
  using assms cr_rename_gba_impl.refine[of R Rm] by simp

schematic_lemma cr_rename_gba_code_aux: "RETURN ?c \<le> cr_rename_gba_impl x y"
  unfolding cr_rename_gba_impl_def
  apply (refine_transfer (post))
  done
concrete_definition cr_rename_gba_code uses cr_rename_gba_code_aux
lemmas [refine_transfer] = cr_rename_gba_code.refine

subsubsection {* Creation of Graph *}

text {*
  The implementation of the node-set. The relation enforces that there are no
  different nodes with the same name. This effectively establishes an additional
  invariant, made explicit by an assertion in the refined program. This invariant
  allows for a more efficient implementation.
*}
definition ls_nds_rel_def_internal:
  "ls_nds_rel R \<equiv> \<langle>R\<rangle>list_set_rel \<inter> {(_,s). inj_on name s}"
lemma ls_nds_rel_def: "\<langle>R\<rangle>ls_nds_rel = \<langle>R\<rangle>list_set_rel \<inter> {(_,s). inj_on name s}"
  by (simp add: relAPP_def ls_nds_rel_def_internal)

lemmas [autoref_rel_intf] = REL_INTFI[of ls_nds_rel i_set]

lemma ls_nds_rel_sv[relator_props]:
  assumes "single_valued R"
  shows "single_valued (\<langle>R\<rangle>ls_nds_rel)"
  using list_set_rel_sv[OF assms]
  unfolding ls_nds_rel_def
  by (metis inf.cobounded1 single_valued_subset)

context begin interpretation autoref_syn .
lemma lsnds_empty_autoref[autoref_rules]:
  assumes "PREFER_id R"
  shows "([],{})\<in>\<langle>R\<rangle>ls_nds_rel"
  using assms
  apply (simp add: ls_nds_rel_def)
  by autoref

lemma lsnds_insert_autoref[autoref_rules]:
  assumes "SIDE_PRECOND (name n \<notin> name`ns)"
  assumes "(n',n)\<in>R"
  assumes "(ns',ns)\<in>\<langle>R\<rangle>ls_nds_rel"
  shows "(n'#ns',(OP insert ::: R \<rightarrow> \<langle>R\<rangle>ls_nds_rel \<rightarrow> \<langle>R\<rangle>ls_nds_rel)$n$ns)
   \<in> \<langle>R\<rangle>ls_nds_rel"
  using assms
  unfolding ls_nds_rel_def
  apply simp
proof (elim conjE, rule conjI)
  assume [autoref_rules]: "(n', n) \<in> R" "(ns', ns) \<in> \<langle>R\<rangle>list_set_rel"
  assume "name n \<notin> name ` ns"
    and "inj_on name ns"
  hence "n \<notin> ns" by (auto)
  thus "(n' # ns', insert n ns) \<in> \<langle>R\<rangle>list_set_rel"
    by autoref
qed auto

lemma ls_nds_image_autoref_aux:
  assumes [autoref_rules]: "(fi,f) \<in> Ra \<rightarrow> Rb"
  assumes "(l,s) \<in> \<langle>Ra\<rangle>ls_nds_rel"
  assumes [simp]: "\<forall>x. name (f x) = name x"
  shows "(map fi l, f`s) \<in> \<langle>Rb\<rangle>ls_nds_rel"
proof -
  from assms have
    [autoref_rules]: "(l,s)\<in>\<langle>Ra\<rangle>list_set_rel"
      and INJ: "(inj_on name s)"
    by (auto simp add: ls_nds_rel_def)

  have [simp]: "inj_on f s"
    by (rule inj_onI) (metis INJ assms(3) inj_on_eq_iff)

  have "(map fi l, f`s) \<in> \<langle>Rb\<rangle>list_set_rel"
    by (autoref (keep_goal))
  moreover have "inj_on name (f`s)"
    apply (rule inj_onI)
    apply (auto simp: image_iff dest: inj_onD[OF INJ])
    done
  ultimately show ?thesis
    by (auto simp: ls_nds_rel_def)
qed

lemma ls_nds_image_autoref[autoref_rules]:
  assumes "(fi,f) \<in> Ra \<rightarrow> Rb"
  assumes "SIDE_PRECOND (\<forall>x. name (f x) = name x)"
  shows "(map fi, (OP op ` ::: (Ra\<rightarrow>Rb) \<rightarrow> \<langle>Ra\<rangle>ls_nds_rel \<rightarrow> \<langle>Rb\<rangle>ls_nds_rel)$f)
    \<in> \<langle>Ra\<rangle>ls_nds_rel \<rightarrow> \<langle>Rb\<rangle>ls_nds_rel"
  using assms
  unfolding autoref_tag_defs
  using ls_nds_image_autoref_aux
  by blast

lemma list_set_autoref_to_list[autoref_ga_rules]:
  shows "is_set_to_sorted_list (\<lambda>_ _. True) R ls_nds_rel id"
  unfolding is_set_to_list_def is_set_to_sorted_list_def ls_nds_rel_def
    it_to_sorted_list_def list_set_rel_def br_def
  by auto

end

context begin interpretation autoref_syn .
lemma [autoref_itype]:
  "upd_incoming
    ::\<^sub>i \<langle>Im, I\<rangle>\<^sub>ii_node \<rightarrow>\<^sub>i \<langle>\<langle>Im', I\<rangle>\<^sub>ii_node\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>\<langle>Im', I\<rangle>\<^sub>ii_node\<rangle>\<^sub>ii_set"
  by simp
end

term upd_incoming
schematic_lemma upd_incoming_impl_aux:
  assumes "REL_IS_ID R"
  shows "(?c, upd_incoming)\<in>\<langle>Rm1,R\<rangle>node_rel
  \<rightarrow> \<langle>\<langle>Rm2,R\<rangle>node_rel\<rangle>ls_nds_rel
  \<rightarrow> \<langle>\<langle>Rm2,R\<rangle>node_rel\<rangle>ls_nds_rel"
  using assms apply simp
  unfolding upd_incoming_def[abs_def]
  using [[autoref_trace_failed_id]]
  apply (autoref (keep_goal))
  done

concrete_definition upd_incoming_impl uses upd_incoming_impl_aux
lemmas [autoref_rules] = upd_incoming_impl.refine[OF PREFER_D[of REL_IS_ID]]

schematic_lemma expand_impl_aux: "(?c, expand_aimpl) \<in>
  \<langle>unit_rel,Id\<rangle>node_rel \<times>\<^sub>r \<langle>\<langle>unit_rel,Id\<rangle>node_rel\<rangle>ls_nds_rel
  \<rightarrow> \<langle>nat_rel \<times>\<^sub>r \<langle>\<langle>unit_rel,Id\<rangle>node_rel\<rangle>ls_nds_rel\<rangle>nres_rel"
  unfolding expand_aimpl_def[abs_def] expand_new_name_def
  using [[autoref_trace_failed_id, autoref_trace_intf_unif]]
  apply (autoref (trace,keep_goal))
  done

concrete_definition expand_impl uses expand_impl_aux

context begin interpretation autoref_syn .
lemma [autoref_itype]: "expand\<^sub>T
  ::\<^sub>i \<langle>\<langle>i_unit, I\<rangle>\<^sub>ii_node, \<langle>\<langle>i_unit, I\<rangle>\<^sub>ii_node\<rangle>\<^sub>ii_set\<rangle>\<^sub>ii_prod
  \<rightarrow>\<^sub>i \<langle>\<langle>i_nat,\<langle>\<langle>i_unit, I\<rangle>\<^sub>ii_node\<rangle>\<^sub>ii_set\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_nres" by simp

lemma expand_autoref[autoref_rules]:
  assumes ID: "PREFER_id R"
  assumes A: "(n_ns', n_ns)
    \<in> \<langle>unit_rel,R\<rangle>node_rel \<times>\<^sub>r \<langle>\<langle>unit_rel,R\<rangle>node_rel\<rangle>list_set_rel"
  assumes B: "SIDE_PRECOND (
    let (n,ns)=n_ns in inj_on name ns \<and> (\<forall>n'\<in>ns. name n > name n')
  )"
  shows "(expand_impl n_ns',
    (OP expand_aimpl
    ::: \<langle>unit_rel,R\<rangle>node_rel \<times>\<^sub>r \<langle>\<langle>unit_rel,R\<rangle>node_rel\<rangle>list_set_rel
    \<rightarrow> \<langle>nat_rel \<times>\<^sub>r \<langle>\<langle>unit_rel,R\<rangle>node_rel\<rangle>list_set_rel\<rangle>nres_rel)$n_ns)
  \<in> \<langle>nat_rel \<times>\<^sub>r \<langle>\<langle>unit_rel,R\<rangle>node_rel\<rangle>list_set_rel\<rangle>nres_rel"
proof simp
  from ID A B have
    1: "(n_ns, n_ns) \<in> Id \<inter> {(_,(n,ns)). \<forall>n'\<in>ns. name n > name n'}"
    and 2: "(n_ns', n_ns)
      \<in> \<langle>unit_rel,Id\<rangle>node_rel \<times>\<^sub>r \<langle>\<langle>unit_rel,Id\<rangle>node_rel\<rangle>ls_nds_rel"
    unfolding ls_nds_rel_def
    apply -
    apply auto []
    apply (cases n_ns')
    apply auto []
    done

  have [simp]: "single_valued (nat_rel \<times>\<^sub>r \<langle>\<langle>unit_rel, Id\<rangle>node_rel\<rangle>list_set_rel)"
    by tagged_solver

  have [relator_props]: "\<And>R. single_valued (Id \<inter> R)"
    by (metis IntE single_valuedD single_valuedI single_valued_Id)

  have [simp]: "single_valued ((nat_rel \<times>\<^sub>r \<langle>\<langle>unit_rel, Id\<rangle>node_rel\<rangle>ls_nds_rel) O
                          (Id \<inter> {(_, n, ns). \<forall>n'\<in>ns. name n' < n}))"
    by (tagged_solver)

  from expand_impl.refine[THEN fun_relD, OF 2, THEN nres_relD]
  show "(expand_impl n_ns', expand_aimpl n_ns)
    \<in> \<langle>nat_rel \<times>\<^sub>r \<langle>\<langle>unit_rel, R\<rangle>node_rel\<rangle>list_set_rel\<rangle>nres_rel"
    apply -
    apply (rule nres_relI)
    using ID
    apply (simp add: pw_le_iff refine_pw_simps)
    apply (fastforce simp: ls_nds_rel_def)
    done
qed

end

schematic_lemma expand_code_aux: "RETURN ?c \<le> expand_impl n_ns"
  unfolding expand_impl_def
  by (refine_transfer the_resI)
concrete_definition expand_code uses expand_code_aux
prepare_code_thms expand_code_def
lemmas [refine_transfer] = expand_code.refine

schematic_lemma create_graph_impl_aux:
  assumes ID: "R=Id"
  shows "(?c, create_graph_aimpl)
    \<in> \<langle>R\<rangle>ltln_rel \<rightarrow> \<langle>\<langle>\<langle>unit_rel,R\<rangle>node_rel\<rangle>list_set_rel\<rangle>nres_rel"
  unfolding ID
  unfolding create_graph_aimpl_def[abs_def] expand_init_def expand_new_name_def
  using [[autoref_trace_failed_id]]
  apply (autoref (keep_goal))
  done
concrete_definition create_graph_impl uses create_graph_impl_aux

lemmas [autoref_rules] = create_graph_impl.refine[OF PREFER_id_D]

schematic_lemma create_graph_code_aux: "RETURN ?c \<le> create_graph_impl \<phi>"
  unfolding create_graph_impl_def
  by refine_transfer
concrete_definition create_graph_code uses create_graph_code_aux
lemmas [refine_transfer] = create_graph_code.refine

schematic_lemma create_name_gba_impl_aux:
  "(?c, (create_name_gba_aimpl:: 'a::linorder ltln \<Rightarrow> _))
  \<in> \<langle>Id\<rangle>ltln_rel \<rightarrow> (?R::(?'c\<times>_) set)"
  unfolding create_name_gba_aimpl_def[abs_def]
  using [[autoref_trace_failed_id]]
  apply (autoref (keep_goal, trace))
  done
concrete_definition create_name_gba_impl uses create_name_gba_impl_aux

lemma create_name_gba_autoref[autoref_rules]:
  assumes "PREFER_id R"
  shows
  "(create_name_gba_impl, create_name_gba)
  \<in> \<langle>R\<rangle>ltln_rel \<rightarrow> \<langle>gbav_impl_rel_ext unit_rel nat_rel (\<langle>R\<rangle>fun_set_rel)\<rangle>nres_rel"
  (is "_:_\<rightarrow>\<langle>?R\<rangle>nres_rel")
proof (intro fun_relI nres_relI)
  fix \<phi> \<phi>'
  assume A: "(\<phi>,\<phi>')\<in>\<langle>R\<rangle>ltln_rel"
  from assms have RID[simp]: "R=Id" by simp

  note create_name_gba_impl.refine[THEN fun_relD,THEN nres_relD, OF A[unfolded RID]]
  also note create_name_gba_aimpl_refine
  finally show "create_name_gba_impl \<phi> \<le> \<Down> ?R (create_name_gba \<phi>')" by simp
qed

schematic_lemma create_name_gba_code_aux: "RETURN ?c \<le> create_name_gba_impl \<phi>"
  unfolding create_name_gba_impl_def
  by (refine_transfer (post))
concrete_definition create_name_gba_code uses create_name_gba_code_aux
lemmas [refine_transfer] = create_name_gba_code.refine

schematic_lemma create_name_igba_impl_aux:
  assumes RID: "R=Id"
  shows "(?c,create_name_igba)\<in>
  \<langle>R\<rangle>ltln_rel \<rightarrow> \<langle>igbav_impl_rel_ext unit_rel nat_rel (\<langle>R\<rangle>fun_set_rel)\<rangle>nres_rel"
  unfolding RID
  unfolding create_name_igba_def[abs_def]
  using [[autoref_trace_failed_id]]
  apply (autoref (trace, keep_goal))
  done
concrete_definition create_name_igba_impl uses create_name_igba_impl_aux
lemmas [autoref_rules] = create_name_igba_impl.refine[OF PREFER_id_D]

schematic_lemma create_name_igba_code_aux: "RETURN ?c \<le> create_name_igba_impl \<phi>"
  unfolding create_name_igba_impl_def
  by (refine_transfer (post))
concrete_definition create_name_igba_code uses create_name_igba_code_aux
lemmas [refine_transfer] = create_name_igba_code.refine

export_code create_name_igba_code checking SML

end


theory Formula_1_Rule
  imports Scoring_Rules
          "Compositional_Structures/Basic_Modules/Scoring_Module"
          "Compositional_Structures/Basic_Modules/Formula_1_Module"
          "Compositional_Structures/Elect_Composition"

begin

lemma f1_elect:
  shows "electoral_module (elector F1)"
proof(unfold F1.simps)
  show "electoral_module (elector (max_eliminator (scoring vector_A_f1)))"
    using scoring_mod_A by blast
qed

lemma f1_hom:
  shows "homogeneity (elector F1)" unfolding F1.simps
  using scoring_rules_homogeneity
  by blast

lemma f1_reinforcement:
  shows "reinforcement (elector F1)" unfolding F1.simps
  using scoring_module_rein
  by blast

end


theory test_utils
imports
  "~~/src/HOL/Library/Float"
  "$AFP/IEEE_Floating_Point/Code_Float"
begin

subsection \<open>Conversion from int\<close>

definition "float_of_int i = Float (real_of_int i)"

context includes integer.lifting begin
lift_definition float_of_integer::"integer \<Rightarrow> float" is float_of_int .
end

lemma float_of_int[code]:
  "float_of_int i = float_of_integer (integer_of_int i)"
  by (auto simp: float_of_integer_def)

code_printing
  constant "float_of_integer :: integer \<Rightarrow> float" \<rightharpoonup> (SML) "Real.fromInt"
declare [[code drop: float_of_integer]]

subsection \<open>Conversion to software floats\<close>

code_printing
code_module "ToManExp" \<rightharpoonup> (SML)
  \<open>fun tomanexp x =
  let
    val {man = m, exp = e} = Real.toManExp x;
    val p = Math.pow (2.0, 53.0);
    val ms = m * p;
    val mi = Real.floor ms;
    val ei = op Int.- (e, 53);
  in (mi, ei)
  end\<close>

consts tomanexp::"float \<Rightarrow> integer * integer"
code_printing constant "tomanexp :: float \<Rightarrow> integer * integer" \<rightharpoonup>
  (SML) "tomanexp"

definition toFloat::"float \<Rightarrow> Float.float" where
  "toFloat x = (let (m, e) = tomanexp x in Float.Float (int_of_integer m) (int_of_integer e))"

value [code] "((Float.Float 123 (-13)) + (Float.Float 13 (-13))) * ((Float.Float 123 (-13)))"
value [code] "toFloat (float_of 1 / float_of 1243313)"

subsection \<open>Conversion from software floats\<close>

code_printing
code_module "FromManExp" \<rightharpoonup> (SML)
  \<open>fun frommanexp m e = Real.fromManExp {man = Real.fromLargeInt m, exp = e}\<close>
consts frommanexp::"integer \<Rightarrow> integer \<Rightarrow> float"
code_printing constant "frommanexp :: integer \<Rightarrow> integer \<Rightarrow> float" \<rightharpoonup>
  (SML) "frommanexp"

definition of_Float::"Float.float \<Rightarrow> float" where
  "of_Float x = frommanexp (integer_of_int (Float.mantissa x)) (integer_of_int (Float.exponent x))"

subsection \<open>just for debugging: floats to strings and printing\<close>

subsubsection \<open>integers to strings\<close>

definition int_to_string::"int \<Rightarrow> String.literal"
  where "int_to_string x = STR ''''"

context includes integer.lifting begin

lift_definition integer_to_string::"integer \<Rightarrow> String.literal"
  is int_to_string .

end

code_printing
  constant "integer_to_string :: integer \<Rightarrow> String.literal" \<rightharpoonup> (SML) "IntInf.toString"
declare [[code drop: integer_to_string]]

subsection \<open>printing floats\<close>

instantiation float::term_of
begin
definition term_of::"float \<Rightarrow> term" where "term_of x = undefined"
instance ..
end

definition string_of_float::"float \<Rightarrow> String.literal" where
  "string_of_float x = STR ''''"

code_printing constant "string_of_float :: float \<Rightarrow> String.literal" \<rightharpoonup>
  (SML) "Real.toString"
declare [[code drop: "string_of_float"]]

definition print::"String.literal \<Rightarrow> unit" where
  "print x = ()"

code_printing constant "print :: String.literal \<Rightarrow> unit" \<rightharpoonup>
  (SML) "TextIO.print"
declare [[code drop: "print"]]

consts float_of_string::"String.literal \<Rightarrow> float"

lemma [code]: "term_of_class.term_of (x::float) \<equiv>
  Code_Evaluation.App
    (Code_Evaluation.termify of_Float)
    (term_of_class.term_of (normfloat (toFloat x)))"
  by (rule term_of_anything)

value [code] "(One::float) + One + One"

definition println::"String.literal \<Rightarrow> unit" where
  "println x = (let _ = print x in print (STR ''\<newline>''))"

subsection \<open>printing Float.floats\<close>

definition println_sw_float::"Float.float \<Rightarrow> unit" where
  "println_sw_float x = (let
      _ = print (int_to_string (Float.mantissa x));
      _ = print (STR '' * 2 ^ '');
      _ = println (int_to_string (Float.exponent x))
     in
       ())"

code_printing constant "Isnormal :: float \<Rightarrow> bool" \<rightharpoonup>
  (SML) "Real.isNormal"
declare [[code drop: "Isnormal"]]

code_printing constant "Finite :: float \<Rightarrow> bool" \<rightharpoonup>
  (SML) "Real.isFinite"
declare [[code drop: "Finite"]]

definition "fin = Finite"
ML \<open>val fin = @{code fin}\<close>
ML \<open>val test = fin 0.4\<close>

definition "z = Float.Float 54252343554345363463465345345234534534624525234345663462452453423232345234523452352523453453465645639099999999998000000000000000000000000000000890349899988888888843242646554 343"
ML \<open>val z = @{code z};
  val of_Float = @{code of_Float}\<close>
ML \<open>of_Float z\<close>
value [code] "Float.Float 4 3"
value [code] "of_Float z"

end


(*
  Theory: PDF_Target_Density_Contexts.thy
  Authors: Manuel Eberl

  Concrete density contexts and operations on them as expressions in the
  target language
*)

header {* Concrete Density Contexts *}

theory PDF_Target_Density_Contexts
imports PDF_Density_Contexts PDF_Target_Semantics
begin

subsection {* Definition *}

type_synonym cdens_ctxt = "vname list \<times> vname list \<times> tyenv \<times> cexpr"

definition dens_ctxt_\<alpha> :: "cdens_ctxt \<Rightarrow> dens_ctxt" where
  "dens_ctxt_\<alpha> \<equiv> \<lambda>(vs,vs',\<Gamma>,\<delta>). (set vs, set vs', \<Gamma>, \<lambda>\<sigma>. extract_real (cexpr_sem \<sigma> \<delta>))"

definition shift_vars :: "nat list \<Rightarrow> nat list" where
  "shift_vars vs = 0 # map Suc vs"

lemma set_shift_vars[simp]: "set (shift_vars vs) = shift_var_set (set vs)"
  unfolding shift_vars_def shift_var_set_def by simp

definition is_density_expr :: "cdens_ctxt \<Rightarrow> pdf_type \<Rightarrow> cexpr \<Rightarrow> bool" where
  "is_density_expr \<equiv> \<lambda>(vs,vs',\<Gamma>,\<delta>) t e.
     case_nat t \<Gamma> \<turnstile>\<^sub>c e : REAL \<and> free_vars e \<subseteq> shift_var_set (set vs')"

lemma is_density_exprI:
  "case_nat t \<Gamma> \<turnstile>\<^sub>c e : REAL \<Longrightarrow> free_vars e \<subseteq> shift_var_set (set vs') \<Longrightarrow>
       is_density_expr (vs, vs', \<Gamma>, \<delta>) t e"
  unfolding is_density_expr_def by simp

lemma is_density_exprD:
  assumes "is_density_expr (vs, vs', \<Gamma>, \<delta>) t e"
  shows "case_nat t \<Gamma> \<turnstile>\<^sub>c e : REAL" "free_vars e \<subseteq> shift_var_set (set vs')"
  using assms unfolding is_density_expr_def by simp_all

lemma density_context_\<alpha>:
  assumes "cdens_ctxt_invar vs vs' \<Gamma> \<delta>"
  shows "density_context (set vs) (set vs') \<Gamma> (\<lambda>\<sigma>. extract_real (cexpr_sem \<sigma> \<delta>))"
proof (unfold density_context_def, intro allI ballI conjI impI subprob_spaceI)
  show "(\<lambda>x. ereal (extract_real (cexpr_sem x \<delta>)))
            \<in> borel_measurable (state_measure (set vs \<union> set vs') \<Gamma>)"
    apply (intro borel_measurable_ereal measurable_compose[OF _ measurable_extract_real])
    apply (subst stock_measure.simps[symmetric], rule measurable_cexpr_sem)
    apply (insert cdens_ctxt_invarD[OF assms], auto)
    done
  note [measurable] = this

  fix \<rho> assume \<rho>: "\<rho> \<in> space (state_measure (set vs') \<Gamma>)"
  let ?M = "dens_ctxt_measure (set vs, set vs', \<Gamma>, \<lambda>x. ereal (extract_real (cexpr_sem x \<delta>))) \<rho>"
  from \<rho> have "(\<lambda>\<sigma>. merge (set vs) (set vs') (\<sigma>, \<rho>))
                    \<in> measurable (state_measure (set vs) \<Gamma>) (state_measure (set vs \<union> set vs') \<Gamma>)"
    unfolding state_measure_def by simp
  hence "emeasure ?M (space ?M) =
             \<integral>\<^sup>+x. ereal (extract_real (cexpr_sem (merge (set vs) (set vs') (x, \<rho>)) \<delta>))
                \<partial>state_measure (set vs) \<Gamma>" (is "_ = ?I")
    using \<rho> unfolding dens_ctxt_measure_def state_measure'_def
    by (simp add: emeasure_density nn_integral_distr, intro nn_integral_cong)
       (simp_all split: split_indicator add: merge_in_state_measure)
  also from cdens_ctxt_invarD[OF assms] have "subprob_cexpr (set vs) (set vs') \<Gamma> \<delta>" by simp
  with \<rho> have "?I \<le> 1" unfolding subprob_cexpr_def by blast
  finally show "emeasure ?M (space ?M) \<le> 1" .
qed (insert cdens_ctxt_invarD[OF assms], simp_all add: nonneg_cexpr_def)

subsection {* Expressions for density context operations *}

definition marg_dens_cexpr :: "tyenv \<Rightarrow> vname list \<Rightarrow> vname \<Rightarrow> cexpr \<Rightarrow> cexpr" where
  "marg_dens_cexpr \<Gamma> vs x e =
      map_vars (\<lambda>y. if y = x then 0 else Suc y) (integrate_vars \<Gamma> (filter (\<lambda>y. y \<noteq> x) vs) e)"

lemma free_vars_marg_dens_cexpr:
  assumes "cdens_ctxt_invar vs vs' \<Gamma> \<delta>"
  shows "free_vars (marg_dens_cexpr \<Gamma> vs x \<delta>) \<subseteq> shift_var_set (set vs')"
proof-
  have "free_vars (marg_dens_cexpr \<Gamma> vs x \<delta>) \<subseteq> shift_var_set (free_vars \<delta> - set vs)"
    unfolding marg_dens_cexpr_def shift_var_set_def by auto
  also from cdens_ctxt_invarD[OF assms] have "... \<subseteq> shift_var_set (set vs')"
      unfolding shift_var_set_def by auto
  finally show ?thesis .
qed

lemma cexpr_typing_marg_dens_cexpr[intro]:
  "\<Gamma> \<turnstile>\<^sub>c \<delta> : REAL \<Longrightarrow> case_nat (\<Gamma> x) \<Gamma> \<turnstile>\<^sub>c marg_dens_cexpr \<Gamma> vs x \<delta> : REAL"
  unfolding marg_dens_cexpr_def
  by (rule cexpr_typing_map_vars, rule cexpr_typing_cong', erule cexpr_typing_integrate_vars) simp

lemma cexpr_sem_marg_dens:
  assumes "cdens_ctxt_invar vs vs' \<Gamma> \<delta>"
  assumes x: "x \<in> set vs" and \<rho>: "\<rho> \<in> space (state_measure (set vs') \<Gamma>)"
  shows "AE v in stock_measure (\<Gamma> x).
           ereal (extract_real (cexpr_sem (case_nat v \<rho>) (marg_dens_cexpr \<Gamma> vs x \<delta>))) =
               marg_dens (dens_ctxt_\<alpha> (vs,vs',\<Gamma>,\<delta>)) x \<rho> v"
proof-
  note invar = cdens_ctxt_invarD[OF assms(1)]
  let ?vs = "filter (\<lambda>y. y \<noteq> x) vs"
  note cdens_ctxt_invar_imp_integrable[OF assms(1) \<rho>]
  moreover from x have insert_eq: "insert x {xa \<in> set vs. xa \<noteq> x} = set vs" by auto
  ultimately have integrable:
    "AE v in stock_measure (\<Gamma> x).
          integrable (state_measure (set ?vs) \<Gamma>)
              (\<lambda>\<sigma>. extract_real (cexpr_sem (merge (set ?vs) (insert x (set vs')) (\<sigma>, \<rho>(x := v))) \<delta>))"
    using invar x \<rho> by (intro integrable_cexpr_projection) auto

  show ?thesis
  proof (rule AE_mp[OF integrable], rule AE_I2, intro impI)
    fix v assume v: "v \<in> space (stock_measure (\<Gamma> x))"
    assume integrable:
      "integrable (state_measure (set ?vs) \<Gamma>)
           (\<lambda>\<sigma>. extract_real (cexpr_sem (merge (set ?vs) (insert x (set vs')) (\<sigma>, \<rho>(x := v))) \<delta>))"

    from v and \<rho> have \<rho>': "(\<rho>(x := v)) \<in> space (state_measure (set (x#vs')) \<Gamma>)"
      by (auto simp: state_measure_def space_PiM split: split_if_asm)
    have "cexpr_sem (case_nat v \<rho>) (marg_dens_cexpr \<Gamma> vs x \<delta>) =
            cexpr_sem (case_nat v \<rho> \<circ> (\<lambda>y. if y = x then 0 else Suc y))
                   (integrate_vars \<Gamma> [y\<leftarrow>vs . y \<noteq> x] \<delta>)" (is "_ = ?A")
      unfolding marg_dens_cexpr_def by (simp add: cexpr_sem_map_vars)
    also have "\<And>y. y \<in> free_vars (integrate_vars \<Gamma> [y\<leftarrow>vs . y \<noteq> x] \<delta>)
                  \<Longrightarrow> (case_nat v \<rho> \<circ> (\<lambda>y. if y = x then 0 else Suc y)) y = (\<rho>(x := v)) y"
      unfolding o_def by simp
    hence "?A = cexpr_sem (\<rho>(x := v)) (integrate_vars \<Gamma> [y\<leftarrow>vs . y \<noteq> x] \<delta>)" by (rule cexpr_sem_eq_on_vars)
    also from x have "insert x {xa \<in> set vs. xa \<noteq> x} \<union> set vs' = set vs \<union> set vs'" by auto
    hence "extract_real (cexpr_sem (\<rho>(x := v)) (integrate_vars \<Gamma> [y\<leftarrow>vs . y \<noteq> x] \<delta>)) =
                  \<integral>\<^sup>+\<sigma>. extract_real (cexpr_sem (merge (set ?vs) (insert x (set vs')) (\<sigma>, \<rho>(x := v))) \<delta>)
                     \<partial>state_measure (set ?vs) \<Gamma>"
      using \<rho>' invar integrable by (subst cexpr_sem_integrate_vars') (auto )
    also from x have "(\<lambda>\<sigma>. merge (set ?vs) (insert x (set vs')) (\<sigma>, \<rho>(x := v))) =
                         (\<lambda>\<sigma>. merge (set vs) (set vs') (\<sigma>(x := v), \<rho>))"
      by (intro ext) (auto simp: merge_def)
    also from x have "set ?vs = set vs - {x}" by auto
    also have "(\<integral>\<^sup>+\<sigma>. extract_real (cexpr_sem (merge (set vs) (set vs') (\<sigma>(x := v), \<rho>)) \<delta>)
                     \<partial>state_measure (set vs - {x}) \<Gamma>) =
                 marg_dens (dens_ctxt_\<alpha> (vs,vs',\<Gamma>,\<delta>)) x \<rho> v"
      unfolding marg_dens_def dens_ctxt_\<alpha>_def by simp
    finally show "ereal (extract_real (cexpr_sem (\<lambda>a. case a of 0 \<Rightarrow> v | Suc a \<Rightarrow> \<rho> a)
                                               (marg_dens_cexpr \<Gamma> vs x \<delta>))) =
                    marg_dens (dens_ctxt_\<alpha> (vs, vs', \<Gamma>, \<delta>)) x \<rho> v" .
  qed
qed

lemma nonneg_cexpr_sem_marg_dens:
  assumes "cdens_ctxt_invar vs vs' \<Gamma> \<delta>"
  assumes x: "x \<in> set vs" and \<rho>: "\<rho> \<in> space (state_measure (set vs') \<Gamma>)"
  assumes v: "v \<in> type_universe (\<Gamma> x)"
  shows "extract_real (cexpr_sem (case_nat v \<rho>) (marg_dens_cexpr \<Gamma> vs x \<delta>)) \<ge> 0"
proof-
  note invar = cdens_ctxt_invarD[OF assms(1)]
  from assms have \<rho>: "case_nat v \<rho> \<circ> (\<lambda>y. if y = x then 0 else Suc y)
                        \<in> space (state_measure (set (x#vs')) \<Gamma>)"
    by (force simp: state_measure_def space_PiM o_def split: split_if_asm)
  moreover from x have "insert x {xa \<in> set vs. xa \<noteq> x} \<union> set vs' = set vs \<union> set vs'" by auto
  ultimately show ?thesis using assms invar unfolding marg_dens_cexpr_def
    by (subst cexpr_sem_map_vars, intro nonneg_cexpr_sem_integrate_vars[of _ "set (x#vs')"]) auto
qed

definition marg_dens2_cexpr :: "tyenv \<Rightarrow> vname list \<Rightarrow> vname \<Rightarrow> vname \<Rightarrow> cexpr \<Rightarrow> cexpr" where
  "marg_dens2_cexpr \<Gamma> vs x y e =
     (cexpr_comp_aux (Suc x) (fst\<^sub>c (CVar 0))
        (cexpr_comp_aux (Suc y) (snd\<^sub>c (CVar 0))
            (map_vars Suc (integrate_vars \<Gamma> (filter (\<lambda>z. z \<noteq> x \<and> z \<noteq> y) vs) e))))"

lemma free_vars_marg_dens2_cexpr:
  assumes "cdens_ctxt_invar vs vs' \<Gamma> \<delta>"
  shows "free_vars (marg_dens2_cexpr \<Gamma> vs x y \<delta>) \<subseteq> shift_var_set (set vs')"
proof-
  have "free_vars (marg_dens2_cexpr \<Gamma> vs x y \<delta>) \<subseteq>
            shift_var_set (free_vars \<delta> - set vs)"
    unfolding marg_dens2_cexpr_def using cdens_ctxt_invarD[OF assms(1)]
    apply (intro order.trans[OF free_vars_cexpr_comp_aux] Un_least)
    apply (subst Diff_subset_conv, intro order.trans[OF free_vars_cexpr_comp_aux])
    apply (auto simp: shift_var_set_def)
    done
  also from cdens_ctxt_invarD[OF assms(1)] have "... \<subseteq> shift_var_set (set vs')"
      unfolding shift_var_set_def by auto
  finally show ?thesis .
qed

lemma cexpr_typing_marg_dens2_cexpr[intro]:
  assumes "\<Gamma> \<turnstile>\<^sub>c \<delta> : REAL"
  shows "case_nat (PRODUCT (\<Gamma> x) (\<Gamma> y)) \<Gamma> \<turnstile>\<^sub>c marg_dens2_cexpr \<Gamma> vs x y \<delta> : REAL"
proof-
  have A: "(case_nat (PRODUCT (\<Gamma> x) (\<Gamma> y)) \<Gamma>) (Suc x := \<Gamma> x, Suc y := \<Gamma> y) \<circ> Suc = \<Gamma>"
    by (intro ext) (auto split: nat.split)
  show ?thesis unfolding marg_dens2_cexpr_def
  apply (rule cexpr_typing_cexpr_comp_aux[of _ _ "\<Gamma> x"])
  apply (rule cexpr_typing_cexpr_comp_aux[of _ _ "\<Gamma> y"])
  apply (rule cexpr_typing_map_vars, subst A, rule cexpr_typing_integrate_vars[OF assms])
  apply (rule cet_op, rule cet_var, simp, rule cet_op, rule cet_var, simp)
  done
qed

lemma cexpr_sem_marg_dens2:
  assumes "cdens_ctxt_invar vs vs' \<Gamma> \<delta>"
  assumes x: "x \<in> set vs" and y: "y \<in> set vs" and "x \<noteq> y"
  assumes \<rho>: "\<rho> \<in> space (state_measure (set vs') \<Gamma>)"
  shows "AE z in stock_measure (PRODUCT (\<Gamma> x) (\<Gamma> y)).
           ereal (extract_real (cexpr_sem (case_nat z \<rho>) (marg_dens2_cexpr \<Gamma> vs x y \<delta>))) =
               marg_dens2 (dens_ctxt_\<alpha> (vs,vs',\<Gamma>,\<delta>)) x y \<rho> z"
proof-
  note invar = cdens_ctxt_invarD[OF assms(1)]
  let ?f = "\<lambda>x. ereal (extract_real (cexpr_sem x \<delta>))"
  let ?vs = "filter (\<lambda>z. z \<noteq> x \<and> z \<noteq> y) vs"
  interpret product_sigma_finite "\<lambda>x. stock_measure (\<Gamma> x)"
    unfolding product_sigma_finite_def by simp
  interpret sf_PiM: sigma_finite_measure "PiM (set ?vs) (\<lambda>x. stock_measure (\<Gamma> x))"
    by (intro sigma_finite) simp

  have meas: "(\<lambda>\<sigma>. extract_real (cexpr_sem (merge (set vs) (set vs') (\<sigma>, \<rho>)) \<delta>))
                 \<in> borel_measurable (state_measure (set vs) \<Gamma>)" using assms invar
    by (intro measurable_cexpr_sem') simp_all
  from x y have insert_eq: "insert x (insert y (set ?vs)) = set vs" by auto
  from x y have insert_eq': "insert y (insert x (set ?vs)) = set vs" by auto
  have meas_upd1: "(\<lambda>(\<sigma>,v). \<sigma>(y := v)) \<in>
      measurable (PiM (insert x (set vs)) (\<lambda>x. stock_measure (\<Gamma> x)) \<Otimes>\<^sub>M stock_measure (\<Gamma> y))
                 (PiM (insert y (insert x (set vs))) (\<lambda>x. stock_measure (\<Gamma> x)))"
    using measurable_add_dim[of y "insert x (set ?vs)" "\<lambda>x. stock_measure (\<Gamma> x)"]
    by (simp only: insert_eq', simp)
  hence meas_upd2: "(\<lambda>xa. (snd xa) (x := fst (fst xa), y := snd (fst xa)))
           \<in> measurable ((stock_measure (\<Gamma> x) \<Otimes>\<^sub>M stock_measure (\<Gamma> y)) \<Otimes>\<^sub>M
                           Pi\<^sub>M (set ?vs) (\<lambda>y. stock_measure (\<Gamma> y)))
                        (Pi\<^sub>M (set vs) (\<lambda>y. stock_measure (\<Gamma> y)))"
    by (subst insert_eq'[symmetric], intro measurable_Pair_compose_split[OF measurable_add_dim])
       (simp_all del: fun_upd_apply)

  from x y have A: "set vs = {x, y} \<union> set ?vs" by auto
  have "(\<integral>\<^sup>+\<sigma>. ?f (merge (set vs) (set vs') (\<sigma>, \<rho>)) \<partial>state_measure (set vs) \<Gamma>) =
               (\<integral>\<^sup>+\<sigma>'. \<integral>\<^sup>+\<sigma>. ?f (merge (set vs) (set vs') (merge {x, y} (set ?vs) (\<sigma>', \<sigma>), \<rho>))
                  \<partial>state_measure (set ?vs) \<Gamma> \<partial>state_measure {x,y} \<Gamma>)" (is "_ = ?I")
    using meas insert_eq unfolding state_measure_def
    by (subst A, subst product_nn_integral_fold) (simp_all add: borel_measurable_ereal)
  also have "\<And>\<sigma>' \<sigma>. merge (set vs) (set vs') (merge {x, y} (set ?vs) (\<sigma>', \<sigma>), \<rho>) =
                       merge (set vs) (set vs') (\<sigma>(x := \<sigma>' x, y := \<sigma>' y), \<rho>)"
    by (intro ext) (auto simp: merge_def)
  hence "?I = (\<integral>\<^sup>+\<sigma>'. \<integral>\<^sup>+\<sigma>. ?f (merge (set vs) (set vs') (\<sigma>(x := \<sigma>' x, y := \<sigma>' y), \<rho>))
                  \<partial>state_measure (set ?vs) \<Gamma> \<partial>state_measure {x,y} \<Gamma>)" by simp
  also have "... = \<integral>\<^sup>+z. \<integral>\<^sup>+\<sigma>. ?f (merge (set vs) (set vs') (\<sigma>(x := fst z, y := snd z), \<rho>))
                     \<partial>state_measure (set ?vs) \<Gamma> \<partial>(stock_measure (\<Gamma> x) \<Otimes>\<^sub>M stock_measure (\<Gamma> y))"
    (is "_ = ?I") using `x \<noteq> y` meas_upd2 \<rho> invar unfolding state_measure_def
    by (subst product_nn_integral_pair, subst measurable_split_conv,
        intro sf_PiM.borel_measurable_nn_integral)
       (auto simp: measurable_split_conv state_measure_def intro!: borel_measurable_ereal
            measurable_compose[OF _ measurable_cexpr_sem'] measurable_Pair )
  finally have "(\<integral>\<^sup>+\<sigma>. ?f (merge (set vs) (set vs') (\<sigma>, \<rho>)) \<partial>state_measure (set vs) \<Gamma>) = ?I" .
  moreover have "(\<integral>\<^sup>+\<sigma>. ?f (merge (set vs) (set vs') (\<sigma>, \<rho>)) \<partial>state_measure (set vs) \<Gamma>) \<noteq> \<infinity>"
    using cdens_ctxt_invar_imp_integrable[OF assms(1) \<rho>] unfolding real_integrable_def by simp
  ultimately have "?I \<noteq> \<infinity>" by simp
  hence "AE z in stock_measure (\<Gamma> x) \<Otimes>\<^sub>M stock_measure (\<Gamma> y).
           (\<integral>\<^sup>+\<sigma>. ?f (merge (set vs) (set vs') (\<sigma>(x := fst z, y := snd z), \<rho>))
               \<partial>state_measure (set ?vs) \<Gamma>) \<noteq> \<infinity>" (is "AE z in _. ?P z")
    using meas_upd2 \<rho> invar unfolding state_measure_def
    by (intro nn_integral_PInf_AE sf_PiM.borel_measurable_nn_integral)
       (auto intro!: borel_measurable_ereal measurable_compose[OF _ measurable_cexpr_sem']
             measurable_Pair simp: measurable_split_conv state_measure_def)
  hence "AE z in stock_measure (\<Gamma> x) \<Otimes>\<^sub>M stock_measure (\<Gamma> y).
          ereal (extract_real (cexpr_sem (case_nat (split PairVal z) \<rho>) (marg_dens2_cexpr \<Gamma> vs x y \<delta>))) =
               marg_dens2 (dens_ctxt_\<alpha> (vs,vs',\<Gamma>,\<delta>)) x y \<rho> (split PairVal z)"
  proof (rule AE_mp[OF _ AE_I2[OF impI]])
    fix z assume z: "z \<in> space (stock_measure (\<Gamma> x) \<Otimes>\<^sub>M stock_measure (\<Gamma> y))"
    assume fin: "?P z"
    have "\<And>\<sigma>. merge (set vs) (set vs') (\<sigma>(x := fst z, y := snd z), \<rho>) =
                 merge (set ?vs) ({x,y} \<union> set vs') (\<sigma>, \<rho>(x := fst z, y := snd z))" using x y
      by (intro ext) (simp add: merge_def)
    hence A: "(\<integral>\<^sup>+\<sigma>. ?f (merge (set vs) (set vs') (\<sigma>(x := fst z, y := snd z), \<rho>))
                 \<partial>state_measure (set ?vs) \<Gamma>) =
              (\<integral>\<^sup>+\<sigma>. ?f (merge (set ?vs) ({x,y} \<union> set vs') (\<sigma>, \<rho>(x := fst z, y := snd z)))
                   \<partial>state_measure (set ?vs) \<Gamma>)" (is "_ = \<integral>\<^sup>+\<sigma>. ereal (?g \<sigma>) \<partial>?M")
      by (intro nn_integral_cong) simp
    have \<rho>': "\<rho>(x := fst z, y := snd z) \<in> space (state_measure ({x, y} \<union> set vs') \<Gamma>)"
      using z \<rho> unfolding state_measure_def
      by (auto simp: space_PiM space_pair_measure split: split_if_asm)
    have integrable: "integrable ?M ?g"
    proof (intro integrableI_nonneg[OF _ AE_I2])
      show "?g \<in> borel_measurable ?M" using invar \<rho>' by (intro measurable_cexpr_sem') auto
      show "(\<integral>\<^sup>+\<sigma>. ereal (?g \<sigma>) \<partial>?M) < \<infinity>" using fin A by simp
      fix \<sigma> assume \<sigma>: "\<sigma> \<in> space ?M"
      from x y have "set ?vs \<union> ({x,y} \<union> set vs') = set vs \<union> set vs'" by auto
      thus "?g \<sigma> \<ge> 0" using merge_in_state_measure[OF \<sigma> \<rho>']
        by (intro nonneg_cexprD[OF invar(4)]) simp_all
    qed
    from x y have B: "(set ?vs \<union> ({x, y} \<union> set vs')) = set vs \<union> set vs'" by auto
    have nonneg: "nonneg_cexpr (set [z\<leftarrow>vs . z \<noteq> x \<and> z \<noteq> y] \<union> ({x, y} \<union> set vs')) \<Gamma> \<delta>"
      using invar by (subst B) simp

    have "ereal (extract_real (cexpr_sem (case_nat (split PairVal z) \<rho>) (marg_dens2_cexpr \<Gamma> vs x y \<delta>))) =
            extract_real (cexpr_sem ((case_nat <|fst z, snd z|> \<rho>) (Suc x := fst z, Suc y := snd z) \<circ> Suc)
                               (integrate_vars \<Gamma> ?vs \<delta>))"
      unfolding marg_dens2_cexpr_def
      by (simp add: cexpr_sem_cexpr_comp_aux extract_pair_def cexpr_sem_map_vars split: prod.split)
    also have "((case_nat <|fst z, snd z|> \<rho>) (Suc x := fst z, Suc y := snd z)) \<circ> Suc =
                   \<rho>(x := fst z, y := snd z)" (is "?\<rho>1 = ?\<rho>2") by (intro ext) (simp split: nat.split)
    also have "ereal (extract_real (cexpr_sem (\<rho>(x := fst z, y := snd z))
               (integrate_vars \<Gamma> [z\<leftarrow>vs . z \<noteq> x \<and> z \<noteq> y] \<delta>))) =
             \<integral>\<^sup>+xa. ?f (merge (set ?vs) ({x, y} \<union> set vs') (xa, \<rho>(x := fst z, y := snd z))) \<partial>?M"
      using invar assms by (intro cexpr_sem_integrate_vars'[OF \<rho>' _ _ nonneg integrable]) auto
    also have C: "set ?vs = set vs - {x, y}" by auto
    have "(\<integral>\<^sup>+xa. ?f (merge (set ?vs) ({x, y} \<union> set vs') (xa, \<rho>(x := fst z, y := snd z))) \<partial>?M) =
                 marg_dens2 (dens_ctxt_\<alpha> (vs,vs',\<Gamma>,\<delta>)) x y \<rho> (split PairVal z)"
      unfolding marg_dens2_def
      by (subst A[symmetric], subst C, simp only: dens_ctxt_\<alpha>_def prod.case)
         (auto intro!: nn_integral_cong split: prod.split simp: extract_pair_def)
    finally show "ereal (extract_real (cexpr_sem (case_nat (split PairVal z) \<rho>)
                                            (marg_dens2_cexpr \<Gamma> vs x y \<delta>))) =
                      marg_dens2 (dens_ctxt_\<alpha> (vs, vs', \<Gamma>, \<delta>)) x y \<rho> (split PairVal z)" .
  qed
  thus ?thesis by (subst stock_measure.simps, subst AE_embed_measure[OF inj_PairVal]) simp
qed

lemma nonneg_cexpr_sem_marg_dens2:
  assumes "cdens_ctxt_invar vs vs' \<Gamma> \<delta>"
  assumes x: "x \<in> set vs" and y: "y \<in> set vs" and \<rho>: "\<rho> \<in> space (state_measure (set vs') \<Gamma>)"
  assumes v: "v \<in> type_universe (PRODUCT (\<Gamma> x) (\<Gamma> y))"
  shows "extract_real (cexpr_sem (case_nat v \<rho>) (marg_dens2_cexpr \<Gamma> vs x y \<delta>)) \<ge> 0"
proof-
  from v obtain a b where v': "v = <|a, b|>" "a \<in> type_universe (\<Gamma> x)" "b \<in> type_universe (\<Gamma> y)"
    by (auto simp: space_stock_measure[symmetric] space_embed_measure space_pair_measure
             simp del: space_stock_measure)
  let ?vs = "filter (\<lambda>z. z \<noteq> x \<and> z \<noteq> y) vs"
  note invar = cdens_ctxt_invarD[OF assms(1)]
  have A: "((case_nat v \<rho>) (Suc x := fst (extract_pair v), Suc y := snd (extract_pair v))) \<circ> Suc =
               \<rho>(x := fst (extract_pair v), y := snd (extract_pair v))" by (intro ext) auto
  have B: "\<rho>(x := fst (extract_pair v), y := snd (extract_pair v))
                     \<in> space (state_measure (set vs' \<union> {x,y}) \<Gamma>)" using x y v' \<rho>
    by (auto simp: state_measure_def space_PiM extract_pair_def split: split_if_asm)
  from x y have "set ?vs \<union> (set vs' \<union> {x, y}) = set vs \<union> set vs'" by auto
  with invar have "nonneg_cexpr (set ?vs \<union> (set vs' \<union> {x, y})) \<Gamma> \<delta>" by simp
  thus ?thesis using assms invar(1-3) A unfolding marg_dens2_cexpr_def
    by (auto simp: cexpr_sem_cexpr_comp_aux cexpr_sem_map_vars intro!: nonneg_cexpr_sem_integrate_vars[OF B])
qed

definition branch_prob_cexpr :: "cdens_ctxt \<Rightarrow> cexpr" where
  "branch_prob_cexpr \<equiv> \<lambda>(vs, vs', \<Gamma>, \<delta>). integrate_vars \<Gamma> vs \<delta>"

lemma free_vars_branch_prob_cexpr[simp]:
    "free_vars (branch_prob_cexpr (vs, vs', \<Gamma>, \<delta>)) = free_vars \<delta> - set vs"
  unfolding branch_prob_cexpr_def by simp

lemma cexpr_typing_branch_prob_cexpr[intro]:
  "\<Gamma> \<turnstile>\<^sub>c \<delta> : REAL \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>c branch_prob_cexpr (vs,vs',\<Gamma>,\<delta>) : REAL"
  unfolding branch_prob_cexpr_def
  by (simp only: prod.case, rule cexpr_typing_integrate_vars)

lemma cexpr_sem_branch_prob:
  assumes "cdens_ctxt_invar vs vs' \<Gamma> \<delta>"
  assumes \<rho>: "\<rho> \<in> space (state_measure (set vs') \<Gamma>)"
  shows "ereal (extract_real (cexpr_sem \<rho> (branch_prob_cexpr (vs, vs', \<Gamma>, \<delta>)))) =
             branch_prob (dens_ctxt_\<alpha> (vs, vs', \<Gamma>, \<delta>)) \<rho>"
proof-
  note invar = cdens_ctxt_invarD[OF assms(1)]
  interpret density_context "set vs" "set vs'" \<Gamma> "\<lambda>\<sigma>. extract_real (cexpr_sem \<sigma> \<delta>)"
    by (rule density_context_\<alpha>) fact
  have "ereal (extract_real (cexpr_sem \<rho> (branch_prob_cexpr (vs, vs', \<Gamma>, \<delta>)))) =
          \<integral>\<^sup>+\<sigma>. extract_real (cexpr_sem (merge (set vs) (set vs') (\<sigma>, \<rho>)) \<delta>)
                   \<partial>state_measure (set vs) \<Gamma>" (is "_ = ?I")
    using assms(2) invar unfolding branch_prob_cexpr_def
    by (simp only: prod.case, subst cexpr_sem_integrate_vars')
       (auto intro!: cdens_ctxt_invar_imp_integrable assms)
  also have "... = branch_prob (dens_ctxt_\<alpha> (vs, vs', \<Gamma>, \<delta>)) \<rho>"
    using \<rho> unfolding dens_ctxt_\<alpha>_def by (simp only: prod.case branch_prob_altdef[of \<rho>])
  finally show ?thesis .
qed

lemma subprob_imp_subprob_cexpr:
  assumes "density_context V V' \<Gamma> (\<lambda>\<sigma>. extract_real (cexpr_sem \<sigma> \<delta>))"
  shows "subprob_cexpr V V' \<Gamma> \<delta>"
proof (intro subprob_cexprI)
  interpret density_context V V' \<Gamma> "\<lambda>\<sigma>. extract_real (cexpr_sem \<sigma> \<delta>)" by fact
  fix \<rho> assume \<rho>: "\<rho> \<in> space (state_measure V' \<Gamma>)"
  let ?M = "dens_ctxt_measure (V, V', \<Gamma>, \<lambda>\<sigma>. extract_real (cexpr_sem \<sigma> \<delta>)) \<rho>"
  from \<rho> have "(\<integral>\<^sup>+ x. ereal (extract_real (cexpr_sem (merge V V' (x, \<rho>)) \<delta>)) \<partial>state_measure V \<Gamma>) =
                   branch_prob (V, V', \<Gamma>, \<lambda>\<sigma>. extract_real (cexpr_sem \<sigma> \<delta>)) \<rho>" (is "?I = _")
    by (subst branch_prob_altdef[symmetric]) simp_all
  also have "... = emeasure ?M (space ?M)" unfolding branch_prob_def by simp
  also have "... \<le> 1" by (rule subprob_space.emeasure_space_le_1) (simp add: subprob_space_dens \<rho>)
  finally show "?I \<le> 1" .
qed

end


theory Load_Store_Example
  imports
    Extended_Assertion
    Utilities_Ext
    Assertion_Tree_Lookup
    Lookup_Ext
    "Insert/Alloc_Optimized/Insert_Opt_Ext"
    "Delete/Alloc_Optimized/Delete_Opt_Ext"
    Extended_Assertion_Exceptions
    Load_Store
begin

context rbt_impl
begin
interpretation rbt_impl_deps .

definition "example t k1 v1 k2 v2 \<equiv>
  do {
    p \<leftarrow> lookup_ptr k1 t;
    t' \<leftarrow> insert_opt k2 v2 t;
    vp \<leftarrow> load p;
    store p v1;
    return (t', vp)
  }
"

method is_contains = match conclusion in "value_of_key _ _  = _" \<Rightarrow> succeed
method join_filter = then_else is_contains \<open>solves auto\<close> succeed

lemma example_correct:
  "is_rbt (rbt_of t) \<Longrightarrow> rbt_lookup (rbt_of t) k1 \<noteq> None \<Longrightarrow>
  llvm_htriple
  (
    rbt_assn_ext t {} ti **
    \<upharpoonleft>key_assn k1 k1i **
    \<upharpoonleft>key_assn k2 k2i **
    \<upharpoonleft>value_assn v1 v1i **
    \<upharpoonleft>value_assn v2 v2i
  )
  (example ti k1i v1i k2i v2i)
  (\<lambda>(ti_res, vi_res). EXS t_res v_res.
    rbt_assn_ext t_res {} ti_res **
    \<upharpoonleft>value_assn v_res vi_res ** \<upharpoonleft>key_assn k1 k1i **
    \<up>(rbt_of t_res = (rbt_update k1 v1 (rbt_insert k2 v2 (rbt_of t))))
  )
  "
  unfolding example_def
  supply map_leD[elim]
  apply vcg
  apply vcg_compat
  apply (isep_drule drule: value_ex_join_ent; join_filter)
    apply simp_all
  apply sepE
  done

lemma example_correct_2:
  " is_rbt (rbt_of t) \<Longrightarrow> rbt_lookup (rbt_of t) k1 \<noteq> None \<Longrightarrow>
  llvm_htriple
  (
    rbt_assn_ext t {} ti **
    \<upharpoonleft>key_assn k1 k1i **
    \<upharpoonleft>key_assn k2 k2i **
    \<upharpoonleft>value_assn v1 v1i **
    \<upharpoonleft>value_assn v2 v2i
  )
  (example ti k1i v1i k2i v2i)
  (\<lambda>(ti_res, vi_res). EXS t_res v_res.
    rbt_assn_ext t_res {} ti_res **
    \<upharpoonleft>value_assn (the (rbt_lookup (rbt_insert k2 v2 (rbt_of t)) k1)) vi_res ** \<upharpoonleft>key_assn k1 k1i **
    \<up>(rbt_of t_res = (rbt_update k1 v1 (rbt_insert k2 v2 (rbt_of t))))
  )
  "
  unfolding example_def
  supply map_leD[elim]
  apply vcg
  apply vcg_compat
  apply (sepEwith \<open>join_filter, auto?\<close> isep_dest: value_ex_join_ent)
  apply simp
  apply sep
  done

definition "example2 t k1 k2 k3 v1 v2 f1 f2 \<equiv>
  do {
    pk1 \<leftarrow> lookup_ptr k1 t;
    t' \<leftarrow> insert_opt k2 v2 t;
    vk1 \<leftarrow> load pk1;
    t'' \<leftarrow> delete_opt k3 t';
    vk1' \<leftarrow> f1 vk1;
    f2 v2;
    store pk1 v1;
    return (t'', vk1')
  }
"

lemma rbt_assn_ext_diff_ex_sets [fri_red_rules]:
  "ex1 = ex2 \<Longrightarrow> is_sep_red \<box> \<box> (rbt_assn_ext t ex1 ti) (rbt_assn_ext t ex2 ti)"
  apply (rule is_sep_redI)
  apply simp
  subgoal premises prems
    apply (sep isep_dest: prems(2))
    done
  done

lemma rbt_update_comp_comm:
  "k1 \<noteq> k2 \<Longrightarrow> rbt_update k2 v2 (rbt_update k1 v1 t) = rbt_update k1 v1 (rbt_update k2 v2 t)"
  apply (induction t) by auto

method catch_sep_prop = match conclusion in "ENTAILS _ _" \<Rightarrow> vcg_compat
  \<bar> "FRAME _ _ _" \<Rightarrow> vcg_compat
  \<bar> "PRECOND (FRAME _ _ _)" \<Rightarrow> vcg_compat

method vcg_sep = (catch_sep_prop | vcg_step | vcg_rl | vcg_solve | sepEwith \<open>solves auto\<close> isep_dest: value_ex_join_ent)+

lemma example2_correct:
  assumes
    [vcg_rules]: "\<And>v vi. llvm_htriple (\<upharpoonleft>value_assn v vi) (f1i vi) (\<lambda>v_res. \<upharpoonleft>value_assn (f1 v) v_res)" and
    [vcg_rules]: "\<And>v vi. llvm_htriple (\<upharpoonleft>value_assn v vi) (f2i vi) (\<lambda>_. \<upharpoonleft>value_assn (f2 v) vi)"
  shows
    "\<lbrakk>is_rbt (rbt_of t); rbt_lookup (rbt_of t) k1 \<noteq> None; k1 \<noteq> k2; k1 \<noteq> k3; k2 \<noteq> k3\<rbrakk> \<Longrightarrow>
  llvm_htriple
  (
    rbt_assn_ext t {} ti **
    \<upharpoonleft>key_assn k1 k1i **
    \<upharpoonleft>key_assn k2 k2i **
    \<upharpoonleft>key_assn k3 k3i **
    \<upharpoonleft>value_assn v1 v1i **
    \<upharpoonleft>value_assn v2 v2i
  )
  (example2 ti k1i k2i k3i v1i v2i f1i f2i)
  (\<lambda>(ti_res, vi_res). EXS t_res v_res.
    rbt_assn_ext t_res {} ti_res **
    \<upharpoonleft>key_assn k1 k1i ** \<upharpoonleft>key_assn k3 k3i **
    \<upharpoonleft>value_assn (f1 (the (rbt_lookup (rbt_of t) k1))) vi_res **
    \<up>(rbt_of t_res = (rbt_update k2 (f2 v2) (rbt_update  k1 v1 (rbt_delete k3 (rbt_insert k2 v2 (rbt_of t))))))
  )
  "
  unfolding example2_def
  supply
    map_leD[elim!]
    is_rbt_def[simp]
  supply value_ex_split_red[fri_red_rules]
  apply (timeit vcg_sep)

  (*
  apply vcg
  apply vcg_rl

   apply vcg_compat
    apply (sepEwith \<open>solves auto\<close> isep_dest: value_ex_join_ent)

  apply vcg_solve
  apply vcg
  apply vcg_rl

   apply vcg_compat
    apply (sepEwith \<open>solves auto\<close> isep_dest: value_ex_join_ent)

  term "inv1"
  apply vcg_solve
  apply vcg

  apply vcg_compat
  *)
  subgoal
    apply sep

    apply (simp_all add: rbt_update_comp_comm rbt_lookup_delete inv_12_def rbt_lookup_rbt_insert)

    subgoal premises
      apply sep
      done
    done
  done

end

end


theory "Transition_Systems-Mutation_Systems"
imports
  "Transition_Systems-Simulation_Systems"
begin

primrec with_shortcut :: "('a \<Rightarrow> 'p relation) \<Rightarrow> ('a option \<Rightarrow> 'p relation)" where
  "with_shortcut \<T> None = (=)" |
  "with_shortcut \<T> (Some \<alpha>) = \<T> \<alpha>"

locale mutation_system =
  simulation_system \<open>original_transition\<close> \<open>simulating_transition\<close>
  for
    original_transition :: "'a \<Rightarrow> 'p relation" (\<open>'(\<rightharpoonup>\<lparr>_\<rparr>')\<close>)
  and
    simulating_transition :: "'a \<Rightarrow> 'p relation" (\<open>'(\<rightharpoondown>\<lparr>_\<rparr>')\<close>)
  +
  fixes
    original_shortcut_transition :: "'a option \<Rightarrow> 'p relation" (\<open>'(\<rightharpoonup>\<^sup>?\<lparr>_\<rparr>')\<close>)
  fixes
    simulating_shortcut_transition :: "'a option \<Rightarrow> 'p relation" (\<open>'(\<rightharpoondown>\<^sup>?\<lparr>_\<rparr>')\<close>)
  fixes
    universe :: "'p relation set" (\<open>\<U>\<close>)
  fixes
    mutation_transition_std :: "'p relation \<Rightarrow> 'a \<Rightarrow> 'a option \<Rightarrow> 'p relation \<Rightarrow> bool"
    (\<open>(_ \<longrightarrow>\<lparr>_ \<bar> _\<rparr>/ _)\<close> [51, 0, 0, 51] 50)
  defines original_shortcut_transition_def [simp]:
    "original_shortcut_transition \<equiv> with_shortcut original_transition"
  defines simulating_shortcut_transition_def [simp]:
    "simulating_shortcut_transition \<equiv> with_shortcut simulating_transition"
  assumes mutation_transition_std_is_type_correct:
    "\<And>\<alpha> \<omega> I J. I \<longrightarrow>\<lparr>\<alpha> \<bar> \<omega>\<rparr> J \<Longrightarrow> I \<in> \<U> \<and> J \<in> \<U>"
  assumes dissection:
    "\<And>\<alpha>. \<forall>I \<in> \<U>. I OO (\<rightharpoonup>\<lparr>\<alpha>\<rparr>) \<le> \<Squnion> {(\<rightharpoonup>\<^sup>?\<lparr>\<omega>\<rparr>) OO J | \<omega> J. I \<longrightarrow>\<lparr>\<alpha> \<bar> \<omega>\<rparr> J}"
  assumes connection:
    "\<And>\<alpha>. \<forall>J \<in> \<U>. \<Squnion> {I\<inverse>\<inverse> OO (\<rightharpoondown>\<^sup>?\<lparr>\<omega>\<rparr>) | \<omega> I. I \<longrightarrow>\<lparr>\<alpha> \<bar> \<omega>\<rparr> J} \<le> (\<rightharpoondown>\<lparr>\<alpha>\<rparr>) OO J\<inverse>\<inverse>"
begin

text \<open>
  The introduction of an explicit \<^term>\<open>mutation_transition_std\<close> relation has the following
  advantages:

    \<^item> We can replace Sangiorgi's seemingly \<^emph>\<open>ad hoc\<close> condition by a pair of conditions that are in
      perfect duality.

    \<^item> We can refer from the outside to the data that is only guaranteed to exist in the case of
      Sangiorgi's condition. This is crucial for the specification of weak mutation systems.
\<close>

definition mutant_lifting :: "'p relation \<Rightarrow> 'p relation" (\<open>\<M>\<close>) where
  [simp]: "\<M> = (\<lambda>K. (\<Squnion>I \<in> \<U>. I\<inverse>\<inverse> OO K OO I))"

context begin

text \<open>
  This is the place where we finally need the extra condition \<^term>\<open>K \<le> L\<close> that sets apart
  \<^term>\<open>K \<leadsto> L\<close> from \<^term>\<open>K \<mapsto> L\<close>.
\<close>

private lemma unilateral_shortcut_progression:
  assumes "K \<le> L" and "K \<hookrightarrow> L"
  shows "K\<inverse>\<inverse> OO (\<rightharpoonup>\<^sup>?\<lparr>\<omega>\<rparr>) \<le> (\<rightharpoondown>\<^sup>?\<lparr>\<omega>\<rparr>) OO L\<inverse>\<inverse>"
  using assms by (cases \<omega>) auto

private lemma unilateral_mutant_progression:
  assumes "K \<le> L" and "K \<hookrightarrow> L"
  shows "\<M> K \<hookrightarrow> \<M> L"
proof -
  have "(\<Squnion>I \<in> \<U>. I\<inverse>\<inverse> OO K OO I)\<inverse>\<inverse> OO (\<rightharpoonup>\<lparr>\<alpha>\<rparr>) \<le> (\<rightharpoondown>\<lparr>\<alpha>\<rparr>) OO (\<Squnion>J \<in> \<U>. J\<inverse>\<inverse> OO L OO J)\<inverse>\<inverse>" for \<alpha>
  proof -
    have "(\<Squnion>I \<in> \<U>. I\<inverse>\<inverse> OO K OO I)\<inverse>\<inverse> OO (\<rightharpoonup>\<lparr>\<alpha>\<rparr>) = (\<Squnion>I \<in> \<U>. I\<inverse>\<inverse> OO K\<inverse>\<inverse> OO I) OO (\<rightharpoonup>\<lparr>\<alpha>\<rparr>)"
      by blast
    also have "\<dots> = (\<Squnion>I \<in> \<U>. I\<inverse>\<inverse> OO K\<inverse>\<inverse> OO I OO (\<rightharpoonup>\<lparr>\<alpha>\<rparr>))"
      by blast
    also have "\<dots> \<le> (\<Squnion>I \<in> \<U>. I\<inverse>\<inverse> OO K\<inverse>\<inverse> OO \<Squnion> {(\<rightharpoonup>\<^sup>?\<lparr>\<omega>\<rparr>) OO J | \<omega> J. I \<longrightarrow>\<lparr>\<alpha> \<bar> \<omega>\<rparr> J})"
      using dissection
      by simp fast
    also have "\<dots> = (\<Squnion>I \<in> \<U>. \<Squnion> {I\<inverse>\<inverse> OO K\<inverse>\<inverse> OO (\<rightharpoonup>\<^sup>?\<lparr>\<omega>\<rparr>) OO J | \<omega> J. I \<longrightarrow>\<lparr>\<alpha> \<bar> \<omega>\<rparr> J})"
      by blast
    also have "\<dots> = \<Squnion> {I\<inverse>\<inverse> OO K\<inverse>\<inverse> OO (\<rightharpoonup>\<^sup>?\<lparr>\<omega>\<rparr>) OO J | \<omega> I J. I \<longrightarrow>\<lparr>\<alpha> \<bar> \<omega>\<rparr> J}"
      using mutation_transition_std_is_type_correct
      by blast
    also have "\<dots> \<le> \<Squnion> {I\<inverse>\<inverse> OO (\<rightharpoondown>\<^sup>?\<lparr>\<omega>\<rparr>) OO L\<inverse>\<inverse> OO J | \<omega> I J. I \<longrightarrow>\<lparr>\<alpha> \<bar> \<omega>\<rparr> J}"
      using unilateral_shortcut_progression [OF \<open>K \<le> L\<close> \<open>K \<hookrightarrow> L\<close>]
      by blast
    also have "\<dots> = (\<Squnion>J \<in> \<U>. \<Squnion> {I\<inverse>\<inverse> OO (\<rightharpoondown>\<^sup>?\<lparr>\<omega>\<rparr>) OO L\<inverse>\<inverse> OO J | \<omega> I. I \<longrightarrow>\<lparr>\<alpha> \<bar> \<omega>\<rparr> J})"
      using mutation_transition_std_is_type_correct
      by blast
    also have "\<dots> = (\<Squnion>J \<in> \<U>. \<Squnion> {I\<inverse>\<inverse> OO (\<rightharpoondown>\<^sup>?\<lparr>\<omega>\<rparr>) | \<omega> I. I \<longrightarrow>\<lparr>\<alpha> \<bar> \<omega>\<rparr> J} OO L\<inverse>\<inverse> OO J)"
      by blast
    also have "\<dots> \<le> (\<Squnion>J \<in> \<U>. (\<rightharpoondown>\<lparr>\<alpha>\<rparr>) OO J\<inverse>\<inverse> OO L\<inverse>\<inverse> OO J)"
      using connection
      by simp fast
    also have "\<dots> = (\<rightharpoondown>\<lparr>\<alpha>\<rparr>) OO (\<Squnion>J \<in> \<U>. J\<inverse>\<inverse> OO L\<inverse>\<inverse> OO J)"
      by blast
    also have "\<dots> = (\<rightharpoondown>\<lparr>\<alpha>\<rparr>) OO (\<Squnion>J \<in> \<U>. J\<inverse>\<inverse> OO L OO J)\<inverse>\<inverse>"
      by blast
    finally show ?thesis .
  qed
  then show ?thesis
    by simp
qed

lemma mutant_lifting_is_respectful [respectful]:
  shows "respectful \<M>"
proof -
  have "\<M> K \<leadsto> \<M> L" if "K \<leadsto> L" for K and L
  proof -
    from \<open>K \<leadsto> L\<close> have "K \<le> L" and "K\<inverse>\<inverse> \<le> L\<inverse>\<inverse>" and "K \<hookrightarrow> L" and "K\<inverse>\<inverse> \<hookrightarrow> L\<inverse>\<inverse>"
      by simp_all
    from \<open>K \<le> L\<close> have "\<M> K \<le> \<M> L"
      by auto
    moreover
    from \<open>K \<le> L\<close> and \<open>K \<hookrightarrow> L\<close> have "\<M> K \<hookrightarrow> \<M> L"
      by (fact unilateral_mutant_progression)
    moreover
    from \<open>K\<inverse>\<inverse> \<le> L\<inverse>\<inverse>\<close> and \<open>K\<inverse>\<inverse> \<hookrightarrow> L\<inverse>\<inverse>\<close> have "\<M> K\<inverse>\<inverse> \<hookrightarrow> \<M> L\<inverse>\<inverse>"
      by (fact unilateral_mutant_progression)
    then have "(\<M> K)\<inverse>\<inverse> \<hookrightarrow> (\<M> L)\<inverse>\<inverse>"
      unfolding mutant_lifting_def by blast
    ultimately show ?thesis
      by simp
  qed
  then show ?thesis
    by simp
qed

end

lemma mutation_is_compatible_with_bisimilarity:
  assumes "I \<in> \<U>" and "I s\<^sub>1 t\<^sub>1" and "I s\<^sub>2 t\<^sub>2" and "s\<^sub>1 \<sim> s\<^sub>2"
  shows "t\<^sub>1 \<sim> t\<^sub>2"
  using
    respectfully_transformed_bisimilarity_in_bisimilarity [OF mutant_lifting_is_respectful]
  and
    assms
  by auto

end

end