(* Copyright 2021 (C) Mihails Milehins *)

section\<open>\<open>SemiCAT\<close> as a semicategory\<close>
theory CZH_SMC_SemiCAT
  imports
    CZH_DG_SemiCAT
    CZH_SMC_Simple
    CZH_SMC_Small_Semicategory
begin

subsection\<open>Background\<close>

text\<open>
The subsection presents the theory of the semicategories of
\<open>\<alpha>\<close>-semicategories.
It continues the development that was initiated in section
\ref{sec:dg_SemiCAT}.
\<close>

named_theorems smc_SemiCAT_simps
named_theorems smc_SemiCAT_intros

subsection\<open>Definition and elementary properties\<close>

definition smc_SemiCAT :: "V \<Rightarrow> V"
  where "smc_SemiCAT \<alpha> =
    [
      set {\<CC>. semicategory \<alpha> \<CC>},
      all_smcfs \<alpha>,
      (\<lambda>\<FF>\<in>\<^sub>\<circ>all_smcfs \<alpha>. \<FF>\<lparr>HomDom\<rparr>),
      (\<lambda>\<FF>\<in>\<^sub>\<circ>all_smcfs \<alpha>. \<FF>\<lparr>HomCod\<rparr>),
      (\<lambda>\<GG>\<FF>\<in>\<^sub>\<circ>composable_arrs (dg_SemiCAT \<alpha>). \<GG>\<FF>\<lparr>0\<rparr> \<circ>\<^sub>S\<^sub>M\<^sub>C\<^sub>F \<GG>\<FF>\<lparr>1\<^sub>\<nat>\<rparr>)
    ]\<^sub>\<circ>"

text\<open>Components.\<close>

lemma smc_SemiCAT_components:
  shows "smc_SemiCAT \<alpha>\<lparr>Obj\<rparr> = set {\<CC>. semicategory \<alpha> \<CC>}"
    and "smc_SemiCAT \<alpha>\<lparr>Arr\<rparr> = all_smcfs \<alpha>"
    and "smc_SemiCAT \<alpha>\<lparr>Dom\<rparr> = (\<lambda>\<FF>\<in>\<^sub>\<circ>all_smcfs \<alpha>. \<FF>\<lparr>HomDom\<rparr>)"
    and "smc_SemiCAT \<alpha>\<lparr>Cod\<rparr> = (\<lambda>\<FF>\<in>\<^sub>\<circ>all_smcfs \<alpha>. \<FF>\<lparr>HomCod\<rparr>)"
    and "smc_SemiCAT \<alpha>\<lparr>Comp\<rparr> =
      (\<lambda>\<GG>\<FF>\<in>\<^sub>\<circ>composable_arrs (dg_SemiCAT \<alpha>). \<GG>\<FF>\<lparr>0\<rparr> \<circ>\<^sub>S\<^sub>M\<^sub>C\<^sub>F \<GG>\<FF>\<lparr>1\<^sub>\<nat>\<rparr>)"
  unfolding smc_SemiCAT_def dg_field_simps
  by (simp_all add: nat_omega_simps)

text\<open>Slicing.\<close>

lemma smc_dg_SemiCAT[smc_SemiCAT_simps]: "smc_dg (smc_SemiCAT \<alpha>) = dg_SemiCAT \<alpha>"
proof(rule vsv_eqI)
  show "vsv (smc_dg (smc_SemiCAT \<alpha>))" unfolding smc_dg_def by auto
  show "vsv (dg_SemiCAT \<alpha>)" unfolding dg_SemiCAT_def by auto
  have dom_lhs: "\<D>\<^sub>\<circ> (smc_dg (smc_SemiCAT \<alpha>)) = 4\<^sub>\<nat>"
    unfolding smc_dg_def by (simp add: nat_omega_simps)
  have dom_rhs: "\<D>\<^sub>\<circ> (dg_SemiCAT \<alpha>) = 4\<^sub>\<nat>"
    unfolding dg_SemiCAT_def by (simp add: nat_omega_simps)
  show "\<D>\<^sub>\<circ> (smc_dg (smc_SemiCAT \<alpha>)) = \<D>\<^sub>\<circ> (dg_SemiCAT \<alpha>)"
    unfolding dom_lhs dom_rhs by simp
  show "a \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (smc_dg (smc_SemiCAT \<alpha>)) \<Longrightarrow>
    smc_dg (smc_SemiCAT \<alpha>)\<lparr>a\<rparr> = dg_SemiCAT \<alpha>\<lparr>a\<rparr>"
    for a
    by
      (
        unfold dom_lhs,
        elim_in_numeral,
        unfold smc_dg_def dg_field_simps smc_SemiCAT_def dg_SemiCAT_def
      )
      (auto simp: nat_omega_simps)
qed

lemmas_with [folded smc_dg_SemiCAT, unfolded slicing_simps]:
  smc_SemiCAT_ObjI = dg_SemiCAT_ObjI
  and smc_SemiCAT_ObjD = dg_SemiCAT_ObjD
  and smc_SemiCAT_ObjE = dg_SemiCAT_ObjE
  and smc_SemiCAT_Obj_iff[smc_SemiCAT_simps] = dg_SemiCAT_Obj_iff
  and smc_SemiCAT_Dom_app[smc_SemiCAT_simps] = dg_SemiCAT_Dom_app
  and smc_SemiCAT_Cod_app[smc_SemiCAT_simps] = dg_SemiCAT_Cod_app
  and smc_SemiCAT_is_arrI = dg_SemiCAT_is_arrI
  and smc_SemiCAT_is_arrD = dg_SemiCAT_is_arrD
  and smc_SemiCAT_is_arrE = dg_SemiCAT_is_arrE
  and smc_SemiCAT_is_arr_iff[smc_SemiCAT_simps] = dg_SemiCAT_is_arr_iff

subsection\<open>Composable arrows\<close>

lemma smc_SemiCAT_composable_arrs_dg_SemiCAT:
  "composable_arrs (dg_SemiCAT \<alpha>) = composable_arrs (smc_SemiCAT \<alpha>)"
  unfolding composable_arrs_def smc_dg_SemiCAT[symmetric] slicing_simps by auto

lemma smc_SemiCAT_Comp:
  "smc_SemiCAT \<alpha>\<lparr>Comp\<rparr> =
    (\<lambda>\<GG>\<FF>\<in>\<^sub>\<circ>composable_arrs (smc_SemiCAT \<alpha>). \<GG>\<FF>\<lparr>0\<rparr> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG>\<FF>\<lparr>1\<^sub>\<nat>\<rparr>)"
  unfolding smc_SemiCAT_components smc_SemiCAT_composable_arrs_dg_SemiCAT ..

subsection\<open>Composition\<close>

lemma smc_SemiCAT_Comp_app[smc_SemiCAT_simps]:
  assumes "\<GG> : \<BB> \<mapsto>\<^bsub>smc_SemiCAT \<alpha>\<^esub> \<CC>" and "\<FF> : \<AA> \<mapsto>\<^bsub>smc_SemiCAT \<alpha>\<^esub> \<BB>"
  shows "\<GG> \<circ>\<^sub>A\<^bsub>smc_SemiCAT \<alpha>\<^esub> \<FF> = \<GG> \<circ>\<^sub>S\<^sub>M\<^sub>C\<^sub>F \<FF>"
proof-
  from assms have "[\<GG>, \<FF>]\<^sub>\<circ> \<in>\<^sub>\<circ> composable_arrs (smc_SemiCAT \<alpha>)"
    by (auto simp: composable_arrsI)
  then show "\<GG> \<circ>\<^sub>A\<^bsub>smc_SemiCAT \<alpha>\<^esub> \<FF> = \<GG> \<circ>\<^sub>S\<^sub>M\<^sub>C\<^sub>F \<FF>"
    unfolding smc_SemiCAT_Comp by (simp add: nat_omega_simps)
qed

lemma smc_SemiCAT_Comp_vdomain[smc_SemiCAT_simps]:
  "\<D>\<^sub>\<circ> (smc_SemiCAT \<alpha>\<lparr>Comp\<rparr>) = composable_arrs (smc_SemiCAT \<alpha>)"
  unfolding smc_SemiCAT_Comp by auto

lemma smc_SemiCAT_Comp_vrange: "\<R>\<^sub>\<circ> (smc_SemiCAT \<alpha>\<lparr>Comp\<rparr>) \<subseteq>\<^sub>\<circ> all_smcfs \<alpha>"
proof(rule vsubsetI)
  fix \<HH> assume "\<HH> \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (smc_SemiCAT \<alpha>\<lparr>Comp\<rparr>)"
  then obtain \<GG>\<FF>
    where \<HH>_def: "\<HH> = smc_SemiCAT \<alpha>\<lparr>Comp\<rparr>\<lparr>\<GG>\<FF>\<rparr>"
      and "\<GG>\<FF> \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (smc_SemiCAT \<alpha>\<lparr>Comp\<rparr>)"
    unfolding smc_SemiCAT_components by (auto intro: composable_arrsI)
  then obtain \<GG> \<FF> \<AA> \<BB> \<CC>
    where "\<GG>\<FF> = [\<GG>, \<FF>]\<^sub>\<circ>"
      and \<GG>: "\<GG> : \<BB> \<mapsto>\<^bsub>smc_SemiCAT \<alpha>\<^esub> \<CC>"
      and \<FF>: "\<FF> : \<AA> \<mapsto>\<^bsub>smc_SemiCAT \<alpha>\<^esub> \<BB>"
    by (auto simp: smc_SemiCAT_Comp_vdomain)
  with \<HH>_def have \<HH>_def': "\<HH> = \<GG> \<circ>\<^sub>A\<^bsub>smc_SemiCAT \<alpha>\<^esub> \<FF>" by simp
  from \<GG> \<FF> show "\<HH> \<in>\<^sub>\<circ> all_smcfs \<alpha>"
    unfolding \<HH>_def' by (auto intro: smc_cs_intros simp: smc_SemiCAT_simps)
qed

subsection\<open>\<open>SemiCAT\<close> is a semicategory\<close>

lemma (in \<Z>) tiny_semicategory_smc_SemiCAT:
  assumes "\<Z> \<beta>" and "\<alpha> \<in>\<^sub>\<circ> \<beta>"
  shows "tiny_semicategory \<beta> (smc_SemiCAT \<alpha>)"
proof(intro tiny_semicategoryI, unfold smc_SemiCAT_is_arr_iff)
  show "vfsequence (smc_SemiCAT \<alpha>)" unfolding smc_SemiCAT_def by auto
  show "vcard (smc_SemiCAT \<alpha>) = 5\<^sub>\<nat>"
    unfolding smc_SemiCAT_def by (simp add: nat_omega_simps)
  show "(\<GG>\<FF> \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (smc_SemiCAT \<alpha>\<lparr>Comp\<rparr>)) \<longleftrightarrow>
    (\<exists>\<GG> \<FF> \<BB> \<CC> \<AA>. \<GG>\<FF> = [\<GG>, \<FF>]\<^sub>\<circ> \<and> \<GG> : \<BB> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC> \<and> \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>)"
    for \<GG>\<FF>
    unfolding smc_SemiCAT_Comp_vdomain
  proof
    show "\<GG>\<FF> \<in>\<^sub>\<circ> composable_arrs (smc_SemiCAT \<alpha>) \<Longrightarrow>
      \<exists>\<GG> \<FF> \<BB> \<CC> \<AA>. \<GG>\<FF> = [\<GG>, \<FF>]\<^sub>\<circ> \<and> \<GG>   : \<BB> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC> \<and> \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
      by (elim composable_arrsE) (auto simp: smc_SemiCAT_is_arr_iff)
  next
    assume "\<exists>\<GG> \<FF> \<BB> \<CC> \<AA>. \<GG>\<FF> = [\<GG>, \<FF>]\<^sub>\<circ> \<and> \<GG> : \<BB> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC> \<and> \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
    with smc_SemiCAT_is_arr_iff show "\<GG>\<FF> \<in>\<^sub>\<circ> composable_arrs (smc_SemiCAT \<alpha>)"
      unfolding smc_SemiCAT_Comp_vdomain by (auto intro: smc_cs_intros)
  qed
  show "\<lbrakk> \<GG> : \<BB> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>; \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB> \<rbrakk> \<Longrightarrow>
    \<GG> \<circ>\<^sub>A\<^bsub>smc_SemiCAT \<alpha>\<^esub> \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
    for \<GG> \<BB> \<CC> \<FF> \<AA>
    by (auto simp: smc_SemiCAT_simps intro: smc_cs_intros)
  fix \<HH> \<CC> \<DD> \<GG> \<BB> \<FF> \<AA>
  assume "\<HH> : \<CC> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>" "\<GG> : \<BB> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>" "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
  moreover then have "\<GG> \<circ>\<^sub>S\<^sub>M\<^sub>C\<^sub>F \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>" "\<HH> \<circ>\<^sub>S\<^sub>M\<^sub>C\<^sub>F \<GG> : \<BB> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<DD>"
    by (auto intro: smc_cs_intros)
  ultimately show "\<HH> \<circ>\<^sub>A\<^bsub>smc_SemiCAT \<alpha>\<^esub> \<GG> \<circ>\<^sub>A\<^bsub>smc_SemiCAT \<alpha>\<^esub> \<FF> =
    \<HH> \<circ>\<^sub>A\<^bsub>smc_SemiCAT \<alpha>\<^esub> (\<GG> \<circ>\<^sub>A\<^bsub>smc_SemiCAT \<alpha>\<^esub> \<FF>)"
    by
      (
        simp add:
          smc_SemiCAT_is_arr_iff smc_SemiCAT_Comp_app smcf_comp_assoc
      )
qed
  (
    auto simp:
      assms smc_dg_SemiCAT tiny_digraph_dg_SemiCAT smc_SemiCAT_components
  )

subsection\<open>Initial object\<close>

lemma (in \<Z>) smc_SemiCAT_obj_initialI: "obj_initial (smc_SemiCAT \<alpha>) smc_0"
  unfolding obj_initial_def
