theory SubclassInstance
  imports
    Main
    "Ecore-GROOVE-Mapping.Instance_Model_Graph_Mapping"
    SubclassType
begin

section "Definition of an instance model which introduces an object typed by a regular subclass"

definition imod_subclass :: "'t Id \<Rightarrow> 't Id \<Rightarrow> 'o set \<Rightarrow> ('o \<Rightarrow> 't) \<Rightarrow> ('o, 't) instance_model" where
  "imod_subclass name supertype objects fid = \<lparr>
    Tm = tmod_subclass name supertype,
    Object = objects,
    ObjectClass = (\<lambda>x. if x \<in> objects then name else undefined),
    ObjectId = (\<lambda>x. if x \<in> objects then fid x else undefined),
    FieldValue = (\<lambda>x. undefined),
    DefaultValue = (\<lambda>x. undefined)
  \<rparr>"

lemma imod_subclass_correct:
  assumes name_supertype_neq: "name \<noteq> supertype"
  assumes name_supertype_ns_valid: "\<not>id_in_ns name (Identifier supertype) \<and> \<not>id_in_ns supertype (Identifier name)"
  assumes unique_ids: "\<And>o1 o2. o1 \<in> objects \<Longrightarrow> o2 \<in> objects \<Longrightarrow> fid o1 = fid o2 \<Longrightarrow> o1 = o2"
  shows "instance_model (imod_subclass name supertype objects fid)"
proof (intro instance_model.intro)
  show "type_model (Tm (imod_subclass name supertype objects fid))"
    unfolding imod_subclass_def
    using tmod_subclass_correct assms
    by simp
qed (simp_all add: assms imod_subclass_def tmod_subclass_def)

lemma imod_subclass_combine_correct:
  assumes "instance_model Imod"
  assumes name_supertype_neq: "name \<noteq> supertype"
  assumes name_supertype_ns_valid: "\<not>id_in_ns name (Identifier supertype) \<and> \<not>id_in_ns supertype (Identifier name)"
  assumes combined_classes: "Class (Tm Imod) \<inter> {supertype, name} = {supertype}"
  assumes new_subclass: "name \<notin> Class (Tm Imod) \<union> Enum (Tm Imod) \<union> UserDataType (Tm Imod)"
  assumes name_namespace_valid: "\<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)"
  assumes new_objects: "objects \<inter> Object Imod = {}"
  assumes unique_ids: "\<And>o1 o2. o1 \<in> objects \<Longrightarrow> o2 \<in> objects \<Longrightarrow> fid o1 = fid o2 \<Longrightarrow> o1 = o2"
  assumes new_ids: "\<And>o1 o2. o1 \<in> Object Imod \<Longrightarrow> o2 \<in> objects \<Longrightarrow> ObjectId Imod o1 \<noteq> fid o2"
  assumes no_fields_supertype: "Type_Model.fields (Tm Imod) supertype = {}"
  shows "instance_model (imod_combine Imod (imod_subclass name supertype objects fid))"
proof (intro imod_combine_merge_no_containment_imod2_correct)
  show "instance_model (imod_subclass name supertype objects fid)"
    using assms imod_subclass_correct
    by blast
next
  fix ob
  assume ob_in_imod: "ob \<in> Object Imod"
  assume "ob \<in> Object (imod_subclass name supertype objects fid)"
  then have "ob \<in> objects"
    unfolding imod_subclass_def
    by simp
  then show "ObjectClass Imod ob = ObjectClass (imod_subclass name supertype objects fid) ob"
    using new_objects ob_in_imod
    by blast
next
  fix ob
  assume ob_in_imod: "ob \<in> Object Imod"
  assume "ob \<in> Object (imod_subclass name supertype objects fid)"
  then have "ob \<in> objects"
    unfolding imod_subclass_def
    by simp
  then show "ObjectId Imod ob = ObjectId (imod_subclass name supertype objects fid) ob"
    using new_objects ob_in_imod
    by blast
next
  have type_model_correct: "type_model (tmod_combine (Tm Imod) (tmod_subclass name supertype))"
    using tmod_subclass_combine_correct assms instance_model.validity_type_model_consistent
    by metis
  fix ob f
  assume "ob \<in> Object (imod_subclass name supertype objects fid)"
  then have ob_def: "ob \<in> objects"
    by (simp add: imod_subclass_def)
  then have ob_type_def: "ObjectClass (imod_combine Imod (imod_subclass name supertype objects fid)) ob = name"
    unfolding imod_subclass_def imod_combine_def imod_combine_object_class_def
    using new_objects
    by auto
  assume f_in_field_tmod: "f \<in> Field (Tm Imod)"
  then have f_class_not_supertype: "fst f \<noteq> supertype"
  proof (induct "fst f = supertype")
    case True
    then have "\<exclamdown>(fst f) \<in> ProperClassType (Tm Imod)"
      using ProperClassType.simps assms(1) instance_model.validity_type_model_consistent type_model.structure_field_wellformed_class
      by blast
    then have "\<exclamdown>(fst f) \<in> Type (Tm Imod)"
      unfolding Type_def NonContainerType_def ClassType_def
      by blast
    then have "f \<in> Type_Model.fields (Tm Imod) supertype"
      unfolding Type_Model.fields_def subtype_def
      using True.hyps True.prems subtype_rel.reflexivity
      by fastforce
    then show ?case
      by (simp add: no_fields_supertype)
  next
    case False
    then show ?case
      by simp
  qed
  have supertype_not_inherits_f: "(supertype, fst f) \<notin> (Inh (Tm Imod) \<union> {(name, supertype)})\<^sup>+"
  proof-
    have "\<not>\<exclamdown>supertype \<sqsubseteq>[Tm Imod] \<exclamdown>(fst f)"
    proof
      assume "\<exclamdown>supertype \<sqsubseteq>[Tm Imod] \<exclamdown>(fst f)"
      then have "f \<in> Type_Model.fields (Tm Imod) supertype"
        using f_in_field_tmod
        unfolding Type_Model.fields_def
        by fastforce
      then show "False"
        using no_fields_supertype
        by blast
    qed
    then have not_in_altdef: "(\<exclamdown>supertype, \<exclamdown>(fst f)) \<notin> subtype_rel_altdef (Tm Imod)"
      unfolding subtype_def
      by (simp add: assms(1) instance_model.validity_type_model_consistent subtype_rel_alt type_model.structure_inh_wellformed_classes)
    have "(supertype, fst f) \<in> (Inh (Tm Imod))\<^sup>+ \<Longrightarrow> (\<exclamdown>supertype, \<exclamdown>(fst f)) \<in> subtype_rel_altdef (Tm Imod)"
    proof-
      assume "(supertype, fst f) \<in> (Inh (Tm Imod))\<^sup>+"
      then have "(\<exclamdown>supertype, \<exclamdown>(fst f)) \<in> subtype_conv proper proper ` (Inh (Tm Imod))\<^sup>+"
        unfolding subtype_conv_def
        by force
      then show "(\<exclamdown>supertype, \<exclamdown>(fst f)) \<in> subtype_rel_altdef (Tm Imod)"
        unfolding subtype_rel_altdef_def
        by blast
    qed
    then have not_in_inh: "(supertype, fst f) \<notin> (Inh (Tm Imod))\<^sup>+"
      using not_in_altdef
      by blast
    have "(supertype, fst f) \<in> (Inh (Tm Imod) \<union> {(name, supertype)})\<^sup>+ \<Longrightarrow> (supertype, fst f) \<in> (Inh (Tm Imod))\<^sup>+"
    proof-
      assume "(supertype, fst f) \<in> (Inh (Tm Imod) \<union> {(name, supertype)})\<^sup>+"
      then show "(supertype, fst f) \<in> (Inh (Tm Imod))\<^sup>+"
      proof (induct)
        case (base y)
        then show ?case
          using name_supertype_neq
          by blast
      next
        case (step y z)
        then show ?case
        proof (elim UnE)
          assume "(y, z) \<in> Inh (Tm Imod)"
          then show ?thesis
            using step.hyps(3)
            by fastforce
        next
          assume "(y, z) \<in> {(name, supertype)}"
          then show ?thesis
            using Pair_inject irrefl_def singletonD step.hyps tmod_combine_def tmod_subclass_def type_model_correct
            using trancl.trancl_into_trancl type_model.property_inh_wellformed_trancl_irrefl type_model.select_convs(7)
            by metis
        qed
      qed
    qed
    then show ?thesis
      using not_in_inh
      by blast
  qed
  assume "\<exclamdown>(ObjectClass (imod_combine Imod (imod_subclass name supertype objects fid)) ob)
    \<sqsubseteq>[Tm (imod_combine Imod (imod_subclass name supertype objects fid))]
    \<exclamdown>(class (Tm (imod_combine Imod (imod_subclass name supertype objects fid))) f)"
  then have name_extends_field_class: "\<exclamdown>name \<sqsubseteq>[tmod_combine (Tm Imod) (tmod_subclass name supertype)] \<exclamdown>(fst f)"
    using ob_type_def
    unfolding class_def imod_combine_def imod_subclass_def
    by simp
  have "\<not>(\<exclamdown>name \<sqsubseteq>[tmod_combine (Tm Imod) (tmod_subclass name supertype)] \<exclamdown>(fst f))"
  proof
    assume "\<exclamdown>name \<sqsubseteq>[tmod_combine (Tm Imod) (tmod_subclass name supertype)] \<exclamdown>(fst f)"
    then have "(\<exclamdown>name, \<exclamdown>(fst f)) \<in> subtype_rel_altdef (tmod_combine (Tm Imod) (tmod_subclass name supertype))"
      unfolding subtype_def
      by (simp add: subtype_rel_alt type_model.structure_inh_wellformed_classes type_model_correct)
    then show "False"
      unfolding subtype_rel_altdef_def
    proof (elim UnE)
      assume "(\<exclamdown>name, \<exclamdown>(fst f)) \<in> subtype_tuple ` Type (tmod_combine (Tm Imod) (tmod_subclass name supertype))"
      then have "name = fst f"
        unfolding subtype_tuple_def
        by blast
      then show ?thesis
        using UnI1 assms(1) f_in_field_tmod instance_model.validity_type_model_consistent new_subclass type_model.structure_field_wellformed_class
        by metis
    next
      assume "(\<exclamdown>name, \<exclamdown>(fst f)) \<in> subtype_conv nullable nullable ` (Inh (tmod_combine (Tm Imod) (tmod_subclass name supertype)))\<^sup>+"
      then show ?thesis
        unfolding subtype_conv_def
        by blast
    next
      assume "(\<exclamdown>name, \<exclamdown>(fst f)) \<in> subtype_conv proper proper ` (Inh (tmod_combine (Tm Imod) (tmod_subclass name supertype)))\<^sup>+"
      then have "(name, fst f) \<in> (Inh (tmod_combine (Tm Imod) (tmod_subclass name supertype)))\<^sup>+"
        unfolding subtype_conv_def
        by fastforce
      then have name_subtype: "(name, fst f) \<in> (Inh (Tm Imod) \<union> {(name, supertype)})\<^sup>+"
        unfolding tmod_combine_def tmod_subclass_def
        by simp
      have name_inherits_supertype: "\<And>x. (name, x) \<in> Inh (Tm Imod) \<union> {(name, supertype)} \<Longrightarrow> x = supertype"
      proof (elim UnE)
        fix x
        assume "(name, x) \<in> Inh (Tm Imod)"
        then show "x = supertype"
          using UnI1 assms(1) instance_model.validity_type_model_consistent new_subclass type_model.structure_inh_wellformed_alt
          by metis
      next
        fix x
        assume "(name, x) \<in> {(name, supertype)}"
        then show "x = supertype"
          by simp
      qed
      have "(supertype, fst f) \<in> (Inh (Tm Imod) \<union> {(name, supertype)})\<^sup>+"
        using name_subtype
      proof (cases)
        case base
        then show ?thesis
          using f_class_not_supertype name_inherits_supertype
          by blast
      next
        case (step c)
        then show ?thesis
          using converse_tranclE f_class_not_supertype name_inherits_supertype name_subtype
          by metis
      qed
      then show ?thesis
        using supertype_not_inherits_f
        by blast
    next
      assume "(\<exclamdown>name, \<exclamdown>(fst f)) \<in> subtype_conv proper nullable ` subtype_tuple ` Class (tmod_combine (Tm Imod) (tmod_subclass name supertype))"
      then show ?thesis
        unfolding subtype_conv_def
        by blast
    next
      assume "(\<exclamdown>name, \<exclamdown>(fst f)) \<in> subtype_conv proper nullable ` (Inh (tmod_combine (Tm Imod) (tmod_subclass name supertype)))\<^sup>+"
      then show ?thesis
        unfolding subtype_conv_def
        by blast
    qed
  qed
  then show "ob \<in> Object Imod \<and> \<exclamdown>(ObjectClass Imod ob) \<sqsubseteq>[Tm Imod] \<exclamdown>(class (Tm Imod) f)"
    using name_extends_field_class
    by blast
