section \<open>Standard Rules\<close>
text \<open>We define the standard rules here, and prove the relation to standard rules.
      This means proving that the graph rules do what they say they do.\<close>
theory StandardRules
imports StandardModels RuleSemanticsConnection
begin

text \<open>Definition 16 makes this remark. We don't have a specific version of Definition 16.\<close>
lemma conflict_free:
":G:\<lbrakk>A_Lbl l\<rbrakk> = {} \<longleftrightarrow> (\<forall> (l',x,y)\<in>edges G. l' \<noteq> l)"
  by (auto simp:getRel_def)

text \<open>Definition 17, abstractly.
      It's unlikely that we wish to use the top rule for any symbol except top,
      but stating it abstractly makes it consistent with the other rules.\<close>
(* Definition 17 *)
definition top_rule :: "'l \<Rightarrow> ('l,nat) Graph_PreRule" where
"top_rule t = (LG {} {0,1},LG {(t,0,1)} {0,1})"

text \<open>Proof that definition 17 does what it says it does.\<close>
lemma top_rule[simp]:
  assumes "graph G"
  shows "maintained (top_rule r) G \<longleftrightarrow> vertices G \<times> vertices G = getRel r G"
proof
  assume a:"maintained (top_rule r) G"
  { fix a b assume "a \<in> vertices G" "b \<in> vertices G"
    hence "graph_homomorphism (LG {} {0, 1}) G {(0::nat,a),(1,b)}"
      using assms unfolding graph_homomorphism_def univalent_def by auto
    with a[unfolded maintained_def top_rule_def] extensible_refl_concr
    have "graph_homomorphism (LG {(r, 0, 1)} {0::nat, 1}) G {(0::nat, a), (1, b)}" by simp
    hence "(a, b) \<in> getRel r G"
      unfolding graph_homomorphism_def2 graph_union_iff getRel_def by auto
  }
  thus "vertices G \<times> vertices G = getRel r G" using getRel_dom[OF assms] by auto next
  assume a:"vertices G \<times> vertices G = getRel r G"
  { fix f assume a2:"graph_homomorphism (fst (top_rule r)) G f"
    hence f:"f `` {0, 1} \<subseteq> vertices G" "on_triple f `` {} \<subseteq> edges G"
          "univalent f" "Domain f = {0, 1}"
      unfolding top_rule_def prod.sel graph_homomorphism_concr_graph[OF assms graph_empty_e]
      by argo+
    from a2 have ih:"graph_homomorphism (LG {} {0, 1}) G f" unfolding top_rule_def by auto
    have "extensible (top_rule r) G f" unfolding top_rule_def extensible_refl_concr[OF ih]
      graph_homomorphism_concr_graph[OF assms graph_single]
      using f a[unfolded getRel_def] by fastforce
  }
  thus "maintained (top_rule r) G" unfolding maintained_def by auto
qed

text \<open>Definition 18.\<close>
(* Definition 18 *)
definition nonempty_rule :: "('l,nat) Graph_PreRule" where
"nonempty_rule = (LG {} {},LG {} {0})"

text \<open>Proof that definition 18 does what it says it does.\<close>
lemma nonempty_rule[simp]:
  assumes "graph G"
  shows "maintained nonempty_rule G \<longleftrightarrow> vertices G \<noteq> {}"
proof -
  have "vertices G = {} \<Longrightarrow> graph_homomorphism (LG {} {0}) G x \<Longrightarrow> False"
       "v \<in> vertices G \<Longrightarrow> graph_homomorphism (LG {} {0}) G {(0,v)}"
       for v::"'b" and x::"(nat \<times> 'b) set"
    unfolding graph_homomorphism_concr_graph[OF assms graph_empty_e] univalent_def by blast+
  thus ?thesis unfolding nonempty_rule_def maintained_def extensible_def by (auto intro:assms)
qed

text \<open>Definition 19.\<close>
definition reflexivity_rule :: "'l \<Rightarrow> ('l,nat) Graph_PreRule" where
  "reflexivity_rule t = (LG {} {0},LG {(t,0,0)} {0})"
definition symmetry_rule :: "'l \<Rightarrow> ('l,nat) Graph_PreRule" where
"symmetry_rule t = (transl_rule (A_Cnv (A_Lbl t) \<sqsubseteq> A_Lbl t))"
definition transitive_rule :: "'l \<Rightarrow> ('l,nat) Graph_PreRule" where
"transitive_rule t = (transl_rule (A_Cmp (A_Lbl t) (A_Lbl t) \<sqsubseteq> A_Lbl t))"
definition congruence_rule :: "'l \<Rightarrow> 'l \<Rightarrow> ('l,nat) Graph_PreRule" where
"congruence_rule t l = (transl_rule (A_Cmp (A_Cmp (A_Lbl t) (A_Lbl l)) (A_Lbl t) \<sqsubseteq> A_Lbl l))"
abbreviation congruence_rules :: "'l \<Rightarrow> 'l set \<Rightarrow> ('l,nat) Graph_PreRule set"
    where
"congruence_rules t L \<equiv> congruence_rule t ` L"

lemma are_rules[intro]:
"graph_rule nonempty_rule"
"graph_rule (top_rule t)"
"graph_rule (reflexivity_rule i)"
  unfolding reflexivity_rule_def top_rule_def nonempty_rule_def graph_homomorphism_def
  by auto

text \<open>Just before Lemma 7, we remark that if I is an identity, it maintains the identity rules.\<close>

lemma ident_rel_refl:
  assumes "graph G" "ident_rel idt G"
  shows "maintained (reflexivity_rule idt) G"
  unfolding reflexivity_rule_def
proof(rule maintainedI) fix f
  assume "graph_homomorphism (LG {} {0::nat}) G f"
  hence f:"Domain f = {0}" "graph G" "f `` {0} \<subseteq> vertices G" "univalent f"
    unfolding graph_homomorphism_def by force+
  from assms(2) univalentD[OF f(4)] f(3)
  have "edge_preserving f {(idt, 0, 0)} (edges G)" unfolding edge_preserving
    by (auto simp:getRel_def set_eq_iff image_def)
  with f have "graph_homomorphism (LG {(idt, 0, 0)} {0}) G f"
              "agree_on (LG {} {0}) f f" using assms
    unfolding graph_homomorphism_def labeled_graph.sel agree_on_def univalent_def
    by auto
  then show "extensible (LG {} {0}, LG {(idt, 0, 0)} {0}) G f"
    unfolding extensible_def prod.sel by auto
qed

lemma
  assumes "ident_rel idt G"
  shows ident_rel_trans:"maintained (transitive_rule idt) G"
    and ident_rel_symm :"maintained (symmetry_rule idt) G"
    and ident_rel_cong :"maintained (congruence_rule idt l) G"
  unfolding transitive_rule_def symmetry_rule_def congruence_rule_def
  by(intro maintained_holds,insert assms,force)+

text \<open>Definition 19.\<close>
definition identity_rules ::
  "'a Standard_Constant set \<Rightarrow> (('a Standard_Constant, nat) Graph_PreRule) set" where
  "identity_rules L \<equiv> {reflexivity_rule S_Idt,transitive_rule S_Idt,symmetry_rule S_Idt}
                       \<union> congruence_rules S_Idt L"

lemma identity_rules_graph_rule:
  assumes "x \<in> identity_rules L"
  shows "graph_rule x"
proof -
  from graph_rule_translation
  have gr:"\<And> u v . graph_rule (transl_rule (u \<sqsubseteq> v))" by auto
  consider "x = reflexivity_rule S_Idt" | "x = transitive_rule S_Idt" | "x = symmetry_rule S_Idt"
    |  "\<exists> v w. x = congruence_rule v w" using assms unfolding identity_rules_def Un_iff by blast
  thus ?thesis using gr are_rules(3)
    unfolding congruence_rule_def transitive_rule_def symmetry_rule_def
    by cases fast+
qed

text \<open>Definition 19, showing that the properties indeed do what they claim to do.\<close>
lemma
  assumes g[intro]:"graph (G :: ('a, 'b) labeled_graph)"
  shows reflexivity_rule: "maintained (reflexivity_rule l) G \<Longrightarrow> refl_on (vertices G) (getRel l G)"
    and transitive_rule: "maintained (transitive_rule l) G \<Longrightarrow> trans (getRel l G)"
    and symmetry_rule: "maintained (symmetry_rule l) G \<Longrightarrow> sym (getRel l G)"
proof -
  { from assms have gr:"getRel l G \<subseteq> vertices G \<times> vertices G" by (auto simp:getRel_def)
    assume m:"maintained (reflexivity_rule l) G" (is "maintained ?r G")
    note [simp] = reflexivity_rule_def
    show r:"refl_on (vertices G) (getRel l G)"
    proof(rule refl_onI[OF gr]) fix x
      assume assm:"x \<in> vertices G"  define f where "f = {(0::nat,x)}"
      have "graph_homomorphism (fst ?r) G f" using assm
        by (auto simp:graph_homomorphism_def univalent_def f_def)
      from m[unfolded maintained_def] this
      obtain g::"(nat\<times>'b) set"
        where g:"graph_homomorphism (snd ?r) G g"
                "agree_on (fst ?r) f g"
        unfolding extensible_def by blast
      have "\<And> n v. (n,v) \<in> g \<Longrightarrow> (n = 0) \<and> (v = x)" using g unfolding
        agree_on_def graph_homomorphism_def f_def by auto
      with g(2) have "g = {(0,x)}" unfolding agree_on_def f_def by auto
      with g(1) show "(x,x)\<in> getRel l G"
        unfolding graph_homomorphism_def edge_preserving getRel_def by auto
    qed
  }
  { assume m:"maintained (transitive_rule l) G"
    from m[unfolded maintained_holds_subset_iff[OF g] transitive_rule_def]
    show "trans (getRel l G)" unfolding trans_def by auto
  }
  { assume m:"maintained (symmetry_rule l) G"
    from m[unfolded maintained_holds_subset_iff[OF g] symmetry_rule_def]
    show "sym (getRel l G)" unfolding sym_def by auto
  }
qed

lemma finite_identity_rules[intro]:
  assumes "finite L"
  shows "finite (identity_rules L)"
  using assms unfolding identity_rules_def by auto

lemma equivalence:
  assumes gr:"graph G" and m:"maintainedA {reflexivity_rule I,transitive_rule I,symmetry_rule I} G"
  shows "equiv (vertices G) (getRel I G)"
proof(rule equivI)
  show "refl_on (vertices G) (getRel I G)" using m by(intro reflexivity_rule[OF gr],auto)
  show "sym (getRel I G)" using m by(intro symmetry_rule[OF gr],auto)
  show "trans (getRel I G)" using m by(intro transitive_rule[OF gr],auto)
qed