proof
  (
    intro obj_terminalI,
    unfold smc_op_simps smc_SemiCAT_is_arr_iff smc_SemiCAT_Obj_iff
  )
  show "semicategory \<alpha> smc_0" by (intro semicategory_smc_0)
  fix \<AA> assume prems: "semicategory \<alpha> \<AA>"
  interpret semicategory \<alpha> \<AA> using prems .
  show "\<exists>!\<FF>. \<FF> : smc_0 \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<AA>"
  proof
    show smcf_0: "smcf_0 \<AA> : smc_0 \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<AA>"
      by
        (
          simp add:
            smcf_0_is_ft_semifunctor semicategory_axioms is_ft_semifunctor.axioms(1)
        )
    fix \<FF> assume prems: "\<FF> : smc_0 \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<AA>"
    then interpret \<FF>: is_semifunctor \<alpha> smc_0 \<AA> \<FF> .
    show "\<FF> = smcf_0 \<AA>"
    proof(rule smcf_eqI)
      show "\<FF> : smc_0 \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<AA>" by (auto simp: smc_cs_intros)
      from smcf_0 show "smcf_0 \<AA> : smc_0 \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<AA>"
        unfolding smc_SemiCAT_is_arr_iff by simp
      have "\<D>\<^sub>\<circ> (\<FF>\<lparr>ObjMap\<rparr>) = 0" by (auto simp: smc_0_components smc_cs_simps)
      with \<FF>.ObjMap.vdomain_vrange_is_vempty show "\<FF>\<lparr>ObjMap\<rparr> = smcf_0 \<AA>\<lparr>ObjMap\<rparr>"
        unfolding smcf_0_components by (auto intro: \<FF>.ObjMap.vsv_vrange_vempty)
      have "\<D>\<^sub>\<circ> (\<FF>\<lparr>ArrMap\<rparr>) = 0" by (auto simp: smc_0_components smc_cs_simps)
      with \<FF>.ArrMap.vdomain_vrange_is_vempty show "\<FF>\<lparr>ArrMap\<rparr> = smcf_0 \<AA>\<lparr>ArrMap\<rparr>"
        unfolding smcf_0_components by (auto intro: \<FF>.ArrMap.vsv_vrange_vempty)
    qed (simp_all add: smcf_0_components)
  qed
qed

lemma (in \<Z>) smc_SemiCAT_obj_initialD:
  assumes "obj_initial (smc_SemiCAT \<alpha>) \<AA>"
  shows "\<AA> = smc_0"
  using assms unfolding obj_initial_def
proof
  (
    elim obj_terminalE,
    unfold smc_op_simps smc_SemiCAT_is_arr_iff smc_SemiCAT_Obj_iff
  )
  assume prems:
    "semicategory \<alpha> \<AA>"
    "semicategory \<alpha> \<BB> \<Longrightarrow> \<exists>!\<FF>. \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
    for \<BB>
  from prems(2)[OF semicategory_smc_0] obtain \<FF> where "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> smc_0"
    by meson
  then interpret \<FF>: is_semifunctor \<alpha> \<AA> smc_0 \<FF> .
  have "\<R>\<^sub>\<circ> (\<FF>\<lparr>ObjMap\<rparr>) \<subseteq>\<^sub>\<circ> 0"
    unfolding smc_0_components(1)[symmetric]
    by (simp add: \<FF>.smcf_ObjMap_vrange)
  then have "\<FF>\<lparr>ObjMap\<rparr> = 0" by (auto intro: \<FF>.ObjMap.vsv_vrange_vempty)
  with \<FF>.smcf_ObjMap_vdomain have Obj[simp]: "\<AA>\<lparr>Obj\<rparr> = 0" by auto
  have "\<R>\<^sub>\<circ> (\<FF>\<lparr>ArrMap\<rparr>) \<subseteq>\<^sub>\<circ> 0"
    unfolding smc_0_components(2)[symmetric]
    by (simp add: \<FF>.smcf_ArrMap_vrange)
  then have "\<FF>\<lparr>ArrMap\<rparr> = 0" by (auto intro: \<FF>.ArrMap.vsv_vrange_vempty)
  with \<FF>.smcf_ArrMap_vdomain have Arr[simp]: "\<AA>\<lparr>Arr\<rparr> = 0" by auto
  from \<FF>.HomDom.Dom.vdomain_vrange_is_vempty have [simp]: "\<AA>\<lparr>Dom\<rparr> = 0"
    by (auto simp: smc_cs_simps intro: \<FF>.HomDom.Dom.vsv_vrange_vempty)
  from \<FF>.HomDom.Cod.vdomain_vrange_is_vempty have [simp]: "\<AA>\<lparr>Cod\<rparr> = 0"
    by (auto simp: smc_cs_simps intro: \<FF>.HomDom.Cod.vsv_vrange_vempty)
  from Arr have "\<AA>\<lparr>Arr\<rparr> ^\<^sub>\<times> 2\<^sub>\<nat> = 0" by (simp add: vcpower_of_vempty)
  with \<FF>.HomDom.Comp.pnop_vdomain have "\<D>\<^sub>\<circ> (\<AA>\<lparr>Comp\<rparr>) = 0" by simp
  with \<FF>.HomDom.Comp.vdomain_vrange_is_vempty have [simp]: "\<AA>\<lparr>Comp\<rparr> = 0"
    by (auto intro: \<FF>.HomDom.Comp.vsv_vrange_vempty)
  show "\<AA> = smc_0"
    by (rule smc_eqI[of \<alpha>])
      (simp_all add: prems(1) smc_0_components semicategory_smc_0)
qed

lemma (in \<Z>) smc_SemiCAT_obj_initialE:
  assumes "obj_initial (smc_SemiCAT \<alpha>) \<AA>"
  obtains "\<AA> = smc_0"
  using assms by (auto dest: smc_SemiCAT_obj_initialD)

lemma (in \<Z>) smc_SemiCAT_obj_initial_iff[smc_SemiCAT_simps]:
  "obj_initial (smc_SemiCAT \<alpha>) \<AA> \<longleftrightarrow> \<AA> = smc_0"
  using smc_SemiCAT_obj_initialI smc_SemiCAT_obj_initialD by auto

subsection\<open>Terminal object\<close>

lemma (in \<Z>) smc_SemiCAT_obj_terminalI[smc_SemiCAT_intros]:
  assumes "a \<in>\<^sub>\<circ> Vset \<alpha>" and "f \<in>\<^sub>\<circ> Vset \<alpha>"
  shows "obj_terminal (smc_SemiCAT \<alpha>) (smc_1 a f)"
