section \<open>Implementing Graphs\<close>
(* Author: Peter Lammich *)
theory Digraph_Impl
imports Digraph
begin

subsection \<open>Directed Graphs by Successor Function\<close>
type_synonym 'a slg = "'a \<Rightarrow> 'a list"

definition slg_rel :: "('a\<times>'b) set \<Rightarrow> ('a slg \<times> 'b digraph) set" where
  slg_rel_def_internal: "slg_rel R \<equiv>
  (R \<rightarrow> \<langle>R\<rangle>list_set_rel) O br (\<lambda>succs. {(u,v). v\<in>succs u}) (\<lambda>_. True)"

lemma slg_rel_def: "\<langle>R\<rangle>slg_rel =
  (R \<rightarrow> \<langle>R\<rangle>list_set_rel) O br (\<lambda>succs. {(u,v). v\<in>succs u}) (\<lambda>_. True)"
  unfolding slg_rel_def_internal relAPP_def by simp

lemma slg_rel_sv[relator_props]:
  "\<lbrakk>single_valued R; Range R = UNIV\<rbrakk> \<Longrightarrow> single_valued (\<langle>R\<rangle>slg_rel)"
  unfolding slg_rel_def
  by (tagged_solver)

consts i_slg :: "interface \<Rightarrow> interface"
lemmas [autoref_rel_intf] = REL_INTFI[of slg_rel i_slg]

definition [simp]: "op_slg_succs E v \<equiv> E``{v}"

lemma [autoref_itype]: "op_slg_succs ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_slg \<rightarrow>\<^sub>i I \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set" by simp

context begin interpretation autoref_syn .

lemma refine_slg_succs[autoref_rules_raw]:
  "(\<lambda>succs v. succs v,op_slg_succs)\<in>\<langle>R\<rangle>slg_rel\<rightarrow>R\<rightarrow>\<langle>R\<rangle>list_set_rel"
  apply (intro fun_relI)
  apply (auto simp add: slg_rel_def br_def dest: fun_relD)
  done

definition "E_of_succ succ \<equiv> { (u,v). v\<in>succ u }"
definition "succ_of_E E \<equiv> (\<lambda>u. {v . (u,v)\<in>E})"

lemma E_of_succ_of_E[simp]: "E_of_succ (succ_of_E E) = E"
  unfolding E_of_succ_def succ_of_E_def
  by auto

lemma succ_of_E_of_succ[simp]: "succ_of_E (E_of_succ E) = E"
  unfolding E_of_succ_def succ_of_E_def
  by auto

context begin interpretation autoref_syn .
  lemma [autoref_itype]: "E_of_succ ::\<^sub>i (I \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set) \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_slg" by simp
  lemma [autoref_itype]: "succ_of_E ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_slg \<rightarrow>\<^sub>i I \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set" by simp
end

lemma E_of_succ_refine[autoref_rules]:
  "(\<lambda>x. x, E_of_succ) \<in> (R \<rightarrow> \<langle>R\<rangle>list_set_rel) \<rightarrow> \<langle>R\<rangle>slg_rel"
  "(\<lambda>x. x, succ_of_E) \<in> \<langle>R\<rangle>slg_rel \<rightarrow> (R \<rightarrow> \<langle>R\<rangle>list_set_rel)"
  unfolding E_of_succ_def[abs_def] succ_of_E_def[abs_def] slg_rel_def br_def
  apply auto []
  apply clarsimp
  apply (blast dest: fun_relD)
  done

subsubsection \<open>Restricting Edges\<close>
definition op_graph_restrict :: "'v set \<Rightarrow> 'v set \<Rightarrow> ('v \<times> 'v) set \<Rightarrow> ('v \<times> 'v) set"
  where [simp]: "op_graph_restrict Vl Vr E \<equiv> E \<inter> Vl \<times> Vr"

definition op_graph_restrict_left :: "'v set \<Rightarrow> ('v \<times> 'v) set \<Rightarrow> ('v \<times> 'v) set"
  where [simp]: "op_graph_restrict_left Vl E \<equiv> E \<inter> Vl \<times> UNIV"

definition op_graph_restrict_right :: "'v set \<Rightarrow> ('v \<times> 'v) set \<Rightarrow> ('v \<times> 'v) set"
  where [simp]: "op_graph_restrict_right Vr E \<equiv> E \<inter> UNIV \<times> Vr"

lemma [autoref_op_pat]:
  "E \<inter> (Vl \<times> Vr) \<equiv> op_graph_restrict Vl Vr E"
  "E \<inter> (Vl \<times> UNIV) \<equiv> op_graph_restrict_left Vl E"
  "E \<inter> (UNIV \<times> Vr) \<equiv> op_graph_restrict_right Vr E"
  by simp_all

lemma graph_restrict_aimpl: "op_graph_restrict Vl Vr E =
  E_of_succ (\<lambda>v. if v\<in>Vl then {x \<in> E``{v}. x\<in>Vr} else {})"
  by (auto simp: E_of_succ_def succ_of_E_def split: if_split_asm)
lemma graph_restrict_left_aimpl: "op_graph_restrict_left Vl E =
  E_of_succ (\<lambda>v. if v\<in>Vl then E``{v} else {})"
  by (auto simp: E_of_succ_def succ_of_E_def split: if_split_asm)
lemma graph_restrict_right_aimpl: "op_graph_restrict_right Vr E =
  E_of_succ (\<lambda>v. {x \<in> E``{v}. x\<in>Vr})"
  by (auto simp: E_of_succ_def succ_of_E_def split: if_split_asm)

schematic_goal graph_restrict_impl_aux:
  fixes Rsl Rsr
  notes [autoref_rel_intf] = REL_INTFI[of Rsl i_set] REL_INTFI[of Rsr i_set]
  assumes [autoref_rules]: "(meml, (\<in>)) \<in> R \<rightarrow> \<langle>R\<rangle>Rsl \<rightarrow> bool_rel"
  assumes [autoref_rules]: "(memr, (\<in>)) \<in> R \<rightarrow> \<langle>R\<rangle>Rsr \<rightarrow> bool_rel"
  shows "(?c, op_graph_restrict) \<in> \<langle>R\<rangle>Rsl \<rightarrow> \<langle>R\<rangle>Rsr \<rightarrow> \<langle>R\<rangle>slg_rel \<rightarrow> \<langle>R\<rangle>slg_rel"
  unfolding graph_restrict_aimpl[abs_def]
  apply (autoref (keep_goal))
  done

schematic_goal graph_restrict_left_impl_aux:
  fixes Rsl Rsr
  notes [autoref_rel_intf] = REL_INTFI[of Rsl i_set] REL_INTFI[of Rsr i_set]
  assumes [autoref_rules]: "(meml, (\<in>)) \<in> R \<rightarrow> \<langle>R\<rangle>Rsl \<rightarrow> bool_rel"
  shows "(?c, op_graph_restrict_left) \<in> \<langle>R\<rangle>Rsl \<rightarrow> \<langle>R\<rangle>slg_rel \<rightarrow> \<langle>R\<rangle>slg_rel"
  unfolding graph_restrict_left_aimpl[abs_def]
  apply (autoref (keep_goal, trace))
  done

schematic_goal graph_restrict_right_impl_aux:
  fixes Rsl Rsr
  notes [autoref_rel_intf] = REL_INTFI[of Rsl i_set] REL_INTFI[of Rsr i_set]
  assumes [autoref_rules]: "(memr, (\<in>)) \<in> R \<rightarrow> \<langle>R\<rangle>Rsr \<rightarrow> bool_rel"
  shows "(?c, op_graph_restrict_right) \<in> \<langle>R\<rangle>Rsr \<rightarrow> \<langle>R\<rangle>slg_rel \<rightarrow> \<langle>R\<rangle>slg_rel"
  unfolding graph_restrict_right_aimpl[abs_def]
  apply (autoref (keep_goal, trace))
  done

concrete_definition graph_restrict_impl uses graph_restrict_impl_aux
concrete_definition graph_restrict_left_impl uses graph_restrict_left_impl_aux
concrete_definition graph_restrict_right_impl uses graph_restrict_right_impl_aux

context begin interpretation autoref_syn .
  lemma [autoref_itype]:
    "op_graph_restrict ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_slg \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_slg"
    "op_graph_restrict_right ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_slg \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_slg"
    "op_graph_restrict_left ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_slg \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_slg"
    by auto
end

lemmas [autoref_rules_raw] =
  graph_restrict_impl.refine[OF GEN_OP_D GEN_OP_D]
  graph_restrict_left_impl.refine[OF GEN_OP_D]
  graph_restrict_right_impl.refine[OF GEN_OP_D]

schematic_goal "(?c::?'c, \<lambda>(E::nat digraph) x. E``{x}) \<in> ?R"
  apply (autoref (keep_goal))
  done

lemma graph_minus_aimpl:
  fixes E1 E2 :: "'a rel"
  shows "E1-E2 = E_of_succ (\<lambda>x. E1``{x} - E2``{x})"
  by (auto simp: E_of_succ_def)

schematic_goal graph_minus_impl_aux:
  fixes R :: "('vi\<times>'v) set"
  assumes [autoref_rules]: "(eq,(=))\<in>R\<rightarrow>R\<rightarrow>bool_rel"
  shows "(?c, (-)) \<in> \<langle>R\<rangle>slg_rel \<rightarrow> \<langle>R\<rangle>slg_rel \<rightarrow> \<langle>R\<rangle>slg_rel"
  apply (subst graph_minus_aimpl[abs_def])
  apply (autoref (keep_goal,trace))
  done

lemmas [autoref_rules] = graph_minus_impl_aux[OF GEN_OP_D]

lemma graph_minus_set_aimpl:
  fixes E1 E2 :: "'a rel"
  shows "E1-E2 = E_of_succ (\<lambda>u. {v\<in>E1``{u}. (u,v)\<notin>E2})"
  by (auto simp: E_of_succ_def)

schematic_goal graph_minus_set_impl_aux:
  fixes R :: "('vi\<times>'v) set"
  assumes [autoref_rules]: "(eq,(=))\<in>R\<rightarrow>R\<rightarrow>bool_rel"
  assumes [autoref_rules]: "(mem,(\<in>)) \<in> R \<times>\<^sub>r R \<rightarrow> \<langle>R \<times>\<^sub>r R\<rangle>Rs \<rightarrow> bool_rel"
  shows "(?c, (-)) \<in> \<langle>R\<rangle>slg_rel \<rightarrow> \<langle>R\<times>\<^sub>rR\<rangle>Rs \<rightarrow> \<langle>R\<rangle>slg_rel"
  apply (subst graph_minus_set_aimpl[abs_def])
  apply (autoref (keep_goal,trace))
  done

lemmas [autoref_rules (overloaded)] = graph_minus_set_impl_aux[OF GEN_OP_D GEN_OP_D]

subsection \<open>Rooted Graphs\<close>

subsubsection \<open>Operation Identification Setup\<close>

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

abbreviation "i_frg \<equiv> \<langle>i_unit\<rangle>\<^sub>ii_g_ext"

context begin interpretation autoref_syn .

lemma g_type[autoref_itype]:
  "g_V ::\<^sub>i \<langle>Ie,I\<rangle>\<^sub>ii_g_ext \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set"
  "g_E ::\<^sub>i \<langle>Ie,I\<rangle>\<^sub>ii_g_ext \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_slg"
  "g_V0 ::\<^sub>i \<langle>Ie,I\<rangle>\<^sub>ii_g_ext \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set"
  "graph_rec_ext
    ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_slg \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i iE \<rightarrow>\<^sub>i \<langle>Ie,I\<rangle>\<^sub>ii_g_ext"
  by simp_all

end

