theory Instance_Graph_Retype
  imports
    Instance_Graph_Combination
begin

section "Validity of instance graphs when changing type graph"

definition instance_graph_retype :: "('lt) type_graph \<Rightarrow> ('nt, 'lt, 'id) instance_graph \<Rightarrow> ('nt, 'lt, 'id) instance_graph" where
  "instance_graph_retype newTG IG \<equiv> \<lparr>
    TG = newTG,
    Id = Id IG,
    N = N IG,
    E = E IG,
    ident = ident IG
  \<rparr>"

lemma instance_graph_retype_identity[simp]: "instance_graph_retype (TG IG) IG = IG"
  unfolding instance_graph_retype_def
  by simp

lemma instance_graph_retype_identity_correct[simp]: "instance_graph IG \<Longrightarrow> instance_graph (instance_graph_retype (TG IG) IG)"
  by simp

lemma instance_graph_retype_combine_empty_correct[simp]:
  assumes type_graph_valid: "type_graph newTG"
  shows "instance_graph (instance_graph_retype newTG ig_empty)"
  unfolding instance_graph_retype_def
  using ig_empty_any_type_graph_correct assms
  by simp

lemma instance_graph_retype_combine_correct[intro]:
  assumes instance_graph_valid: "instance_graph IG"
  assumes type_graph_second_valid: "type_graph TG2"
  assumes type_graph_combination_valid: "type_graph (tg_combine (TG IG) TG2)"
  assumes validity_outgoing_mult: "\<And>et n. et \<in> ET (TG IG) \<union> ET TG2 \<Longrightarrow> n \<in> N IG \<Longrightarrow>
    (type\<^sub>n n, src et) \<in> (inh (TG IG) \<union> inh TG2)\<^sup>+ \<Longrightarrow>
    card {e \<in> E IG. src e = n \<and> type\<^sub>e e = et} in m_out (tg_combine_mult (ET (TG IG)) (mult (TG IG)) (ET TG2) (mult TG2) et)"
  assumes validity_ingoing_mult: "\<And>et n. et \<in> ET (TG IG) \<union> ET TG2 \<Longrightarrow> n \<in> N IG \<Longrightarrow>
    (type\<^sub>n n, tgt et) \<in> (inh (TG IG) \<union> inh TG2)\<^sup>+ \<Longrightarrow>
    card {e \<in> E IG. tgt e = n \<and> type\<^sub>e e = et} in m_in (tg_combine_mult (ET (TG IG)) (mult (TG IG)) (ET TG2) (mult TG2) et)"
  assumes validity_contained_node: "\<And>n. n \<in> N IG \<Longrightarrow> card { e \<in> E IG. tgt e = n \<and> type\<^sub>e e \<in> contains (TG IG) \<union> contains TG2 } \<le> 1"
  assumes validity_containment: "irrefl ((edge_to_tuple ` {e \<in> E IG. type\<^sub>e e \<in> contains (TG IG) \<union> contains TG2})\<^sup>+)"
  shows "instance_graph (instance_graph_retype (tg_combine (TG IG) TG2) IG)"
proof (intro instance_graph.intro)
  fix n
  assume "n \<in> N (instance_graph_retype (tg_combine (TG IG) TG2) IG)"
  then have "n \<in> N IG"
    unfolding instance_graph_retype_def
    by simp
  then show "n \<in> Node"
    using instance_graph_valid instance_graph.structure_nodes_wellformed
    by blast
next
  fix s l t
  assume "(s, l, t) \<in> E (instance_graph_retype (tg_combine (TG IG) TG2) IG)"
  then have "(s, l, t) \<in> E IG"
    unfolding instance_graph_retype_def
    by simp
  then show "s \<in> N (instance_graph_retype (tg_combine (TG IG) TG2) IG) \<and>
    l \<in> ET (TG (instance_graph_retype (tg_combine (TG IG) TG2) IG)) \<and>
    t \<in> N (instance_graph_retype (tg_combine (TG IG) TG2) IG)"
  proof (intro conjI)
    assume "(s, l, t) \<in> E IG"
    then have "s \<in> N IG"
      using instance_graph_valid instance_graph.structure_edges_wellformed_src_node
      by blast
    then show "s \<in> N (instance_graph_retype (tg_combine (TG IG) TG2) IG)"
      unfolding instance_graph_retype_def
      by simp
  next
    assume "(s, l, t) \<in> E IG"
    then have "l \<in> ET (TG IG)"
      using instance_graph_valid instance_graph.structure_edges_wellformed_edge_type
      by blast
    then show "l \<in> ET (TG (instance_graph_retype (tg_combine (TG IG) TG2) IG))"
      unfolding instance_graph_retype_def tg_combine_def
      by simp
  next
    assume "(s, l, t) \<in> E IG"
    then have "t \<in> N IG"
      using instance_graph_valid instance_graph.structure_edges_wellformed_tgt_node
      by blast
    then show "t \<in> N (instance_graph_retype (tg_combine (TG IG) TG2) IG)"
      unfolding instance_graph_retype_def
      by simp
  qed
next
  fix i
  assume "i \<in> Id (instance_graph_retype (tg_combine (TG IG) TG2) IG)"
  then have "i \<in> Id IG"
    unfolding instance_graph_retype_def
    by simp
  then have "ident IG i \<in> N IG \<and> type\<^sub>n (ident IG i) \<in> Lab\<^sub>t"
    using instance_graph_valid instance_graph.structure_ident_wellformed
    by metis
  then show "ident (instance_graph_retype (tg_combine (TG IG) TG2) IG) i \<in> N (instance_graph_retype (tg_combine (TG IG) TG2) IG) \<and> type\<^sub>n (ident (instance_graph_retype (tg_combine (TG IG) TG2) IG) i) \<in> Lab\<^sub>t"
    unfolding instance_graph_retype_def
    by simp
next
  fix i
  assume "i \<notin> Id (instance_graph_retype (tg_combine (TG IG) TG2) IG)"
  then have "i \<notin> Id IG"
    unfolding instance_graph_retype_def
    by simp
  then have "ident IG i = undefined"
    using instance_graph_valid instance_graph.structure_ident_domain
    by metis
  then show "ident (instance_graph_retype (tg_combine (TG IG) TG2) IG) i = undefined"
    unfolding instance_graph_retype_def
    by simp
next
  have "type_graph (tg_combine (TG IG) TG2)"
    by (fact assms)
  then show "type_graph (TG (instance_graph_retype (tg_combine (TG IG) TG2) IG))"
    unfolding instance_graph_retype_def
    by simp
next
  fix n
  assume "n \<in> N (instance_graph_retype (tg_combine (TG IG) TG2) IG)"
  then have "n \<in> N IG"
    unfolding instance_graph_retype_def
    by simp
  then have "type\<^sub>n n \<in> NT (TG IG)"
    using instance_graph_valid instance_graph.validity_node_typed
    by blast
  then show "type\<^sub>n n \<in> NT (TG (instance_graph_retype (tg_combine (TG IG) TG2) IG))"
    unfolding instance_graph_retype_def tg_combine_def
    by simp
next
  fix e
  assume "e \<in> E (instance_graph_retype (tg_combine (TG IG) TG2) IG)"
  then have "e \<in> E IG"
    unfolding instance_graph_retype_def
    by simp
  then have "(type\<^sub>n (src e), src (type\<^sub>e e)) \<in> inh (TG IG)"
    using instance_graph_valid instance_graph.validity_edge_src_typed
    by blast
  then show "(type\<^sub>n (src e), src (type\<^sub>e e)) \<in> inh (TG (instance_graph_retype (tg_combine (TG IG) TG2) IG))"
    unfolding instance_graph_retype_def tg_combine_def
    by auto
next
  fix e
  assume "e \<in> E (instance_graph_retype (tg_combine (TG IG) TG2) IG)"
  then have "e \<in> E IG"
    unfolding instance_graph_retype_def
    by simp
  then have "(type\<^sub>n (tgt e), tgt (type\<^sub>e e)) \<in> inh (TG IG)"
    using instance_graph_valid instance_graph.validity_edge_tgt_typed
    by blast
  then show "(type\<^sub>n (tgt e), tgt (type\<^sub>e e)) \<in> inh (TG (instance_graph_retype (tg_combine (TG IG) TG2) IG))"
    unfolding instance_graph_retype_def tg_combine_def
    by auto
next
  fix n
  assume "n \<in> N (instance_graph_retype (tg_combine (TG IG) TG2) IG)"
  then have n_in_ig: "n \<in> N IG"
    unfolding instance_graph_retype_def
    by simp
  then have "type\<^sub>n n \<notin> abs (TG IG)"
    using instance_graph_valid instance_graph.validity_abs_no_instances
    by blast
  then have "type\<^sub>n n \<notin> (abs (TG IG) - NT TG2) \<union> (abs TG2 - NT (TG IG)) \<union> (abs (TG IG) \<inter> abs TG2)"
    using n_in_ig instance_graph.validity_node_typed instance_graph_valid
    by fastforce
  then show "type\<^sub>n n \<notin> abs (TG (instance_graph_retype (tg_combine (TG IG) TG2) IG))"
    unfolding instance_graph_retype_def tg_combine_def
    by simp
next
  fix et n
  assume "et \<in> ET (TG (instance_graph_retype (tg_combine (TG IG) TG2) IG))"
  then have et_in_ef: "et \<in> ET (TG IG) \<union> ET TG2"
    unfolding instance_graph_retype_def tg_combine_def
    by simp
  assume "n \<in> N (instance_graph_retype (tg_combine (TG IG) TG2) IG)"
  then have n_in_in: "n \<in> N IG"
    unfolding instance_graph_retype_def
    by simp
  assume "(type\<^sub>n n, src et) \<in> inh (TG (instance_graph_retype (tg_combine (TG IG) TG2) IG))"
  then have type_extend: "(type\<^sub>n n, src et) \<in> (inh (TG IG) \<union> inh TG2)\<^sup>+"
    unfolding instance_graph_retype_def tg_combine_def
    by simp
  have "card {e \<in> E IG. src e = n \<and> type\<^sub>e e = et} in
       m_out (tg_combine_mult (ET (TG IG)) (mult (TG IG)) (ET TG2) (mult TG2) et)"
    using et_in_ef n_in_in type_extend
    by (fact assms)
  then show "card {e \<in> E (instance_graph_retype (tg_combine (TG IG) TG2) IG). src e = n \<and> type\<^sub>e e = et} in
       m_out (mult (TG (instance_graph_retype (tg_combine (TG IG) TG2) IG)) et)"
    unfolding instance_graph_retype_def tg_combine_def
    by simp
next
  fix et n
  assume "et \<in> ET (TG (instance_graph_retype (tg_combine (TG IG) TG2) IG))"
  then have et_in_ef: "et \<in> ET (TG IG) \<union> ET TG2"
    unfolding instance_graph_retype_def tg_combine_def
    by simp
  assume "n \<in> N (instance_graph_retype (tg_combine (TG IG) TG2) IG)"
  then have n_in_in: "n \<in> N IG"
    unfolding instance_graph_retype_def
    by simp
  assume "(type\<^sub>n n, tgt et) \<in> inh (TG (instance_graph_retype (tg_combine (TG IG) TG2) IG))"
  then have type_extend: "(type\<^sub>n n, tgt et) \<in> (inh (TG IG) \<union> inh TG2)\<^sup>+"
    unfolding instance_graph_retype_def tg_combine_def
    by simp
  have "card {e \<in> E IG. tgt e = n \<and> type\<^sub>e e = et} in
       m_in (tg_combine_mult (ET (TG IG)) (mult (TG IG)) (ET TG2) (mult TG2) et)"
    using et_in_ef n_in_in type_extend
    by (fact assms)
  then show "card {e \<in> E (instance_graph_retype (tg_combine (TG IG) TG2) IG). tgt e = n \<and> type\<^sub>e e = et} in
       m_in (mult (TG (instance_graph_retype (tg_combine (TG IG) TG2) IG)) et)"
    unfolding instance_graph_retype_def tg_combine_def
    by simp