next
  have type_model_correct: "type_model (tmod_combine (Tm Imod) (tmod_subclass name supertype))"
    using tmod_subclass_combine_correct assms instance_model.validity_type_model_consistent
    by metis
  fix ob f
  assume ob_in_imod: "ob \<in> Object Imod"
  then have ob_class_def: "ObjectClass (imod_combine Imod (imod_subclass name supertype objects fid)) ob = ObjectClass Imod ob"
    unfolding imod_combine_def imod_subclass_def imod_combine_object_class_def
    using new_objects
    by auto
  then have ob_class_not_name: "ObjectClass Imod ob \<noteq> name"
    using assms(1) instance_model.structure_object_class_wellformed new_subclass ob_in_imod
    by fastforce
  assume f_in_field: "f \<in> Field (Tm Imod)"
  then have f_class_in_imod: "fst f \<in> Class (Tm Imod)"
    by (simp add: assms(1) instance_model.validity_type_model_consistent type_model.structure_field_wellformed_class)
  assume "\<exclamdown>(ObjectClass (imod_combine Imod (imod_subclass name supertype objects fid)) ob)
    \<sqsubseteq>[Tm (imod_combine Imod (imod_subclass name supertype objects fid))]
    \<exclamdown>(class (Tm (imod_combine Imod (imod_subclass name supertype objects fid))) f)"
  then have "\<exclamdown>(ObjectClass Imod ob) \<sqsubseteq>[tmod_combine (Tm Imod) (tmod_subclass name supertype)] \<exclamdown>(fst f)"
    using ob_class_def
    unfolding class_def imod_combine_def imod_subclass_def
    by simp
  then have "(\<exclamdown>(ObjectClass Imod ob), \<exclamdown>(fst f)) \<in> subtype_rel_altdef (tmod_combine (Tm Imod) (tmod_subclass name supertype))"
    unfolding subtype_def
    by (simp add: subtype_rel_alt type_model.structure_inh_wellformed_classes type_model_correct)
  then have "(\<exclamdown>(ObjectClass Imod ob), \<exclamdown>(fst f)) \<in>
    subtype_tuple ` Type (tmod_combine (Tm Imod) (tmod_subclass name supertype)) \<union>
    subtype_conv nullable nullable ` (Inh (tmod_combine (Tm Imod) (tmod_subclass name supertype)))\<^sup>+ \<union>
    subtype_conv proper proper ` (Inh (tmod_combine (Tm Imod) (tmod_subclass name supertype)))\<^sup>+ \<union>
    subtype_conv proper nullable ` subtype_tuple ` Class (tmod_combine (Tm Imod) (tmod_subclass name supertype)) \<union>
    subtype_conv proper nullable ` (Inh (tmod_combine (Tm Imod) (tmod_subclass name supertype)))\<^sup>+"
    unfolding subtype_rel_altdef_def
    by simp
  then have "(\<exclamdown>(ObjectClass Imod ob), \<exclamdown>(fst f)) \<in> subtype_rel_altdef (Tm Imod)"
  proof (elim UnE)
    assume "(\<exclamdown>(ObjectClass Imod ob), \<exclamdown>(fst f)) \<in> subtype_tuple ` Type (tmod_combine (Tm Imod) (tmod_subclass name supertype))"
    then have eq: "ObjectClass Imod ob = fst f"
      unfolding subtype_tuple_def
      by fastforce
    have "\<exclamdown>(ObjectClass Imod ob) \<in> ProperClassType (Tm Imod)"
      by (simp add: ProperClassType.rule_proper_classes assms(1) instance_model.structure_object_class_wellformed ob_in_imod)
    then have "\<exclamdown>(ObjectClass Imod ob) \<in> Type (Tm Imod)"
      unfolding Type_def NonContainerType_def ClassType_def
      by simp
    then have "(\<exclamdown>(ObjectClass Imod ob), \<exclamdown>(fst f)) \<in> subtype_tuple ` Type (Tm Imod)"
      by (simp add: eq subtype_tuple_def)
    then show ?thesis
      unfolding subtype_rel_altdef_def
      by simp
  next
    assume "(\<exclamdown>(ObjectClass Imod ob), \<exclamdown>(fst f)) \<in> subtype_conv nullable nullable ` (Inh (tmod_combine (Tm Imod) (tmod_subclass name supertype)))\<^sup>+"
    then show ?thesis
      unfolding subtype_conv_def
      by blast
  next
    assume "(\<exclamdown>(ObjectClass Imod ob), \<exclamdown>(fst f)) \<in> subtype_conv proper proper ` (Inh (tmod_combine (Tm Imod) (tmod_subclass name supertype)))\<^sup>+"
    then have "(ObjectClass Imod ob, fst f) \<in> (Inh (tmod_combine (Tm Imod) (tmod_subclass name supertype)))\<^sup>+"
      unfolding subtype_conv_def
      by fastforce
    then have "(ObjectClass Imod ob, fst f) \<in> (Inh (Tm Imod) \<union> {(name, supertype)})\<^sup>+"
      unfolding tmod_combine_def tmod_subclass_def
      by simp
    then have "(ObjectClass Imod ob, fst f) \<in> (Inh (Tm Imod))\<^sup>+"
    proof (induct)
      case (base y)
      then show ?case
        by (simp add: ob_class_not_name)
    next
      case (step y z)
      then have "y \<noteq> name"
        using UnI1 assms(1) instance_model.validity_type_model_consistent new_subclass trancl.simps type_model.structure_inh_wellformed_alt
        by metis
      then show ?case
        using step.hyps(2) step.hyps(3)
        by simp
    qed
    then have "(\<exclamdown>(ObjectClass Imod ob), \<exclamdown>(fst f)) \<in> subtype_conv proper proper ` (Inh (Tm Imod))\<^sup>+"
      unfolding subtype_conv_def
      by force
    then show ?thesis
      by (simp add: subtype_rel_altdef_def)
  next
    assume "(\<exclamdown>(ObjectClass Imod ob), \<exclamdown>(fst f)) \<in> subtype_conv proper nullable ` subtype_tuple ` Class (tmod_combine (Tm Imod) (tmod_subclass name supertype))"
    then show ?thesis
      unfolding subtype_conv_def
      by blast
  next
    assume "(\<exclamdown>(ObjectClass Imod ob), \<exclamdown>(fst f)) \<in> subtype_conv proper nullable ` (Inh (tmod_combine (Tm Imod) (tmod_subclass name supertype)))\<^sup>+"
    then show ?thesis
      unfolding subtype_conv_def
      by blast
  qed
  then show "\<exclamdown>(ObjectClass Imod ob) \<sqsubseteq>[Tm Imod] \<exclamdown>(class (Tm Imod) f)"
    unfolding class_def
    by (simp add: assms(1) instance_model.validity_type_model_consistent subtype_def subtype_rel_alt type_model.structure_inh_wellformed_classes)
next
  have "type_model (tmod_combine (Tm Imod) (tmod_subclass name supertype))"
    using tmod_subclass_combine_correct assms instance_model.validity_type_model_consistent
    by metis
  then show "type_model (tmod_combine (Tm Imod) (Tm (imod_subclass name supertype objects fid)))"
    unfolding imod_subclass_def
    by simp
qed (simp_all add: assms imod_subclass_def tmod_subclass_def)

section "Encoding of a Slass as Node Type in GROOVE"

definition ig_subclass_as_node_type :: "'t Id \<Rightarrow> 't Id \<Rightarrow> 'o set \<Rightarrow> ('o \<Rightarrow> 't) \<Rightarrow> ('o, 't list, 't) instance_graph" where
  "ig_subclass_as_node_type name supertype objects fid = \<lparr>
    TG = tg_subclass_as_node_type name supertype,
    Id = fid ` objects,
    N = typed (type (id_to_list name)) ` objects,
    E = {},
    ident = (\<lambda>x. if x \<in> fid ` objects then typed (type (id_to_list name)) (THE y. fid y = x) else undefined)
  \<rparr>"

lemma ig_subclass_as_node_type_correct:
  assumes unique_ids: "\<And>o1 o2. o1 \<in> objects \<Longrightarrow> fid o1 = fid o2 \<Longrightarrow> o1 = o2"
  shows "instance_graph (ig_subclass_as_node_type name supertype objects fid)"
proof (intro instance_graph.intro)
  fix n
  assume "n \<in> N (ig_subclass_as_node_type name supertype objects fid)"
  then have "n \<in> typed (type (id_to_list name)) ` objects"
    unfolding ig_subclass_as_node_type_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_subclass_as_node_type name supertype objects fid)"
  then have i_in_id: "i \<in> fid ` objects"
    unfolding ig_subclass_as_node_type_def
    by simp
  then show "ident (ig_subclass_as_node_type name supertype objects fid) i \<in> N (ig_subclass_as_node_type name supertype objects fid) \<and> type\<^sub>n (ident (ig_subclass_as_node_type name supertype objects fid) i) \<in> Lab\<^sub>t"
  proof (intro conjI)
    assume "i \<in> fid ` objects"
    then have "(THE y. fid y = i) \<in> objects"
    proof
      fix x
      assume i_def: "i = fid x"
      assume x_is_object: "x \<in> objects"
      have "(THE y. fid y = fid x) \<in> objects"
      proof (rule the1I2)
        show "\<exists>!y. fid y = fid x"
          using unique_ids x_is_object
          by metis
      next
        fix y
        assume "fid y = fid x"
        then show "y \<in> objects"
          using unique_ids x_is_object
          by metis
      qed
      then show "(THE y. fid y = i) \<in> objects"
        by (simp add: i_def)
    qed
    then have "typed (type (id_to_list name)) (THE y. fid y = i) \<in> typed (type (id_to_list name)) ` objects"
      by simp
    then show "ident (ig_subclass_as_node_type name supertype objects fid) i \<in> N (ig_subclass_as_node_type name supertype objects fid)"
      unfolding ig_subclass_as_node_type_def
      using i_in_id
      by simp
  next
    have "type\<^sub>n (typed (type (id_to_list name)) (THE y. fid y = i)) = type (id_to_list name)"
      by simp
    then have "type\<^sub>n (typed (type (id_to_list name)) (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_subclass_as_node_type name supertype objects fid) i) \<in> Lab\<^sub>t"
      unfolding ig_subclass_as_node_type_def
      using i_in_id
      by simp
  qed