subsubsection \<open>Generic Implementation\<close>
record ('vi,'ei,'v0i) gen_g_impl =
  gi_V :: 'vi
  gi_E :: 'ei
  gi_V0 :: 'v0i

definition gen_g_impl_rel_ext_internal_def: "\<And> Rm Rv Re Rv0. gen_g_impl_rel_ext Rm Rv Re Rv0
  \<equiv> { (gen_g_impl_ext Vi Ei V0i mi, graph_rec_ext V E V0 m)
      | Vi Ei V0i mi V E V0 m.
        (Vi,V)\<in>Rv \<and> (Ei,E)\<in>Re \<and> (V0i,V0)\<in>Rv0 \<and> (mi,m)\<in>Rm
    }"

lemma gen_g_impl_rel_ext_def: "\<And>Rm Rv Re Rv0. \<langle>Rm,Rv,Re,Rv0\<rangle>gen_g_impl_rel_ext
  \<equiv> { (gen_g_impl_ext Vi Ei V0i mi, graph_rec_ext V E V0 m)
      | Vi Ei V0i mi V E V0 m.
        (Vi,V)\<in>Rv \<and> (Ei,E)\<in>Re \<and> (V0i,V0)\<in>Rv0 \<and> (mi,m)\<in>Rm
    }"
  unfolding gen_g_impl_rel_ext_internal_def relAPP_def by simp

lemma gen_g_impl_rel_sv[relator_props]:
  "\<And>Rm Rv Re Rv0. \<lbrakk>single_valued Rv; single_valued Re; single_valued Rv0; single_valued Rm \<rbrakk> \<Longrightarrow>
  single_valued (\<langle>Rm,Rv,Re,Rv0\<rangle>gen_g_impl_rel_ext)"
  unfolding gen_g_impl_rel_ext_def
  apply (auto
    intro!: single_valuedI
    dest: single_valuedD slg_rel_sv list_set_rel_sv)
  done

lemma gen_g_refine:
  "\<And>Rm Rv Re Rv0. (gi_V,g_V) \<in> \<langle>Rm,Rv,Re,Rv0\<rangle>gen_g_impl_rel_ext \<rightarrow> Rv"
  "\<And>Rm Rv Re Rv0. (gi_E,g_E) \<in> \<langle>Rm,Rv,Re,Rv0\<rangle>gen_g_impl_rel_ext \<rightarrow> Re"
  "\<And>Rm Rv Re Rv0. (gi_V0,g_V0) \<in> \<langle>Rm,Rv,Re,Rv0\<rangle>gen_g_impl_rel_ext \<rightarrow> Rv0"
  "\<And>Rm Rv Re Rv0. (gen_g_impl_ext, graph_rec_ext)
    \<in> Rv \<rightarrow> Re \<rightarrow> Rv0 \<rightarrow> Rm \<rightarrow> \<langle>Rm,Rv,Re,Rv0\<rangle>gen_g_impl_rel_ext"
  unfolding gen_g_impl_rel_ext_def
  by auto

subsubsection \<open>Implementation with list-set for Nodes\<close>
type_synonym ('v,'m) frgv_impl_scheme =
  "('v list, 'v \<Rightarrow> 'v list, 'v list, 'm) gen_g_impl_scheme"

definition frgv_impl_rel_ext_internal_def:
  "frgv_impl_rel_ext Rm Rv
  \<equiv> \<langle>Rm,\<langle>Rv\<rangle>list_set_rel,\<langle>Rv\<rangle>slg_rel,\<langle>Rv\<rangle>list_set_rel\<rangle>gen_g_impl_rel_ext"

lemma frgv_impl_rel_ext_def: "\<langle>Rm,Rv\<rangle>frgv_impl_rel_ext
  \<equiv> \<langle>Rm,\<langle>Rv\<rangle>list_set_rel,\<langle>Rv\<rangle>slg_rel,\<langle>Rv\<rangle>list_set_rel\<rangle>gen_g_impl_rel_ext"
  unfolding frgv_impl_rel_ext_internal_def relAPP_def by simp

lemma [autoref_rel_intf]: "REL_INTF frgv_impl_rel_ext i_g_ext"
  by (rule REL_INTFI)

lemma [relator_props, simp]:
  "\<lbrakk>single_valued Rv; Range Rv = UNIV; single_valued Rm\<rbrakk>
  \<Longrightarrow> single_valued (\<langle>Rm,Rv\<rangle>frgv_impl_rel_ext)"
  unfolding frgv_impl_rel_ext_def by tagged_solver

lemmas [param, autoref_rules] = gen_g_refine[where
  Rv = "\<langle>Rv\<rangle>list_set_rel" and Re = "\<langle>Rv\<rangle>slg_rel" and ?Rv0.0 = "\<langle>Rv\<rangle>list_set_rel"
  for Rv, folded frgv_impl_rel_ext_def]

subsubsection \<open>Implementation with Cfun for Nodes\<close>
text \<open>This implementation allows for the universal node set.\<close>
type_synonym ('v,'m) g_impl_scheme =
  "('v \<Rightarrow> bool, 'v \<Rightarrow> 'v list, 'v list, 'm) gen_g_impl_scheme"

definition g_impl_rel_ext_internal_def:
  "g_impl_rel_ext Rm Rv
  \<equiv> \<langle>Rm,\<langle>Rv\<rangle>fun_set_rel,\<langle>Rv\<rangle>slg_rel,\<langle>Rv\<rangle>list_set_rel\<rangle>gen_g_impl_rel_ext"

lemma g_impl_rel_ext_def: "\<langle>Rm,Rv\<rangle>g_impl_rel_ext
  \<equiv> \<langle>Rm,\<langle>Rv\<rangle>fun_set_rel,\<langle>Rv\<rangle>slg_rel,\<langle>Rv\<rangle>list_set_rel\<rangle>gen_g_impl_rel_ext"
  unfolding g_impl_rel_ext_internal_def relAPP_def by simp

lemma [autoref_rel_intf]: "REL_INTF g_impl_rel_ext i_g_ext"
  by (rule REL_INTFI)

lemma [relator_props, simp]:
  "\<lbrakk>single_valued Rv; Range Rv = UNIV; single_valued Rm\<rbrakk>
  \<Longrightarrow> single_valued (\<langle>Rm,Rv\<rangle>g_impl_rel_ext)"
  unfolding g_impl_rel_ext_def by tagged_solver

lemmas [param, autoref_rules] = gen_g_refine[where
  Rv = "\<langle>Rv\<rangle>fun_set_rel"
  and Re = "\<langle>Rv\<rangle>slg_rel"
  and ?Rv0.0 = "\<langle>Rv\<rangle>list_set_rel"
  for Rv, folded g_impl_rel_ext_def]

lemma [autoref_rules]: "(gi_V_update, g_V_update) \<in> (\<langle>Rv\<rangle>fun_set_rel \<rightarrow> \<langle>Rv\<rangle>fun_set_rel) \<rightarrow>
  \<langle>Rm, Rv\<rangle>g_impl_rel_ext \<rightarrow> \<langle>Rm, Rv\<rangle>g_impl_rel_ext"
  unfolding g_impl_rel_ext_def gen_g_impl_rel_ext_def
  by (auto, metis (full_types) tagged_fun_relD_both)
lemma [autoref_rules]: "(gi_E_update, g_E_update) \<in> (\<langle>Rv\<rangle>slg_rel \<rightarrow> \<langle>Rv\<rangle>slg_rel) \<rightarrow>
  \<langle>Rm, Rv\<rangle>g_impl_rel_ext \<rightarrow> \<langle>Rm, Rv\<rangle>g_impl_rel_ext"
  unfolding g_impl_rel_ext_def gen_g_impl_rel_ext_def
  by (auto, metis (full_types) tagged_fun_relD_both)
lemma [autoref_rules]: "(gi_V0_update, g_V0_update) \<in> (\<langle>Rv\<rangle>list_set_rel \<rightarrow> \<langle>Rv\<rangle>list_set_rel) \<rightarrow>
  \<langle>Rm, Rv\<rangle>g_impl_rel_ext \<rightarrow> \<langle>Rm, Rv\<rangle>g_impl_rel_ext"
  unfolding g_impl_rel_ext_def gen_g_impl_rel_ext_def
  by (auto, metis (full_types) tagged_fun_relD_both)

(* HACK: The homgeneity rule heuristics erronously creates a homogeneity rule that
    equalizes Rv and Rv0, out of the frv-implementation, which happens to be the
    first. This declaration counters the undesired effects caused by this. *)
lemma [autoref_hom]:
  "CONSTRAINT graph_rec_ext (\<langle>Rv\<rangle>Rvs \<rightarrow> \<langle>Rv\<rangle>Res \<rightarrow> \<langle>Rv\<rangle>Rv0s \<rightarrow> Rm \<rightarrow> \<langle>Rm,Rv\<rangle>Rg)"
  by simp

schematic_goal "(?c::?'c, \<lambda>G x. g_E G `` {x})\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_goal "(?c,\<lambda>V0 E.
   \<lparr> g_V = UNIV, g_E = E, g_V0 = V0 \<rparr>  )
  \<in>\<langle>R\<rangle>list_set_rel \<rightarrow> \<langle>R\<rangle>slg_rel \<rightarrow> \<langle>unit_rel,R\<rangle>g_impl_rel_ext"
  apply (autoref (keep_goal))
  done

schematic_goal "(?c,\<lambda>V V0 E.
   \<lparr> g_V = V, g_E = E, g_V0 = V0 \<rparr>  )
  \<in>\<langle>R\<rangle>list_set_rel \<rightarrow> \<langle>R\<rangle>list_set_rel \<rightarrow> \<langle>R\<rangle>slg_rel \<rightarrow> \<langle>unit_rel,R\<rangle>frgv_impl_rel_ext"
  apply (autoref (keep_goal))
  done

subsubsection \<open>Renaming\<close>

definition "the_inv_into_map V f x
  = (if x \<in> f`V then Some (the_inv_into V f x) else None)"

lemma the_inv_into_map_None[simp]:
  "the_inv_into_map V f x = None \<longleftrightarrow> x \<notin> f`V"
  unfolding the_inv_into_map_def by auto

lemma the_inv_into_map_Some':
  "the_inv_into_map V f x = Some y \<longleftrightarrow> x \<in> f`V \<and> y=the_inv_into V f x"
  unfolding the_inv_into_map_def by auto

lemma the_inv_into_map_Some[simp]:
  "inj_on f V \<Longrightarrow> the_inv_into_map V f x = Some y \<longleftrightarrow> y\<in>V \<and> x=f y"
  by (auto simp: the_inv_into_map_Some' the_inv_into_f_f)

definition "the_inv_into_map_impl V f =
  FOREACH V (\<lambda>x m. RETURN (m(f x \<mapsto> x))) Map.empty"

lemma the_inv_into_map_impl_correct:
  assumes [simp]: "finite V"
  assumes INJ: "inj_on f V"
  shows "the_inv_into_map_impl V f \<le> SPEC (\<lambda>r. r = the_inv_into_map V f)"
  unfolding the_inv_into_map_impl_def
  apply (refine_rcg
    FOREACH_rule[where I="\<lambda>it m. m=the_inv_into_map (V - it) f"]
    refine_vcg
  )

  apply (vc_solve
    simp: the_inv_into_map_def[abs_def] it_step_insert_iff
    intro!: ext)

  apply (intro allI impI conjI)

  apply (subst the_inv_into_f_f[OF subset_inj_on[OF INJ]], auto) []

  apply (subst the_inv_into_f_f[OF subset_inj_on[OF INJ]], auto) []

  apply safe []
  apply (subst the_inv_into_f_f[OF subset_inj_on[OF INJ]], (auto) [2])+
  apply simp
  done

schematic_goal the_inv_into_map_code_aux:
  fixes Rv' :: "('vti \<times> 'vt) set"
  assumes [autoref_ga_rules]: "is_bounded_hashcode Rv' eq bhc"
  assumes [autoref_ga_rules]: "is_valid_def_hm_size TYPE('vti) (def_size)"
  assumes [autoref_rules]: "(Vi,V)\<in>\<langle>Rv\<rangle>list_set_rel"
  assumes [autoref_rules]: "(fi,f)\<in>Rv\<rightarrow>Rv'"
  shows "(RETURN ?c, the_inv_into_map_impl V f) \<in> \<langle>\<langle>Rv',Rv\<rangle>ahm_rel bhc\<rangle>nres_rel"
  unfolding the_inv_into_map_impl_def[abs_def]
  apply (autoref_monadic (plain))
  done

concrete_definition the_inv_into_map_code uses the_inv_into_map_code_aux
export_code the_inv_into_map_code checking SML

thm the_inv_into_map_code.refine

context begin interpretation autoref_syn .
lemma autoref_the_inv_into_map[autoref_rules]:
  fixes Rv' :: "('vti \<times> 'vt) set"
  assumes "SIDE_GEN_ALGO (is_bounded_hashcode Rv' eq bhc)"
  assumes "SIDE_GEN_ALGO (is_valid_def_hm_size TYPE('vti) def_size)"
  assumes INJ: "SIDE_PRECOND (inj_on f V)"
  assumes V: "(Vi,V)\<in>\<langle>Rv\<rangle>list_set_rel"
  assumes F: "(fi,f)\<in>Rv\<rightarrow>Rv'"
  shows "(the_inv_into_map_code eq bhc def_size Vi fi,
    (OP the_inv_into_map
      ::: \<langle>Rv\<rangle>list_set_rel \<rightarrow> (Rv\<rightarrow>Rv') \<rightarrow> \<langle>Rv', Rv\<rangle>Impl_Array_Hash_Map.ahm_rel bhc)
    $V$f) \<in> \<langle>Rv', Rv\<rangle>Impl_Array_Hash_Map.ahm_rel bhc"
proof simp

  from V have FIN: "finite V" using list_set_rel_range by auto

  note the_inv_into_map_code.refine[
    OF assms(1-2,4-5)[unfolded autoref_tag_defs], THEN nres_relD
  ]
  also note the_inv_into_map_impl_correct[OF FIN INJ[unfolded autoref_tag_defs]]
  finally show "(the_inv_into_map_code eq bhc def_size Vi fi, the_inv_into_map V f)
    \<in> \<langle>Rv', Rv\<rangle>Impl_Array_Hash_Map.ahm_rel bhc"
    by (simp add: refine_pw_simps pw_le_iff)
qed

end

schematic_goal "(?c::?'c, do {
  let s = {1,2,3::nat};
  \<^cancel>\<open>ASSERT (inj_on Suc s);\<close>
  RETURN (the_inv_into_map s Suc) }) \<in> ?R"
  apply (autoref (keep_goal))
  done

definition "fr_rename_ext_aimpl ecnv f G \<equiv> do {
    ASSERT (inj_on f (g_V G));
    ASSERT (inj_on f (g_V0 G));
    let fi_map = the_inv_into_map (g_V G) f;
    e \<leftarrow> ecnv fi_map G;
    RETURN \<lparr>
      g_V = f`(g_V G),
      g_E = (E_of_succ (\<lambda>v. case fi_map v of
          Some u \<Rightarrow> f ` (succ_of_E (g_E G) u) | None \<Rightarrow> {})),
      g_V0 = (f`g_V0 G),
      \<dots> = e
    \<rparr>
  }"

context g_rename_precond begin

  definition "fi_map x = (if x \<in> f`V then Some (fi x) else None)"
  lemma fi_map_alt: "fi_map = the_inv_into_map V f"
    apply (rule ext)
    unfolding fi_map_def the_inv_into_map_def fi_def
    by simp

  lemma fi_map_Some: "(fi_map u = Some v) \<longleftrightarrow> u\<in>f`V \<and> fi u = v"
    unfolding fi_map_def by (auto split: if_split_asm)

  lemma fi_map_None: "(fi_map u = None) \<longleftrightarrow> u\<notin>f`V"
    unfolding fi_map_def by (auto split: if_split_asm)

  lemma rename_E_aimpl_alt: "rename_E f E = E_of_succ (\<lambda>v. case fi_map v of
    Some u \<Rightarrow> f ` (succ_of_E E u) | None \<Rightarrow> {})"
    unfolding E_of_succ_def succ_of_E_def
    using E_ss
    by (force
      simp: fi_f f_fi fi_map_Some fi_map_None
      split: if_split_asm option.splits)

  lemma frv_rename_ext_aimpl_alt:
    assumes ECNV: "ecnv' fi_map G \<le> SPEC (\<lambda>r. r = ecnv G)"
    shows "fr_rename_ext_aimpl ecnv' f G
      \<le> SPEC (\<lambda>r. r = fr_rename_ext ecnv f G)"
  proof -
    (*have [simp]: "\<lparr> g_E =
             E_of_succ
              (\<lambda>v. case the_inv_into_map V f v of None \<Rightarrow> {}
                 | Some u \<Rightarrow> f ` succ_of_E (g_E G) u),
            g_V0 = f ` g_V0 G, \<dots> = ecnv Gv\<rparr>
      = frv_G (frv_rename_ext ecnv f Gv)"
      unfolding frv_rename_ext_def
      by (auto simp: rename_E_aimpl_alt fi_map_alt)

    have [simp]: "\<lparr>frv_V = f ` V, frv_G = frv_G Gv'\<rparr> = Gv'"
      unfolding frv_rename_ext_def
      by simp*)

    show ?thesis
      unfolding fr_rename_ext_def fr_rename_ext_aimpl_def
      apply (refine_rcg
        order_trans[OF ECNV[unfolded fi_map_alt]]
        refine_vcg)
      using subset_inj_on[OF _ V0_ss]
      apply (auto intro: INJ simp: rename_E_aimpl_alt fi_map_alt)
      done
  qed
end