next
  fix n
  assume "n \<in> N (instance_graph_retype (tg_combine (TG IG) TG2) IG)"
  then have "n \<in> N IG"
    unfolding instance_graph_retype_def
    by simp
  then have "card {e \<in> E IG. tgt e = n \<and> type\<^sub>e e \<in> contains (TG IG) \<union> contains TG2} \<le> 1"
    by (fact assms)
  then show "card {e \<in> E (instance_graph_retype (tg_combine (TG IG) TG2) IG). tgt e = n \<and> type\<^sub>e e \<in> contains (TG (instance_graph_retype (tg_combine (TG IG) TG2) IG))} \<le> 1"
    unfolding instance_graph_retype_def tg_combine_def
    by simp
next
  fix p
  show "\<not>pre_digraph.cycle (instance_graph_containment_proj (instance_graph_retype (tg_combine (TG IG) TG2) IG)) p"
  proof (intro validity_containmentI)
    show "\<And>e. e \<in> E (instance_graph_retype (tg_combine (TG IG) TG2) IG) \<Longrightarrow> type\<^sub>e e \<in> contains (TG (instance_graph_retype (tg_combine (TG IG) TG2) IG)) \<Longrightarrow>
      src e \<in> N (instance_graph_retype (tg_combine (TG IG) TG2) IG) \<and> tgt e \<in> N (instance_graph_retype (tg_combine (TG IG) TG2) IG)"
    proof (intro conjI)
      fix e
      assume "e \<in> E (instance_graph_retype (tg_combine (TG IG) TG2) IG)"
      then have "e \<in> E IG"
        unfolding instance_graph_retype_def
        by simp
      then have "src e \<in> N IG"
        using instance_graph_valid instance_graph.structure_edges_wellformed_src_node_alt
        by blast
      then show "src e \<in> N (instance_graph_retype (tg_combine (TG IG) TG2) IG)"
        unfolding instance_graph_retype_def
        by simp
    next
      fix e
      assume "e \<in> E (instance_graph_retype (tg_combine (TG IG) TG2) IG)"
      then have "e \<in> E IG"
        unfolding instance_graph_retype_def
        by simp
      then have "tgt e \<in> N IG"
        using instance_graph_valid instance_graph.structure_edges_wellformed_tgt_node_alt
        by blast
      then show "tgt e \<in> N (instance_graph_retype (tg_combine (TG IG) TG2) IG)"
        unfolding instance_graph_retype_def
        by simp
    qed
  next
    have "irrefl ((edge_to_tuple ` {e \<in> E IG. type\<^sub>e e \<in> contains (TG IG) \<union> contains TG2})\<^sup>+)"
      by (fact validity_containment)
    then show "irrefl ((edge_to_tuple ` {e \<in> E (instance_graph_retype (tg_combine (TG IG) TG2) IG). type\<^sub>e e \<in> contains (TG (instance_graph_retype (tg_combine (TG IG) TG2) IG))})\<^sup>+)"
      unfolding instance_graph_retype_def tg_combine_def
      by simp
  qed
qed

lemma instance_graph_retype_combine_merge_correct[intro]:
  assumes instance_graph_valid: "instance_graph IG"
  assumes type_graph_second_valid: "type_graph TG2"
  assumes type_graph_combination_valid: "type_graph (tg_combine (TG IG) TG2)"
  assumes combine_edges_distinct: "ET (TG IG) \<inter> ET TG2 = {}"
  assumes validity_outgoing_mult_first: "\<And>et n. et \<in> ET (TG IG) \<Longrightarrow> n \<in> N IG \<Longrightarrow>
    (type\<^sub>n n, src et) \<in> (inh (TG IG) \<union> inh TG2)\<^sup>+ \<Longrightarrow>
    card {e \<in> E IG. src e = n \<and> type\<^sub>e e = et} in m_out (mult (TG IG) et)"
  assumes validity_outgoing_mult_second: "\<And>et n. et \<in> ET TG2 \<Longrightarrow> n \<in> N IG \<Longrightarrow>
    (type\<^sub>n n, src et) \<in> (inh (TG IG) \<union> inh TG2)\<^sup>+ \<Longrightarrow> 0 in m_out (mult TG2 et)"
  assumes validity_ingoing_mult_first: "\<And>et n. et \<in> ET (TG IG) \<Longrightarrow> n \<in> N IG \<Longrightarrow>
    (type\<^sub>n n, tgt et) \<in> (inh (TG IG) \<union> inh TG2)\<^sup>+ \<Longrightarrow>
    card {e \<in> E IG. tgt e = n \<and> type\<^sub>e e = et} in m_in (mult (TG IG) et)"
  assumes validity_ingoing_mult_second: "\<And>et n. et \<in> ET TG2 \<Longrightarrow> n \<in> N IG \<Longrightarrow>
    (type\<^sub>n n, tgt et) \<in> (inh (TG IG) \<union> inh TG2)\<^sup>+ \<Longrightarrow> 0 in m_in (mult TG2 et)"
  shows "instance_graph (instance_graph_retype (tg_combine (TG IG) TG2) IG)"
proof (intro instance_graph_retype_combine_correct)
  fix et n
  assume et_in_tg_e: "et \<in> ET (TG IG) \<union> ET TG2"
  assume n_in_in_ig: "n \<in> N IG"
  assume edge_of_type: "(type\<^sub>n n, src et) \<in> (inh (TG IG) \<union> inh TG2)\<^sup>+"
  show "card {e \<in> E IG. src e = n \<and> type\<^sub>e e = et} in m_out (tg_combine_mult (ET (TG IG)) (mult (TG IG)) (ET TG2) (mult TG2) et)"
    using et_in_tg_e n_in_in_ig edge_of_type
  proof (elim UnE)
    assume et_in_e: "et \<in> ET (TG IG)"
    then have mult_et: "m_out (tg_combine_mult (ET (TG IG)) (mult (TG IG)) (ET TG2) (mult TG2) et) = m_out (mult (TG IG) et)"
      unfolding tg_combine_mult_def
      by (simp add: combine_edges_distinct)
    have "card {e \<in> E IG. src e = n \<and> type\<^sub>e e = et} in m_out (mult (TG IG) et)"
      using et_in_e n_in_in_ig edge_of_type
      by (fact validity_outgoing_mult_first)
    then show "card {e \<in> E IG. src e = n \<and> type\<^sub>e e = et} in m_out (tg_combine_mult (ET (TG IG)) (mult (TG IG)) (ET TG2) (mult TG2) et)"
      using mult_et
      by simp
  next
    assume et_in_e: "et \<in> ET TG2"
    then have "\<And>e. e \<in> E IG \<Longrightarrow> src e = n \<and> type\<^sub>e e = et \<Longrightarrow> False"
      using combine_edges_distinct disjoint_iff_not_equal instance_graph.structure_edges_wellformed_edge_type_alt instance_graph_valid
      by metis
    then have "{e \<in> E IG. src e = n \<and> type\<^sub>e e = et} = {}"
      by blast
    then have card_zero: "card {e \<in> E IG. src e = n \<and> type\<^sub>e e = et} = 0"
      using card_empty
      by metis
    have mult_et: "m_out (tg_combine_mult (ET (TG IG)) (mult (TG IG)) (ET TG2) (mult TG2) et) = m_out (mult TG2 et)"
      unfolding tg_combine_mult_def
      using et_in_e combine_edges_distinct
      by auto
    have "0 in m_out (mult TG2 et)"
      using et_in_e n_in_in_ig edge_of_type
      by (fact validity_outgoing_mult_second)
    then show "card {e \<in> E IG. src e = n \<and> type\<^sub>e e = et} in m_out (tg_combine_mult (ET (TG IG)) (mult (TG IG)) (ET TG2) (mult TG2) et)"
      using card_zero mult_et
      by simp
  qed
next
  fix et n
  assume et_in_tg_e: "et \<in> ET (TG IG) \<union> ET TG2"
  assume n_in_in_ig: "n \<in> N IG"
  assume edge_of_type: "(type\<^sub>n n, tgt et) \<in> (inh (TG IG) \<union> inh TG2)\<^sup>+"
  show "card {e \<in> E IG. tgt e = n \<and> type\<^sub>e e = et} in m_in (tg_combine_mult (ET (TG IG)) (mult (TG IG)) (ET TG2) (mult TG2) et)"
    using et_in_tg_e n_in_in_ig edge_of_type
  proof (elim UnE)
    assume et_in_e: "et \<in> ET (TG IG)"
    then have mult_et: "m_in (tg_combine_mult (ET (TG IG)) (mult (TG IG)) (ET TG2) (mult TG2) et) = m_in (mult (TG IG) et)"
      unfolding tg_combine_mult_def
      by (simp add: combine_edges_distinct)
    have "card {e \<in> E IG. tgt e = n \<and> type\<^sub>e e = et} in m_in (mult (TG IG) et)"
      using et_in_e n_in_in_ig edge_of_type
      by (fact validity_ingoing_mult_first)
    then show "card {e \<in> E IG. tgt e = n \<and> type\<^sub>e e = et} in m_in (tg_combine_mult (ET (TG IG)) (mult (TG IG)) (ET TG2) (mult TG2) et)"
      using mult_et
      by simp
  next
    assume et_in_e: "et \<in> ET TG2"
    then have "\<And>e. e \<in> E IG \<Longrightarrow> tgt e = n \<and> type\<^sub>e e = et \<Longrightarrow> False"
      using combine_edges_distinct disjoint_iff_not_equal instance_graph.structure_edges_wellformed_edge_type_alt instance_graph_valid
      by metis
    then have "{e \<in> E IG. tgt e = n \<and> type\<^sub>e e = et} = {}"
      by blast
    then have card_zero: "card {e \<in> E IG. tgt e = n \<and> type\<^sub>e e = et} = 0"
      using card_empty
      by metis
    have mult_et: "m_in (tg_combine_mult (ET (TG IG)) (mult (TG IG)) (ET TG2) (mult TG2) et) = m_in (mult TG2 et)"
      unfolding tg_combine_mult_def
      using et_in_e combine_edges_distinct
      by auto
    have "0 in m_in (mult TG2 et)"
      using et_in_e n_in_in_ig edge_of_type
      by (fact validity_ingoing_mult_second)
    then show "card {e \<in> E IG. tgt e = n \<and> type\<^sub>e e = et} in m_in (tg_combine_mult (ET (TG IG)) (mult (TG IG)) (ET TG2) (mult TG2) et)"
      using card_zero mult_et
      by simp
  qed
next
  fix n
  assume n_in_in_ig: "n \<in> N IG"
  have "\<And>e. e \<in> E IG \<Longrightarrow> type\<^sub>e e \<notin> contains TG2"
  proof-
    fix e
    assume "e \<in> E IG"
    then have "type\<^sub>e e \<in> ET (TG IG)"
      using instance_graph_valid instance_graph.structure_edges_wellformed_edge_type_alt
      by blast
    then have "type\<^sub>e e \<notin> ET TG2"
      using combine_edges_distinct
      by blast
    then show "type\<^sub>e e \<notin> contains TG2"
      using type_graph.structure_contains_wellformed type_graph_second_valid
      by blast
  qed
  then have "{e \<in> E IG. tgt e = n \<and> type\<^sub>e e \<in> contains (TG IG) \<union> contains TG2} = {e \<in> E IG. tgt e = n \<and> type\<^sub>e e \<in> contains (TG IG)}"
    by blast
  then show "card {e \<in> E IG. tgt e = n \<and> type\<^sub>e e \<in> contains (TG IG) \<union> contains TG2} \<le> 1"
    using n_in_in_ig instance_graph_valid instance_graph.validity_contained_node
    by simp
next
  fix p
  have irrefl_contains: "irrefl ((edge_to_tuple ` {e \<in> E IG. type\<^sub>e e \<in> contains (TG IG)})\<^sup>+)"
    using instance_graph_valid instance_graph.validity_containment_alt'
    by blast
  have "\<And>e. e \<in> E IG \<Longrightarrow> type\<^sub>e e \<notin> contains TG2"
  proof-
    fix e
    assume "e \<in> E IG"
    then have "type\<^sub>e e \<in> ET (TG IG)"
      using instance_graph_valid instance_graph.structure_edges_wellformed_edge_type_alt
      by blast
    then have "type\<^sub>e e \<notin> ET TG2"
      using combine_edges_distinct
      by blast
    then show "type\<^sub>e e \<notin> contains TG2"
      using type_graph.structure_contains_wellformed type_graph_second_valid
      by blast
  qed
  then have "{e \<in> E IG. type\<^sub>e e \<in> contains (TG IG) \<union> contains TG2} = {e \<in> E IG. type\<^sub>e e \<in> contains (TG IG)}"
    by blast
  then show "irrefl ((edge_to_tuple ` {e \<in> E IG. type\<^sub>e e \<in> contains (TG IG) \<union> contains TG2})\<^sup>+)"
    using irrefl_contains
    by simp