next
  show "type_graph (TG (ig_subclass_as_node_type name supertype objects fid))"
    unfolding ig_subclass_as_node_type_def
    using tg_subclass_as_node_type_correct
    by simp
next
  fix n
  assume "n \<in> N (ig_subclass_as_node_type name supertype objects fid)"
  then have "n \<in> typed (type (id_to_list name)) ` objects"
    unfolding ig_subclass_as_node_type_def
    by simp
  then have "type\<^sub>n n = type (id_to_list name)"
    by auto
  then show "type\<^sub>n n \<in> NT (TG (ig_subclass_as_node_type name supertype objects fid))"
    unfolding ig_subclass_as_node_type_def tg_subclass_as_node_type_def
    by simp
next
  fix p
  show "\<not>pre_digraph.cycle (instance_graph_containment_proj (ig_subclass_as_node_type name supertype objects fid)) p"
    unfolding ig_subclass_as_node_type_def instance_graph_containment_proj_def pre_digraph.cycle_def pre_digraph.awalk_def
    by simp
qed (simp_all add: assms ig_subclass_as_node_type_def tg_subclass_as_node_type_def)

lemma ig_subclass_as_node_type_combine_correct:
  assumes "instance_graph IG"
  assumes name_supertype_neq: "name \<noteq> supertype"
  assumes combined_type: "NT (TG IG) \<inter> {type (id_to_list supertype), type (id_to_list name)} = {type (id_to_list supertype)}"
  assumes no_src_edge_types: "\<And>et. et \<in> ET (TG IG) \<Longrightarrow> (type (id_to_list supertype), src et) \<notin> inh (TG IG)"
  assumes no_tgt_edge_types: "\<And>et. et \<in> ET (TG IG) \<Longrightarrow> (type (id_to_list supertype), tgt et) \<notin> inh (TG IG)"
  assumes unique_ids: "\<And>o1 o2. o1 \<in> objects \<Longrightarrow> fid o1 = fid o2 \<Longrightarrow> o1 = o2"
  assumes new_ids: "Id IG \<inter> fid ` objects = {}"
  shows "instance_graph (ig_combine IG (ig_subclass_as_node_type name supertype objects fid))"
proof (intro ig_combine_merge_no_containment_imod2_correct)
  show "instance_graph (ig_subclass_as_node_type name supertype objects fid)"
    using unique_ids
    by (fact ig_subclass_as_node_type_correct)
next
  fix i
  assume "i \<in> Id IG"
  then have i_not_in_ids: "i \<notin> fid ` objects"
    using new_ids
    by auto
  assume "i \<in> Id (ig_subclass_as_node_type name supertype objects fid)"
  then have "i \<in> fid ` objects"
    unfolding ig_subclass_as_node_type_def
    by simp
  then show "ident IG i = ident (ig_subclass_as_node_type name supertype objects fid) i"
    using i_not_in_ids
    by blast
next
  have "type_graph (tg_combine (TG IG) (tg_subclass_as_node_type name supertype))"
    using tg_subclass_as_node_type_combine_correct assms
    by (simp add: tg_subclass_as_node_type_combine_correct instance_graph.validity_type_graph)
  then show "type_graph (tg_combine (TG IG) (TG (ig_subclass_as_node_type name supertype objects fid)))"
    by (simp add: ig_subclass_as_node_type_def)
next
  have name_not_in_tg: "type (id_to_list name) \<notin> NT (TG IG)"
    using Int_insert_right_if1 doubleton_eq_iff id_to_list_inverse insert_absorb2 unlabel.simps(1) combined_type name_supertype_neq
    by metis
  fix et n
  assume et_def: "et \<in> ET (TG IG)"
  then have src_et_def: "src et \<in> NT (TG IG)"
    using assms(1) instance_graph.validity_type_graph type_graph.structure_edges_wellformed_alt
    by blast
  then have src_et_not_name: "src et \<noteq> type (id_to_list name)"
    using name_not_in_tg
    by fastforce
  have src_et_not_supertype: "src et \<noteq> type (id_to_list supertype)"
    using no_src_edge_types src_et_def assms(1) et_def instance_graph.validity_type_graph type_graph.validity_inh_node
    by metis
  have no_supertype_inh: "(type (id_to_list supertype), src et) \<notin> (inh (TG IG) \<union>
    {(type (id_to_list name), type (id_to_list name)),
    (type (id_to_list name), type (id_to_list supertype))})\<^sup>+"
  proof
    assume "(type (id_to_list supertype), src et) \<in> (inh (TG IG) \<union>
      {(type (id_to_list name), type (id_to_list name)),
      (type (id_to_list name), type (id_to_list supertype))})\<^sup>+"
    then show "False"
    proof (cases)
      case base
      then have "(LabDef.type (id_to_list supertype), src et) \<in> inh (TG IG)"
        using Pair_inject src_et_not_name
        by auto
      then show ?thesis
        using et_def no_src_edge_types
        by blast
    next
      case (step c)
      have "(LabDef.type (id_to_list supertype), c) \<in> (inh (TG IG))\<^sup>+"
        using step(1)
      proof (induct)
        case (base y)
        then show ?case
          using combined_type insertE name_not_in_tg
          by fastforce
      next
        case (step y z)
        then have "y \<in> NT (TG IG)"
          using assms(1) instance_graph.validity_type_graph trancl.simps type_graph.structure_inheritance_wellformed_second_node
          by metis
        then have "y \<noteq> type (id_to_list name)"
          using name_not_in_tg
          by blast
        then have "(y, z) \<in> inh (TG IG)"
          using step.hyps
          by simp
        then show ?case
          using step.hyps(3)
          by simp
      qed
      then have fst_tuple_def: "(LabDef.type (id_to_list supertype), c) \<in> inh (TG IG)"
        using assms(1) instance_graph.validity_type_graph type_graph.validity_inh_trans
        by fastforce
      then have "c \<in> NT (TG IG)"
        using assms(1) instance_graph.validity_type_graph type_graph.structure_inheritance_wellformed_second_node
        by metis
      then have "c \<noteq> type (id_to_list name)"
        using name_not_in_tg
        by blast
      then have "(c, src et) \<in> inh (TG IG)"
        using step(2)
        by simp
      then show ?thesis
        using transE fst_tuple_def et_def no_src_edge_types assms(1) instance_graph.validity_type_graph type_graph.validity_inh_trans
        by metis
    qed
  qed
  assume "n \<in> N IG \<union> N (ig_subclass_as_node_type name supertype objects fid)"
  then have n_def: "n \<in> N IG \<union> typed (type (id_to_list name)) ` objects"
    by (simp add: ig_subclass_as_node_type_def)
  assume "(type\<^sub>n n, src et) \<in> (inh (TG IG) \<union> inh (TG (ig_subclass_as_node_type name supertype objects fid)))\<^sup>+"
  then have inh_unfold_def: "(type\<^sub>n n, src et) \<in> (inh (TG IG) \<union>
    {(type (id_to_list name), type (id_to_list name)),
    (type (id_to_list supertype), type (id_to_list supertype)),
    (type (id_to_list name), type (id_to_list supertype))})\<^sup>+"
    unfolding ig_subclass_as_node_type_def tg_subclass_as_node_type_def
    by simp
  have supertype_refl: "(type (id_to_list supertype), type (id_to_list supertype)) \<in> inh (TG IG)"
    using assms(1) combined_type instance_graph.validity_type_graph type_graph.validity_inh_node
    by fastforce
  then have inh_def: "(type\<^sub>n n, src et) \<in> (inh (TG IG) \<union>
    {(type (id_to_list name), type (id_to_list name)),
    (type (id_to_list name), type (id_to_list supertype))})\<^sup>+"
    using inh_unfold_def
    by (simp add: insert_absorb)
  show "card {e \<in> E IG. src e = n \<and> type\<^sub>e e = et} in m_out (mult (TG IG) et)"
    using n_def
  proof (elim UnE)
    assume n_in_ig: "n \<in> N IG"
    then have type_n_not_name: "type\<^sub>n n \<noteq> type (id_to_list name)"
      using IntI Un_insert_left Un_insert_right assms(1) combined_type id_to_list_inverse insertI1
      using instance_graph.validity_node_typed name_supertype_neq singletonD sup_bot.right_neutral unlabel.simps(1)
      by metis
    have "(type\<^sub>n n, src et) \<in> (inh (TG IG))\<^sup>+"
      using inh_def
    proof (cases)
      case base
      then show ?thesis
        using type_n_not_name
        by simp
    next
      case (step c)
      have fst_tuple_def: "(type\<^sub>n n, c) \<in> (inh (TG IG))\<^sup>+"
        using step(1)
      proof (induct)
        case (base y)
        then show ?case
          using type_n_not_name
          by simp
      next
        case (step y z)
        then have "y \<in> NT (TG IG)"
          using assms(1) instance_graph.validity_type_graph trancl.simps type_graph.structure_inheritance_wellformed_second_node
          by metis
        then have "y \<noteq> type (id_to_list name)"
          using name_not_in_tg
          by blast
        then have "(y, z) \<in> inh (TG IG)"
          using step.hyps
          by simp
        then show ?case
          using step.hyps(3)
          by simp
      qed
      then have "c \<in> NT (TG IG)"
        using assms(1) instance_graph.validity_type_graph trancl.simps type_graph.structure_inheritance_wellformed_second_node
        by metis
      then have "c \<noteq> type (id_to_list name)"
        using name_not_in_tg
        by blast
      then have "(c, src et) \<in> inh (TG IG)"
        using step(2)
        by simp
      then show ?thesis
        using fst_tuple_def
        by simp
    qed
    then have "(type\<^sub>n n, src et) \<in> inh (TG IG)"
      using assms(1) instance_graph.validity_type_graph type_graph.validity_inh_trans
      by fastforce
    then show ?thesis
      using assms(1) instance_graph.validity_outgoing_mult n_in_ig et_def
      by blast
  next
    assume n_in_typed: "n \<in> typed (LabDef.type (id_to_list name)) ` objects"
    then have type_n_is_name: "type\<^sub>n n = type (id_to_list name)"
      by fastforce
    have name_inherits_supertype: "\<And>x. (type\<^sub>n n, x) \<in> (inh (TG IG) \<union>
      {(type (id_to_list name), type (id_to_list name)),
      (type (id_to_list name), type (id_to_list supertype))}) \<Longrightarrow>
      x = type (id_to_list name) \<or> x = type (id_to_list supertype)"
    proof-
      fix x
      assume "(type\<^sub>n n, x) \<in> (inh (TG IG) \<union>
        {(type (id_to_list name), type (id_to_list name)),
        (type (id_to_list name), type (id_to_list supertype))})"
      then show "x = type (id_to_list name) \<or> x = type (id_to_list supertype)"
      proof (elim UnE)
        assume "(type\<^sub>n n, x) \<in> inh (TG IG)"
        then have "type\<^sub>n n \<in> NT (TG IG)"
          by (simp add: assms(1) instance_graph.validity_type_graph type_graph.structure_inheritance_wellformed_first_node)
        then show ?thesis
          using name_not_in_tg type_n_is_name
          by simp
      next
        assume "(type\<^sub>n n, x) \<in> {(type (id_to_list name), type (id_to_list name)), (type (id_to_list name), type (id_to_list supertype))}"
        then show ?thesis
          by blast
      qed
    qed
    have "(type\<^sub>n n, src et) \<notin> (inh (TG IG) \<union>
      {(type (id_to_list name), type (id_to_list name)),
      (type (id_to_list name), type (id_to_list supertype))})\<^sup>+"
    proof
      assume "(type\<^sub>n n, src et) \<in> (inh (TG IG) \<union>
        {(type (id_to_list name), type (id_to_list name)),
        (type (id_to_list name), type (id_to_list supertype))})\<^sup>+"
      then show "False"
      proof (cases)
        case base
        then have "(type\<^sub>n n, src et) \<in> {(LabDef.type (id_to_list name), LabDef.type (id_to_list name)), (LabDef.type (id_to_list name), LabDef.type (id_to_list supertype))}"
          using assms(1) instance_graph.validity_type_graph type_graph.structure_inheritance_wellformed_first_node trancl.simps type_n_is_name name_not_in_tg
          by fastforce
        then show ?thesis
          using src_et_not_name src_et_not_supertype
          by blast
      next
        case (step c)
        then have snd_tuple_def: "(c, src et) \<in> inh (TG IG)"
          using src_et_not_name src_et_not_supertype
          by blast
        then have "c \<in> NT (TG IG)"
          using assms(1) instance_graph.validity_type_graph type_graph.structure_inheritance_wellformed_first_node
          by fastforce
        then have c_neq_name: "c \<noteq> type (id_to_list name)"
          using name_not_in_tg
          by blast
        have "(type (id_to_list supertype), c) \<in> (inh (TG IG) \<union>
          {(type (id_to_list name), type (id_to_list name)),
          (type (id_to_list name), type (id_to_list supertype))})\<^sup>+ \<or> c = type (id_to_list name)"
          using step(1)
        proof (induct)
          case (base y)
          then have "y = type (id_to_list name) \<or> y = type (id_to_list supertype)"
            using name_inherits_supertype
            by simp
          then show ?case
            using supertype_refl
            by blast
        next
          case (step y z)
          then show ?case
          proof (elim disjE)
            assume "(LabDef.type (id_to_list supertype), y) \<in>
              (inh (TG IG) \<union> {(LabDef.type (id_to_list name), LabDef.type (id_to_list name)), (LabDef.type (id_to_list name), LabDef.type (id_to_list supertype))})\<^sup>+"
            then show ?thesis
              using step.hyps(2) trancl.trancl_into_trancl
              by force
          next
            assume "y = LabDef.type (id_to_list name)"
            then show ?thesis
              using name_inherits_supertype step.hyps(2) supertype_refl type_n_is_name
              by fastforce
          qed
        qed
        then have "(type (id_to_list supertype), c) \<in> (inh (TG IG) \<union>
          {(type (id_to_list name), type (id_to_list name)),
          (type (id_to_list name), type (id_to_list supertype))})\<^sup>+"
          using c_neq_name
          by blast
        then have "(type (id_to_list supertype), src et) \<in> (inh (TG IG) \<union>
          {(type (id_to_list name), type (id_to_list name)),
          (type (id_to_list name), type (id_to_list supertype))})\<^sup>+"
          using snd_tuple_def
          by (simp add: trancl.trancl_into_trancl)
        then show ?thesis
          using no_supertype_inh
          by blast
      qed
    qed
    then show ?thesis
      using inh_def
      by blast
  qed