lemma congruence_rule:
 (* Transitivity is not needed for this proof, but it's more convenient to reuse in this form *)
  assumes g:"graph G"
      and mA:"maintainedA {reflexivity_rule I,transitive_rule I,symmetry_rule I} G"
      and m:"maintained (congruence_rule I l) G"
    shows "(\<lambda> v. getRel l G `` {v}) respects (getRel I G)" (is "?g1")
      and "(\<lambda> v. (getRel l G)\<inverse> `` {v}) respects (getRel I G)" (is "?g2")
proof -
  (* Both parts of this lemma are proved using roughly the same proof. *)
  note eq = equivalence[OF g mA]
  { fix y z
    assume aI:"(y, z)\<in>getRel I G"
    hence a2:"(z, y)\<in>getRel I G" using eq[unfolded equiv_def sym_def] by auto
    hence a3:"(z, z)\<in>getRel I G" "(y, y)\<in>getRel I G"
      using eq[unfolded equiv_def refl_on_def] by auto
    { fix x
      { assume al:"(y,x) \<in> getRel l G"
        hence "x \<in> vertices G" using g unfolding getRel_def by auto
        hence r:"(x,x) \<in> getRel I G" using eq[unfolded equiv_def refl_on_def] by auto
        note relcompI[OF relcompI[OF a2 al] r]
      } note yx = this
      { assume al:"(z,x) \<in> getRel l G"
        hence "x \<in> vertices G" using g unfolding getRel_def by auto
        hence r:"(x,x) \<in> getRel I G" using eq[unfolded equiv_def refl_on_def] by auto
        note relcompI[OF relcompI[OF aI al] r]
      } note zx = this
      from zx yx m[unfolded maintained_holds_subset_iff[OF g] congruence_rule_def]
      have "(y,x) \<in> getRel l G \<longleftrightarrow> (z,x) \<in> getRel l G" by auto
    } note v1 = this
    { fix x
      { assume al:"(x,y) \<in> getRel l G"
        hence "x \<in> vertices G" using g unfolding getRel_def by auto
        hence r:"(x,x) \<in> getRel I G" using eq[unfolded equiv_def refl_on_def] by auto
        note relcompI[OF relcompI[OF r al] aI]
      } note yx = this
      { assume al:"(x,z) \<in> getRel l G"
        hence "x \<in> vertices G" using g unfolding getRel_def by auto
        hence r:"(x,x) \<in> getRel I G" using eq[unfolded equiv_def refl_on_def] by auto
        note relcompI[OF relcompI[OF r al] a2]
      } note zx = this
      from zx yx m[unfolded maintained_holds_subset_iff[OF g] congruence_rule_def]
      have "(x,y) \<in> getRel l G \<longleftrightarrow> (x,z) \<in> getRel l G" by auto
    } note v2 = this
    from v1 v2
    have "getRel l G `` {y} = getRel l G `` {z}"
         "(getRel l G)\<inverse> `` {y} = (getRel l G)\<inverse> `` {z}" by auto
  }
  thus ?g1 ?g2 unfolding congruent_def by force+
qed

text \<open>Lemma 7, strengthened with an extra property to make subsequent proofs easier to carry out.\<close>
lemma identity_rules:
  assumes "graph G"
          "maintainedA (identity_rules L) G"
          "fst ` edges G \<subseteq> L"
  shows "\<exists> f. f o f = f
         \<and> ident_rel S_Idt (map_graph_fn G f)
         \<and> subgraph (map_graph_fn G f) G
         \<and> (\<forall> l x y. (l,x,y) \<in> edges G \<longleftrightarrow> (l,f x,f y) \<in> edges G)"
proof -
  (* While this proof defines a concrete f, we only expose it using an existential quantifier.
     The reason is that the f of our choice is non-constructive,
     and its definition relies on the axiom of choice.
     In fact, this theorem applies to the infinite case too,
     which means that it's probably equivalent to the axiom of choice.
     We therefore have no hopes of giving an executable concrete f here.
     In the implementation, we will be able to use finiteness of G (which is not required here),
     and therefore we can construct an f with these properties again.
     Unfortunately, this does mean doing roughly the same proof twice. *)
  have ma:"maintainedA {reflexivity_rule S_Idt, transitive_rule S_Idt, symmetry_rule S_Idt} G"
    using assms(2) by (auto simp:identity_rules_def)
  note equiv = equivalence[OF assms(1) this]
  { fix l x y
    assume "(x, y) \<in> getRel l G" hence l:"l \<in> L" using assms(3) unfolding getRel_def by auto
    have r1:"(\<lambda>v. getRel l G `` {v}) respects getRel S_Idt G"
      apply(intro congruence_rule[OF assms(1) ma])
      using assms(2) l unfolding identity_rules_def by auto
    have r2:"(\<lambda>v. (getRel l G)\<inverse> `` {v}) respects getRel S_Idt G"
      apply(intro congruence_rule[OF assms(1) ma])
      using assms(2) l unfolding identity_rules_def by auto
    note congr = r1 r2
  } note congr = this
  define P where P:"P = (\<lambda> x y. y \<in> getRel S_Idt G `` {x})"
  { fix x
    assume a:"getRel S_Idt G `` {x} \<noteq> {}"
    hence "\<exists> y. P x y" unfolding P by auto
    hence p:"P x (Eps (P x))" unfolding some_eq_ex by auto
    { fix y
      assume b:"P x y"
      hence "(x,y) \<in> getRel S_Idt G" unfolding P by auto
      from equiv_class_eq[OF equiv this]
      have "getRel S_Idt G `` {x} = getRel S_Idt G `` {y}".
    } note u = this[OF p]
    have "getRel S_Idt G `` {Eps (P x)} = getRel S_Idt G `` {x}"
      unfolding u by (fact refl)
    hence "Eps (P (Eps (P x))) = Eps (P x)" unfolding P by auto
  } note P_eq = this
  define f where f:"f = (\<lambda> x. (if getRel S_Idt G `` {x} = {} then x else (SOME y. P x y)))"
  have "(f \<circ> f) x = f x" for x proof(cases "getRel S_Idt G `` {x} = {}")
    case False
    then show ?thesis using P_eq by (simp add:o_def f)
  qed (auto simp:o_def f)
  hence idemp: "f o f = f" by auto

  from equivE equiv have refl:"refl_on (vertices G) (getRel S_Idt G)" by auto
  hence [intro]:"x \<in> vertices G \<Longrightarrow> (x, x) \<in> getRel S_Idt G" for x unfolding refl_on_def by auto
  hence vert_P:"x \<in> vertices G \<Longrightarrow> (x, Eps (P x)) \<in> getRel S_Idt G" for x
     unfolding P getRel_def by (metis tfl_some Image_singleton_iff getRel_def)
  have r1:"x \<in> vertices G \<longleftrightarrow> P x x" for x using refl unfolding refl_on_def P by auto
  have r2[simp]:"getRel S_Idt G `` {x} = {} \<longleftrightarrow> x \<notin> vertices G" for x
    using refl assms(1) unfolding refl_on_def by auto
  { fix x y assume "(S_Idt,x,y)\<in> edges G"
    hence "(x,y) \<in> getRel S_Idt G" unfolding getRel_def by auto
    hence "getRel S_Idt G `` {x} = getRel S_Idt G `` {y}"
      using equiv_class_eq[OF equiv] by metis
    hence "Eps (P x) = Eps (P y)" unfolding P by auto
  } note idt_eq = this
  have ident:"ident_rel S_Idt (map_graph_fn G f)"
  proof(rule ident_relI,goal_cases)
    case (1 x) thus ?case unfolding f by auto
  next case (2 x y) thus ?case unfolding getRel_def by (auto simp:f intro!:idt_eq)
  next case (3 x y) thus ?case unfolding getRel_def by auto
  qed

  { fix l x y
    assume a:"(l,x,y) \<in> edges G" "x \<in> vertices G" "y \<in> vertices G"
    hence f:"(f x, x) \<in> getRel S_Idt G" "(f y, y) \<in> getRel S_Idt G"
      using vert_P equivE[OF equiv] sym_def unfolding f by auto
    from a have gr:"(x, y) \<in> getRel l G" unfolding getRel_def by auto
    from congruentD[OF congr(1)[OF gr] f(1)] congruentD[OF congr(2)[OF gr] f(2)] a(1)
    have "(l,f x, f y) \<in> edges G" unfolding set_eq_iff getRel_def by auto
  } note gu1 = this
  { fix x assume a: "x \<in> vertices G"
    with vert_P have "(x,Eps (P x)) \<in> getRel S_Idt G" by auto
    hence "Eps (P x) \<in> vertices G" using assms(1) unfolding getRel_def by auto
    hence "f x \<in> vertices G" using a unfolding f by auto
  } note gu2 = this
  have "graph_union (map_graph_fn G f) G = G"
    using gu1 gu2 assms(1) unfolding graph_union_def by(cases G,auto)
  hence subg: "subgraph (map_graph_fn G f) G"
    unfolding subgraph_def using assms(1) by auto

  have congr:"((l, x, y) \<in> edges G) = ((l, f x, f y) \<in> edges G)" for l x y proof
    assume a:"((l, f x, f y) \<in> edges G)"
    hence gr:"(f x, f y) \<in> getRel l G" unfolding getRel_def by auto
    from a have fv:"f x \<in> vertices G" "f y \<in> vertices G" using assms(1) by auto
    { fix x assume a:"f x \<in> vertices G" "x \<notin> vertices G"
      with assms(1) have "getRel S_Idt G `` {x} = {}" by auto
      with a f have False by auto
    }
    with fv have v:"x \<in> vertices G" "y \<in> vertices G" by auto
    have gx:"(x, f x) \<in> getRel S_Idt G" and gy:"(y, f y) \<in> getRel S_Idt G" by (auto simp: f v vert_P)
    from congruentD[OF congr(1)[OF gr] gx] gr
    have "(x, f y) \<in> getRel l G" by auto
    with congruentD[OF congr(2)[OF gr] gy]
    have "(x, y) \<in> getRel l G" by auto
    thus "((l, x, y) \<in> edges G)" unfolding getRel_def by auto next
    assume e:"((l, x, y) \<in> edges G)"
    hence "x \<in> vertices G" "y \<in> vertices G" using assms(1) by auto
    from gu1[OF e this]
    show "((l, f x, f y) \<in> edges G)".
  qed

  from idemp ident subg congr show ?thesis by auto
qed

text \<open>The idempotency property of Lemma 7 suffices to show that 'maintained' is preserved.\<close>
lemma idemp_embedding_maintained_preserved:
  assumes subg:"subgraph (map_graph_fn G f) G" and f:"\<And> x. x\<in>vertices G \<Longrightarrow> (f o f) x = f x"
      and maint:"maintained r G"
    shows "maintained r (map_graph_fn G f)"
proof -
  { fix h assume hom_h:"graph_homomorphism (fst r) (map_graph_fn G f) h"
    from subgraph_preserves_hom[OF subg this] maint[unfolded maintained_def extensible_def]
    obtain g where g:"graph_homomorphism (snd r) G g"
                     "agree_on (fst r) h g" by blast
    { fix v x
      have subs:"h `` {v} \<subseteq> vertices (map_graph_fn G f)"
        using hom_h[unfolded graph_homomorphism_def] by auto
      assume "v\<in>vertices (fst r)" and x:"(v, x) \<in> g"
      hence "g `` {v} = h `` {v}" using g(2)[unfolded agree_on_def,rule_format,of v] by auto
      hence "g `` {v} \<subseteq> vertices (map_graph_fn G f)" using subs by auto
      hence x2:"x \<in> vertices (map_graph_fn G f)" using x by auto
      then obtain y where "x = f y" "y \<in> vertices G" by auto
      hence f:"f x = x" using f x2 unfolding o_def by metis
      from x2 subgraph_subset[OF subg] have "(x, f x) \<in> on_graph G f" by auto
      with x have "(v, x) \<in> g O on_graph G f" "f x = x" unfolding f by auto
    }
    hence agr:"agree_on (fst r) h (g O on_graph G f)"
      using g(2) unfolding agree_on_def by auto
    have "extensible r (map_graph_fn G f) h"
      unfolding extensible_def using graph_homomorphism_on_graph[OF g(1)] agr by blast
  }
  thus ?thesis unfolding maintained_def by blast
qed

text \<open>Definition 20.\<close>
definition const_exists where
"const_exists c \<equiv> transl_rule (\<top> \<sqsubseteq> A_Cmp (A_Cmp \<top> (A_Lbl (S_Const c))) \<top>)"
definition const_exists_rev where
"const_exists_rev c \<equiv> transl_rule (A_Cmp (A_Cmp (A_Lbl (S_Const c)) \<top>) (A_Lbl (S_Const c)) \<sqsubseteq> A_Lbl (S_Const c))"
definition const_prop where
"const_prop c \<equiv> transl_rule (A_Lbl (S_Const c) \<sqsubseteq> \<one>)"
definition const_disj where
"const_disj c\<^sub>1 c\<^sub>2 \<equiv> transl_rule (A_Cmp (A_Lbl (S_Const c\<^sub>1)) (A_Lbl (S_Const c\<^sub>2)) \<sqsubseteq> \<bottom>)"

lemma constant_rules:
  assumes "standard' C G" "c \<in> C"
  shows "maintained (const_exists c) G"
        "maintained (const_exists_rev c) G"
        "maintained (const_prop c) G"
        "c' \<in> C \<Longrightarrow> c \<noteq> c' \<Longrightarrow> maintained (const_disj c c') G"
proof -
  note a = assms[unfolded standard_def]
  from a have g:"graph G" by auto
  from a
  have gr_c:"getRel (S_Const c) G = {(Inl c, Inl c)}"
       "getRel S_Idt G = Id_on (vertices G)" "getRel S_Bot G = {}"
       "getRel S_Top G = vertices G \<times> vertices G" by auto
  with g have inlc:"Inl c \<in> vertices G" by (metis getRel_dom(1) singletonI)
  thus "maintained (const_exists c) G" "maintained (const_exists_rev c) G"
       "maintained (const_prop c) G"
    unfolding const_prop_def const_exists_rev_def const_exists_def maintained_holds_subset_iff[OF g]
    by (auto simp:gr_c relcomp_unfold)
  assume "c' \<in> C"
  with a have gr_c':"getRel (S_Const c') G = {(Inl c', Inl c')}" by auto
  thus "c \<noteq> c' \<Longrightarrow>  maintained (const_disj c c') G"
    unfolding const_disj_def maintained_holds_subset_iff[OF g] using gr_c by auto
qed

definition constant_rules where
"constant_rules C \<equiv> const_exists ` C \<union> const_exists_rev ` C \<union> const_prop ` C
                  \<union> {const_disj c\<^sub>1 c\<^sub>2 | c\<^sub>1 c\<^sub>2. c\<^sub>1 \<in> C \<and> c\<^sub>2 \<in> C \<and> c\<^sub>1 \<noteq> c\<^sub>2}"

lemma constant_rules_graph_rule:
  assumes "x \<in> constant_rules C"
  shows "graph_rule x"
proof -
  from graph_rule_translation
  have gr:"\<And> u v . graph_rule (transl_rule (u \<sqsubseteq> v))" by auto
  consider "\<exists> v. x = const_exists v" | "\<exists> v. x = const_exists_rev v" |  "\<exists> v. x = const_prop v"
    |  "\<exists> v w. x = const_disj v w" using assms unfolding constant_rules_def Un_iff by blast
  thus ?thesis using gr
    unfolding const_exists_def const_exists_rev_def const_prop_def const_disj_def
    by cases fast+
qed

lemma finite_constant[intro]:
  assumes "finite C"
  shows "finite (constant_rules C)"
proof -
  have "{const_disj c\<^sub>1 c\<^sub>2 | c\<^sub>1 c\<^sub>2. c\<^sub>1 \<in> C \<and> c\<^sub>2 \<in> C \<and> c\<^sub>1 \<noteq> c\<^sub>2} \<subseteq> case_prod const_disj ` (C \<times> C)"
    by auto
  moreover have "finite \<dots>" using assms by auto
  ultimately have "finite {const_disj c\<^sub>1 c\<^sub>2 | c\<^sub>1 c\<^sub>2. c\<^sub>1 \<in> C \<and> c\<^sub>2 \<in> C \<and> c\<^sub>1 \<noteq> c\<^sub>2}"
    by(rule finite_subset)
  thus ?thesis unfolding constant_rules_def using assms by blast
qed

lemma standard_maintains_constant_rules:
  assumes "standard' C G" "R\<in>constant_rules C"
  shows "maintained R G"
proof -
  from assms(2)[unfolded constant_rules_def]
  consider "\<exists> c \<in> C. R = const_exists c"
         | "\<exists> c \<in> C. R = const_exists_rev c"
         | "\<exists> c \<in> C. R = const_prop c"
         | "\<exists> c\<^sub>1 c\<^sub>2. c\<^sub>1 \<in> C \<and> c\<^sub>2 \<in> C \<and> c\<^sub>1 \<noteq> c\<^sub>2 \<and> R = const_disj c\<^sub>1 c\<^sub>2" by blast
  from this assms(1) show ?thesis by(cases,auto simp:constant_rules)
qed

lemma constant_rules_empty[simp]:
  "constant_rules {} = {}"
  by (auto simp:constant_rules_def)

text \<open>Definition 20, continued.\<close>
definition standard_rules :: "'a set \<Rightarrow> 'a Standard_Constant set \<Rightarrow> (('a Standard_Constant, nat) labeled_graph \<times> ('a Standard_Constant, nat) labeled_graph) set"
  where
"standard_rules C L \<equiv> constant_rules C \<union> identity_rules L \<union> {top_rule S_Top,nonempty_rule}"

lemma constant_rules_mono:
  assumes "C\<^sub>1 \<subseteq> C\<^sub>2"
  shows "constant_rules C\<^sub>1 \<subseteq> constant_rules C\<^sub>2"
  using assms unfolding constant_rules_def
  by(intro Un_mono,auto) (* also works with just auto, this is faster *)

lemma identity_rules_mono:
  assumes "C\<^sub>1 \<subseteq> C\<^sub>2"
  shows "identity_rules C\<^sub>1 \<subseteq> identity_rules C\<^sub>2"
   using assms unfolding identity_rules_def by auto

lemma standard_rules_mono:
  assumes "C\<^sub>1 \<subseteq> C\<^sub>2" "L\<^sub>1 \<subseteq> L\<^sub>2"
  shows "standard_rules C\<^sub>1 L\<^sub>1 \<subseteq> standard_rules C\<^sub>2 L\<^sub>2"
  using constant_rules_mono[OF assms(1)] identity_rules_mono[OF assms(2)]
  unfolding standard_rules_def by auto