qed (simp_all only: assms)

lemma instance_graph_retype_combine_distinct_correct[simp]:
  assumes instance_graph_valid: "instance_graph IG"
  assumes type_graph_second_valid: "type_graph TG2"
  assumes combine_edges_distinct: "ET (TG IG) \<inter> ET TG2 = {}"
  assumes combine_nodes_distinct: "NT (TG IG) \<inter> NT TG2 = {}"
  shows "instance_graph (instance_graph_retype (tg_combine (TG IG) TG2) IG)"
proof (intro instance_graph_retype_combine_merge_correct)
  show "type_graph (tg_combine (TG IG) TG2)"
    by (intro tg_combine_distinct_correct) (simp_all only: assms instance_graph.validity_type_graph)
next
  fix et n
  assume et_in_tg_ig: "et \<in> ET (TG IG)"
  then have "src et \<in> NT (TG IG)"
    using instance_graph.validity_type_graph instance_graph_valid type_graph.structure_edges_wellformed_alt
    by blast
  then have src_et_not_tg2: "src et \<notin> NT TG2"
    using combine_nodes_distinct
    by blast
  assume n_in_in_ig: "n \<in> N IG"
  assume "(type\<^sub>n n, src et) \<in> (inh (TG IG) \<union> inh TG2)\<^sup>+"
  then have "(type\<^sub>n n, src et) \<in> inh (TG IG) \<union> inh TG2"
    using combine_nodes_distinct instance_graph.validity_type_graph instance_graph_valid tg_combine_distinct_inh type_graph_second_valid
    by blast
  then have "(type\<^sub>n n, src et) \<in> inh (TG IG)"
    using UnE type_graph.structure_inheritance_wellformed_second_node type_graph_second_valid src_et_not_tg2
    by metis
  then show "card {e \<in> E IG. src e = n \<and> type\<^sub>e e = et} in m_out (mult (TG IG) et)"
    using et_in_tg_ig n_in_in_ig instance_graph_valid instance_graph.validity_outgoing_mult
    by simp
next
  fix et n
  assume "et \<in> ET TG2"
  then have "src et \<in> NT TG2"
    using type_graph_second_valid type_graph.structure_edges_wellformed_alt
    by blast
  then have src_et_not_tg_ig: "src et \<notin> NT (TG IG)"
    using combine_nodes_distinct
    by blast
  assume "n \<in> N IG"
  then have "type\<^sub>n n \<in> NT (TG IG)"
    using instance_graph_valid instance_graph.validity_node_typed
    by blast
  then have type_n_not_tg2: "type\<^sub>n n \<notin> NT TG2"
    using combine_nodes_distinct
    by blast
  assume "(type\<^sub>n n, src et) \<in> (inh (TG IG) \<union> inh TG2)\<^sup>+"
  then have "(type\<^sub>n n, src et) \<in> inh (TG IG) \<union> inh TG2"
    using combine_nodes_distinct instance_graph.validity_type_graph instance_graph_valid tg_combine_distinct_inh type_graph_second_valid
    by blast
  then have "False"
    using Un_iff instance_graph.validity_type_graph type_graph.structure_inheritance_wellformed_first_node
    using type_graph.structure_inheritance_wellformed_second_node type_graph_second_valid type_n_not_tg2
    using instance_graph_valid src_et_not_tg_ig
    by metis
  then show "0 in m_out (mult TG2 et)"
    by simp
next
  fix et n
  assume et_in_tg_ig: "et \<in> ET (TG IG)"
  then have "tgt et \<in> NT (TG IG)"
    using instance_graph.validity_type_graph instance_graph_valid type_graph.structure_edges_wellformed_alt
    by blast
  then have tgt_et_not_tg2: "tgt et \<notin> NT TG2"
    using combine_nodes_distinct
    by blast
  assume n_in_in_ig: "n \<in> N IG"
  assume "(type\<^sub>n n, tgt et) \<in> (inh (TG IG) \<union> inh TG2)\<^sup>+"
  then have "(type\<^sub>n n, tgt et) \<in> inh (TG IG) \<union> inh TG2"
    using combine_nodes_distinct instance_graph.validity_type_graph instance_graph_valid tg_combine_distinct_inh type_graph_second_valid
    by blast
  then have "(type\<^sub>n n, tgt et) \<in> inh (TG IG)"
    using UnE type_graph.structure_inheritance_wellformed_second_node type_graph_second_valid tgt_et_not_tg2
    by metis
  then show "card {e \<in> E IG. tgt e = n \<and> type\<^sub>e e = et} in m_in (mult (TG IG) et)"
    using et_in_tg_ig n_in_in_ig instance_graph_valid instance_graph.validity_ingoing_mult
    by simp
next
  fix et n
  assume "et \<in> ET TG2"
  then have "tgt et \<in> NT TG2"
    using type_graph_second_valid type_graph.structure_edges_wellformed_alt
    by blast
  then have tgt_et_not_tg_ig: "tgt et \<notin> NT (TG IG)"
    using combine_nodes_distinct
    by blast
  assume "n \<in> N IG"
  then have "type\<^sub>n n \<in> NT (TG IG)"
    using instance_graph_valid instance_graph.validity_node_typed
    by blast
  then have type_n_not_tg2: "type\<^sub>n n \<notin> NT TG2"
    using combine_nodes_distinct
    by blast
  assume "(type\<^sub>n n, tgt et) \<in> (inh (TG IG) \<union> inh TG2)\<^sup>+"
  then have "(type\<^sub>n n, tgt et) \<in> inh (TG IG) \<union> inh TG2"
    using combine_nodes_distinct instance_graph.validity_type_graph instance_graph_valid tg_combine_distinct_inh type_graph_second_valid
    by blast
  then have "False"
    using Un_iff instance_graph.validity_type_graph type_graph.structure_inheritance_wellformed_first_node
    using type_graph.structure_inheritance_wellformed_second_node type_graph_second_valid type_n_not_tg2
    using instance_graph_valid tgt_et_not_tg_ig
    by metis
  then show "0 in m_in (mult TG2 et)"
    by simp
qed (simp_all only: assms)

end


theory prop_15
imports Main
        "../../TestTheories/Listi"
        "../../TestTheories/Naturals"
        "$HIPSTER_HOME/IsaHipster"

begin

hipster rev app elem
lemma lemma_a [thy_expl]: "eqN x2 y2 = eqN y2 x2"
by (hipster_induct_schemes rev.simps app.simps elem.simps)

lemma lemma_aa [thy_expl]: "eqN x2 x2 = True"
by (hipster_induct_schemes rev.simps app.simps elem.simps)

lemma lemma_ab [thy_expl]: "app x2 NL.Nil = x2"
by (hipster_induct_schemes rev.simps app.simps elem.simps)

lemma lemma_ac [thy_expl]: "app (app x1 y1) z1 = app x1 (app y1 z1)"
by (hipster_induct_schemes rev.simps app.simps elem.simps)

lemma lemma_ad [thy_expl]: "eqN x2 (S x2) = False"
by (hipster_induct_schemes rev.simps app.simps elem.simps)

lemma lemma_ae [thy_expl]: "app (rev x13) (rev y13) = rev (app y13 x13)"
by (hipster_induct_schemes rev.simps app.simps elem.simps)

lemma lemma_af [thy_expl]: "rev (rev x12) = x12"
by (hipster_induct_schemes rev.simps app.simps elem.simps)

lemma unknown [thy_expl]: "elem x (app y z) = elem x (app z y)"
oops

lemma unknown [thy_expl]: "elem x (app y y) = elem x y"
oops

lemma unknown [thy_expl]: "elem x (rev y) = elem x y"
oops

lemma unknown [thy_expl]: "elem (S x) (app y z) = elem (S x) (app z y)"
oops

lemma unknown [thy_expl]: "elem Z (app x y) = elem Z (app y x)"
oops

lemma unknown [thy_expl]: "elem (S x) (app y y) = elem (S x) y"
oops

lemma unknown [thy_expl]: "elem (S x) (rev y) = elem (S x) y"
oops

lemma unknown [thy_expl]: "elem Z (app x x) = elem Z x"
oops

lemma unknown [thy_expl]: "elem Z (rev x) = elem Z x"
oops

lemma unknown [thy_expl]: "elem (S Z) (app x y) = elem (S Z) (app y x)"
oops

lemma unknown [thy_expl]: "elem (S Z) (app x x) = elem (S Z) x"
oops

lemma unknown [thy_expl]: "elem (S Z) (rev x) = elem (S Z) x"
oops

hipster_cond elem app eqN
lemma lemma_ag [thy_expl]: "elem x7 y7 \<Longrightarrow> elem x7 (app y7 z7) = True"
by (hipster_induct_schemes elem.simps app.simps Naturals.eqN.simps)

lemma lemma_ah [thy_expl]: "elem x5 z5 \<Longrightarrow> elem x5 (app y5 z5) = True"
by (hipster_induct_schemes elem.simps app.simps Naturals.eqN.simps)

lemma lemma_ai [thy_expl]: "elem x3 y3 \<Longrightarrow> elem Z (NL.Cons x3 y3) = elem Z y3"
by (hipster_induct_schemes elem.simps app.simps Naturals.eqN.simps)

lemma unknown [thy_expl]: "elem x (app y z) = elem x (app z y)"
oops

lemma unknown [thy_expl]: "elem x (app y y) = elem x y"
oops

lemma unknown [thy_expl]: "elem (S x) (app y z) = elem (S x) (app z y)"
oops

lemma unknown [thy_expl]: "elem Z (app x y) = elem Z (app y x)"
oops

lemma unknown [thy_expl]: "elem (S x) (app y y) = elem (S x) y"
oops

lemma unknown [thy_expl]: "elem Z (app x x) = elem Z x"
oops

lemma unknown [thy_expl]: "elem (S Z) (app x y) = elem (S Z) (app y x)"
oops

lemma unknown [thy_expl]: "elem (S Z) (app x x) = elem (S Z) x"
oops

lemma unknown [thy_expl]: "elem y z \<Longrightarrow> elem x (NL.Cons y z) = elem x z"
oops

lemma unknown [thy_expl]: "elem y z \<Longrightarrow> elem (S x) (NL.Cons y z) = elem (S x) z"
oops

lemma unknown [thy_expl]: "elem x y \<Longrightarrow> elem (S Z) (NL.Cons x y) = elem (S Z) y"
oops

theorem inRev: "elem t ts \<Longrightarrow> elem t (rev ts)"
(*apply(induction ts)  apply(simp_all)  by (metis elem.simps(2) elem02 elem03)*)
(* XXX: for some reason it requires elem.simps(2) to be specified even though elem.simps is
        artificially added within Hipster *)
by (hipster_induct_schemes elem.simps rev.simps)

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
paragraph \<open>Galois Relator\<close>
theory Transport_Compositions_Agree_Galois_Relator
  imports
    Transport_Compositions_Agree_Base
begin

context transport_comp_agree
begin

lemma Galois_le_Galois_rel_compI:
  assumes in_codom_mono_r2: "([in_codom (\<le>\<^bsub>R2\<^esub>)] \<Rrightarrow>\<^sub>m in_codom (\<le>\<^bsub>R1\<^esub>)) r2"
  and r2_L2_self_if_in_codom: "\<And>z. in_codom (\<le>\<^bsub>R2\<^esub>) z \<Longrightarrow> r2 z \<le>\<^bsub>L2\<^esub> r2 z"
  shows "(\<^bsub>L\<^esub>\<lessapprox>) \<le> ((\<^bsub>L1\<^esub>\<lessapprox>) \<circ>\<circ> (\<^bsub>L2\<^esub>\<lessapprox>))"
