theory EnumInstance
  imports
    Main
    "Ecore-GROOVE-Mapping.Instance_Model_Graph_Mapping"
    EnumType
begin

section "Definition of an instance model which introduces values for an enumeration type"

definition imod_enum :: "'t Id \<Rightarrow> 't set \<Rightarrow> ('o, 't) instance_model" where
  "imod_enum name values = \<lparr>
    Tm = tmod_enum name values,
    Object = {},
    ObjectClass = (\<lambda>x. undefined),
    ObjectId = (\<lambda>x. undefined),
    FieldValue = (\<lambda>x. undefined),
    DefaultValue = (\<lambda>x. undefined)
  \<rparr>"

lemma imod_enum_correct: "instance_model (imod_enum name values)"
proof (intro imod_empty_any_type_model_correct)
  show "type_model (Tm (imod_enum name values))"
    unfolding imod_enum_def
    using tmod_enum_correct
    by simp
qed (simp_all add: imod_enum_def tmod_enum_def)

lemma imod_enum_combine_correct:
  assumes "instance_model Imod"
  assumes new_enum: "name \<notin> Class (Tm Imod) \<union> Enum (Tm Imod) \<union> UserDataType (Tm Imod)"
  assumes valid_identifier: "\<And>x. x \<in> Class (Tm Imod) \<union> Enum (Tm Imod) \<union> UserDataType (Tm Imod) \<Longrightarrow> \<not>id_in_ns name (Identifier x) \<and> \<not>id_in_ns x (Identifier name)"
  shows "instance_model (imod_combine Imod (imod_enum name values))"
proof (intro imod_combine_distinct_correct)
  show "instance_model (imod_enum name values)"
    by (fact imod_enum_correct)
next
  show "type_model (tmod_combine (Tm Imod) (Tm (imod_enum name values)))"
    unfolding imod_enum_def
    using assms instance_model.select_convs(1) instance_model.validity_type_model_consistent tmod_enum_combine_correct
    by metis
next
  show "Enum (Tm Imod) \<inter> Enum (Tm (imod_enum name values)) = {}"
    unfolding imod_enum_def tmod_enum_def
    using new_enum
    by simp
qed (simp_all add: assms imod_enum_def tmod_enum_def)

section "Encoding of an enumeration type as Node Type in GROOVE"