proof
  (
    intro obj_terminalI,
    unfold smc_op_simps smc_SemiCAT_is_arr_iff smc_SemiCAT_Obj_iff
  )
  fix \<AA> assume "semicategory \<alpha> \<AA>"
  then interpret semicategory \<alpha> \<AA> .
  show "\<exists>!\<FF>'. \<FF>' : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> smc_1 a f"
  proof
    show smcf_1: "smcf_const \<AA> (smc_1 a f) a f : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> smc_1 a f"
      by
        (
          auto
            intro: smc_cs_intros smc_1_is_arrI smcf_const_is_semifunctor
            simp: assms semicategory_smc_1
        )
    fix \<FF>' assume "\<FF>' : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> smc_1 a f"
    then interpret \<FF>': is_semifunctor \<alpha> \<AA> \<open>smc_1 a f\<close> \<FF>' .
    show "\<FF>' = smcf_const \<AA> (smc_1 a f) a f"
    proof(rule smcf_eqI, unfold dghm_const_components)
      show "smcf_const \<AA> (smc_1 a f) a f : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> smc_1 a f"
        by (rule smcf_1)
      show "\<FF>'\<lparr>ObjMap\<rparr> = vconst_on (\<AA>\<lparr>Obj\<rparr>) a"
      proof(cases\<open>\<AA>\<lparr>Obj\<rparr> = 0\<close>)
        case True
        with \<FF>'.ObjMap.vbrelation_vintersection_vdomain have "\<FF>'\<lparr>ObjMap\<rparr> = 0"
          by (auto simp: smc_cs_simps)
        with True show ?thesis by simp
      next
        case False
        then have "\<D>\<^sub>\<circ> (\<FF>'\<lparr>ObjMap\<rparr>) \<noteq> 0" by (auto simp: smc_cs_simps)
        then have "\<R>\<^sub>\<circ> (\<FF>'\<lparr>ObjMap\<rparr>) \<noteq> 0"
          by (simp add: \<FF>'.ObjMap.vsv_vdomain_vempty_vrange_vempty)
        moreover from \<FF>'.smcf_ObjMap_vrange have "\<R>\<^sub>\<circ> (\<FF>'\<lparr>ObjMap\<rparr>) \<subseteq>\<^sub>\<circ> set {a}"
          by (simp add: smc_1_components)
        ultimately have "\<R>\<^sub>\<circ> (\<FF>'\<lparr>ObjMap\<rparr>) = set {a}" by auto
        then show ?thesis
          by (intro vsv.vsv_is_vconst_onI) (auto simp: smc_cs_simps)
      qed
      show "\<FF>'\<lparr>ArrMap\<rparr> = vconst_on (\<AA>\<lparr>Arr\<rparr>) f"
      proof(cases\<open>\<AA>\<lparr>Arr\<rparr> = 0\<close>)
        case True
        with \<FF>'.ArrMap.vdomain_vrange_is_vempty have "\<FF>'\<lparr>ArrMap\<rparr> = 0"
          by (simp add: smc_cs_simps \<FF>'.smcf_ArrMap_vsv vsv.vsv_vrange_vempty)
        with True show ?thesis by simp
      next
        case False
        then have "\<D>\<^sub>\<circ> (\<FF>'\<lparr>ArrMap\<rparr>) \<noteq> 0" by (auto simp: smc_cs_simps)
        then have "\<R>\<^sub>\<circ> (\<FF>'\<lparr>ArrMap\<rparr>) \<noteq> 0"
          by (simp add: \<FF>'.ArrMap.vsv_vdomain_vempty_vrange_vempty)
        moreover from \<FF>'.smcf_ArrMap_vrange have "\<R>\<^sub>\<circ> (\<FF>'\<lparr>ArrMap\<rparr>) \<subseteq>\<^sub>\<circ> set {f}"
          by (simp add: smc_1_components)
        ultimately have "\<R>\<^sub>\<circ> (\<FF>'\<lparr>ArrMap\<rparr>) = set {f}" by auto
        then show ?thesis
          by (intro vsv.vsv_is_vconst_onI) (auto simp: smc_cs_simps)
      qed
    qed (auto intro: smc_cs_intros)
  qed
qed (simp add: assms semicategory_smc_1)

lemma (in \<Z>) smc_SemiCAT_obj_terminalE:
  assumes "obj_terminal (smc_SemiCAT \<alpha>) \<BB>"
  obtains a f where "a \<in>\<^sub>\<circ> Vset \<alpha>" and "f \<in>\<^sub>\<circ> Vset \<alpha>" and "\<BB> = smc_1 a f"
  using assms
proof
  (
    elim obj_terminalE,
    unfold smc_op_simps smc_SemiCAT_is_arr_iff smc_SemiCAT_Obj_iff
  )

  assume prems:
    "semicategory \<alpha> \<BB>"
    "semicategory \<alpha> \<AA> \<Longrightarrow> \<exists>!\<FF>. \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
    for \<AA>
  interpret \<BB>: semicategory \<alpha> \<BB> by (rule prems(1))

  obtain a where \<BB>_Obj: "\<BB>\<lparr>Obj\<rparr> = set {a}" and a: "a \<in>\<^sub>\<circ> Vset \<alpha>"
  proof-
    have semicategory_smc_10: "semicategory \<alpha> (smc_10 0)"
      by (intro semicategory_smc_10) auto
    from prems(2)[OF semicategory_smc_10] obtain \<FF>
      where \<FF>: "\<FF> : smc_10 0 \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
        and \<GG>\<FF>: "\<GG> : smc_10 0 \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB> \<Longrightarrow> \<GG> = \<FF>" for \<GG>
      by fastforce
    interpret \<FF>: is_semifunctor \<alpha> \<open>smc_10 0\<close> \<BB> \<FF> by (rule \<FF>)
    have "\<D>\<^sub>\<circ> (\<FF>\<lparr>ObjMap\<rparr>) = set {0}"
      by (auto simp add: smc_10_components smc_cs_simps)
    then obtain a where vrange_\<FF>[simp]: "\<R>\<^sub>\<circ> (\<FF>\<lparr>ObjMap\<rparr>) = set {a}"
      by (auto intro: \<FF>.ObjMap.vsv_vdomain_vsingleton_vrange_vsingleton)
    with \<BB>.smc_Obj_vsubset_Vset \<FF>.smcf_ObjMap_vrange have [simp]: "a \<in>\<^sub>\<circ> Vset \<alpha>"
      by auto
    from \<FF>.smcf_ObjMap_vrange have "set {a} \<subseteq>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>" by simp
    moreover have "\<BB>\<lparr>Obj\<rparr> \<subseteq>\<^sub>\<circ> set {a}"
    proof(rule ccontr)
      assume "\<not> \<BB>\<lparr>Obj\<rparr> \<subseteq>\<^sub>\<circ> set {a}"
      then obtain b where ba: "b \<noteq> a" and b: "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>" by force
      define \<GG> where "\<GG> = [set {\<langle>0, b\<rangle>}, 0, smc_10 0, \<BB>]\<^sub>\<circ>"
      have \<GG>_components:
        "\<GG>\<lparr>ObjMap\<rparr> = set {\<langle>0, b\<rangle>}"
        "\<GG>\<lparr>ArrMap\<rparr> = 0"
        "\<GG>\<lparr>HomDom\<rparr> = smc_10 0"
        "\<GG>\<lparr>HomCod\<rparr> = \<BB>"
        unfolding \<GG>_def dghm_field_simps by (simp_all add: nat_omega_simps)
      have \<GG>: "\<GG> : smc_10 0 \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
      proof(rule is_semifunctorI, unfold \<GG>_components smc_10_components)
        show "vfsequence \<GG>" unfolding \<GG>_def by auto
        show "vcard \<GG> = 4\<^sub>\<nat>"
          unfolding \<GG>_def by (auto simp: nat_omega_simps)
        show "smcf_dghm \<GG> : smc_dg (smc_10 0) \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> smc_dg \<BB>"
        proof(intro is_dghmI, unfold \<GG>_components dg_10_components smc_dg_smc_10)
          show "vfsequence (smcf_dghm \<GG>)" unfolding smcf_dghm_def by simp
          show "vcard (smcf_dghm \<GG>) = 4\<^sub>\<nat>"
            unfolding smcf_dghm_def by (simp add: nat_omega_simps)
        qed
          (
            auto simp:
              slicing_simps slicing_intros slicing_commute smc_dg_smc_10
              b \<GG>_components dg_10_is_arr_iff digraph_dg_10
          )
      qed (auto simp: smc_cs_intros smc_10_is_arr_iff b vsubset_vsingleton_leftI)
      then have \<GG>_def: "\<GG> = \<FF>" by (rule \<GG>\<FF>)
      have "\<R>\<^sub>\<circ> (\<GG>\<lparr>ObjMap\<rparr>) = set {b}" unfolding \<GG>_components by simp
      with vrange_\<FF> ba show False unfolding \<GG>_def by simp
    qed
    ultimately have "\<BB>\<lparr>Obj\<rparr> = set {a}" by simp
    with that show ?thesis by simp
  qed

  obtain f
    where \<BB>_Arr: "\<BB>\<lparr>Arr\<rparr> = set {f}"
      and f: "f \<in>\<^sub>\<circ> Vset \<alpha>"
      and ff_f: "f \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> f = f"
  proof-
    from prems(2)[OF semicategory_smc_1, of 0 0] obtain \<FF>
      where "\<FF> : smc_1 0 0 \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
        and "\<GG> : smc_1 0 0 \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB> \<Longrightarrow> \<GG> = \<FF>"
      for \<GG>
      by fastforce
    then interpret \<FF>: is_semifunctor \<alpha> \<open>smc_1 0 0\<close> \<BB> \<FF> by force
    have "\<D>\<^sub>\<circ> (\<FF>\<lparr>ObjMap\<rparr>) = set {0}"
      by (simp add: smc_cs_simps smc_1_components)
    then obtain a' where "\<R>\<^sub>\<circ> (\<FF>\<lparr>ObjMap\<rparr>) = set {a'}"
      by (auto intro: \<FF>.ObjMap.vsv_vdomain_vsingleton_vrange_vsingleton)
    with \<FF>.smcf_ObjMap_vrange have "\<R>\<^sub>\<circ> (\<FF>\<lparr>ObjMap\<rparr>) = set {a}"
      by (auto simp: \<BB>_Obj)
    have vdomain_\<FF>: "\<D>\<^sub>\<circ> (\<FF>\<lparr>ArrMap\<rparr>) = set {0}"
      by (simp add: smc_cs_simps smc_1_components)
    then obtain f where vrange_\<FF>[simp]: "\<R>\<^sub>\<circ> (\<FF>\<lparr>ArrMap\<rparr>) = set {f}"
      by (auto intro: \<FF>.ArrMap.vsv_vdomain_vsingleton_vrange_vsingleton)
    with \<BB>.smc_Arr_vsubset_Vset \<FF>.smcf_ArrMap_vrange have [simp]: "f \<in>\<^sub>\<circ> Vset \<alpha>"
      by auto
    from \<FF>.smcf_ArrMap_vrange have f_ss_\<BB>: "set {f} \<subseteq>\<^sub>\<circ> \<BB>\<lparr>Arr\<rparr>" by simp
    then have "f \<in>\<^sub>\<circ> \<BB>\<lparr>Arr\<rparr>" by auto
    then have f: "f : a \<mapsto>\<^bsub>\<BB>\<^esub> a"
      by (metis \<BB>_Obj \<BB>.smc_is_arrD(2,3) is_arrI vsingleton_iff)
    from vdomain_\<FF> \<FF>.ArrMap.vsv_value have [simp]: "\<FF>\<lparr>ArrMap\<rparr>\<lparr>0\<rparr> = f" by auto
    from \<FF>.smcf_is_arr_HomCod(2) have [simp]: "\<FF>\<lparr>ObjMap\<rparr>\<lparr>0\<rparr> = a"
      by (auto simp: smc_1_is_arr_iff \<BB>_Obj)
    have "\<FF>\<lparr>ArrMap\<rparr>\<lparr>0\<rparr> \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> \<FF>\<lparr>ArrMap\<rparr>\<lparr>0\<rparr> = \<FF>\<lparr>ArrMap\<rparr>\<lparr>0\<rparr>"
      by (metis smc_1_Comp_app \<FF>.smcf_ArrMap_Comp smc_1_is_arr_iff)
    then have ff_f[simp]: "f \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> f = f" by simp
    have id_\<BB>: "smcf_id \<BB> : \<BB> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
      by (simp add: \<BB>.smc_smcf_id_is_semifunctor)
    interpret id_\<BB>: is_semifunctor \<alpha> \<BB> \<BB> \<open>smcf_id \<BB>\<close> by (rule id_\<BB>)
    from prems(2)[OF \<BB>.semicategory_axioms] have
      "\<GG> : \<BB> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB> \<Longrightarrow> \<GG> = smcf_id \<BB>" for \<GG>
      by (clarsimp simp: id_\<BB>.is_semifunctor_axioms)
    moreover from f have "smcf_const \<BB> \<BB> a f : \<BB> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
      by (intro smcf_const_is_semifunctor) (auto intro: smc_cs_intros)
    ultimately have const_eq_id: "smcf_const \<BB> \<BB> a f = smcf_id \<BB>" by simp
    have "\<BB>\<lparr>Arr\<rparr> \<subseteq>\<^sub>\<circ> set {f}"
    proof(rule ccontr)
      assume "\<not>\<BB>\<lparr>Arr\<rparr> \<subseteq>\<^sub>\<circ> set {f}"
      then obtain g where gf: "g \<noteq> f" and g: "g \<in>\<^sub>\<circ> \<BB>\<lparr>Arr\<rparr>" by force
      have g: "g : a \<mapsto>\<^bsub>\<BB>\<^esub> a"
      proof(intro is_arrI)
        from g \<BB>_Obj show "\<BB>\<lparr>Dom\<rparr>\<lparr>g\<rparr> = a"
          by (metis \<BB>.smc_is_arrD(2) is_arr_def vsingleton_iff)
        from g \<BB>_Obj show "\<BB>\<lparr>Cod\<rparr>\<lparr>g\<rparr> = a"
          by (metis \<BB>.smc_is_arrD(3) is_arr_def vsingleton_iff)
      qed (auto simp: g)
      then have "smcf_const \<BB> \<BB> a f\<lparr>ArrMap\<rparr>\<lparr>g\<rparr> = f"
        by (cs_concl cs_shallow cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
      moreover from g have "smcf_id \<BB>\<lparr>ArrMap\<rparr>\<lparr>g\<rparr> = g"
        by (cs_concl cs_shallow cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
      ultimately show False using const_eq_id by (simp add: gf)
    qed
    with f_ss_\<BB> have "\<BB>\<lparr>Arr\<rparr> = set {f}" by simp
    with that show ?thesis by simp
  qed

  have "\<BB> = smc_1 a f"
  proof(rule smc_eqI [of \<alpha>], unfold smc_1_components)
    show "\<BB>\<lparr>Obj\<rparr> = set {a}" by (simp add: \<BB>_Obj)
    moreover show "\<BB>\<lparr>Arr\<rparr> = set {f}" by (simp add: \<BB>_Arr)
    ultimately have dom: "\<BB>\<lparr>Dom\<rparr>\<lparr>f\<rparr> = a" and cod: "\<BB>\<lparr>Cod\<rparr>\<lparr>f\<rparr> = a"
      by (metis \<BB>.smc_is_arrE is_arr_def vsingleton_iff)+
    have "\<D>\<^sub>\<circ> (\<BB>\<lparr>Dom\<rparr>) = set {f}" by (simp add: \<BB>_Arr smc_cs_simps)
    moreover from \<BB>.Dom.vsv_vrange_vempty \<BB>.smc_Dom_vdomain \<BB>.smc_Dom_vrange
    have "\<R>\<^sub>\<circ> (\<BB>\<lparr>Dom\<rparr>) = set {a}"
      by (fastforce simp: \<BB>_Arr \<BB>_Obj)
    ultimately show "\<BB>\<lparr>Dom\<rparr> = set {\<langle>f, a\<rangle>}"
      using assms \<BB>.Dom.vsv_vdomain_vrange_vsingleton by simp
    have "\<D>\<^sub>\<circ> (\<BB>\<lparr>Cod\<rparr>) = set {f}" by (simp add: \<BB>_Arr smc_cs_simps)
    moreover from \<BB>.Cod.vsv_vrange_vempty \<BB>.smc_Cod_vdomain \<BB>.smc_Cod_vrange
    have "\<R>\<^sub>\<circ> (\<BB>\<lparr>Cod\<rparr>) = set {a}"
      by (fastforce simp: \<BB>_Arr \<BB>_Obj)
    ultimately show "\<BB>\<lparr>Cod\<rparr> = set {\<langle>f, a\<rangle>}"
      using assms \<BB>.Cod.vsv_vdomain_vrange_vsingleton by simp
    show "\<BB>\<lparr>Comp\<rparr> = set {\<langle>[f, f]\<^sub>\<circ>, f\<rangle>}"
    proof(rule vsv_eqI)
      show [simp]: "\<D>\<^sub>\<circ> (\<BB>\<lparr>Comp\<rparr>) = \<D>\<^sub>\<circ> (set {\<langle>[f, f]\<^sub>\<circ>, f\<rangle>})"
        unfolding vdomain_vsingleton
      proof(rule vsubset_antisym)
        from \<BB>.Comp.pnop_vdomain show "\<D>\<^sub>\<circ> (\<BB>\<lparr>Comp\<rparr>) \<subseteq>\<^sub>\<circ> set {[f, f]\<^sub>\<circ>}"
          by (auto simp: \<BB>_Arr intro: smc_cs_intros) (*slow*)
        from \<BB>_Arr dom cod is_arrI show "set {[f, f]\<^sub>\<circ>} \<subseteq>\<^sub>\<circ> \<D>\<^sub>\<circ> (\<BB>\<lparr>Comp\<rparr>)"
          by (metis \<BB>.smc_Comp_vdomainI vsingletonI vsubset_vsingleton_leftI)
      qed
      from ff_f show "a \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (\<BB>\<lparr>Comp\<rparr>) \<Longrightarrow> \<BB>\<lparr>Comp\<rparr>\<lparr>a\<rparr> = set {\<langle>[f, f]\<^sub>\<circ>, f\<rangle>}\<lparr>a\<rparr>"
        for a
        by simp
    qed auto
  qed (auto intro: smc_cs_intros a f semicategory_smc_1)
  with a f that show ?thesis by auto

qed

text\<open>\newpage\<close>

end


theory Standard_PMFs
  imports
    "HOL-Probability.Probability"
begin

text \<open>This is a library of code equations for common pmfs based on the primitve nat_pmf, which
performs sampling a natural number uniformly from a range.\<close>

definition nat_pmf :: "nat \<Rightarrow> nat pmf" where
  "nat_pmf n = pmf_of_set {0..n}"

lemma pmf_of_set_code [code]:
  "pmf_of_set (set xs) =
     (if xs = [] then
        Code.abort (STR ''pmf_of_set {}'') (\<lambda>_. pmf_of_set {})
      else (let xs' = remdups xs in
        map_pmf (\<lambda>k. xs' ! k) (nat_pmf (length xs' - 1))))"
proof -
  have "pmf_of_set (set xs) = map_pmf (\<lambda>k. xs ! k) (nat_pmf (length xs - 1))"
    if "xs \<noteq> []" "distinct xs" for xs :: "'a list"
  proof -
    define n where "n = length xs"
    from \<open>xs \<noteq> []\<close> have n: "n > 0" "length xs \<ge> n"
      by (force simp: n_def)+
    have "map_pmf ((!) xs) (nat_pmf (n - 1)) = pmf_of_set ((!) xs ` {0..n - 1})"
      unfolding nat_pmf_def using that n
      by (intro map_pmf_of_set_inj inj_on_nth)
         (auto simp: minus_nat.diff_Suc split: nat.splits)
    also have "{0..n - 1} = {..<n}"
      using n by auto
    also have "(!) xs ` {..<n} = set xs"
      by (auto simp: n_def set_conv_nth)
    finally show ?thesis
      by (simp add: n_def)
  qed
  from this[of "remdups xs"] show ?thesis
    by (auto simp: Let_def)
qed

lemma eq_bernoulli_pmfI: "pmf d True = p \<Longrightarrow> d = bernoulli_pmf p"
  by (metis (full_types) pmf_False_conv_True pmf_bernoulli_True pmf_eq_iff pmf_le_1 pmf_nonneg)

lemma bernoulli_pmf_code [code]:
  "bernoulli_pmf (Ratreal p) = (let (a, b) = quotient_of (max 0 (min 1 p)) in
     map_pmf (\<lambda>k. int k < a) (nat_pmf (nat b - 1)))" (is "_ = ?rhs")
proof (cases "p \<in> {0..1}")
  case True
  obtain x y where xy: "quotient_of p = (x, y)"
    by (cases "quotient_of p")
  have p_eq: "p = of_int x / of_int y"
    using xy by (metis quotient_of_div)
  have "y > 0"
    using xy by (simp add: quotient_of_denom_pos)
  have "x \<ge> 0"
    using True xy
    by (metis Fract_of_int_quotient \<open>0 < y\<close> atLeastAtMost_iff quotient_of_div zero_le_Fract_iff)
  have "Ratreal p \<in> {0..1}"
    using True by simp
  hence "x \<ge> 0" "x \<le> y"
    using \<open>y > 0\<close> unfolding p_eq by (auto simp: field_simps)
  define x' y' where "x' = nat x" and "y' = nat y"
  have [simp]: "x = int x'" "y = int y'" and "x' \<ge> 0" "y' > 0" "x' \<le> y'"
    using \<open>x \<ge> 0\<close> \<open>y > 0\<close> \<open>x \<le> y\<close> unfolding x'_def y'_def by auto

  show ?thesis
  proof (rule sym, rule eq_bernoulli_pmfI)
    have "pmf ?rhs True = measure_pmf.prob (pmf_of_set {0..y'-1}) ((\<lambda>k. k < x') -` {True})"
      using True \<open>y > 0\<close> by (auto simp: xy nat_pmf_def pmf_map)
    also have "{0..y'-1} = {0..<y'}"
      using \<open>y' > 0\<close> by (metis Suc_diff_1 atLeastLessThanSuc_atLeastAtMost)
    also have "(\<lambda>k. k < x') -` {True} = {0..<x'}"
      by force
    also have "measure_pmf.prob (pmf_of_set {0..<y'}) {0..<x'} = Ratreal p"
      using \<open>x' \<le> y'\<close> \<open>y' > 0\<close> by (subst measure_pmf_of_set) (auto simp: p_eq of_rat_divide)
    finally show "pmf ?rhs True = Ratreal p" .
  qed
qed (auto intro!: pmf_eqI simp: bernoulli_pmf.rep_eq nat_pmf_def pmf_of_set_singleton)

lemma binomial_pmf_code [code]:
  "binomial_pmf n p =
     (if 0 \<le> p \<and> p \<le> 1 then
        map_pmf (length \<circ> filter id) (replicate_pmf n (bernoulli_pmf p))
      else
        Code.abort (STR ''binomial_pmf: probability out of range'') (\<lambda>_. binomial_pmf n p))"
  using binomial_pmf_altdef by simp

lemma geometric_pmf_code [code]: "geometric_pmf p =
    (if 0 < p \<and> p \<le> 1 then
       bernoulli_pmf p \<bind> (\<lambda>b. if b then return_pmf 0 else map_pmf Suc (geometric_pmf p))
     else
       Code.abort (STR ''geometric_pmf: probability out of range'') (\<lambda>_. geometric_pmf p)
    )"
  using geometric_bind_pmf_unfold[of p] by simp