proof (rule le_relI)
  fix x z assume "x \<^bsub>L\<^esub>\<lessapprox> z"
  then have "x \<le>\<^bsub>L1\<^esub> r z" "in_codom (\<le>\<^bsub>R\<^esub>) z" by auto
  with \<open>x \<le>\<^bsub>L1\<^esub> r z\<close> in_codom_mono_r2 have "x \<^bsub>L1\<^esub>\<lessapprox> r2 z" by auto
  moreover from \<open>in_codom (\<le>\<^bsub>R2\<^esub>) z\<close> r2_L2_self_if_in_codom have "r2 z \<^bsub>L2\<^esub>\<lessapprox> z"
    by (intro g2.GaloisI) auto
  ultimately show "((\<^bsub>L1\<^esub>\<lessapprox>) \<circ>\<circ> (\<^bsub>L2\<^esub>\<lessapprox>)) x z" by blast
qed

lemma Galois_rel_comp_le_GaloisI:
  assumes mono_r1: "((\<le>\<^bsub>R1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L1\<^esub>)) r1"
  and trans_L1: "transitive (\<le>\<^bsub>L1\<^esub>)"
  and R1_r2_if_in_codom: "\<And>y z. in_codom (\<le>\<^bsub>R2\<^esub>) z \<Longrightarrow> y \<le>\<^bsub>L2\<^esub> r2 z \<Longrightarrow> y \<le>\<^bsub>R1\<^esub> r2 z"
  shows "((\<^bsub>L1\<^esub>\<lessapprox>) \<circ>\<circ> (\<^bsub>L2\<^esub>\<lessapprox>)) \<le> (\<^bsub>L\<^esub>\<lessapprox>)"
proof (rule le_relI)
  fix x z assume "((\<^bsub>L1\<^esub>\<lessapprox>) \<circ>\<circ> (\<^bsub>L2\<^esub>\<lessapprox>)) x z"
  then obtain y where "x \<^bsub>L1\<^esub>\<lessapprox> y" "y \<^bsub>L2\<^esub>\<lessapprox> z" by blast
  then have "x \<le>\<^bsub>L1\<^esub> r1 y" "y \<le>\<^bsub>L2\<^esub> r2 z" "in_codom (\<le>\<^bsub>R\<^esub>) z" by auto
  with R1_r2_if_in_codom have "y \<le>\<^bsub>R1\<^esub> r2 z" by blast
  with mono_r1 have "r1 y \<le>\<^bsub>L1\<^esub> r z" by auto
  with \<open>x \<le>\<^bsub>L1\<^esub> r1 y\<close> \<open>in_codom (\<le>\<^bsub>R\<^esub>) z\<close> show "x \<^bsub>L\<^esub>\<lessapprox> z" using trans_L1 by blast
qed

corollary Galois_eq_Galois_rel_compI:
  assumes "((\<le>\<^bsub>R1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L1\<^esub>)) r1"
  and "transitive (\<le>\<^bsub>L1\<^esub>)"
  and "\<And>z. in_codom (\<le>\<^bsub>R2\<^esub>) z \<Longrightarrow> r2 z \<le>\<^bsub>L2\<^esub> r2 z"
  and "\<And>y z. in_codom (\<le>\<^bsub>R2\<^esub>) z \<Longrightarrow> y \<le>\<^bsub>L2\<^esub> r2 z \<Longrightarrow> y \<le>\<^bsub>R1\<^esub> r2 z"
  shows "(\<^bsub>L\<^esub>\<lessapprox>) = ((\<^bsub>L1\<^esub>\<lessapprox>) \<circ>\<circ> (\<^bsub>L2\<^esub>\<lessapprox>))"
  using assms
  by (intro antisym Galois_le_Galois_rel_compI Galois_rel_comp_le_GaloisI
    dep_mono_wrt_predI)
  fastforce

corollary Galois_eq_Galois_rel_compI':
  assumes "((\<le>\<^bsub>R1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L1\<^esub>)) r1"
  and "transitive (\<le>\<^bsub>L1\<^esub>)"
  and "((\<le>\<^bsub>R2\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L2\<^esub>)) r2"
  and "reflexive_on (in_codom (\<le>\<^bsub>R2\<^esub>)) (\<le>\<^bsub>R2\<^esub>)"
  and "\<And>y z. in_codom (\<le>\<^bsub>R2\<^esub>) z \<Longrightarrow> y \<le>\<^bsub>L2\<^esub> r2 z \<Longrightarrow> y \<le>\<^bsub>R1\<^esub> r2 z"
  shows "(\<^bsub>L\<^esub>\<lessapprox>) = ((\<^bsub>L1\<^esub>\<lessapprox>) \<circ>\<circ> (\<^bsub>L2\<^esub>\<lessapprox>))"
  using assms by (intro Galois_eq_Galois_rel_compI) auto

corollary Galois_eq_Galois_rel_compI'':
  assumes "((\<le>\<^bsub>R1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L1\<^esub>)) r1"
  and "transitive (\<le>\<^bsub>L1\<^esub>)"
  and "((\<le>\<^bsub>R2\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L2\<^esub>)) r2"
  and "reflexive_on (in_codom (\<le>\<^bsub>L2\<^esub>)) (\<le>\<^bsub>L2\<^esub>)"
  and "\<And>y z. in_codom (\<le>\<^bsub>R2\<^esub>) z \<Longrightarrow> y \<le>\<^bsub>L2\<^esub> r2 z \<Longrightarrow> y \<le>\<^bsub>R1\<^esub> r2 z"
  shows "(\<^bsub>L\<^esub>\<lessapprox>) = ((\<^bsub>L1\<^esub>\<lessapprox>) \<circ>\<circ> (\<^bsub>L2\<^esub>\<lessapprox>))"
  using assms by (intro Galois_eq_Galois_rel_compI) (auto 0 4)

end

context transport_comp_same
begin

lemma Galois_eq_Galois_rel_compI:
  assumes "((\<le>\<^bsub>R1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L1\<^esub>)) r1"
  and "transitive (\<le>\<^bsub>L1\<^esub>)"
  and "((\<le>\<^bsub>R2\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R1\<^esub>)) r2"
  and "reflexive_on (in_codom (\<le>\<^bsub>R2\<^esub>)) (\<le>\<^bsub>R2\<^esub>)"
  shows "(\<^bsub>L\<^esub>\<lessapprox>) = ((\<^bsub>L1\<^esub>\<lessapprox>) \<circ>\<circ> (\<^bsub>L2\<^esub>\<lessapprox>))"
  using assms by (intro Galois_eq_Galois_rel_compI') auto

lemma Galois_eq_Galois_rel_compI':
  assumes "((\<le>\<^bsub>R1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L1\<^esub>)) r1"
  and "transitive (\<le>\<^bsub>L1\<^esub>)"
  and "reflexive_on (in_codom (\<le>\<^bsub>R1\<^esub>)) (\<le>\<^bsub>R1\<^esub>)"
  and "((\<le>\<^bsub>R2\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R1\<^esub>)) r2"
  shows "(\<^bsub>L\<^esub>\<lessapprox>) = ((\<^bsub>L1\<^esub>\<lessapprox>) \<circ>\<circ> (\<^bsub>L2\<^esub>\<lessapprox>))"
  using assms by (intro Galois_eq_Galois_rel_compI'') auto

end

end


theory HEAP1SanityIJW
imports HEAP1ProofsIJW
begin

lemma new1_dispose_1_identity_isar:
  assumes nat1n: "nat1 n" (* Needed to add? *)
  and n1_post: "new1_post f n f' r"
  and d1_post: "dispose1_post f' r n f''"
  and inv: "F1_inv f"
  shows "f = f''"
proof -
  from n1_post show ?thesis
  unfolding new1_post_def
  proof
    assume n1_eq: "new1_post_eq f n f' r"
    then show "f = f''"
      unfolding new1_post_eq_def
    proof(elim conjE)
      assume r_in_dom: "r \<in> dom f"
      and eq_n: "the (f r) = n"
      and f'_restr: "f' = {r} -\<triangleleft> f"
      (* Shape of below *)
      have below_shape: "dispose1_below ({r} -\<triangleleft> f) r = empty"
        unfolding dispose1_below_def
        proof (rule l_dom_r_nothing_empty)
          from inv show "{x \<in> dom ({r} -\<triangleleft> f). x + the (({r} -\<triangleleft> f) x) = r} = {}"
          proof
            assume sepf: "sep f"
              have "{x \<in> dom ({r} -\<triangleleft> f). x + the (({r} -\<triangleleft> f) x) = r}
                 =  {x \<in> dom ({r} -\<triangleleft> f). x + the (f x) = r}"
                  by (metis (full_types) Diff_iff l_dom_dom_ar f_in_dom_ar_apply_not_elem)
              also have "... \<subseteq> {x \<in> dom (f). x + the (f x) = r}"
                by (smt Collect_empty_eq l_dom_ar_not_in_dom r_in_dom sep_def sepf subsetI)
              also have "... = {}"
                by (smt Collect_empty_eq r_in_dom sep_def sepf)
            finally show ?thesis by simp
          qed
        qed
      (* Shape of above *)
      have above_shape: "dispose1_above ({r} -\<triangleleft> f) r n = empty"
      unfolding dispose1_above_def
      (*  proof (rule l_dom_r_nothing_empty) Why not work?? *)
          proof (rule l_dom_r_nothing_empty)
          from inv show "{x \<in> dom ({r} -\<triangleleft> f). x = r + n} = {}"
          proof
            assume sepf: "sep f"
              have "{x \<in> dom ({r} -\<triangleleft> f). x = r + n} \<subseteq> {x \<in> dom (f). x = r + n}"
                by (smt Collect_cong Collect_empty_eq equals0D l_dom_ar_not_in_dom subsetI)
              also have "... = {}" by (smt empty_Collect_eq eq_n r_in_dom sep_def sepf)
            finally show ?thesis by simp
          qed
        qed
      (* Shape of min_loc *)
      have min_loc_shape:  "min_loc (dispose1_ext ({r} -\<triangleleft> f) r n) = r"
        unfolding dispose1_ext_def
      proof -
        have "dispose1_above ({r} -\<triangleleft> f) r n \<union>m dispose1_below ({r} -\<triangleleft> f) r \<union>m [r \<mapsto> n]
             = [r \<mapsto> n]"
              by (simp add: above_shape l_munion_empty_lhs below_shape)
        moreover have "min_loc [r \<mapsto> n] = r"
          unfolding min_loc_def
          by simp
          ultimately show "min_loc (dispose1_above ({r} -\<triangleleft> f) r n
                              \<union>m dispose1_below ({r} -\<triangleleft> f) r \<union>m [r \<mapsto> n]) = r"
           by simp
      qed
      (* Final shape rule *)
      have sum_size_shape:  "sum_size (dispose1_ext ({r} -\<triangleleft> f) r n) = the(f r)"
        unfolding dispose1_ext_def
      proof -
        have "dispose1_above ({r} -\<triangleleft> f) r n \<union>m dispose1_below ({r} -\<triangleleft> f) r \<union>m [r \<mapsto> n]
             = [r \<mapsto> n]"
              by (simp add: above_shape l_munion_empty_lhs below_shape)
        moreover have "sum_size [r \<mapsto> n] = n"
          unfolding sum_size_def by simp
        moreover have "the (f r) = n"by (rule eq_n)
        ultimately show "sum_size (dispose1_above ({r} -\<triangleleft> f) r n
                \<union>m dispose1_below ({r} -\<triangleleft> f) r \<union>m [r \<mapsto> n]) = the (f r)"
             by simp
      qed
      (* We are now able to rewrite f'' *)
      from d1_post show ?thesis
      proof (simp only: dispose1_equiv, unfold dispose1_post2_def)
        assume "f'' = (dom (dispose1_below f' r) \<union> dom (dispose1_above f' r n)) -\<triangleleft> f' \<union>m
          [min_loc (dispose1_ext f' r n) \<mapsto> sum_size (dispose1_ext f' r n)]"
        then have "f'' = ((dom (empty) \<union> dom (empty)) -\<triangleleft> f'
                    \<union>m [min_loc (dispose1_ext f' r n) \<mapsto> sum_size (dispose1_ext f' r n)])"
             by (simp add: f'_restr below_shape above_shape)
        then have "f'' = {} -\<triangleleft> f'
                    \<union>m [min_loc (dispose1_ext f' r n) \<mapsto> sum_size (dispose1_ext f' r n)]"
                    by simp (* For some reason also wasn't working here!!! *)
        also have " ... =  f'
                    \<union>m [min_loc (dispose1_ext f' r n) \<mapsto> sum_size (dispose1_ext f' r n)]"
            by (metis l_dom_ar_empty_lhs)
       also have "...= f' \<union>m [r \<mapsto> the (f r)]"
          by (simp add: min_loc_shape sum_size_shape f'_restr)
       also have "... = ({r} -\<triangleleft> f) \<union>m [r \<mapsto> the (f r)]"
          by (simp add: f'_restr)
       also have "... =  ({r} -\<triangleleft> f) \<dagger> [r \<mapsto> the (f r)]"
          proof -
            have "dom ({r} -\<triangleleft> f) \<inter> dom [r \<mapsto> the (f r)] = {}"
              by (metis Int_insert_right_if0 dom_eq_singleton_conv f_in_dom_ar_notelem inf_bot_right)
            thus ?thesis by (simp add: munion_def)
          qed
      also have "... = f" using r_in_dom by (rule antirestr_then_dagger)
      finally show ?thesis ..
    qed
  qed
  next
    assume "new1_post_gr f n f' r"
    then show ?thesis
      unfolding new1_post_gr_def
    proof(elim conjE)
      assume r_in_dom: "r \<in> dom f"
      and gr_n: "the (f r) > n"
      and f'_restr: "f' = {r} -\<triangleleft> f \<union>m [r + n \<mapsto> the (f r) - n]"

      have disjoint_dom: " dom f \<inter> dom [r + n \<mapsto> the (f r) - n] = {}"
      proof (simp)
      show "r + n \<notin> dom  f"
      proof (rule l_plus_s_not_in_f)
        show "F1_inv f" by (metis inv)
        next
        show "r \<in> dom  f" by (rule r_in_dom)
        next
        show "n < the (f r)" by (rule gr_n)
        next
        show "nat1 n" by (rule nat1n)
      qed
    qed
      have disjoint_dom_antirestr: " dom ({r} -\<triangleleft> f) \<inter> dom [r + n \<mapsto> the (f r) - n] = {}"
        by (metis disjoint_dom l_dom_ar_disjoint_weakening)
      (* Shape of below *)
      have below_shape: "dispose1_below ({r} -\<triangleleft> f \<union>m [r + n \<mapsto> the (f r) - n]) r = empty"
         unfolding dispose1_below_def
        proof (rule l_dom_r_nothing_empty)
          from inv show "{x \<in> dom ({r} -\<triangleleft> f \<union>m [r + n \<mapsto> the (f r) - n]).
                  x + the (({r} -\<triangleleft> f \<union>m [r + n \<mapsto> the (f r) - n]) x) = r} = {}"
          proof
            assume sepf: "sep f"
              have "({r} -\<triangleleft> f \<union>m [r + n \<mapsto> the (f r) - n])
                            =({r} -\<triangleleft> f \<dagger> [r + n \<mapsto> the (f r) - n]) "
                          by (metis  disjoint_dom_antirestr munion_def)
              then have "{x \<in> dom ({r} -\<triangleleft> f \<union>m [r + n \<mapsto> the (f r) - n]).
                  x + the (({r} -\<triangleleft> f \<union>m [r + n \<mapsto> the (f r) - n]) x) = r}
                 = {x \<in> dom ({r} -\<triangleleft> f \<dagger> [r + n \<mapsto> the (f r) - n]).
                 x + the (({r} -\<triangleleft> f \<dagger> [r + n \<mapsto> the (f r) - n]) x) = r}"
                  by simp
             also have "... = {x \<in> dom ({r} -\<triangleleft> f).
                 x + the (({r} -\<triangleleft> f) x) = r} \<union> {x\<in> dom ([r + n \<mapsto> the (f r) - n]).
                          x + the  ([r + n \<mapsto> the (f r) - n] x) = r}"
             proof (subst l_dagger_dom)
                show "{x \<in> dom ({r} -\<triangleleft> f) \<union> dom [r + n \<mapsto> the (f r) - n].
                          x + the (({r} -\<triangleleft> f \<dagger> [r + n \<mapsto> the (f r) - n]) x) = r}
                   =   {x \<in> dom ({r} -\<triangleleft> f). x + the (({r} -\<triangleleft> f) x) = r}
                     \<union> {x \<in> dom [r + n \<mapsto> the (f r) - n]. x + the ([r + n \<mapsto> the (f r) - n] x) = r}"
                proof (subst union_comp)
                  show "{x \<in> dom ({r} -\<triangleleft> f). x + the (({r} -\<triangleleft> f \<dagger> [r + n \<mapsto> the (f r) - n]) x) = r}
                      \<union> {x \<in> dom [r + n \<mapsto> the (f r) - n]. x + the (({r} -\<triangleleft> f \<dagger> [r + n \<mapsto> the (f r) - n]) x) = r}
                   =   {x \<in> dom ({r} -\<triangleleft> f). x + the (({r} -\<triangleleft> f) x) = r}
                     \<union> {x \<in> dom [r + n \<mapsto> the (f r) - n]. x + the ([r + n \<mapsto> the (f r) - n] x) = r}"
                  proof -
                    have " {x \<in> dom ({r} -\<triangleleft> f). x + the (({r} -\<triangleleft> f \<dagger> [r + n \<mapsto> the (f r) - n]) x) = r}
                      = {x \<in> dom ({r} -\<triangleleft> f). x + the (({r} -\<triangleleft> f) x) = r}"
                        by (metis Int_iff `{r} -\<triangleleft> f \<union>m [r + n \<mapsto> the (f r) - n] = {r} -\<triangleleft> f \<dagger> [r + n \<mapsto> the (f r) - n]`
                       disjoint_dom_antirestr dom_eq_singleton_conv empty_iff f'_restr the_dagger_dom_left)
                   moreover have " {x \<in> dom [r + n \<mapsto> the (f r) - n]. x + the (({r} -\<triangleleft> f \<dagger> [r + n \<mapsto> the (f r) - n]) x) = r}
                            = {x \<in> dom [r + n \<mapsto> the (f r) - n]. x + the ([r + n \<mapsto> the (f r) - n] x) = r}"
                            by (metis (lifting) l_dagger_apply)
                  ultimately show ?thesis by auto
                 qed
               qed
             qed
            also have "... = {}"
                proof -
                  have "{x\<in> dom ([r + n \<mapsto> the (f r) - n]).
                          x + the  ([r + n \<mapsto> the (f r) - n] x) = r} = {}"