next
  have name_not_in_tg: "type (id_to_list name) \<notin> NT (TG IG)"
    using Int_insert_right_if1 doubleton_eq_iff id_to_list_inverse insert_absorb2 unlabel.simps(1) combined_type name_supertype_neq
    by metis
  fix et n
  assume et_def: "et \<in> ET (TG IG)"
  then have tgt_et_def: "tgt et \<in> NT (TG IG)"
    using assms(1) instance_graph.validity_type_graph type_graph.structure_edges_wellformed_alt
    by blast
  then have tgt_et_not_name: "tgt et \<noteq> type (id_to_list name)"
    using name_not_in_tg
    by fastforce
  have tgt_et_not_supertype: "tgt et \<noteq> type (id_to_list supertype)"
    using no_tgt_edge_types tgt_et_def assms(1) et_def instance_graph.validity_type_graph type_graph.validity_inh_node
    by metis
  have no_supertype_inh: "(type (id_to_list supertype), tgt et) \<notin> (inh (TG IG) \<union>
    {(type (id_to_list name), type (id_to_list name)),
    (type (id_to_list name), type (id_to_list supertype))})\<^sup>+"
  proof
    assume "(type (id_to_list supertype), tgt et) \<in> (inh (TG IG) \<union>
      {(type (id_to_list name), type (id_to_list name)),
      (type (id_to_list name), type (id_to_list supertype))})\<^sup>+"
    then show "False"
    proof (cases)
      case base
      then have "(LabDef.type (id_to_list supertype), tgt et) \<in> inh (TG IG)"
        using Pair_inject tgt_et_not_name
        by auto
      then show ?thesis
        using et_def no_tgt_edge_types
        by blast
    next
      case (step c)
      have "(LabDef.type (id_to_list supertype), c) \<in> (inh (TG IG))\<^sup>+"
        using step(1)
      proof (induct)
        case (base y)
        then show ?case
          using combined_type insertE name_not_in_tg
          by fastforce
      next
        case (step y z)
        then have "y \<in> NT (TG IG)"
          using assms(1) instance_graph.validity_type_graph trancl.simps type_graph.structure_inheritance_wellformed_second_node
          by metis
        then have "y \<noteq> type (id_to_list name)"
          using name_not_in_tg
          by blast
        then have "(y, z) \<in> inh (TG IG)"
          using step.hyps
          by simp
        then show ?case
          using step.hyps(3)
          by simp
      qed
      then have fst_tuple_def: "(LabDef.type (id_to_list supertype), c) \<in> inh (TG IG)"
        using assms(1) instance_graph.validity_type_graph type_graph.validity_inh_trans
        by fastforce
      then have "c \<in> NT (TG IG)"
        using assms(1) instance_graph.validity_type_graph type_graph.structure_inheritance_wellformed_second_node
        by metis
      then have "c \<noteq> type (id_to_list name)"
        using name_not_in_tg
        by blast
      then have "(c, tgt et) \<in> inh (TG IG)"
        using step(2)
        by simp
      then show ?thesis
        using transE fst_tuple_def et_def no_tgt_edge_types assms(1) instance_graph.validity_type_graph type_graph.validity_inh_trans
        by metis
    qed
  qed
  assume "n \<in> N IG \<union> N (ig_subclass_as_node_type name supertype objects fid)"
  then have n_def: "n \<in> N IG \<union> typed (type (id_to_list name)) ` objects"
    by (simp add: ig_subclass_as_node_type_def)
  assume "(type\<^sub>n n, tgt et) \<in> (inh (TG IG) \<union> inh (TG (ig_subclass_as_node_type name supertype objects fid)))\<^sup>+"
  then have inh_unfold_def: "(type\<^sub>n n, tgt et) \<in> (inh (TG IG) \<union>
    {(type (id_to_list name), type (id_to_list name)),
    (type (id_to_list supertype), type (id_to_list supertype)),
    (type (id_to_list name), type (id_to_list supertype))})\<^sup>+"
    unfolding ig_subclass_as_node_type_def tg_subclass_as_node_type_def
    by simp
  have supertype_refl: "(type (id_to_list supertype), type (id_to_list supertype)) \<in> inh (TG IG)"
    using assms(1) combined_type instance_graph.validity_type_graph type_graph.validity_inh_node
    by fastforce
  then have inh_def: "(type\<^sub>n n, tgt et) \<in> (inh (TG IG) \<union>
    {(type (id_to_list name), type (id_to_list name)),
    (type (id_to_list name), type (id_to_list supertype))})\<^sup>+"
    using inh_unfold_def
    by (simp add: insert_absorb)
  show "card {e \<in> E IG. tgt e = n \<and> type\<^sub>e e = et} in m_in (mult (TG IG) et)"
    using n_def
  proof (elim UnE)
    assume n_in_ig: "n \<in> N IG"
    then have type_n_not_name: "type\<^sub>n n \<noteq> type (id_to_list name)"
      using IntI Un_insert_left Un_insert_right assms(1) combined_type id_to_list_inverse insertI1
      using instance_graph.validity_node_typed name_supertype_neq singletonD sup_bot.right_neutral unlabel.simps(1)
      by metis
    have "(type\<^sub>n n, tgt et) \<in> (inh (TG IG))\<^sup>+"
      using inh_def
    proof (cases)
      case base
      then show ?thesis
        using type_n_not_name
        by simp
    next
      case (step c)
      have fst_tuple_def: "(type\<^sub>n n, c) \<in> (inh (TG IG))\<^sup>+"
        using step(1)
      proof (induct)
        case (base y)
        then show ?case
          using type_n_not_name
          by simp
      next
        case (step y z)
        then have "y \<in> NT (TG IG)"
          using assms(1) instance_graph.validity_type_graph trancl.simps type_graph.structure_inheritance_wellformed_second_node
          by metis
        then have "y \<noteq> type (id_to_list name)"
          using name_not_in_tg
          by blast
        then have "(y, z) \<in> inh (TG IG)"
          using step.hyps
          by simp
        then show ?case
          using step.hyps(3)
          by simp
      qed
      then have "c \<in> NT (TG IG)"
        using assms(1) instance_graph.validity_type_graph trancl.simps type_graph.structure_inheritance_wellformed_second_node
        by metis
      then have "c \<noteq> type (id_to_list name)"
        using name_not_in_tg
        by blast
      then have "(c, tgt et) \<in> inh (TG IG)"
        using step(2)
        by simp
      then show ?thesis
        using fst_tuple_def
        by simp
    qed
    then have "(type\<^sub>n n, tgt et) \<in> inh (TG IG)"
      using assms(1) instance_graph.validity_type_graph type_graph.validity_inh_trans
      by fastforce
    then show ?thesis
      using assms(1) instance_graph.validity_ingoing_mult n_in_ig et_def
      by blast
  next
    assume n_in_typed: "n \<in> typed (LabDef.type (id_to_list name)) ` objects"
    then have type_n_is_name: "type\<^sub>n n = type (id_to_list name)"
      by fastforce
    have name_inherits_supertype: "\<And>x. (type\<^sub>n n, x) \<in> (inh (TG IG) \<union>
      {(type (id_to_list name), type (id_to_list name)),
      (type (id_to_list name), type (id_to_list supertype))}) \<Longrightarrow>
      x = type (id_to_list name) \<or> x = type (id_to_list supertype)"
    proof-
      fix x
      assume "(type\<^sub>n n, x) \<in> (inh (TG IG) \<union>
        {(type (id_to_list name), type (id_to_list name)),
        (type (id_to_list name), type (id_to_list supertype))})"
      then show "x = type (id_to_list name) \<or> x = type (id_to_list supertype)"
      proof (elim UnE)
        assume "(type\<^sub>n n, x) \<in> inh (TG IG)"
        then have "type\<^sub>n n \<in> NT (TG IG)"
          by (simp add: assms(1) instance_graph.validity_type_graph type_graph.structure_inheritance_wellformed_first_node)
        then show ?thesis
          using name_not_in_tg type_n_is_name
          by simp
      next
        assume "(type\<^sub>n n, x) \<in> {(type (id_to_list name), type (id_to_list name)), (type (id_to_list name), type (id_to_list supertype))}"
        then show ?thesis
          by blast
      qed
    qed
    have "(type\<^sub>n n, tgt et) \<notin> (inh (TG IG) \<union>
      {(type (id_to_list name), type (id_to_list name)),
      (type (id_to_list name), type (id_to_list supertype))})\<^sup>+"
    proof
      assume "(type\<^sub>n n, tgt et) \<in> (inh (TG IG) \<union>
        {(type (id_to_list name), type (id_to_list name)),
        (type (id_to_list name), type (id_to_list supertype))})\<^sup>+"
      then show "False"
      proof (cases)
        case base
        then have "(type\<^sub>n n, tgt et) \<in> {(LabDef.type (id_to_list name), LabDef.type (id_to_list name)), (LabDef.type (id_to_list name), LabDef.type (id_to_list supertype))}"
          using assms(1) instance_graph.validity_type_graph type_graph.structure_inheritance_wellformed_first_node trancl.simps type_n_is_name name_not_in_tg
          by fastforce
        then show ?thesis
          using tgt_et_not_name tgt_et_not_supertype
          by blast
      next
        case (step c)
        then have snd_tuple_def: "(c, tgt et) \<in> inh (TG IG)"
          using tgt_et_not_name tgt_et_not_supertype
          by blast
        then have "c \<in> NT (TG IG)"
          using assms(1) instance_graph.validity_type_graph type_graph.structure_inheritance_wellformed_first_node
          by fastforce
        then have c_neq_name: "c \<noteq> type (id_to_list name)"
          using name_not_in_tg
          by blast
        have "(type (id_to_list supertype), c) \<in> (inh (TG IG) \<union>
          {(type (id_to_list name), type (id_to_list name)),
          (type (id_to_list name), type (id_to_list supertype))})\<^sup>+ \<or> c = type (id_to_list name)"
          using step(1)
        proof (induct)
          case (base y)
          then have "y = type (id_to_list name) \<or> y = type (id_to_list supertype)"
            using name_inherits_supertype
            by simp
          then show ?case
            using supertype_refl
            by blast
        next
          case (step y z)
          then show ?case
          proof (elim disjE)
            assume "(LabDef.type (id_to_list supertype), y) \<in>
              (inh (TG IG) \<union> {(LabDef.type (id_to_list name), LabDef.type (id_to_list name)), (LabDef.type (id_to_list name), LabDef.type (id_to_list supertype))})\<^sup>+"
            then show ?thesis
              using step.hyps(2) trancl.trancl_into_trancl
              by force
          next
            assume "y = LabDef.type (id_to_list name)"
            then show ?thesis
              using name_inherits_supertype step.hyps(2) supertype_refl type_n_is_name
              by fastforce
          qed
        qed
        then have "(type (id_to_list supertype), c) \<in> (inh (TG IG) \<union>
          {(type (id_to_list name), type (id_to_list name)),
          (type (id_to_list name), type (id_to_list supertype))})\<^sup>+"
          using c_neq_name
          by blast
        then have "(type (id_to_list supertype), tgt et) \<in> (inh (TG IG) \<union>
          {(type (id_to_list name), type (id_to_list name)),
          (type (id_to_list name), type (id_to_list supertype))})\<^sup>+"
          using snd_tuple_def
          by (simp add: trancl.trancl_into_trancl)
        then show ?thesis
          using no_supertype_inh
          by blast
      qed
    qed
    then show ?thesis
      using inh_def
      by blast
  qed