end


theory TacticSolving
  imports Common
begin

fun size :: "IRExpr \<Rightarrow> nat" where
  "size (UnaryExpr op e) = (size e) * 2" |
  "size (BinaryExpr BinAdd x y) = (size x) + ((size y) * 2)" |
  "size (BinaryExpr op x y) = (size x) + (size y)" |
  "size (ConditionalExpr cond t f) = (size cond) + (size t) + (size f) + 2" |
  "size (ConstantExpr c) = 1" |
  "size (ParameterExpr ind s) = 2" |
  "size (LeafExpr nid s) = 2" |
  "size (ConstantVar c) = 2" |
  "size (VariableExpr x s) = 2"

lemma size_pos[simp]: "0 < size y"
  apply (induction y; auto?)
  subgoal premises prems for op a b
    using prems by (induction op; auto)
  done

phase TacticSolving
  terminating size
begin

subsection \<open>AddNode\<close>
(*lemma val_add_left_negate_to_sub:
  "val[-x + y] \<approx> val[y - x]"
  apply simp by (cases x; cases y; auto)

lemma exp_add_left_negate_to_sub:
  "exp[-x + y] \<ge> exp[y - x]"
  using val_add_left_negate_to_sub by auto*)

lemma value_approx_implies_refinement:
  assumes "lhs \<approx> rhs"
  assumes "\<forall>m p v. ([m, p] \<turnstile> elhs \<mapsto> v) \<longrightarrow> v = lhs"
  assumes "\<forall>m p v. ([m, p] \<turnstile> erhs \<mapsto> v) \<longrightarrow> v = rhs"
  assumes "\<forall>m p v1 v2. ([m, p] \<turnstile> elhs \<mapsto> v1) \<longrightarrow> ([m, p] \<turnstile> erhs \<mapsto> v2)"
  shows "elhs \<ge> erhs"
  using assms unfolding le_expr_def well_formed_equal_def
  using evalDet evaltree_not_undef
  by metis

method explore_cases for x y :: Value =
  (cases x; cases y; auto)

method explore_cases_bin for x :: IRExpr =
  (cases x; auto)

method obtain_approx_eq for lhs rhs x y :: Value =
  (rule meta_mp[where P="lhs \<approx> rhs"], defer_tac, explore_cases x y)

method obtain_eval for exp::IRExpr and val::Value =
  (rule meta_mp[where P="\<And>m p v. ([m, p] \<turnstile> exp \<mapsto> v) \<Longrightarrow> v = val"], defer_tac)

method solve for lhs rhs x y :: Value =
  (match conclusion in "size _ < size _" \<Rightarrow> \<open>simp\<close>)?,
  (match conclusion in "(elhs::IRExpr) \<ge> (erhs::IRExpr)" for elhs erhs \<Rightarrow> \<open>
    (obtain_approx_eq lhs rhs x y)?\<close>)

print_methods
(*
    (simp del: well_formed_equal_def le_expr_def)?;
    ((rule allI)+)?\<close>)*)
thm BinaryExprE
optimization opt_add_left_negate_to_sub:
  "-x + y \<longmapsto> y - x"
  (*defer apply simp apply (rule allI)+ apply (rule impI)
   apply (subgoal_tac "\<forall>x1. [m, p] \<turnstile> exp[-x + y] \<mapsto> x1") defer
  *)
   apply (solve "val[-x1 + y1]" "val[y1 - x1]" x1 y1)
  apply simp apply auto using evaltree_not_undef sorry
(*
  apply (obtain_eval "exp[-x + y]" "val[-x1 + y1]")

  apply (rule BinaryExprE)
  apply (rule allI)+ sorry
  apply (auto simp: unfold_evaltree) sorry*)
  (*
   defer apply (test "val[-x1 + y1]" "val[y1 - x1]" x1 y1)
   apply (rule meta_mp[where P="val[-x1 + y1] \<approx> val[y1 - x1]"])
    prefer 2 apply (cases x1; cases y1; auto)
   apply (subgoal_tac "val[-x1 + y1] \<approx> val[y1 - x1]")
    apply (cases x1; cases y1; auto)
  using exp_add_left_negate_to_sub apply simp
  unfolding size.simps by simp*)

subsection \<open>NegateNode\<close>

lemma val_distribute_sub:
 "val[-(x-y)] \<approx> val[y-x]"
  by (cases x; cases y; auto)

optimization distribute_sub: "-(x-y) \<longmapsto> (y-x)"
  apply simp
  using val_distribute_sub apply simp
  using unfold_binary unfold_unary by auto

lemma val_xor_self_is_false:
  assumes "x = IntVal 32 v"
  shows "val[x \<oplus> x] \<approx> val[false]"
  apply simp using assms by (cases x; auto)

definition wf_stamp :: "IRExpr \<Rightarrow> bool" where
  "wf_stamp e = (\<forall>m p v. ([m, p] \<turnstile> e \<mapsto> v) \<longrightarrow> valid_value v (stamp_expr e))"

lemma exp_xor_self_is_false:
  assumes "stamp_expr x = IntegerStamp 32 l h"
  assumes "wf_stamp x"
  shows "exp[x \<oplus> x] >= exp[false]"
  unfolding le_expr_def using assms unfolding wf_stamp_def
  using val_xor_self_is_false evaltree_not_undef
  by (smt (z3) wf_value_def bin_eval.simps(6) bin_eval_new_int constantAsStamp.simps(1) evalDet
      int_signed_value_bounds new_int.simps new_int_take_bits unfold_binary unfold_const valid_int
      valid_stamp.simps(1) valid_value.simps(1) well_formed_equal_defn)

lemma val_or_commute[simp]:
   "val[x | y] = val[y | x]"
   apply (cases x; cases y; auto)
  by (simp add: or.commute)+

lemma val_xor_commute[simp]:
   "val[x \<oplus> y] = val[y \<oplus> x]"
   apply (cases x; cases y; auto)
  by (simp add: word_bw_comms(3))

lemma exp_or_commutative:
  "exp[x | y] \<ge> exp[y | x]"
  by auto

lemma exp_xor_commutative:
  "exp[x \<oplus> y] \<ge> exp[y \<oplus> x]"
  by auto

(* 32-bit proofs of new optimisations *)
lemma OrInverseVal:
  assumes "n = IntVal 32 v"
  shows "val[n | ~n] \<approx> new_int 32 (-1)"
  apply simp using assms using word_or_not apply (cases n; auto) using take_bit_or
  by (metis bit.disj_cancel_right mask_eq_take_bit_minus_one)

optimization OrInverse: "exp[n | ~n] \<longmapsto> (const (new_int 32 (not 0)))
                        when (stamp_expr n = IntegerStamp 32 l h \<and> wf_stamp n)"
  unfolding size.simps apply (simp add: Suc_lessI)
  apply auto using OrInverseVal unfolding wf_stamp_def
  by (smt (z3) wf_value_def constantAsStamp.simps(1) evalDet int_signed_value_bounds
      mask_eq_take_bit_minus_one new_int.elims new_int_take_bits unfold_const valid_int
      valid_stamp.simps(1) valid_value.simps(1) well_formed_equal_defn)

optimization OrInverse2: "exp[~n | n] \<longmapsto> (const (new_int 32 (not 0)))
                        when (stamp_expr n = IntegerStamp 32 l h \<and> wf_stamp n)"
   using OrInverse exp_or_commutative by auto

lemma XorInverseVal:
  assumes "n = IntVal 32 v"
  shows "val[n \<oplus> ~n] \<approx> new_int 32 (-1)"
  apply simp using assms using word_or_not apply (cases n; auto)
  by (metis (no_types, opaque_lifting) bit.compl_zero bit.xor_compl_right bit.xor_self
      mask_eq_take_bit_minus_one take_bit_xor)

optimization XorInverse: "exp[n \<oplus> ~n] \<longmapsto> (const (new_int 32 (not 0)))
                        when (stamp_expr n = IntegerStamp 32 l h \<and> wf_stamp n)"
  unfolding size.simps apply (simp add: Suc_lessI)
  apply auto using XorInverseVal
  by (smt (verit) wf_value_def constantAsStamp.simps(1) evalDet int_signed_value_bounds
      intval_xor.elims mask_eq_take_bit_minus_one new_int.elims new_int_take_bits unfold_const
      valid_stamp.simps(1) valid_value.simps(1) well_formed_equal_defn wf_stamp_def)

optimization XorInverse2: "exp[(~n) \<oplus> n] \<longmapsto> (const (new_int 32 (not 0)))
                        when (stamp_expr n = IntegerStamp 32 l h \<and> wf_stamp n)"
   using XorInverse exp_xor_commutative by auto

end

end


(* Author: Bernhard Stöckl *)

theory QueryGraph
  imports Complex_Main "Graph_Additions" "Selectivities" "JoinTree"
begin

section \<open>Query Graphs\<close>

locale query_graph = graph +
  fixes sel :: "'b weight_fun"
  fixes cf :: "'a \<Rightarrow> real"
  assumes sel_sym: "\<lbrakk>tail G e\<^sub>1 = head G e\<^sub>2; head G e\<^sub>1 = tail G e\<^sub>2\<rbrakk> \<Longrightarrow> sel e\<^sub>1 = sel e\<^sub>2"
      and not_arc_sel_1: "e \<notin> arcs G \<Longrightarrow> sel e = 1"
      and sel_pos: "sel e > 0"
      and sel_leq_1: "sel e \<le> 1"
      and pos_cards: "x \<in> verts G \<Longrightarrow> cf x > 0"

begin

subsection \<open>Function for Join Trees and Selectivities\<close>

definition matching_sel :: "'a selectivity \<Rightarrow> bool" where
  "matching_sel f = (\<forall>x y.
      (\<exists>e. (tail G e) = x \<and> (head G e) = y \<and> f x y = sel e)
    \<or> ((\<nexists>e. (tail G e) = x \<and> (head G e) = y) \<and> f x y = 1))"

definition match_sel :: "'a selectivity" where
  "match_sel x y =
    (if \<exists>e \<in> arcs G. (tail G e) = x \<and> (head G e) = y
    then sel (THE e. e \<in> arcs G \<and> (tail G e) = x \<and> (head G e) = y) else 1)"

definition matching_rels :: "'a joinTree \<Rightarrow> bool" where
  "matching_rels t = (relations t \<subseteq> verts G)"

definition remove_sel :: "'a \<Rightarrow> 'b weight_fun" where
  "remove_sel x = (\<lambda>b. if b\<in>{a \<in> arcs G. tail G a = x \<or> head G a = x} then 1 else sel b)"

definition valid_tree :: "'a joinTree \<Rightarrow> bool" where
  "valid_tree t = (relations t = verts G \<and> distinct_relations t)"

fun no_cross_products :: "'a joinTree \<Rightarrow> bool" where
  "no_cross_products (Relation rel) = True"
| "no_cross_products (Join l r) = ((\<exists>x\<in>relations l. \<exists>y\<in>relations r. x \<rightarrow>\<^bsub>G\<^esub> y)
    \<and> no_cross_products l \<and> no_cross_products r)"

subsection "Proofs"

text \<open>
  Proofs that a query graph satisifies basic properties of join trees and selectivities.
\<close>

lemma sel_less_arc: "sel x < 1 \<Longrightarrow> x \<in> arcs G"
  using not_arc_sel_1 by force

lemma joinTree_card_pos: "matching_rels t \<Longrightarrow> pos_rel_cards cf t"
  by(induction t) (auto simp: pos_cards pos_rel_cards_def matching_rels_def)

lemma symmetric_arcs: "x\<in>arcs G \<Longrightarrow> \<exists>y. head G x = tail G y \<and> tail G x = head G y"
  using sym_arcs symmetric_conv by fast

lemma arc_ends_eq_impl_sel_eq: "head G x = head G y \<Longrightarrow> tail G x = tail G y \<Longrightarrow> sel x = sel y"
  using sel_sym symmetric_arcs not_arc_sel_1 by metis

lemma arc_ends_eq_impl_arc_eq:
  "\<lbrakk>e1 \<in> arcs G; e2 \<in> arcs G; head G e1 = head G e2; tail G e1 = tail G e2\<rbrakk> \<Longrightarrow> e1 = e2"
  using no_multi_alt by blast

lemma matching_sel_simp_if_not1:
  "\<lbrakk>matching_sel sf; sf x y \<noteq> 1\<rbrakk> \<Longrightarrow> \<exists>e \<in> arcs G. tail G e = x \<and> head G e = y \<and> sf x y = sel e"
  using not_arc_sel_1 unfolding matching_sel_def by fastforce

lemma matching_sel_simp_if_arc:
  "\<lbrakk>matching_sel sf; e \<in> arcs G\<rbrakk> \<Longrightarrow> sf (tail G e) (head G e) = sel e"
  unfolding matching_sel_def by (metis arc_ends_eq_impl_sel_eq)

lemma matching_sel1_if_no_arc: "matching_sel sf \<Longrightarrow> \<not>(x \<rightarrow>\<^bsub>G\<^esub> y \<or> y \<rightarrow>\<^bsub>G\<^esub> x) \<Longrightarrow> sf x y = 1"
  using not_arc_sel_1 unfolding arcs_ends_def arc_to_ends_def matching_sel_def image_iff by metis

lemma matching_sel_alt_aux1:
  "matching_sel f
    \<Longrightarrow> (\<forall>x y. (\<exists>e \<in> arcs G. (tail G e) = x \<and> (head G e) = y \<and> f x y = sel e)
            \<or> ((\<nexists>e. e \<in> arcs G \<and> (tail G e) = x \<and> (head G e) = y) \<and> f x y = 1))"
  by (metis matching_sel_def arc_ends_eq_impl_sel_eq not_arc_sel_1)

lemma matching_sel_alt_aux2:
  "(\<forall>x y.(\<exists>e \<in> arcs G. (tail G e) = x \<and> (head G e) = y \<and> f x y = sel e)
      \<or> ((\<nexists>e. e \<in> arcs G \<and> (tail G e) = x \<and> (head G e) = y) \<and> f x y = 1))
    \<Longrightarrow> matching_sel f"
  by (fastforce simp: not_arc_sel_1 matching_sel_def)

lemma matching_sel_alt:
  "matching_sel f
    = (\<forall>x y. (\<exists>e \<in> arcs G. (tail G e) = x \<and> (head G e) = y \<and> f x y = sel e)
          \<or> ((\<nexists>e. e \<in> arcs G \<and> (tail G e) = x \<and> (head G e) = y) \<and> f x y = 1))"
  using matching_sel_alt_aux1 matching_sel_alt_aux2 by blast

lemma matching_sel_symm:
  assumes "matching_sel f"
  shows "sel_symm f"
  unfolding sel_symm_def