using nat1n by auto
                 moreover have "{x \<in> dom ({r} -\<triangleleft> f).
                 x + the (({r} -\<triangleleft> f) x) = r} = {}"
                 proof -
                  have "{x \<in> dom ({r} -\<triangleleft> f). x + the (({r} -\<triangleleft> f) x) = r}
                    \<subseteq> {x \<in> dom (f). x + the (f x) = r}"
                      by (smt Collect_cong eq_refl f_in_dom_ar_the_subsume l_dom_ar_not_in_dom r_in_dom sep_def sepf)
                  also have "... = {}"
                    by (smt Collect_empty_eq r_in_dom sep_def sepf)
                  finally show ?thesis by simp
                 qed
                ultimately show ?thesis by simp
            qed
            finally show ?thesis by simp
          qed
        qed
      have above_shape: "dispose1_above ({r} -\<triangleleft> f \<union>m [r + n \<mapsto> the (f r) - n]) r n = [r + n \<mapsto> the(f r) - n]"
      unfolding dispose1_above_def
      proof -
        have "{x \<in> dom ({r} -\<triangleleft> f \<union>m [r + n \<mapsto> the (f r) - n]). x = r + n} = {r+n}"
        proof -
          have "{x \<in> dom ({r} -\<triangleleft> f \<union>m [r + n \<mapsto> the (f r) - n]). x = r + n} =
                    {x \<in> dom ({r} -\<triangleleft> f \<dagger> [r + n \<mapsto> the (f r) - n]). x = r + n}"
                    unfolding munion_def by (subst disjoint_dom_antirestr, simp)
          also have "... =  {x \<in> dom ({r} -\<triangleleft> f). x = r + n} \<union>
                {x \<in> dom ([r + n \<mapsto> the (f r) - n]). x = r + n}"
                by(subst l_dagger_dom,rule union_comp)
          also have "... = {x \<in> dom ({r} -\<triangleleft> f). x = r + n} \<union> {r+n}"
            by auto
          also have "... = {r+n}"
          proof -
            have " {x \<in> dom ({r} -\<triangleleft> f). x = r + n} = {}"
              by (metis (lifting, mono_tags) Collect_empty_eq gr_n inv l_dom_ar_not_in_dom l_plus_s_not_in_f nat1n r_in_dom)
            thus ?thesis by auto
         qed
         finally show ?thesis by simp
       qed
        moreover have "{r+n} \<triangleleft> ({r} -\<triangleleft> f \<union>m [r + n \<mapsto> the (f r) - n]) = [r + n \<mapsto> the (f r) - n]"
        proof (subst l_dom_r_singleton)
          show "r + n \<in> dom ({r} -\<triangleleft> f \<union>m [r + n \<mapsto> the (f r) - n])"
            by (smt calculation empty_Collect_eq insert_compr)
         next
         show "[r + n \<mapsto> the (({r} -\<triangleleft> f \<union>m [r + n \<mapsto> the (f r) - n]) (r + n))]
                = [r + n \<mapsto> the (f r) - n]"
                by (metis dagger_upd_dist disjoint_dom_antirestr fun_upd_same munion_def option.sel)
        qed
        ultimately show " {x \<in> dom ({r} -\<triangleleft> f \<union>m [r + n \<mapsto> the (f r) - n]). x = r + n} \<triangleleft> ({r} -\<triangleleft> f \<union>m [r + n \<mapsto> the (f r) - n]) = [r + n \<mapsto> the (f r) - n]"
        by auto
      qed
      have min_loc_shape: "min_loc (dispose1_ext ({r} -\<triangleleft> f \<union>m [r + n \<mapsto> the (f r) - n]) r n) = r"
        unfolding dispose1_ext_def
      proof ( simp add: above_shape below_shape)
        show "min_loc ([r + n \<mapsto> the (f r) - n] \<union>m Map.empty \<union>m [r \<mapsto> n]) = r"
        proof -
            have without_empty: "[r + n \<mapsto> the (f r) - n] \<union>m Map.empty \<union>m [r \<mapsto> n]
            = [r + n \<mapsto> the (f r) - n] \<union>m [r \<mapsto> n]"
              by (metis l_munion_empty_rhs)
           then have "min_loc ([r + n \<mapsto> the (f r) - n] \<union>m [r \<mapsto> n])
                    = min_loc ([r + n \<mapsto> the (f r) - n] \<dagger> [r \<mapsto> n])"
           proof -
            have "dom ([r + n \<mapsto> the (f r) - n])\<inter> dom( [r \<mapsto> n]) = {r+n} \<inter> {r}"
              by auto
            also have "... = {}" using nat1n by auto
            finally show ?thesis by (simp add: munion_def)
           qed
           also have "...  = min (min_loc [r + n \<mapsto> the (f r) - n]) (min_loc [r \<mapsto> n])"
           by(rule min_loc_dagger,simp_all)
          also have "... = min (r+n) (r)" by (simp add: min_loc_singleton)
          also have "... = r" by simp
          finally show ?thesis using without_empty by simp
        qed
      qed
      have sum_size_shape: "sum_size (dispose1_ext ({r} -\<triangleleft> f \<union>m [r + n \<mapsto> the (f r) - n]) r n) = the(f r)"
        unfolding dispose1_ext_def
      proof ( simp add: above_shape below_shape)
        show "sum_size ([r + n \<mapsto> the (f r) - n] \<union>m empty \<union>m [r \<mapsto> n]) = the (f r)"
        proof -
            have without_empty: "[r + n \<mapsto> the (f r) - n] \<union>m Map.empty \<union>m [r \<mapsto> n]
            = [r + n \<mapsto> the (f r) - n] \<union>m [r \<mapsto> n]"
              by (metis l_munion_empty_rhs)
            then have "sum_size ([r + n \<mapsto> the (f r) - n] \<union>m [r \<mapsto> n])
                 = sum_size ([r + n \<mapsto> the (f r) - n]) + sum_size ([r \<mapsto> n])"
                 apply (subst  sum_size_munion, simp_all)
                 by (metis nat1_def nat1n)
            also have "... = the (f r) - n + n" by (simp add: sum_size_singleton)
            also have "... = the (f r)"