lemma maintainedA_invmono:
  assumes "C\<^sub>1 \<subseteq> C\<^sub>2" "L\<^sub>1 \<subseteq> L\<^sub>2"
  shows "maintainedA (standard_rules C\<^sub>2 L\<^sub>2) G \<Longrightarrow> maintainedA (standard_rules C\<^sub>1 L\<^sub>1) G"
  using standard_rules_mono[OF assms] by auto

lemma maintained_preserved_by_isomorphism:
  assumes "\<And> x. x \<in> vertices G \<Longrightarrow> (f \<circ> g) x = x" "graph G"
      and "maintained r (map_graph_fn G g)"
  shows "maintained r G"
proof(cases r)
  case (Pair L R)
  show ?thesis unfolding Pair proof(standard,goal_cases)
    case (1 h)
    from assms(3)[unfolded maintained_def Pair] graph_homomorphism_on_graph[OF this, of g]
    have "extensible (L, R) (map_graph_fn G g) (h O on_graph G g)" by auto
    then obtain h2
      where h2:"graph_homomorphism R (map_graph_fn G g) h2" "agree_on L (h O on_graph G g) h2"
      unfolding extensible_def by auto
    from 1 have h_id:"h O Id_on (vertices G) = h" unfolding graph_homomorphism_def by auto
    let ?h = "h2 O on_graph (map_graph_fn G g) f"
    from assms(1) have "on_graph G (f \<circ> g) = Id_on (vertices G)" by auto
    hence "map_graph_fn G (f \<circ> g) = G" using assms(2) map_graph_fn_id by auto
    with graph_homomorphism_on_graph[OF h2(1),of f]
    have igh:"graph_homomorphism R G ?h" by auto
    have "g x = g xa \<Longrightarrow> x \<in> (vertices G) \<Longrightarrow> xa \<in> (vertices G) \<Longrightarrow> x = xa"
      for x xa using assms(1) o_def by metis
    hence "g x = g xa \<Longrightarrow> x \<in> (vertices G) \<Longrightarrow> xa \<in> (vertices G) \<Longrightarrow> (x, xa) \<in> Id_on (vertices G)"
      for x xa by auto
    hence id:"(on_graph G g) O on_graph (map_graph_fn G g) f = Id_on (vertices G)"
      using assms(1) by auto
    from agree_on_ext[OF h2(2),of "on_graph (map_graph_fn G g) f",unfolded O_assoc]
    have agh:"agree_on L h ?h" unfolding agree_on_def id h_id.
    from igh agh show ?case unfolding extensible_def by auto
  qed
qed

lemma standard_identity_rules:
  assumes "standard' C G"
  shows "maintained (reflexivity_rule S_Idt) G"
        "maintained (transitive_rule S_Idt) G"
        "maintained (symmetry_rule S_Idt) G"
        "maintained (congruence_rule S_Idt l) G"
proof -
  note a = assms[unfolded standard_def]
  from a have g:"graph G" by auto
  from a
  have gr:"getRel S_Idt G = Id_on (vertices G)" "getRel S_Bot G = {}"
       "getRel S_Top G = vertices G \<times> vertices G"
    and v_gr:"\<forall>a b. ((S_Idt, a, b) \<in> edges G) = (a \<in> vertices G \<and> b = a)"
    unfolding getRel_def by auto
  thus "maintained (transitive_rule S_Idt) G" "maintained (symmetry_rule S_Idt) G"
       "maintained (congruence_rule S_Idt l) G"
    unfolding transitive_rule_def symmetry_rule_def congruence_rule_def
              maintained_holds_subset_iff[OF g]
    by (auto simp:gr relcomp_unfold)
  { fix f :: "(nat \<times> ('a + 'b)) set"
    assume "graph_homomorphism (LG {} {0}) G f"
    hence u:"univalent f" and d:"Domain f = {0}"
       and r:"f `` {0} \<subseteq> vertices G" unfolding graph_homomorphism_def by simp+
    from d obtain v where v:"(0,v) \<in> f" by auto
    hence f:"f = {(0,v)}"
      using d insert_iff mk_disjoint_insert all_not_in_conv old.prod.exhaust
            u[unfolded univalent_def] Domain.intros[of _ _ f,unfolded d,THEN singletonD]
      by (metis (no_types))
    from v r have v:"v \<in> vertices G" by auto
    with v_gr have "(S_Idt, v, v) \<in> edges G" by auto
    hence "edge_preserving {(0, v)} {(S_Idt, 0, 0)} (edges G)" unfolding edge_preserving by auto
    hence "graph_homomorphism (LG {(S_Idt, 0, 0)} {0}) G f" unfolding f
      graph_homomorphism_def using g v by (auto simp:univalent_def)
  }
  thus "maintained (reflexivity_rule S_Idt) G"
    unfolding reflexivity_rule_def maintained_def by auto
qed

lemma standard_maintains_identity_rules:
  assumes "standard' C G" "x\<in>identity_rules L"
  shows "maintained x G"
proof -
  consider "x = reflexivity_rule S_Idt" | "x = transitive_rule S_Idt" | "x = symmetry_rule S_Idt"
    |  "\<exists> l. x = congruence_rule S_Idt l" using assms unfolding identity_rules_def Un_iff by blast
  thus ?thesis using standard_identity_rules[OF assms(1)] by(cases,auto)
qed

lemma standard_maintains_rules:
  assumes "standard' C G"
  shows "maintainedA (standard_rules C L) G"
proof fix R
  assume "R \<in> standard_rules C L"
  then consider "R \<in> constant_rules C" | "R \<in> identity_rules L"
    | "R = top_rule S_Top" | "R = nonempty_rule" by (auto simp:standard_rules_def)
  thus "maintained R G"
    using assms standard_maintains_constant_rules[OF assms]
          standard_maintains_identity_rules[OF assms] by (cases,auto simp:standard_def)
qed