proof (standard, standard)
  fix x y
  show "f x y = f y x"
  proof(cases "\<exists>e\<in>arcs G. (head G e) = x \<and> (tail G e) = y")
    case True
    then show ?thesis using assms symmetric_arcs sel_sym unfolding matching_sel_def by metis
  next
    case False
    then show ?thesis by (metis assms symmetric_arcs matching_sel_def not_arc_sel_1 sel_sym)
  qed
qed

lemma matching_sel_reasonable: "matching_sel f \<Longrightarrow> sel_reasonable f"
  using sel_reasonable_def matching_sel_def sel_pos sel_leq_1
  by (metis le_numeral_extra(4) less_numeral_extra(1))

lemma matching_reasonable_cards:
  "\<lbrakk>matching_sel f; matching_rels t\<rbrakk> \<Longrightarrow> reasonable_cards cf f t"
  by (simp add: joinTree_card_pos matching_sel_reasonable pos_sel_reason_impl_reason)

lemma matching_sel_unique_aux:
  assumes "matching_sel f" "matching_sel g"
  shows "f x y = g x y"
proof(cases "\<exists>e. tail G e = x \<and> head G e = y")
  case True
  then show ?thesis
    using assms arc_ends_eq_impl_sel_eq unfolding matching_sel_def by metis
next
  case False
  then show ?thesis using assms unfolding matching_sel_def by fastforce
qed

lemma matching_sel_unique: "\<lbrakk>matching_sel f; matching_sel g\<rbrakk> \<Longrightarrow> f = g"
  using matching_sel_unique_aux by blast

lemma match_sel_matching[intro]: "matching_sel match_sel"
  unfolding matching_sel_alt
proof(standard,standard)
  fix x y
  show "(\<exists>e\<in>arcs G. tail G e = x \<and> head G e = y \<and> match_sel x y = sel e) \<or>
          ((\<nexists>e. e \<in> arcs G \<and> tail G e = x \<and> head G e = y) \<and> match_sel x y = 1)"
  proof(cases "\<exists>e \<in> arcs G. tail G e = x \<and> head G e = y")
    case True
    then obtain e where e_def: "e \<in> arcs G" "tail G e = x" "head G e = y" by blast
    then have "match_sel x y = sel (THE e. e \<in> arcs G \<and> tail G e = x \<and> head G e = y)"
      unfolding match_sel_def by auto
    moreover have "(THE e. e \<in> arcs G \<and> tail G e = x \<and> head G e = y) = e"
      using e_def arc_ends_eq_impl_arc_eq by blast
    ultimately show ?thesis using e_def by blast
  next
    case False
    then show ?thesis unfolding match_sel_def by auto
  qed
qed

corollary match_sel_unique: "matching_sel f \<Longrightarrow> f = match_sel"
  using matching_sel_unique by blast

corollary match_sel1_if_no_arc: "\<not>(x \<rightarrow>\<^bsub>G\<^esub> y \<or> y \<rightarrow>\<^bsub>G\<^esub> x) \<Longrightarrow> match_sel x y = 1"
  using matching_sel1_if_no_arc by blast

corollary match_sel_symm[intro]: "sel_symm match_sel"
  using matching_sel_symm by blast

corollary match_sel_reasonable[intro]: "sel_reasonable match_sel"
  using matching_sel_reasonable by blast

corollary match_reasonable_cards: "matching_rels t \<Longrightarrow> reasonable_cards cf match_sel t"
  using matching_reasonable_cards by blast

lemma matching_rels_trans: "matching_rels (Join l r) = (matching_rels l \<and> matching_rels r)"
  using matching_rels_def by simp

lemma first_node_in_verts_if_rels_eq_verts: "relations t = verts G \<Longrightarrow> first_node t \<in> verts G"
  unfolding first_node_eq_hd using inorder_eq_set hd_in_set[OF inorder_nempty] by fast

lemma first_node_in_verts_if_valid: "valid_tree t \<Longrightarrow> first_node t \<in> verts G"
  using first_node_in_verts_if_rels_eq_verts valid_tree_def by simp

lemma dominates_sym: "(x \<rightarrow>\<^bsub>G\<^esub> y) \<longleftrightarrow> (y \<rightarrow>\<^bsub>G\<^esub> x)"
  using graph_symmetric by blast

lemma no_cross_mirror_eq: "no_cross_products (mirror t) = no_cross_products t"
  using graph_symmetric by(induction t) auto

lemma no_cross_create_ldeep_rev_app:
  "\<lbrakk>ys\<noteq>[]; no_cross_products (create_ldeep_rev (xs@ys))\<rbrakk> \<Longrightarrow> no_cross_products (create_ldeep_rev ys)"
proof(induction "xs@ys" arbitrary: xs rule: create_ldeep_rev.induct)
  case (2 x)
  then show ?case by (metis append_eq_Cons_conv append_is_Nil_conv)
next
  case (3 x y zs)
  then show ?case
  proof(cases xs)
    case Nil
    then show ?thesis using "3.prems"(2) by simp
  next
    case (Cons x' xs')
    have "no_cross_products (Join (create_ldeep_rev (y#zs)) (Relation x))"
      using "3.hyps"(2) "3.prems"(2) create_ldeep_rev.simps(3)[of x y zs] by simp
    then have "no_cross_products (create_ldeep_rev (y#zs))" by simp
    then show ?thesis using "3.hyps" "3.prems"(1) Cons by simp
  qed
qed(simp)

lemma no_cross_create_ldeep_app:
  "\<lbrakk>xs\<noteq>[]; no_cross_products (create_ldeep (xs@ys))\<rbrakk> \<Longrightarrow> no_cross_products (create_ldeep xs)"
  by (simp add: create_ldeep_def no_cross_create_ldeep_rev_app)

lemma matching_rels_if_no_cross: "\<lbrakk>\<forall>r. t \<noteq> Relation r; no_cross_products t\<rbrakk> \<Longrightarrow> matching_rels t"
  unfolding matching_rels_def by(induction t) fastforce+

lemma no_cross_awalk:
  "\<lbrakk>matching_rels t; no_cross_products t; x \<in> relations t; y \<in> relations t\<rbrakk>
    \<Longrightarrow> \<exists>p. awalk x p y \<and> set (awalk_verts x p) \<subseteq> relations t"
proof(induction t arbitrary: x y)
  case (Relation rel)
  then have "x \<in> verts G" using matching_rels_def by blast
  then have "awalk x [] x" by (simp add: awalk_Nil_iff)
  then show ?case using Relation(3,4) by force
next
  case (Join l r)
  then consider "x \<in> relations l" "y \<in> relations l" | "x \<in> relations r" "y \<in> relations l"
    | "x \<in> relations l" "y \<in> relations r" | "x \<in> relations r" "y \<in> relations r"
    by force
  then show ?case
  proof(cases)
    case 1
    then show ?thesis using Join.IH(1)[of x y] Join.prems(1,2) matching_rels_trans by auto
  next
    case 2
    then obtain x' y' e where e_def:
        "x' \<in> relations r" "y' \<in> relations l" "tail G e = y'" "head G e = x'" "e \<in> arcs G"
      using Join.prems(2) by auto
    then obtain e2 where e2_def: "tail G e2 = x'" "head G e2 = y'" "e2 \<in> arcs G"
      using symmetric_conv by force
    obtain p1 where p1_def: "awalk y' p1 y \<and> set (awalk_verts y' p1) \<subseteq> relations l"
      using Join.IH(1) Join.prems(1,2) 2(2) matching_rels_trans e_def(2) by fastforce
    obtain p2 where p2_def: "awalk x p2 x' \<and> set (awalk_verts x p2) \<subseteq> relations r"
      using Join.IH(2) Join.prems(1,2) 2(1) matching_rels_trans e_def(1) by fastforce
    have "awalk x (p2@[e2]@p1) y"
      using e2_def p1_def p2_def awalk_appendI arc_implies_awalk by blast
    moreover from this have "set (awalk_verts x (p2@[e2]@p1)) \<subseteq> relations (Join l r)"
      using p1_def p2_def awalk_verts_append3 by auto
    ultimately show ?thesis by blast
  next
    case 3
    then obtain x' y' e where e_def:
        "x' \<in> relations l" "y' \<in> relations r" "tail G e = x'" "head G e = y'" "e \<in> arcs G"
      using Join.prems(2) by auto
    obtain p1 where p1_def: "awalk y' p1 y \<and> set (awalk_verts y' p1) \<subseteq> relations r"
      using Join.IH(2) Join.prems(1,2) 3(2) matching_rels_trans e_def(2) by fastforce
    obtain p2 where p2_def: "awalk x p2 x' \<and> set (awalk_verts x p2) \<subseteq> relations l"
      using Join.IH(1) Join.prems(1,2) 3(1) matching_rels_trans e_def(1) by fastforce
    have "awalk x (p2@[e]@p1) y"
      using e_def(3-5) p1_def p2_def awalk_appendI arc_implies_awalk by blast
    moreover from this have "set (awalk_verts x (p2@[e]@p1)) \<subseteq> relations (Join l r)"
      using p1_def p2_def awalk_verts_append3 by auto
    ultimately show ?thesis by blast
  next
    case 4
    then show ?thesis using Join.IH(2)[of x y] Join.prems(1,2) matching_rels_trans by auto
  qed
qed

lemma no_cross_apath:
  "\<lbrakk>matching_rels t; no_cross_products t; x \<in> relations t; y \<in> relations t\<rbrakk>
    \<Longrightarrow> \<exists>p. apath x p y \<and> set (awalk_verts x p) \<subseteq> relations t"
  using no_cross_awalk apath_awalk_to_apath awalk_to_apath_verts_subset by blast

lemma no_cross_reachable:
  "\<lbrakk>matching_rels t; no_cross_products t; x \<in> relations t; y \<in> relations t\<rbrakk> \<Longrightarrow> x \<rightarrow>\<^sup>* y"
  using no_cross_awalk reachable_awalk by blast

corollary reachable_if_no_cross:
  "\<lbrakk>\<exists>t. relations t = verts G \<and> no_cross_products t; x \<in> verts G; y \<in> verts G\<rbrakk> \<Longrightarrow> x \<rightarrow>\<^sup>* y"
  using no_cross_reachable matching_rels_def by blast

lemma remove_sel_sym:
  "\<lbrakk>tail G e\<^sub>1 = head G e\<^sub>2; head G e\<^sub>1 = tail G e\<^sub>2\<rbrakk> \<Longrightarrow> (remove_sel x) e\<^sub>1 = (remove_sel x) e\<^sub>2"
  by(metis (no_types, lifting) mem_Collect_eq not_arc_sel_1 remove_sel_def sel_sym)+

lemma remove_sel_1: "e \<notin> arcs G \<Longrightarrow> (remove_sel x) e = 1"
  apply(cases "e\<in>{a \<in> arcs G. tail G a = x \<or> head G a = x}")
  by(auto simp: not_arc_sel_1 sel_sym remove_sel_def)

lemma del_vert_remove_sel_1:
  assumes "e \<notin> arcs ((del_vert x))"
  shows "(remove_sel x) e = 1"
proof(cases "e\<in>{a \<in> arcs G. tail G a = x \<or> head G a = x}")
  case True
  then show ?thesis by (simp add: remove_sel_def)
next
  case False
  then have "e \<notin> arcs G" using assms arcs_del_vert by simp
  then show ?thesis using remove_sel_def not_arc_sel_1 by simp
qed

lemma remove_sel_pos: "remove_sel x e > 0"
  by(cases "e\<in>{a \<in> arcs G. tail G a = x \<or> head G a = x}") (auto simp: remove_sel_def sel_pos)

lemma remove_sel_leq_1: "remove_sel x e \<le> 1"
  by(cases "e\<in>{a \<in> arcs G. tail G a = x \<or> head G a = x}") (auto simp: remove_sel_def sel_leq_1)

lemma del_vert_pos_cards: "x \<in> verts (del_vert y) \<Longrightarrow> cf x > 0"
  by(cases "x=y") (auto simp: remove_sel_def del_vert_def pos_cards)

lemma del_vert_remove_sel_query_graph:
  "query_graph G sel cf \<Longrightarrow> query_graph (del_vert x) (remove_sel x) cf"
  by (simp add: del_vert_pos_cards del_vert_remove_sel_1 graph_del_vert remove_sel_sym
      remove_sel_leq_1 remove_sel_pos query_graph.intro graph_axioms head_del_vert
      query_graph_axioms_def tail_del_vert)

lemma finite_nempty_set_min:
  assumes "xs \<noteq> {}" and "finite xs"
  shows "\<exists>x. min_degree xs x"
proof -
  have "finite xs" using assms(2) by simp
  then show ?thesis
  using assms proof (induction "xs" rule: finite_induct)
    case empty
    then show ?case by simp
  next
    case ind: (insert x xs)
    then show ?case
    proof(cases xs)
      case emptyI
      then show ?thesis by (metis order_refl singletonD singletonI)
    next
      case (insertI xs' x')
      then have "\<exists>a. min_degree xs a" using ind by simp
      then show ?thesis
        using ind by (metis order_trans insert_iff le_cases)
    qed
  qed
qed

lemma no_cross_reachable_graph':
  "\<lbrakk>\<exists>t. relations t = verts G \<and> no_cross_products t; x\<in>verts G; y\<in>verts G\<rbrakk>
    \<Longrightarrow> x \<rightarrow>\<^sup>*\<^bsub>mk_symmetric G\<^esub> y"
  by (simp add: reachable_mk_symmetricI reachable_if_no_cross)

lemma verts_nempty_if_tree: "\<exists>t. relations t \<subseteq> verts G \<Longrightarrow> verts G \<noteq> {}"
  using relations_nempty by fast

lemma connected_if_tree: "\<exists>t. relations t = verts G \<and> no_cross_products t \<Longrightarrow> connected G"
  using no_cross_reachable_graph' connected_def strongly_connected_def verts_nempty_if_tree
  by fastforce

end

locale nempty_query_graph = query_graph +
  assumes non_empty: "verts G \<noteq> {}"

subsection \<open>Pair Query Graph\<close>

text \<open>Alternative definition based on pair graphs\<close>

locale pair_query_graph = pair_graph +
  fixes sel :: "('a \<times> 'a) weight_fun"
  fixes cf :: "'a \<Rightarrow> real"
  assumes sel_sym: "\<lbrakk>tail G e\<^sub>1 = head G e\<^sub>2; head G e\<^sub>1 = tail G e\<^sub>2\<rbrakk> \<Longrightarrow> sel e\<^sub>1 = sel e\<^sub>2"
      and not_arc_sel_1: "e \<notin> parcs G \<Longrightarrow> sel e = 1"
      and sel_pos: "sel e > 0"
      and sel_leq_1: "sel e \<le> 1"
      and pos_cards: "x \<in> pverts G \<Longrightarrow> cf x > 0"