definition ig_enum_as_node_types :: "'t Id \<Rightarrow> 't set \<Rightarrow> ('t \<Rightarrow> 'o) \<Rightarrow> ('t \<Rightarrow> 't) \<Rightarrow> ('o, 't list, 't) instance_graph" where
  "ig_enum_as_node_types name values fob fid = \<lparr>
    TG = tg_enum_as_node_types name values,
    Id = fid ` values,
    N = (\<lambda>x. typed (type (id_to_list name @ [x])) (fob x)) ` values,
    E = {},
    ident = (\<lambda>x. if x \<in> fid ` values then typed (type (id_to_list name @ [(THE y. fid y = x)])) (fob (THE y. fid y = x)) else undefined)
  \<rparr>"

lemma ig_enum_as_node_types_correct:
  assumes unique_ids: "\<And>o1 o2. o1 \<in> values \<Longrightarrow> fid o1 = fid o2 \<Longrightarrow> o1 = o2"
  assumes unique_obs: "\<And>o1 o2. o1 \<in> values \<Longrightarrow> fob o1 = fob o2 \<Longrightarrow> o1 = o2"
  shows "instance_graph (ig_enum_as_node_types name values fob fid)"
proof (intro instance_graph.intro)
  fix n
  assume "n \<in> N (ig_enum_as_node_types name values fob fid)"
  then have "n \<in> (\<lambda>x. typed (type (id_to_list name @ [x])) (fob x)) ` values"
    unfolding ig_enum_as_node_types_def
    by simp
  then have "n \<in> Node\<^sub>t"
    using Lab\<^sub>t.rule_type_labels Node\<^sub>t.rule_typed_nodes
    by fastforce
  then show "n \<in> Node"
    unfolding Node_def
    by simp
next
  fix i
  assume "i \<in> Id (ig_enum_as_node_types name values fob fid)"
  then have i_in_id: "i \<in> fid ` values"
    unfolding ig_enum_as_node_types_def
    by simp
  then show "ident (ig_enum_as_node_types name values fob fid) i \<in> N (ig_enum_as_node_types name values fob fid) \<and> type\<^sub>n (ident (ig_enum_as_node_types name values fob fid) i) \<in> Lab\<^sub>t"
  proof (intro conjI)
    assume "i \<in> fid ` values"
    then have "(THE y. fid y = i) \<in> values"
    proof
      fix x
      assume i_def: "i = fid x"
      assume x_is_value: "x \<in> values"
      have "(THE y. fid y = fid x) \<in> values"
      proof (rule the1I2)
        show "\<exists>!y. fid y = fid x"
          using unique_ids x_is_value
          by metis
      next
        fix y
        assume "fid y = fid x"
        then show "y \<in> values"
          using unique_ids x_is_value
          by metis
      qed
      then show "(THE y. fid y = i) \<in> values"
        by (simp add: i_def)
    qed
    then have "typed (type (id_to_list name @ [(THE y. fid y = i)])) (fob (THE y. fid y = i)) \<in> (\<lambda>x. typed (type (id_to_list name @ [x])) (fob x)) ` values"
      by simp
    then show "ident (ig_enum_as_node_types name values fob fid) i \<in> N (ig_enum_as_node_types name values fob fid)"
      unfolding ig_enum_as_node_types_def
      using i_in_id
      by simp
  next
    have "type\<^sub>n (typed (type (id_to_list name @ [(THE y. fid y = i)])) (fob (THE y. fid y = i))) \<in> Lab\<^sub>t"
      by (simp add: Lab\<^sub>t.rule_type_labels)
    then show "type\<^sub>n (ident (ig_enum_as_node_types name values fob fid) i) \<in> Lab\<^sub>t"
      unfolding ig_enum_as_node_types_def
      using i_in_id
      by simp
  qed
next
  show "type_graph (TG (ig_enum_as_node_types name values fob fid))"
    unfolding ig_enum_as_node_types_def
    using tg_enum_as_node_types_correct
    by simp
next
  fix n
  assume "n \<in> N (ig_enum_as_node_types name values fob fid)"
  then have "n \<in> (\<lambda>x. typed (type (id_to_list name @ [x])) (fob x)) ` values"
    unfolding ig_enum_as_node_types_def
    by simp
  then have "type\<^sub>n n \<in> (\<lambda>x. type (id_to_list name @ [x])) ` values"
    by fastforce
  then have type_n_def: "type\<^sub>n n \<in> type ` append (id_to_list name) ` (\<lambda>x. [x]) ` values"
    by blast
  then show "type\<^sub>n n \<in> NT (TG (ig_enum_as_node_types name values fob fid))"
    unfolding ig_enum_as_node_types_def tg_enum_as_node_types_def
    by simp
  show "type\<^sub>n n \<notin> type_graph.abs (TG (ig_enum_as_node_types name values fob fid))"
    unfolding ig_enum_as_node_types_def tg_enum_as_node_types_def
    using type_n_def
    by fastforce
next
  fix p
  show "\<not>pre_digraph.cycle (instance_graph_containment_proj (ig_enum_as_node_types name values fob fid)) p"
    unfolding ig_enum_as_node_types_def instance_graph_containment_proj_def pre_digraph.cycle_def pre_digraph.awalk_def
    by simp
qed (simp_all add: assms ig_enum_as_node_types_def tg_enum_as_node_types_def)

lemma ig_enum_as_node_types_combine_correct:
  assumes "instance_graph IG"
  assumes new_enum_type: "type (id_to_list name) \<notin> NT (TG IG)"
  assumes new_value_types: "NT (TG IG) \<inter> type ` (@) (id_to_list name) ` (\<lambda>x. [x]) ` values = {}"
  assumes unique_ids: "\<And>o1 o2. o1 \<in> values \<Longrightarrow> fid o1 = fid o2 \<Longrightarrow> o1 = o2"
  assumes unique_obs: "\<And>o1 o2. o1 \<in> values \<Longrightarrow> fob o1 = fob o2 \<Longrightarrow> o1 = o2"
  assumes new_ids: "Id IG \<inter> fid ` values = {}"
  shows "instance_graph (ig_combine IG (ig_enum_as_node_types name values fob fid))"
proof (intro ig_combine_distinct_correct)
  show "instance_graph (ig_enum_as_node_types name values fob fid)"
    using unique_ids unique_obs
    by (fact ig_enum_as_node_types_correct)
next
  fix i
  assume "i \<in> Id IG"
  then have i_not_in_ids: "i \<notin> fid ` values"
    using new_ids
    by auto
  assume "i \<in> Id (ig_enum_as_node_types name values fob fid)"
  then have "i \<in> fid ` values"
    unfolding ig_enum_as_node_types_def
    by simp
  then show "ident IG i = ident (ig_enum_as_node_types name values fob fid) i"
    using i_not_in_ids
    by blast
qed (simp_all add: ig_enum_as_node_types_def tg_enum_as_node_types_def assms)

subsection "Transformation functions"

definition imod_enum_to_ig_enum_as_node_types :: "'t Id \<Rightarrow> 't set \<Rightarrow> ('t \<Rightarrow> 'o) \<Rightarrow> ('t \<Rightarrow> 't) \<Rightarrow> ('o, 't) instance_model \<Rightarrow> ('o, 't list, 't) instance_graph" where
  "imod_enum_to_ig_enum_as_node_types name values fob fid Imod = \<lparr>
    TG = tg_enum_as_node_types name values,
    Id = fid ` values,
    N = (\<lambda>x. typed (type (id_to_list name @ [x])) (fob x)) ` values,
    E = {},
    ident = (\<lambda>x. if x \<in> fid ` values then typed (type (id_to_list name @ [(THE y. fid y = x)])) (fob (THE y. fid y = x)) else undefined)
  \<rparr>"

lemma imod_enum_to_ig_enum_as_node_types_proj:
  shows "imod_enum_to_ig_enum_as_node_types name values fob fid (imod_enum name values) = ig_enum_as_node_types name values fob fid"
  unfolding imod_enum_to_ig_enum_as_node_types_def ig_enum_as_node_types_def imod_enum_def
  by simp

lemma imod_enum_to_ig_enum_as_node_types_func:
  shows "ig_combine_mapping_function (imod_enum_to_ig_enum_as_node_types name values fob fid) (imod_enum name values) (ig_enum_as_node_types name values fob fid)"
  by (intro ig_combine_mapping_function.intro)
    (auto simp add: imod_enum_to_ig_enum_as_node_types_def imod_enum_def ig_enum_as_node_types_def imod_combine_def)

definition ig_enum_as_node_types_to_imod_enum :: "'t Id \<Rightarrow> 't set \<Rightarrow> ('o, 't list, 't) instance_graph \<Rightarrow> ('o, 't) instance_model" where
  "ig_enum_as_node_types_to_imod_enum name values IG = \<lparr>
    Tm = tmod_enum name values,
    Object = {},
    ObjectClass = (\<lambda>x. undefined),
    ObjectId = (\<lambda>x. undefined),
    FieldValue = (\<lambda>x. undefined),
    DefaultValue = (\<lambda>x. undefined)
  \<rparr>"

lemma ig_enum_as_node_types_to_imod_enum_proj:
  shows "ig_enum_as_node_types_to_imod_enum name values (ig_enum_as_node_types name values fob fid) = imod_enum name values"
  unfolding ig_enum_as_node_types_to_imod_enum_def imod_enum_def ig_enum_as_node_types_def
  by simp

lemma ig_enum_as_node_types_to_imod_enum_func:
  shows "imod_combine_mapping_function (ig_enum_as_node_types_to_imod_enum name values) (ig_enum_as_node_types name values fob fid) (imod_enum name values)"
  by (intro imod_combine_mapping_function.intro)
    (simp_all add: ig_enum_as_node_types_to_imod_enum_def imod_enum_def ig_enum_as_node_types_def ig_combine_def)

section "Encoding of an enumeration type as flags in GROOVE"

definition ig_enum_as_flags :: "'t Id \<Rightarrow> 't set \<Rightarrow> ('t \<Rightarrow> 'o) \<Rightarrow> ('t \<Rightarrow> 't) \<Rightarrow> ('o, 't list, 't) instance_graph" where
  "ig_enum_as_flags name values fob fid = \<lparr>
    TG = tg_enum_as_flags name values,
    Id = fid ` values,
    N = typed (type (id_to_list name)) ` fob ` values,
    E = (\<lambda>x. (typed (type (id_to_list name)) (fob x), (type (id_to_list name), flag [x], type (id_to_list name)), typed (type (id_to_list name)) (fob x))) ` values,
    ident = (\<lambda>x. if x \<in> fid ` values then typed (type (id_to_list name)) (fob (THE y. fid y = x)) else undefined)
  \<rparr>"

lemma ig_enum_as_flags_correct:
  assumes unique_ids: "\<And>o1 o2. o1 \<in> values \<Longrightarrow> fid o1 = fid o2 \<Longrightarrow> o1 = o2"
  assumes unique_obs: "\<And>o1 o2. o1 \<in> values \<Longrightarrow> fob o1 = fob o2 \<Longrightarrow> o1 = o2"
  shows "instance_graph (ig_enum_as_flags name values fob fid)"
proof (intro instance_graph.intro)
  fix n
  assume "n \<in> N (ig_enum_as_flags name values fob fid)"
  then have "n \<in> typed (type (id_to_list name)) ` fob ` values"
    unfolding ig_enum_as_flags_def
    by simp
  then have "n \<in> Node\<^sub>t"
    using Lab\<^sub>t.rule_type_labels Node\<^sub>t.rule_typed_nodes
    by fastforce
  then show "n \<in> Node"
    unfolding Node_def
    by simp
next
  fix s l t
  assume "(s, l, t) \<in> E (ig_enum_as_flags name values fob fid)"
  then have edge_def: "(s, l, t) \<in> (\<lambda>x. (typed (type (id_to_list name)) (fob x), (type (id_to_list name), flag [x], type (id_to_list name)), typed (type (id_to_list name)) (fob x))) ` values"
    unfolding ig_enum_as_flags_def
    by simp
  then have "s \<in> typed (type (id_to_list name)) ` fob ` values \<and>
    l \<in> (\<lambda>x. (type (id_to_list name), x, type (id_to_list name))) ` flag ` (\<lambda>x. [x]) ` values \<and>
    t \<in> typed (type (id_to_list name)) ` fob ` values"
  proof (intro conjI)
    assume "(s, l, t) \<in> (\<lambda>x. (typed (type (id_to_list name)) (fob x), (type (id_to_list name), flag [x], type (id_to_list name)), typed (type (id_to_list name)) (fob x))) ` values"
    then show "s \<in> typed (LabDef.type (id_to_list name)) ` fob ` values"
      by fastforce
  next
    assume "(s, l, t) \<in> (\<lambda>x. (typed (type (id_to_list name)) (fob x), (type (id_to_list name), flag [x], type (id_to_list name)), typed (type (id_to_list name)) (fob x))) ` values"
    then show "l \<in> (\<lambda>x. (LabDef.type (id_to_list name), x, LabDef.type (id_to_list name))) ` flag ` (\<lambda>x. [x]) ` values"
      by fastforce
  next
    assume "(s, l, t) \<in> (\<lambda>x. (typed (type (id_to_list name)) (fob x), (type (id_to_list name), flag [x], type (id_to_list name)), typed (type (id_to_list name)) (fob x))) ` values"
    then show "t \<in> typed (LabDef.type (id_to_list name)) ` fob ` values"
      by fastforce
  qed
  then show "s \<in> N (ig_enum_as_flags name values fob fid) \<and>
    l \<in> ET (TG (ig_enum_as_flags name values fob fid)) \<and>
    t \<in> N (ig_enum_as_flags name values fob fid)"
    unfolding ig_enum_as_flags_def tg_enum_as_flags_def
    by simp
next
  fix i
  assume "i \<in> Id (ig_enum_as_flags name values fob fid)"
  then have i_in_id: "i \<in> fid ` values"
    unfolding ig_enum_as_flags_def
    by simp
  then show "ident (ig_enum_as_flags name values fob fid) i \<in> N (ig_enum_as_flags name values fob fid) \<and> type\<^sub>n (ident (ig_enum_as_flags name values fob fid) i) \<in> Lab\<^sub>t"
  proof (intro conjI)
    assume "i \<in> fid ` values"
    then have "(THE y. fid y = i) \<in> values"
    proof
      fix x
      assume i_def: "i = fid x"
      assume x_is_value: "x \<in> values"
      have "(THE y. fid y = fid x) \<in> values"
      proof (rule the1I2)
        show "\<exists>!y. fid y = fid x"
          using unique_ids x_is_value
          by metis
      next
        fix y
        assume "fid y = fid x"
        then show "y \<in> values"
          using unique_ids x_is_value
          by metis
      qed
      then show "(THE y. fid y = i) \<in> values"
        by (simp add: i_def)
    qed
    then have "typed (type (id_to_list name)) (fob (THE y. fid y = i)) \<in> typed (type (id_to_list name)) ` fob ` values"
      by simp
    then show "ident (ig_enum_as_flags name values fob fid) i \<in> N (ig_enum_as_flags name values fob fid)"
      unfolding ig_enum_as_flags_def
      using i_in_id
      by simp
  next
    have "type\<^sub>n (typed (type (id_to_list name)) (fob (THE y. fid y = i))) \<in> Lab\<^sub>t"
      by (simp add: Lab\<^sub>t.rule_type_labels)
    then show "type\<^sub>n (ident (ig_enum_as_flags name values fob fid) i) \<in> Lab\<^sub>t"
      unfolding ig_enum_as_flags_def
      using i_in_id
      by simp
  qed
next
  show "type_graph (TG (ig_enum_as_flags name values fob fid))"
    unfolding ig_enum_as_flags_def
    using tg_enum_as_flags_correct
    by simp
next
  fix e
  assume "e \<in> E (ig_enum_as_flags name values fob fid)"
  then have e_def: "e \<in> (\<lambda>x. (typed (type (id_to_list name)) (fob x), (type (id_to_list name), flag [x], type (id_to_list name)), typed (type (id_to_list name)) (fob x))) ` values"
    unfolding ig_enum_as_flags_def
    by simp
  have type_n_def: "type\<^sub>n (src e) = type (id_to_list name)"
    using e_def
    by fastforce
  have type_e_def: "src (type\<^sub>e e) = type (id_to_list name)"
    using e_def
    by fastforce
  show "(type\<^sub>n (src e), src (type\<^sub>e e)) \<in> inh (TG (ig_enum_as_flags name values fob fid))"
    unfolding ig_enum_as_flags_def tg_enum_as_flags_def
    using type_n_def type_e_def
    by simp
next
  fix e
  assume "e \<in> E (ig_enum_as_flags name values fob fid)"
  then have e_def: "e \<in> (\<lambda>x. (typed (type (id_to_list name)) (fob x), (type (id_to_list name), flag [x], type (id_to_list name)), typed (type (id_to_list name)) (fob x))) ` values"
    unfolding ig_enum_as_flags_def
    by simp
  have type_n_def: "type\<^sub>n (tgt e) = type (id_to_list name)"
    using e_def
    by fastforce
  have type_e_def: "tgt (type\<^sub>e e) = type (id_to_list name)"
    using e_def
    by fastforce
  show "(type\<^sub>n (tgt e), tgt (type\<^sub>e e)) \<in> inh (TG (ig_enum_as_flags name values fob fid))"
    unfolding ig_enum_as_flags_def tg_enum_as_flags_def
    using type_n_def type_e_def
    by simp
next
  fix n
  assume "n \<in> N (ig_enum_as_flags name values fob fid)"
  then have "n \<in> typed (type (id_to_list name)) ` fob ` values"
    unfolding ig_enum_as_flags_def
    by simp
  then have "type\<^sub>n n = type (id_to_list name)"
    by fastforce
  then show "type\<^sub>n n \<in> NT (TG (ig_enum_as_flags name values fob fid))"
    unfolding ig_enum_as_flags_def tg_enum_as_flags_def
    by simp
next
  fix et n
  assume "et \<in> ET (TG (ig_enum_as_flags name values fob fid))"
  then have et_def: "et \<in> (\<lambda>x. (type (id_to_list name), x, type (id_to_list name))) ` flag ` (\<lambda>x. [x]) ` values"
    unfolding ig_enum_as_flags_def tg_enum_as_flags_def
    by simp
  then have mult_def: "m_out (mult (TG (ig_enum_as_flags name values fob fid)) et) = \<^bold>0..\<^bold>1"
    unfolding ig_enum_as_flags_def tg_enum_as_flags_def
    by simp
  assume "n \<in> N (ig_enum_as_flags name values fob fid)"
  then have n_def: "n \<in> typed (type (id_to_list name)) ` fob ` values"
    unfolding ig_enum_as_flags_def
    by simp
  assume "(type\<^sub>n n, src et) \<in> inh (TG (ig_enum_as_flags name values fob fid))"
  then have inh_def: "type\<^sub>n n = type (id_to_list name) \<and> src et = type (id_to_list name)"
    unfolding ig_enum_as_flags_def tg_enum_as_flags_def
    by simp
  have "card {e \<in> E (ig_enum_as_flags name values fob fid). src e = n \<and> type\<^sub>e e = et} in \<^bold>0..\<^bold>1"
    using et_def n_def
  proof (elim imageE)
    fix x1 x2 x3 y1 y2
    assume x1_def: "x1 \<in> values"
    assume x2_def: "x2 = [x1]"
    assume "x3 = flag x2"
    then have x3_def: "x3 = flag [x1]"
      by (simp add: x2_def)
    assume "et = (type (id_to_list name), x3, type (id_to_list name))"
    then have et_def: "et = (type (id_to_list name), flag [x1], type (id_to_list name))"
      by (simp add: x3_def)
    assume y1_def: "y1 \<in> values"
    assume y2_def: "y2 = fob y1"
    assume "n = typed (type (id_to_list name)) y2"
    then have n_def: "n = typed (type (id_to_list name)) (fob y1)"
      by (simp add: y2_def)
    show ?thesis
    proof (induct "x1 = y1")
      case True
      then have n_def: "n = typed (type (id_to_list name)) (fob x1)"
        using n_def
        by simp
      have "{e \<in> E (ig_enum_as_flags name values fob fid). src e = n \<and> type\<^sub>e e = et} =
        {(typed (type (id_to_list name)) (fob x1), (type (id_to_list name), flag [x1], type (id_to_list name)), typed (type (id_to_list name)) (fob x1))}"
      proof
        show "{e \<in> E (ig_enum_as_flags name values fob fid). src e = n \<and> type\<^sub>e e = et} \<subseteq>
          {(typed (type (id_to_list name)) (fob x1), (type (id_to_list name), flag [x1], type (id_to_list name)), typed (type (id_to_list name)) (fob x1))}"
        proof
          fix x
          assume "x \<in> {e \<in> E (ig_enum_as_flags name values fob fid). src e = n \<and> type\<^sub>e e = et}"
          then show "x \<in> {(typed (type (id_to_list name)) (fob x1), (type (id_to_list name), flag [x1], type (id_to_list name)), typed (type (id_to_list name)) (fob x1))}"
          proof
            assume "x \<in> E (ig_enum_as_flags name values fob fid) \<and> src x = n \<and> type\<^sub>e x = et"
            then show "x \<in> {(typed (type (id_to_list name)) (fob x1), (type (id_to_list name), flag [x1], type (id_to_list name)), typed (type (id_to_list name)) (fob x1))}"
              unfolding ig_enum_as_flags_def
              using et_def n_def x1_def
              by fastforce
          qed
        qed
      next
        show "{(typed (type (id_to_list name)) (fob x1), (type (id_to_list name), flag [x1], type (id_to_list name)), typed (type (id_to_list name)) (fob x1))} \<subseteq>
          {e \<in> E (ig_enum_as_flags name values fob fid). src e = n \<and> type\<^sub>e e = et}"
        proof
          fix x
          assume "x \<in> {(typed (type (id_to_list name)) (fob x1), (type (id_to_list name), flag [x1], type (id_to_list name)), typed (type (id_to_list name)) (fob x1))}"
          then show "x \<in> {e \<in> E (ig_enum_as_flags name values fob fid). src e = n \<and> type\<^sub>e e = et}"
            unfolding ig_enum_as_flags_def
            using et_def n_def x1_def
            by simp
        qed
      qed
      then have "card {e \<in> E (ig_enum_as_flags name values fob fid). src e = n \<and> type\<^sub>e e = et} = 1"
        by simp
      then show ?case
        unfolding within_multiplicity_def
        by simp
    next
      case False
      then have "{e \<in> E (ig_enum_as_flags name values fob fid). src e = n \<and> type\<^sub>e e = et} = {}"
        unfolding ig_enum_as_flags_def
        using n_def et_def unique_obs
        by fastforce
      then have "card {e \<in> E (ig_enum_as_flags name values fob fid). src e = n \<and> type\<^sub>e e = et} = 0"
        using card_empty
        by metis
      then show ?case
        unfolding within_multiplicity_def
        by simp
    qed
  qed
  then show "card {e \<in> E (ig_enum_as_flags name values fob fid). src e = n \<and> type\<^sub>e e = et} in
    m_out (mult (TG (ig_enum_as_flags name values fob fid)) et)"
    using mult_def
    by simp
next
  fix et n
  assume "et \<in> ET (TG (ig_enum_as_flags name values fob fid))"
  then have et_def: "et \<in> (\<lambda>x. (type (id_to_list name), x, type (id_to_list name))) ` flag ` (\<lambda>x. [x]) ` values"
    unfolding ig_enum_as_flags_def tg_enum_as_flags_def
    by simp
  then have mult_def: "m_in (mult (TG (ig_enum_as_flags name values fob fid)) et) = \<^bold>0..\<^bold>1"
    unfolding ig_enum_as_flags_def tg_enum_as_flags_def
    by simp
  assume "n \<in> N (ig_enum_as_flags name values fob fid)"
  then have n_def: "n \<in> typed (type (id_to_list name)) ` fob ` values"
    unfolding ig_enum_as_flags_def
    by simp
  assume "(type\<^sub>n n, tgt et) \<in> inh (TG (ig_enum_as_flags name values fob fid))"
  then have inh_def: "type\<^sub>n n = type (id_to_list name) \<and> tgt et = type (id_to_list name)"
    unfolding ig_enum_as_flags_def tg_enum_as_flags_def
    by simp
  have "card {e \<in> E (ig_enum_as_flags name values fob fid). tgt e = n \<and> type\<^sub>e e = et} in \<^bold>0..\<^bold>1"
    using et_def n_def
  proof (elim imageE)
    fix x1 x2 x3 y1 y2
    assume x1_def: "x1 \<in> values"
    assume x2_def: "x2 = [x1]"
    assume "x3 = flag x2"
    then have x3_def: "x3 = flag [x1]"
      by (simp add: x2_def)
    assume "et = (type (id_to_list name), x3, type (id_to_list name))"
    then have et_def: "et = (type (id_to_list name), flag [x1], type (id_to_list name))"
      by (simp add: x3_def)
    assume y1_def: "y1 \<in> values"
    assume y2_def: "y2 = fob y1"
    assume "n = typed (type (id_to_list name)) y2"
    then have n_def: "n = typed (type (id_to_list name)) (fob y1)"
      by (simp add: y2_def)
    show ?thesis
    proof (induct "x1 = y1")
      case True
      then have n_def: "n = typed (type (id_to_list name)) (fob x1)"
        using n_def
        by simp
      have "{e \<in> E (ig_enum_as_flags name values fob fid). tgt e = n \<and> type\<^sub>e e = et} =
        {(typed (type (id_to_list name)) (fob x1), (type (id_to_list name), flag [x1], type (id_to_list name)), typed (type (id_to_list name)) (fob x1))}"
      proof
        show "{e \<in> E (ig_enum_as_flags name values fob fid). tgt e = n \<and> type\<^sub>e e = et} \<subseteq>
          {(typed (type (id_to_list name)) (fob x1), (type (id_to_list name), flag [x1], type (id_to_list name)), typed (type (id_to_list name)) (fob x1))}"
        proof
          fix x
          assume "x \<in> {e \<in> E (ig_enum_as_flags name values fob fid). tgt e = n \<and> type\<^sub>e e = et}"
          then show "x \<in> {(typed (type (id_to_list name)) (fob x1), (type (id_to_list name), flag [x1], type (id_to_list name)), typed (type (id_to_list name)) (fob x1))}"
          proof
            assume "x \<in> E (ig_enum_as_flags name values fob fid) \<and> tgt x = n \<and> type\<^sub>e x = et"
            then show "x \<in> {(typed (type (id_to_list name)) (fob x1), (type (id_to_list name), flag [x1], type (id_to_list name)), typed (type (id_to_list name)) (fob x1))}"
              unfolding ig_enum_as_flags_def
              using et_def n_def x1_def
              by fastforce
          qed
        qed
      next
        show "{(typed (type (id_to_list name)) (fob x1), (type (id_to_list name), flag [x1], type (id_to_list name)), typed (type (id_to_list name)) (fob x1))} \<subseteq>
          {e \<in> E (ig_enum_as_flags name values fob fid). tgt e = n \<and> type\<^sub>e e = et}"
        proof
          fix x
          assume "x \<in> {(typed (type (id_to_list name)) (fob x1), (type (id_to_list name), flag [x1], type (id_to_list name)), typed (type (id_to_list name)) (fob x1))}"
          then show "x \<in> {e \<in> E (ig_enum_as_flags name values fob fid). tgt e = n \<and> type\<^sub>e e = et}"
            unfolding ig_enum_as_flags_def
            using et_def n_def x1_def
            by simp
        qed
      qed
      then have "card {e \<in> E (ig_enum_as_flags name values fob fid). tgt e = n \<and> type\<^sub>e e = et} = 1"
        by simp
      then show ?case
        unfolding within_multiplicity_def
        by simp
    next
      case False
      then have "{e \<in> E (ig_enum_as_flags name values fob fid). tgt e = n \<and> type\<^sub>e e = et} = {}"
        unfolding ig_enum_as_flags_def
        using n_def et_def unique_obs
        by fastforce
      then have "card {e \<in> E (ig_enum_as_flags name values fob fid). tgt e = n \<and> type\<^sub>e e = et} = 0"
        using card_empty
        by metis
      then show ?case
        unfolding within_multiplicity_def
        by simp
    qed
  qed
  then show "card {e \<in> E (ig_enum_as_flags name values fob fid). tgt e = n \<and> type\<^sub>e e = et} in
    m_in (mult (TG (ig_enum_as_flags name values fob fid)) et)"
    using mult_def
    by simp
next
  fix p
  show "\<not>pre_digraph.cycle (instance_graph_containment_proj (ig_enum_as_flags name values fob fid)) p"
    unfolding ig_enum_as_flags_def tg_enum_as_flags_def instance_graph_containment_proj_def
    unfolding pre_digraph.cycle_def pre_digraph.awalk_def
    by simp
qed (simp_all add: assms ig_enum_as_flags_def tg_enum_as_flags_def)

lemma ig_enum_as_flags_combine_correct:
  assumes "instance_graph IG"
  assumes new_enum_type: "type (id_to_list name) \<notin> NT (TG IG)"
  assumes new_value_types: "NT (TG IG) \<inter> type ` (@) (id_to_list name) ` (\<lambda>x. [x]) ` values = {}"
  assumes unique_ids: "\<And>o1 o2. o1 \<in> values \<Longrightarrow> fid o1 = fid o2 \<Longrightarrow> o1 = o2"
  assumes unique_obs: "\<And>o1 o2. o1 \<in> values \<Longrightarrow> fob o1 = fob o2 \<Longrightarrow> o1 = o2"
  assumes new_ids: "Id IG \<inter> fid ` values = {}"
  shows "instance_graph (ig_combine IG (ig_enum_as_flags name values fob fid))"
proof (intro ig_combine_distinct_correct)
  show "instance_graph (ig_enum_as_flags name values fob fid)"
    using unique_ids unique_obs
    by (fact ig_enum_as_flags_correct)
next
  fix i
  assume "i \<in> Id IG"
  then have i_not_in_ids: "i \<notin> fid ` values"
    using new_ids
    by auto
  assume "i \<in> Id (ig_enum_as_flags name values fob fid)"
  then have "i \<in> fid ` values"
    unfolding ig_enum_as_flags_def
    by simp
  then show "ident IG i = ident (ig_enum_as_flags name values fob fid) i"
    using i_not_in_ids
    by blast
qed (simp_all add: ig_enum_as_flags_def tg_enum_as_flags_def assms)

subsection "Transformation functions"

definition imod_enum_to_ig_enum_as_flags :: "'t Id \<Rightarrow> 't set \<Rightarrow> ('t \<Rightarrow> 'o) \<Rightarrow> ('t \<Rightarrow> 't) \<Rightarrow> ('o, 't) instance_model \<Rightarrow> ('o, 't list, 't) instance_graph" where
  "imod_enum_to_ig_enum_as_flags name values fob fid Imod = \<lparr>
    TG = tg_enum_as_flags name values,
    Id = fid ` values,
    N = typed (type (id_to_list name)) ` fob ` values,
    E = (\<lambda>x. (typed (type (id_to_list name)) (fob x), (type (id_to_list name), flag [x], type (id_to_list name)), typed (type (id_to_list name)) (fob x))) ` values,
    ident = (\<lambda>x. if x \<in> fid ` values then typed (type (id_to_list name)) (fob (THE y. fid y = x)) else undefined)
  \<rparr>"

lemma imod_enum_to_ig_enum_as_flags_proj:
  shows "imod_enum_to_ig_enum_as_flags name values fob fid (imod_enum name values) = ig_enum_as_flags name values fob fid"
  unfolding imod_enum_to_ig_enum_as_flags_def ig_enum_as_flags_def imod_enum_def
  by simp

lemma imod_enum_to_ig_enum_as_flags_func:
  shows "ig_combine_mapping_function (imod_enum_to_ig_enum_as_flags name values fob fid) (imod_enum name values) (ig_enum_as_flags name values fob fid)"
  by (intro ig_combine_mapping_function.intro)
    (auto simp add: imod_enum_to_ig_enum_as_flags_def imod_enum_def ig_enum_as_flags_def imod_combine_def)

definition ig_enum_as_flags_to_imod_enum :: "'t Id \<Rightarrow> 't set \<Rightarrow> ('o, 't list, 't) instance_graph \<Rightarrow> ('o, 't) instance_model" where
  "ig_enum_as_flags_to_imod_enum name values IG = \<lparr>
    Tm = tmod_enum name values,
    Object = {},
    ObjectClass = (\<lambda>x. undefined),
    ObjectId = (\<lambda>x. undefined),
    FieldValue = (\<lambda>x. undefined),
    DefaultValue = (\<lambda>x. undefined)
  \<rparr>"

lemma ig_enum_as_flags_to_imod_enum_proj:
  shows "ig_enum_as_flags_to_imod_enum name values (ig_enum_as_flags name values fob fid) = imod_enum name values"
  unfolding ig_enum_as_flags_to_imod_enum_def imod_enum_def ig_enum_as_flags_def
  by simp

lemma ig_enum_as_flags_to_imod_enum_func:
  shows "imod_combine_mapping_function (ig_enum_as_flags_to_imod_enum name values) (ig_enum_as_flags name values fob fid) (imod_enum name values)"
  by (intro imod_combine_mapping_function.intro)
    (simp_all add: ig_enum_as_flags_to_imod_enum_def imod_enum_def ig_enum_as_flags_def ig_combine_def)

end


(*
    Author:      Sebastiaan Joosten
                 René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Algebraic Numbers -- Preliminary Implementation\<close>

text \<open>This theory gathers some preliminary results to implement algebraic numbers,
  e.g., it defines an invariant to have unique representing polynomials and shows
  that polynomials for unary minus and inversion preserve this invariant.\<close>

theory Algebraic_Numbers_Pre_Impl
imports
  "Abstract-Rewriting.SN_Order_Carrier"
  Deriving.Compare_Rat
  Deriving.Compare_Real
  Jordan_Normal_Form.Gauss_Jordan_IArray_Impl
  Algebraic_Numbers
  Sturm_Rat
  Factors_of_Int_Poly
  Min_Int_Poly
begin

text \<open>For algebraic numbers, it turned out that @{const gcd_int_poly} is not
  preferable to the default implementation of @{const gcd}, which just implements
  Collin's primitive remainder sequence.\<close>
declare gcd_int_poly_code[code_unfold del]

(*TODO: move *)
lemma ex1_imp_Collect_singleton: "(\<exists>!x. P x) \<and> P x \<longleftrightarrow> Collect P = {x}"
proof(intro iffI conjI, unfold conj_imp_eq_imp_imp)
  assume "Ex1 P" "P x" then show "Collect P = {x}" by blast
next
  assume Px: "Collect P = {x}"
  then have "P y \<longleftrightarrow> x = y" for y by auto
  then show "Ex1 P" by auto
  from Px show "P x" by auto
qed

lemma ex1_Collect_singleton[consumes 2]:
  assumes "\<exists>!x. P x" and "P x" and "Collect P = {x} \<Longrightarrow> thesis" shows thesis
  by (rule assms(3), subst ex1_imp_Collect_singleton[symmetric], insert assms(1,2), auto)

lemma ex1_iff_Collect_singleton: "P x \<Longrightarrow> (\<exists>!x. P x) \<longleftrightarrow> Collect P = {x}"
  by (subst ex1_imp_Collect_singleton[symmetric], auto)

context
  fixes f
  assumes bij: "bij f"
begin
lemma bij_imp_ex1_iff: "(\<exists>!x. P (f x)) \<longleftrightarrow> (\<exists>!y. P y)" (is "?l = ?r")
proof (intro iffI)
  assume l: ?l
  then obtain x where "P (f x)" by auto
  with l have *: "{x} = Collect (P o f)" by auto
  also have "f ` \<dots> = {y. P (f (Hilbert_Choice.inv f y))}" using bij_image_Collect_eq[OF bij] by auto
  also have "\<dots> = {y. P y}"
  proof-
    have "f (Hilbert_Choice.inv f y) = y" for y by (meson bij bij_inv_eq_iff)
    then show ?thesis by simp
  qed
  finally have "Collect P = {f x}" by auto
  then show ?r by (fold ex1_imp_Collect_singleton, auto)
next
  assume r: ?r
  then obtain y where "P y" by auto
  with r have "{y} = Collect P" by auto
  also have "Hilbert_Choice.inv f ` \<dots> = Collect (P \<circ> f)"
    using bij_image_Collect_eq[OF bij_imp_bij_inv[OF bij]] bij by (auto simp: inv_inv_eq)
  finally have "Collect (P o f) = {Hilbert_Choice.inv f y}" by (simp add: o_def)
  then show ?l by (fold ex1_imp_Collect_singleton, auto)
qed

lemma bij_ex1_imp_the_shift:
  assumes ex1: "\<exists>!y. P y" shows "(THE x. P (f x)) = Hilbert_Choice.inv f (THE y. P y)" (is "?l = ?r")
proof-
  from ex1 have "P (THE y. P y)" by (rule the1I2)
  moreover from ex1[folded bij_imp_ex1_iff] have "P (f (THE x. P (f x)))" by (rule the1I2)
  ultimately have "(THE y. P y) = f (THE x. P (f x))" using ex1 by auto
  also have "Hilbert_Choice.inv f \<dots> = (THE x. P (f x))" using bij by (simp add: bij_is_inj)
  finally show "?l = ?r" by auto
qed

lemma bij_imp_Collect_image: "{x. P (f x)} = Hilbert_Choice.inv f ` {y. P y}" (is "?l = ?g ` _")
proof-
  have "?l = ?g ` f ` ?l" by (simp add: image_comp inv_o_cancel[OF bij_is_inj[OF bij]])
  also have "f ` ?l = {f x | x. P (f x)}" by auto
  also have "\<dots> = {y. P y}" by (metis bij bij_iff)
  finally show ?thesis.
qed

lemma bij_imp_card_image: "card (f ` X) = card X"
  by (metis bij bij_iff card.infinite finite_imageD inj_onI inj_on_iff_eq_card)

end

definition poly_cond :: "int poly \<Rightarrow> bool" where
  "poly_cond p = (lead_coeff p > 0 \<and> irreducible p)"

lemma poly_condI[intro]:
  assumes "lead_coeff p > 0" and "irreducible p" shows "poly_cond p" using assms by (auto simp: poly_cond_def)

lemma poly_condD:
  assumes "poly_cond p"
  shows "irreducible p" and "lead_coeff p > 0" and "root_free p" and "square_free p" and "p \<noteq> 0"
  using assms unfolding poly_cond_def using irreducible_root_free irreducible_imp_square_free cf_pos_def by auto

lemma poly_condE[elim]:
  assumes "poly_cond p"
      and "irreducible p \<Longrightarrow> lead_coeff p > 0 \<Longrightarrow> root_free p \<Longrightarrow> square_free p \<Longrightarrow> p \<noteq> 0 \<Longrightarrow> thesis"
  shows thesis
  using assms by (auto dest:poly_condD)

lemma poly_cond_abs_int_poly[simp]: "irreducible p \<Longrightarrow> poly_cond (abs_int_poly p)"
  unfolding poly_cond_def by (cases "p = 0", auto)

definition poly_uminus_abs :: "int poly \<Rightarrow> int poly" where
  "poly_uminus_abs p = abs_int_poly (poly_uminus p)"

lemma irreducible_poly_uminus[simp]: "irreducible p \<Longrightarrow> irreducible (poly_uminus (p :: int poly))"
proof (cases "degree p = 0")
  case True
  from degree0_coeffs[OF this]
  obtain a where p: "p = [:a:]" by auto
  have "poly_uminus p = p" unfolding p by (cases "a = 0", auto)
  thus "irreducible p \<Longrightarrow> irreducible (poly_uminus p)" by auto
next
  case False
  from poly_uminus_irreducible[OF _ this]
  show "irreducible p \<Longrightarrow> irreducible (poly_uminus p)" .
qed

lemma irreducible_poly_uminus_abs[simp]: "irreducible p \<Longrightarrow> irreducible (poly_uminus_abs p)"
  unfolding poly_uminus_abs_def using irreducible_poly_uminus[of p] by auto

lemma poly_cond_poly_uminus_abs[simp]: "poly_cond p \<Longrightarrow> poly_cond (poly_uminus_abs p)"
  by (auto simp: poly_cond_def, unfold poly_uminus_abs_def, subst pos_poly_abs_poly, auto)

lemma ipoly_poly_uminus_abs_zero[simp]: "ipoly (poly_uminus_abs p) (x :: 'a :: idom) = 0 \<longleftrightarrow> ipoly p (-x) = 0"
  unfolding poly_uminus_abs_def by simp

lemma degree_poly_uminus_abs[simp]: "degree (poly_uminus_abs p) = degree p"
  unfolding poly_uminus_abs_def by auto

definition poly_inverse :: "int poly \<Rightarrow> int poly" where
  "poly_inverse p = abs_int_poly (reflect_poly p)"

lemma irreducible_poly_inverse[simp]: "coeff p 0 \<noteq> 0 \<Longrightarrow> irreducible p \<Longrightarrow> irreducible (poly_inverse p)"
  unfolding poly_inverse_def by (auto simp: irreducible_reflect_poly)

lemma degree_poly_inverse[simp]: "coeff p 0 \<noteq> 0 \<Longrightarrow> degree (poly_inverse p) = degree p"
  unfolding poly_inverse_def by auto

lemma ipoly_poly_inverse[simp]: assumes "coeff p 0 \<noteq> 0"
  shows "ipoly (poly_inverse p) (x :: 'a :: field_char_0) = 0 \<longleftrightarrow> ipoly p (inverse x) = 0"
  unfolding poly_inverse_def ipoly_abs_int_poly_eq_zero_iff
proof (cases "x = 0")
  case False
  thus "(ipoly (reflect_poly p) x = 0) = (ipoly p (inverse x) = 0)"
    by (subst ipoly_reflect_poly, auto)
next
  case True
  show "(ipoly (reflect_poly p) x = 0) = (ipoly p (inverse x) = 0)" unfolding True using assms by (auto simp: poly_0_coeff_0)
qed

lemma ipoly_roots_finite: "p \<noteq> 0 \<Longrightarrow> finite {x :: 'a :: {idom, ring_char_0}. ipoly p x = 0}"
  by (rule poly_roots_finite, simp)

lemma root_sign_change: assumes
    p0: "poly (p::real poly) x = 0" and
    pd_ne0: "poly (pderiv p) x \<noteq> 0"
  obtains d where
    "0 < d"
    "sgn (poly p (x - d)) \<noteq> sgn (poly p (x + d))"
    "sgn (poly p (x - d)) \<noteq> 0"
    "0 \<noteq> sgn (poly p (x + d))"
    "\<forall> d' > 0. d' \<le> d \<longrightarrow> sgn (poly p (x + d')) = sgn (poly p (x + d)) \<and> sgn (poly p (x - d')) = sgn (poly p (x - d))"
proof -
  assume a:"(\<And>d. 0 < d \<Longrightarrow>
          sgn (poly p (x - d)) \<noteq> sgn (poly p (x + d)) \<Longrightarrow>
          sgn (poly p (x - d)) \<noteq> 0 \<Longrightarrow>
          0 \<noteq> sgn (poly p (x + d)) \<Longrightarrow>
          \<forall>d'>0. d' \<le> d \<longrightarrow>
                 sgn (poly p (x + d')) = sgn (poly p (x + d)) \<and> sgn (poly p (x - d')) = sgn (poly p (x - d)) \<Longrightarrow>
          thesis)"
  from pd_ne0 consider "poly (pderiv p) x > 0" | "poly (pderiv p) x < 0" by linarith
  thus ?thesis proof(cases)
    case 1
    obtain d1 where d1:"\<And>h. 0<h \<Longrightarrow> h < d1 \<Longrightarrow> poly p (x - h) < 0" "d1 > 0"
      using DERIV_pos_inc_left[OF poly_DERIV 1] p0 by auto
    obtain d2 where d2:"\<And>h. 0<h \<Longrightarrow> h < d2 \<Longrightarrow> poly p (x + h) > 0" "d2 > 0"
      using DERIV_pos_inc_right[OF poly_DERIV 1] p0 by auto
    have g0:"0 < (min d1 d2) / 2" using d1 d2 by auto
    hence m1:"min d1 d2 / 2 < d1" and m2:"min d1 d2 / 2 < d2" by auto
    { fix d
      assume a1:"0 < d" and a2:"d < min d1 d2"
      have "sgn (poly p (x - d)) = -1" "sgn (poly p (x + d)) = 1"
        using d1(1)[OF a1] d2(1)[OF a1] a2 by auto
    } note d=this
    show ?thesis by(rule a[OF g0];insert d g0 m1 m2, simp)
  next
    case 2
    obtain d1 where d1:"\<And>h. 0<h \<Longrightarrow> h < d1 \<Longrightarrow> poly p (x - h) > 0" "d1 > 0"
      using DERIV_neg_dec_left[OF poly_DERIV 2] p0 by auto
    obtain d2 where d2:"\<And>h. 0<h \<Longrightarrow> h < d2 \<Longrightarrow> poly p (x + h) < 0" "d2 > 0"
      using DERIV_neg_dec_right[OF poly_DERIV 2] p0 by auto
    have g0:"0 < (min d1 d2) / 2" using d1 d2 by auto
    hence m1:"min d1 d2 / 2 < d1" and m2:"min d1 d2 / 2 < d2" by auto
    { fix d
      assume a1:"0 < d" and a2:"d < min d1 d2"
      have "sgn (poly p (x - d)) = 1" "sgn (poly p (x + d)) = -1"
        using d1(1)[OF a1] d2(1)[OF a1] a2 by auto
    } note d=this
    show ?thesis by(rule a[OF g0];insert d g0 m1 m2, simp)
  qed
qed

lemma gt_rat_sign_change_square_free:
  assumes ur: "\<exists>! x. root_cond plr x"
    and plr[simp]: "plr = (p,l,r)"
    and sf: "square_free p" and in_interval: "l \<le> y" "y \<le> r"
    and py0: "ipoly p y \<noteq> 0" and pr0: "ipoly p r \<noteq> 0"
  shows "(sgn (ipoly p y) = sgn (ipoly p r)) = (of_rat y > (THE x. root_cond plr x))" (is "?gt = _")
proof (rule ccontr)
  define ur where "ur = (THE x. root_cond plr x)"
  assume "\<not> ?thesis"
  hence "?gt \<noteq> (real_of_rat y > ur)" unfolding ur_def by auto
  note a = this[unfolded plr]
  from py0 have "p \<noteq> 0" unfolding irreducible_def by auto
  hence p0_real: "real_of_int_poly p \<noteq> (0::real poly)" by auto
  let ?p = "real_of_int_poly p"
  let ?r = real_of_rat
  from in_interval have in':"?r l \<le> ?r y" "?r y \<le> ?r r" unfolding of_rat_less_eq by auto
  from sf square_free_of_int_poly[of p] square_free_rsquarefree
  have rsf:"rsquarefree ?p" by auto
  from ur have "root_cond plr ur" by (metis ur_def theI')
  note urD = this[unfolded root_cond_def plr split] this[unfolded plr]
  have ur3:"poly ?p ur = 0" using urD by auto
  from urD have "ur \<le> of_rat r" by auto
  moreover
  from pr0 have "ipoly p (real_of_rat r) \<noteq> 0" by auto
  with ur3 have "real_of_rat r \<noteq> ur" by force
  ultimately have "ur < ?r r" by auto
  hence ur2: "0 < ?r r - ur" by linarith
  from rsquarefree_roots rsf ur3
  have pd_nonz:"poly (pderiv ?p) ur \<noteq> 0" by auto
  obtain d where d':"\<And>d'. d'>0 \<Longrightarrow> d' \<le> d \<Longrightarrow>
             sgn (poly ?p (ur + d')) = sgn (poly ?p (ur + d)) \<and>
             sgn (poly ?p (ur - d')) = sgn (poly ?p (ur - d))"
    "sgn (poly ?p (ur - d)) \<noteq> sgn (poly ?p (ur + d))"
    "sgn (poly ?p (ur + d)) \<noteq> 0"
    and d_ge_0:"d > 0"
    by (metis root_sign_change[OF ur3 pd_nonz])
  have sr:"sgn (poly ?p (ur + d)) = sgn (poly ?p (?r r))"
  proof (cases "?r r - ur \<le> d")
    case True show ?thesis using d'(1)[OF ur2 True] by auto
  next
    case False hence less:"ur + d < ?r r" by auto
    show ?thesis
    proof(rule no_roots_inbetween_imp_same_sign[OF less,rule_format],goal_cases)
      case (1 x)
      from ur 1 d_ge_0 have ran: "real_of_rat l \<le> x" "x \<le> real_of_rat r" using urD by auto
      from 1 d_ge_0 have "ur \<noteq> x" by auto
      with ur urD have "\<not> root_cond (p,l,r) x" by (auto simp: root_cond_def)
      with ran show ?case by (auto simp: root_cond_def)
    qed
  qed
  consider "?r l < ur - d" "?r l < ur" | "0 < ur - ?r l" "ur - ?r l \<le> d" | "ur = ?r l"
    using urD by argo
  hence sl:"sgn (poly ?p (ur - d)) = sgn (poly ?p (?r l)) \<or> 0 = sgn (poly ?p (?r l))"
  proof (cases)
    case 1
    have "sgn (poly ?p (?r l)) = sgn (poly ?p (ur - d))"
    proof(rule no_roots_inbetween_imp_same_sign[OF 1(1),rule_format],goal_cases)
      case (1 x)
      from ur 1 d_ge_0 urD have ran: "real_of_rat l \<le> x" "x \<le> real_of_rat r" by auto
      from 1 d_ge_0 have "ur \<noteq> x" by auto
      with ur urD have "\<not> root_cond (p,l,r) x" by (auto simp: root_cond_def)
      with ran show ?case by (auto simp: root_cond_def)
    qed
    thus ?thesis by auto
  next
    case 2 show ?thesis using d'(1)[OF 2] by simp
  qed (insert ur3,simp)
  have diff_sign: "sgn (ipoly p l) \<noteq> sgn (ipoly p r)"
    using d'(2-) sr sl real_of_rat_sgn by auto
  have ur':"\<And>x. real_of_rat l \<le> x \<and> x \<le> real_of_rat y \<Longrightarrow> ipoly p x = 0 \<Longrightarrow> \<not> (?r y \<le> ur)"
  proof(standard+,goal_cases)
    case (1 x)
    {
      assume id: "ur = ?r y"
      with urD ur py0 have False by auto
    } note neq = this
    have x: "root_cond (p, l, r) x" unfolding root_cond_def
      using 1 a ur urD by auto
    from ur urD x have ur_eqI: "ur = x"
      by auto
    with 1 have "ur = of_rat y" by auto
    with urD(1) py0 show False by auto
  qed
  hence ur'':"\<forall>x. real_of_rat y \<le> x \<and> x \<le> real_of_rat r \<longrightarrow> poly (real_of_int_poly p) x \<noteq> 0 \<Longrightarrow> \<not> (?r y \<le> ur)"
    using urD by auto
  have "(sgn (ipoly p y) = sgn (ipoly p r)) = (?r y > ur)"
  proof(cases "sgn (ipoly p r) = sgn (ipoly p y)")
    case True
    have sgn:"sgn (poly ?p (real_of_rat l)) \<noteq> sgn (poly ?p (real_of_rat y))" using True diff_sign
      by (simp add: real_of_rat_sgn)
    have ly:"of_rat l < (of_rat y::real)" using in_interval True diff_sign less_eq_rat_def of_rat_less by auto
    with no_roots_inbetween_imp_same_sign[OF ly,of ?p] sgn ur' True
    show ?thesis by force
  next
    case False
    hence ne:"sgn (ipoly p (real_of_rat y)) \<noteq> sgn (ipoly p (real_of_rat r))" by (simp add: real_of_rat_sgn)
    have ry:"of_rat y < (of_rat r::real)" using in_interval False diff_sign less_eq_rat_def of_rat_less by auto
    obtain x where x:"real_of_rat y \<le> x" "x \<le> real_of_rat r" "ipoly p x = 0"
      using no_roots_inbetween_imp_same_sign[OF ry,of ?p] ne by auto
    hence lx:"real_of_rat l \<le> x" using in_interval
      using False a urD by auto
    with x have "root_cond (p,l,r) x" by (auto simp: root_cond_def)
    with urD ur
    have "ur = x" by auto
    then show ?thesis using False x by auto
  qed
  thus False using diff_sign(1) a py0 by(cases "ipoly p r = 0";auto simp:sgn_0_0)
qed

definition algebraic_real :: "real \<Rightarrow> bool" where
  [simp]: "algebraic_real = algebraic"

lemma algebraic_real_iff[code_unfold]: "algebraic = algebraic_real" by simp

end


(* Copyright 2021 (C) Mihails Milehins *)

section\<open>Transformation of digraph homomorphisms\<close>
theory CZH_DG_TDGHM
  imports CZH_DG_DGHM
begin

subsection\<open>Background\<close>

named_theorems tdghm_cs_simps
named_theorems tdghm_cs_intros
named_theorems nt_field_simps

definition NTMap :: V where [nt_field_simps]: "NTMap = 0"
definition NTDom :: V where [nt_field_simps]: "NTDom = 1\<^sub>\<nat>"
definition NTCod :: V where [nt_field_simps]: "NTCod = 2\<^sub>\<nat>"
definition NTDGDom :: V where [nt_field_simps]: "NTDGDom = 3\<^sub>\<nat>"
definition NTDGCod :: V where [nt_field_simps]: "NTDGCod = 4\<^sub>\<nat>"

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

text\<open>
A transformation of digraph homomorphisms, as presented in this work,
is a generalization of the concept of a natural transformation, as presented in
Chapter I-4 in \<^cite>\<open>"mac_lane_categories_2010"\<close>, to digraphs and digraph
homomorphisms. The generalization is performed by excluding the commutativity
axiom from the definition.

The definition of a transformation of digraph homomorphisms is
parameterized by a limit ordinal \<open>\<alpha>\<close> such that \<open>\<omega> < \<alpha>\<close>.
Such transformations of digraph homomorphisms are referred to either as
\<open>\<alpha>\<close>-transformations of digraph homomorphisms or
transformations of \<open>\<alpha>\<close>-digraph homomorphisms.
\<close>

locale is_tdghm =
  \<Z> \<alpha> +
  vfsequence \<NN> +
  NTDom: is_dghm \<alpha> \<AA> \<BB> \<FF> +
  NTCod: is_dghm \<alpha> \<AA> \<BB> \<GG>
  for \<alpha> \<AA> \<BB> \<FF> \<GG> \<NN> +
  assumes tdghm_length[dg_cs_simps]: "vcard \<NN> = 5\<^sub>\<nat>"
    and tdghm_NTMap_vsv: "vsv (\<NN>\<lparr>NTMap\<rparr>)"
    and tdghm_NTMap_vdomain[dg_cs_simps]: "\<D>\<^sub>\<circ> (\<NN>\<lparr>NTMap\<rparr>) = \<AA>\<lparr>Obj\<rparr>"
    and tdghm_NTDom[dg_cs_simps]: "\<NN>\<lparr>NTDom\<rparr> = \<FF>"
    and tdghm_NTCod[dg_cs_simps]: "\<NN>\<lparr>NTCod\<rparr> = \<GG>"
    and tdghm_NTDGDom[dg_cs_simps]: "\<NN>\<lparr>NTDGDom\<rparr> = \<AA>"
    and tdghm_NTDGCod[dg_cs_simps]: "\<NN>\<lparr>NTDGCod\<rparr> = \<BB>"
    and tdghm_NTMap_is_arr:
      "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr> \<Longrightarrow> \<NN>\<lparr>NTMap\<rparr>\<lparr>a\<rparr> : \<FF>\<lparr>ObjMap\<rparr>\<lparr>a\<rparr> \<mapsto>\<^bsub>\<BB>\<^esub> \<GG>\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>"

syntax "_is_tdghm" :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> bool"
  (\<open>(_ :/ _ \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M _ :/ _ \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<index> _)\<close> [51, 51, 51, 51, 51] 51)
translations "\<NN> : \<FF> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>" \<rightleftharpoons>
  "CONST is_tdghm \<alpha> \<AA> \<BB> \<FF> \<GG> \<NN>"

abbreviation all_tdghms :: "V \<Rightarrow> V"
  where "all_tdghms \<alpha> \<equiv> set {\<NN>. \<exists>\<FF> \<GG> \<AA> \<BB>. \<NN> : \<FF> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>}"

abbreviation tdghms :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V"
  where "tdghms \<alpha> \<AA> \<BB> \<equiv> set {\<NN>. \<exists>\<FF> \<GG>. \<NN> : \<FF> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>}"

abbreviation these_tdghms :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V"
  where "these_tdghms \<alpha> \<AA> \<BB> \<FF> \<GG> \<equiv> set {\<NN>. \<NN> : \<FF> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>}"

sublocale is_tdghm \<subseteq> NTMap: vsv \<open>\<NN>\<lparr>NTMap\<rparr>\<close>
  rewrites "\<D>\<^sub>\<circ> (\<NN>\<lparr>NTMap\<rparr>) = \<AA>\<lparr>Obj\<rparr>"
  by (rule tdghm_NTMap_vsv) (simp add: dg_cs_simps)

lemmas [dg_cs_simps] =
  is_tdghm.tdghm_length
  is_tdghm.tdghm_NTMap_vdomain
  is_tdghm.tdghm_NTDom
  is_tdghm.tdghm_NTCod
  is_tdghm.tdghm_NTDGDom
  is_tdghm.tdghm_NTDGCod

lemma (in is_tdghm) tdghm_NTMap_is_arr'[dg_cs_intros]:
  assumes "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
    and "A = \<FF>\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>"
    and "B = \<GG>\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>"
  shows "\<NN>\<lparr>NTMap\<rparr>\<lparr>a\<rparr> : A \<mapsto>\<^bsub>\<BB>\<^esub> B"
  using assms(1) unfolding assms(2,3) by (rule tdghm_NTMap_is_arr)

lemmas [dg_cs_intros] = is_tdghm.tdghm_NTMap_is_arr'

text\<open>Rules.\<close>

lemma (in is_tdghm) is_tdghm_axioms'[dg_cs_intros]:
  assumes "\<alpha>' = \<alpha>" and "\<AA>' = \<AA>" and "\<BB>' = \<BB>" and "\<FF>' = \<FF>" and "\<GG>' = \<GG>"
  shows "\<NN> : \<FF>' \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG>' : \<AA>' \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>'\<^esub> \<BB>'"
  unfolding assms by (rule is_tdghm_axioms)

mk_ide rf is_tdghm_def[unfolded is_tdghm_axioms_def]
  |intro is_tdghmI|
  |dest is_tdghmD[dest]|
  |elim is_tdghmE[elim]|

lemmas [dg_cs_intros] =
  is_tdghmD(3,4)

text\<open>Elementary properties.\<close>

lemma tdghm_eqI:
  assumes "\<NN> : \<FF> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>"
    and "\<NN>' : \<FF>' \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG>' : \<AA>' \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>'"
    and "\<NN>\<lparr>NTMap\<rparr> = \<NN>'\<lparr>NTMap\<rparr>"
    and "\<FF> = \<FF>'"
    and "\<GG> = \<GG>'"
    and "\<AA> = \<AA>'"
    and "\<BB> = \<BB>'"
  shows "\<NN> = \<NN>'"
proof-
  interpret L: is_tdghm \<alpha> \<AA> \<BB> \<FF> \<GG> \<NN> by (rule assms(1))
  interpret R: is_tdghm \<alpha> \<AA>' \<BB>' \<FF>' \<GG>' \<NN>' by (rule assms(2))
  show ?thesis
  proof(rule vsv_eqI)
    have dom: "\<D>\<^sub>\<circ> \<NN> = 5\<^sub>\<nat>"
      by (cs_concl cs_shallow cs_simp: dg_cs_simps V_cs_simps)
    show "\<D>\<^sub>\<circ> \<NN> = \<D>\<^sub>\<circ> \<NN>'"
      by (cs_concl cs_shallow cs_simp: dg_cs_simps V_cs_simps)
    from assms(4-7) have sup:
      "\<NN>\<lparr>NTDom\<rparr> = \<NN>'\<lparr>NTDom\<rparr>" "\<NN>\<lparr>NTCod\<rparr> = \<NN>'\<lparr>NTCod\<rparr>"
      "\<NN>\<lparr>NTDGDom\<rparr> = \<NN>'\<lparr>NTDGDom\<rparr>" "\<NN>\<lparr>NTDGCod\<rparr> = \<NN>'\<lparr>NTDGCod\<rparr>"
      by (simp_all add: dg_cs_simps)
    show "a \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> \<NN> \<Longrightarrow> \<NN>\<lparr>a\<rparr> = \<NN>'\<lparr>a\<rparr>" for a
      by (unfold dom, elim_in_numeral, insert assms(3) sup)
        (auto simp: nt_field_simps)
  qed (auto simp: L.vsv_axioms R.vsv_axioms)
qed

lemma (in is_tdghm) tdghm_def:
  "\<NN> = [\<NN>\<lparr>NTMap\<rparr>, \<NN>\<lparr>NTDom\<rparr>, \<NN>\<lparr>NTCod\<rparr>, \<NN>\<lparr>NTDGDom\<rparr>, \<NN>\<lparr>NTDGCod\<rparr>]\<^sub>\<circ>"
proof(rule vsv_eqI)
  have dom_lhs: "\<D>\<^sub>\<circ> \<NN> = 5\<^sub>\<nat>"
    by (cs_concl cs_shallow cs_simp: dg_cs_simps V_cs_simps)
  have dom_rhs:
    "\<D>\<^sub>\<circ> [\<NN>\<lparr>NTMap\<rparr>, \<NN>\<lparr>NTDGDom\<rparr>, \<NN>\<lparr>NTDGCod\<rparr>, \<NN>\<lparr>NTDom\<rparr>, \<NN>\<lparr>NTCod\<rparr>]\<^sub>\<circ> = 5\<^sub>\<nat>"
    by (simp add: nat_omega_simps)
  then show
    "\<D>\<^sub>\<circ> \<NN> = \<D>\<^sub>\<circ> [\<NN>\<lparr>NTMap\<rparr>, \<NN>\<lparr>NTDom\<rparr>, \<NN>\<lparr>NTCod\<rparr>, \<NN>\<lparr>NTDGDom\<rparr>, \<NN>\<lparr>NTDGCod\<rparr>]\<^sub>\<circ>"
    unfolding dom_lhs dom_rhs by (simp add: nat_omega_simps)
  show "a \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> \<NN> \<Longrightarrow>
    \<NN>\<lparr>a\<rparr> = [\<NN>\<lparr>NTMap\<rparr>, \<NN>\<lparr>NTDom\<rparr>, \<NN>\<lparr>NTCod\<rparr>, \<NN>\<lparr>NTDGDom\<rparr>, \<NN>\<lparr>NTDGCod\<rparr>]\<^sub>\<circ>\<lparr>a\<rparr>"
    for a
    by (unfold dom_lhs, elim_in_numeral, unfold nt_field_simps)
      (simp_all add: nat_omega_simps)
qed (auto simp: vsv_axioms)

lemma (in is_tdghm) tdghm_NTMap_app_in_Arr[dg_cs_intros]:
  assumes "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
  shows "\<NN>\<lparr>NTMap\<rparr>\<lparr>a\<rparr> \<in>\<^sub>\<circ> \<BB>\<lparr>Arr\<rparr>"
  using assms using tdghm_NTMap_is_arr by auto

lemmas [dg_cs_intros] = is_tdghm.tdghm_NTMap_app_in_Arr

lemma (in is_tdghm) tdghm_NTMap_vrange_vifunion:
  "\<R>\<^sub>\<circ> (\<NN>\<lparr>NTMap\<rparr>) \<subseteq>\<^sub>\<circ> (\<Union>\<^sub>\<circ>a\<in>\<^sub>\<circ>\<R>\<^sub>\<circ> (\<FF>\<lparr>ObjMap\<rparr>). \<Union>\<^sub>\<circ>b\<in>\<^sub>\<circ>\<R>\<^sub>\<circ> (\<GG>\<lparr>ObjMap\<rparr>). Hom \<BB> a b)"
proof(intro NTMap.vsv_vrange_vsubset)
  fix x assume prems: "x \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
  note \<NN>x = tdghm_NTMap_is_arr[OF prems]
  from prems show
    "\<NN>\<lparr>NTMap\<rparr>\<lparr>x\<rparr> \<in>\<^sub>\<circ> (\<Union>\<^sub>\<circ>a\<in>\<^sub>\<circ>\<R>\<^sub>\<circ> (\<FF>\<lparr>ObjMap\<rparr>). \<Union>\<^sub>\<circ>b\<in>\<^sub>\<circ>\<R>\<^sub>\<circ> (\<GG>\<lparr>ObjMap\<rparr>). Hom \<BB> a b)"
    by (intro vifunionI, unfold in_Hom_iff)
      (
        auto intro:
          dg_cs_intros NTDom.ObjMap.vsv_vimageI2' NTCod.ObjMap.vsv_vimageI2'
      )
qed

lemma (in is_tdghm) tdghm_NTMap_vrange: "\<R>\<^sub>\<circ> (\<NN>\<lparr>NTMap\<rparr>) \<subseteq>\<^sub>\<circ> \<BB>\<lparr>Arr\<rparr>"
proof(intro NTMap.vsv_vrange_vsubset)
  fix x assume "x \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
  with is_tdghm_axioms show "\<NN>\<lparr>NTMap\<rparr>\<lparr>x\<rparr> \<in>\<^sub>\<circ> \<BB>\<lparr>Arr\<rparr>"
    by (cs_concl cs_shallow cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
qed

text\<open>Size.\<close>

lemma (in is_tdghm) tdghm_NTMap_vsubset_Vset: "\<NN>\<lparr>NTMap\<rparr> \<subseteq>\<^sub>\<circ> Vset \<alpha>"
proof(intro NTMap.vbrelation_Limit_vsubset_VsetI)
  show "\<R>\<^sub>\<circ> (\<NN>\<lparr>NTMap\<rparr>) \<subseteq>\<^sub>\<circ> Vset \<alpha>"
    by
      (
        rule vsubset_transitive,
        rule tdghm_NTMap_vrange,
        rule NTDom.HomCod.dg_Arr_vsubset_Vset
      )
qed (simp_all add: NTDom.HomDom.dg_Obj_vsubset_Vset)

lemma (in is_tdghm) tdghm_NTMap_in_Vset:
  assumes "\<alpha> \<in>\<^sub>\<circ> \<beta>"
  shows "\<NN>\<lparr>NTMap\<rparr> \<in>\<^sub>\<circ> Vset \<beta>"
  by (meson assms tdghm_NTMap_vsubset_Vset Vset_in_mono vsubset_in_VsetI)

lemma (in is_tdghm) tdghm_in_Vset:
  assumes "\<Z> \<beta>" and "\<alpha> \<in>\<^sub>\<circ> \<beta>"
  shows "\<NN> \<in>\<^sub>\<circ> Vset \<beta>"
proof-
  interpret \<beta>: \<Z> \<beta> by (rule assms(1))
  note [dg_cs_intros] =
    tdghm_NTMap_in_Vset
    NTDom.dghm_in_Vset
    NTCod.dghm_in_Vset
    NTDom.HomDom.dg_in_Vset
    NTDom.HomCod.dg_in_Vset
  from assms(2) show ?thesis
    by (subst tdghm_def)
      (
        cs_concl cs_shallow
          cs_simp: dg_cs_simps cs_intro: dg_cs_intros V_cs_intros
      )
qed

lemma (in is_tdghm) tdghm_is_tdghm_if_ge_Limit:
  assumes "\<Z> \<beta>" and "\<alpha> \<in>\<^sub>\<circ> \<beta>"
  shows "\<NN> : \<FF> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<beta>\<^esub> \<BB>"
proof(rule is_tdghmI)
  show "\<NN>\<lparr>NTMap\<rparr>\<lparr>a\<rparr> : \<FF>\<lparr>ObjMap\<rparr>\<lparr>a\<rparr> \<mapsto>\<^bsub>\<BB>\<^esub> \<GG>\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>" if "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>" for a
    using that by (cs_concl cs_shallow cs_intro: dg_cs_intros)
qed
  (
    cs_concl cs_shallow
      cs_simp: dg_cs_simps
      cs_intro:
        V_cs_intros
        assms NTDom.dghm_is_dghm_if_ge_Limit NTCod.dghm_is_dghm_if_ge_Limit
   )+

lemma small_all_tdghms[simp]:
  "small {\<NN>. \<exists>\<FF> \<GG> \<AA> \<BB>. \<NN> : \<FF> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>}"
proof(cases \<open>\<Z> \<alpha>\<close>)
  case True
  from is_tdghm.tdghm_in_Vset show ?thesis
    by (intro down[of _ \<open>Vset (\<alpha> + \<omega>)\<close>])
      (auto simp: True \<Z>.\<Z>_Limit_\<alpha>\<omega> \<Z>.\<Z>_\<omega>_\<alpha>\<omega> \<Z>.intro \<Z>.\<Z>_\<alpha>_\<alpha>\<omega>)
next
  case False
  then have "{\<NN>. \<exists>\<FF> \<GG> \<AA> \<BB>. \<NN> : \<FF> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>} = {}" by auto
  then show ?thesis by simp
qed

lemma small_tdghms[simp]: "small {\<NN>. \<exists>\<FF> \<GG>. \<NN> : \<FF> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>}"
  by (rule down[of _ \<open>set {\<NN>. \<exists>\<FF> \<GG> \<AA> \<BB>. \<NN> : \<FF> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>}\<close>])
    auto

lemma small_these_tdghms[simp]: "small {\<NN>. \<NN> : \<FF> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>}"
  by (rule down[of _ \<open>set {\<NN>. \<exists>\<FF> \<GG> \<AA> \<BB>. \<NN> : \<FF> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>}\<close>])
    auto

text\<open>Further elementary results.\<close>

lemma these_tdghms_iff(*not simp*):
  "\<NN> \<in>\<^sub>\<circ> these_tdghms \<alpha> \<AA> \<BB> \<FF> \<GG> \<longleftrightarrow> \<NN> : \<FF> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>"
  by auto

subsection\<open>Opposite transformation of digraph homomorphisms\<close>

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

text\<open>See section 1.5 in \<^cite>\<open>"bodo_categories_1970"\<close>.\<close>

definition op_tdghm :: "V \<Rightarrow> V"
  where "op_tdghm \<NN> =
    [
      \<NN>\<lparr>NTMap\<rparr>,
      op_dghm (\<NN>\<lparr>NTCod\<rparr>),
      op_dghm (\<NN>\<lparr>NTDom\<rparr>),
      op_dg (\<NN>\<lparr>NTDGDom\<rparr>),
      op_dg (\<NN>\<lparr>NTDGCod\<rparr>)
    ]\<^sub>\<circ>"

text\<open>Components.\<close>

lemma op_tdghm_components[dg_op_simps]:
  shows "op_tdghm \<NN>\<lparr>NTMap\<rparr> = \<NN>\<lparr>NTMap\<rparr>"
    and "op_tdghm \<NN>\<lparr>NTDom\<rparr> = op_dghm (\<NN>\<lparr>NTCod\<rparr>)"
    and "op_tdghm \<NN>\<lparr>NTCod\<rparr> = op_dghm (\<NN>\<lparr>NTDom\<rparr>)"
    and "op_tdghm \<NN>\<lparr>NTDGDom\<rparr> = op_dg (\<NN>\<lparr>NTDGDom\<rparr>)"
    and "op_tdghm \<NN>\<lparr>NTDGCod\<rparr> = op_dg (\<NN>\<lparr>NTDGCod\<rparr>)"
  unfolding op_tdghm_def nt_field_simps by (auto simp: nat_omega_simps)

subsubsection\<open>Further properties\<close>

lemma (in is_tdghm) is_tdghm_op:
  "op_tdghm \<NN> : op_dghm \<GG> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M op_dghm \<FF> : op_dg \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> op_dg \<BB>"
proof(rule is_tdghmI, unfold dg_op_simps)
  show "vfsequence (op_tdghm \<NN>)" by (simp add: op_tdghm_def)
  show "vcard (op_tdghm \<NN>) = 5\<^sub>\<nat>" by (simp add: op_tdghm_def nat_omega_simps)
  show "\<NN>\<lparr>NTMap\<rparr>\<lparr>a\<rparr> : \<FF>\<lparr>ObjMap\<rparr>\<lparr>a\<rparr> \<mapsto>\<^bsub>\<BB>\<^esub> \<GG>\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>" if "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>" for a
    using that by (cs_concl cs_shallow cs_intro: dg_cs_intros)
qed
  (
    cs_concl cs_shallow
      cs_simp: dg_cs_simps cs_intro: dg_cs_intros dg_op_intros V_cs_intros
  )+

lemma (in is_tdghm) is_tdghm_op'[dg_op_intros]:
  assumes "\<GG>' = op_dghm \<GG>"
    and "\<FF>' = op_dghm \<FF>"
    and "\<AA>' = op_dg \<AA>"
    and "\<BB>' = op_dg \<BB>"
  shows "op_tdghm \<NN> : \<GG>' \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<FF>' : \<AA>' \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>'"
  unfolding assms by (rule is_tdghm_op)

lemmas is_tdghm_op[dg_op_intros] = is_tdghm.is_tdghm_op'

lemma (in is_tdghm) tdghm_op_tdghm_op_tdghm[dg_op_simps]:
  "op_tdghm (op_tdghm \<NN>) = \<NN>"
proof(rule tdghm_eqI[of \<alpha> \<AA> \<BB> \<FF> \<GG> _ \<AA> \<BB> \<FF> \<GG>], unfold dg_op_simps)
  interpret op:
    is_tdghm \<alpha> \<open>op_dg \<AA>\<close> \<open>op_dg \<BB>\<close> \<open>op_dghm \<GG>\<close> \<open>op_dghm \<FF>\<close> \<open>op_tdghm \<NN>\<close>
    by (rule is_tdghm_op)
  from op.is_tdghm_op show
    "op_tdghm (op_tdghm \<NN>) : \<FF> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>"
    by (simp add: dg_op_simps)
qed (auto simp: dg_cs_intros)

lemmas tdghm_op_tdghm_op_tdghm[dg_op_simps] =
  is_tdghm.tdghm_op_tdghm_op_tdghm

lemma eq_op_tdghm_iff:
  assumes "\<NN> : \<FF> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>"
    and "\<NN>' : \<FF>' \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG>' : \<AA>' \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>'"
  shows "op_tdghm \<NN> = op_tdghm \<NN>' \<longleftrightarrow> \<NN> = \<NN>'"
proof
  interpret L: is_tdghm \<alpha> \<AA> \<BB> \<FF> \<GG> \<NN> by (rule assms(1))
  interpret R: is_tdghm \<alpha> \<AA>' \<BB>' \<FF>' \<GG>' \<NN>' by (rule assms(2))
  assume prems: "op_tdghm \<NN> = op_tdghm \<NN>'"
  show "\<NN> = \<NN>'"
  proof(rule tdghm_eqI[OF assms])
    from prems L.tdghm_op_tdghm_op_tdghm R.tdghm_op_tdghm_op_tdghm show
      "\<NN>\<lparr>NTMap\<rparr> = \<NN>'\<lparr>NTMap\<rparr>"
      by metis+
    from prems L.tdghm_op_tdghm_op_tdghm R.tdghm_op_tdghm_op_tdghm
    have "\<NN>\<lparr>NTDom\<rparr> = \<NN>'\<lparr>NTDom\<rparr>"
      and "\<NN>\<lparr>NTCod\<rparr> = \<NN>'\<lparr>NTCod\<rparr>"
      and "\<NN>\<lparr>NTDGDom\<rparr> = \<NN>'\<lparr>NTDGDom\<rparr>"
      and "\<NN>\<lparr>NTDGCod\<rparr> = \<NN>'\<lparr>NTDGCod\<rparr>"
      by metis+
    then show "\<FF> = \<FF>'" "\<GG> = \<GG>'" "\<AA> = \<AA>'" "\<BB> = \<BB>'" by (auto simp: dg_cs_simps)
  qed
qed auto

subsection\<open>
Composition of a transformation of digraph homomorphisms
and a digraph homomorphism
\<close>

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

definition tdghm_dghm_comp :: "V \<Rightarrow> V \<Rightarrow> V" (infixl \<open>\<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<close> 55)
  where "\<NN> \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<HH> =
    [
      (\<lambda>a\<in>\<^sub>\<circ>\<HH>\<lparr>HomDom\<rparr>\<lparr>Obj\<rparr>. \<NN>\<lparr>NTMap\<rparr>\<lparr>\<HH>\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>\<rparr>),
      \<NN>\<lparr>NTDom\<rparr> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<HH>,
      \<NN>\<lparr>NTCod\<rparr> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<HH>,
      \<HH>\<lparr>HomDom\<rparr>,
      \<NN>\<lparr>NTDGCod\<rparr>
    ]\<^sub>\<circ>"

text\<open>Components.\<close>

lemma tdghm_dghm_comp_components:
  shows "(\<NN> \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<HH>)\<lparr>NTMap\<rparr> =
    (\<lambda>a\<in>\<^sub>\<circ>\<HH>\<lparr>HomDom\<rparr>\<lparr>Obj\<rparr>. \<NN>\<lparr>NTMap\<rparr>\<lparr>\<HH>\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>\<rparr>)"
    and [dg_shared_cs_simps, dg_cs_simps]:
      "(\<NN> \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<HH>)\<lparr>NTDom\<rparr> = \<NN>\<lparr>NTDom\<rparr> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<HH>"
    and [dg_shared_cs_simps, dg_cs_simps]:
      "(\<NN> \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<HH>)\<lparr>NTCod\<rparr> = \<NN>\<lparr>NTCod\<rparr> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<HH>"
    and [dg_shared_cs_simps, dg_cs_simps]:
      "(\<NN> \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<HH>)\<lparr>NTDGDom\<rparr> = \<HH>\<lparr>HomDom\<rparr>"
    and [dg_shared_cs_simps, dg_cs_simps]:
      "(\<NN> \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<HH>)\<lparr>NTDGCod\<rparr> = \<NN>\<lparr>NTDGCod\<rparr>"
  unfolding tdghm_dghm_comp_def nt_field_simps
  by (simp_all add: nat_omega_simps)

subsubsection\<open>Transformation map\<close>

mk_VLambda tdghm_dghm_comp_components(1)
  |vsv tdghm_dghm_comp_NTMap_vsv[dg_shared_cs_intros, dg_cs_intros]|

mk_VLambda (in is_dghm)
  tdghm_dghm_comp_components(1)[where \<HH>=\<FF>, unfolded dghm_HomDom]
  |vdomain tdghm_dghm_comp_NTMap_vdomain|
  |app tdghm_dghm_comp_NTMap_app|

lemmas [dg_cs_simps] =
  is_dghm.tdghm_dghm_comp_NTMap_vdomain
  is_dghm.tdghm_dghm_comp_NTMap_app

lemma tdghm_dghm_comp_NTMap_vrange:
  assumes "\<NN> : \<FF> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG> : \<BB> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<CC>" and "\<HH> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>"
  shows "\<R>\<^sub>\<circ> ((\<NN> \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<HH>)\<lparr>NTMap\<rparr>) \<subseteq>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>"
proof-
  interpret \<NN>: is_tdghm \<alpha> \<BB> \<CC> \<FF> \<GG> \<NN> by (rule assms(1))
  interpret \<HH>: is_dghm \<alpha> \<AA> \<BB> \<HH> by (rule assms(2))
  show ?thesis
    unfolding tdghm_dghm_comp_components
  proof(rule vrange_VLambda_vsubset, unfold dg_cs_simps)
    fix x assume "x \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
    then show "\<NN>\<lparr>NTMap\<rparr>\<lparr>\<HH>\<lparr>ObjMap\<rparr>\<lparr>x\<rparr>\<rparr> \<in>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>"
      by (cs_concl cs_shallow cs_intro: dg_cs_intros)
  qed
qed

subsubsection\<open>
Opposite of the composition of a transformation of
digraph homomorphisms and a digraph homomorphism
\<close>

lemma op_tdghm_tdghm_dghm_comp[dg_op_simps]:
  "op_tdghm (\<NN> \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<HH>) = op_tdghm \<NN> \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M op_dghm \<HH>"
  unfolding
    tdghm_dghm_comp_def
    dghm_comp_def
    op_tdghm_def
    op_dghm_def
    op_dg_def
    dg_field_simps
    dghm_field_simps
    nt_field_simps
  by (simp add: nat_omega_simps) (*slow*)

subsubsection\<open>
Composition of a transformation of digraph homomorphisms and a digraph
homomorphism is a transformation of digraph homomorphisms
\<close>

lemma tdghm_dghm_comp_is_tdghm:
  assumes "\<NN> : \<FF> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG> : \<BB> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<CC>" and "\<HH> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>"
  shows "\<NN> \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<HH> : \<FF> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<HH> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<HH> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<CC>"
proof-
  interpret \<NN>: is_tdghm \<alpha> \<BB> \<CC> \<FF> \<GG> \<NN> by (rule assms(1))
  interpret \<HH>: is_dghm \<alpha> \<AA> \<BB> \<HH> by (rule assms(2))
  show ?thesis
  proof(rule is_tdghmI)
    show "vfsequence (\<NN> \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<HH>)" unfolding tdghm_dghm_comp_def by simp
    show "vcard (\<NN> \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<HH>) = 5\<^sub>\<nat>"
      unfolding tdghm_dghm_comp_def by (simp add: nat_omega_simps)
    show "(\<NN> \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<HH>)\<lparr>NTMap\<rparr>\<lparr>a\<rparr> :
      (\<FF> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<HH>)\<lparr>ObjMap\<rparr>\<lparr>a\<rparr> \<mapsto>\<^bsub>\<CC>\<^esub> (\<GG> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<HH>)\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>"
      if "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>" for a
      by
        (
          use that in
            \<open>cs_concl cs_shallow cs_simp: dg_cs_simps cs_intro: dg_cs_intros\<close>
        )
  qed (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)+
qed

lemma tdghm_dghm_comp_is_tdghm'[dg_cs_intros]:
  assumes "\<NN> : \<FF> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG> : \<BB> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<CC>"
    and "\<HH> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>"
    and "\<FF>' = \<FF> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<HH>"
    and "\<GG>' = \<GG> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<HH>"
  shows "\<NN> \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<HH> : \<FF>' \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG>' : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<CC>"
  using assms(1,2) unfolding assms(3,4) by (rule tdghm_dghm_comp_is_tdghm)

subsubsection\<open>Further properties\<close>

lemma tdghm_dghm_comp_tdghm_dghm_comp_assoc:
  assumes "\<NN> : \<HH> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<HH>' : \<CC> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<DD>"
    and "\<GG> : \<BB> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<CC>"
    and "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>"
  shows "(\<NN> \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG>) \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<FF> = \<NN> \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M (\<GG> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<FF>)"
proof-
  interpret \<NN>: is_tdghm \<alpha> \<CC> \<DD> \<HH> \<HH>' \<NN> by (rule assms(1))
  interpret \<GG>: is_dghm \<alpha> \<BB> \<CC> \<GG> by (rule assms(2))
  interpret \<FF>: is_dghm \<alpha> \<AA> \<BB> \<FF> by (rule assms(3))
  show ?thesis
  proof(rule tdghm_eqI)
    from assms show
      "(\<NN> \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG>) \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<FF> :
        \<HH> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<FF> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<HH>' \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<FF> :
        \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<DD>"
      by (cs_concl cs_shallow cs_intro: dg_cs_intros)
    then have dom_lhs: "\<D>\<^sub>\<circ> (((\<NN> \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG>) \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<FF>)\<lparr>NTMap\<rparr>) = \<AA>\<lparr>Obj\<rparr>"
      by (cs_concl cs_simp: dg_cs_simps)
    show "\<NN> \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M (\<GG> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<FF>) :
      \<HH> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<FF> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<HH>' \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<FF> :
      \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<DD>"
      by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
    then have dom_rhs: "\<D>\<^sub>\<circ> ((\<NN> \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M (\<GG> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<FF>))\<lparr>NTMap\<rparr>) = \<AA>\<lparr>Obj\<rparr>"
      by (cs_concl cs_simp: dg_cs_simps)
    show
      "((\<NN> \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG>) \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<FF>)\<lparr>NTMap\<rparr> =
        (\<NN> \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M (\<GG> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<FF>))\<lparr>NTMap\<rparr>"
    proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
      fix a assume "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
      with assms show
        "((\<NN> \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG>) \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<FF>)\<lparr>NTMap\<rparr>\<lparr>a\<rparr> =
          (\<NN> \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M (\<GG> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<FF>))\<lparr>NTMap\<rparr>\<lparr>a\<rparr>"
        by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
    qed (cs_concl cs_shallow cs_intro: dg_cs_intros)
  qed simp_all
qed

lemma (in is_tdghm) tdghm_tdghm_dghm_comp_dghm_id[dg_cs_simps]:
  "\<NN> \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M dghm_id \<AA> = \<NN>"
proof(rule tdghm_eqI)
  show "\<NN> \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M dghm_id \<AA> : \<FF> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>"
    by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
  show "\<NN> : \<FF> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>"
    by (cs_concl cs_shallow cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
  have dom_lhs: "\<D>\<^sub>\<circ> ((\<NN> \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M dghm_id \<AA>)\<lparr>NTMap\<rparr>) = \<AA>\<lparr>Obj\<rparr>"
    by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
  show "(\<NN> \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M dghm_id \<AA>)\<lparr>NTMap\<rparr> = \<NN>\<lparr>NTMap\<rparr>"
  proof(rule vsv_eqI, unfold dom_lhs dg_cs_simps)
    fix a assume "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
    then show "(\<NN> \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M dghm_id \<AA>)\<lparr>NTMap\<rparr>\<lparr>a\<rparr> = \<NN>\<lparr>NTMap\<rparr>\<lparr>a\<rparr>"
      by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
  qed (cs_concl cs_intro: dg_cs_intros V_cs_intros)+
qed simp_all

lemmas [dg_cs_simps] = is_tdghm.tdghm_tdghm_dghm_comp_dghm_id

subsection\<open>
Composition of a digraph homomorphism and a transformation of
digraph homomorphisms
\<close>

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

definition dghm_tdghm_comp :: "V \<Rightarrow> V \<Rightarrow> V" (infixl \<open>\<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<close> 55)
  where "\<HH> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<NN> =
    [
      (\<lambda>a\<in>\<^sub>\<circ>\<NN>\<lparr>NTDGDom\<rparr>\<lparr>Obj\<rparr>. \<HH>\<lparr>ArrMap\<rparr>\<lparr>\<NN>\<lparr>NTMap\<rparr>\<lparr>a\<rparr>\<rparr>),
      \<HH> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<NN>\<lparr>NTDom\<rparr>,
      \<HH> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<NN>\<lparr>NTCod\<rparr>,
      \<NN>\<lparr>NTDGDom\<rparr>,
      \<HH>\<lparr>HomCod\<rparr>
    ]\<^sub>\<circ>"

text\<open>Components.\<close>

lemma dghm_tdghm_comp_components:
  shows "(\<HH> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<NN>)\<lparr>NTMap\<rparr> =
    (\<lambda>a\<in>\<^sub>\<circ>\<NN>\<lparr>NTDGDom\<rparr>\<lparr>Obj\<rparr>. \<HH>\<lparr>ArrMap\<rparr>\<lparr>\<NN>\<lparr>NTMap\<rparr>\<lparr>a\<rparr>\<rparr>)"
    and [dg_shared_cs_simps, dg_cs_simps]:
      "(\<HH> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<NN>)\<lparr>NTDom\<rparr> = \<HH> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<NN>\<lparr>NTDom\<rparr>"
    and [dg_shared_cs_simps, dg_cs_simps]:
      "(\<HH> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<NN>)\<lparr>NTCod\<rparr> = \<HH> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<NN>\<lparr>NTCod\<rparr>"
    and [dg_shared_cs_simps, dg_cs_simps]:
      "(\<HH> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<NN>)\<lparr>NTDGDom\<rparr> = \<NN>\<lparr>NTDGDom\<rparr>"
    and [dg_shared_cs_simps, dg_cs_simps]:
      "(\<HH> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<NN>)\<lparr>NTDGCod\<rparr> = \<HH>\<lparr>HomCod\<rparr>"
  unfolding dghm_tdghm_comp_def nt_field_simps
  by (simp_all add: nat_omega_simps)

subsubsection\<open>Transformation map\<close>

mk_VLambda dghm_tdghm_comp_components(1)
  |vsv dghm_tdghm_comp_NTMap_vsv[dg_shared_cs_intros, dg_cs_intros]|

mk_VLambda (in is_tdghm)
  dghm_tdghm_comp_components(1)[where \<NN>=\<NN>, unfolded tdghm_NTDGDom]
  |vdomain dghm_tdghm_comp_NTMap_vdomain|
  |app dghm_tdghm_comp_NTMap_app|

lemmas [dg_cs_simps] =
  is_tdghm.dghm_tdghm_comp_NTMap_vdomain
  is_tdghm.dghm_tdghm_comp_NTMap_app

lemma dghm_tdghm_comp_NTMap_vrange:
  assumes "\<HH> : \<BB> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<CC>" and "\<NN> : \<FF> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>"
  shows "\<R>\<^sub>\<circ> ((\<HH> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<NN>)\<lparr>NTMap\<rparr>) \<subseteq>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>"
proof-
  interpret \<HH>: is_dghm \<alpha> \<BB> \<CC> \<HH> by (rule assms(1))
  interpret \<NN>: is_tdghm \<alpha> \<AA> \<BB> \<FF> \<GG> \<NN> by (rule assms(2))
  show ?thesis
    unfolding dghm_tdghm_comp_components
  proof(rule vrange_VLambda_vsubset, unfold dg_cs_simps)
    fix x assume "x \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
    then show "\<HH>\<lparr>ArrMap\<rparr>\<lparr>\<NN>\<lparr>NTMap\<rparr>\<lparr>x\<rparr>\<rparr> \<in>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>"
      by (cs_concl cs_shallow cs_intro: dg_cs_intros)
  qed
qed

subsubsection\<open>
Opposite of the composition of a digraph homomorphism
and a transformation of digraph homomorphisms
\<close>

lemma op_tdghm_dghm_tdghm_comp[dg_op_simps]:
  "op_tdghm (\<HH> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<NN>) = op_dghm \<HH> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M op_tdghm \<NN>"
  unfolding
    dghm_tdghm_comp_def
    dghm_comp_def
    op_tdghm_def
    op_dghm_def
    op_dg_def
    dg_field_simps
    dghm_field_simps
    nt_field_simps
  by (simp add: nat_omega_simps) (*slow*)

subsubsection\<open>
Composition of a digraph homomorphism and a transformation of
digraph homomorphisms is a transformation of digraph homomorphisms
\<close>

lemma dghm_tdghm_comp_is_tdghm:
  assumes "\<HH> : \<BB> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<CC>" and "\<NN> : \<FF> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>"
  shows "\<HH> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<NN> : \<HH> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<FF> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<HH> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<CC>"
proof-
  interpret \<HH>: is_dghm \<alpha> \<BB> \<CC> \<HH> by (rule assms(1))
  interpret \<NN>: is_tdghm \<alpha> \<AA> \<BB> \<FF> \<GG> \<NN> by (rule assms(2))
  show ?thesis
  proof(rule is_tdghmI)
    show "vfsequence (\<HH> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<NN>)"
      unfolding dghm_tdghm_comp_def by simp
    show "vcard (\<HH> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<NN>) = 5\<^sub>\<nat>"
      unfolding dghm_tdghm_comp_def  by (simp add: nat_omega_simps)
    show "(\<HH> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<NN>)\<lparr>NTMap\<rparr>\<lparr>a\<rparr> :
      (\<HH> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<FF>)\<lparr>ObjMap\<rparr>\<lparr>a\<rparr> \<mapsto>\<^bsub>\<CC>\<^esub> (\<HH> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG>)\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>"
      if "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>" for a
      by (use that in \<open>cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros\<close>)
  qed (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)+
qed

lemma dghm_tdghm_comp_is_tdghm'[dg_cs_intros]:
  assumes "\<HH> : \<BB> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<CC>"
    and "\<NN> : \<FF> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>"
    and "\<FF>' = \<HH> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<FF>"
    and "\<GG>' = \<HH> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG>"
  shows "\<HH> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<NN> : \<FF>' \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG>' : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<CC>"
  using assms(1,2) unfolding assms(3,4) by (rule dghm_tdghm_comp_is_tdghm)

subsubsection\<open>Further properties\<close>

lemma dghm_comp_dghm_tdghm_comp_assoc:
  assumes "\<NN> : \<HH> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<HH>' : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>"
    and "\<FF> : \<BB> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<CC>"
    and "\<GG> : \<CC> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<DD>"
  shows "(\<GG> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<FF>) \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<NN> = \<GG> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M (\<FF> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<NN>)"
proof(rule tdghm_eqI)
  interpret \<NN>: is_tdghm \<alpha> \<AA> \<BB> \<HH> \<HH>' \<NN> by (rule assms(1))
  interpret \<FF>: is_dghm \<alpha> \<BB> \<CC> \<FF> by (rule assms(2))
  interpret \<GG>: is_dghm \<alpha> \<CC> \<DD> \<GG> by (rule assms(3))
  from assms show "(\<GG> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<FF>) \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<NN> :
    \<GG> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<FF> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<HH> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<FF> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<HH>' : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<DD>"
    by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
  then have dom_lhs: "\<D>\<^sub>\<circ> ((\<GG> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<FF> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<NN>)\<lparr>NTMap\<rparr>) = \<AA>\<lparr>Obj\<rparr>"
    by (cs_concl cs_simp: dg_cs_simps)
  from assms show "\<GG> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M (\<FF> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<NN>) :
    \<GG> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<FF> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<HH> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<FF> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<HH>' : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<DD>"
    by (cs_concl cs_shallow cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
  then have dom_rhs:
    "\<D>\<^sub>\<circ> ((\<GG> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M (\<FF> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<NN>))\<lparr>NTMap\<rparr>) = \<AA>\<lparr>Obj\<rparr>"
    by (cs_concl cs_simp: dg_cs_simps)
  show
    "((\<GG> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<FF>) \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<NN>)\<lparr>NTMap\<rparr> =
      (\<GG> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M (\<FF> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<NN>))\<lparr>NTMap\<rparr>"
  proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
    fix a assume "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
    then show
      "(\<GG> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<FF> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<NN>)\<lparr>NTMap\<rparr>\<lparr>a\<rparr> =
        (\<GG> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M (\<FF> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<NN>))\<lparr>NTMap\<rparr>\<lparr>a\<rparr>"
      by (cs_concl cs_shallow cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
  qed (cs_concl cs_shallow cs_simp: dg_cs_simps cs_intro: dg_cs_intros)+
qed simp_all

lemma (in is_tdghm) tdghm_dghm_tdghm_comp_dghm_id[dg_cs_simps]:
  "dghm_id \<BB> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<NN> = \<NN>"
proof(rule tdghm_eqI)
  show "dghm_id \<BB> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<NN> : \<FF> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>"
    by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
  then have dom_lhs: "\<D>\<^sub>\<circ> ((dghm_id \<BB> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<NN>)\<lparr>NTMap\<rparr>) = \<AA>\<lparr>Obj\<rparr>"
    by (cs_concl cs_simp: dg_cs_simps)
  show "\<NN> : \<FF> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>"
    by (cs_concl cs_shallow cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
  show "(dghm_id \<BB> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<NN>)\<lparr>NTMap\<rparr> = \<NN>\<lparr>NTMap\<rparr>"
  proof(rule vsv_eqI, unfold dom_lhs dg_cs_simps)
    show "vsv (\<NN>\<lparr>NTMap\<rparr>)" by auto
    fix a assume "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
    then show "(dghm_id \<BB> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<NN>)\<lparr>NTMap\<rparr>\<lparr>a\<rparr> = \<NN>\<lparr>NTMap\<rparr>\<lparr>a\<rparr>"
      by (cs_concl cs_shallow cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
  qed (cs_concl cs_shallow cs_intro: dg_cs_intros)+
qed simp_all

lemmas [dg_cs_simps] = is_tdghm.tdghm_dghm_tdghm_comp_dghm_id

lemma dghm_tdghm_comp_tdghm_dghm_comp_assoc:
  assumes "\<NN> : \<FF> \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<GG> : \<BB> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<CC>"
    and "\<HH> : \<CC> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<DD>"
    and "\<KK> : \<AA> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>"
  shows "(\<HH> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<NN>) \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<KK> = \<HH> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M (\<NN> \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<KK>)"
proof-
  interpret \<NN>: is_tdghm \<alpha> \<BB> \<CC> \<FF> \<GG> \<NN> by (rule assms(1))
  interpret \<HH>: is_dghm \<alpha> \<CC> \<DD> \<HH> by (rule assms(2))
  interpret \<KK>: is_dghm \<alpha> \<AA> \<BB> \<KK> by (rule assms(3))
  show ?thesis
  proof(rule tdghm_eqI)
    from assms have dom_lhs:
      "\<D>\<^sub>\<circ> (((\<HH> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<NN>) \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<KK>)\<lparr>NTMap\<rparr>) = \<AA>\<lparr>Obj\<rparr>"
      by (cs_concl cs_shallow cs_simp: dg_cs_simps)
    from assms have dom_rhs:
      "\<D>\<^sub>\<circ> ((\<HH> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M (\<NN> \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<KK>))\<lparr>NTMap\<rparr>) = \<AA>\<lparr>Obj\<rparr>"
      by (cs_concl cs_shallow cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
    show
      "((\<HH> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<NN>) \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<KK>)\<lparr>NTMap\<rparr> =
        (\<HH> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M (\<NN> \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<KK>))\<lparr>NTMap\<rparr>"
    proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
      fix a assume "a \<in>\<^sub>\<circ> \<AA>\<lparr>Obj\<rparr>"
      then show
        "((\<HH> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<NN>) \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<KK>)\<lparr>NTMap\<rparr>\<lparr>a\<rparr> =
          ((\<HH> \<circ>\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M (\<NN> \<circ>\<^sub>T\<^sub>D\<^sub>G\<^sub>H\<^sub>M\<^sub>-\<^sub>D\<^sub>G\<^sub>H\<^sub>M \<KK>)))\<lparr>NTMap\<rparr>\<lparr>a\<rparr>"
        by (cs_concl cs_shallow cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
    qed (cs_concl cs_shallow cs_intro: dg_cs_intros)
  qed (cs_concl cs_shallow cs_simp: dg_cs_simps cs_intro: dg_cs_intros)+
qed

text\<open>\newpage\<close>

end