qed (simp_all add: ig_subclass_as_node_type_def tg_subclass_as_node_type_def assms)

subsection "Transformation functions"

definition imod_subclass_to_ig_subclass_as_node_type :: "'t Id \<Rightarrow> 't Id \<Rightarrow> ('o \<Rightarrow> 't) \<Rightarrow> ('o, 't) instance_model \<Rightarrow> ('o, 't list, 't) instance_graph" where
  "imod_subclass_to_ig_subclass_as_node_type name supertype fid Imod = \<lparr>
    TG = tg_subclass_as_node_type name supertype,
    Id = fid ` Object Imod,
    N = typed (type (id_to_list name)) ` Object Imod,
    E = {},
    ident = (\<lambda>x. if x \<in> fid ` Object Imod then typed (type (id_to_list name)) (THE y. fid y = x) else undefined)
  \<rparr>"

lemma imod_subclass_to_ig_subclass_as_node_type_proj:
  shows "imod_subclass_to_ig_subclass_as_node_type name supertype fid (imod_subclass name supertype objects fid) = ig_subclass_as_node_type name supertype objects fid"
  unfolding imod_subclass_to_ig_subclass_as_node_type_def ig_subclass_as_node_type_def imod_subclass_def
  by simp

lemma imod_subclass_to_ig_subclass_as_node_type_func:
  shows "ig_combine_mapping_function (imod_subclass_to_ig_subclass_as_node_type name supertype fid) (imod_subclass name supertype objects fid) (ig_subclass_as_node_type name supertype objects fid)"
  by (intro ig_combine_mapping_function.intro)
    (auto simp add: imod_subclass_to_ig_subclass_as_node_type_def imod_subclass_def ig_subclass_as_node_type_def imod_combine_def)

definition ig_subclass_as_node_type_to_imod_subclass :: "'t Id \<Rightarrow> 't Id \<Rightarrow> ('o \<Rightarrow> 't) \<Rightarrow> ('o, 't list, 't) instance_graph \<Rightarrow> ('o, 't) instance_model" where
  "ig_subclass_as_node_type_to_imod_subclass name supertype fid IG = \<lparr>
    Tm = tmod_subclass name supertype,
    Object = nodeId ` N IG,
    ObjectClass = (\<lambda>x. if x \<in> nodeId ` N IG then name else undefined),
    ObjectId = (\<lambda>x. if x \<in> nodeId ` N IG then fid x else undefined),
    FieldValue = (\<lambda>x. undefined),
    DefaultValue = (\<lambda>x. undefined)
  \<rparr>"

lemma ig_subclass_as_node_type_to_imod_subclass_proj:
  shows "ig_subclass_as_node_type_to_imod_subclass name supertype fid (ig_subclass_as_node_type name supertype objects fid) = imod_subclass name supertype objects fid"
proof-
  have "nodeId ` typed (LabDef.type (id_to_list name)) ` objects = objects"
    by force
  then show "ig_subclass_as_node_type_to_imod_subclass name supertype fid (ig_subclass_as_node_type name supertype objects fid) = imod_subclass name supertype objects fid"
    unfolding ig_subclass_as_node_type_to_imod_subclass_def imod_subclass_def ig_subclass_as_node_type_def
    by simp
qed

lemma ig_subclass_as_node_type_to_imod_subclass_func:
  shows "imod_combine_mapping_function (ig_subclass_as_node_type_to_imod_subclass name supertype fid) (ig_subclass_as_node_type name supertype objects fid) (imod_subclass name supertype objects fid)"
proof-
  have "nodeId ` typed (LabDef.type (id_to_list name)) ` objects = objects"
    by force
  then show "imod_combine_mapping_function (ig_subclass_as_node_type_to_imod_subclass name supertype fid) (ig_subclass_as_node_type name supertype objects fid) (imod_subclass name supertype objects fid)"
    by (intro imod_combine_mapping_function.intro)
      (auto simp add: ig_subclass_as_node_type_to_imod_subclass_def imod_subclass_def ig_subclass_as_node_type_def ig_combine_def)
qed

end


(*  Title:      HOL/MicroJava/BV/LBVComplete.thy
    Author:     Gerwin Klein
    Copyright   2000 Technische Universitaet Muenchen
*)

section \<open>Completeness of the LBV\<close>

theory LBVComplete
imports LBVSpec Typing_Framework
begin

definition is_target :: "'s step_type \<Rightarrow> 's list \<Rightarrow> nat \<Rightarrow> bool" where
  "is_target step \<tau>s pc' \<longleftrightarrow> (\<exists>pc s'. pc' \<noteq> pc+1 \<and> pc < size \<tau>s \<and> (pc',s') \<in> set (step pc (\<tau>s!pc)))"

definition make_cert :: "'s step_type \<Rightarrow> 's list \<Rightarrow> 's \<Rightarrow> 's certificate" where
  "make_cert step \<tau>s B = map (\<lambda>pc. if is_target step \<tau>s pc then \<tau>s!pc else B) [0..<size \<tau>s] @ [B]"

locale lbvc = lbv +
  fixes \<tau>s :: "'a list"
  fixes c :: "'a list"
  defines cert_def: "c \<equiv> make_cert step \<tau>s \<bottom>"

  assumes mono: "mono r step (size \<tau>s) A"
  assumes pres: "pres_type step (size \<tau>s) A"
  assumes \<tau>s:  "\<forall>pc < size \<tau>s. \<tau>s!pc \<in> A \<and> \<tau>s!pc \<noteq> \<top>"
  assumes bounded: "bounded step (size \<tau>s)"

  assumes B_neq_T: "\<bottom> \<noteq> \<top>"

lemma (in lbvc) cert: "cert_ok c (size \<tau>s) \<top> \<bottom> A"
(*<*)
proof (unfold cert_ok_def, intro strip conjI)
  note [simp] = make_cert_def cert_def nth_append

  show "c!size \<tau>s = \<bottom>" by simp

  fix pc assume pc: "pc < size \<tau>s"
  from pc \<tau>s B_A show "c!pc \<in> A" by simp
  from pc \<tau>s B_neq_T show "c!pc \<noteq> \<top>" by simp
qed
(*>*)

lemmas [simp del] = split_paired_Ex

lemma (in lbvc) cert_target [intro?]:
  "\<lbrakk> (pc',s') \<in> set (step pc (\<tau>s!pc));
      pc' \<noteq> pc+1; pc < size \<tau>s; pc' < size \<tau>s \<rbrakk>
  \<Longrightarrow> c!pc' = \<tau>s!pc'"
(*<*) by (auto simp add: cert_def make_cert_def nth_append is_target_def) (*>*)

lemma (in lbvc) cert_approx [intro?]:
  "\<lbrakk> pc < size \<tau>s; c!pc \<noteq> \<bottom> \<rbrakk> \<Longrightarrow> c!pc = \<tau>s!pc"
(*<*) by (auto simp add: cert_def make_cert_def nth_append) (*>*)

lemma (in lbv) le_top [simp, intro]: "x <=_r \<top>"
(*<*) by (insert top) simp (*>*)

lemma (in lbv) merge_mono:
  assumes less:  "set ss\<^sub>2 {\<sqsubseteq>\<^bsub>r\<^esub>} set ss\<^sub>1"
  assumes x:     "x \<in> A"
  assumes ss\<^sub>1:   "snd`set ss\<^sub>1 \<subseteq> A"
  assumes ss\<^sub>2:   "snd`set ss\<^sub>2 \<subseteq> A"
  shows "merge c pc ss\<^sub>2 x \<sqsubseteq>\<^sub>r merge c pc ss\<^sub>1 x" (is "?s\<^sub>2 \<sqsubseteq>\<^sub>r ?s\<^sub>1")
(*<*)
proof-
  have "?s\<^sub>1 = \<top> \<Longrightarrow> ?thesis" by simp
  moreover {
    assume merge: "?s\<^sub>1 \<noteq> T"
    from x ss\<^sub>1 have "?s\<^sub>1 =
      (if \<forall>(pc',s')\<in>set ss\<^sub>1. pc' \<noteq> pc + 1 \<longrightarrow> s' \<sqsubseteq>\<^sub>r c!pc'
      then (map snd [(p', t') \<leftarrow> ss\<^sub>1 . p'=pc+1]) \<Squnion>\<^bsub>f\<^esub> x
      else \<top>)" by (rule merge_def)
    with merge obtain
      app: "\<forall>(pc',s')\<in>set ss\<^sub>1. pc' \<noteq> pc+1 \<longrightarrow> s' \<sqsubseteq>\<^sub>r c!pc'"
           (is "?app ss\<^sub>1") and
      sum: "(map snd [(p',t') \<leftarrow> ss\<^sub>1 . p' = pc+1] \<Squnion>\<^bsub>f\<^esub> x) = ?s\<^sub>1"
           (is "?map ss\<^sub>1 \<Squnion>\<^bsub>f\<^esub> x = _" is "?sum ss\<^sub>1 = _")
      by (simp split: if_split_asm)
    from app less have "?app ss\<^sub>2" by (blast dest: trans_r lesub_step_typeD)
    moreover {
      from ss\<^sub>1 have map1: "set (?map ss\<^sub>1) \<subseteq> A" by auto
      with x and semilat Semilat_axioms have "?sum ss\<^sub>1 \<in> A" by (auto intro!: plusplus_closed)
      with sum have "?s\<^sub>1 \<in> A" by simp
      moreover
      have mapD: "\<And>x ss. x \<in> set (?map ss) \<Longrightarrow> \<exists>p. (p,x) \<in> set ss \<and> p=pc+1" by auto
      from x map1 have "\<forall>x \<in> set (?map ss\<^sub>1). x \<sqsubseteq>\<^sub>r ?sum ss\<^sub>1" by clarify (rule pp_ub1)
      with sum have "\<forall>x \<in> set (?map ss\<^sub>1). x \<sqsubseteq>\<^sub>r ?s\<^sub>1" by simp
      with less have "\<forall>x \<in> set (?map ss\<^sub>2). x \<sqsubseteq>\<^sub>r ?s\<^sub>1"
        by (fastforce dest!: mapD lesub_step_typeD intro: trans_r)
      moreover from map1 x have "x \<sqsubseteq>\<^sub>r (?sum ss\<^sub>1)" by (rule pp_ub2)
      with sum have "x \<sqsubseteq>\<^sub>r ?s\<^sub>1" by simp
      moreover from ss\<^sub>2 have "set (?map ss\<^sub>2) \<subseteq> A" by auto
      ultimately  have "?sum ss\<^sub>2 \<sqsubseteq>\<^sub>r ?s\<^sub>1" using x by - (rule pp_lub)
    }
    moreover from x ss\<^sub>2 have "?s\<^sub>2 =
      (if \<forall>(pc', s')\<in>set ss\<^sub>2. pc' \<noteq> pc + 1 \<longrightarrow> s' \<sqsubseteq>\<^sub>r c!pc'
      then map snd [(p', t') \<leftarrow> ss\<^sub>2 . p' = pc + 1] \<Squnion>\<^bsub>f\<^esub> x
      else \<top>)" by (rule merge_def)
    ultimately have ?thesis by simp
  }
  ultimately show ?thesis by (cases "?s\<^sub>1 = \<top>") auto
qed
(*>*)

lemma (in lbvc) wti_mono:
  assumes less: "s\<^sub>2 \<sqsubseteq>\<^sub>r s\<^sub>1"
  assumes pc: "pc < size \<tau>s" and s\<^sub>1: "s\<^sub>1 \<in> A" and s\<^sub>2: "s\<^sub>2 \<in> A"
  shows "wti c pc s\<^sub>2 \<sqsubseteq>\<^sub>r wti c pc s\<^sub>1" (is "?s\<^sub>2' \<sqsubseteq>\<^sub>r ?s\<^sub>1'")
(*<*)
proof -
  from mono pc s\<^sub>2 less have "set (step pc s\<^sub>2) {\<sqsubseteq>\<^bsub>r\<^esub>} set (step pc s\<^sub>1)" by (rule monoD)
  moreover from cert B_A pc have "c!Suc pc \<in> A" by (rule cert_okD3)
  moreover from pres s\<^sub>1 pc have "snd`set (step pc s\<^sub>1) \<subseteq> A" by (rule pres_typeD2)
  moreover from pres s\<^sub>2 pc have "snd`set (step pc s\<^sub>2) \<subseteq> A" by (rule pres_typeD2)
  ultimately show ?thesis by (simp add: wti merge_mono)
qed
(*>*)

lemma (in lbvc) wtc_mono:
  assumes less: "s\<^sub>2 \<sqsubseteq>\<^sub>r s\<^sub>1"
  assumes pc: "pc < size \<tau>s" and s\<^sub>1: "s\<^sub>1 \<in> A" and s\<^sub>2: "s\<^sub>2 \<in> A"
  shows "wtc c pc s\<^sub>2 \<sqsubseteq>\<^sub>r wtc c pc s\<^sub>1" (is "?s\<^sub>2' \<sqsubseteq>\<^sub>r ?s\<^sub>1'")
(*<*)
proof (cases "c!pc = \<bottom>")
  case True
  moreover from less pc s\<^sub>1 s\<^sub>2 have "wti c pc s\<^sub>2 \<sqsubseteq>\<^sub>r wti c pc s\<^sub>1" by (rule wti_mono)
  ultimately show ?thesis by (simp add: wtc)
next
  case False
  have "?s\<^sub>1' = \<top> \<Longrightarrow> ?thesis" by simp
  moreover {
    assume "?s\<^sub>1' \<noteq> \<top>"
    with False have c: "s\<^sub>1 \<sqsubseteq>\<^sub>r c!pc" by (simp add: wtc split: if_split_asm)
    with less have "s\<^sub>2 \<sqsubseteq>\<^sub>r c!pc" ..
    with False c have ?thesis by (simp add: wtc)
  }
  ultimately show ?thesis by (cases "?s\<^sub>1' = \<top>") auto
qed
(*>*)

lemma (in lbv) top_le_conv [simp]: "\<top> \<sqsubseteq>\<^sub>r x = (x = \<top>)"
(*<*) by (insert semilat) (simp add: top top_le_conv)  (*>*)

lemma (in lbv) neq_top [simp, elim]: "\<lbrakk> x \<sqsubseteq>\<^sub>r y; y \<noteq> \<top> \<rbrakk> \<Longrightarrow> x \<noteq> \<top>"
(*<*) by (cases "x = T") auto (*>*)

lemma (in lbvc) stable_wti:
  assumes stable:  "stable r step \<tau>s pc" and pc: "pc < size \<tau>s"
  shows "wti c pc (\<tau>s!pc) \<noteq> \<top>"
(*<*)
proof -
  let ?step = "step pc (\<tau>s!pc)"
  from stable
  have less: "\<forall>(q,s')\<in>set ?step. s' \<sqsubseteq>\<^sub>r \<tau>s!q" by (simp add: stable_def)

  from cert B_A pc have cert_suc: "c!Suc pc \<in> A" by (rule cert_okD3)
  moreover from \<tau>s pc have "\<tau>s!pc \<in> A" by simp
  with pres pc have stepA: "snd`set ?step \<subseteq> A" by - (rule pres_typeD2)
  ultimately
  have "merge c pc ?step (c!Suc pc) =
    (if \<forall>(pc',s')\<in>set ?step. pc'\<noteq>pc+1 \<longrightarrow> s' \<sqsubseteq>\<^sub>r c!pc'
    then map snd [(p',t') \<leftarrow> ?step.p'=pc+1] \<Squnion>\<^bsub>f\<^esub> c!Suc pc
    else \<top>)" unfolding mrg_def by (rule lbv.merge_def [OF lbvc.axioms(1), OF lbvc_axioms])
  moreover {
    fix pc' s' assume s': "(pc',s') \<in> set ?step" and suc_pc: "pc' \<noteq> pc+1"
    with less have "s' \<sqsubseteq>\<^sub>r \<tau>s!pc'" by auto
    also from bounded pc s' have "pc' < size \<tau>s" by (rule boundedD)
    with s' suc_pc pc have "c!pc' = \<tau>s!pc'" ..
    hence "\<tau>s!pc' = c!pc'" ..
    finally have "s' \<sqsubseteq>\<^sub>r c!pc'" .
  } hence "\<forall>(pc',s')\<in>set ?step. pc'\<noteq>pc+1 \<longrightarrow> s' \<sqsubseteq>\<^sub>r c!pc'" by auto
  moreover from pc have "Suc pc = size \<tau>s \<or> Suc pc < size \<tau>s" by auto
  hence "map snd [(p',t') \<leftarrow> ?step.p'=pc+1] \<Squnion>\<^bsub>f\<^esub> c!Suc pc \<noteq> \<top>" (is "?map \<Squnion>\<^bsub>f\<^esub> _ \<noteq> _")
  proof (rule disjE)
    assume pc': "Suc pc = size \<tau>s"
    with cert have "c!Suc pc = \<bottom>" by (simp add: cert_okD2)
    moreover
    from pc' bounded pc
    have "\<forall>(p',t')\<in>set ?step. p'\<noteq>pc+1" by clarify (drule boundedD, auto)
    hence "[(p',t') \<leftarrow> ?step. p'=pc+1] = []" by (blast intro: filter_False)
    hence "?map = []" by simp
    ultimately show ?thesis by (simp add: B_neq_T)
  next
    assume pc': "Suc pc < size \<tau>s"
    from pc' \<tau>s have "\<tau>s!Suc pc \<in> A" by simp
    moreover note cert_suc
    moreover from stepA have "set ?map \<subseteq> A" by auto
    moreover have "\<And>s. s \<in> set ?map \<Longrightarrow> \<exists>t. (Suc pc, t) \<in> set ?step" by auto
    with less have "\<forall>s' \<in> set ?map. s' \<sqsubseteq>\<^sub>r \<tau>s!Suc pc" by auto
    moreover from pc' have "c!Suc pc \<sqsubseteq>\<^sub>r \<tau>s!Suc pc"
      by (cases "c!Suc pc = \<bottom>") (auto dest: cert_approx)
    ultimately have "?map \<Squnion>\<^bsub>f\<^esub> c!Suc pc \<sqsubseteq>\<^sub>r \<tau>s!Suc pc" by (rule pp_lub)
    moreover from pc' \<tau>s have "\<tau>s!Suc pc \<noteq> \<top>" by simp
    ultimately show ?thesis by auto
  qed
  ultimately have "merge c pc ?step (c!Suc pc) \<noteq> \<top>" by simp
  thus ?thesis by (simp add: wti)
qed
(*>*)

lemma (in lbvc) wti_less:
  assumes stable: "stable r step \<tau>s pc" and suc_pc: "Suc pc < size \<tau>s"
  shows "wti c pc (\<tau>s!pc) \<sqsubseteq>\<^sub>r \<tau>s!Suc pc" (is "?wti \<sqsubseteq>\<^sub>r _")
(*<*)
proof -
  let ?step = "step pc (\<tau>s!pc)"

  from stable
  have less: "\<forall>(q,s')\<in>set ?step. s' \<sqsubseteq>\<^sub>r \<tau>s!q" by (simp add: stable_def)

  from suc_pc have pc: "pc < size \<tau>s" by simp
  with cert B_A have cert_suc: "c!Suc pc \<in> A" by (rule cert_okD3)
  moreover from \<tau>s pc have "\<tau>s!pc \<in> A" by simp
  with pres pc have stepA: "snd`set ?step \<subseteq> A" by - (rule pres_typeD2)
  moreover from stable pc have "?wti \<noteq> \<top>" by (rule stable_wti)
  hence "merge c pc ?step (c!Suc pc) \<noteq> \<top>" by (simp add: wti)
  ultimately
  have "merge c pc ?step (c!Suc pc) =
    map snd [(p',t') \<leftarrow> ?step.p'=pc+1] \<Squnion>\<^bsub>f\<^esub> c!Suc pc" by (rule merge_not_top_s)
  hence "?wti = \<dots>" (is "_ = (?map \<Squnion>\<^bsub>f\<^esub> _)" is "_ = ?sum") by (simp add: wti)
  also {
    from suc_pc \<tau>s have "\<tau>s!Suc pc \<in> A" by simp
    moreover note cert_suc
    moreover from stepA have "set ?map \<subseteq> A" by auto
    moreover have "\<And>s. s \<in> set ?map \<Longrightarrow> \<exists>t. (Suc pc, t) \<in> set ?step" by auto
    with less have "\<forall>s' \<in> set ?map. s' \<sqsubseteq>\<^sub>r \<tau>s!Suc pc" by auto
    moreover from suc_pc have "c!Suc pc \<sqsubseteq>\<^sub>r \<tau>s!Suc pc"
      by (cases "c!Suc pc = \<bottom>") (auto dest: cert_approx)
    ultimately have "?sum \<sqsubseteq>\<^sub>r \<tau>s!Suc pc" by (rule pp_lub)
  }
  finally show ?thesis .
qed
(*>*)

lemma (in lbvc) stable_wtc:
  assumes stable: "stable r step \<tau>s pc" and pc: "pc < size \<tau>s"
  shows "wtc c pc (\<tau>s!pc) \<noteq> \<top>"
(*<*)
proof -
  from stable pc have wti: "wti c pc (\<tau>s!pc) \<noteq> \<top>" by (rule stable_wti)
  show ?thesis
  proof (cases "c!pc = \<bottom>")
    case True with wti show ?thesis by (simp add: wtc)
  next
    case False
    with pc have "c!pc = \<tau>s!pc" ..
    with False wti show ?thesis by (simp add: wtc)
  qed
qed
(*>*)

lemma (in lbvc) wtc_less:
  assumes stable: "stable r step \<tau>s pc" and suc_pc: "Suc pc < size \<tau>s"
  shows "wtc c pc (\<tau>s!pc) \<sqsubseteq>\<^sub>r \<tau>s!Suc pc" (is "?wtc \<sqsubseteq>\<^sub>r _")
(*<*)
proof (cases "c!pc = \<bottom>")
  case True
  moreover from stable suc_pc have "wti c pc (\<tau>s!pc) \<sqsubseteq>\<^sub>r \<tau>s!Suc pc" by (rule wti_less)
  ultimately show ?thesis by (simp add: wtc)
next
  case False
  from suc_pc have pc: "pc < size \<tau>s" by simp
  with stable have "?wtc \<noteq> \<top>" by (rule stable_wtc)
  with False have "?wtc = wti c pc (c!pc)"
    by (unfold wtc) (simp split: if_split_asm)
  also from pc False have "c!pc = \<tau>s!pc" ..
  finally have "?wtc = wti c pc (\<tau>s!pc)" .
  also from stable suc_pc have "wti c pc (\<tau>s!pc) \<sqsubseteq>\<^sub>r \<tau>s!Suc pc" by (rule wti_less)
  finally show ?thesis .
qed
(*>*)

lemma (in lbvc) wt_step_wtl_lemma:
  assumes wt_step: "wt_step r \<top> step \<tau>s"
  shows "\<And>pc s. pc+size ls = size \<tau>s \<Longrightarrow> s \<sqsubseteq>\<^sub>r \<tau>s!pc \<Longrightarrow> s \<in> A \<Longrightarrow> s\<noteq>\<top> \<Longrightarrow>
                wtl ls c pc s \<noteq> \<top>"
  (is "\<And>pc s. _ \<Longrightarrow> _ \<Longrightarrow> _ \<Longrightarrow> _ \<Longrightarrow> ?wtl ls pc s \<noteq> _")
(*<*)
proof (induct ls)
  fix pc s assume "s\<noteq>\<top>" thus "?wtl [] pc s \<noteq> \<top>" by simp
next
  fix pc s i ls
  assume "\<And>pc s. pc+size ls=size \<tau>s \<Longrightarrow> s \<sqsubseteq>\<^sub>r \<tau>s!pc \<Longrightarrow> s \<in> A \<Longrightarrow> s\<noteq>\<top> \<Longrightarrow>
                  ?wtl ls pc s \<noteq> \<top>"
  moreover
  assume pc_l: "pc + size (i#ls) = size \<tau>s"
  hence suc_pc_l: "Suc pc + size ls = size \<tau>s" by simp
  ultimately
  have IH: "\<And>s. s \<sqsubseteq>\<^sub>r \<tau>s!Suc pc \<Longrightarrow> s \<in> A \<Longrightarrow> s \<noteq> \<top> \<Longrightarrow> ?wtl ls (Suc pc) s \<noteq> \<top>" .

  from pc_l obtain pc: "pc < size \<tau>s" by simp
  with wt_step have stable: "stable r step \<tau>s pc" by (simp add: wt_step_def)
  moreover note pc
  ultimately have wt_\<tau>s: "wtc c pc (\<tau>s!pc) \<noteq> \<top>" by (rule stable_wtc)

  assume s_\<tau>s: "s \<sqsubseteq>\<^sub>r \<tau>s!pc"
  assume sA: "s \<in> A"
  from \<tau>s pc have \<tau>s_pc: "\<tau>s!pc \<in> A" by simp
  from s_\<tau>s pc \<tau>s_pc sA have wt_s_\<tau>s: "wtc c pc s \<sqsubseteq>\<^sub>r wtc c pc (\<tau>s!pc)" by (rule wtc_mono)
  with wt_\<tau>s have wt_s: "wtc c pc s \<noteq> \<top>" by simp
  moreover assume s: "s \<noteq> \<top>"
  ultimately have "ls = [] \<Longrightarrow> ?wtl (i#ls) pc s \<noteq> \<top>" by simp
  moreover {
    assume "ls \<noteq> []"
    with pc_l have suc_pc: "Suc pc < size \<tau>s" by (auto simp add: neq_Nil_conv)
    with stable have "wtc c pc (\<tau>s!pc) \<sqsubseteq>\<^sub>r \<tau>s!Suc pc" by (rule wtc_less)
    with wt_s_\<tau>s have "wtc c pc s \<sqsubseteq>\<^sub>r \<tau>s!Suc pc" by (rule trans_r)
    moreover from cert suc_pc have "c!pc \<in> A" "c!(pc+1) \<in> A"
      by (auto simp add: cert_ok_def)
    from pres this sA pc have "wtc c pc s \<in> A" by (rule wtc_pres)
    ultimately have "?wtl ls (Suc pc) (wtc c pc s) \<noteq> \<top>" using IH wt_s by blast
    with s wt_s have "?wtl (i#ls) pc s \<noteq> \<top>" by simp
  }
  ultimately show "?wtl (i#ls) pc s \<noteq> \<top>" by (cases ls) blast+
qed
(*>*)

theorem (in lbvc) wtl_complete:
  assumes wt: "wt_step r \<top> step \<tau>s"
  assumes s: "s \<sqsubseteq>\<^sub>r \<tau>s!0" "s \<in> A" "s \<noteq> \<top>" and eq: "size ins = size \<tau>s"
  shows "wtl ins c 0 s \<noteq> \<top>"
(*<*)
proof -
  from eq have "0+size ins = size \<tau>s" by simp
  from wt this s show ?thesis by (rule wt_step_wtl_lemma)
qed
(*>*)

end


(*  Title:      HOL/Auth/Event.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1996  University of Cambridge

Datatype of events; function "spies"; freshness

"bad" agents have been broken by the Spy; their private keys and internal
    stores are visible to him
*)

section{*Theory of Events for Security Protocols*}

theory Event imports Message begin

consts  (*Initial states of agents -- parameter of the construction*)
  initState :: "agent => msg set"

datatype
  event = Says  agent agent msg
        | Gets  agent       msg
        | Notes agent       msg

consts
  bad    :: "agent set"                         -- {* compromised agents *}

text{*Spy has access to his own key for spoof messages, but Server is secure*}
specification (bad)
  Spy_in_bad     [iff]: "Spy \<in> bad"
  Server_not_bad [iff]: "Server \<notin> bad"
    by (rule exI [of _ "{Spy}"], simp)

primrec knows :: "agent => event list => msg set"
where
  knows_Nil:   "knows A [] = initState A"
| knows_Cons:
    "knows A (ev # evs) =
       (if A = Spy then
        (case ev of
           Says A' B X => insert X (knows Spy evs)
         | Gets A' X => knows Spy evs
         | Notes A' X  =>
             if A' \<in> bad then insert X (knows Spy evs) else knows Spy evs)
        else
        (case ev of
           Says A' B X =>
             if A'=A then insert X (knows A evs) else knows A evs
         | Gets A' X    =>
             if A'=A then insert X (knows A evs) else knows A evs
         | Notes A' X    =>
             if A'=A then insert X (knows A evs) else knows A evs))"
(*
  Case A=Spy on the Gets event
  enforces the fact that if a message is received then it must have been sent,
  therefore the oops case must use Notes
*)

text{*The constant "spies" is retained for compatibility's sake*}

abbreviation (input)
  spies  :: "event list => msg set" where
  "spies == knows Spy"

(*Set of items that might be visible to somebody:
    complement of the set of fresh items*)

primrec used :: "event list => msg set"
where
  used_Nil:   "used []         = (UN B. parts (initState B))"
| used_Cons:  "used (ev # evs) =
                     (case ev of
                        Says A B X => parts {X} \<union> used evs
                      | Gets A X   => used evs
                      | Notes A X  => parts {X} \<union> used evs)"
    --{*The case for @{term Gets} seems anomalous, but @{term Gets} always
        follows @{term Says} in real protocols.  Seems difficult to change.
        See @{text Gets_correct} in theory @{text "Guard/Extensions.thy"}. *}

lemma Notes_imp_used [rule_format]: "Notes A X \<in> set evs --> X \<in> used evs"
apply (induct_tac evs)
apply (auto split: event.split)
done

lemma Says_imp_used [rule_format]: "Says A B X \<in> set evs --> X \<in> used evs"
apply (induct_tac evs)
apply (auto split: event.split)
done

subsection{*Function @{term knows}*}

(*Simplifying
 parts(insert X (knows Spy evs)) = parts{X} \<union> parts(knows Spy evs).
  This version won't loop with the simplifier.*)
lemmas parts_insert_knows_A = parts_insert [of _ "knows A evs"] for A evs

text{*Letting the Spy see "bad" agents' notes avoids redundant case-splits
      on whether @{term "A=Spy"} and whether @{term "A\<in>bad"}*}
lemma knows_Spy_Notes [simp]:
     "knows Spy (Notes A X # evs) =
          (if A:bad then insert X (knows Spy evs) else knows Spy evs)"
by simp

lemma knows_Spy_Gets [simp]: "knows Spy (Gets A X # evs) = knows Spy evs"
by simp

lemma knows_Spy_subset_knows_Spy_Says:
     "knows Spy evs \<subseteq> knows Spy (Says A B X # evs)"
by (simp add: subset_insertI)

lemma knows_Spy_subset_knows_Spy_Notes:
     "knows Spy evs \<subseteq> knows Spy (Notes A X # evs)"
by force

lemma knows_Spy_subset_knows_Spy_Gets:
     "knows Spy evs \<subseteq> knows Spy (Gets A X # evs)"
by (simp add: subset_insertI)

text{*Spy sees what is sent on the traffic*}
lemma Says_imp_knows_Spy [rule_format]:
     "Says A B X \<in> set evs --> X \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split add: event.split)
done

lemma Notes_imp_knows_Spy [rule_format]:
     "Notes A X \<in> set evs --> A: bad --> X \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split add: event.split)
done

text{*Elimination rules: derive contradictions from old Says events containing
  items known to be fresh*}
lemmas Says_imp_parts_knows_Spy =
       Says_imp_knows_Spy [THEN parts.Inj, elim_format]

lemmas knows_Spy_partsEs =
     Says_imp_parts_knows_Spy parts.Body [elim_format]

lemmas Says_imp_analz_Spy = Says_imp_knows_Spy [THEN analz.Inj]

text{*Compatibility for the old "spies" function*}
lemmas spies_partsEs = knows_Spy_partsEs
lemmas Says_imp_spies = Says_imp_knows_Spy
lemmas parts_insert_spies = parts_insert_knows_A [of _ Spy]

subsection{*Knowledge of Agents*}

lemma knows_subset_knows_Says: "knows A evs \<subseteq> knows A (Says A' B X # evs)"
by (simp add: subset_insertI)

lemma knows_subset_knows_Notes: "knows A evs \<subseteq> knows A (Notes A' X # evs)"
by (simp add: subset_insertI)

lemma knows_subset_knows_Gets: "knows A evs \<subseteq> knows A (Gets A' X # evs)"
by (simp add: subset_insertI)

text{*Agents know what they say*}
lemma Says_imp_knows [rule_format]: "Says A B X \<in> set evs --> X \<in> knows A evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split add: event.split)
apply blast
done

text{*Agents know what they note*}
lemma Notes_imp_knows [rule_format]: "Notes A X \<in> set evs --> X \<in> knows A evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split add: event.split)
apply blast
done

text{*Agents know what they receive*}
lemma Gets_imp_knows_agents [rule_format]:
     "A \<noteq> Spy --> Gets A X \<in> set evs --> X \<in> knows A evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split add: event.split)
done

text{*What agents DIFFERENT FROM Spy know
  was either said, or noted, or got, or known initially*}
lemma knows_imp_Says_Gets_Notes_initState [rule_format]:
     "[| X \<in> knows A evs; A \<noteq> Spy |] ==> EX B.
  Says A B X \<in> set evs | Gets A X \<in> set evs | Notes A X \<in> set evs | X \<in> initState A"
apply (erule rev_mp)
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split add: event.split)
apply blast
done

text{*What the Spy knows -- for the time being --
  was either said or noted, or known initially*}
lemma knows_Spy_imp_Says_Notes_initState [rule_format]:
     "[| X \<in> knows Spy evs |] ==> EX A B.
  Says A B X \<in> set evs | Notes A X \<in> set evs | X \<in> initState Spy"
apply (erule rev_mp)
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split add: event.split)
apply blast
done

lemma parts_knows_Spy_subset_used: "parts (knows Spy evs) \<subseteq> used evs"
apply (induct_tac "evs", force)
apply (simp add: parts_insert_knows_A knows_Cons add: event.split, blast)
done

lemmas usedI = parts_knows_Spy_subset_used [THEN subsetD, intro]

lemma initState_into_used: "X \<in> parts (initState B) ==> X \<in> used evs"
apply (induct_tac "evs")
apply (simp_all add: parts_insert_knows_A split add: event.split, blast)
done

lemma used_Says [simp]: "used (Says A B X # evs) = parts{X} \<union> used evs"
by simp

lemma used_Notes [simp]: "used (Notes A X # evs) = parts{X} \<union> used evs"
by simp

lemma used_Gets [simp]: "used (Gets A X # evs) = used evs"
by simp

lemma used_nil_subset: "used [] \<subseteq> used evs"
apply simp
apply (blast intro: initState_into_used)
done

text{*NOTE REMOVAL--laws above are cleaner, as they don't involve "case"*}
declare knows_Cons [simp del]
        used_Nil [simp del] used_Cons [simp del]

text{*For proving theorems of the form @{term "X \<notin> analz (knows Spy evs) --> P"}
  New events added by induction to "evs" are discarded.  Provided
  this information isn't needed, the proof will be much shorter, since
  it will omit complicated reasoning about @{term analz}.*}

lemmas analz_mono_contra =
       knows_Spy_subset_knows_Spy_Says [THEN analz_mono, THEN contra_subsetD]
       knows_Spy_subset_knows_Spy_Notes [THEN analz_mono, THEN contra_subsetD]
       knows_Spy_subset_knows_Spy_Gets [THEN analz_mono, THEN contra_subsetD]

lemma knows_subset_knows_Cons: "knows A evs \<subseteq> knows A (e # evs)"
by (cases e, auto simp: knows_Cons)

lemma initState_subset_knows: "initState A \<subseteq> knows A evs"
apply (induct_tac evs, simp)
apply (blast intro: knows_subset_knows_Cons [THEN subsetD])
done

text{*For proving @{text new_keys_not_used}*}
lemma keysFor_parts_insert:
     "[| K \<in> keysFor (parts (insert X G));  X \<in> synth (analz H) |]
      ==> K \<in> keysFor (parts (G \<union> H)) | Key (invKey K) \<in> parts H"
by (force
    dest!: parts_insert_subset_Un [THEN keysFor_mono, THEN [2] rev_subsetD]
           analz_subset_parts [THEN keysFor_mono, THEN [2] rev_subsetD]
    intro: analz_subset_parts [THEN subsetD] parts_mono [THEN [2] rev_subsetD])

lemmas analz_impI = impI [where P = "Y \<notin> analz (knows Spy evs)"] for Y evs

ML
{*
fun analz_mono_contra_tac ctxt =
  rtac @{thm analz_impI} THEN'
  REPEAT1 o (dresolve_tac @{thms analz_mono_contra})
  THEN' (mp_tac ctxt)
*}

method_setup analz_mono_contra = {*
    Scan.succeed (fn ctxt => SIMPLE_METHOD (REPEAT_FIRST (analz_mono_contra_tac ctxt))) *}
    "for proving theorems of the form X \<notin> analz (knows Spy evs) --> P"

subsubsection{*Useful for case analysis on whether a hash is a spoof or not*}

lemmas syan_impI = impI [where P = "Y \<notin> synth (analz (knows Spy evs))"] for Y evs

ML
{*
fun synth_analz_mono_contra_tac ctxt =
  rtac @{thm syan_impI} THEN'
  REPEAT1 o
    (dresolve_tac
     [@{thm knows_Spy_subset_knows_Spy_Says} RS @{thm synth_analz_mono} RS @{thm contra_subsetD},
      @{thm knows_Spy_subset_knows_Spy_Notes} RS @{thm synth_analz_mono} RS @{thm contra_subsetD},
      @{thm knows_Spy_subset_knows_Spy_Gets} RS @{thm synth_analz_mono} RS @{thm contra_subsetD}])
  THEN'
  mp_tac ctxt
*}

method_setup synth_analz_mono_contra = {*
    Scan.succeed (fn ctxt => SIMPLE_METHOD (REPEAT_FIRST (synth_analz_mono_contra_tac ctxt))) *}
    "for proving theorems of the form X \<notin> synth (analz (knows Spy evs)) --> P"

end