by (simp add: gr_n less_imp_le)
          finally show ?thesis using without_empty by simp
        qed
     qed
       from d1_post show ?thesis
      proof (simp only: dispose1_equiv, unfold dispose1_post2_def)
      assume "f'' = (dom (dispose1_below f' r) \<union> dom (dispose1_above f' r n)) -\<triangleleft> f'
          \<union>m [min_loc (dispose1_ext f' r n) \<mapsto> sum_size (dispose1_ext f' r n)]"
      then have "f'' =
              {r+n}  -\<triangleleft> f' \<union>m [min_loc (dispose1_ext f' r n) \<mapsto> sum_size (dispose1_ext f' r n)]"
               by (simp add: f'_restr below_shape above_shape)
     also have "... = ({r} -\<triangleleft> f) \<union>m [min_loc (dispose1_ext f' r n) \<mapsto> sum_size (dispose1_ext f' r n)]"
        proof -
          have "{r+n} -\<triangleleft> f' = {r+n} -\<triangleleft> ({r} -\<triangleleft> f \<union>m [r + n \<mapsto> the (f r) - n])"
            by (simp add: f'_restr)
          also have "... =  {r+n} -\<triangleleft> ({r} -\<triangleleft> (f \<union>m [r + n \<mapsto> the (f r) - n]))"
          proof(subst l_munion_dom_ar_assoc)
            show " {r} \<subseteq> dom f" by (simp add: r_in_dom)
          next
            show " dom f \<inter> dom [r + n \<mapsto> the (f r) - n] = {}" by (rule disjoint_dom)
          next
            show "{r + n} -\<triangleleft> {r} -\<triangleleft> (f \<union>m [r + n \<mapsto> the (f r) - n]) =
                  {r + n} -\<triangleleft> {r} -\<triangleleft> (f \<union>m [r + n \<mapsto> the (f r) - n])" ..
          qed
          also have "... =  {r} -\<triangleleft> ({r+n} -\<triangleleft> (f \<union>m [r + n \<mapsto> the (f r) - n]))"
            by (metis l_dom_ar_singletons_comm)
           also have "... =  {r} -\<triangleleft> ({r+n} -\<triangleleft> (f \<dagger> [r + n \<mapsto> the (f r) - n]))"
            unfolding munion_def
            by (simp only: disjoint_dom,simp)
           also have "... =  {r} -\<triangleleft> f"
           proof (subst antirestr_then_dagger_notin)
            show "r+n \<notin> dom f" using disjoint_dom by auto
            next
            show " {r} -\<triangleleft> f = {r} -\<triangleleft> f" ..
           qed
           finally show ?thesis by simp
         qed
         also have "... =  ({r} -\<triangleleft> f) \<union>m [r \<mapsto> the (f r)]"
            by (simp add: min_loc_shape sum_size_shape f'_restr)
         also have "... =  ({r} -\<triangleleft> f) \<dagger> [r \<mapsto> the (f r)]"
          proof -
            have "dom ({r} -\<triangleleft> f) \<inter> dom [r \<mapsto> the (f r)] = {}"
              by (metis Collect_conj_eq Collect_conv_if2 Collect_mem_eq dom_eq_singleton_conv f_in_dom_ar_notelem inf_commute singleton_conv2)
            thus ?thesis by (simp add: munion_def)
          qed
      also have "... = f" using r_in_dom by (rule antirestr_then_dagger)
      finally show ?thesis ..
    qed
  qed
qed
qed

end


theory Frame
  imports "Isabelle_LLVM.Frame_Infer"
begin

section "Frame"

definition frame ("_/ -- _/ \<tturnstile> _/ -- _" [0,0,0,10] 10 ) where "frame p pr q qr \<equiv> p ** pr \<turnstile> q ** qr"

abbreviation post_frame ("_/ \<tturnstile> _/ -- _" [0,0,10] 10)
  where "post_frame p q qr \<equiv> frame p \<box> q qr"

abbreviation pre_frame ("_/ -- _/ \<tturnstile> _" [0,0,10] 10)
  where "pre_frame p pr q \<equiv> frame p pr q \<box>"

lemma frameD: "p -- pr  \<tturnstile> q -- qr \<Longrightarrow> p ** pr \<turnstile> q ** qr"
  unfolding frame_def by simp

lemma frameI: "p ** pr \<turnstile> q ** qr \<Longrightarrow> p ** pr \<tturnstile> q -- qr"
  unfolding frame_def by simp

end


section "Common Proofs"

theory Common_Proof
imports Common_Aux Idle_Proof Current_Proof
begin

lemma take_rev_drop: "take_rev n xs @ acc = drop (length xs - n) (rev xs) @ acc"
  unfolding take_rev_def using rev_take by blast

lemma take_rev_step: "xs \<noteq> [] \<Longrightarrow> take_rev n (tl xs) @ (hd xs # acc) = take_rev (Suc n) xs @ acc"
  by (simp add: take_Suc)

lemma take_rev_empty [simp]: "take_rev n [] = []"
  by simp

lemma take_rev_tl_hd:
    "0 < n \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> take_rev  n xs @ ys = take_rev (n - (Suc 0)) (tl xs) @ (hd xs #ys)"
  by (simp add: take_rev_step del: take_rev_def)

lemma take_rev_nth:
    "n < length xs \<Longrightarrow> x = xs ! n \<Longrightarrow> x # take_rev n xs @ ys = take_rev (Suc n) xs @ ys"
  by (simp add: take_Suc_conv_app_nth)

lemma step_list [simp]: "invar common \<Longrightarrow> list (step common) = list common"
proof(induction common rule: step_state.induct)
  case (1 idle)
  then show ?case by auto
next
  case (2 current aux new moved)

  then show ?case
  proof(cases current)
    case (Current extra added old remained)

    with 2 have aux_not_empty: "aux \<noteq> []"
        by auto

    from 2 Current show ?thesis
    proof(cases "remained \<le> Suc moved")
      case True

      with 2 Current have "remained - length new = 1"
        by auto

      with True Current 2 aux_not_empty show ?thesis
        by(auto simp: )
    next
      case False
      with Current show ?thesis
        by(auto simp: aux_not_empty take_rev_step Suc_diff_Suc simp del: take_rev_def)
    qed
  qed
qed

lemma step_list_current [simp]: "invar common \<Longrightarrow> list_current (step common) = list_current common"
  by(cases common)(auto split: current.splits)

lemma push_list [simp]: "list (push x common) = x # list common"
proof(induction x common rule: push.induct)
  case (1 x stack stackSize)
  then show ?case
    by auto
next
  case (2 x current aux new moved)
  then show ?case
    by(induction x current rule: Current.push.induct) auto
qed

      then show ?thesis
      proof(cases "remained \<le> Suc (length new)")
        case True
        with 2 Current False
          have "take (Suc (length new)) (Stack_Aux.list old) = take (size old) (hd aux # new)"
            by(auto simp: le_Suc_eq take_Cons')

        with 2 Current True show ?thesis
          by auto
      next
        case False
        with 2 Current AUX_NOT_EMPTY show ?thesis
          by(auto simp: take_rev_step Suc_diff_Suc simp del: take_rev_def)
      qed
    qed
  qed
qed

lemma invar_push: "invar common \<Longrightarrow> invar (push x common)"
proof(induction x common rule: push.induct)
  case (1 x current stack stackSize)
  then show ?case
  proof(induction x current rule: Current.push.induct)
    case (1 x extra added old remained)
    then show ?case
    proof(induction x stack rule: Stack.push.induct)
      case (1 x left right)
      then show ?case by auto
    qed
  qed
next
  case (2 x current aux new moved)
  then show ?case
  proof(induction x current rule: Current.push.induct)
    case (1 x extra added old remained)
    then show ?case by auto
  qed
qed

lemma invar_pop: "\<lbrakk>
  0 < size common;
  invar common;
  pop common = (x, common')
\<rbrakk> \<Longrightarrow> invar common'"
proof(induction common arbitrary: x rule: pop.induct)
  case (1 current idle)
  then obtain idle' where idle: "Idle.pop idle = (x, idle')"
    by(auto split: prod.splits)

  obtain current' where current: "drop_first current = current'"
    by auto

  from 1 current idle show ?case
    using Idle_Proof.size_pop[of idle x idle', symmetric]
        size_new_pop[of current]
        size_pop_sub[of current _ current']
    by(auto simp: Idle_Proof.invar_pop invar_pop eq_snd_iff take_tl size_not_empty)
next
  case (2 current aux new moved)
  then show ?case
  proof(induction current rule: Current.pop.induct)
    case (1 added old remained)
    then show ?case
    proof(cases "remained - Suc 0 \<le> length new")
      case True

      with 1 have [simp]:
          "0 < size old"
          "Stack_Aux.list old \<noteq> []"
          "aux \<noteq> []"
          "length new = remained - Suc 0"
        by(auto simp: Stack_Proof.size_not_empty Stack_Proof.list_not_empty)

      then have [simp]: "Suc 0 \<le> size old"
        by linarith

      from 1 have "0 < remained"
        by auto

      then have "take remained (Stack_Aux.list old)
          = hd (Stack_Aux.list old) # take (remained - Suc 0) (tl (Stack_Aux.list old))"
        by (metis Suc_pred \<open>Stack_Aux.list old \<noteq> []\<close> list.collapse take_Suc_Cons)

      with 1 True show ?thesis
        using Stack_Proof.pop_list[of old]
        by(auto simp: Stack_Proof.size_not_empty)
    next
      case False
      with 1 have "remained - Suc 0 \<le> length aux + length new" by auto

      with 1 False show ?thesis
        using Stack_Proof.pop_list[of old]
        apply(auto simp: Suc_diff_Suc take_tl Stack_Proof.size_not_empty tl_append_if)
        by (simp add: Suc_diff_le rev_take tl_drop_2 tl_take)
    qed
   next
    case (2 x xs added old remained)
    then show ?case by auto
  qed
qed

lemma push_list_current [simp]: "list_current (push x left) = x # list_current left"
  by(induction x left rule: push.induct) auto

lemma pop_list [simp]: "invar common \<Longrightarrow> 0 < size common \<Longrightarrow> pop common = (x, common') \<Longrightarrow>
   x # list common' = list common"
proof(induction common arbitrary: x rule: pop.induct)
  case 1
  then show ?case
    by(auto simp: size_not_empty split: prod.splits)
next
  case (2 current aux new moved)
  then show ?case
  proof(induction current rule: Current.pop.induct)
    case (1 added old remained)
    then show ?case
    proof(cases "remained - Suc 0 \<le> length new")
      case True

      from 1 True have [simp]:
          "aux \<noteq> []" "0 < remained"
          "Stack_Aux.list old \<noteq> []" "remained - length new = 1"
        by(auto simp: Stack_Proof.size_not_empty Stack_Proof.list_not_empty)

      then have "take remained (Stack_Aux.list old) = hd aux # take (size old - Suc 0) new
             \<Longrightarrow> Stack.first old = hd aux"
        by (metis first_hd hd_take list.sel(1))

      with 1 True take_hd[of aux] show ?thesis
        by(auto simp: Suc_leI)
    next
      case False
      then show ?thesis
      proof(cases "remained - length new = length aux")
        case True

        then have length_minus_1: "remained - Suc (length new) = length aux - 1"
          by simp

        from 1 have not_empty: "0 < remained" "0 < size old"  "aux \<noteq> []" "\<not> is_empty old"
          by(auto simp: Stack_Proof.size_not_empty)

        from 1 True not_empty have "take 1 (Stack_Aux.list old) = take 1 (rev aux)"
          using take_1[of
                remained
                "size old"
                "Stack_Aux.list old"
                "(rev aux) @ take (size old + length new - remained) new"
                ]
          by(simp)

        then have "[last aux] = [Stack.first old]"
          using take_last first_take not_empty
          by fastforce

        then have "last aux = Stack.first old"
          by auto

        with 1 True False show ?thesis
          using not_empty last_drop_rev[of aux]
          by(auto simp: take_rev_drop length_minus_1 simp del: take_rev_def)
       next
        case False

        with 1 have a: "take (remained - length new) aux \<noteq> []"
          by auto

        from 1 False have b: "\<not> is_empty old"
          by(auto simp: Stack_Proof.size_not_empty)

        from 1 have c: "remained - Suc (length new) < length aux"
          by auto

        from 1 have not_empty: "0 < remained" "0 < size old" "0 < remained - length new" "0 < length aux"
          by auto

        with False have
           "take remained (Stack_Aux.list old) =
            take (size old) (take_rev (remained - length new) aux @ new)
            \<Longrightarrow> take (Suc 0) (Stack_Aux.list old) =
                take (Suc 0) (rev (take (remained - length new) aux))"
          using take_1[of
                remained
                "size old"
                "Stack_Aux.list old"
                " (take_rev (remained - length new) aux @ new)"
              ]
          by(auto simp: not_empty Suc_le_eq)

        with 1 False have
            "take 1 (Stack_Aux.list old) = take 1 (rev (take (remained - length new) aux))"
          by auto

        then have d: "[Stack.first old] = [last (take (remained - length new) aux)]"
          using take_last first_take a b
          by metis

        have "last (take (remained - length new) aux) # rev (take (remained - Suc (length new)) aux)
            = rev (take (remained - length new) aux)"
          using Suc_diff_Suc c not_empty
          by (metis a drop_drop last_drop_rev plus_1_eq_Suc rev_take zero_less_diff)

        with 1(1) 1(3) False not_empty d show ?thesis
          by(cases "remained - length new = 1") (auto)
      qed
    qed
  next
    case 2
    then show ?case by auto
  qed
qed

lemma pop_list_current: "invar common \<Longrightarrow> 0 < size common \<Longrightarrow> pop common = (x, common')
   \<Longrightarrow> x # list_current common' = list_current common"
proof(induction common arbitrary: x rule: pop.induct)
  case (1 current idle)
  then show ?case
  proof(induction idle rule: Idle.pop.induct)
    case (1 stack stackSize)
    then show ?case
    proof(induction current rule: Current.pop.induct)
      case (1 added old remained)
      then have "Stack.first old = Stack.first stack"
        using take_first[of old stack]
        by auto

      with 1 show ?case
        by(auto simp: Stack_Proof.size_not_empty Stack_Proof.list_not_empty)
    next
      case (2 x xs added old remained)
      then have "0 < size stack"
        by auto

      with Stack_Proof.size_not_empty Stack_Proof.list_not_empty
      have not_empty: "\<not> is_empty stack" "Stack_Aux.list stack \<noteq> []"
        by auto

      with 2 have "hd (Stack_Aux.list stack) = x"
        using take_hd'[of "Stack_Aux.list stack" x "xs @ Stack_Aux.list old"]
        by auto

      with 2 show ?case
        using first_list[of stack] not_empty
        by auto
    qed
  qed
next
  case (2 current)
  then show ?case
  proof(induction current rule: Current.pop.induct)
    case (1 added old remained)
    then have "\<not> is_empty old"
      by(auto simp: Stack_Proof.size_not_empty)

    with 1 show ?case
      using first_pop
      by(auto simp: Stack_Proof.list_not_empty)
  next
    case 2
    then show ?case by auto
  qed
qed

lemma list_current_size [simp]:
  "\<lbrakk>0 < size common; list_current common = []; invar common\<rbrakk> \<Longrightarrow> False"
proof(induction common rule: invar_state.induct)
  case 1
  then show ?case
    using list_size by auto
next
  case (2 current)
  then have "invar current"
            "Current_Aux.list current = []"
            "0 < size current"
    by(auto split: current.splits)

  then show ?case using list_size by auto
qed

lemma list_size [simp]: "\<lbrakk>0 < size common; list common = []; invar common\<rbrakk> \<Longrightarrow> False"
proof(induction common rule: invar_state.induct)
  case 1
  then show ?case
    using list_size Idle_Proof.size_empty
    by auto
next
  case (2 current aux new moved)
  then have "invar current"
            "Current_Aux.list current = []"
            "0 < size current"
    by(auto split: current.splits)

  then show ?case using list_size by auto
qed

lemma step_size [simp]: "invar (common :: 'a state) \<Longrightarrow> size (step common) = size common"
proof(induction common rule: step_state.induct)
  case 1
  then show ?case by auto
next
  case 2
  then show ?case
    by(auto simp: min_def split: current.splits)
qed

lemma step_size_new [simp]: "invar (common :: 'a state)
   \<Longrightarrow> size_new (step common) = size_new common"
proof(induction common rule: step_state.induct)
  case (1 current idle)
  then show ?case by auto
next
  case (2 current aux new moved)
  then show ?case by(auto split: current.splits)
qed

lemma remaining_steps_step [simp]: "\<lbrakk>invar (common :: 'a state); remaining_steps common > 0\<rbrakk>
   \<Longrightarrow> Suc (remaining_steps (step common)) = remaining_steps common"
  by(induction common)(auto split: current.splits)

lemma remaining_steps_step_sub [simp]: "\<lbrakk>invar (common :: 'a state)\<rbrakk>
 \<Longrightarrow> remaining_steps (step common) = remaining_steps common - 1"
  by(induction common)(auto split: current.splits)

lemma remaining_steps_step_0 [simp]: "\<lbrakk>invar (common :: 'a state); remaining_steps common = 0\<rbrakk>
   \<Longrightarrow> remaining_steps (step common) = 0"
  by(induction common)(auto split: current.splits)

lemma remaining_steps_push [simp]: "invar common
   \<Longrightarrow> remaining_steps (push x common) = remaining_steps common"
  by(induction x common rule: Common.push.induct)(auto split: current.splits)

lemma remaining_steps_pop: "\<lbrakk>invar common; pop common = (x, common')\<rbrakk>
  \<Longrightarrow> remaining_steps common' \<le> remaining_steps common"
proof(induction common rule: pop.induct)
  case (1 current idle)
  then show ?case
  proof(induction idle rule: Idle.pop.induct)
    case 1
    then show ?case
      by(induction current rule: Current.pop.induct) auto
  qed
next
  case (2 current aux new moved)
  then show ?case
    by(induction current rule: Current.pop.induct) auto
qed

lemma size_push [simp]: "invar common \<Longrightarrow> size (push x common) = Suc (size common)"
  by(induction x common rule: push.induct) (auto split: current.splits)

lemma size_new_push [simp]: "invar common \<Longrightarrow> size_new (push x common) = Suc (size_new common)"
  by(induction x common rule: Common.push.induct) (auto split: current.splits)

lemma size_pop [simp]: "\<lbrakk>invar common; 0 < size common; pop common = (x, common')\<rbrakk>
   \<Longrightarrow> Suc (size common') = size common"
proof(induction common rule: Common.pop.induct)
  case (1 current idle)
  then show ?case
    using size_drop_first_sub[of current] Idle_Proof.size_pop_sub[of idle]
    by(auto simp: size_not_empty split: prod.splits)
next
  case (2 current aux new moved)
  then show ?case
    by(induction current rule: Current.pop.induct) auto
qed

lemma size_new_pop [simp]: "\<lbrakk>invar common; 0 < size_new common; pop common = (x, common')\<rbrakk>
   \<Longrightarrow>  Suc (size_new common') = size_new common"
proof(induction common rule: Common.pop.induct)
  case (1 current idle)
  then show ?case
    using size_new_pop[of current]
    by(auto split: prod.splits)
next
  case (2 current aux new moved)
  then show ?case
  proof(induction current rule: Current.pop.induct)
    case (1 added old remained)
    then show ?case by auto
  next
    case (2 x xs added old remained)
    then show ?case by auto
  qed
qed

lemma size_size_new: "\<lbrakk>invar (common :: 'a state); 0 < size common\<rbrakk> \<Longrightarrow> 0 < size_new common"
  by(cases common) auto

end


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

section "L4V-Internal Word Lemmas"

text \<open>
  This is a holding area for Word utility lemmas that are too specific or unpolished for the
  AFP, but which are reusable enough to be collected together for the rest of L4V. New
  utility lemmas that only prove facts about words should be added here (in preference to being
  kept where they were first needed).
\<close>

theory Word_Lemmas_Internal
imports Word_Lemmas
begin

lemma signed_ge_zero_scast_eq_ucast:
 "0 <=s x \<Longrightarrow> scast x = ucast x"
  by (simp add: scast_eq_ucast word_sle_msb_le)

(* FIXME: move out of Word_Lib *)
lemma disjCI2:
  "(\<not> P \<Longrightarrow> Q) \<Longrightarrow> P \<or> Q"
  by blast

(* FIXME: move out of Word_Lib *)
lemma nat_diff_diff_le_lhs:
  "a + c - b \<le> d \<Longrightarrow> a - (b - c) \<le> (d :: nat)"
  by arith

lemma is_aligned_obvious_no_wrap':
  "\<lbrakk> is_aligned ptr sz; x = 2 ^ sz - 1 \<rbrakk>
   \<Longrightarrow> ptr \<le> ptr + x"
  by (fastforce simp: field_simps intro: is_aligned_no_overflow)

lemmas add_ge0_weak = add_increasing[where 'a=int and b=0]

lemmas aligned_sub_aligned = Aligned.aligned_sub_aligned'

lemma minus_minus_swap:
  "\<lbrakk> a \<le> c; b \<le> d; b \<le> a; d \<le> c ; (d :: nat) - b = c - a \<rbrakk>
   \<Longrightarrow> a - b = c - d"
  by arith

lemma minus_minus_swap':
  "\<lbrakk> c \<le> a; d \<le> b; b \<le> a; d \<le> c ; (b :: nat) - d = a - c \<rbrakk>
   \<Longrightarrow> a - b = c - d"
  by arith

lemmas word_le_mask_eq = le_mask_imp_and_mask

lemma int_and_leR:
  "0 \<le> b \<Longrightarrow> a AND b \<le> (b :: int)"
  by (rule AND_upper2)

lemma int_and_leL:
  "0 \<le> a \<Longrightarrow> a AND b \<le> (a :: int)"
  by (rule AND_upper1)

lemma if_then_1_else_0:
  "(if P then 1 else 0) = (0 :: 'a :: zero_neq_one) \<longleftrightarrow> \<not>P"
  by (simp split: if_split)

lemma if_then_0_else_1:
  "(if P then 0 else 1) = (0 :: 'a :: zero_neq_one) \<longleftrightarrow> P"
  by simp

lemmas if_then_simps = if_then_0_else_1 if_then_1_else_0

lemma createNewCaps_guard:
  fixes x :: "'a :: len word"
  shows "\<lbrakk> unat x = c; b < 2 ^ LENGTH('a) \<rbrakk>
         \<Longrightarrow> (n < of_nat b \<and> n < x) = (n < of_nat (min (min b c) c))"
  apply (erule subst)
  apply (simp add: min.assoc)
  apply (rule iffI)
   apply (simp add: min_def word_less_nat_alt split: if_split)
  apply (simp add: min_def word_less_nat_alt not_le le_unat_uoi split: if_split_asm)
  by (simp add: of_nat_inverse)

lemma bits_2_subtract_ineq:
  "i < (n :: ('a :: len) word)
   \<Longrightarrow> 2 ^ bits + 2 ^ bits * unat (n - (1 + i)) = unat (n - i) * 2 ^ bits"
  apply (simp add: unat_sub word_minus_one_le_leq)
  apply (subst unatSuc)
   apply clarsimp
   apply unat_arith
  apply (simp only: mult_Suc_right[symmetric])
  apply (rule trans[OF mult.commute], rule arg_cong2[where f="(*)"], simp_all)
  apply (simp add: word_less_nat_alt)
  done

lemmas double_neg_mask = neg_mask_combine

lemmas int_unat = uint_nat[symmetric]

lemmas word_sub_mono3 = word_plus_mcs_4'

lemma shift_distinct_helper:
  "\<lbrakk> (x :: 'a :: len word) < bnd; y < bnd; x \<noteq> y; x << n = y << n; n < LENGTH('a);
     bnd - 1 \<le> 2 ^ (LENGTH('a) - n) - 1 \<rbrakk>
   \<Longrightarrow> P"
  apply (cases "n = 0")
   apply simp
  apply (drule word_plus_mono_right[where x=1])
   apply simp_all
   apply (subst word_le_sub1)
    apply (rule power_not_zero)
    apply simp
   apply simp
  apply (drule(1) order_less_le_trans)+
  apply (clarsimp simp: bang_eq)
  apply (drule_tac x="na + n" in spec)
  apply (simp add: nth_shiftl)
  apply (case_tac "na + n < LENGTH('a)", simp_all)
  apply safe
   apply (drule(1) nth_bounded)
    apply simp
   apply simp
  apply (drule(1) nth_bounded)
   apply simp
  apply simp
  done

lemma of_nat_shift_distinct_helper:
  "\<lbrakk> x < bnd; y < bnd; x \<noteq> y; (of_nat x :: 'a :: len word) << n = of_nat y << n;
     n < LENGTH('a); bnd \<le> 2 ^ (LENGTH('a) - n) \<rbrakk>
   \<Longrightarrow> P"
  apply (cases "n = 0")
   apply (simp add: word_unat.Abs_inject unats_def)
  apply (subgoal_tac "bnd < 2 ^ LENGTH('a)")
   apply (erule(1) shift_distinct_helper[rotated, rotated, rotated])
      defer
      apply (erule(1) of_nat_mono_maybe[rotated])
     apply (erule(1) of_nat_mono_maybe[rotated])
    apply (simp add: word_unat.Abs_inject unats_def)
   apply (erule order_le_less_trans)
   apply (rule power_strict_increasing)
    apply simp
   apply simp
  apply (simp add: word_less_nat_alt)
  apply (simp add: unat_minus_one [OF of_nat_neq_0]
                   word_unat.Abs_inverse unats_def)
  done

lemmas pre_helper2 = add_mult_in_mask_range[folded add_mask_fold]

lemma ptr_add_distinct_helper:
  "\<lbrakk> ptr_add (p :: 'a :: len word) (x * 2 ^ n) = ptr_add p (y * 2 ^ n); x \<noteq> y;
     x < bnd; y < bnd; n < LENGTH('a);
     bnd \<le> 2 ^ (LENGTH('a) - n) \<rbrakk>
   \<Longrightarrow> P"
  apply (clarsimp simp: ptr_add_def word_unat_power[symmetric]
                        shiftl_t2n[symmetric, simplified mult.commute])
  using of_nat_shift_distinct_helper
  by blast

lemma unat_sub_le_strg:
  "unat v \<le> v2 \<and> x \<le> v \<and> y \<le> v \<and> y < (x :: ('a :: len) word)
    \<longrightarrow> unat (x + (- 1 - y)) \<le> v2"
  apply clarsimp
  apply (erule order_trans[rotated])
  apply (fold word_le_nat_alt)
  apply (rule order_trans[rotated], assumption)
  apply (rule order_trans[rotated], rule word_sub_le[where y="y + 1"])
   apply (erule Word.inc_le)
  apply (simp add: field_simps)
  done

lemma multi_lessD:
  "\<lbrakk> (a :: nat) * b < c; 0 < a; 0 < b \<rbrakk>
   \<Longrightarrow> a < c \<and> b < c"
  by (cases a, simp_all,cases b,simp_all)

lemmas leq_high_bits_shiftr_low_bits_leq_bits =
  leq_high_bits_shiftr_low_bits_leq_bits_mask[unfolded mask_2pm1[of high_bits]]

lemmas unat_le_helper = word_unat_less_le

lemmas word_of_nat_plus = of_nat_add[where 'a="'a :: len word"]
lemmas word_of_nat_minus = of_nat_diff[where 'a="'a :: len word"]

(* this is a bit deceptive: 2 ^ len.. = 0, so really this is relying on 'word_n1_ge': ptr \<le> -1 *)
lemma word_up_bound:
  "(ptr :: 'a :: len word) \<le> 2 ^ LENGTH('a) - 1 "
  by auto

lemma base_length_minus_one_inequality:
  assumes foo: "wbase \<le> 2 ^ sz - 1"
    "1 \<le> (wlength :: ('a :: len) word)"
    "wlength \<le> 2 ^ sz - wbase"
    "sz < LENGTH ('a)"
  shows "wbase \<le> wbase + wlength - 1"
proof -

  note sz_less = power_strict_increasing[OF foo(4), where a=2]

  from foo have plus: "unat wbase + unat wlength < 2 ^ LENGTH('a)"
    apply -
    apply (rule order_le_less_trans[rotated], rule sz_less, simp)
    apply (simp add: unat_arith_simps split: if_split_asm)
    done

  from foo show ?thesis
   by (simp add: unat_arith_simps plus)
qed

lemmas from_bool_to_bool_and_1 = from_to_bool_last_bit[where x=r for r]

lemmas max_word_neq_0 = max_word_not_0

lemmas word_le_p2m1 = word_up_bound[where ptr=w for w]

lemma inj_ucast:
  "\<lbrakk> uc = ucast; is_up uc \<rbrakk>
   \<Longrightarrow> inj uc"
  using down_ucast_inj is_up_down by blast

lemma ucast_eq_0[OF refl]:
  "\<lbrakk> c = ucast; is_up c \<rbrakk>
   \<Longrightarrow> (c x = 0) = (x = 0)"
  by (metis uint_0_iff uint_up_ucast)

lemmas is_up_compose' = is_up_compose

lemma uint_is_up_compose:
  fixes uc :: "'a :: len word \<Rightarrow> 'b :: len word"
    and uc' :: "'b word \<Rightarrow> 'c :: len sword"
  assumes "uc = ucast"
    and "uc' = ucast"
    and " uuc = uc' \<circ> uc"
  shows "\<lbrakk> is_up uc; is_up uc' \<rbrakk>
         \<Longrightarrow> uint (uuc b) = uint b"
  apply (simp add: assms)
  apply (frule is_up_compose)
   apply (simp_all )
  apply (simp only: Word.uint_up_ucast)
  done

lemma uint_is_up_compose_pred:
  fixes uc :: "'a :: len word \<Rightarrow> 'b :: len word"
    and uc' :: "'b word \<Rightarrow> 'c :: len sword"
  assumes "uc = ucast" and "uc' = ucast" and " uuc = uc' \<circ> uc"
  shows "\<lbrakk> is_up uc; is_up uc' \<rbrakk>
         \<Longrightarrow> P (uint (uuc b)) \<longleftrightarrow> P( uint b)"
  apply (simp add: assms)
  apply (frule is_up_compose)
   apply (simp_all )
  apply (simp only: Word.uint_up_ucast)
 done

lemma is_down_up_sword:
  fixes uc :: "'a :: len word \<Rightarrow> 'b :: len sword"
  shows "\<lbrakk> uc = ucast; LENGTH('a) < LENGTH('b) \<rbrakk>
         \<Longrightarrow> is_up uc = (\<not> is_down uc)"
  by (simp add: target_size source_size  is_up_def is_down_def )

lemma is_not_down_compose:
  fixes uc :: "'a :: len word \<Rightarrow> 'b :: len word"
    and uc' :: "'b word \<Rightarrow> 'c :: len sword"
  shows "\<lbrakk> uc = ucast; uc' = ucast; LENGTH('a) < LENGTH('c) \<rbrakk>
         \<Longrightarrow> \<not> is_down (uc' \<circ> uc)"
  unfolding is_down_def
  by (simp add: Word.target_size Word.source_size)

lemma sint_ucast_uint:
  fixes uc :: "'a :: len word \<Rightarrow> 'b :: len word"
    and uc' :: "'b word \<Rightarrow> 'c :: len sword"
  assumes "uc = ucast" and " uc' = ucast" and "uuc=uc' \<circ> uc "
    and "LENGTH('a) < LENGTH('c signed)"
  shows "\<lbrakk> is_up uc; is_up uc'\<rbrakk>
         \<Longrightarrow> sint (uuc b) = uint b"
  apply (simp add: assms)
  apply (frule is_up_compose')
   apply simp_all
  apply (simp add: ucast_ucast_b)
  apply (rule sint_ucast_eq_uint)
  apply (insert assms)
  apply (simp add: is_down_def target_size source_size)
  done

lemma sint_ucast_uint_pred:
  fixes uc :: "'a :: len word \<Rightarrow> 'b :: len word"
    and uc' :: "'b word \<Rightarrow> 'c :: len sword"
    and uuc :: "'a word \<Rightarrow> 'c sword"
  assumes "uc = ucast" and " uc' = ucast" and "uuc=uc' \<circ> uc "
    and "LENGTH('a) < LENGTH('c )"
  shows "\<lbrakk> is_up uc; is_up uc' \<rbrakk>
         \<Longrightarrow> P (uint b) \<longleftrightarrow> P (sint (uuc b))"
  apply (simp add: assms )
  apply (insert sint_ucast_uint[where uc=uc and uc'=uc' and uuc=uuc and b = b])
  apply (simp add: assms)
 done

lemma sint_uucast_uint_uucast_pred:
  fixes uc :: "'a :: len word \<Rightarrow> 'b :: len word"
    and uc' :: "'b word \<Rightarrow> 'c :: len sword"
  assumes "uc = ucast" and " uc' = ucast" and "uuc=uc' \<circ> uc "
    and "LENGTH('a) < LENGTH('c )"
  shows "\<lbrakk> is_up uc; is_up uc' \<rbrakk>
         \<Longrightarrow> P (uint(uuc b)) \<longleftrightarrow> P (sint (uuc b))"
  apply (simp add: assms )
  apply (insert sint_ucast_uint[where uc=uc and uc'=uc' and uuc=uuc and b = b])
  apply (insert uint_is_up_compose_pred[where uc=uc and uc'=uc' and uuc=uuc and b=b])
  apply (simp add: assms uint_is_up_compose_pred)
 done

lemma unat_minus':
  fixes x :: "'a :: len word"
  shows "x \<noteq> 0 \<Longrightarrow> unat (-x) = 2 ^ LENGTH('a) - unat x"
  by (simp add: unat_minus wsst_TYs(3))

lemma word_nth_neq:
  "n < LENGTH('a) \<Longrightarrow> (~~ x :: 'a :: len word) !! n = (\<not> x !! n)"
  by (simp add: word_size word_ops_nth_size)

lemma word_wrap_of_natD:
  fixes x :: "'a :: len word"
  assumes wraps: "\<not> x \<le> x + of_nat n"
  shows   "\<exists>k. x + of_nat k = 0 \<and> k \<le> n"
proof -
  show ?thesis
  proof (rule exI [where x = "unat (- x)"], intro conjI)
    show "x + of_nat (unat (-x)) = 0"
      by simp
  next
    show "unat (-x) \<le> n"
    proof (subst unat_minus')
      from wraps show "x \<noteq> 0"
        by (rule contrapos_pn, simp add: not_le)
    next
      show "2 ^ LENGTH('a) - unat x \<le> n" using wraps
        apply (simp add: no_olen_add_nat le_diff_conv not_less)
        apply (erule order_trans)
        apply (simp add: unat_of_nat)
        done
    qed
  qed
qed

lemma two_bits_cases:
  "\<lbrakk> LENGTH('a) > 2; (x :: 'a :: len word) && 3 = 0 \<Longrightarrow> P; x && 3 = 1 \<Longrightarrow> P;
     x && 3 = 2 \<Longrightarrow> P; x && 3 = 3 \<Longrightarrow> P \<rbrakk>
   \<Longrightarrow> P"
  apply (frule and_mask_cases[where n=2 and x=x, simplified mask_def])
  using upt_conv_Cons by auto[1]

lemma zero_OR_eq:
  "y = 0 \<Longrightarrow> (x || y) = x"
  by simp

declare is_aligned_neg_mask_eq[simp]
declare is_aligned_neg_mask_weaken[simp]

lemmas mask_in_range = neg_mask_in_mask_range[folded add_mask_fold]
lemmas aligned_range_offset_mem = aligned_offset_in_range[folded add_mask_fold]
lemmas range_to_bl' = mask_range_to_bl'[folded add_mask_fold]
lemmas range_to_bl = mask_range_to_bl[folded add_mask_fold]
lemmas aligned_ranges_subset_or_disjoint = aligned_mask_range_cases[folded add_mask_fold]
lemmas aligned_range_offset_subset = aligned_mask_range_offset_subset[folded add_mask_fold]
lemmas aligned_diff = aligned_mask_diff[unfolded mask_2pm1]
lemmas aligned_ranges_subset_or_disjoint_coroll = aligned_mask_ranges_disjoint[folded add_mask_fold]
lemmas distinct_aligned_addresses_accumulate = aligned_mask_ranges_disjoint2[folded add_mask_fold]

lemmas bang_big = test_bit_over

end