term frv_rename_ext_aimpl
schematic_goal fr_rename_ext_impl_aux:
  fixes Re and Rv' :: "('vti \<times> 'vt) set"
  assumes [autoref_rules]: "(eq, (=)) \<in> Rv' \<rightarrow> Rv' \<rightarrow> bool_rel"
  assumes [autoref_ga_rules]: "is_bounded_hashcode Rv' eq bhc"
  assumes [autoref_ga_rules]: "is_valid_def_hm_size TYPE('vti) def_size"
  shows "(?c,fr_rename_ext_aimpl) \<in>
    ((\<langle>Rv',Rv\<rangle>ahm_rel bhc) \<rightarrow> \<langle>Re,Rv\<rangle>frgv_impl_rel_ext \<rightarrow> \<langle>Re'\<rangle>nres_rel) \<rightarrow>
    (Rv\<rightarrow>Rv') \<rightarrow>
    \<langle>Re,Rv\<rangle>frgv_impl_rel_ext \<rightarrow>
    \<langle>\<langle>Re',Rv'\<rangle>frgv_impl_rel_ext\<rangle>nres_rel"
  unfolding fr_rename_ext_aimpl_def[abs_def]
  apply (autoref (keep_goal))
  done

concrete_definition fr_rename_ext_impl uses fr_rename_ext_impl_aux

thm fr_rename_ext_impl.refine[OF GEN_OP_D SIDE_GEN_ALGO_D SIDE_GEN_ALGO_D]

subsection \<open>Graphs from Lists\<close>

definition succ_of_list :: "(nat\<times>nat) list \<Rightarrow> nat \<Rightarrow> nat set"
  where
  "succ_of_list l \<equiv> let
    m = fold (\<lambda>(u,v) g.
          case g u of
            None \<Rightarrow> g(u\<mapsto>{v})
          | Some s \<Rightarrow> g(u\<mapsto>insert v s)
        ) l Map.empty
  in
    (\<lambda>u. case m u of None \<Rightarrow> {} | Some s \<Rightarrow> s)"

lemma succ_of_list_correct_aux:
  "(succ_of_list l, set l) \<in> br (\<lambda>succs. {(u,v). v\<in>succs u}) (\<lambda>_. True)"
proof -

  term the_default

  { fix m
    have "fold (\<lambda>(u,v) g.
            case g u of
              None \<Rightarrow> g(u\<mapsto>{v})
            | Some s \<Rightarrow> g(u\<mapsto>insert v s)
          ) l m
      = (\<lambda>u. let s=set l `` {u} in
          if s={} then m u else Some (the_default {} (m u) \<union> s))"
      apply (induction l arbitrary: m)
      apply (auto
        split: option.split if_split
        simp: Let_def Image_def
        intro!: ext)
      done
  } note aux=this

  show ?thesis
    unfolding succ_of_list_def aux
    by (auto simp: br_def Let_def split: option.splits if_split_asm)
qed

schematic_goal succ_of_list_impl:
  notes [autoref_tyrel] =
    ty_REL[where 'a="nat\<rightharpoonup>nat set" and R="\<langle>nat_rel,R\<rangle>iam_map_rel" for R]
    ty_REL[where 'a="nat set" and R="\<langle>nat_rel\<rangle>list_set_rel"]

  shows "(?f::?'c,succ_of_list) \<in> ?R"
  unfolding succ_of_list_def[abs_def]
  apply (autoref (keep_goal))
  done

concrete_definition succ_of_list_impl uses succ_of_list_impl
export_code succ_of_list_impl in SML

lemma succ_of_list_impl_correct: "(succ_of_list_impl,set) \<in> Id \<rightarrow> \<langle>Id\<rangle>slg_rel"
  apply rule
  unfolding slg_rel_def
  apply rule
  apply (rule succ_of_list_impl.refine[THEN fun_relD])
  apply simp
  apply (rule succ_of_list_correct_aux)
  done

end


\<^marker>\<open>creator Bilel Ghorbel\<close>
chapter \<open>Complexity classes definitions\<close>
paragraph \<open>Summary\<close>
text \<open>

\<bullet> Stating definitions of P AND NP based on the defined abstractions AND bounds.
\<bullet> Sanity checks: Proving that problems having polyreductions to P/NP problems are P/NP
\<bullet> Stating definitions of NP-Hard AND NP-complete using polyreductions
\<close>
theory Complexity_Classes
  imports
    "Poly_Reductions_Lib.Polynomial_Growth_Functions"
    "Poly_Reductions_Lib.SAT_Definition" Bounds Abstractions
        "IMP-_Reductions"

begin
paragraph \<open>Conventions\<close>
text \<open>
We consider natural numbers sets as our languages.
A Complexity class is a set containing languages hence a set containing natural numbers sets.

hence we are only interested with decision problems over natural numbers.
\<close>
subsection \<open>P\<close>
paragraph \<open>Definition\<close>
text \<open>A language is \<in> P iff. it can be decided by a program that is polynomially time bounded.\<close>
definition P :: "lang set" where
  "P \<equiv> {L. \<exists>c. poly_time_bounded c  [''input''] \<and> decides c L}"

subsection \<open>NP\<close>
paragraph \<open>Polyverifiers\<close>
text \<open>A polyverifier c of a language L is a verifier of that language that has following bounds:
\<bullet> polynomial time bound respectively to the input AND certificate size.
\<bullet> polynomial valid-certificate bound
 \<close>
definition is_poly_verif :: "com \<Rightarrow> lang \<Rightarrow> bool" where
  "is_poly_verif c L \<equiv> is_verif c L \<and> poly_time_bounded c [''input'',''certificate'']
                                  \<and> poly_certif_bounded c"

paragraph \<open>NP definition\<close>
text \<open>NP is the set of languages having a polyverifier\<close>
definition NP :: "lang set" where
"NP \<equiv> {L. \<exists>c. is_poly_verif c L}"

subsection \<open>Reduction to a P/NP problem\<close>
lemma p_sanity:
  assumes "D' \<in> P" "poly_reduces D D'"
  shows "D \<in> P"
  using assms apply (auto simp add: P_def poly_reduces_def)
proof
  fix g f
  assume assms: "is_polyreduction f D D'"
    "poly_time_bounded g [''input'']" "decides g D'"
  show "poly_time_bounded (f;;g)[''input''] \<and> decides (f;;g) D "
  proof
    show "poly_time_bounded (f;;g)[''input'']"
      using assms is_polyreduction_def reduction_poly by auto
  next
    show "decides (f;;g) D"
      using assms(1) assms(3) reduction_decision_correct is_polyreduction_def by blast
  qed
qed

lemma np_sanity:
  assumes "poly_reduces D D'" "D' \<in> NP"
  shows "D \<in> NP"
proof -
  from assms(1) obtain f
    where f_def: "is_reduction f D D'" "poly_time_bounded f [''input'']"
                                      "poly_result_bounded f [''input''] [''input'']"
    using is_polyreduction_def poly_reduces_def by auto
  from assms(2) obtain g
    where g_def: "is_verif g D'" "poly_time_bounded g [''input'',''certificate'']"
                                "poly_certif_bounded g"
    using NP_def is_poly_verif_def by blast
  from f_def(1) have cf:"cons_certif f" by (simp add: is_reduction_def)
  moreover from g_def(1) have "\<forall>y z. \<exists>r. verif g y z r " by (simp add: is_verif_def)
  ultimately have "poly_certif_bounded (f;;g)" using f_def(3) g_def(3)
      poly_result_bounded_poly_certif_bounded   by blast
  moreover from f_def(1) g_def(1) have "is_verif (f;;g) D" using reduction_verification_correct by simp
  moreover from f_def(2) have p1: "poly_time_bounded f [''input'',''certificate'']"
    using extend_poly_time_bounded
    by fastforce
  from f_def(3) have p2:
              "poly_result_bounded f [''input'',''certificate''][''input'',''certificate'']"
    using assms(2) cf cons_certif_poly_result_bounded by blast
  from g_def(2)  p1 p2 have p3:"poly_time_bounded (f;;g)[''input'',''certificate'']"
    using reduction_poly by blast
  ultimately show  ?thesis using NP_def is_poly_verif_def  by auto
qed

subsection \<open>NP-Hard AND NP-Complete Definitions\<close>
definition NP_hard :: "lang set" where
"NP_hard \<equiv> {L'. \<forall>L\<in>NP. poly_reduces L L'}"

definition NP_complete :: "lang set" where
"NP_complete \<equiv> NP_hard \<inter> NP"

subsection \<open>Defining NP using P\<close>
paragraph \<open>Idea AND Intuition\<close>
text \<open>
Disclaimer: This is not a proof of P = NP.

Verifiers AND deciders are a lot a like. While within P, it's about the existence of polynomially
bounded decider, within NP it's about polynomially bounded verifiers.
Hence if we encode the input AND certificate in one value. We could do the work of a verifier
using a decider who's able to decode them.
\<close>

paragraph \<open>Assumptions\<close>
text \<open>
For this definition we will need an encoding/entupling AND decoding/detupling programs that convert
couples of natural numbers into one natural number AND vice versa.

Since we don't care what the programs are as long they satisfy some assumptions/properties
we just state them AND assume them IN a local context.

A next step could be proving that the cantor pairing function satifies them.

The assumptions are:
\<bullet> the entupling happens in polynomial time.
\<bullet> the detupling happens in polynomial time AND produces a couple that's polynomially bounded w.r.t
the bitsize of the encoded couple.
\<bullet> The entupling AND detupling are both total and computable. The computation always gives a result
that is depending only the input.
\<bullet> entupling AND detupling are inverse operations.
\<close>
definition rev_verif:: "com \<Rightarrow> val \<Rightarrow> val \<Rightarrow> val \<Rightarrow> bool" where
  "rev_verif c x z r \<equiv> comp c [(''input'',r)] [(''input'',x),(''certificate'',z)]"

locale NP_using_P =
  fixes entuple::com
  fixes detuple::com
  assumes en_bound:"poly_time_bounded entuple [''input'',''certificate'']"
                  "poly_result_bounded entuple [''input'',''certificate''] [''input'']"
   and de_bound:"poly_time_bounded detuple [''input'']"
                            "poly_result_bounded detuple [''input''] [''input'',''certificate'']"
   and total_en:"\<forall>x z. \<exists>r. verif entuple x z r"
   and total_de:"\<forall>r. \<exists>x z. rev_verif detuple x z r"
   and  equiv_en_de:"verif entuple x z r \<longleftrightarrow> rev_verif detuple x z r "
begin

paragraph \<open>Certificate language of a verifier\<close>
text \<open>This is in the heart of the alternative definition.

The certificate language of a verifier v is the set of encoded couples of input AND certificate that
are accepted by v.
\<close>
definition cert_lang_of :: "com \<Rightarrow> lang" where
  "cert_lang_of v \<equiv> {tuple. \<exists>x z. verif entuple x z tuple \<and> verif v x z 0 }"

text \<open>Helping lemma\<close>
lemma verif_entuple_det:
  assumes "verif entuple x z r"
  assumes "verif entuple x' z' r"
  shows "x=x' \<and> z=z'"
  using assms equiv_en_de rev_verif_def comp_comp verif_def
  by (smt comp_det list.inject list.simps(9) prod.sel(1) prod.sel(2))

text \<open>Proving that the certificate language of a polyverifier is decidable in polynomial time,
we would obtain that an alternative definition for NP.\<close>

paragraph \<open>Helping lemmas \<close>

lemma NP_to_P: "is_verif v L \<Longrightarrow> decides (detuple;;v) (cert_lang_of v)"
proof (auto simp add: decides_def)
  fix tu
  assume asm:"is_verif v L"
  then obtain x z where xz_def: "rev_verif detuple x z tu" using total_de by blast
  hence entuple_rel:"verif entuple x z tu" using equiv_en_de by simp
  obtain r where r_def: "verif v x z r" using asm is_verif_def by metis
  have "(tu \<in> cert_lang_of v) = (0 = r)"
  proof
    assume "tu \<in> cert_lang_of v"
    then obtain x' z'  where def':"verif entuple x' z' tu" " verif v x' z' 0"
      using cert_lang_of_def by blast
    then have "x=x'" "z=z'" using entuple_rel verif_entuple_det by auto
    hence "verif v x z 0" using def'(2) by simp
    thus "0=r" using r_def verif_def comp_comp
      by (smt comp_det list.inject list.map(2) prod.sel(1) prod.sel(2))
  next
    assume "0 = r"
    thus " tu \<in> cert_lang_of v" using r_def entuple_rel cert_lang_of_def by blast
  qed
  moreover have "comp' (detuple;; v) tu r" using r_def xz_def
                      verif_def rev_verif_def comp'_def comp_comp by auto
  ultimately show " \<exists>r. comp' (detuple;; v) tu r \<and> (tu \<in> cert_lang_of v) = (r = 0)"
    by blast
qed

lemma P_to_NP:
  assumes "decides c L'"
  assumes "\<forall>x. x\<in>L \<longleftrightarrow> (\<exists>tu z. tu\<in>L' \<and> verif entuple x z tu)"
  shows "is_verif (entuple;;c) L"
proof (auto simp add:is_verif_def)
  fix x z
  obtain tu where "verif entuple x z tu " using total_en by auto
  moreover obtain r where "comp' c tu r" using assms(1) decides_def by blast
  ultimately have "verif (entuple;;c) x z r" using verif_def comp'_def comp_comp by simp
  thus "\<exists>r. verif (entuple;; c) x z r" by auto
next
  fix x
  assume "x\<in>L"
  then obtain tu z where tu_z_def: "tu \<in> L'" "verif entuple x z tu"  using assms(2) by blast
  hence r_def:"comp' c tu 0"  using assms(1) decides_def by blast
  from tu_z_def(2) r_def(1) have "verif (entuple;; c) x z 0"
      using verif_def comp'_def comp_comp by simp
  thus "\<exists>z. verif (entuple;; c) x z 0" using r_def by blast
next
  fix x z r
  assume asm: "verif (entuple;; c) x z 0"
  obtain tu where tu_def: "verif entuple x z tu" using total_en by blast
  moreover obtain r' where r'_def:"comp' c tu r'" "(tu \<in> L') \<longleftrightarrow> (r' = 0)"
    using assms(1) decides_def by blast
  ultimately have "verif (entuple;;c) x z r'" using verif_def comp'_def comp_comp by simp
  hence "r'= 0" using asm verif_def comp_det
    by (smt fstI iszero_primfun_list.simps(1) iszero_primfun_list.simps(2)
                  iszero_primfun_list_iff list.simps(9))
  hence "tu \<in> L'" using r'_def(2) by simp
  thus  "x\<in>L" using tu_def assms(2) by blast
qed
paragraph \<open>NP alternative definition \<close>
text \<open>A language is NP, iff. there EXISTS a  language of  (input,certifiate) tuples IN P, such that
1) every input existing IN the language has at least one corresponding certificate that is
    polynomially bounded
2) the set of inputs is  exactly the NP language.
 \<close>
theorem NP_alter_def:
      "L \<in> NP \<longleftrightarrow> (\<exists>L' p. L' \<in> P \<and> poly p \<and>
                    certif_bounded_to_goal entuple p L' \<and>
                  (\<forall>x. x\<in>L \<longleftrightarrow> (\<exists>tu z. tu\<in>L' \<and> verif entuple x z tu)))"

proof safe
  assume " L \<in> NP"
  then obtain v where v_def: "is_poly_verif v L" using NP_def by blast
  let ?L' = "cert_lang_of v"
  obtain p where p_def: "poly p" "certif_bounded v p"
    using v_def is_poly_verif_def poly_certif_bounded_def by blast
  have "decides (detuple;;v) ?L'" using v_def is_poly_verif_def NP_to_P by blast
  moreover have "poly_time_bounded (detuple;;v) [''input'']"
    using v_def is_poly_verif_def de_bound reduction_poly by blast
  ultimately have "?L' \<in> P" using P_def by blast

  moreover have "\<forall>x.(x \<in> L) = (\<exists>tu z. tu \<in> ?L' \<and> verif entuple x z tu)"
  proof auto
    fix x
    assume "x \<in> L"
    then obtain z where zr_def: "verif v x z 0"
      using v_def is_poly_verif_def is_verif_def by force
    obtain tu where tu_def:"verif entuple x z tu" using total_en by blast
    hence "tu \<in> ?L'" using zr_def cert_lang_of_def by blast
    thus "\<exists>tu. tu \<in> ?L' \<and> (\<exists>z. verif entuple x z tu)" using tu_def  by blast
  next
    fix x tu z
    assume asm: "tu \<in> ?L'" "verif entuple x z tu"
    then obtain x' z' where defs: "verif entuple x' z' tu"  "verif v x' z' 0"
      using cert_lang_of_def by auto
    hence "x=x'" "z=z'" using asm(2) verif_entuple_det by auto
    thus "x \<in> L" using defs(2) v_def is_poly_verif_def is_verif_def by blast
  qed

  moreover have "certif_bounded_to_goal entuple p ?L'"
    unfolding certif_bounded_to_goal_def
  proof safe
    fix tu x z
    assume asm:"tu \<in> cert_lang_of v" " verif entuple x z tu"
    then obtain x' z' where def': "verif entuple x' z' tu" "verif v x' z' 0"
      using cert_lang_of_def by blast
    hence "x' =x " using asm(2)  verif_entuple_det by blast
    hence "verif v x z' 0" using def'(2) by blast
    then obtain z'' where def'':"verif v x z'' 0" "bit_length z'' \<le> p (bit_length x)"
      using p_def certif_bounded_def def'(2) certif_bounded_to_goal_def by auto
    obtain tu'' where tu''_def: "verif entuple x z'' tu''" using total_en by fast
    moreover have "tu'' \<in> cert_lang_of v "
      using def''(1) def''(2) tu''_def cert_lang_of_def by blast
    ultimately  show
      " \<exists>z' tu'. verif entuple x z' tu' \<and> bit_length z' \<le> p (bit_length x) \<and>  tu' \<in> cert_lang_of v"
      using def''(2) def''(2) by blast
  qed
  ultimately show "\<exists>L' p. L' \<in> P \<and> poly p \<and> certif_bounded_to_goal entuple p L'
                       \<and> (\<forall>x. (x \<in> L) = (\<exists>tu z. tu \<in> L' \<and> verif entuple x z tu))"
    using p_def(1) by force
next
  fix L' p
  assume L'_def: "L' \<in> P" "poly p" "certif_bounded_to_goal entuple p L'"
          "\<forall>x. (x \<in> L) = (\<exists>tu z. tu \<in> L' \<and>  verif entuple x z tu)"
  then obtain c where c_def:"decides c L'" "poly_time_bounded c [''input'']" using P_def by blast

  from L'_def(4) c_def(1) P_to_NP have "is_verif (entuple;;c) L" by auto

  moreover have  "poly_time_bounded (entuple;;c)[''input'',''certificate'']"
    using c_def(2) en_bound reduction_poly by simp

  moreover have "poly_certif_bounded (entuple;;c)"
  proof (auto simp add: poly_certif_bounded_def certif_bounded_def)
    have "(\<forall>x. (\<exists>z r. verif (entuple;; c) x z 0) \<longrightarrow>
             (\<exists>z r. verif (entuple;; c) x z 0 \<and> bit_length z \<le> p (bit_length x)))"
    proof auto
      fix x z
      assume asm: "verif (entuple;;c) x z 0"
      obtain tu where tu_def: "verif entuple x z tu" using total_en by blast
      obtain r' where r'_def:"comp' c tu r'" "tu \<in> L' \<longleftrightarrow> r'= 0" using c_def decides_def by blast
      from tu_def r'_def(1) have "verif (entuple;;c) x z r'"
        using comp_comp verif_def comp'_def by simp
      hence "r' = 0" using asm(1) verif_def comp_det
                 by (smt fstI iszero_primfun_list.simps(1) iszero_primfun_list.simps(2)
                  iszero_primfun_list_iff list.simps(9))
      hence "tu \<in> L'" using r'_def(2)  asm by blast
      then obtain tu' z'
        where tuz'_def: "tu' \<in> L'" " verif entuple x z' tu'" "bit_length z' \<le> p (bit_length x)"
        using L'_def(3)[unfolded certif_bounded_to_goal_def] tu_def by blast
      then obtain r''
        where r''_def: "comp' c tu' r''" "tu' \<in> L' \<longleftrightarrow> r''=0" using c_def decides_def by blast
      have "verif (entuple;;c) x z' r''" using r''_def(1) tuz'_def(2) verif_def comp'_def comp_comp
        by blast
      moreover have "r'' = 0" using r''_def(2) tuz'_def(1) by simp
      ultimately show "\<exists>z. verif (entuple;; c) x z 0 \<and> bit_length z \<le> p (bit_length x)"
        using tuz'_def(3) by blast
    qed
    thus "\<exists>p. poly p \<and> certif_bounded_to_goal (entuple;; c) p {0}"
      using L'_def(2) certif_bounded_to_goal_def by auto
  qed
  ultimately show "L \<in> NP" using NP_def is_poly_verif_def by auto
qed

end

end


(* Author: Alexander Maletzky *)

section \<open>Utility Definitions and Lemmas about Degree Bounds for Gr\"obner Bases\<close>

theory Degree_Bound_Utils
  imports Groebner_Bases.Groebner_PM
begin

context pm_powerprod
begin

definition is_GB_cofactor_bound :: "(('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'b::field) set \<Rightarrow> nat \<Rightarrow> bool"
  where "is_GB_cofactor_bound F b \<longleftrightarrow>
    (\<exists>G. punit.is_Groebner_basis G \<and> ideal G = ideal F \<and> (UN g:G. indets g) \<subseteq> (UN f:F. indets f) \<and>
      (\<forall>g\<in>G. \<exists>F' q. finite F' \<and> F' \<subseteq> F \<and> g = (\<Sum>f\<in>F'. q f * f) \<and> (\<forall>f\<in>F'. poly_deg (q f * f) \<le> b)))"

definition is_hom_GB_bound :: "(('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'b::field) set \<Rightarrow> nat \<Rightarrow> bool"
  where "is_hom_GB_bound F b \<longleftrightarrow> ((\<forall>f\<in>F. homogeneous f) \<longrightarrow> (\<forall>g\<in>punit.reduced_GB F. poly_deg g \<le> b))"

lemma is_GB_cofactor_boundI:
  assumes "punit.is_Groebner_basis G" and "ideal G = ideal F" and "\<Union>(indets ` G) \<subseteq> \<Union>(indets ` F)"
    and "\<And>g. g \<in> G \<Longrightarrow> \<exists>F' q. finite F' \<and> F' \<subseteq> F \<and> g = (\<Sum>f\<in>F'. q f * f) \<and> (\<forall>f\<in>F'. poly_deg (q f * f) \<le> b)"
  shows "is_GB_cofactor_bound F b"
  unfolding is_GB_cofactor_bound_def using assms by blast

lemma is_GB_cofactor_boundE:
  fixes F :: "(('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'b::field) set"
  assumes "is_GB_cofactor_bound F b"
  obtains G where "punit.is_Groebner_basis G" and "ideal G = ideal F" and "\<Union>(indets ` G) \<subseteq> \<Union>(indets ` F)"
    and "\<And>g. g \<in> G \<Longrightarrow> \<exists>F' q. finite F' \<and> F' \<subseteq> F \<and> g = (\<Sum>f\<in>F'. q f * f) \<and>
                          (\<forall>f. indets (q f) \<subseteq> \<Union>(indets ` F) \<and> poly_deg (q f * f) \<le> b \<and> (f \<notin> F' \<longrightarrow> q f = 0))"
proof -
  let ?X = "\<Union>(indets ` F)"
  from assms obtain G where "punit.is_Groebner_basis G" and "ideal G = ideal F" and "\<Union>(indets ` G) \<subseteq> ?X"
    and 1: "\<And>g. g \<in> G \<Longrightarrow> \<exists>F' q. finite F' \<and> F' \<subseteq> F \<and> g = (\<Sum>f\<in>F'. q f * f) \<and> (\<forall>f\<in>F'. poly_deg (q f * f) \<le> b)"
    by (auto simp: is_GB_cofactor_bound_def)
  from this(1, 2, 3) show ?thesis
  proof
    fix g
    assume "g \<in> G"
    show "\<exists>F' q. finite F' \<and> F' \<subseteq> F \<and> g = (\<Sum>f\<in>F'. q f * f) \<and>
                (\<forall>f. indets (q f) \<subseteq> ?X \<and> poly_deg (q f * f) \<le> b \<and> (f \<notin> F' \<longrightarrow> q f = 0))"
    proof (cases "g = 0")
      case True
      define q where "q = (\<lambda>f::('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'b. 0::('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'b)"
      show ?thesis
      proof (intro exI conjI allI)
        show "g = (\<Sum>f\<in>{}. q f * f)" by (simp add: True q_def)
      qed (simp_all add: q_def)
    next
      case False
      let ?X = "\<Union>(indets ` F)"
      from \<open>g \<in> G\<close> have "\<exists>F' q. finite F' \<and> F' \<subseteq> F \<and> g = (\<Sum>f\<in>F'. q f * f) \<and> (\<forall>f\<in>F'. poly_deg (q f * f) \<le> b)"
        by (rule 1)
      then obtain F' q0 where "finite F'" and "F' \<subseteq> F" and g: "g = (\<Sum>f\<in>F'. q0 f * f)"
        and q0: "\<And>f. f \<in> F' \<Longrightarrow> poly_deg (q0 f * f) \<le> b" by blast
      define sub where "sub = (\<lambda>x::'x. if x \<in> ?X then
                                         monomial (1::'b) (Poly_Mapping.single x (1::nat))
                                       else 1)"
      have 1: "sub x = monomial 1 (monomial 1 x)" if "x \<in> indets g" for x
      proof (simp add: sub_def, rule)
        from that \<open>g \<in> G\<close> have "x \<in> \<Union>(indets ` G)" by blast
        also have "\<dots> \<subseteq> ?X" by fact
        finally obtain f where "f \<in> F" and "x \<in> indets f" ..
        assume "\<forall>f\<in>F. x \<notin> indets f"
        hence "x \<notin> indets f" using \<open>f \<in> F\<close> ..
        thus "monomial 1 (monomial (Suc 0) x) = 1" using \<open>x \<in> indets f\<close> ..
      qed
      have 2: "sub x = monomial 1 (monomial 1 x)" if "f \<in> F'" and "x \<in> indets f" for f x
      proof (simp add: sub_def, rule)
        assume "\<forall>f\<in>F. x \<notin> indets f"
        moreover from that(1) \<open>F' \<subseteq> F\<close> have "f \<in> F" ..
        ultimately have "x \<notin> indets f" ..
        thus "monomial 1 (monomial (Suc 0) x) = 1" using that(2) ..
      qed
      have 3: "poly_subst sub f = f" if "f \<in> F'" for f by (rule poly_subst_id, rule 2, rule that)
      define q where "q = (\<lambda>f. if f \<in> F' then poly_subst sub (q0 f) else 0)"
      show ?thesis
      proof (intro exI allI conjI impI)
        from 1 have "g = poly_subst sub g" by (rule poly_subst_id[symmetric])
        also have "\<dots> = (\<Sum>f\<in>F'. q f * (poly_subst sub f))"
          by (simp add: g poly_subst_sum poly_subst_times q_def cong: sum.cong)
        also from refl have "\<dots> = (\<Sum>f\<in>F'. q f * f)"
        proof (rule sum.cong)
          fix f
          assume "f \<in> F'"
          hence "poly_subst sub f = f" by (rule 3)
          thus "q f * poly_subst sub f = q f * f" by simp
        qed
        finally show "g = (\<Sum>f\<in>F'. q f * f)" .
      next
        fix f
        have "indets (q f) \<subseteq> ?X \<and> poly_deg (q f * f) \<le> b"
        proof (cases "f \<in> F'")
          case True
          hence qf: "q f = poly_subst sub (q0 f)" by (simp add: q_def)
          show ?thesis
          proof
            show "indets (q f) \<subseteq> ?X"
            proof
              fix x
              assume "x \<in> indets (q f)"
              then obtain y where "x \<in> indets (sub y)" unfolding qf by (rule in_indets_poly_substE)
              hence y: "y \<in> ?X" and "x \<in> indets (monomial (1::'b) (monomial (1::nat) y))"
                by (simp_all add: sub_def split: if_splits)
              from this(2) have "x = y" by (simp add: indets_monomial)
              with y show "x \<in> ?X" by (simp only:)
            qed
          next
            from \<open>f \<in> F'\<close> have "poly_subst sub f = f" by (rule 3)
            hence "poly_deg (q f * f) = poly_deg (q f * poly_subst sub f)" by (simp only:)
            also have "\<dots> = poly_deg (poly_subst sub (q0 f * f))" by (simp only: qf poly_subst_times)
            also have "\<dots> \<le> poly_deg (q0 f * f)"
            proof (rule poly_deg_poly_subst_le)
              fix x
              show "poly_deg (sub x) \<le> 1" by (simp add: sub_def poly_deg_monomial deg_pm_single)
            qed
            also from \<open>f \<in> F'\<close> have "\<dots> \<le> b" by (rule q0)
            finally show "poly_deg (q f * f) \<le> b" .
          qed
        next
          case False
          thus ?thesis by (simp add: q_def)
        qed
        thus "indets (q f) \<subseteq> ?X" and "poly_deg (q f * f) \<le> b" by simp_all

        assume "f \<notin> F'"
        thus "q f = 0" by (simp add: q_def)
      qed fact+
    qed
  qed
qed

lemma is_GB_cofactor_boundE_Polys:
  fixes F :: "(('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'b::field) set"
  assumes "is_GB_cofactor_bound F b" and "F \<subseteq> P[X]"
  obtains G where "punit.is_Groebner_basis G" and "ideal G = ideal F" and "G \<subseteq> P[X]"
    and "\<And>g. g \<in> G \<Longrightarrow> \<exists>F' q. finite F' \<and> F' \<subseteq> F \<and> g = (\<Sum>f\<in>F'. q f * f) \<and>
                            (\<forall>f. q f \<in> P[X] \<and> poly_deg (q f * f) \<le> b \<and> (f \<notin> F' \<longrightarrow> q f = 0))"
proof -
  let ?X = "\<Union>(indets ` F)"
  have "?X \<subseteq> X"
  proof
    fix x
    assume "x \<in> ?X"
    then obtain f where "f \<in> F" and "x \<in> indets f" ..
    from this(1) assms(2) have "f \<in> P[X]" ..
    hence "indets f \<subseteq> X" by (rule PolysD)
    with \<open>x \<in> indets f\<close> show "x \<in> X" ..
  qed
  from assms(1) obtain G where "punit.is_Groebner_basis G" and "ideal G = ideal F"
    and 1: "\<Union>(indets ` G) \<subseteq> ?X"
    and 2: "\<And>g. g \<in> G \<Longrightarrow> \<exists>F' q. finite F' \<and> F' \<subseteq> F \<and> g = (\<Sum>f\<in>F'. q f * f) \<and>
                            (\<forall>f. indets (q f) \<subseteq> ?X \<and> poly_deg (q f * f) \<le> b \<and> (f \<notin> F' \<longrightarrow> q f = 0))"
    by (rule is_GB_cofactor_boundE) blast
  from this(1, 2) show ?thesis
  proof
    show "G \<subseteq> P[X]"
    proof
      fix g
      assume "g \<in> G"
      hence "indets g \<subseteq> \<Union>(indets ` G)" by blast
      also have "\<dots> \<subseteq> ?X" by fact
      also have "\<dots> \<subseteq> X" by fact
      finally show "g \<in> P[X]" by (rule PolysI_alt)
    qed
  next
    fix g
    assume "g \<in> G"
    hence "\<exists>F' q. finite F' \<and> F' \<subseteq> F \<and> g = (\<Sum>f\<in>F'. q f * f) \<and>
                  (\<forall>f. indets (q f) \<subseteq> ?X \<and> poly_deg (q f * f) \<le> b \<and> (f \<notin> F' \<longrightarrow> q f = 0))"
      by (rule 2)
    then obtain F' q where "finite F'" and "F' \<subseteq> F" and "g = (\<Sum>f\<in>F'. q f * f)"
      and "\<And>f. indets (q f) \<subseteq> ?X" and "\<And>f. poly_deg (q f * f) \<le> b" and "\<And>f. f \<notin> F' \<Longrightarrow> q f = 0"
      by blast
    show "\<exists>F' q. finite F' \<and> F' \<subseteq> F \<and> g = (\<Sum>f\<in>F'. q f * f) \<and>
                  (\<forall>f. q f \<in> P[X] \<and> poly_deg (q f * f) \<le> b \<and> (f \<notin> F' \<longrightarrow> q f = 0))"
    proof (intro exI allI conjI impI)
      fix f
      from \<open>indets (q f) \<subseteq> ?X\<close> \<open>?X \<subseteq> X\<close> have "indets (q f) \<subseteq> X" by (rule subset_trans)
      thus "q f \<in> P[X]" by (rule PolysI_alt)
    qed fact+
  qed
qed

lemma is_GB_cofactor_boundE_finite_Polys:
  fixes F :: "(('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'b::field) set"
  assumes "is_GB_cofactor_bound F b" and "finite F" and "F \<subseteq> P[X]"
  obtains G where "punit.is_Groebner_basis G" and "ideal G = ideal F" and "G \<subseteq> P[X]"
    and "\<And>g. g \<in> G \<Longrightarrow> \<exists>q. g = (\<Sum>f\<in>F. q f * f) \<and> (\<forall>f. q f \<in> P[X] \<and> poly_deg (q f * f) \<le> b)"
proof -
  from assms(1, 3) obtain G where "punit.is_Groebner_basis G" and "ideal G = ideal F" and "G \<subseteq> P[X]"
    and 1: "\<And>g. g \<in> G \<Longrightarrow> \<exists>F' q. finite F' \<and> F' \<subseteq> F \<and> g = (\<Sum>f\<in>F'. q f * f) \<and>
                            (\<forall>f. q f \<in> P[X] \<and> poly_deg (q f * f) \<le> b \<and> (f \<notin> F' \<longrightarrow> q f = 0))"
    by (rule is_GB_cofactor_boundE_Polys) blast
  from this(1, 2, 3) show ?thesis
  proof
    fix g
    assume "g \<in> G"
    hence "\<exists>F' q. finite F' \<and> F' \<subseteq> F \<and> g = (\<Sum>f\<in>F'. q f * f) \<and>
                            (\<forall>f. q f \<in> P[X] \<and> poly_deg (q f * f) \<le> b \<and> (f \<notin> F' \<longrightarrow> q f = 0))"
      by (rule 1)
    then obtain F' q where "F' \<subseteq> F" and g: "g = (\<Sum>f\<in>F'. q f * f)"
      and "\<And>f. q f \<in> P[X]" and "\<And>f. poly_deg (q f * f) \<le> b" and 2: "\<And>f. f \<notin> F' \<Longrightarrow> q f = 0" by blast
    show "\<exists>q. g = (\<Sum>f\<in>F. q f * f) \<and> (\<forall>f. q f \<in> P[X] \<and> poly_deg (q f * f) \<le> b)"
    proof (intro exI conjI impI allI)
      from assms(2) \<open>F' \<subseteq> F\<close> have "(\<Sum>f\<in>F'. q f * f) = (\<Sum>f\<in>F. q f * f)"
      proof (intro sum.mono_neutral_left ballI)
        fix f
        assume "f \<in> F - F'"
        hence "f \<notin> F'" by simp
        hence "q f = 0" by (rule 2)
        thus "q f * f = 0" by simp
      qed
      thus "g = (\<Sum>f\<in>F. q f * f)" by (simp only: g)
    qed fact+
  qed
qed

lemma is_GB_cofactor_boundI_subset_zero:
  assumes "F \<subseteq> {0}"
  shows "is_GB_cofactor_bound F b"
  using punit.is_Groebner_basis_empty
proof (rule is_GB_cofactor_boundI)
  from assms show "ideal {} = ideal F" by (metis ideal.span_empty ideal_eq_zero_iff)
qed simp_all

lemma is_hom_GB_boundI:
  "(\<And>g. (\<And>f. f \<in> F \<Longrightarrow> homogeneous f) \<Longrightarrow> g \<in> punit.reduced_GB F \<Longrightarrow> poly_deg g \<le> b) \<Longrightarrow> is_hom_GB_bound F b"
  unfolding is_hom_GB_bound_def by blast

lemma is_hom_GB_boundD:
  "is_hom_GB_bound F b \<Longrightarrow> (\<And>f. f \<in> F \<Longrightarrow> homogeneous f) \<Longrightarrow> g \<in> punit.reduced_GB F \<Longrightarrow> poly_deg g \<le> b"
  unfolding is_hom_GB_bound_def by blast

text \<open>The following is the main theorem in this theory. It shows that a bound for Gr\"obner bases of
  homogenized input sets is always also a cofactor bound for the original input sets.\<close>

lemma (in extended_ord_pm_powerprod) hom_GB_bound_is_GB_cofactor_bound:
  assumes "finite X" and "F \<subseteq> P[X]" and "extended_ord.is_hom_GB_bound (homogenize None ` extend_indets ` F) b"
  shows "is_GB_cofactor_bound F b"
proof -
  let ?F = "homogenize None ` extend_indets ` F"
  define Y where "Y = \<Union> (indets ` F)"
  define G where "G = restrict_indets ` (extended_ord.punit.reduced_GB ?F)"
  have "Y \<subseteq> X"
  proof
    fix x
    assume "x \<in> Y"
    then obtain f where "f \<in> F" and "x \<in> indets f" unfolding Y_def ..
    from this(1) assms(2) have "f \<in> P[X]" ..
    hence "indets f \<subseteq> X" by (rule PolysD)
    with \<open>x \<in> indets f\<close> show "x \<in> X" ..
  qed
  hence "finite Y" using assms(1) by (rule finite_subset)
  moreover have "F \<subseteq> P[Y]" by (auto simp: Y_def Polys_alt)
  ultimately have "punit.is_Groebner_basis G" and "ideal G = ideal F" and "G \<subseteq> P[Y]"
    unfolding G_def by (rule restrict_indets_reduced_GB)+
  from this(1, 2) show ?thesis
  proof (rule is_GB_cofactor_boundI)
    from \<open>G \<subseteq> P[Y]\<close> show "\<Union> (indets ` G) \<subseteq> \<Union> (indets ` F)" by (auto simp: Y_def Polys_alt)
  next
    fix g
    assume "g \<in> G"
    then obtain g' where g': "g' \<in> extended_ord.punit.reduced_GB ?F"
      and g: "g = restrict_indets g'" unfolding G_def ..
    have "f \<in> ?F \<Longrightarrow> homogeneous f" for f by (auto simp: homogeneous_homogenize)
    with assms(3) have "poly_deg g' \<le> b" using g' by (rule extended_ord.is_hom_GB_boundD)
    from g' have "g' \<in> ideal (extended_ord.punit.reduced_GB ?F)" by (rule ideal.span_base)
    also have "\<dots> = ideal ?F"
    proof (rule extended_ord.reduced_GB_ideal_Polys)
      from \<open>finite Y\<close> show "finite (insert None (Some ` Y))" by simp
    next
      show "?F \<subseteq> P[insert None (Some ` Y)]"
      proof
        fix f0
        assume "f0 \<in> ?F"
        then obtain f where "f \<in> F" and f0: "f0 = homogenize None (extend_indets f)" by blast
        from this(1) \<open>F \<subseteq> P[Y]\<close> have "f \<in> P[Y]" ..
        hence "extend_indets f \<in> P[Some ` Y]" by (auto simp: indets_extend_indets Polys_alt)
        thus "f0 \<in> P[insert None (Some ` Y)]" unfolding f0 by (rule homogenize_in_Polys)
      qed
    qed
    finally have "g' \<in> ideal ?F" .
    with \<open>\<And>f. f \<in> ?F \<Longrightarrow> homogeneous f\<close> obtain F0 q where "finite F0" and "F0 \<subseteq> ?F"
      and g': "g' = (\<Sum>f\<in>F0. q f * f)" and deg_le: "\<And>f. poly_deg (q f * f) \<le> poly_deg g'"
      by (rule homogeneous_idealE) blast+
    from this(2) obtain F' where "F' \<subseteq> F" and F0: "F0 = homogenize None ` extend_indets ` F'"
      and inj_on: "inj_on (homogenize None \<circ> extend_indets) F'"
      unfolding image_comp by (rule subset_imageE_inj)
    show "\<exists>F' q. finite F' \<and> F' \<subseteq> F \<and> g = (\<Sum>f\<in>F'. q f * f) \<and> (\<forall>f\<in>F'. poly_deg (q f * f) \<le> b)"
    proof (intro exI conjI ballI)
      from inj_on \<open>finite F0\<close> show "finite F'" by (simp only: finite_image_iff F0 image_comp)
    next
      from inj_on show "g = (\<Sum>f\<in>F'. (restrict_indets \<circ> q \<circ> homogenize None \<circ> extend_indets) f * f)"
        by (simp add: g g' F0 restrict_indets_sum restrict_indets_times sum.reindex image_comp o_def)
    next
      fix f
      assume "f \<in> F'"
      have "poly_deg ((restrict_indets \<circ> q \<circ> homogenize None \<circ> extend_indets) f * f) =
              poly_deg (restrict_indets (q (homogenize None (extend_indets f)) * homogenize None (extend_indets f)))"
        by (simp add: restrict_indets_times)
      also have "\<dots> \<le> poly_deg (q (homogenize None (extend_indets f)) * homogenize None (extend_indets f))"
        by (rule poly_deg_restrict_indets_le)
      also have "\<dots> \<le> poly_deg g'" by (rule deg_le)
      also have "\<dots> \<le> b" by fact
      finally show "poly_deg ((restrict_indets \<circ> q \<circ> homogenize None \<circ> extend_indets) f * f) \<le> b" .
    qed fact
  qed
qed

end (* pm_powerprod *)

end (* theory *)


theory Prompt_Test imports
  Main
  "HOL-Algebra.Algebra"
  "HOL-Analysis.Analysis"
begin

(*
Natural language version: "Let $P$ be a $p$-subgroup of $G$. Then $P$ is contained in a Sylow $p$-subgroup of $G$." Translate the natural language version to a Lean mathlib version:
theorem exists_le_sylow {p : \<nat>} {G : Type*} [group G] {P : subgroup G}
  (hP : is_p_group p P) :
  \<exists> (Q : sylow p G), P \<le> Q :=
*)
theorem exists_le_sylow:
  fixes p a m::nat and G::"('a, 'b) monoid_scheme"
  assumes "normalization_semidom_class.prime p" "group G" "order G = (p^a) * m" "finite (carrier G)"
  shows "\<exists>H. subgroup H G \<and> card H = p^a"
  oops

(*
Natural language version: "Let $E$ and $F$ be complex normed spaces and let $f:E\to F$. If $f$ is differentiable and bounded, then $f$ is constant." Translate the natural language version to a Lean mathlib version:
theorem exists_eq_const_of_bounded {E : Type u} [normed_group E]
  [normed_space \<complex> E] {F : Type v} [normed_group F] [normed_space \<complex> F]
  {f : E \<rightarrow> F} (hf : differentiable \<complex> f) (hb : metric.bounded (set.range f)) :
  \<exists> (c : F), f = function.const E c :=
*)
theorem exists_eq_const_of_bounded:
  fixes  f::"complex \<Rightarrow> 'a::real_normed_vector"
  assumes "\<forall>x. f differentiable (at x)" "bounded (range f)"
  shows "f constant_on (UNIV::complex set)"
  oops

(*
Natural language version: "Let $X$ be a topological space; let $A$ be a subset of $X$. Suppose that for each $x\in A$ there is an open set $U$ containing $x$ such that $U\subset A$. Then $A$ is open in $X$." Translate the natural language version to a Lean mathlib version:
theorem subset_of_open_subset_is_open (X : Type* ) [topological_space X]
  (A : set X) (hA : \<forall> x \<in> A, \<exists> U : set X, is_open U \<and> x \<in> U \<and> U \<subseteq> A):
  is_open A :=
*)
theorem subset_of_open_subset_is_open:
  fixes T::"'a topology" and A::"'a set"
  assumes "A \<subseteq> topspace T" "\<forall>x\<in>A. \<exists> U \<subseteq> topspace T. openin T U \<and> x\<in>U \<and> U \<subseteq> A"
  shows "openin T A"
  oops

(*
Natural language version: "Two multiplicative functions $f, g:\mathbb{N}\to R$ are equal if and only if $f(p^i)=f(g^i)$ for all primes $p$." Translate the natural language version to a Lean mathlib version:
theorem is_multiplicative.eq_iff_eq_on_prime_powers {R : Type*}
  [comm_monoid_with_zero R] (f : nat.arithmetic_function R)
  (hf : f.is_multiplicative) (g : nat.arithmetic_function R)
  (hg : g.is_multiplicative) :
  f = g \<leftrightarrow> \<forall> (p i : \<nat>), nat.prime p \<rightarrow> f (p ^ i) = g (p ^ i) :=
*)
(*
I don't think we have a definition of multiplicative function yet.
*)

(*
Natural language version: "If $z_1, \\dots, z_n$ are complex, then $|z_1 + z_2 + \\dots + z_n|\\leq |z_1| + |z_2| + \\dots + |z_n|$." Translate the natural language version to a Lean mathlib version:
theorem abs_sum_leq_sum_abs (n : \<nat>) (f : \<nat> \<rightarrow> \<complex>) :
  abs (\<Sum> i in finset.range n, f i) \<le> \<Sum> i in finset.range n, abs (f i) :=
*)
theorem abs_sum_leq_sum_abs:
  fixes n::nat and f::"nat \<Rightarrow> complex"
  shows "abs (\<Sum>i<n. f i) \<le> (\<Sum>i<n. abs (f i))"
  oops

(*
Natural language version: "If x and y are in $\\mathbb{R}^n$, then $|x+y|^2 + |x-y|^2 = 2|x|^2 + 2|y|^2$." Translate the natural language version to a Lean mathlib version:
theorem sum_add_square_sub_square_eq_sum_square (n : \<nat>) (x y : euclidean_space \<real> (fin n)) :
  \<parallel>x + y\<parallel>^2 + \<parallel>x - y\<parallel>^2 = 2*\<parallel>x\<parallel>^2 + 2*\<parallel>y\<parallel>^2 :=
*)
theorem sum_add_square_sub_square_eq_sum_square:
  fixes x y::"'a::euclidean_space"
  shows "norm (x+y)^2 + norm (x - y) ^ 2 = 2 * (norm x)^2 + 2* (norm y)^2"
  oops

(*
Natural language version: "If $x$ is an element of infinite order in $G$, prove that the elements $x^n$, $n\\in\\mathbb{Z}$ are all distinct." Translate the natural language version to a Lean mathlib version:
theorem distinct_powers_of_infinite_order_element (G : Type* ) [group G] (x : G)
  (hx_inf : \<forall> n : \<nat>, x ^ n \<noteq> 1) :
  \<forall> m n : \<int>, m \<noteq> n \<rightarrow> x ^ m \<noteq> x ^ n :=
*)
theorem distinct_powers_of_infinite_order_element:
  fixes G::"('a, 'b) monoid_scheme" (structure)
  assumes "group G" "\<forall>n ::nat. x [^] n \<noteq> \<one>"
  shows "\<forall> m n :: int. m \<noteq> n \<longrightarrow> x [^] m \<noteq> x [^] n"
  oops

(*
Natural language version "A set of vectors $\{v_i\}_{i\in I}$ orthogonal with respect
to some bilinear form $B: V\times V\to K$ is linearly independent if for
all $i \in I, B(v_i, v_i)\neq 0$." Translate the natural language version to a Lean mathlib version:
theorem linear_independent_of_is_Ortho {V K : Type*} [field K]
  [add_comm_group V] [module K V] {n : Type*} {B : bilin_form K V}
  {v : n \<rightarrow> V} (hv₁ : B.is_Ortho v)
  (hv₂ : \<forall> (i : n), \<not>B.is_ortho (v i) (v i)) :
  linear_independent K v :=
*)
theorem linear_independent_of_is_Ortho:
  fixes B::"'a::real_vector \<Rightarrow> 'a \<Rightarrow> 'b::real_vector"
  assumes "bilinear B" "pairwise (\<lambda>x y. B x y=0) v" "\<forall>x\<in>v. B x x\<noteq>0"
  shows "independent v"
  oops

(*
Natural language version: "Suppose that $V$ is an $n$-dimensional vector space.
Then for some set of vectors $\{v_i\}_{i=1}^k$, if $k>n$ then there exist scalars $f_1,
\dots, f_k$ such that $\sum_{i=1}^k f_kv_k = 0$." Translate the natural
language version to a Lean mathlib version:
theorem exists_nontrivial_relation_sum_zero_of_dim_succ_lt_card {K V : Type*}
  [division_ring K] [add_comm_group V] [module K V] [finite_dimensional K V]
  {t : finset V} (h : finite_dimensional.finrank K V + 1 < t.card) :
  \<exists> (f : V \<rightarrow> K), t.sum (\<lambda> (e : V), f e • e) = 0 \<and> t.sum (\<lambda> (e : V), f e) = 0
  \<and> \<exists> (x : V) (H : x \<in> t), f x \<noteq> 0 :=
*)
theorem exists_nontrivial_relation_sum_zero_of_dim_succ_lt_card:
  fixes v::"'a::euclidean_space set"
  assumes "card v > DIM('a)"
  shows "\<exists>f. (\<Sum>x\<in>v. f x *\<^sub>R x) = 0 \<and> (\<exists>x\<in>v. f x\<noteq>0)"
  oops

(*
Natural language version: "A group is commutative if the quotient by the center is cyclic." Translate the natural language version to a Lean mathlib version:
theorem comm_group_of_cycle_center_quotient {G H : Type*} [group G] [group H]
  [is_cyclic H] (f : G \<rightarrow>* H) (hf : f.ker \<le> center G) :
  comm_group G :=
*)
(*
we have 'cyclic_group' and 'comm_group' but I am not sure how to translate 'the quotient by the center'
*)

(*
Natural language version: "If $H$ is a $p$-subgroup of $G$, then the index of $H$ inside its normalizer is congruent modulo $p$ to the index of $H$." Translate the natural language version to a Lean mathlib version:
theorem card_quotient_normalizer_modeq_card_quotient {G : Type*} [group G]
  [fintype G] {p n : \<nat>} [hp : fact (nat.prime p)] {H : subgroup G}
  (hH : card H = p ^ n) :
  card (H.normalizer / subgroup.comap H.normalizer.subtype H) \<equiv>  card (G / H) [MOD p] :=
*)
(*
Not sure how to translate this to HOL-Algebra
*)

(*Natural language version: "Suppose $X, Y, Z$ are metric spaces, and $Y$ is compact.
 Let $f$ map $X$ into $Y$, let $g$ be a continuous one-to-one mapping of $Y$ into $Z$,
and put $h(x)=g(f(x))$ for $x \in X$. Prove that $f$ is uniformly
continuous if $h$ is uniformly continuous."
Translate the natural language version to a Lean mathlib version:
theorem uniform_continuous_of_continuous_injective_uniform_continuous_comp
  {X Y Z : Type*} [metric_space X] [metric_space Y] [metric_space Z]
  (hY : compact_space Y) (f : X \<rightarrow> Y) (g : Y \<rightarrow> Z) (hgc : continuous g)
  (hgi : function.injective g)
  (h : uniform_continuous (g \<circ> f)) : uniform_continuous f :=*)
theorem uniform_continuous_of_continuous_injective_uniform_continuous_comp:
  fixes f::"'a::metric_space \<Rightarrow> 'b::metric_space" and g::"'b::metric_space \<Rightarrow> 'c::metric_space"
  assumes "compact (UNIV::'b set)" "continuous_on UNIV g" "inj g" "uniformly_continuous_on UNIV (g \<circ> f)"
  shows "uniformly_continuous_on UNIV f"
  oops

theorem xxx: undefined

end


theory Check
  imports Submission
begin

theorem SQUARE_correct: "\<turnstile> {\<lambda>s. s ''n'' \<ge> 0 \<and> s=s\<^sub>0} SQUARE {\<lambda>s. s ''a'' = s\<^sub>0 ''n'' * s\<^sub>0 ''n''}"
  by (rule Submission.SQUARE_correct)

end


(*  Title:       The Partial Cost Model of the List Update Problem
    Author:      Max Haslbeck
*)

section "Partial cost model"

theory Partial_Cost_Model
imports Move_to_Front
begin

definition t\<^sub>p :: "'a state \<Rightarrow> 'a \<Rightarrow> answer \<Rightarrow> nat" where
"t\<^sub>p s q a = (let (mf,sws) = a in index (swaps sws s) q + size sws)"

notation (latex) t\<^sub>p ("\<^latex>\<open>$t^{*}$\<close>")

lemma t\<^sub>pt: "t\<^sub>p s q a + 1 = t s q a" unfolding t\<^sub>p_def t_def by(simp add: split_def)

interpretation On_Off step t\<^sub>p static .

abbreviation "T\<^sub>p == T"
abbreviation "T\<^sub>p_opt == T_opt"
abbreviation "T\<^sub>p_on == T_on"
abbreviation "T\<^sub>p_on_rand' == T_on_rand'"
abbreviation "T\<^sub>p_on_n == T_on_n"
abbreviation "T\<^sub>p_on_rand == T_on_rand"
abbreviation "T\<^sub>p_on_rand_n == T_on_rand_n"
abbreviation "config\<^sub>p == config "
abbreviation "compet\<^sub>p == compet"

end


(*  Title:      HOL/UNITY/Extend.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1998  University of Cambridge

Extending of state setsExtending of state sets
  function f (forget)    maps the extended state to the original state
  function g (forgotten) maps the extended state to the "extending part"
*)

section\<open>Extending State Sets\<close>

theory Extend imports Guar begin

definition
  (*MOVE to Relation.thy?*)
  Restrict :: "[ 'a set, ('a*'b) set] => ('a*'b) set"
  where "Restrict A r = r \<inter> (A \<times> UNIV)"

definition
  good_map :: "['a*'b => 'c] => bool"
  where "good_map h \<longleftrightarrow> surj h & (\<forall>x y. fst (inv h (h (x,y))) = x)"
     (*Using the locale constant "f", this is  f (h (x,y))) = x*)

definition
  extend_set :: "['a*'b => 'c, 'a set] => 'c set"
  where "extend_set h A = h ` (A \<times> UNIV)"

definition
  project_set :: "['a*'b => 'c, 'c set] => 'a set"
  where "project_set h C = {x. \<exists>y. h(x,y) \<in> C}"

definition
  extend_act :: "['a*'b => 'c, ('a*'a) set] => ('c*'c) set"
  where "extend_act h = (%act. \<Union>(s,s') \<in> act. \<Union>y. {(h(s,y), h(s',y))})"

definition
  project_act :: "['a*'b => 'c, ('c*'c) set] => ('a*'a) set"
  where "project_act h act = {(x,x'). \<exists>y y'. (h(x,y), h(x',y')) \<in> act}"

definition
  extend :: "['a*'b => 'c, 'a program] => 'c program"
  where "extend h F = mk_program (extend_set h (Init F),
                               extend_act h ` Acts F,
                               project_act h -` AllowedActs F)"

definition
  (*Argument C allows weak safety laws to be projected*)
  project :: "['a*'b => 'c, 'c set, 'c program] => 'a program"
  where "project h C F =
       mk_program (project_set h (Init F),
                   project_act h ` Restrict C ` Acts F,
                   {act. Restrict (project_set h C) act \<in>
                         project_act h ` Restrict C ` AllowedActs F})"

locale Extend =
  fixes f     :: "'c => 'a"
    and g     :: "'c => 'b"
    and h     :: "'a*'b => 'c"    (*isomorphism between 'a * 'b and 'c *)
    and slice :: "['c set, 'b] => 'a set"
  assumes
    good_h:  "good_map h"
  defines f_def: "f z == fst (inv h z)"
      and g_def: "g z == snd (inv h z)"
      and slice_def: "slice Z y == {x. h(x,y) \<in> Z}"

(** These we prove OUTSIDE the locale. **)

subsection\<open>Restrict\<close>
(*MOVE to Relation.thy?*)

lemma Restrict_iff [iff]: "((x,y) \<in> Restrict A r) = ((x,y) \<in> r & x \<in> A)"
by (unfold Restrict_def, blast)

lemma Restrict_UNIV [simp]: "Restrict UNIV = id"
apply (rule ext)
apply (auto simp add: Restrict_def)
done

lemma Restrict_empty [simp]: "Restrict {} r = {}"
by (auto simp add: Restrict_def)

lemma Restrict_Int [simp]: "Restrict A (Restrict B r) = Restrict (A \<inter> B) r"
by (unfold Restrict_def, blast)

lemma Restrict_triv: "Domain r \<subseteq> A ==> Restrict A r = r"
by (unfold Restrict_def, auto)

lemma Restrict_subset: "Restrict A r \<subseteq> r"
by (unfold Restrict_def, auto)

lemma Restrict_eq_mono:
     "[| A \<subseteq> B;  Restrict B r = Restrict B s |]
      ==> Restrict A r = Restrict A s"
by (unfold Restrict_def, blast)

lemma Restrict_imageI:
     "[| s \<in> RR;  Restrict A r = Restrict A s |]
      ==> Restrict A r \<in> Restrict A ` RR"
by (unfold Restrict_def image_def, auto)

lemma Domain_Restrict [simp]: "Domain (Restrict A r) = A \<inter> Domain r"
by blast

lemma Image_Restrict [simp]: "(Restrict A r) `` B = r `` (A \<inter> B)"
by blast

(*Possibly easier than reasoning about "inv h"*)
lemma good_mapI:
     assumes surj_h: "surj h"
         and prem:   "!! x x' y y'. h(x,y) = h(x',y') ==> x=x'"
     shows "good_map h"
apply (simp add: good_map_def)
apply (safe intro!: surj_h)
apply (rule prem)
apply (subst surjective_pairing [symmetric])
apply (subst surj_h [THEN surj_f_inv_f])
apply (rule refl)
done

lemma good_map_is_surj: "good_map h ==> surj h"
by (unfold good_map_def, auto)

(*A convenient way of finding a closed form for inv h*)
lemma fst_inv_equalityI:
     assumes surj_h: "surj h"
         and prem:   "!! x y. g (h(x,y)) = x"
     shows "fst (inv h z) = g z"
by (metis UNIV_I f_inv_into_f prod.collapse prem surj_h)

subsection\<open>Trivial properties of f, g, h\<close>

context Extend
begin

lemma f_h_eq [simp]: "f(h(x,y)) = x"
by (simp add: f_def good_h [unfolded good_map_def, THEN conjunct2])

lemma h_inject1 [dest]: "h(x,y) = h(x',y') ==> x=x'"
apply (drule_tac f = f in arg_cong)
apply (simp add: f_def good_h [unfolded good_map_def, THEN conjunct2])
done

lemma h_f_g_equiv: "h(f z, g z) == z"
by (simp add: f_def g_def
            good_h [unfolded good_map_def, THEN conjunct1, THEN surj_f_inv_f])

lemma h_f_g_eq: "h(f z, g z) = z"
by (simp add: h_f_g_equiv)

lemma split_extended_all:
     "(!!z. PROP P z) == (!!u y. PROP P (h (u, y)))"
proof
   assume allP: "\<And>z. PROP P z"
   fix u y
   show "PROP P (h (u, y))" by (rule allP)
 next
   assume allPh: "\<And>u y. PROP P (h(u,y))"
   fix z
   have Phfgz: "PROP P (h (f z, g z))" by (rule allPh)
   show "PROP P z" by (rule Phfgz [unfolded h_f_g_equiv])
qed

end

subsection\<open>\<^term>\<open>extend_set\<close>: basic properties\<close>

lemma project_set_iff [iff]:
     "(x \<in> project_set h C) = (\<exists>y. h(x,y) \<in> C)"
by (simp add: project_set_def)

lemma extend_set_mono: "A \<subseteq> B ==> extend_set h A \<subseteq> extend_set h B"
by (unfold extend_set_def, blast)

context Extend
begin

lemma mem_extend_set_iff [iff]: "z \<in> extend_set h A = (f z \<in> A)"
apply (unfold extend_set_def)
apply (force intro: h_f_g_eq [symmetric])
done

lemma extend_set_strict_mono [iff]:
     "(extend_set h A \<subseteq> extend_set h B) = (A \<subseteq> B)"
by (unfold extend_set_def, force)

lemma (in -) extend_set_empty [simp]: "extend_set h {} = {}"
by (unfold extend_set_def, auto)

lemma extend_set_eq_Collect: "extend_set h {s. P s} = {s. P(f s)}"
by auto

lemma extend_set_sing: "extend_set h {x} = {s. f s = x}"
by auto

lemma extend_set_inverse [simp]: "project_set h (extend_set h C) = C"
by (unfold extend_set_def, auto)

lemma extend_set_project_set: "C \<subseteq> extend_set h (project_set h C)"
apply (unfold extend_set_def)
apply (auto simp add: split_extended_all, blast)
done

lemma inj_extend_set: "inj (extend_set h)"
apply (rule inj_on_inverseI)
apply (rule extend_set_inverse)
done

lemma extend_set_UNIV_eq [simp]: "extend_set h UNIV = UNIV"
apply (unfold extend_set_def)
apply (auto simp add: split_extended_all)
done

subsection\<open>\<^term>\<open>project_set\<close>: basic properties\<close>

(*project_set is simply image!*)
lemma project_set_eq: "project_set h C = f ` C"
by (auto intro: f_h_eq [symmetric] simp add: split_extended_all)

(*Converse appears to fail*)
lemma project_set_I: "!!z. z \<in> C ==> f z \<in> project_set h C"
by (auto simp add: split_extended_all)

subsection\<open>More laws\<close>

(*Because A and B could differ on the "other" part of the state,
   cannot generalize to
      project_set h (A \<inter> B) = project_set h A \<inter> project_set h B
*)
lemma project_set_extend_set_Int: "project_set h ((extend_set h A) \<inter> B) = A \<inter> (project_set h B)"
  by auto

(*Unused, but interesting?*)
lemma project_set_extend_set_Un: "project_set h ((extend_set h A) \<union> B) = A \<union> (project_set h B)"
  by auto

lemma (in -) project_set_Int_subset:
    "project_set h (A \<inter> B) \<subseteq> (project_set h A) \<inter> (project_set h B)"
  by auto

lemma extend_set_Un_distrib: "extend_set h (A \<union> B) = extend_set h A \<union> extend_set h B"
  by auto

lemma extend_set_Int_distrib: "extend_set h (A \<inter> B) = extend_set h A \<inter> extend_set h B"
  by auto

lemma extend_set_INT_distrib: "extend_set h (\<Inter>(B ` A)) = (\<Inter>x \<in> A. extend_set h (B x))"
  by auto

lemma extend_set_Diff_distrib: "extend_set h (A - B) = extend_set h A - extend_set h B"
  by auto

lemma extend_set_Union: "extend_set h (\<Union>A) = (\<Union>X \<in> A. extend_set h X)"
  by blast

lemma extend_set_subset_Compl_eq: "(extend_set h A \<subseteq> - extend_set h B) = (A \<subseteq> - B)"
  by (auto simp: extend_set_def)

subsection\<open>\<^term>\<open>extend_act\<close>\<close>

(*Can't strengthen it to
  ((h(s,y), h(s',y')) \<in> extend_act h act) = ((s, s') \<in> act & y=y')
  because h doesn't have to be injective in the 2nd argument*)
lemma mem_extend_act_iff [iff]: "((h(s,y), h(s',y)) \<in> extend_act h act) = ((s, s') \<in> act)"
  by (auto simp: extend_act_def)

(*Converse fails: (z,z') would include actions that changed the g-part*)
lemma extend_act_D: "(z, z') \<in> extend_act h act ==> (f z, f z') \<in> act"
  by (auto simp: extend_act_def)

lemma extend_act_inverse [simp]: "project_act h (extend_act h act) = act"
  unfolding extend_act_def project_act_def by blast

lemma project_act_extend_act_restrict [simp]:
     "project_act h (Restrict C (extend_act h act)) =
      Restrict (project_set h C) act"
  unfolding extend_act_def project_act_def by blast

lemma subset_extend_act_D: "act' \<subseteq> extend_act h act ==> project_act h act' \<subseteq> act"
  unfolding extend_act_def project_act_def by force

lemma inj_extend_act: "inj (extend_act h)"
apply (rule inj_on_inverseI)
apply (rule extend_act_inverse)
done

lemma extend_act_Image [simp]:
     "extend_act h act `` (extend_set h A) = extend_set h (act `` A)"
  unfolding extend_set_def extend_act_def by force

lemma extend_act_strict_mono [iff]:
     "(extend_act h act' \<subseteq> extend_act h act) = (act'<=act)"
  by (auto simp: extend_act_def)

lemma (in -) Domain_extend_act:
    "Domain (extend_act h act) = extend_set h (Domain act)"
  unfolding extend_set_def extend_act_def by force

lemma extend_act_Id [simp]: "extend_act h Id = Id"
  unfolding extend_act_def by (force intro: h_f_g_eq [symmetric])

lemma project_act_I:  "!!z z'. (z, z') \<in> act ==> (f z, f z') \<in> project_act h act"
  unfolding project_act_def by (force simp add: split_extended_all)

lemma project_act_Id [simp]: "project_act h Id = Id"
  unfolding project_act_def by force

lemma Domain_project_act: "Domain (project_act h act) = project_set h (Domain act)"
  unfolding project_act_def by (force simp add: split_extended_all)

subsection\<open>extend\<close>

text\<open>Basic properties\<close>

lemma (in -) Init_extend [simp]:
     "Init (extend h F) = extend_set h (Init F)"
  by (auto simp: extend_def)

lemma (in -) Init_project [simp]:
     "Init (project h C F) = project_set h (Init F)"
  by (auto simp: project_def)

lemma Acts_extend [simp]: "Acts (extend h F) = (extend_act h ` Acts F)"
  by (simp add: extend_def insert_Id_image_Acts)

lemma AllowedActs_extend [simp]:
     "AllowedActs (extend h F) = project_act h -` AllowedActs F"
  by (simp add: extend_def insert_absorb)

lemma (in -) Acts_project [simp]:
     "Acts(project h C F) = insert Id (project_act h ` Restrict C ` Acts F)"
  by (auto simp add: project_def image_iff)

lemma AllowedActs_project [simp]:
     "AllowedActs(project h C F) =
        {act. Restrict (project_set h C) act
               \<in> project_act h ` Restrict C ` AllowedActs F}"
apply (simp (no_asm) add: project_def image_iff)
apply (subst insert_absorb)
apply (auto intro!: bexI [of _ Id] simp add: project_act_def)
done

lemma Allowed_extend: "Allowed (extend h F) = project h UNIV -` Allowed F"
  by (auto simp add: Allowed_def)

lemma extend_SKIP [simp]: "extend h SKIP = SKIP"
apply (unfold SKIP_def)
apply (rule program_equalityI, auto)
done

lemma (in -) project_set_UNIV [simp]: "project_set h UNIV = UNIV"
  by auto

lemma (in -) project_set_Union: "project_set h (\<Union>A) = (\<Union>X \<in> A. project_set h X)"
  by blast

(*Converse FAILS: the extended state contributing to project_set h C
  may not coincide with the one contributing to project_act h act*)
lemma (in -) project_act_Restrict_subset:
     "project_act h (Restrict C act) \<subseteq> Restrict (project_set h C) (project_act h act)"
  by (auto simp add: project_act_def)

lemma project_act_Restrict_Id_eq: "project_act h (Restrict C Id) = Restrict (project_set h C) Id"
  by (auto simp add: project_act_def)

lemma project_extend_eq:
     "project h C (extend h F) =
      mk_program (Init F, Restrict (project_set h C) ` Acts F,
                  {act. Restrict (project_set h C) act
                          \<in> project_act h ` Restrict C `
                                     (project_act h -` AllowedActs F)})"
apply (rule program_equalityI)
  apply simp
 apply (simp add: image_image)
apply (simp add: project_def)
done

lemma extend_inverse [simp]:
     "project h UNIV (extend h F) = F"
apply (simp (no_asm_simp) add: project_extend_eq
          subset_UNIV [THEN subset_trans, THEN Restrict_triv])
apply (rule program_equalityI)
apply (simp_all (no_asm))
apply (subst insert_absorb)
apply (simp (no_asm) add: bexI [of _ Id])
apply auto
apply (simp add: image_def)
using project_act_Id apply blast
apply (simp add: image_def)
apply (rename_tac "act")
apply (rule_tac x = "extend_act h act" in exI)
apply simp
done

lemma inj_extend: "inj (extend h)"
apply (rule inj_on_inverseI)
apply (rule extend_inverse)
done

lemma extend_Join [simp]: "extend h (F\<squnion>G) = extend h F\<squnion>extend h G"
apply (rule program_equalityI)
apply (simp (no_asm) add: extend_set_Int_distrib)
apply (simp add: image_Un, auto)
done

lemma extend_JN [simp]: "extend h (JOIN I F) = (\<Squnion>i \<in> I. extend h (F i))"
apply (rule program_equalityI)
  apply (simp (no_asm) add: extend_set_INT_distrib)
 apply (simp add: image_UN, auto)
done

(** These monotonicity results look natural but are UNUSED **)

lemma extend_mono: "F \<le> G ==> extend h F \<le> extend h G"
  by (force simp add: component_eq_subset)

lemma project_mono: "F \<le> G ==> project h C F \<le> project h C G"
  by (simp add: component_eq_subset, blast)

lemma all_total_extend: "all_total F ==> all_total (extend h F)"
  by (simp add: all_total_def Domain_extend_act)

subsection\<open>Safety: co, stable\<close>

lemma extend_constrains:
     "(extend h F \<in> (extend_set h A) co (extend_set h B)) =
      (F \<in> A co B)"
  by (simp add: constrains_def)

lemma extend_stable:
     "(extend h F \<in> stable (extend_set h A)) = (F \<in> stable A)"
  by (simp add: stable_def extend_constrains)

lemma extend_invariant:
     "(extend h F \<in> invariant (extend_set h A)) = (F \<in> invariant A)"
  by (simp add: invariant_def extend_stable)

(*Projects the state predicates in the property satisfied by  extend h F.
  Converse fails: A and B may differ in their extra variables*)
lemma extend_constrains_project_set:
     "extend h F \<in> A co B ==> F \<in> (project_set h A) co (project_set h B)"
  by (auto simp add: constrains_def, force)

lemma extend_stable_project_set:
     "extend h F \<in> stable A ==> F \<in> stable (project_set h A)"
  by (simp add: stable_def extend_constrains_project_set)

subsection\<open>Weak safety primitives: Co, Stable\<close>

lemma reachable_extend_f: "p \<in> reachable (extend h F) ==> f p \<in> reachable F"
  by (induct set: reachable) (auto intro: reachable.intros simp add: extend_act_def image_iff)

lemma h_reachable_extend: "h(s,y) \<in> reachable (extend h F) ==> s \<in> reachable F"
  by (force dest!: reachable_extend_f)

lemma reachable_extend_eq: "reachable (extend h F) = extend_set h (reachable F)"
apply (unfold extend_set_def)
apply (rule equalityI)
apply (force intro: h_f_g_eq [symmetric] dest!: reachable_extend_f, clarify)
apply (erule reachable.induct)
apply (force intro: reachable.intros)+
done

lemma extend_Constrains:
     "(extend h F \<in> (extend_set h A) Co (extend_set h B)) =
      (F \<in> A Co B)"
  by (simp add: Constrains_def reachable_extend_eq extend_constrains
              extend_set_Int_distrib [symmetric])

lemma extend_Stable: "(extend h F \<in> Stable (extend_set h A)) = (F \<in> Stable A)"
  by (simp add: Stable_def extend_Constrains)

lemma extend_Always: "(extend h F \<in> Always (extend_set h A)) = (F \<in> Always A)"
  by (simp add: Always_def extend_Stable)

(** Safety and "project" **)

(** projection: monotonicity for safety **)

lemma (in -) project_act_mono:
     "D \<subseteq> C ==>
      project_act h (Restrict D act) \<subseteq> project_act h (Restrict C act)"
  by (auto simp add: project_act_def)

lemma project_constrains_mono:
     "[| D \<subseteq> C; project h C F \<in> A co B |] ==> project h D F \<in> A co B"
apply (auto simp add: constrains_def)
apply (drule project_act_mono, blast)
done

lemma project_stable_mono:
     "[| D \<subseteq> C;  project h C F \<in> stable A |] ==> project h D F \<in> stable A"
  by (simp add: stable_def project_constrains_mono)

(*Key lemma used in several proofs about project and co*)
lemma project_constrains:
     "(project h C F \<in> A co B)  =
      (F \<in> (C \<inter> extend_set h A) co (extend_set h B) & A \<subseteq> B)"
apply (unfold constrains_def)
apply (auto intro!: project_act_I simp add: ball_Un)
apply (force intro!: project_act_I dest!: subsetD)
(*the <== direction*)
apply (unfold project_act_def)
apply (force dest!: subsetD)
done

lemma project_stable: "(project h UNIV F \<in> stable A) = (F \<in> stable (extend_set h A))"
  by (simp add: stable_def project_constrains)

lemma project_stable_I: "F \<in> stable (extend_set h A) ==> project h C F \<in> stable A"
apply (drule project_stable [THEN iffD2])
apply (blast intro: project_stable_mono)
done

lemma Int_extend_set_lemma:
     "A \<inter> extend_set h ((project_set h A) \<inter> B) = A \<inter> extend_set h B"
  by (auto simp add: split_extended_all)

(*Strange (look at occurrences of C) but used in leadsETo proofs*)
lemma project_constrains_project_set:
     "G \<in> C co B ==> project h C G \<in> project_set h C co project_set h B"
  by (simp add: constrains_def project_def project_act_def, blast)

lemma project_stable_project_set:
     "G \<in> stable C ==> project h C G \<in> stable (project_set h C)"
  by (simp add: stable_def project_constrains_project_set)

subsection\<open>Progress: transient, ensures\<close>

lemma extend_transient:
     "(extend h F \<in> transient (extend_set h A)) = (F \<in> transient A)"
  by (auto simp add: transient_def extend_set_subset_Compl_eq Domain_extend_act)

lemma extend_ensures:
     "(extend h F \<in> (extend_set h A) ensures (extend_set h B)) =
      (F \<in> A ensures B)"
  by (simp add: ensures_def extend_constrains extend_transient
        extend_set_Un_distrib [symmetric] extend_set_Diff_distrib [symmetric])

lemma leadsTo_imp_extend_leadsTo:
     "F \<in> A leadsTo B
      ==> extend h F \<in> (extend_set h A) leadsTo (extend_set h B)"
apply (erule leadsTo_induct)
  apply (simp add: leadsTo_Basis extend_ensures)
 apply (blast intro: leadsTo_Trans)
apply (simp add: leadsTo_UN extend_set_Union)
done

subsection\<open>Proving the converse takes some doing!\<close>

lemma slice_iff [iff]: "(x \<in> slice C y) = (h(x,y) \<in> C)"
  by (simp add: slice_def)

lemma slice_Union: "slice (\<Union>S) y = (\<Union>x \<in> S. slice x y)"
  by auto

lemma slice_extend_set: "slice (extend_set h A) y = A"
  by auto

lemma project_set_is_UN_slice: "project_set h A = (\<Union>y. slice A y)"
  by auto

lemma extend_transient_slice:
     "extend h F \<in> transient A ==> F \<in> transient (slice A y)"
  by (auto simp: transient_def)

(*Converse?*)
lemma extend_constrains_slice:
     "extend h F \<in> A co B ==> F \<in> (slice A y) co (slice B y)"
  by (auto simp add: constrains_def)

lemma extend_ensures_slice:
     "extend h F \<in> A ensures B ==> F \<in> (slice A y) ensures (project_set h B)"
apply (auto simp add: ensures_def extend_constrains extend_transient)
apply (erule_tac [2] extend_transient_slice [THEN transient_strengthen])
apply (erule extend_constrains_slice [THEN constrains_weaken], auto)
done

lemma leadsTo_slice_project_set:
     "\<forall>y. F \<in> (slice B y) leadsTo CU ==> F \<in> (project_set h B) leadsTo CU"
apply (simp add: project_set_is_UN_slice)
apply (blast intro: leadsTo_UN)
done

lemma extend_leadsTo_slice [rule_format]:
     "extend h F \<in> AU leadsTo BU
      ==> \<forall>y. F \<in> (slice AU y) leadsTo (project_set h BU)"
apply (erule leadsTo_induct)
  apply (blast intro: extend_ensures_slice)
 apply (blast intro: leadsTo_slice_project_set leadsTo_Trans)
apply (simp add: leadsTo_UN slice_Union)
done

lemma extend_leadsTo:
     "(extend h F \<in> (extend_set h A) leadsTo (extend_set h B)) =
      (F \<in> A leadsTo B)"
apply safe
apply (erule_tac [2] leadsTo_imp_extend_leadsTo)
apply (drule extend_leadsTo_slice)
apply (simp add: slice_extend_set)
done

lemma extend_LeadsTo:
     "(extend h F \<in> (extend_set h A) LeadsTo (extend_set h B)) =
      (F \<in> A LeadsTo B)"
  by (simp add: LeadsTo_def reachable_extend_eq extend_leadsTo
              extend_set_Int_distrib [symmetric])

subsection\<open>preserves\<close>

lemma project_preserves_I:
     "G \<in> preserves (v o f) ==> project h C G \<in> preserves v"
  by (auto simp add: preserves_def project_stable_I extend_set_eq_Collect)

(*to preserve f is to preserve the whole original state*)
lemma project_preserves_id_I:
     "G \<in> preserves f ==> project h C G \<in> preserves id"
  by (simp add: project_preserves_I)

lemma extend_preserves:
     "(extend h G \<in> preserves (v o f)) = (G \<in> preserves v)"
  by (auto simp add: preserves_def extend_stable [symmetric]
                   extend_set_eq_Collect)

lemma inj_extend_preserves: "inj h ==> (extend h G \<in> preserves g)"
  by (auto simp add: preserves_def extend_def extend_act_def stable_def
                   constrains_def g_def)

subsection\<open>Guarantees\<close>

lemma project_extend_Join: "project h UNIV ((extend h F)\<squnion>G) = F\<squnion>(project h UNIV G)"
  apply (rule program_equalityI)
  apply (auto simp add: project_set_extend_set_Int image_iff)
  apply (metis Un_iff extend_act_inverse image_iff)
  apply (metis Un_iff extend_act_inverse image_iff)
  done

lemma extend_Join_eq_extend_D:
     "(extend h F)\<squnion>G = extend h H ==> H = F\<squnion>(project h UNIV G)"
apply (drule_tac f = "project h UNIV" in arg_cong)
apply (simp add: project_extend_Join)
done

(** Strong precondition and postcondition; only useful when
    the old and new state sets are in bijection **)

lemma ok_extend_imp_ok_project: "extend h F ok G ==> F ok project h UNIV G"
apply (auto simp add: ok_def)
apply (drule subsetD)
apply (auto intro!: rev_image_eqI)
done

lemma ok_extend_iff: "(extend h F ok extend h G) = (F ok G)"
apply (simp add: ok_def, safe)
apply force+
done

lemma OK_extend_iff: "OK I (%i. extend h (F i)) = (OK I F)"
apply (unfold OK_def, safe)
apply (drule_tac x = i in bspec)
apply (drule_tac [2] x = j in bspec)
apply force+
done

lemma guarantees_imp_extend_guarantees:
     "F \<in> X guarantees Y ==>
      extend h F \<in> (extend h ` X) guarantees (extend h ` Y)"
apply (rule guaranteesI, clarify)
apply (blast dest: ok_extend_imp_ok_project extend_Join_eq_extend_D
                   guaranteesD)
done

lemma extend_guarantees_imp_guarantees:
     "extend h F \<in> (extend h ` X) guarantees (extend h ` Y)
      ==> F \<in> X guarantees Y"
apply (auto simp add: guar_def)
apply (drule_tac x = "extend h G" in spec)
apply (simp del: extend_Join
            add: extend_Join [symmetric] ok_extend_iff
                 inj_extend [THEN inj_image_mem_iff])
done

lemma extend_guarantees_eq:
     "(extend h F \<in> (extend h ` X) guarantees (extend h ` Y)) =
      (F \<in> X guarantees Y)"
  by (blast intro: guarantees_imp_extend_guarantees
                 extend_guarantees_imp_guarantees)

end

end


theory Common
  imports Main (* "HOL-Eisbach.Eisbach" *)
begin

sledgehammer_params [provers=vampire cvc4 spass z3,timeout=60]

bundle trace = [[simp_trace, linarith_trace, metis_trace, smt_trace]]

lemma wf_compatP:
  assumes "\<And>a b. R a b \<Longrightarrow> R' (f a) (f b)" "wfP R'"
  shows "wfP R"
proof -
  have A: "\<forall>a b. (a, b) \<in> {(x, y). r x y} \<longrightarrow> (f a, f b) \<in> {(x, y). r' x y}"
    if "\<And>a b. r a b \<Longrightarrow> r' (f a) (f b)"
    for r :: "'a \<Rightarrow> 'a \<Rightarrow> bool" and f :: "'a \<Rightarrow> 'b" and r'
    using that by blast
  show ?thesis using compat_wf[to_pred,simplified compat_def,OF A,of R R'] assms by blast
qed

lemma set_comp_eq_iff: "({ f x | x . P x } = { g x | x . Q x }) \<longleftrightarrow>
       (\<forall>x. P x \<longrightarrow> (\<exists>y. Q y \<and> f x = g y)) \<and>
       (\<forall>x. Q x \<longrightarrow> (\<exists>y. P y \<and> g x = f y))"
  by blast

(* method solve methods m = (m ; fail)

named_theorems subst
named_theorems intros
named_theorems elims

method prop_solver declares intros elims subst =
  (assumption |
  (rule intros) | erule elims |
  subst subst | subst (asm) subst |
  (erule notE ; solve \<open>prop_solver\<close> ))+

lemmas [intros] =
  conjI \<comment> \<open>P \<Longrightarrow> Q \<Longrightarrow> P \<and> Q\<close>
  impI \<comment> \<open>(P \<Longrightarrow> Q) \<Longrightarrow> P \<Longrightarrow> Q\<close>
  disjCI \<comment> \<open>(\<not> Q \<Longrightarrow> P) \<Longrightarrow> P \<or> Q\<close>
  iffI \<comment> \<open>(P \<Longrightarrow> Q) \<Longrightarrow> (Q \<Longrightarrow> P) \<Longrightarrow> P \<longleftrightarrow> Q\<close>
  notI \<comment> \<open>(P \<Longrightarrow> False) \<Longrightarrow> \<not> P\<close>

lemmas [elims] =
  impCE \<comment> \<open>P \<longrightarrow> Q \<Longrightarrow> (\<not> P \<Longrightarrow> R) \<Longrightarrow> (Q \<Longrightarrow> R) \<Longrightarrow> R\<close>
  conjE \<comment> \<open>P \<and> Q \<Longrightarrow> (P \<Longrightarrow> Q \<Longrightarrow> R) \<Longrightarrow> R\<close>
  disjE \<comment> \<open>P \<or> Q \<Longrightarrow> (P \<Longrightarrow> R) \<Longrightarrow> (Q \<Longrightarrow> R) \<Longrightarrow> R\<close>
*)
lemma inv_into_aux_1: "(inv_into X f) ` (A \<inter> f ` X) =
        ((inv_into X f) ` A) \<inter> X"
  if A: "A \<subseteq> f ` X" for f :: "'a \<Rightarrow> 'b"
  using A
  by (simp add: inf_absorb1 inv_into_into subset_eq)

lemma inv_into_aux_2: "g ` (A \<inter> f ` X) =
        (g ` A) \<inter> X"
  if A:  "\<And>Y. g ` Y = inv_into X f ` (Y \<inter> f ` X) \<union>
                      {b | x . x \<in> Y \<and> x \<notin> f ` X}"
         "b \<notin> X"
  for g :: "'b \<Rightarrow> 'a" and f :: "'a \<Rightarrow> 'b" and X :: "'a set"
proof -
  have B: "A \<inter> f ` X \<subseteq> f ` X" using A by blast
  note C = inv_into_aux_1[of "A \<inter> f ` X" f X]
  have D: "\<And>Y. Y \<subseteq> f ` X \<Longrightarrow> g ` Y = inv_into X f ` Y"
    using A by auto
  have E: "(g ` Y) \<inter> X = g ` Y" if "Y \<subseteq> f ` X" for Y
    using that A
    by (metis (no_types, lifting) D inf.orderE inv_into_aux_1)
  have eq1: "g ` (A \<inter> f ` X) = inv_into X f ` (A \<inter> f ` X)"
    using C D[OF B] E B by (simp ; metis)
  have F: "g ` A \<subseteq> (inv_into X f ` (A \<inter> f ` X)) \<union> {b}"
    using A(1)[of A] A(2) Un_insert_right by blast
  have G: "inv_into X f ` (A \<inter> f ` X) \<subseteq> g ` A"
    using A by blast
  have eq2: "g ` A \<inter> X = inv_into X f ` (A \<inter> f ` X)"
    using F G A(2) C by auto
  show ?thesis
    using eq1 eq2 by simp
qed

lemma someI_bex: "(SOME x. x \<in> A \<and> P x) \<in> A" "P (SOME x. x \<in> A \<and> P x)"
    if "\<exists>a\<in>A. P a" for A :: "'a set" and P
    using someI2_bex[of A P "\<lambda>x. x \<in> A \<and> P x" , simplified,OF that]
    by simp+

lemma ex_iff_exI:
  fixes f g P Q
  assumes "\<And>x. P x \<Longrightarrow> Q (f x)"
          "\<And>x. Q x \<Longrightarrow> P (g x)"
  shows "(\<exists>x. P x) \<longleftrightarrow> (\<exists>x. Q x)"
  using assms by metis

lemma not_image_E:
  assumes "f y \<notin> f ` Y"
  obtains "y \<notin> Y" using assms imageI by metis

lemma image_Diff_subset: "\<lbrakk> Y \<subseteq> X ; f ` X \<inter> f ` Y = {} \<rbrakk> \<Longrightarrow> f ` (X - Y) = f ` X - f ` Y"
  by blast

lemma disjointE:
  assumes "A \<inter> B = {}"
  obtains "\<And>x. x \<notin> A \<or> x \<notin> B"
  using assms by blast

lemma iff_conj_I:
  assumes "P \<or> Q \<Longrightarrow> C"
      "\<lbrakk> P ; C \<rbrakk> \<Longrightarrow> Q" "\<lbrakk> Q ; C \<rbrakk> \<Longrightarrow> P"
  shows "P \<longleftrightarrow> Q"
  using assms by blast

lemma iff_dist: "(P \<Longrightarrow> (Q \<longleftrightarrow> R)) \<Longrightarrow> P \<and> Q \<longleftrightarrow> P \<and> R" for P Q R by blast

lemma permutation_disj_subset:
  assumes "\<forall>x. \<Omega> x \<in> X \<longleftrightarrow> x \<in> X" "\<forall>x. \<Omega> x \<in> Z \<longleftrightarrow> x \<in> Z" "X = Y \<union> Z"  "Y \<inter> X = {}"
  shows "\<And>x. \<Omega> x \<in> Y \<longleftrightarrow> x \<in> Y"
  using assms by simp

lemma neg_iff_D:
  assumes "(A \<longleftrightarrow> B)"
  shows "\<not> A \<Longrightarrow> \<not> B" "\<not> B \<Longrightarrow> \<not> A" using assms by auto

lemma Collect_by_func_I:
  assumes "\<And>x. P x \<Longrightarrow> Q (G x)"
     "\<And>x. P x \<Longrightarrow> g (G x) = f x"
     "\<And>x. Q x \<Longrightarrow> P (F x)"
     "\<And>x. Q x \<Longrightarrow> f (F x) = g x"
   shows "{ f x | x . P x } = { g x | x . Q x }"
  apply (rule Collect_eqI ; intro ex_iff_exI[of _ _ G F] ; elim conjE ; hypsubst_thin)
  using assms by metis+

locale equiv_rel =
  fixes P
  assumes
    sym[sym]: "P x y \<Longrightarrow> P y x" and
    trans: "\<lbrakk> P x y ; P y z \<rbrakk> \<Longrightarrow> P x z"

locale closure_rel_P = equiv_rel +
  fixes A
  assumes
    refl[intro]: "x \<in> A \<Longrightarrow> P x x" and
    closed: "\<lbrakk> P x y ; x \<in> A \<rbrakk> \<Longrightarrow> y \<in> A"
begin

lemma closed_iff: "P x y \<Longrightarrow> x \<in> A \<longleftrightarrow> y \<in> A" using closed sym by metis

end

lemma closure_rel_empty[intro!,simp]:
  assumes "equiv_rel P"
  shows "closure_rel_P P {}"
  apply (intro_locales ; (intro assms)?)
  by (unfold_locales ; simp)

lemma closure_rel_combs:
  assumes "closure_rel_P P X" "closure_rel_P P Y"
  shows "closure_rel_P P (X \<inter> Y)" (is ?goal1)
        "closure_rel_P P (X \<union> Y)" (is ?goal2)
        "closure_rel_P P (X - Y)" (is ?goal3)
proof -
  interpret X: closure_rel_P P X using assms by simp
  interpret Y: closure_rel_P P Y using assms by simp
  show ?goal1 by (metis Int_iff X.closed X.equiv_rel_axioms X.refl Y.closed closure_rel_P.intro closure_rel_P_axioms.intro)
  show ?goal2 by (metis Un_iff X.closed_iff X.equiv_rel_axioms X.refl Y.closed Y.refl closure_rel_P.intro closure_rel_P_axioms.intro)
  show ?goal3 by (metis DiffD1 DiffD2 DiffI X.closed X.equiv_rel_axioms X.refl Y.closed_iff closure_rel_P.intro closure_rel_P_axioms.intro)
qed

end