sublocale pair_query_graph \<subseteq> query_graph
  by(unfold_locales) (auto simp: sel_sym not_arc_sel_1 sel_pos sel_leq_1 pos_cards)

context pair_query_graph
begin

lemma "matching_sel f \<longleftrightarrow> (\<forall>x y. sel (x,y) = f x y)"
  using matching_sel_def sel_sym by fastforce

end

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory More_Numeral_Type
  imports "Word_Lib.WordSetup"
begin

(* This theory provides additional setup for numeral types, which should probably go into
   Numeral_Type in the distribution at some point. *)

text \<open>
  The function package uses @{const size} for guessing termination measures.
  Using @{const size} also provides a convenient cast to natural numbers.
\<close>

instantiation num1 :: size
begin
  definition size_num1 where [simp, code]: "size (n::num1) = 0"
  instance ..
end

instantiation bit0 and bit1 :: (finite) size
begin
  definition size_bit0 where [code]: "size n = nat (Rep_bit0 n)"
  definition size_bit1 where [code]: "size n = nat (Rep_bit1 n)"
  instance ..
end

(* As in the parent theory Numeral_Type, we first prove everything abstractly to avoid duplication,
   and then instantiate bit0 and bit1. *)
locale mod_size_order = mod_ring n Rep Abs
  for n :: int
  and Rep :: "'a::{comm_ring_1,size,linorder} \<Rightarrow> int"
  and Abs :: "int \<Rightarrow> 'a::{comm_ring_1,size,linorder}" +
  assumes size_def: "size x = nat (Rep x)"
  assumes less_def: "(a < b) = (Rep a < Rep b)"
  assumes less_eq_def: "(a \<le> b) = (Rep a \<le> Rep b)"
begin

text \<open>
  Automatic simplification of concrete @{term "(<)"} and @{term "(<=)"} goals on numeral types.
\<close>
lemmas order_numeral[simp] =
  less_def[of "numeral a" "numeral b" for a b]
  less_eq_def[of "numeral a" "numeral b" for a b]
  less_def[of "0" "numeral b" for b]
  less_def[of "1" "numeral b" for b]
  less_eq_def[of "0" "numeral b" for b]
  less_eq_def[of "1" "numeral b" for b]
  less_def[of "numeral a" "0" for a]
  less_def[of "numeral a" "1" for a]
  less_eq_def[of "numeral a" "0" for a]
  less_eq_def[of "numeral a" "1" for a]

text \<open> Simplifying size numerals. \<close>
lemmas [simp] = Rep_numeral
lemmas size_numerals[simp] = size_def[of "numeral m" for m]

text \<open> Simplifying representatives of 0 and 1 \<close>
lemmas [simp] = Rep_0 Rep_1

lemmas definitions = definitions less_def less_eq_def size_def

lemmas Rep = type_definition.Rep[OF type]
lemmas Abs_cases = type_definition.Abs_cases[OF type]

lemma of_nat_size[simp]:
  "of_nat (size x) = (x::'a)"
  by (cases x rule: Abs_cases) (clarsimp simp: Abs_inverse of_int_eq size_def)

lemma size_of_nat[simp]:
  "size (of_nat x :: 'a) = nat (int x mod n)"
  by (simp add: Rep_Abs_mod of_nat_eq size0 size_def)

lemma zero_less_eq[simp]:
  "0 \<le> (x :: 'a)"
  using Rep by (simp add: less_eq_def)

lemma zero_less_one[simp,intro!]:
  "0 < (1::'a)"
  by (simp add: less_def)

lemma zero_least[simp,intro]:
  "(x::'a) < y \<Longrightarrow> 0 < y"
  by (simp add: le_less_trans)

lemma not_less_zero_bit0[simp]:
  "\<not> (x::'a) < 0"
  by (simp add: not_less)

lemmas not_less_zeroE[elim!] = notE[OF not_less_zero]

lemma one_leq[simp]:
  "(1 \<le> x) = (0 < (x::'a))"
  using less_def less_eq_def by auto

lemma less_eq_0[simp]:
  "(x \<le> 0) = (x = (0::'a))"
  by (simp add: antisym)

lemma size_less[simp]:
  "(size (x::'a) < size y) = (x < y)"
  by (cases x rule: Abs_cases, cases y rule: Abs_cases) (auto simp: Abs_inverse definitions)

lemma size_inj[simp]:
  "(size (x::'a) = size y) = (x = y)"
  by (metis of_nat_size)

lemma size_less_eq[simp]:
  "(size (x::'a) \<le> size y) = (x \<le> y)"
  by (auto simp: le_eq_less_or_eq)

lemma size_0[simp]:
  "size (0::'a) = 0"
  by (simp add: size_def)

lemma size_1[simp]:
  "size (1::'a) = 1"
  by (simp add: size_def)

lemma size_eq_0[simp]:
  "(size x = 0) = ((x::'a) = 0)"
  using size_inj by fastforce

lemma minus_less:
  "\<lbrakk> y \<le> x; 0 < y \<rbrakk> \<Longrightarrow> x - y < (x::'a)"
  unfolding definitions
  by (cases x rule: Abs_cases, cases y rule: Abs_cases) (simp add: Abs_inverse)

lemma pred[simp,intro!]:
  "0 < (x::'a) \<Longrightarrow> x - 1 < x"
  by (auto intro!: minus_less)

lemma minus1_leq:
  "\<lbrakk> x - 1 \<le> y; y < x \<rbrakk> \<Longrightarrow> (y::'a) = x-1"
  by (smt Rep_1 Rep_Abs_mod Rep_less_n less_def diff_def int_mod_ge le_neq_trans)