text \<open>A case-split rule.\<close>
lemma standard_rules_edges:
  assumes "(lhs, rhs) \<in> standard_rules C L" "(l, x, y) \<in> edges rhs"
  shows "(l = S_Bot \<Longrightarrow> thesis) \<Longrightarrow>
         (l = S_Top \<Longrightarrow> thesis) \<Longrightarrow>
         (l = S_Idt \<Longrightarrow> thesis) \<Longrightarrow>
         (l \<in> S_Const ` C \<Longrightarrow> thesis) \<Longrightarrow>
         (l \<in> L \<Longrightarrow> thesis) \<Longrightarrow> thesis"
  using assms
  by (auto simp:Let_def standard_rules_def constant_rules_def identity_rules_def
   const_exists_def const_exists_rev_def const_prop_def const_disj_def
   reflexivity_rule_def transitive_rule_def symmetry_rule_def congruence_rule_def
   top_rule_def nonempty_rule_def)

text \<open>Lemma 8.

   This is a slightly stronger version of Lemma 8:
   we reason about maintained rather than holds,
   and the quantification for maintained happens within the existential quantifier, rather than outside.

   Due to the type system of Isabelle, we construct the concrete type @{term std_graph} for G.
   This in contrast to arguing that 'there exists a type large enough', as in the paper.\<close>

lemma maintained_standard_noconstants:
  assumes mnt:"maintainedA (standard_rules C L) G'"
  and gr:"graph (G'::('V Standard_Constant, 'V') labeled_graph)"
         "fst ` edges G' \<subseteq> L" (* Graph on labels L *)
  and cf:"getRel S_Bot G' = {}" (* Conflict free *)
shows "\<exists> f g (G::('V, 'V') std_graph). G = map_graph_fn G (f o g) \<and> G = map_graph_fn G' f
              \<and> subgraph (map_graph_fn G g) G'
              \<and> standard' C G
              \<and> (\<forall> r. maintained r G' \<longrightarrow> maintained r G)
              \<and> (\<forall> x y e. x \<in> vertices G' \<longrightarrow> y \<in> vertices G' \<longrightarrow>
                          (g (f x), g (f y)) \<in> :map_graph_fn G g:\<lbrakk>e\<rbrakk> \<longrightarrow> (x,y) \<in> :G':\<lbrakk>e\<rbrakk>)"
proof -
  note mnt = mnt[unfolded standard_rules_def]
  from mnt have "maintainedA (identity_rules L) G'" by auto
  from identity_rules[OF gr(1) this gr(2)] obtain h where
    h:"h \<circ> h = h" "ident_rel S_Idt (map_graph_fn G' h)" "subgraph (map_graph_fn G' h) G'"
      "((l, x, y) \<in> edges G') = ((l, h x, h y) \<in> edges G')" for l x y by blast
  have mg:"\<And> r. maintained r G' \<Longrightarrow> maintained r (map_graph_fn G' h)"
   using idemp_embedding_maintained_preserved[OF h(3)] h(1) by auto
  from mnt have tr:"maintained (top_rule S_Top) G'" and ne:"maintained nonempty_rule G'" by auto
  from nonempty_rule[OF gr(1)] ne obtain x where x:"x \<in> vertices G'" by blast
  from tr[unfolded top_rule[OF gr(1)]] x have top_nonempty:"(x, x) \<in> getRel S_Top G'" by auto
  have "\<And> c. c \<in> C \<Longrightarrow> \<exists>v. (v, v) \<in> getRel (S_Const c) (map_graph_fn G' h)" proof(goal_cases)
    case (1 c)
    with mnt have cr5: "maintained (const_exists c) G'"
              and cr7: "maintained (const_prop c) G'" unfolding constant_rules_def by blast+
    from top_nonempty cr5[unfolded maintained_holds_subset_iff[OF gr(1)] const_exists_def]
    obtain y z where yz:"(y,z) \<in> getRel (S_Const c) G'" by auto
    from this gr(1) have yzv:"y \<in> vertices G'" "z \<in> vertices G'" by (auto simp:getRel_def)
    from getRel_hom[OF yz yzv]
    have hi:"(h y,h z) \<in> getRel (S_Const c) (map_graph_fn G' h)".
    with h(2) cr7[THEN mg,unfolded maintained_holds_subset_iff[OF map_graph_fn_graphI] const_prop_def]
    have "h y = h z" by force
    thus "\<exists> v. (v,v) \<in> getRel (S_Const c) (map_graph_fn G' h)" using hi by auto
  qed
  hence "\<forall> c. \<exists> v. c \<in> C \<longrightarrow> (v, v) \<in> getRel (S_Const c) (map_graph_fn G' h)" by blast
  from choice[OF this] obtain m
    where m:"\<And> x. x \<in> C \<Longrightarrow> (m x, m x) \<in> getRel (S_Const x) (map_graph_fn G' h)" by blast
  let ?m' = "\<lambda> x. if x \<in> m ` C then Inl (the_inv_into C m x) else Inr x"
  define f where "f \<equiv> ?m' o h"
  have "\<And> x y. x \<in> C \<Longrightarrow> y \<in> C \<Longrightarrow> m x = m y \<Longrightarrow> x = y" proof(goal_cases)
    case (1 x y)
    with m have "(m x,m x) \<in> getRel (S_Const y) (map_graph_fn G' h)"
                "(m x,m x) \<in> getRel (S_Const x) (map_graph_fn G' h)" by metis+
    hence mx: "(m x,m x) \<in> getRel (S_Const y) G'"
              "(m x,m x) \<in> getRel (S_Const x) G'" using h(3) by force+
    from 1(1,2) mnt have cr8:"x \<noteq> y \<Longrightarrow> maintained (const_disj x y) G'"
      unfolding constant_rules_def by blast
    from cr8[unfolded maintained_holds_subset_iff[OF gr(1)] const_disj_def] mx
    have "x\<noteq>y\<Longrightarrow>(m x,m x) \<in> :G':\<lbrakk>\<bottom>\<rbrakk>" by auto
    thus "x = y" using cf by auto
  qed
  hence "univalent (converse (BNF_Def.Gr C m))" unfolding univalent_def by auto
  hence inj_m:"inj_on m C" unfolding inj_on_def by auto

  from inj_on_the_inv_into[OF inj_m] have inj_m':"inj ?m'" unfolding inj_on_def by auto
  define G where "G = map_graph_fn G' f"
  hence G:"graph G" "f x \<in> vertices G" "getRel S_Bot G = {}" using x cf unfolding getRel_def
    by force+
  from comp_inj_on[OF inj_on_the_inv_into[OF inj_m] inj_Inl, unfolded o_def] inj_Inr
  have inj_m':"inj_on ?m' (vertices G')" unfolding inj_on_def by auto
  define g where "g = the_inv_into (vertices G') ?m'"

  have gf_h:"\<And> x. x \<in> vertices G' \<Longrightarrow> (g o f) x = h x" unfolding g_def f_def o_def
    apply(rule the_inv_into_f_f[OF inj_m']) using h unfolding subgraph_def graph_union_iff by auto

  have mg_eq:"map_graph_fn G' (g \<circ> f) = map_graph_fn G' h"
    by (rule map_graph_fn_eqI[OF gf_h])

  have "\<And> x. x \<in> vertices G' \<Longrightarrow> h x \<in> vertices G'" using h(3)
    unfolding subgraph_def graph_union_iff by(cases G',auto)
  hence gf_id:"\<And> x. x \<in> vertices G' \<Longrightarrow> (g o f) (h x) = (h x)"
    using h(1) gf_h unfolding o_def by metis
  { fix x assume "x \<in> vertices G"
    then obtain y where y:"f y = x" "y \<in> vertices G'" unfolding G_def by auto
    from gf_h[OF y(2)] have "(f o g) (f y) = f (h y)" unfolding o_def by auto
    also have "\<dots> = f y" using h(1) unfolding f_def o_def by metis
    finally have "(f o g) x = x" unfolding y.
  } note fg_id = this

  have fg_inv:"map_graph_fn G (f o g) = G"
    using h(1) G_def f_def mg_eq map_graph_fn_comp by (metis (no_types, lifting))

  have ir:"ident_rel S_Idt G" unfolding set_eq_iff proof(standard,standard,goal_cases)
    case (1 x)
    from this[unfolded G_def]
    obtain v1 v2 where v:"(v1,v2) \<in> getRel S_Idt G'" "x = (f v1,f v2)"
      unfolding getRel_def map_graph_def on_triple_def by auto
    hence vv:"v1 \<in> vertices G'" "v2 \<in> vertices G'" using gr unfolding getRel_def by auto
    with h(2) v(1) have "h v1 = h v2" unfolding image_def by blast
    hence x:"x = (f v1,f v1)" unfolding f_def v by auto
    from vv(1) show ?case unfolding x G_def by auto
  next
    case (2 x)
    hence x:"fst x = snd x" "fst x \<in> vertices G" by auto
    hence "(fst x) \<in> f ` vertices G'" unfolding G_def o_def by auto
    then obtain v where v:"v \<in> vertices G'" "f v = fst x" by auto
    hence hv:"h v \<in> vertices (map_graph_fn G' h)" by simp
    hence "(h v,h v) \<in> getRel S_Idt (map_graph_fn G' h)" unfolding h(2) by auto
    from getRel_hom[OF this hv hv]
    have "(?m' (h v),?m' (h v)) \<in> getRel S_Idt (map_graph_fn G' (?m' o h))"
      unfolding map_graph_fn_comp by fast
    hence "(f v,f v) \<in> getRel S_Idt (map_graph_fn G' f)" unfolding f_def by auto
    hence "(fst x,snd x) \<in> getRel S_Idt G" unfolding x v G_def by auto
    thus ?case unfolding G_def by auto
  qed

  from tr[unfolded top_rule[OF gr(1)]]
  have tr0:"getRel S_Top (map_graph_fn G' h)
          = {(x,y). x \<in> vertices (map_graph_fn G' h) \<and> y \<in> vertices (map_graph_fn G' h)}"
    and tr:"getRel S_Top G = {(x, y). x \<in> vertices G \<and> y \<in> vertices G}"
    unfolding G_def getRel_def on_triple_def map_graph_def by auto

  have m:"\<And> x. x \<in> C \<Longrightarrow> {(m x, m x)} = getRel (S_Const x) (map_graph_fn G' h)" proof fix x
    assume x:"x \<in> C"
    { fix y z assume a:"(y,z) \<in> getRel (S_Const x) (map_graph_fn G' h)"
      let ?t = "getRel S_Top (map_graph_fn G' h)"
      let ?r = "getRel (S_Const x) (map_graph_fn G' h)"
      have mx:"(m x,m x) \<in> getRel (S_Const x) (map_graph_fn G' h)" using m x by auto
      with a have v:"y \<in> vertices (map_graph_fn G' h)"
                    "z \<in> vertices (map_graph_fn G' h)"
                    "m x \<in> vertices (map_graph_fn G' h)" unfolding getRel_def by force+
      with tr0 have "(m x,y) \<in> ?t" "(z,m x) \<in> ?t" by auto
      with a mx have lhs:"(m x,z) \<in> ?r O ?t O ?r" "(y,m x) \<in> ?r O ?t O ?r" by auto
      from x mnt have "maintained (const_exists_rev x) G'"
                  and "maintained (const_prop x) G'" unfolding constant_rules_def by blast+
      hence cr6:"maintained (const_exists_rev x) (map_graph_fn G' h)"
        and cr7:"maintained (const_prop x) (map_graph_fn G' h)"
        by (intro mg, force)+
      hence "(m x,z) \<in> getRel S_Idt (map_graph_fn G' h)"
            "(y,m x) \<in> getRel S_Idt (map_graph_fn G' h)" using lhs
        unfolding maintained_holds_subset_iff[OF map_graph_fn_graphI]
                  const_exists_rev_def const_prop_def by auto
      hence "y = m x" "z = m x" using h(2) by auto
    }
    thus "getRel (S_Const x) (map_graph_fn G' h) \<subseteq> {(m x, m x)}" by auto
  qed (insert m,auto)

  from mg_eq have mg_eq:"map_graph_fn G g = map_graph_fn G' h" unfolding G_def map_graph_fn_comp.

  { fix l fix v::"'V + 'V'"
    assume a:"(l, v)\<in>(\<lambda>c. (S_Const c, Inl c)) ` C"
    hence "getRel l G = {(v, v)}" using m proof(cases l)
      case (S_Const x) hence x:"l = S_Const x" "v = Inl x" "x \<in> C" using a by auto
      hence mx:"m x \<in> m ` C" by auto
      from m[OF x(3)] have "(m x,m x) \<in> getRel (S_Const x) (map_graph_fn G' h)" by auto
      hence "(S_Const x,m x,m x) \<in> edges (map_graph_fn G' h)" unfolding getRel_def by auto
      hence "m x \<in> vertices (map_graph_fn G' h)" unfolding map_graph_def Image_def by auto
      then obtain x' where x':"m x = h x'" "x' \<in> vertices G'" by auto
      from h(1) have hmx[simp]:"h (m x) = m x" unfolding x' o_def by metis
      hence fmx:"f (m x) = v" unfolding x f_def
        using the_inv_into_f_f[OF inj_m] inj_m[unfolded inj_on_def,rule_format,OF x(3)] mx by auto
      have "{(f (m x), f (m x))} = getRel l (map_graph_fn G (f \<circ> g))"
        unfolding map_graph_fn_comp getRel_hom_map[OF map_graph_fn_graphI]
                  m[OF x(3),folded mg_eq x(1),symmetric] by auto
      hence gr:"getRel l G = {(f (m x), f (m x))}" unfolding fg_inv by blast
      show ?thesis unfolding gr fmx by (fact refl)
    qed auto
  } note cr = this

  have sg:"subgraph (map_graph_fn G g) G'" unfolding mg_eq using h(3).
  have std:"standard' C G" unfolding standard_def using G ir tr cr by blast
  have mtd:"\<And>r. maintained r G' \<Longrightarrow> maintained r G" proof(goal_cases)
    case (1 r) from mg[OF 1,folded mg_eq] maintained_preserved_by_isomorphism[OF fg_id G(1)]
    show ?case by metis
  qed

  { fix x y e
    assume "x \<in> vertices G'" "y \<in> vertices G'"
           "(g (f x), g (f y)) \<in> :map_graph_fn (map_graph_fn G' f) g:\<lbrakk>e\<rbrakk>"
    hence "(x,y) \<in> :G':\<lbrakk>e\<rbrakk>"
    proof(induct e arbitrary: x y)
      case (A_Cmp e1 e2)
        then obtain z where z:"(g (f x), z) \<in> :map_graph_fn (map_graph_fn G' f) g:\<lbrakk>e1\<rbrakk>"
                              "(z, g (f y)) \<in> :map_graph_fn (map_graph_fn G' f) g:\<lbrakk>e2\<rbrakk>" by auto
        hence "z \<in> vertices (map_graph_fn (map_graph_fn G' f) g)"
          using semantics_in_vertices(1)[OF map_graph_fn_graphI] by metis
        then obtain z' where z':"z = g (f z')" "z' \<in> vertices G'" by auto
        with A_Cmp(1)[OF A_Cmp(3) z'(2) z(1)[unfolded z']]
             A_Cmp(2)[OF z'(2) A_Cmp(4) z(2)[unfolded z']]
        have "(x, y) \<in> (:G':\<lbrakk>e1\<rbrakk>) O (:G':\<lbrakk>e2\<rbrakk>)" by auto
        then show ?case by auto
      next
        case (A_Lbl l)
        hence "(l, g (f x), g (f y)) \<in> edges (map_graph_fn G g)"
          by (auto simp:getRel_def G_def)
        then obtain x' y'
          where "(l, x', y') \<in> edges G" "g (f x) = g x'" "g (f y) = g y'" by auto
        then obtain x' y'
          where xy:"(l, x', y') \<in> edges G'" "g (f x) = g (f x')" "g (f y) = g (f y')"
          unfolding G_def by auto
        hence "x' \<in> vertices G'" "y' \<in> vertices G'" using gr(1) by auto
        from this[THEN gf_h,unfolded o_def] A_Lbl(1,2)[THEN gf_h,unfolded o_def]
        have "h x = h x'" "h y = h y'" using xy(2,3) by auto
        hence "(l, x, y) \<in> edges G'" using h(4)[of l x y] h(4)[of l x' y'] xy(1) by auto
        then show ?case by (simp add:getRel_def)
    qed auto
  }
  hence cons:"(\<forall> x y e. x \<in> vertices G' \<longrightarrow> y \<in> vertices G' \<longrightarrow> (g (f x), g (f y)) \<in> :map_graph_fn G g:\<lbrakk>e\<rbrakk> \<longrightarrow> (x,y) \<in> :G':\<lbrakk>e\<rbrakk>)"
    unfolding G_def by auto

  show ?thesis using cons G_def fg_inv[symmetric] sg std mtd by blast
qed

end


section\<open>Commitment Schemes\<close>

text\<open>A commitment scheme is a two party Cryptographic protocol run between a committer and a verifier.
They allow the committer to commit to a chosen value while at a later time reveal the value. A commitment
scheme is composed of three algorithms, the key generation, the commitment and the verification algorithms.

The two main properties of commitment schemes are hiding and binding.\<close>

text\<open>Hiding is the property that the commitment leaks no information about the committed value, and
binding is the property that the committer cannot reveal their a different message to the one they
committed to; that is they are bound to their commitment. We follow the game based approach \cite{DBLP:journals/iacr/Shoup04} to
define security. A game is played between an adversary and a challenger.\<close>

theory Commitment_Schemes imports
  CryptHOL.CryptHOL
begin

subsection\<open>Defining security\<close>
text\<open>Here we define the hiding, binding and correctness properties of commitment schemes.\<close>

text\<open>We provide the types of the adversaries that take part in the hiding and binding games. We consider
two variants of the hiding property, one stronger than the other --- thus we provide two hiding adversaries.
The first hiding property we consider is analogous to the IND-CPA property for encryption schemes, the second,
weaker notion, does not allow the adversary to choose the messages used in the game, instead they are sampled
from a set distribution.\<close>

type_synonym ('vk', 'plain', 'commit', 'state) hid_adv =
  "('vk' \<Rightarrow> (('plain' \<times> 'plain') \<times> 'state) spmf)
   \<times> ('commit' \<Rightarrow> 'state \<Rightarrow> bool spmf)"

type_synonym 'commit' hid = "'commit' \<Rightarrow> bool spmf"

type_synonym ('ck', 'plain', 'commit', 'opening')  bind_adversary =
  "'ck' \<Rightarrow> ('commit' \<times> 'plain' \<times> 'opening' \<times> 'plain' \<times> 'opening') spmf"

text\<open>We fix the algorithms that make up a commitment scheme in the locale.\<close>

locale abstract_commitment =
  fixes key_gen :: "('ck \<times> 'vk) spmf" \<comment> \<open>outputs the keys received by the two parties\<close>
    and commit :: "'ck \<Rightarrow> 'plain \<Rightarrow> ('commit \<times> 'opening) spmf" \<comment> \<open>outputs the commitment as well as the opening values sent by the committer in the reveal phase\<close>
    and verify :: "'vk \<Rightarrow> 'plain \<Rightarrow> 'commit \<Rightarrow> 'opening \<Rightarrow> bool"
    and valid_msg :: "'plain \<Rightarrow> bool" \<comment> \<open>checks whether a message is valid, used in the hiding game\<close>
begin

definition "valid_msg_set = {m. valid_msg m}"

definition lossless :: "('pub_key, 'plain, 'commit, 'state) hid_adv \<Rightarrow> bool"
  where "lossless \ \<longleftrightarrow>
   ((\<forall>pk. lossless_spmf (fst \ pk)) \<and>
        (\<forall>commit \<sigma>. lossless_spmf (snd \ commit \<sigma>)))"

text\<open>The correct game runs the three algorithms that make up commitment schemes and outputs the output
of the verification algorithm.\<close>

definition correct_game :: "'plain \<Rightarrow> bool spmf"
  where "correct_game m = do {
  (ck, vk) \<leftarrow> key_gen;
  (c,d) \<leftarrow> commit ck m;
  return_spmf (verify vk m c d)}"

lemma   "\<lbrakk> lossless_spmf key_gen; lossless_spmf TI;
          \<And>pk m. valid_msg m \<Longrightarrow> lossless_spmf (commit pk m) \<rbrakk>
              \<Longrightarrow> valid_msg m \<Longrightarrow> lossless_spmf (correct_game m)"
  by(simp add: lossless_def correct_game_def split_def Let_def)

definition correct where "correct \<equiv> (\<forall>m. valid_msg m \<longrightarrow> spmf (correct_game m) True = 1)"

text\<open>The hiding property is defined using the hiding game. Here the adversary is asked to output two
messages, the challenger flips a coin to decide which message to commit and hand to the adversary.
The adversary's challenge is to guess which commitment it was handed. Note we must check the two
messages outputted by the adversary are valid.\<close>

primrec hiding_game_ind_cpa :: "('vk, 'plain, 'commit, 'state) hid_adv \<Rightarrow> bool spmf"
  where "hiding_game_ind_cpa (\1, \2) = TRY do {
  (ck, vk) \<leftarrow> key_gen;
  ((m0, m1), \<sigma>) \<leftarrow> \1 vk;
  _ :: unit \<leftarrow> assert_spmf (valid_msg m0 \<and> valid_msg m1);
  b \<leftarrow> coin_spmf;
  (c,d) \<leftarrow> commit ck (if b then m0 else m1);
  b' :: bool \<leftarrow> \2 c \<sigma>;
  return_spmf (b' = b)} ELSE coin_spmf"

text\<open>The adversary wins the game if \<open>b = b'\<close>.\<close>

lemma lossless_hiding_game:
  "\<lbrakk> lossless \; lossless_spmf key_gen;
     \<And>pk plain. valid_msg plain \<Longrightarrow> lossless_spmf (commit pk plain) \<rbrakk>
  \<Longrightarrow> lossless_spmf (hiding_game_ind_cpa \)"
  by(auto simp add: lossless_def hiding_game_ind_cpa_def split_def Let_def)

text\<open>To define security we consider the advantage an adversary has of winning the game over a tossing
a coin to determine their output.\<close>

definition hiding_advantage_ind_cpa :: "('vk, 'plain, 'commit, 'state) hid_adv \<Rightarrow> real"
  where "hiding_advantage_ind_cpa \ \<equiv> \<bar>spmf (hiding_game_ind_cpa \) True - 1/2\<bar>"

definition perfect_hiding_ind_cpa :: "('vk, 'plain, 'commit, 'state) hid_adv \<Rightarrow> bool"
  where "perfect_hiding_ind_cpa \ \<equiv> (hiding_advantage_ind_cpa \ = 0)"

  text\<open>The binding game challenges an adversary to bind two messages to the same committed value. Both
opening values and messages are verified with respect to the same committed value, the adversary wins
if the game outputs true. We must check some conditions of the adversaries output are met;
we will always require that \<open>m \<noteq> m'\<close>, other conditions will be dependent on the protocol for example
we may require group or field membership.\<close>

definition bind_game :: "('ck, 'plain, 'commit, 'opening) bind_adversary \<Rightarrow> bool spmf"
  where "bind_game \ = TRY do {
  (ck, vk) \<leftarrow> key_gen;
  (c, m, d, m', d') \<leftarrow> \ ck;
  _ :: unit \<leftarrow> assert_spmf (m \<noteq> m' \<and> valid_msg m \<and> valid_msg m');
  let b = verify vk m c d;
  let b' = verify vk m' c d';
  return_spmf (b \<and> b')} ELSE return_spmf False"

text\<open>We proof the binding game is equivalent to the following game which is easier to work with. In particular
we assert b and b' in the game and return True.\<close>

lemma bind_game_alt_def:
  "bind_game \ = TRY do {
  (ck, vk) \<leftarrow> key_gen;
  (c, m, d, m', d') \<leftarrow> \ ck;
  _ :: unit \<leftarrow> assert_spmf (m \<noteq> m' \<and> valid_msg m \<and> valid_msg m');
  let b = verify vk m c d;
  let b' = verify vk m' c d';
  _ :: unit \<leftarrow> assert_spmf (b \<and> b');
  return_spmf True} ELSE return_spmf False"
  (is "?lhs = ?rhs")
proof -
  have "?lhs = TRY do {
      (ck, vk) \<leftarrow> key_gen;
      TRY do {
        (c, m, d, m', d') \<leftarrow> \ ck;
        TRY do {
          _ :: unit \<leftarrow> assert_spmf (m \<noteq> m' \<and> valid_msg m \<and> valid_msg m');
          TRY return_spmf (verify vk m c d \<and> verify vk m' c d') ELSE return_spmf False
        } ELSE return_spmf False
      } ELSE return_spmf False
    } ELSE return_spmf False"
    unfolding split_def bind_game_def
    by(fold try_bind_spmf_lossless2[OF lossless_return_spmf]) simp
  also have "\<dots> = TRY do {
      (ck, vk) \<leftarrow> key_gen;
      TRY do {
        (c, m, d, m', d') \<leftarrow> \ ck;
        TRY do {
          _ :: unit \<leftarrow> assert_spmf (m \<noteq> m' \<and> valid_msg m \<and> valid_msg m');
          TRY do {
            _ :: unit \<leftarrow> assert_spmf (verify vk m c d \<and> verify vk m' c d');
            return_spmf True
          } ELSE return_spmf False
        } ELSE return_spmf False
      } ELSE return_spmf False
    } ELSE return_spmf False"
    by(auto simp add: try_bind_assert_spmf try_spmf_return_spmf1 intro!: try_spmf_cong bind_spmf_cong)
  also have "\<dots> = ?rhs"
    unfolding split_def Let_def
    by(fold try_bind_spmf_lossless2[OF lossless_return_spmf]) simp
  finally show ?thesis .
qed

lemma lossless_binding_game: "lossless_spmf (bind_game \)"
  by (simp add: bind_game_def)

definition bind_advantage :: "('ck, 'plain, 'commit, 'opening) bind_adversary \<Rightarrow> real"
  where "bind_advantage \ \<equiv> spmf (bind_game \) True"

end

end


(*
  File:     Algebraic_Auxiliaries.thy
  Authors:  Daniel Stüwe

  Miscellaneous facts about algebra and number theory
*)
section \<open>Auxiliary Material\<close>
theory Algebraic_Auxiliaries
  imports
    "HOL-Algebra.Algebra"
    "HOL-Computational_Algebra.Squarefree"
    "HOL-Number_Theory.Number_Theory"
begin

hide_const (open) Divisibility.prime

lemma sum_of_bool_eq_card:
  assumes "finite S"
  shows "(\<Sum>a \<in> S. of_bool (P a)) = real (card {a \<in> S . P a })"
proof -
  have "(\<Sum>a \<in> S. of_bool (P a) :: real) = (\<Sum>a \<in> {x\<in>S. P x}. 1)"
    using assms by (intro sum.mono_neutral_cong_right) auto
  thus ?thesis by simp
qed

lemma mod_natE:
  fixes a n b :: nat
  assumes "a mod n = b"
  shows "\<exists> l. a = n * l + b"
  using assms mod_mult_div_eq[of a n] by (metis add.commute)

lemma (in group) r_coset_is_image: "H #> a = (\<lambda> x. x \<otimes> a) ` H"
  unfolding r_coset_def image_def
  by blast

lemma (in group) FactGroup_order:
  assumes "subgroup H G" "finite H"
  shows "order G = order (G Mod H) * card H"
using lagrange assms unfolding FactGroup_def order_def by simp

corollary (in group) FactGroup_order_div:
  assumes "subgroup H G" "finite H"
  shows "order (G Mod H) = order G div card H"
using assms FactGroup_order subgroupE(2)[OF \<open>subgroup H G\<close>] by (auto simp: order_def)

lemma group_hom_imp_group_hom_image:
  assumes "group_hom G G h"
  shows "group_hom G (G\<lparr>carrier := h  ` carrier G\<rparr>) h"
  using group_hom.axioms[OF assms] group_hom.img_is_subgroup[OF assms] group.subgroup_imp_group
  by(auto intro!: group_hom.intro simp: group_hom_axioms_def hom_def)

theorem homomorphism_thm:
  assumes "group_hom G G h"
  shows "G Mod kernel G (G\<lparr>carrier := h ` carrier G\<rparr>) h \<cong> G \<lparr>carrier := h ` carrier G\<rparr>"
  by (intro group_hom.FactGroup_iso group_hom_imp_group_hom_image assms) simp

lemma is_iso_imp_same_card:
  assumes "H \<cong> G "
  shows "order H = order G"
proof -
  from assms obtain h where "bij_betw h (carrier H) (carrier G)"
    unfolding is_iso_def iso_def
    by blast

  then show ?thesis
    unfolding order_def
    by (rule bij_betw_same_card)
qed

corollary homomorphism_thm_order:
  assumes "group_hom G G h"
  shows "order (G\<lparr>carrier := h ` carrier G\<rparr>) * card (kernel G (G\<lparr>carrier := h ` carrier G\<rparr>) h) = order G "
proof -
  have "order (G\<lparr>carrier := h ` carrier G\<rparr>) = order (G Mod (kernel G (G\<lparr>carrier := h ` carrier G\<rparr>) h))"
    using is_iso_imp_same_card[OF homomorphism_thm] \<open>group_hom G G h\<close>
    by fastforce

  moreover have "group G" using \<open>group_hom G G h\<close> group_hom.axioms by blast

  ultimately show ?thesis
    using \<open>group_hom G G h\<close> and group_hom_imp_group_hom_image[OF \<open>group_hom G G h\<close>]
    unfolding FactGroup_def
    by (simp add: group.lagrange group_hom.subgroup_kernel order_def)
qed

lemma (in group_hom) kernel_subset: "kernel G H h \<subseteq> carrier G"
  using subgroup_kernel G.subgroupE(1) by blast

lemma (in group) proper_subgroup_imp_bound_on_card:
  assumes "H \<subset> carrier G" "subgroup H G" "finite (carrier G)"
  shows "card H \<le> order G div 2"
proof -
  from \<open>finite (carrier G)\<close> have "finite (rcosets H)"
    by (simp add: RCOSETS_def)

  note subgroup.subgroup_in_rcosets[OF \<open>subgroup H G\<close> is_group]
  then obtain J where "J \<noteq> H" "J \<in> rcosets H"
    using rcosets_part_G[OF \<open>subgroup H G\<close>] and \<open>H \<subset> carrier G\<close>
    by (metis Sup_le_iff inf.absorb_iff2 inf.idem inf.strict_order_iff)

  then have "2 \<le> card (rcosets H)"
    using \<open>H \<in> rcosets H\<close> card_mono[OF \<open>finite (rcosets H)\<close>, of "{H, J}"]
    by simp

  then show ?thesis
    using mult_le_mono[of 2 "card (rcosets H)" "card H" "card H"]
    unfolding lagrange[OF \<open>subgroup H G\<close>]
    by force
qed

lemma cong_exp_trans[trans]:
  "[a ^ b = c] (mod n) \<Longrightarrow> [a = d] (mod n) \<Longrightarrow> [d ^ b = c] (mod n)"
  "[c = a ^ b] (mod n) \<Longrightarrow> [a = d] (mod n) \<Longrightarrow> [c = d ^ b] (mod n)"
  using cong_pow cong_sym cong_trans by blast+

lemma cong_exp_mod[simp]:
  "[(a mod n) ^ b = c] (mod n) \<longleftrightarrow> [a ^ b = c] (mod n)"
  "[c = (a mod n) ^ b] (mod n) \<longleftrightarrow> [c = a ^ b] (mod n)"
  by (auto simp add: cong_def mod_simps)

lemma cong_mult_mod[simp]:
  "[(a mod n) * b = c] (mod n) \<longleftrightarrow> [a * b = c] (mod n)"
  "[a * (b mod n) = c] (mod n) \<longleftrightarrow> [a * b = c] (mod n)"
  by (auto simp add: cong_def mod_simps)

lemma cong_add_trans[trans]:
  "[a = b + x] (mod n) \<Longrightarrow> [x = y] (mod n) \<Longrightarrow> [a = b + y] (mod n)"
  "[a = x + b] (mod n) \<Longrightarrow> [x = y] (mod n) \<Longrightarrow> [a = y + b] (mod n)"
  "[b + x = a] (mod n) \<Longrightarrow> [x = y] (mod n) \<Longrightarrow> [b + y = a] (mod n)"
  "[x + b = a] (mod n) \<Longrightarrow> [x = y] (mod n) \<Longrightarrow> [y + b = a] (mod n)"
  unfolding cong_def
  using mod_simps(1, 2)
  by metis+

lemma cong_mult_trans[trans]:
  "[a = b * x] (mod n) \<Longrightarrow> [x = y] (mod n) \<Longrightarrow> [a = b * y] (mod n)"
  "[a = x * b] (mod n) \<Longrightarrow> [x = y] (mod n) \<Longrightarrow> [a = y * b] (mod n)"
  "[b * x = a] (mod n) \<Longrightarrow> [x = y] (mod n) \<Longrightarrow> [b * y = a] (mod n)"
  "[x * b = a] (mod n) \<Longrightarrow> [x = y] (mod n) \<Longrightarrow> [y * b = a] (mod n)"
  unfolding cong_def
  using mod_simps(4, 5)
  by metis+

lemma cong_diff_trans[trans]:
  "[a = b - x] (mod n) \<Longrightarrow> [x = y] (mod n) \<Longrightarrow> [a = b - y] (mod n)"
  "[a = x - b] (mod n) \<Longrightarrow> [x = y] (mod n) \<Longrightarrow> [a = y - b] (mod n)"
  "[b - x = a] (mod n) \<Longrightarrow> [x = y] (mod n) \<Longrightarrow> [b - y = a] (mod n)"
  "[x - b = a] (mod n) \<Longrightarrow> [x = y] (mod n) \<Longrightarrow> [y - b = a] (mod n)"
  for a :: "'a :: {unique_euclidean_semiring, euclidean_ring_cancel}"
  unfolding cong_def
  by (metis mod_diff_eq)+

lemma eq_imp_eq_mod_int: "a = b \<Longrightarrow> [a = b] (mod m)" for a b :: int by simp
lemma eq_imp_eq_mod_nat: "a = b \<Longrightarrow> [a = b] (mod m)" for a b :: nat by simp

lemma cong_pow_I: "a = b \<Longrightarrow> [x^a = x^b](mod n)" by simp

lemma gre1I: "(n = 0 \<Longrightarrow> False) \<Longrightarrow> (1 :: nat) \<le> n"
  by presburger

lemma gre1I_nat: "(n = 0 \<Longrightarrow> False) \<Longrightarrow> (Suc 0 :: nat) \<le> n"
  by presburger

lemma power2_diff_nat: "x \<ge> y \<Longrightarrow> (x - y)\<^sup>2 = x\<^sup>2 + y\<^sup>2 - 2 * x * y" for x y :: nat
  by (simp add: algebra_simps power2_eq_square mult_2_right)
     (meson Nat.diff_diff_right le_add2 le_trans mult_le_mono order_refl)

lemma square_inequality: "1 < n \<Longrightarrow> (n + n) \<le> (n * n)" for n :: nat
  by (metis Suc_eq_plus1_left Suc_leI mult_le_mono1 semiring_normalization_rules(4))

lemma square_one_cong_one:
  assumes "[x = 1](mod n)"
  shows "[x^2 = 1](mod n)"
  using assms cong_pow by fastforce

lemma cong_square_alt_int:
  "prime p \<Longrightarrow> [a * a = 1] (mod p) \<Longrightarrow> [a = 1] (mod p) \<or> [a = p - 1] (mod p)"
  for a p :: "'a :: {normalization_semidom, linordered_idom, unique_euclidean_ring}"
  using dvd_add_triv_right_iff[of p "a - (p - 1)"]
  by (auto simp add: cong_iff_dvd_diff square_diff_one_factored dest!: prime_dvd_multD)

lemma cong_square_alt:
  "prime p \<Longrightarrow> [a * a = 1] (mod p) \<Longrightarrow> [a = 1] (mod p) \<or> [a = p - 1] (mod p)"
  for a p :: nat
  using cong_square_alt_int and cong_int_iff prime_nat_int_transfer
  by (metis (mono_tags) int_ops(2) int_ops(7) less_imp_le_nat of_nat_diff prime_gt_1_nat)

lemma square_minus_one_cong_one:
  fixes n x :: nat
  assumes "1 < n" "[x = n - 1](mod n)"
  shows "[x^2 = 1](mod n)"
proof -
  have "[x^2 = (n - 1) * (n - 1)] (mod n)"
    using cong_mult[OF assms(2) assms(2)]
    by (simp add: algebra_simps power2_eq_square)

  also have "[(n - 1) * (n - 1) = Suc (n * n) - (n + n)] (mod n)"
    using power2_diff_nat[of 1 n] \<open>1 < n\<close>
    by (simp add: algebra_simps power2_eq_square)

  also have "[Suc (n * n) - (n + n) = Suc (n * n)] (mod n)"
  proof -
    have "n * n + 0 * n = n * n" by linarith
    moreover have "n * n - (n + n) + (n + n) = n * n"
      using square_inequality[OF \<open>1 < n\<close>] le_add_diff_inverse2 by blast
    moreover have "(Suc 0 + 1) * n = n + n"
      by simp
    ultimately show ?thesis
      using square_inequality[OF \<open>1 < n\<close>]
      by (metis (no_types) Suc_diff_le add_Suc cong_iff_lin_nat)
  qed

  also have "[Suc (n * n) = 1] (mod n)"
    using cong_to_1'_nat by auto

  finally show ?thesis .
qed

lemma odd_prime_gt_2_int:
 "2 < p" if "odd p" "prime p" for p :: int
  using prime_ge_2_int[OF \<open>prime p\<close>] \<open>odd p\<close>
  by (cases "p = 2") auto

lemma odd_prime_gt_2_nat:
 "2 < p" if "odd p" "prime p" for p :: nat
  using prime_ge_2_nat[OF \<open>prime p\<close>] \<open>odd p\<close>
  by (cases "p = 2") auto

lemma gt_one_imp_gt_one_power_if_coprime:
  "1 \<le> x \<Longrightarrow> 1 < n \<Longrightarrow> coprime x n \<Longrightarrow> 1 \<le> x ^ (n - 1) mod n"
  by (rule gre1I) (auto simp: coprime_commute dest: coprime_absorb_left)

lemma residue_one_dvd: "a mod n = 1 \<Longrightarrow> n dvd a - 1" for a n :: nat
  by (fastforce intro!: cong_to_1_nat simp: cong_def)

lemma coprimeI_power_mod:
  fixes x r n :: nat
  assumes "x ^ r mod n = 1" "r \<noteq> 0" "n \<noteq> 0"
  shows "coprime x n"
proof -
  have "coprime (x ^ r mod n) n"
    using coprime_1_right \<open>x ^ r mod n = 1\<close>
    by (simp add: coprime_commute)
  thus ?thesis using \<open>r \<noteq> 0\<close> \<open>n \<noteq> 0\<close> by simp
qed

(* MOVE - EXTRA *)
lemma prime_dvd_choose:
  assumes "0 < k" "k < p" "prime p"
  shows "p dvd (p choose k)"
proof -
  have "k \<le> p" using \<open>k < p\<close> by auto

  have "p dvd fact p" using \<open>prime p\<close> by (simp add: prime_dvd_fact_iff)

  moreover have "\<not> p dvd fact k * fact (p - k)"
    unfolding prime_dvd_mult_iff[OF \<open>prime p\<close>] prime_dvd_fact_iff[OF \<open>prime p\<close>]
    using assms by simp

  ultimately show ?thesis
    unfolding binomial_fact_lemma[OF \<open>k \<le> p\<close>, symmetric]
    using assms prime_dvd_multD by blast
qed

lemma cong_eq_0_I: "(\<forall>i\<in>A. [f i mod n = 0] (mod n)) \<Longrightarrow> [\<Sum>i\<in>A. f i = 0] (mod n)"
  using cong_sum by fastforce

lemma power_mult_cong:
  assumes "[x^n = a](mod m)" "[y^n = b](mod m)"
  shows "[(x*y)^n = a*b](mod m)"
  using assms cong_mult[of "x^n" a m "y^n" b] power_mult_distrib
  by metis

lemma
  fixes n :: nat
  assumes "n > 1"
  shows odd_pow_cong: "odd m \<Longrightarrow> [(n - 1) ^ m = n - 1] (mod n)"
  and even_pow_cong: "even m \<Longrightarrow> [(n - 1) ^ m = 1] (mod n)"
proof (induction m)
  case (Suc m)
  case 1
  with Suc have IH: "[(n - 1) ^ m = 1] (mod n)" by auto
  show ?case using \<open>1 < n\<close> cong_mult[OF cong_refl IH] by simp
next
  case (Suc m)
  case 2
  with Suc have IH: "[(n - 1) ^ m = n - 1] (mod n)" by auto
  show ?case
    using cong_mult[OF cong_refl IH, of "(n - 1)"] and square_minus_one_cong_one[OF \<open>1 < n\<close>, of "n - 1"]
    by (auto simp: power2_eq_square intro: cong_trans)
qed simp_all

lemma cong_mult_uneq':
  fixes a :: "'a::{unique_euclidean_ring, ring_gcd}"
  assumes "coprime d a"
  shows "[b \<noteq> c] (mod a) \<Longrightarrow> [d = e] (mod a) \<Longrightarrow> [b * d \<noteq> c * e] (mod a)"
  using cong_mult_rcancel[OF assms]
  using cong_trans[of "b*d" "c*e" a "c*d"]
  using cong_scalar_left cong_sym by blast

lemma p_coprime_right_nat: "prime p \<Longrightarrow> coprime a p = (\<not> p dvd a)" for p a :: nat
  by (meson coprime_absorb_left coprime_commute not_prime_unit prime_imp_coprime_nat)

lemma squarefree_mult_imp_coprime:
  assumes "squarefree (a * b :: 'a :: semiring_gcd)"
  shows   "coprime a b"
proof (rule coprimeI)
  fix l assume "l dvd a" "l dvd b"
  then obtain a' b' where "a = l * a'" "b = l * b'"
    by (auto elim!: dvdE)
  with assms have "squarefree (l\<^sup>2 * (a' * b'))"
    by (simp add: power2_eq_square mult_ac)
  thus "l dvd 1" by (rule squarefreeD) auto
qed

lemma prime_divisor_exists_strong:
  fixes m :: int
  assumes "m > 1" "\<not>prime m"
  shows   "\<exists>n k. m = n * k \<and> 1 < n \<and> n < m \<and> 1 < k \<and> k < m"
proof -
  from assms obtain n k where nk: "n * k > 1" "n \<ge> 0" "m = n * k" "n \<noteq> 1" "n \<noteq> 0" "k \<noteq> 1"
    using assms unfolding prime_int_iff dvd_def by auto
  from nk have "n > 1" by linarith

  from nk assms have "n * k > 0" by simp
  with \<open>n \<ge> 0\<close> have "k > 0"
    using zero_less_mult_pos by force
  with \<open>k \<noteq> 1\<close> have "k > 1" by linarith
  from nk have "n > 1" by linarith

  from \<open>k > 1\<close> nk have "n < m" "k < m" by simp_all
  with nk \<open>k > 1\<close> \<open>n > 1\<close> show ?thesis by blast
qed

lemma prime_divisor_exists_strong_nat:
  fixes m :: nat
  assumes "1 < m" "\<not>prime m"
  shows   "\<exists>p k. m = p * k \<and> 1 < p \<and> p < m \<and> 1 < k \<and> k < m \<and> prime p"
proof -
  obtain p where p_def: "prime p" "p dvd m" "p \<noteq> m" "1 < p"
    using assms prime_prime_factor and prime_gt_1_nat
    by blast

  moreover define k where "k = m div p"
  with \<open>p dvd m\<close> have "m = p * k" by simp

  moreover have "p < m"
    using \<open>p \<noteq> m\<close> dvd_imp_le[OF \<open>p dvd m\<close>] and \<open>m > 1\<close>
    by simp

  moreover have "1 < k" "k < m"
    using \<open>1 < m\<close> \<open>1 < p\<close> and \<open>p \<noteq> m\<close>
    unfolding \<open>m = p * k\<close>
    by (force intro: Suc_lessI Nat.gr0I)+

  ultimately show ?thesis using \<open>1 < m\<close> by blast
qed

(* TODO Remove *)
lemma prime_factorization_eqI:
  assumes "\<And>p. p \<in># P \<Longrightarrow> prime p" "prod_mset P = n"
  shows   "prime_factorization n = P"
  using prime_factorization_prod_mset_primes[of P] assms by simp

lemma prime_factorization_prime_elem:
  assumes "prime_elem p"
  shows   "prime_factorization p = {#normalize p#}"
proof -
  have "prime_factorization p = prime_factorization (normalize p)"
    by (metis normalize_idem prime_factorization_cong)
  also have "\<dots> = {#normalize p#}"
    by (rule prime_factorization_prime) (use assms in auto)
  finally show ?thesis .
qed

lemma size_prime_factorization_eq_Suc_0_iff [simp]:
  fixes n :: "'a :: factorial_semiring_multiplicative"
  shows "size (prime_factorization n) = Suc 0 \<longleftrightarrow> prime_elem n"
proof
  assume size: "size (prime_factorization n) = Suc 0"
  hence [simp]: "n \<noteq> 0" by auto
  from size obtain p where *: "prime_factorization n = {#p#}"
    by (auto elim!: size_mset_SucE)
  hence p: "p \<in> prime_factors n" by auto

  have "prime_elem (normalize p)"
    using p by (auto simp: in_prime_factors_iff)
  also have "p = prod_mset (prime_factorization n)"
    using * by simp
  also have "normalize \<dots> = normalize n"
    by (rule prod_mset_prime_factorization_weak) auto
  finally show "prime_elem n" by simp
qed (auto simp: prime_factorization_prime_elem)
(* END TODO *)

(* TODO Move *)
lemma squarefree_prime_elem [simp, intro]:
  fixes p :: "'a :: algebraic_semidom"
  assumes "prime_elem p"
  shows   "squarefree p"
proof (rule squarefreeI)
  fix x assume "x\<^sup>2 dvd p"
  show "is_unit x"
  proof (rule ccontr)
    assume "\<not>is_unit x"
    hence "\<not>is_unit (x\<^sup>2)"
      by (simp add: is_unit_power_iff)
    from assms and this and \<open>x\<^sup>2 dvd p\<close> have "prime_elem (x\<^sup>2)"
      by (rule prime_elem_mono)
    thus False by (simp add: prime_elem_power_iff)
  qed
qed

lemma not_squarefree_primepow:
  assumes "primepow n"
  shows   "squarefree n \<longleftrightarrow> prime n"
  using assms by (auto simp: primepow_def squarefree_power_iff prime_power_iff)

lemma prime_factorization_normalize [simp]:
  "prime_factorization (normalize n) = prime_factorization n"
  by (rule prime_factorization_cong) auto

lemma one_prime_factor_iff_primepow:
  fixes n :: "'a :: factorial_semiring_multiplicative"
  shows "card (prime_factors n) = Suc 0 \<longleftrightarrow> primepow (normalize n)"
proof
  assume "primepow (normalize n)"
  then obtain p k where pk: "prime p" "normalize n = p ^ k" "k > 0"
    by (auto simp: primepow_def)
  hence "card (prime_factors (normalize n)) = Suc 0"
    by (subst pk) (simp add: prime_factors_power prime_factorization_prime)
  thus "card (prime_factors n) = Suc 0"
    by simp
next
  assume *: "card (prime_factors n) = Suc 0"
  from * have "(\<Prod>p\<in>prime_factors n. p ^ multiplicity p n) = normalize n"
    by (intro prod_prime_factors) auto
  also from * have "card (prime_factors n) = 1" by simp
  then obtain p where p: "prime_factors n = {p}"
    by (elim card_1_singletonE)
  finally have "normalize n = p ^ multiplicity p n"
    by simp
  moreover from p have "prime p" "multiplicity p n > 0"
    by (auto simp: prime_factors_multiplicity)
  ultimately show "primepow (normalize n)"
    unfolding primepow_def by blast
qed

lemma squarefree_imp_prod_prime_factors_eq:
  fixes x :: "'a :: factorial_semiring_multiplicative"
  assumes "squarefree x"
  shows   "\<Prod>(prime_factors x) = normalize x"
proof -
  from assms have [simp]: "x \<noteq> 0" by auto
  have "(\<Prod>p\<in>prime_factors x. p ^ multiplicity p x) = normalize x"
    by (intro prod_prime_factors) auto
  also have "(\<Prod>p\<in>prime_factors x. p ^ multiplicity p x) = (\<Prod>p\<in>prime_factors x. p)"
    using assms by (intro prod.cong refl) (auto simp: squarefree_factorial_semiring')
  finally show ?thesis by simp
qed
(* END TODO *)

end


(*  Title:       Jive Data and Store Model
    Author:      Norbert Schirmer <schirmer at informatik.tu-muenchen.de>, 2003
    Maintainer:  Nicole Rauch <rauch at informatik.uni-kl.de>
    License:     LGPL
*)

header {* Widening the Direct Subtype Relation *}

theory Subtype
imports "../Isa_Counter/DirectSubtypes"
begin

text {*
In this theory, we define the widening subtype relation of types and prove
that it is a partial order.
*}

subsection {* Auxiliary lemmas *}

text {* These general lemmas are not especially related to Jive.
They capture
some useful properties of general relations.
*}
lemma distinct_rtrancl_into_trancl:
  assumes neq_x_y: "x\<noteq>y"
  assumes x_y_rtrancl: "(x,y) \<in> r\<^sup>*"
  shows "(x,y) \<in> r\<^sup>+"
  using x_y_rtrancl neq_x_y
proof (induct)
  assume "x\<noteq>x" thus "(x, x) \<in> r\<^sup>+" by simp
next
  fix y z
  assume x_y_rtrancl: "(x, y) \<in> r\<^sup>*"
  assume y_z_r: "(y, z) \<in> r"
  assume "x \<noteq> y \<Longrightarrow> (x, y) \<in> r\<^sup>+"
  assume "x \<noteq> z"
  from x_y_rtrancl
  show "(x, z) \<in> r\<^sup>+"
  proof (cases)
    assume "x=y"
    with y_z_r have "(x,z) \<in> r" by simp
    thus "(x,z) \<in>  r\<^sup>+"..
  next
    fix w
    assume "(x, w) \<in> r\<^sup>*"
    moreover assume "(w, y) \<in> r"
    ultimately have "(x,y) \<in> r\<^sup>+"
      by (rule rtrancl_into_trancl1)
    from this y_z_r
    show "(x, z) \<in> r\<^sup>+"..
  qed
qed

lemma acyclic_imp_antisym_rtrancl: "acyclic r \<Longrightarrow> antisym (r\<^sup>*)"
proof (clarsimp simp only: acyclic_def antisym_def)
  fix x y
  assume acyclic: "\<forall>x. (x, x) \<notin> r\<^sup>+"
  assume x_y: "(x, y) \<in> r\<^sup>*"
  assume y_x: "(y, x) \<in> r\<^sup>*"
  show "x=y"
  proof (cases "x=y")
    case True thus ?thesis .
  next
    case False
    from False x_y have "(x, y) \<in> r\<^sup>+"
      by (rule distinct_rtrancl_into_trancl)
    also
    from False y_x have "(y, x) \<in> r\<^sup>+"
      by (fastforce intro: distinct_rtrancl_into_trancl)
    finally have "(x,x) \<in> r\<^sup>+".
    with acyclic show ?thesis by simp
  qed
qed

lemma acyclic_trancl_rtrancl:
  assumes acyclic: "acyclic r"
  shows "(x,y) \<in> r\<^sup>+ = ((x,y) \<in> r\<^sup>* \<and> x\<noteq>y)"
proof
  assume x_y_trancl: "(x,y) \<in> r\<^sup>+"
  show "(x,y) \<in> r\<^sup>* \<and> x\<noteq>y"
  proof
    from x_y_trancl show "(x,y) \<in> r\<^sup>*"..
  next
    from x_y_trancl acyclic show "x\<noteq>y" by (auto simp add: acyclic_def)
  qed
next
  assume "(x,y) \<in> r\<^sup>* \<and> x\<noteq>y"
  thus "(x,y) \<in> r\<^sup>+"
    by (auto intro: distinct_rtrancl_into_trancl)
qed

subsection {* The Widening (Subtype) Relation of Javatypes *}

text {* \label{widening_subtypes}
In this section we widen the direct subtype relations specified in Sec.
\ref{direct_subtype_relations}.
It is done by a calculation of the transitive closure of the
direct subtype relation.
*}

text {* This is the concrete syntax that expresses the subtype relations
between all types.
\label{subtype_relations_concrete_syntax} *}

abbreviation
  direct_subtype_syntax :: "Javatype \<Rightarrow> Javatype \<Rightarrow> bool" ("_ \<prec>1 _" [71,71] 70)
where -- {* direct subtype relation *}
  "A \<prec>1 B == (A,B) \<in> direct_subtype"

abbreviation
  widen_syntax :: "Javatype \<Rightarrow> Javatype \<Rightarrow> bool" ("_ \<preceq> _" [71,71] 70)
where -- {* reflexive transitive closure of direct subtype relation *}
  "A \<preceq> B == (A,B) \<in> direct_subtype\<^sup>*"

abbreviation
  widen_strict_syntax :: "Javatype \<Rightarrow> Javatype \<Rightarrow> bool" ("_ \<prec> _" [71,71] 70)
where -- {* transitive closure of direct subtype relation *}
  "A \<prec> B == (A,B) \<in> direct_subtype\<^sup>+"

subsection {* The Subtype Relation as Partial Order *}

text {* We prove the axioms required for partial orders, i.e.\
reflexivity, transitivity and antisymmetry, for the widened subtype
relation. The direct subtype relation has been
defined in Sec. \ref{direct_subtype_relations}.
The reflexivity lemma is
added to the Simplifier and to the Classical reasoner (via the
attribute iff), and the transitivity and antisymmetry lemmas
are made known as transitivity rules (via the attribute trans).
This way, these lemmas will be automatically used in subsequent proofs.
*}

lemma acyclic_direct_subtype: "acyclic direct_subtype"
proof (clarsimp simp add: acyclic_def)
  fix x show "x \<prec> x \<Longrightarrow> False"
  by (cases x) (fastforce elim: tranclE simp add: direct_subtype_def)+
     (* takes a very long time to calculate *)
qed

lemma antisym_rtrancl_direct_subtype: "antisym (direct_subtype\<^sup>*)"
using acyclic_direct_subtype by (rule acyclic_imp_antisym_rtrancl)

lemma widen_strict_to_widen: "C \<prec> D = (C \<preceq> D \<and> C\<noteq>D)"
using acyclic_direct_subtype by (rule acyclic_trancl_rtrancl)

text {* The widening relation on Javatype is reflexive. *}

lemma widen_refl [iff]: "X \<preceq> X" ..

text {* The widening relation on Javatype is transitive. *}

lemma widen_trans [trans] :
  assumes a_b: "a \<preceq> b"
  shows "\<And> c. b \<preceq> c \<Longrightarrow> a \<preceq> c"
  by (insert a_b, rule rtrancl_trans)

text {* The widening relation on Javatype is antisymmetric. *}

lemma widen_antisym [trans]:
  assumes a_b: "a \<preceq> b"
  assumes b_c: "b \<preceq> a"
  shows "a = b"
  using a_b b_c antisym_rtrancl_direct_subtype
  by (unfold antisym_def) blast

subsection {* Javatype Ordering Properties *}

text {* The type class @{term ord} allows us to overwrite the two comparison
operators $<$ and $\leq$.
  These are  the two comparison operators on @{typ Javatype} that we want
to use subsequently. *}

text {* We can also prove that @{typ Javatype} is in the type class @{term order}.
For this we
  have to prove reflexivity, transitivity, antisymmetry and that $<$ and $\leq$ are
defined in such
  a way that @{thm Orderings.order_less_le [no_vars]} holds. This proof can easily
be achieved by using the
  lemmas proved above and the definition of @{term less_Javatype_def}.
  *}

instantiation Javatype:: order
begin

definition
  le_Javatype_def:   "A \<le> B \<equiv> A \<preceq> B"

definition
  less_Javatype_def: "A < B \<equiv> A \<le> B \<and> \<not> B \<le> (A::Javatype)"

instance proof
  fix x y z:: "Javatype"
  {
    show "x \<le> x"
      by (simp add: le_Javatype_def )
  next
    assume "x \<le> y" "y \<le> z"
    then show "x \<le> z"
      by (unfold le_Javatype_def) (rule rtrancl_trans)
  next
    assume "x \<le> y" "y \<le> x"
    then show "x = y"
      apply (unfold le_Javatype_def)
      apply (rule widen_antisym)
      apply assumption +
      done
  next
    show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
      by (simp add: less_Javatype_def)
  }
qed

end

subsection {* Enhancing the Simplifier *}

lemmas subtype_defs = le_Javatype_def less_Javatype_def
                      direct_subtype_def
(*
                      direct_subtype
                      direct_subtype[THEN r_into_rtrancl]
*)
lemmas subtype_ok_simps = subtype_defs
lemmas subtype_wrong_elims = rtranclE

text {* During verification we will often have to solve the goal that one type
widens to the other. So we equip the simplifier with a special solver-tactic.
*}

lemmas direct_subtype_widened = direct_subtype[THEN r_into_rtrancl]

ML {*
local val ss = simpset_of @{context} in

fun widen_tac ctxt =
  rtac @{thm widen_asm} THEN'
  simp_tac (put_simpset ss ctxt addsimps @{thms le_Javatype_def}) THEN'
  Method.insert_tac @{thms direct_subtype_widened} THEN'
  simp_tac (put_simpset (simpset_of @{theory_context Transitive_Closure}) ctxt)

end
*}

declaration {* fn _ =>
  Simplifier.map_ss (fn ss => ss addSolver (mk_solver "widen" widen_tac))
*}

text {* In this solver-tactic, we first try the trivial resolution with @{text "widen_asm"} to
check if the actual subgaol really is a request to solve a subtyping problem.
If so, we unfold the comparison operator, insert the direct subtype
relations and call the simplifier.
*}

subsection {* Properties of the Subtype Relation *}

text {* The class @{text "Object"} has to be the root of the class hierarchy,
i.e.~it is supertype of each concrete class, abstract class, interface
and array type.
  The proof scripts should run on every correctly generated type hierarchy.
*}

lemma Object_root: "CClassT C \<le> CClassT Object"
  by (cases C, simp_all)

lemma Object_root_abs: "AClassT C \<le> CClassT Object"
  by (cases C, simp_all)

lemma Object_root_int: "InterfaceT C \<le> CClassT Object"
  by (cases C, simp_all)

lemma Object_root_array: "ArrT C \<le> CClassT Object"
  proof (cases C)
    fix x
    assume c: "C = CClassAT x"
    show "ArrT C \<le> CClassT Object"
      using c by (cases x, simp_all)
  next
    fix x
    assume c: "C = AClassAT x"
    show "ArrT C \<le> CClassT Object"
      using c by (cases x, simp_all)
  next
    fix x
    assume c: "C = InterfaceAT x"
    show "ArrT C \<le> CClassT Object"
      using c by (cases x, simp_all)
  next
    assume c: "C = BoolAT"
    show "ArrT C \<le> CClassT Object"
      using c by simp
  next
    assume c: "C = IntgAT"
    show "ArrT C \<le> CClassT Object"
      using c by simp
  next
    assume c: "C = ShortAT"
    show "ArrT C \<le> CClassT Object"
      using c by simp
  next
    assume c: "C = ByteAT"
    show "ArrT C \<le> CClassT Object"
      using c by simp
qed

text {* If another type is (non-strict) supertype of Object,
then it must be the type Object itself. *}

lemma Object_rootD:
  assumes p: "CClassT Object \<le> c"
  shows "CClassT Object = c"
  using p
  apply (cases c)
  apply (fastforce elim: subtype_wrong_elims simp add: subtype_defs) +
  -- {* In this lemma, we only get contradictory cases except for Object itself. *}
done

text {* The type NullT has to be the leaf of each branch of the class
hierarchy, i.e.~it is subtype of each type. *}

lemma NullT_leaf [simp]: "NullT \<le> CClassT C"
  by (cases C, simp_all)

lemma NullT_leaf_abs [simp]: "NullT \<le> AClassT C"
  by (cases C, simp_all)

lemma NullT_leaf_int [simp]: "NullT \<le> InterfaceT C"
  by (cases C, simp_all)

lemma NullT_leaf_array: "NullT \<le> ArrT C"
  proof (cases C)
    fix x
    assume c: "C = CClassAT x"
    show "NullT \<le> ArrT C"
      using c by (cases x, simp_all)
  next
    fix x
    assume c: "C = AClassAT x"
    show "NullT \<le> ArrT C"
      using c by (cases x, simp_all)
  next
    fix x
    assume c: "C = InterfaceAT x"
    show "NullT \<le> ArrT C"
      using c by (cases x, simp_all)
  next
    assume c: "C = BoolAT"
    show "NullT \<le> ArrT C"
      using c by simp
  next
    assume c: "C = IntgAT"
    show "NullT \<le> ArrT C"
      using c by simp
  next
    assume c: "C = ShortAT"
    show "NullT \<le> ArrT C"
      using c by simp
  next
    assume c: "C = ByteAT"
    show "NullT \<le> ArrT C"
      using c by simp
qed

end


(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Missing Permutations\<close>

text \<open>This theory provides some definitions and lemmas on permutations which we did not find in the
  Isabelle distribution.\<close>

theory Missing_Permutations
imports
  Missing_Ring
  "HOL-Library.Permutations"
begin

definition signof :: "(nat \<Rightarrow> nat) \<Rightarrow> 'a :: ring_1" where
  "signof p = (if sign p = 1 then 1 else - 1)"

lemma signof_id[simp]: "signof id = 1" "signof (\<lambda> x. x) = 1"
  unfolding signof_def sign_id id_def[symmetric] by auto

lemma signof_inv: "finite S \<Longrightarrow> p permutes S \<Longrightarrow> signof (Hilbert_Choice.inv p) = signof p"
  unfolding signof_def using sign_inverse permutation_permutes by metis

lemma signof_pm_one: "signof p \<in> {1, - 1}"
  unfolding signof_def by auto

lemma signof_compose: assumes "p permutes {0..<(n :: nat)}"
  and "q permutes {0 ..<(m :: nat)}"
  shows "signof (p o q) = signof p * signof q"
proof -
  from assms have pp: "permutation p" "permutation q"
    by (auto simp: permutation_permutes)
  show "signof (p o q) = signof p * signof q"
    unfolding signof_def sign_compose[OF pp]
    by (auto simp: sign_def split: if_splits)
qed

lemma permutes_funcset: "p permutes A \<Longrightarrow> (p ` A \<rightarrow> B) = (A \<rightarrow> B)"
  by (simp add: permutes_image)

context comm_monoid
begin
lemma finprod_permute:
  assumes p: "p permutes S"
  and f: "f \<in> S \<rightarrow> carrier G"
  shows "finprod G f S = finprod G (f \<circ> p) S"
proof -
  from \<open>p permutes S\<close> have "inj p"
    by (rule permutes_inj)
  then have "inj_on p S"
    by (auto intro: subset_inj_on)
  from finprod_reindex[OF _ this, unfolded permutes_image[OF p], OF f]
  show ?thesis unfolding o_def .
qed

lemma finprod_singleton_set[simp]: assumes "f a \<in> carrier G"
  shows "finprod G f {a} = f a"
proof -
  have "finprod G f {a} = f a \<otimes> finprod G f {}"
    by (rule finprod_insert, insert assms, auto)
  also have "\<dots> = f a" using assms by auto
  finally show ?thesis .
qed
end

lemmas (in semiring) finsum_permute = add.finprod_permute
lemmas (in semiring) finsum_singleton_set = add.finprod_singleton_set

lemma permutes_less[simp]: assumes p: "p permutes {0..<(n :: nat)}"
  shows "i < n \<Longrightarrow> p i < n" "i < n \<Longrightarrow> Hilbert_Choice.inv p i < n"
  "p (Hilbert_Choice.inv p i) = i"
  "Hilbert_Choice.inv p (p i) = i"
proof -
  assume i: "i < n"
  show "p i < n" using permutes_in_image[OF p] i by auto
  let ?inv = "Hilbert_Choice.inv p"
  have "\<And>n. ?inv (p n) = n"
      using permutes_inverses[OF p] by simp
  thus "?inv i < n"
      by (metis (no_types) atLeastLessThan_iff f_inv_into_f inv_into_into le0 permutes_image[OF p] i)
qed (insert permutes_inverses[OF p], auto)

context cring
begin

lemma finsum_permutations_inverse:
  assumes f: "f \<in> {p. p permutes S} \<rightarrow> carrier R"
  shows "finsum R f {p. p permutes S} = finsum R (\<lambda>p. f(Hilbert_Choice.inv p)) {p. p permutes S}"
  (is "?lhs = ?rhs")
proof -
  let ?inv = "Hilbert_Choice.inv"
  let ?S = "{p . p permutes S}"
  have th0: "inj_on ?inv ?S"
  proof (auto simp add: inj_on_def)
    fix q r
    assume q: "q permutes S"
      and r: "r permutes S"
      and qr: "?inv q = ?inv r"
    then have "?inv (?inv q) = ?inv (?inv r)"
      by simp
    with permutes_inv_inv[OF q] permutes_inv_inv[OF r] show "q = r"
      by metis
  qed
  have th1: "?inv ` ?S = ?S"
    using image_inverse_permutations by blast
  have th2: "?rhs = finsum R (f \<circ> ?inv) ?S"
    by (simp add: o_def)
  from finsum_reindex[OF _ th0, of f] show ?thesis unfolding th1 th2 using f .
qed

lemma finsum_permutations_compose_right: assumes q: "q permutes S"
  and *: "f \<in> {p. p permutes S} \<rightarrow> carrier R"
  shows "finsum R f {p. p permutes S} = finsum R (\<lambda>p. f(p \<circ> q)) {p. p permutes S}"
  (is "?lhs = ?rhs")
proof -
  let ?S = "{p. p permutes S}"
  let ?inv = "Hilbert_Choice.inv"
  have th0: "?rhs = finsum R (f \<circ> (\<lambda>p. p \<circ> q)) ?S"
    by (simp add: o_def)
  have th1: "inj_on (\<lambda>p. p \<circ> q) ?S"
  proof (auto simp add: inj_on_def)
    fix p r
    assume "p permutes S"
      and r: "r permutes S"
      and rp: "p \<circ> q = r \<circ> q"
    then have "p \<circ> (q \<circ> ?inv q) = r \<circ> (q \<circ> ?inv q)"
      by (simp add: o_assoc)
    with permutes_surj[OF q, unfolded surj_iff] show "p = r"
      by simp
  qed
  have th3: "(\<lambda>p. p \<circ> q) ` ?S = ?S"
    using image_compose_permutations_right[OF q] by auto
  from finsum_reindex[OF _ th1, of f]
  show ?thesis unfolding th0 th1 th3 using * .
qed

end

text \<open>The following lemma is slightly generalized from Determinants.thy in HMA.\<close>

lemma finite_bounded_functions:
  assumes fS: "finite S"
  shows "finite T \<Longrightarrow> finite {f. (\<forall>i \<in> T. f i \<in> S) \<and> (\<forall>i. i \<notin> T \<longrightarrow> f i = i)}"
proof (induct T rule: finite_induct)
  case empty
  have th: "{f. \<forall>i. f i = i} = {id}"
    by auto
  show ?case
    by (auto simp add: th)
next
  case (insert a T)
  let ?f = "\<lambda>(y,g) i. if i = a then y else g i"
  let ?S = "?f ` (S \<times> {f. (\<forall>i\<in>T. f i \<in> S) \<and> (\<forall>i. i \<notin> T \<longrightarrow> f i = i)})"
  have "?S = {f. (\<forall>i\<in> insert a T. f i \<in> S) \<and> (\<forall>i. i \<notin> insert a T \<longrightarrow> f i = i)}"
    apply (auto simp add: image_iff)
    apply (rule_tac x="x a" in bexI)
    apply (rule_tac x = "\<lambda>i. if i = a then i else x i" in exI)
    apply (insert insert, auto)
    done
  with finite_imageI[OF finite_cartesian_product[OF fS insert.hyps(3)], of ?f]
  show ?case
    by metis
qed

lemma finite_bounded_functions':
  assumes fS: "finite S"
  shows "finite T \<Longrightarrow> finite {f. (\<forall>i \<in> T. f i \<in> S) \<and> (\<forall>i. i \<notin> T \<longrightarrow> f i = j)}"
proof (induct T rule: finite_induct)
  case empty
  have th: "{f. \<forall>i. f i = j} = {(\<lambda> x. j)}"
    by auto
  show ?case
    by (auto simp add: th)
next
  case (insert a T)
  let ?f = "\<lambda>(y,g) i. if i = a then y else g i"
  let ?S = "?f ` (S \<times> {f. (\<forall>i\<in>T. f i \<in> S) \<and> (\<forall>i. i \<notin> T \<longrightarrow> f i = j)})"
  have "?S = {f. (\<forall>i\<in> insert a T. f i \<in> S) \<and> (\<forall>i. i \<notin> insert a T \<longrightarrow> f i = j)}"
    apply (auto simp add: image_iff)
    apply (rule_tac x="x a" in bexI)
    apply (rule_tac x = "\<lambda>i. if i = a then j else x i" in exI)
    apply (insert insert, auto)
    done
  with finite_imageI[OF finite_cartesian_product[OF fS insert.hyps(3)], of ?f]
  show ?case
    by metis
qed

context
  fixes A :: "'a set"
    and B :: "'b set"
    and a_to_b :: "'a \<Rightarrow> 'b"
    and b_to_a :: "'b \<Rightarrow> 'a"
  assumes ab: "\<And> a. a \<in> A \<Longrightarrow> a_to_b a \<in> B"
    and ba: "\<And> b. b \<in> B \<Longrightarrow> b_to_a b \<in> A"
    and ab_ba: "\<And> a. a \<in> A \<Longrightarrow> b_to_a (a_to_b a) = a"
    and ba_ab: "\<And> b. b \<in> B \<Longrightarrow> a_to_b (b_to_a b) = b"
begin

qualified lemma permutes_memb: fixes p :: "'b \<Rightarrow> 'b"
  assumes p: "p permutes B"
  and a: "a \<in> A"
  defines "ip \<equiv> Hilbert_Choice.inv p"
  shows "a \<in> A" "a_to_b a \<in> B" "ip (a_to_b a) \<in> B" "p (a_to_b a) \<in> B"
    "b_to_a (p (a_to_b a)) \<in> A" "b_to_a (ip (a_to_b a)) \<in> A"
proof -
  let ?b = "a_to_b a"
  from p have ip: "ip permutes B" unfolding ip_def by (rule permutes_inv)
  note in_ip = permutes_in_image[OF ip]
  note in_p = permutes_in_image[OF p]
  show a: "a \<in> A" by fact
  show b: "?b \<in> B" by (rule ab[OF a])
  show pb: "p ?b \<in> B" unfolding in_p by (rule b)
  show ipb: "ip ?b \<in> B" unfolding in_ip by (rule b)
  show "b_to_a (p ?b) \<in> A" by (rule ba[OF pb])
  show "b_to_a (ip ?b) \<in> A" by (rule ba[OF ipb])
qed

lemma permutes_bij_main:
  "{p . p permutes A} \<supseteq> (\<lambda> p a. if a \<in> A then b_to_a (p (a_to_b a)) else a) ` {p . p permutes B}"
  (is "?A \<supseteq> ?f ` ?B")
proof
  note d = permutes_def
  let ?g = "\<lambda> q b. if b \<in> B then a_to_b (q (b_to_a b)) else b"
  let ?inv = "Hilbert_Choice.inv"
  fix p
  assume p: "p \<in> ?f ` ?B"
  then obtain q where q: "q permutes B" and p: "p = ?f q" by auto
  let ?iq = "?inv q"
  from q have iq: "?iq permutes B" by (rule permutes_inv)
  note in_iq = permutes_in_image[OF iq]
  note in_q = permutes_in_image[OF q]
  have qiB: "\<And> b. b \<in> B \<Longrightarrow> q (?iq b) = b" using q by (rule permutes_inverses)
  have iqB: "\<And> b. b \<in> B \<Longrightarrow> ?iq (q b) = b" using q by (rule permutes_inverses)
  from q[unfolded d]
  have q1: "\<And> b. b \<notin> B \<Longrightarrow> q b = b"
   and q2: "\<And> b. \<exists>!b'. q b' = b" by auto
  note memb = permutes_memb[OF q]
  show "p \<in> ?A" unfolding p d
  proof (rule, intro conjI impI allI, force)
    fix a
    show "\<exists>!a'. ?f q a' = a"
    proof (cases "a \<in> A")
      case True
      note a = memb[OF True]
      let ?a = "b_to_a (?iq (a_to_b a))"
      show ?thesis
      proof
        show "?f q ?a = a" using a by (simp add: ba_ab qiB ab_ba)
      next
        fix a'
        assume id: "?f q a' = a"
        show "a' = ?a"
        proof (cases "a' \<in> A")
          case False
          thus ?thesis using id a by auto
        next
          case True
          note a' = memb[OF this]
          from id True have "b_to_a (q (a_to_b a')) = a" by simp
          from arg_cong[OF this, of "a_to_b"] a' a
          have "q (a_to_b a') = a_to_b a" by (simp add: ba_ab)
          from arg_cong[OF this, of ?iq]
          have "a_to_b a' = ?iq (a_to_b a)" unfolding iqB[OF a'(2)] .
          from arg_cong[OF this, of b_to_a] show ?thesis unfolding ab_ba[OF True] .
        qed
      qed
    next
      case False note a = this
      show ?thesis
      proof
        show "?f q a = a" using a by simp
      next
        fix a'
        assume id: "?f q a' = a"
        show "a' = a"
        proof (cases "a' \<in> A")
          case False
          with id show ?thesis by simp
        next
          case True
          note a' = memb[OF True]
          with id False show ?thesis by auto
        qed
      qed
    qed
  qed
qed
end

lemma  permutes_bij': assumes ab: "\<And> a. a \<in> A \<Longrightarrow> a_to_b a \<in> B"
    and ba: "\<And> b. b \<in> B \<Longrightarrow> b_to_a b \<in> A"
    and ab_ba: "\<And> a. a \<in> A \<Longrightarrow> b_to_a (a_to_b a) = a"
    and ba_ab: "\<And> b. b \<in> B \<Longrightarrow> a_to_b (b_to_a b) = b"
  shows "{p . p permutes A} = (\<lambda> p a. if a \<in> A then b_to_a (p (a_to_b a)) else a) ` {p . p permutes B}"
  (is "?A = ?f ` ?B")
proof -
  note one_dir = ab ba ab_ba ba_ab
  note other_dir = ba ab ba_ab ab_ba
  let ?g = "(\<lambda> p b. if b \<in> B then a_to_b (p (b_to_a b)) else b)"
  define PA where "PA = ?A"
  define f where "f = ?f"
  define g where "g = ?g"
  {
    fix p
    assume "p \<in> PA"
    hence p: "p permutes A" unfolding PA_def by simp
    from p[unfolded permutes_def] have pnA: "\<And> a. a \<notin> A \<Longrightarrow> p a = a" by auto
    have "?f (?g p) = p"
    proof (rule ext)
      fix a
      show "?f (?g p) a = p a"
      proof (cases "a \<in> A")
        case False
        thus ?thesis by (simp add: pnA)
      next
        case True note a = this
        hence "p a \<in> A" unfolding permutes_in_image[OF p] .
        thus ?thesis using a by (simp add: ab_ba ba_ab ab)
      qed
    qed
    hence "f (g p) = p" unfolding f_def g_def .
  }
  hence "f ` g ` PA = PA" by force
  hence id: "?f ` ?g ` ?A = ?A" unfolding PA_def f_def g_def .
  have "?f ` ?B \<subseteq> ?A" by (rule permutes_bij_main[OF one_dir])
  moreover have "?g ` ?A \<subseteq> ?B" by (rule permutes_bij_main[OF ba ab ba_ab ab_ba])
  hence "?f ` ?g ` ?A \<subseteq> ?f ` ?B" by auto
  hence "?A \<subseteq> ?f ` ?B" unfolding id .
  ultimately show ?thesis by blast
qed

lemma inj_on_nat_permutes: assumes i: "inj_on f (S :: nat set)"
  and fS: "f \<in> S \<rightarrow> S"
  and fin: "finite S"
  and f: "\<And> i. i \<notin> S \<Longrightarrow> f i = i"
  shows "f permutes S"
  unfolding permutes_def
proof (intro conjI allI impI, rule f)
  fix y
  from endo_inj_surj[OF fin _ i] fS have fs: "f ` S = S" by auto
  show "\<exists>!x. f x = y"
  proof (cases "y \<in> S")
    case False
    thus ?thesis by (intro ex1I[of _ y], insert fS f, auto)
  next
    case True
    with fs obtain x where x: "x \<in> S" and fx: "f x = y" by force
    show ?thesis
    proof (rule ex1I, rule fx)
      fix x'
      assume fx': "f x' = y"
      with True f[of x'] have "x' \<in> S" by metis
      from inj_onD[OF i fx[folded fx'] x this]
      show "x' = x" by simp
    qed
  qed
qed

lemma permutes_pair_eq:
  assumes p: "p permutes S"
  shows "{ (p s, s) | s. s \<in> S } = { (s, Hilbert_Choice.inv p s) | s. s \<in> S }"
    (is "?L = ?R")
proof
  show "?L \<subseteq> ?R"
  proof
    fix x assume "x \<in> ?L"
    then obtain s where x: "x = (p s, s)" and s: "s \<in> S" by auto
    note x
    also have "(p s, s) = (p s, Hilbert_Choice.inv p (p s))"
      using permutes_inj[OF p] inv_f_f by auto
    also have "... \<in> ?R" using s permutes_in_image[OF p] by auto
    finally show "x \<in> ?R".
  qed
  show "?R \<subseteq> ?L"
  proof
    fix x assume "x \<in> ?R"
    then obtain s
      where x: "x = (s, Hilbert_Choice.inv p s)" (is "_ = (s, ?ips)")
        and s: "s \<in> S" by auto
    note x
    also have "(s, ?ips) = (p ?ips, ?ips)"
      using inv_f_f[OF permutes_inj[OF permutes_inv[OF p]]]
      using inv_inv_eq[OF permutes_bij[OF p]] by auto
    also have "... \<in> ?L"
      using s permutes_in_image[OF permutes_inv[OF p]] by auto
    finally show "x \<in> ?L".
  qed
qed

lemma inj_on_finite[simp]:
  assumes inj: "inj_on f A" shows "finite (f ` A) = finite A"
proof
  assume fin: "finite (f ` A)"
  show "finite A"
  proof (cases "card (f ` A) = 0")
    case True thus ?thesis using fin by auto
    next case False
      hence "card A > 0" unfolding card_image[OF inj] by auto
      thus ?thesis using card_infinite by force
  qed
qed auto

lemma permutes_prod:
  assumes p: "p permutes S"
  shows "(\<Prod>s\<in>S. f (p s) s) = (\<Prod>s\<in>S. f s (Hilbert_Choice.inv p s))"
    (is "?l = ?r")
proof -
  let ?f = "\<lambda>(x,y). f x y"
  let ?ps = "\<lambda>s. (p s, s)"
  let ?ips = "\<lambda>s. (s, Hilbert_Choice.inv p s)"
  have inj1: "inj_on ?ps S" by (rule inj_onI;auto)
  have inj2: "inj_on ?ips S" by (rule inj_onI;auto)
  have "?l = prod ?f (?ps ` S)"
    using prod.reindex[OF inj1, of ?f] by simp
  also have "?ps ` S = {(p s, s) |s. s \<in> S}" by auto
  also have "... = {(s, Hilbert_Choice.inv p s) | s. s \<in> S}"
    unfolding permutes_pair_eq[OF p] by simp
  also have "... = ?ips ` S" by auto
  also have "prod ?f ... = ?r"
    using prod.reindex[OF inj2, of ?f] by simp
  finally show ?thesis.
qed

lemma permutes_sum:
  assumes p: "p permutes S"
  shows "(\<Sum>s\<in>S. f (p s) s) = (\<Sum>s\<in>S. f s (Hilbert_Choice.inv p s))"
    (is "?l = ?r")
proof -
  let ?f = "\<lambda>(x,y). f x y"
  let ?ps = "\<lambda>s. (p s, s)"
  let ?ips = "\<lambda>s. (s, Hilbert_Choice.inv p s)"
  have inj1: "inj_on ?ps S" by (rule inj_onI;auto)
  have inj2: "inj_on ?ips S" by (rule inj_onI;auto)
  have "?l = sum ?f (?ps ` S)"
    using sum.reindex[OF inj1, of ?f] by simp
  also have "?ps ` S = {(p s, s) |s. s \<in> S}" by auto
  also have "... = {(s, Hilbert_Choice.inv p s) | s. s \<in> S}"
    unfolding permutes_pair_eq[OF p] by simp
  also have "... = ?ips ` S" by auto
  also have "sum ?f ... = ?r"
    using sum.reindex[OF inj2, of ?f] by simp
  finally show ?thesis.
qed

lemma inv_inj_on_permutes: "inj_on Hilbert_Choice.inv { p. p permutes S }"
proof (intro inj_onI, unfold mem_Collect_eq)
  let ?i = "Hilbert_Choice.inv"
  fix p q
  assume p: "p permutes S" and q: "q permutes S" and eq: "?i p = ?i q"
  have "?i (?i p) = ?i (?i q)" using eq by simp
  thus "p = q"
    using inv_inv_eq[OF permutes_bij] p q by metis
qed

lemma permutes_others:
  assumes p: "p permutes S" and x: "x \<notin> S" shows "p x = x"
  using p unfolding permutes_def using x by simp

end