lemma max_bound_leq[simp,intro!]:
  "(x::'a) \<le> -1"
  by (smt Rep_1 Rep_Abs_mod Rep_less_n less_eq_def int_mod_ge' minus_def)

lemma leq_minus1_less:
  "0 < y \<Longrightarrow> (x \<le> y - 1) = (x < (y::'a))"
  by (metis le_less less_trans minus1_leq not_less pred)

lemma max_bound_neq_conv[simp]:
  "(x \<noteq> -1) = ((x::'a) < -1)"
  using le_neq_trans by auto

lemma max_bound_leq_conv[simp]:
  "(- 1 \<le> (x::'a)) = (x = - 1)"
  by (simp add: eq_iff)

lemma max_bound_not_less[simp]:
  "\<not> -1 < (x::'a)"
  using minus1_leq by fastforce

lemma minus_1_eq:
  "(-1::'a) = of_nat (nat n - 1)"
  unfolding definitions using Rep_Abs_1 of_nat_eq size1 by auto

lemma n_not_less_Rep[simp]:
  "\<not> n < Rep x"
  using Rep[of x] by (simp add: not_less)

lemma size_plus:
  "(x::'a) < x + y \<Longrightarrow> size (x + y) = size x + size y"
  unfolding definitions Rep_Abs_mod
  using Rep size0
  by (simp flip: nat_add_distrib add: eq_nat_nat_iff pos_mod_sign mod_add_if_z split: if_split_asm)

lemma Suc_size[simp]:
  "(x::'a) < x + 1 \<Longrightarrow> size (x + 1) = Suc (size x)"
  by (simp add: size_plus)

lemma no_overflow_eq_max_bound:
  "((x::'a) < x + 1) = (x < -1)"
  unfolding definitions
  by (smt Rep_Abs_mod Rep_Abs_1 Rep_less_n int_mod_ge int_mod_ge' size0)

lemma plus_one_leq:
  "x < y \<Longrightarrow> x + 1 \<le> (y::'a)"
  by (metis add_diff_cancel_right' leq_minus1_less not_le zero_least)

lemma less_uminus:
  "\<lbrakk> - x < y; x \<noteq> 0 \<rbrakk> \<Longrightarrow> - y < (x::'a)"
  unfolding definitions
  by (smt Rep_inverse Rep_mod Rep_Abs_mod size0 zmod_zminus1_eq_if)

lemma of_nat_cases[case_names of_nat]:
  "(\<And>m. \<lbrakk> (x::'a) = of_nat m; m < nat n \<rbrakk> \<Longrightarrow> P) \<Longrightarrow> P"
  by (metis mod_type.Rep_less_n mod_type_axioms nat_mono_iff of_nat_size size0 size_def)

lemma minus_induct[case_names 0 minus]:
  assumes "P (0::'a)"
  assumes suc: "\<And>x. \<lbrakk> P (x - 1); 0 < x \<rbrakk> \<Longrightarrow> P x"
  shows "P x"
proof (cases x rule: of_nat_cases)
  case (of_nat m)
  have "P (of_nat m)"
  proof (induct m)
    case 0
    then show ?case using `P 0` by simp
  next
    case (Suc m)
    show ?case
    proof (cases "1 + of_nat m = (0::'a)")
      case True
      then show ?thesis using `P 0` by simp
    next
      case False
      with Suc suc show ?thesis by (metis add_diff_cancel_left' less_eq_0 not_less of_nat_Suc)
    qed
  qed
  with of_nat show ?thesis by simp
qed

lemma plus_induct[case_names 0 plus]:
  assumes "P (0::'a)"
  assumes suc: "\<And>x. \<lbrakk> P x; x < x + 1 \<rbrakk> \<Longrightarrow> P (x + 1)"
  shows "P x"
proof (cases x rule: of_nat_cases)
  case (of_nat m)
  have "P (of_nat m)"
  proof (induct m)
    case 0
    then show ?case using `P 0` by simp
  next
    case (Suc m)
    with `P 0` suc show ?case by (metis diff_add_cancel minus_induct pred)
  qed
  with of_nat show ?thesis by simp
qed

lemma from_top_induct[case_names top step]:
  assumes top: "\<And>x. y \<le> x \<Longrightarrow> P (x::'a)"
  assumes step: "\<And>x. \<lbrakk>P x; 0 < x; x \<le> y\<rbrakk> \<Longrightarrow> P (x - 1)"
  shows "P x"
proof -
  obtain z where x: "x = y - z"
    by (metis diff_eq_diff_eq diff_right_commute)
  moreover
  have "P (y - z)"
  proof (induct z rule: plus_induct)
    case 0
    then show ?case by (simp add: top)
  next
    case (plus x)
    then have [simp]: "y - (x + 1) = (y - x) - 1" by simp
    show ?case
    proof (cases "x < y")
      case True
      with plus show ?thesis
       by simp (metis diff_add_cancel eq_iff_diff_eq_0 le_neq_trans step plus_one_leq not_le
                      top zero_less_eq)
    next
      case False
      with plus show ?thesis
       by (smt top Rep_Abs_mod Rep_le_n less_def less_eq_def diff_def int_mod_ge' size0)
    qed
  qed
  ultimately show ?thesis by simp
qed

lemma tranclp_greater: "(>)\<^sup>+\<^sup>+ = ((>) :: 'a \<Rightarrow> 'a \<Rightarrow> bool)"
  by(auto simp add: fun_eq_iff intro: less_trans elim: tranclp.induct)

lemma card_n:
  "CARD('a) = nat n"
  using type by (simp add: type_definition.card)

lemma finite_UNIV[intro!,simp]:
  "finite (UNIV::'a set)"
  by (rule card_ge_0_finite) (simp add: card_n size0)

lemma finite_greater[simp]:
  "finite {(x, y). y < (x::'a)}"
  by (rule finite_subset[of _ "UNIV \<times> UNIV"], simp)
     (rule finite_cartesian_product; rule finite_UNIV)

lemma wf_greater[intro!,simp]:
  "wf {(x,y). x > (y::'a)}"
  by (auto simp: trancl_def tranclp_greater intro!: finite_acyclic_wf acyclicI)

(* less_induct already instantiated in class well_order *)
lemma greater_induct[case_names greater]:
  "(\<And>x. (\<And>z. x < z \<Longrightarrow> P z) \<Longrightarrow> P x) \<Longrightarrow> P (x::'a)"
  by (rule wf_induct_rule, rule wf_greater) fastforce

lemma from_top_full_induct[case_names top step]:
  assumes top: "\<And>x. y \<le> x \<Longrightarrow> P (x::'a)"
  assumes step: "\<And>x. \<lbrakk>\<forall>z > x. P z; x < y\<rbrakk> \<Longrightarrow> P x"
  shows "P x"
proof (induct x rule: greater_induct)
  case (greater x)
  show ?case
  proof (cases "x < y")
    case True
    then show ?thesis by (blast intro: step greater)
  next
    case False
    then show ?thesis by (auto simp: not_less intro: top)
  qed
qed

interpretation greater_wellorder: wellorder "(\<ge>) :: 'a \<Rightarrow> 'a \<Rightarrow> bool" "(>) :: 'a \<Rightarrow> 'a \<Rightarrow> bool"
  by unfold_locales (auto intro: greater_induct)

lemma greater_least_fold[simp]: "greater_wellorder.Least = Greatest"
  by (auto simp: greater_wellorder.Least_def Greatest_def)

lemmas GreatestI = greater_wellorder.LeastI[simplified greater_least_fold]
lemmas Greatest_le = greater_wellorder.Least_le[simplified greater_least_fold]
lemmas exists_greatest_iff = greater_wellorder.exists_least_iff
lemmas GreatestI2_wellorder = greater_wellorder.LeastI2_wellorder[simplified greater_least_fold]

lemma neq_0_conv:
  "((x::'a) \<noteq> 0) = (0 < x)"
  by (meson neqE not_less_zero_bit0)

lemma minus_leq_less: "\<lbrakk> (x::'a) \<le> y; 0 < z; z \<le> x \<rbrakk> \<Longrightarrow> x - z < y"
  by (metis le_less less_trans minus_less)

lemma minus_one_leq_less: "\<lbrakk> (x::'a) \<le> y; 0 < x \<rbrakk> \<Longrightarrow> x - 1 < y"
  using pred by fastforce

lemma size_minus:
  "y \<le> (x::'a) \<Longrightarrow> size (x - y) = size x - size y"
  unfolding definitions Rep_Abs_mod
  using Rep size0
  by (simp flip: nat_diff_distrib add: eq_nat_nat_iff pos_mod_sign mod_sub_if_z split: if_split_asm)

lemma size_minus_one:
  "0 < (x::'a) \<Longrightarrow> size (x - 1) = size x - Suc 0"
  by (simp add: size_minus)

end

interpretation bit0:
  mod_size_order "int CARD('a::finite bit0)"
                 "Rep_bit0 :: 'a::finite bit0 \<Rightarrow> int"
                 "Abs_bit0 :: int \<Rightarrow> 'a::finite bit0"
  by unfold_locales (auto simp: size_bit0_def less_bit0_def less_eq_bit0_def)

interpretation bit1:
  mod_size_order "int CARD('a::finite bit1)"
                 "Rep_bit1 :: 'a::finite bit1 \<Rightarrow> int"
                 "Abs_bit1 :: int \<Rightarrow> 'a::finite bit1"
  by unfold_locales (auto simp: size_bit1_def less_bit1_def less_eq_bit1_def)

declare bit0.minus_induct[induct type]
declare bit1.minus_induct[induct type]

section \<open>Further enumeration instances.\<close>

instantiation bit0 and bit1 :: (finite) enumeration_both
begin

definition enum_alt_bit0 where "enum_alt \<equiv> alt_from_ord (enum :: 'a :: finite bit0 list)"
definition enum_alt_bit1  where "enum_alt \<equiv> alt_from_ord (enum :: 'a :: finite bit1 list)"

instance by intro_classes (auto simp: enum_alt_bit0_def enum_alt_bit1_def)

end

subsection \<open>Relating @{const enum} and @{const size}\<close>

lemma fromEnum_size_bit0[simp]:
  "fromEnum (x::'a::finite bit0) = size x"
proof -
  have "enum ! the_index enum x = x" by (auto intro: nth_the_index)
  moreover
  have "the_index enum x < length (enum::'a bit0 list)" by (auto intro: the_index_bounded)
  moreover
  { fix y
    assume "Abs_bit0' (int y) = x"
    moreover
    assume "y < 2 * CARD('a)"
    ultimately
    have "y = nat (Rep_bit0 x)"
      by (smt Abs_bit0'_code card_bit0 mod_pos_pos_trivial nat_int of_nat_less_0_iff
              zless_nat_eq_int_zless)
  }
  ultimately
  show ?thesis by (simp  add: fromEnum_def enum_bit0_def size_bit0_def)
qed

lemma fromEnum_size_bitq[simp]:
  "fromEnum (x::'a::finite bit1) = size x"
proof -
  have "enum ! the_index enum x = x" by (auto intro: nth_the_index)
  moreover
  have "the_index enum x < length (enum::'a bit1 list)" by (auto intro: the_index_bounded)
  moreover
  { fix y
    assume "Abs_bit1' (int y) = x"
    moreover
    assume "y < Suc (2 * CARD('a))"
    ultimately
    have "y = nat (Rep_bit1 x)"
      by (smt Abs_bit1'_code card_bit1 mod_pos_pos_trivial nat_int of_nat_less_0_iff
              zless_nat_eq_int_zless)
  }
  ultimately
  show ?thesis by (simp add: fromEnum_def enum_bit1_def size_bit1_def del: upt_Suc)
qed

lemma minBound_size_bit0[simp]:
  "(minBound::'a::finite bit0) = 0"
  by (simp add: minBound_def hd_map enum_bit0_def Abs_bit0'_def zero_bit0_def)

lemma minBound_size_bit1[simp]:
  "(minBound::'a::finite bit1) = 0"
  by (simp add: minBound_def hd_map enum_bit1_def Abs_bit1'_def zero_bit1_def)

lemma maxBound_size_bit0:
  "(maxBound::'a::finite bit0) = of_nat (2 * CARD('a) - 1)"
  by (simp add: maxBound_def enum_bit0_def last_map Abs_bit0'_def bit0.of_nat_eq)

lemma maxBound_size_bit1:
  "(maxBound::'a::finite bit1) = of_nat (2 * CARD('a))"
  by (simp add: maxBound_def enum_bit1_def last_map Abs_bit1'_def bit1.of_nat_eq)

lemma maxBound_minus_one_bit0:
  "maxBound = (-1 ::'a::finite bit0)"
  by (simp add: bit0.definitions bit0.of_nat_eq bit0.Rep_Abs_1 maxBound_size_bit0)

lemma maxBound_minus_one_bit1:
  "maxBound = (-1 ::'a::finite bit1)"
  by (simp add: bit1.definitions bit1.of_nat_eq bit1.Rep_Abs_1 zmod_minus1 maxBound_size_bit1)

lemmas maxBound_size_bit = maxBound_size_bit0 maxBound_size_bit1
lemmas maxBound_minus_one_bit[simp] = maxBound_minus_one_bit1 maxBound_minus_one_bit0

end


theory LValues
  imports Main
begin

record ('mem,'val) lvalue_raw =
  lv_domain :: \<open>'mem set\<close>
  lv_range :: \<open>'val set\<close>
  lv_getter :: \<open>'mem \<Rightarrow> 'val\<close>
  lv_setter :: \<open>'val \<Rightarrow> 'mem \<Rightarrow> 'mem\<close>

inductive valid_lvalue where
  "\<lbrakk>\<And>a m. m \<in> D \<Longrightarrow> a \<in> R \<Longrightarrow> g (s a m) = a;
    \<And>m. m \<in> D \<Longrightarrow> s (g m) m = m;
    \<And>a b m. m \<in> D \<Longrightarrow> a \<in> R \<Longrightarrow> b \<in> R \<Longrightarrow> s a (s b m) = s a m;
    \<And>m. m \<in> D \<Longrightarrow> g m \<in> R;
    \<And>a m. m \<in> D \<Longrightarrow> a \<in> R \<Longrightarrow> s a m \<in> D\<rbrakk>
   \<Longrightarrow> valid_lvalue \<lparr> lv_domain=D, lv_range=R, lv_getter=g, lv_setter=s \<rparr>"

lemmas valid_lvalueI = valid_lvalue.intros
    [case_names get_set set_get set_set get_range set_domain (* domain_inhabited *)]

inductive compatible_lvalues where
  "\<lbrakk>valid_lvalue x; valid_lvalue y;
    lv_domain x = lv_domain y;
    \<And>a b m. m \<in> lv_domain x \<Longrightarrow> a \<in> lv_range x \<Longrightarrow> b \<in> lv_range y \<Longrightarrow>
            lv_setter x a (lv_setter y b m) = lv_setter y b (lv_setter x a m)\<rbrakk>
    \<Longrightarrow> compatible_lvalues x y"

lemma compatible_swap_set:
  assumes "compatible_lvalues x y"
  assumes "m \<in> lv_domain x" and "a \<in> lv_range x" and "b \<in> lv_range y"
  shows "lv_setter x a (lv_setter y b m) = lv_setter y b (lv_setter x a m)"
  using assms(1) apply cases
  using assms(2) assms(3) assms(4) by blast

lemma compatible_lvalues_sym:
  assumes "compatible_lvalues x y"
  shows "compatible_lvalues y x"
  using assms apply cases apply (rule compatible_lvalues.intros) by auto

definition lvalue_pair where
  "lvalue_pair x y = \<lparr> lv_domain = lv_domain x, lv_range = lv_range x \<times> lv_range y,
    lv_getter = \<lambda>m. if m \<in> lv_domain x then (lv_getter x m, lv_getter y m) else undefined,
    lv_setter = \<lambda>(a,b). lv_setter y b \<circ> lv_setter x a\<rparr>"

lemma lvalue_pair_domain[simp]:
  "lv_domain (lvalue_pair x y) = lv_domain x"
  by (simp add: lvalue_pair_def)

lemma lvalue_pair_range[simp]:
  "lv_range (lvalue_pair x y) = lv_range x \<times> lv_range y"
  by (simp add: lvalue_pair_def)

lemma set_domain[simp]:
  assumes "valid_lvalue x"
  assumes "m \<in> lv_domain x"
  assumes "a \<in> lv_range x"
  shows "lv_setter x a m \<in> lv_domain x"
  using assms apply cases
  by auto

lemma get_set[simp]:
  assumes "valid_lvalue x"
  assumes "m \<in> lv_domain x"
  assumes "a \<in> lv_range x"
  shows "lv_getter x (lv_setter x a m) = a"
  using assms apply cases by auto

lemma set_get[simp]:
  assumes "valid_lvalue x"
  assumes "m \<in> lv_domain x"
  shows "lv_setter x (lv_getter x m) m = m"
  using assms apply cases by auto

lemma set_set[simp]:
  assumes "valid_lvalue x"
  assumes "m \<in> lv_domain x"
  assumes "a \<in> lv_range x"
  assumes "b \<in> lv_range x"
  shows "lv_setter x a (lv_setter x b m) = lv_setter x a m"
  using assms apply cases by auto

lemma get_range[simp]:
  assumes "valid_lvalue x"
  assumes "m \<in> lv_domain x"
  shows "lv_getter x m \<in> lv_range x"
  using assms apply cases by auto

(* lemma domain_inhabited[simp]:
  assumes "valid_lvalue x"
  shows "lv_domain x \<noteq> {}"
  using assms apply cases by auto

lemma range_inhabited[simp]:
  assumes "valid_lvalue x"
  shows "lv_range x \<noteq> {}"
  using assms apply cases by auto *)

lemma lvalue_pair_valid[simp]:
  fixes x :: "('mem,'val1) lvalue_raw" and y :: "('mem,'val2) lvalue_raw"
  assumes "compatible_lvalues x y"
  shows "valid_lvalue (lvalue_pair x y)"
  using assms apply cases
  unfolding lvalue_pair_def apply (rule valid_lvalueI)
       apply auto
           apply (metis get_set set_domain)
  using set_domain apply fastforce
    apply (metis set_domain)
  apply (metis set_domain set_set)
  using set_domain by fastforce

definition lvalue_chain where
  "lvalue_chain x y = \<lparr> lv_domain = lv_domain x, lv_range = lv_range y,
                        lv_getter = lv_getter y \<circ> lv_getter x,
                        lv_setter = \<lambda>a m. lv_setter x (lv_setter y a (lv_getter x m)) m\<rparr>"

lemma lvalue_chain_domain[simp]: "lv_domain (lvalue_chain x y) = lv_domain x"
  by (simp add: lvalue_chain_def)

lemma lvalue_chain_range[simp]: "lv_range (lvalue_chain x y) = lv_range y"
  by (simp add: lvalue_chain_def)

lemma lvalue_chain_valid[simp]:
  assumes "valid_lvalue x"
  assumes "valid_lvalue y"
  assumes "lv_range x = lv_domain y"
  shows "valid_lvalue (lvalue_chain x y)"
  using assms apply cases
  unfolding lvalue_chain_def apply (rule valid_lvalueI)
  by auto

inductive_set same_except for x where
  "\<lbrakk>m \<in> lv_domain x; a \<in> lv_range x\<rbrakk> \<Longrightarrow> (m, lv_setter x a m) \<in> same_except x"

lemma equiv_same_except:
  assumes "valid_lvalue x"
  shows "equiv (lv_domain x) (same_except x)"
proof (rule equivI)
  show "refl_on (lv_domain x) (same_except x)"
    apply (rule refl_onI)
    using assms same_except.simps apply fastforce
    by (metis assms get_range same_except.simps set_get)
  show "sym (same_except x)"
    by (metis (no_types, lifting) assms get_range same_except.simps set_domain set_get set_set sym_def)
  show "trans (same_except x)"
    by (smt assms same_except.simps set_set trans_def)
qed

definition memory_except where
  "memory_except x = lv_domain x // same_except x"

definition split_memory where
  "split_memory x m = (lv_getter x m, same_except x `` {m})"

definition join_memory where
  "join_memory x = (\<lambda>(a,m). the_elem (lv_setter x a ` m))"

lemma split_memory_range:
  assumes [simp]: "valid_lvalue x"
  assumes [simp]: "m \<in> lv_domain x"
  shows "split_memory x m \<in> lv_range x \<times> memory_except x"
  by (simp add: split_memory_def memory_except_def quotientI)

lemma congruent_lv_setter:
  assumes "valid_lvalue x" and "a \<in> lv_range x"
  shows "congruent (same_except x) (lv_setter x a)"
  apply (rule congruentI)
  apply (cases rule: same_except.cases)
  using assms by auto

lemma apply_congruent:
  assumes "f respects r"
  assumes "equiv A r"
  assumes "x \<in> A"
  shows "f ` r `` {x} = {f x}"
  using assms
  using congruentD equiv_class_self image_insert by fastforce

lemma join_split_memory[simp]:
  assumes "valid_lvalue x"
  assumes "m \<in> lv_domain x"
  shows "join_memory x (split_memory x m) = m"
proof -
  define a m' where "a = lv_getter x m" and "m' = same_except x `` {m}"
  have sm: "split_memory x m = (a,m')"
    by (simp add: a_def m'_def split_memory_def)
  have "congruent (same_except x) (lv_setter x a)"
    and "equiv (lv_domain x) (same_except x)"
    and "m \<in> lv_domain x"
    by (auto simp add: a_def assms(1) assms(2) congruent_lv_setter equiv_same_except)
  then have s: "lv_setter x a ` m' = {lv_setter x a m}"
    unfolding m'_def
    by (meson apply_congruent)
  then show ?thesis
    unfolding sm join_memory_def a_def using assms by auto
qed

lemma split_join_memory[simp]:
  assumes [simp]: "valid_lvalue x"
  assumes "am \<in> lv_range x \<times> memory_except x"
  shows "split_memory x (join_memory x am) = am"
proof -
  obtain a m' where am_def: "am = (a,m')" by force
  then have a[simp]: "a \<in> lv_range x" and "m' \<in> lv_domain x // same_except x"
    using assms unfolding memory_except_def by auto
  then obtain m where m[simp]: "m \<in> lv_domain x" and m': "m' = same_except x `` {m}"
    using quotientE by blast
  have am': "am = split_memory x (lv_setter x a m)"
    unfolding split_memory_def am_def apply simp
    by (metis a assms(1) equiv_class_eq equiv_same_except m m' same_except.intros)
  show ?thesis
    unfolding am'
    apply (subst join_split_memory)
    by auto
qed

lemma join_memory_range:
  assumes [simp]: "valid_lvalue x"
  assumes [simp]: "am \<in> lv_range x \<times> memory_except x"
  shows "join_memory x am \<in> lv_domain x"
  by (smt ImageE Pair_inject SigmaE SigmaI assms(1) assms(2) equiv_Eps_in equiv_same_except memory_except_def same_except.simps singletonD split_join_memory split_memory_def)

lemma bij_split_memory:
  assumes [simp]: "valid_lvalue x"
  shows "bij_betw (split_memory x) (lv_domain x) (lv_range x \<times> memory_except x)"
  apply (rule bij_betw_byWitness[where f'="join_memory x"])
  apply auto
  apply (simp add: split_memory_def)
  apply (simp add: memory_except_def quotientI split_memory_def)
  apply (rule join_memory_range)
  by auto

lemma bij_join_memory:
  assumes [simp]: "valid_lvalue x"
  shows "bij_betw (join_memory x) (lv_range x \<times> memory_except x) (lv_domain x)"
  apply (rule bij_betw_byWitness[where f'="split_memory x"])
     apply auto
    apply (simp add: join_memory_range)
   apply (simp add: split_memory_def)
  by (simp add: memory_except_def quotientI split_memory_def)

lemma get_split_memory[simp]:
  assumes [simp]: "valid_lvalue x"
  assumes [simp]: "m \<in> lv_domain x"
  shows "fst (split_memory x m) = lv_getter x m"
  unfolding split_memory_def by simp

definition lvalue_map where
  "lvalue_map f x = \<lparr> lv_domain=lv_domain x, lv_range = f ` lv_range x,
    lv_getter = \<lambda>m. f (lv_getter x m),
    lv_setter = \<lambda>a m. lv_setter x (inv_into (lv_range x) f a) m\<rparr>"

lemma valid_lvalue_map:
  assumes "valid_lvalue x"
  assumes "inj_on f (lv_range x)"
  shows "valid_lvalue (lvalue_map f x)"
  unfolding lvalue_map_def apply (rule valid_lvalueI)
  using assms by auto

lemma lvalue_map_range[simp]: "lv_range (lvalue_map f x) = f ` lv_range x"
  by (simp add: lvalue_map_def)

lemma lvalue_map_domain[simp]: "lv_domain (lvalue_map f x) = lv_domain x"
  by (simp add: lvalue_map_def)

lemma compatible_valid1: "compatible_lvalues x y \<Longrightarrow> valid_lvalue x"
  using compatible_lvalues.simps by blast

lemma compatible_valid2: "compatible_lvalues x y \<Longrightarrow> valid_lvalue y"
  using compatible_lvalues.simps by blast

lemma lvalue_map_compat1:
  assumes [simp]: "compatible_lvalues x y"
  assumes "inj_on f (lv_range x)"
  shows "compatible_lvalues (lvalue_map f x) y"
  using assms(1) apply cases
  apply (rule compatible_lvalues.intros)
     apply (rule valid_lvalue_map)
  using assms(2) apply auto
  by (simp add: lvalue_map_def)

lemma lvalue_map_compat2:
  assumes [simp]: "compatible_lvalues x y"
  assumes "inj_on f (lv_range y)"
  shows "compatible_lvalues x (lvalue_map f y)"
  using assms(1) apply cases
  apply (rule compatible_lvalues.intros)
  apply auto
     apply (rule valid_lvalue_map)
  using assms(2) apply auto
  by (simp add: lvalue_map_def)

lemma get_set_diff[simp]:
  fixes x y
  assumes [simp]: "LValues.compatible_lvalues x y"
  assumes [simp]: "m \<in> lv_domain x"
  assumes [simp]: "a \<in> lv_range y"
  shows "lv_getter x (lv_setter y a m) = lv_getter x m"
proof -
  have [simp]: "LValues.valid_lvalue x" and [simp]: "LValues.valid_lvalue y"
    using assms compatible_valid1 compatible_valid2 by blast+
  have [simp]: "m \<in> lv_domain y"
    using assms(1) assms(2) compatible_lvalues.cases by blast
  have "lv_getter x (lv_setter y a m) = lv_getter x (lv_setter y a (lv_setter x (lv_getter x m) m))"
    by (subst set_get; simp)
  also have "\<dots> = lv_getter x (lv_setter x (lv_getter x m) (lv_setter y a m))"
    apply (subst compatible_swap_set)
    apply (subst compatible_lvalues_sym)
    by auto
  also have "\<dots> = lv_getter x m"
    apply (rule get_set, auto)
    by (metis \<open>m \<in> lv_domain y\<close> assms(1) assms(3) compatible_lvalues.cases set_domain)
  finally show ?thesis
    by -
qed

definition "unit_lvalue A = \<lparr> lv_domain=A, lv_range={()},
  lv_getter = \<lambda>_. (), lv_setter = \<lambda>_. id \<rparr>"

lemma valid_unit_lvalue[simp]: "valid_lvalue (unit_lvalue A)"
  unfolding unit_lvalue_def
  apply (rule valid_lvalueI)
  by auto

lemma domain_unit_lvalue[simp]: "lv_domain (unit_lvalue A) = A"
  by (simp add: unit_lvalue_def)

lemma range_unit_lvalue[simp]: "lv_range (unit_lvalue A) = {()}"
  by (simp add: unit_lvalue_def)

lemma setter_unit_lvalue[simp]: "lv_setter (unit_lvalue A) a = id"
  by (simp add: unit_lvalue_def)

lemma unit_lvalue_compat[simp]:
  assumes [simp]: "valid_lvalue x"
  assumes [simp]: "A = lv_domain x"
  shows "compatible_lvalues (unit_lvalue A) x"
  apply (rule compatible_lvalues.intros)
  by auto

lemma unit_lvalue_compat'[simp]:
  assumes [simp]: "valid_lvalue x"
  assumes [simp]: "A = lv_domain x"
  shows "compatible_lvalues x (unit_lvalue A)"
  apply (rule compatible_lvalues_sym)
  by simp

lemma setter_pair[simp]:
  shows "lv_setter (lvalue_pair x y) (a,b) m = lv_setter y b (lv_setter x a m)"
  unfolding lvalue_pair_def by simp

lemma pair_compat1[simp]:
  assumes [simp]: "compatible_lvalues x z"
  assumes [simp]: "compatible_lvalues y z"
  assumes [simp]: "compatible_lvalues x y"
  shows "compatible_lvalues (lvalue_pair x y) z"
proof (rule compatible_lvalues.intros)
  have [simp]: "valid_lvalue x" "valid_lvalue y"
    using compatible_valid1 compatible_valid2 assms by blast+
  show "valid_lvalue (lvalue_pair x y)" and [simp]: "valid_lvalue z"
    using assms compatible_valid2 apply simp
    using assms(1) compatible_valid2 by blast
  show "lv_domain (lvalue_pair x y) = lv_domain z"
    using assms(1) apply cases by simp

  have xy[simp]: "lv_domain x = lv_domain y"
    using compatible_lvalues.simps by fastforce
  have yz[simp]: "lv_domain y = lv_domain z"
    using compatible_lvalues.simps by fastforce

  fix m a b
  assume "m \<in> lv_domain (lvalue_pair x y)"
  then have [simp]: "m \<in> lv_domain x" "m \<in> lv_domain y" "m \<in> lv_domain z"
    by auto
  assume "a \<in> lv_range (lvalue_pair x y)"
  then obtain a1 a2 where a: "a = (a1,a2)"
    and [simp]: "a1 \<in> lv_range x" and [simp]: "a2 \<in> lv_range y" by auto
  assume [simp]: "b \<in> lv_range z"

  have "lv_setter (lvalue_pair x y) a (lv_setter z b m) =
        lv_setter y a2 (lv_setter x a1 (lv_setter z b m))"
    unfolding a by simp
  also have "\<dots> = lv_setter y a2 (lv_setter z b (lv_setter x a1 m))"
    apply (subst (2) compatible_swap_set) by auto
  also have "\<dots> = lv_setter z b (lv_setter y a2 (lv_setter x a1 m))"
    apply (subst (1) compatible_swap_set) by (auto simp flip: yz xy)
  also have "\<dots> = lv_setter z b (lv_setter (lvalue_pair x y) a m)"
    unfolding a by simp
  finally show "lv_setter (lvalue_pair x y) a (lv_setter z b m) =
        lv_setter z b (lv_setter (lvalue_pair x y) a m)"
    by -
qed

lemma pair_compat2[simp]:
  assumes [simp]: "compatible_lvalues x y"
  assumes [simp]: "compatible_lvalues x z"
  assumes [simp]: "compatible_lvalues y z"
  shows "compatible_lvalues x (lvalue_pair y z)"
  apply (rule compatible_lvalues_sym)
  apply (rule pair_compat1)
  using assms compatible_lvalues_sym by blast+

definition "co_lvalue x = \<lparr> lv_domain=lv_domain x,
  lv_range=memory_except x,
  lv_getter=snd o split_memory x,
  lv_setter=\<lambda>r' m. case split_memory x m of (a,r) \<Rightarrow> join_memory x (a,r') \<rparr>"

lemma valid_co_lvalue[simp]:
  assumes "valid_lvalue x"
  shows "valid_lvalue (co_lvalue x)"
  using assms apply cases
  unfolding co_lvalue_def
  apply (rule valid_lvalueI)
  apply auto
  apply (metis (no_types, lifting) SigmaI assms case_prod_beta eq_snd_iff get_split_memory select_convs(1) select_convs(2) select_convs(3) split_join_memory)
  apply (metis (no_types, lifting) SigmaI assms get_split_memory prod.case_eq_if select_convs(1) select_convs(2) select_convs(3) sndI split_join_memory)
  apply (metis (no_types, lifting) assms case_prod_beta' join_split_memory prod.collapse select_convs(1))
  apply (metis (no_types, lifting) SigmaI assms fstI prod.case_eq_if select_convs(2) select_convs(3) split_join_memory split_memory_def)
  apply (simp add: memory_except_def quotientI split_memory_def)
  by (metis (no_types, lifting) SigmaI assms case_prod_beta' get_split_memory join_memory_range select_convs(1) select_convs(2) select_convs(3))

lemma domain_co_lvalue[simp]: "lv_domain (co_lvalue x) = lv_domain x"
  by (simp add: co_lvalue_def)

lemma range_co_lvalue[simp]: "lv_range (co_lvalue x) = memory_except x"
  by (simp add: co_lvalue_def)

lemma snd_split_set:
  assumes [simp]: "valid_lvalue x"
  assumes [simp]: "m \<in> lv_domain x"
  assumes [simp]: "a \<in> lv_range x"
  shows "snd (split_memory x (lv_setter x a m)) = snd (split_memory x m)"
  apply (rule sym)
  unfolding split_memory_def apply simp
  apply (rule equiv_class_eq)
   apply (rule equiv_same_except, simp)
  apply (rule same_except.intros)
  by auto

lemma compatible_co_lvalue:
  assumes [simp]: "valid_lvalue x"
  shows "compatible_lvalues x (co_lvalue x)"
  apply (rule compatible_lvalues.intros)
     apply simp_all
  unfolding co_lvalue_def split_memory_def apply auto
  apply (rule inj_onD[where f="split_memory x" and A="lv_domain x"])
  using assms bij_betw_def bij_split_memory apply blast
    apply (rule prod_eqI)
     apply simp
     apply (subst get_split_memory, simp)
      apply (simp add: join_memory_range)
     apply (simp add: join_memory_range)
    apply (simp add: join_memory_range snd_split_set)
   apply (simp add: join_memory_range)
  by (simp add: join_memory_range)

definition "get_from_rest x y m = the_elem (lv_getter y ` m)"

lemma get_from_rest:
  assumes "compatible_lvalues x y"
  assumes [simp]: "m \<in> lv_domain x"
  shows "get_from_rest x y (snd (split_memory x m)) = lv_getter y m"
proof -
  have "lv_getter y ` same_except x `` {m} = {lv_getter y m}"
    apply (rule apply_congruent)
    apply (metis assms(1) compatible_lvalues.simps compatible_lvalues_sym congruentI get_set_diff same_except.cases)
     apply (rule equiv_same_except)
    using assms compatible_valid1 apply blast
    by auto
  then show ?thesis
    unfolding get_from_rest_def split_memory_def by simp
qed

lemma split_pair_eq:
  fixes x y
  assumes [simp]: "compatible_lvalues x y"
  defines "xy \<equiv> lvalue_pair x y"
  assumes [simp]: "m1 \<in> lv_domain x"
  assumes [simp]: "m2 \<in> lv_domain x"
  shows "snd (split_memory x m1) = snd (split_memory x m2)
     \<longleftrightarrow> snd (split_memory xy m1) = snd (split_memory xy m2)
         \<and> lv_getter y m1 = lv_getter y m2"
proof -
  have [simp]: "valid_lvalue y"
    using assms(1) compatible_valid2 by blast
  have [simp]: "m1 \<in> lv_domain xy"
    by (simp add: xy_def)
  have [simp]: "m1 \<in> lv_domain y"
    by (metis assms(1) assms(3) compatible_lvalues.simps)
  have [simp]: "compatible_lvalues y x"
    using assms(1) compatible_lvalues_sym by blast
  have [simp]: "m2 \<in> lv_domain y"
    by (metis \<open>compatible_lvalues y x\<close> assms(4) compatible_lvalues.simps)
  have 1: "(m1, m2) \<in> same_except xy" if "(m1, m2) \<in> same_except x"
    using that
  proof cases
    case (1 a)
    have *: "m2 = lv_setter xy (a, lv_getter y m2) m1"
      unfolding xy_def by (auto simp flip: 1(1))
    show ?thesis
      apply (subst *)
      apply (rule same_except.intros)
       apply auto
      by (simp add: "1"(3) xy_def)
  qed

  have 2: "lv_getter y m1 = lv_getter y m2" if "(m1, m2) \<in> same_except x"
    using that
  proof cases
    case (1 a)
    show ?thesis
      apply (subst 1(1))
      apply (subst get_set_diff)
      using 1 by auto
  qed

  have 3: "(m1, m2) \<in> same_except x"
    if "(m1, m2) \<in> same_except xy" and "lv_getter y m1 = lv_getter y m2"
    using that(1)
  proof cases
    case (1 a)
    then obtain a1 a2 where a: "a=(a1,a2)" and [simp]: "a1 \<in> lv_range x"
      using xy_def by auto
    from 1(1) have "m2 = lv_setter y a2 (lv_setter x a1 m1)"
      unfolding a xy_def by simp
    also have "\<dots> = lv_setter y (lv_getter y m2) (lv_setter y a2 (lv_setter x a1 m1))"
      using \<open>m2 \<in> lv_domain y\<close> calculation by auto
    also have "\<dots> = lv_setter y (lv_getter y m2) (lv_setter x a1 m1)"
      by (metis "1"(3) \<open>m1 \<in> lv_domain y\<close> a assms(1) compatible_lvalues.simps get_range lvalue_pair_range mem_Sigma_iff set_domain set_set that(2) xy_def)
    also have "\<dots> = lv_setter y (lv_getter y m1) (lv_setter x a1 m1)"
      by (simp add: that(2))
    also have "\<dots> = lv_setter x a1 (lv_setter y (lv_getter y m1) m1)"
      by (simp add: compatible_swap_set)
    also have "\<dots> = lv_setter x a1 m1"
      by simp
    finally have *: "m2 = lv_setter x a1 m1"
      by -
    show ?thesis
      apply (subst *)
      apply (rule same_except.intros)
      by auto
  qed

  show ?thesis
    unfolding split_memory_def apply simp
    apply (subst eq_equiv_class_iff[OF equiv_same_except])
    using assms compatible_valid1 apply blast+
    apply (subst eq_equiv_class_iff[OF equiv_same_except])
       apply (simp_all add: xy_def)[3]
    using 1 2 3 by auto
qed

end