(*  Title:       Candidate Models for Ground Resolution
    Author:      Jasmin Blanchette <j.c.blanchette at vu.nl>, 2014, 2017
    Author:      Dmitriy Traytel <traytel at inf.ethz.ch>, 2014
    Maintainer:  Anders Schlichtkrull <andschl at dtu.dk>
*)

section \<open>Candidate Models for Ground Resolution\<close>

theory Ground_Resolution_Model
  imports Herbrand_Interpretation
begin

text \<open>
The proofs of refutational completeness for the two resolution inference systems presented in
Section 3 (``Standard Resolution'') of Bachmair and Ganzinger's chapter share mostly the same
candidate model construction. The literal selection capability needed for the second system is
ignored by the first one, by taking @{term "\<lambda>_. {}"} as instantiation for the \<open>S\<close>
parameter.
\<close>

locale selection =
  fixes S :: "'a clause \<Rightarrow> 'a clause"
  assumes
    S_selects_subseteq: "S C \<subseteq># C" and
    S_selects_neg_lits: "L \<in># S C \<Longrightarrow> is_neg L"

locale ground_resolution_with_selection = selection S
  for S :: "('a :: wellorder) clause \<Rightarrow> 'a clause"
begin

text \<open>
The following commands corresponds to Definition 3.14, which generalizes Definition 3.1.
\<open>production C\<close> is denoted $\varepsilon_C$ in the chapter; \<open>interp C\<close> is denoted
$I_C$; \<open>Interp C\<close> is denoted $I^C$; and \<open>Interp_N\<close> is denoted $I_N$. The mutually
recursive definition from the chapter is massaged to simplify the termination argument. The
\<open>production_unfold\<close> lemma below gives the intended characterization.
\<close>

context
  fixes N :: "'a clause set"
begin

function production :: "'a clause \<Rightarrow> 'a interp" where
  "production C =
   {A. C \<in> N \<and> C \<noteq> {#} \<and> Max_mset C = Pos A \<and> \<not> (\<Union>D \<in> {D. D < C}. production D) \<Turnstile> C \<and> S C = {#}}"
  by auto
termination by (rule "termination"[OF wf, simplified])

declare production.simps [simp del]

definition interp :: "'a clause \<Rightarrow> 'a interp" where
  "interp C = (\<Union>D \<in> {D. D < C}. production D)"

lemma production_unfold:
  "production C = {A. C \<in> N \<and> C \<noteq> {#} \<and> Max_mset C = Pos A \<and> \<not> interp C \<Turnstile> C \<and> S C = {#}}"
  unfolding interp_def by (rule production.simps)

abbreviation productive :: "'a clause \<Rightarrow> bool" where
  "productive C \<equiv> production C \<noteq> {}"

abbreviation produces :: "'a clause \<Rightarrow> 'a \<Rightarrow> bool" where
  "produces C A \<equiv> production C = {A}"

lemma producesD: "produces C A \<Longrightarrow> C \<in> N \<and> C \<noteq> {#} \<and> Pos A = Max_mset C \<and> \<not> interp C \<Turnstile> C \<and> S C = {#}"
  unfolding production_unfold by auto

definition Interp :: "'a clause \<Rightarrow> 'a interp" where
  "Interp C = interp C \<union> production C"

lemma interp_subseteq_Interp[simp]: "interp C \<subseteq> Interp C"
  by (simp add: Interp_def)

lemma Interp_as_UNION: "Interp C = (\<Union>D \<in> {D. D \<le> C}. production D)"
  unfolding Interp_def interp_def less_eq_multiset_def by fast

lemma productive_not_empty: "productive C \<Longrightarrow> C \<noteq> {#}"
  unfolding production_unfold by simp

lemma productive_imp_produces_Max_literal: "productive C \<Longrightarrow> produces C (atm_of (Max_mset C))"
  unfolding production_unfold by (auto simp del: atm_of_Max_lit)

lemma productive_imp_produces_Max_atom: "productive C \<Longrightarrow> produces C (Max (atms_of C))"
  unfolding atms_of_def Max_atm_of_set_mset_commute[OF productive_not_empty]
  by (rule productive_imp_produces_Max_literal)

lemma produces_imp_Max_literal: "produces C A \<Longrightarrow> A = atm_of (Max_mset C)"
  using productive_imp_produces_Max_literal by auto

lemma produces_imp_Max_atom: "produces C A \<Longrightarrow> A = Max (atms_of C)"
  using producesD produces_imp_Max_literal by auto

lemma produces_imp_Pos_in_lits: "produces C A \<Longrightarrow> Pos A \<in># C"
  by (simp add: producesD)

lemma productive_in_N: "productive C \<Longrightarrow> C \<in> N"
  unfolding production_unfold by simp

lemma produces_imp_atms_leq: "produces C A \<Longrightarrow> B \<in> atms_of C \<Longrightarrow> B \<le> A"
  using Max.coboundedI produces_imp_Max_atom by blast

lemma produces_imp_neg_notin_lits: "produces C A \<Longrightarrow> \<not> Neg A \<in># C"
  by (simp add: pos_Max_imp_neg_notin producesD)

lemma less_eq_imp_interp_subseteq_interp: "C \<le> D \<Longrightarrow> interp C \<subseteq> interp D"
  unfolding interp_def by auto (metis order.strict_trans2)

lemma less_eq_imp_interp_subseteq_Interp: "C \<le> D \<Longrightarrow> interp C \<subseteq> Interp D"
  unfolding Interp_def using less_eq_imp_interp_subseteq_interp by blast

lemma less_imp_production_subseteq_interp: "C < D \<Longrightarrow> production C \<subseteq> interp D"
  unfolding interp_def by fast

lemma less_eq_imp_production_subseteq_Interp: "C \<le> D \<Longrightarrow> production C \<subseteq> Interp D"
  unfolding Interp_def using less_imp_production_subseteq_interp
  by (metis le_imp_less_or_eq le_supI1 sup_ge2)

lemma less_imp_Interp_subseteq_interp: "C < D \<Longrightarrow> Interp C \<subseteq> interp D"
  by (simp add: Interp_def less_eq_imp_interp_subseteq_interp less_imp_production_subseteq_interp)

lemma less_eq_imp_Interp_subseteq_Interp: "C \<le> D \<Longrightarrow> Interp C \<subseteq> Interp D"
  using Interp_def less_eq_imp_interp_subseteq_Interp less_eq_imp_production_subseteq_Interp by auto

lemma not_Interp_to_interp_imp_less: "A \<notin> Interp C \<Longrightarrow> A \<in> interp D \<Longrightarrow> C < D"
  using less_eq_imp_interp_subseteq_Interp not_less by blast

lemma not_interp_to_interp_imp_less: "A \<notin> interp C \<Longrightarrow> A \<in> interp D \<Longrightarrow> C < D"
  using less_eq_imp_interp_subseteq_interp not_less by blast

lemma not_Interp_to_Interp_imp_less: "A \<notin> Interp C \<Longrightarrow> A \<in> Interp D \<Longrightarrow> C < D"
  using less_eq_imp_Interp_subseteq_Interp not_less by blast

lemma not_interp_to_Interp_imp_le: "A \<notin> interp C \<Longrightarrow> A \<in> Interp D \<Longrightarrow> C \<le> D"
  using less_imp_Interp_subseteq_interp not_less by blast

definition INTERP :: "'a interp" where
  "INTERP = (\<Union>C \<in> N. production C)"

lemma interp_subseteq_INTERP: "interp C \<subseteq> INTERP"
  unfolding interp_def INTERP_def by (auto simp: production_unfold)

lemma production_subseteq_INTERP: "production C \<subseteq> INTERP"
  unfolding INTERP_def using production_unfold by blast

lemma Interp_subseteq_INTERP: "Interp C \<subseteq> INTERP"
  by (simp add: Interp_def interp_subseteq_INTERP production_subseteq_INTERP)

lemma produces_imp_in_interp:
  assumes a_in_c: "Neg A \<in># C" and d: "produces D A"
  shows "A \<in> interp C"
  by (metis Interp_def Max_pos_neg_less_multiset UnCI a_in_c d
      not_interp_to_Interp_imp_le not_less producesD singletonI)

lemma neg_notin_Interp_not_produce: "Neg A \<in># C \<Longrightarrow> A \<notin> Interp D \<Longrightarrow> C \<le> D \<Longrightarrow> \<not> produces D'' A"
  using less_eq_imp_interp_subseteq_Interp produces_imp_in_interp by blast

lemma in_production_imp_produces: "A \<in> production C \<Longrightarrow> produces C A"
  using productive_imp_produces_Max_atom by fastforce

lemma not_produces_imp_notin_production: "\<not> produces C A \<Longrightarrow> A \<notin> production C"
  using in_production_imp_produces by blast

lemma not_produces_imp_notin_interp: "(\<And>D. \<not> produces D A) \<Longrightarrow> A \<notin> interp C"
  unfolding interp_def by (fast intro!: in_production_imp_produces)

text \<open>
The results below corresponds to Lemma 3.4.
\<close>

lemma Interp_imp_general:
  assumes
    c_le_d: "C \<le> D" and
    d_lt_d': "D < D'" and
    c_at_d: "Interp D \<Turnstile> C" and
    subs: "interp D' \<subseteq> (\<Union>C \<in> CC. production C)"
  shows "(\<Union>C \<in> CC. production C) \<Turnstile> C"
proof (cases "\<exists>A. Pos A \<in># C \<and> A \<in> Interp D")
  case True
  then obtain A where a_in_c: "Pos A \<in># C" and a_at_d: "A \<in> Interp D"
    by blast
  from a_at_d have "A \<in> interp D'"
    using d_lt_d' less_imp_Interp_subseteq_interp by blast
  then show ?thesis
    using subs a_in_c by (blast dest: contra_subsetD)
next
  case False
  then obtain A where a_in_c: "Neg A \<in># C" and "A \<notin> Interp D"
    using c_at_d unfolding true_cls_def by blast
  then have "\<And>D''. \<not> produces D'' A"
    using c_le_d neg_notin_Interp_not_produce by simp
  then show ?thesis
    using a_in_c subs not_produces_imp_notin_production by auto
qed

lemma Interp_imp_interp: "C \<le> D \<Longrightarrow> D < D' \<Longrightarrow> Interp D \<Turnstile> C \<Longrightarrow> interp D' \<Turnstile> C"
  using interp_def Interp_imp_general by simp

lemma Interp_imp_Interp: "C \<le> D \<Longrightarrow> D \<le> D' \<Longrightarrow> Interp D \<Turnstile> C \<Longrightarrow> Interp D' \<Turnstile> C"
  using Interp_as_UNION interp_subseteq_Interp Interp_imp_general by (metis antisym_conv2)

lemma Interp_imp_INTERP: "C \<le> D \<Longrightarrow> Interp D \<Turnstile> C \<Longrightarrow> INTERP \<Turnstile> C"
  using INTERP_def interp_subseteq_INTERP Interp_imp_general[OF _ le_multiset_right_total] by simp

lemma interp_imp_general:
  assumes
    c_le_d: "C \<le> D" and
    d_le_d': "D \<le> D'" and
    c_at_d: "interp D \<Turnstile> C" and
    subs: "interp D' \<subseteq> (\<Union>C \<in> CC. production C)"
  shows "(\<Union>C \<in> CC. production C) \<Turnstile> C"
proof (cases "\<exists>A. Pos A \<in># C \<and> A \<in> interp D")
  case True
  then obtain A where a_in_c: "Pos A \<in># C" and a_at_d: "A \<in> interp D"
    by blast
  from a_at_d have "A \<in> interp D'"
    using d_le_d' less_eq_imp_interp_subseteq_interp by blast
  then show ?thesis
    using subs a_in_c by (blast dest: contra_subsetD)
next
  case False
  then obtain A where a_in_c: "Neg A \<in># C" and "A \<notin> interp D"
    using c_at_d unfolding true_cls_def by blast
  then have "\<And>D''. \<not> produces D'' A"
    using c_le_d by (auto dest: produces_imp_in_interp less_eq_imp_interp_subseteq_interp)
  then show ?thesis
    using a_in_c subs not_produces_imp_notin_production by auto
qed

lemma interp_imp_interp: "C \<le> D \<Longrightarrow> D \<le> D' \<Longrightarrow> interp D \<Turnstile> C \<Longrightarrow> interp D' \<Turnstile> C"
  using interp_def interp_imp_general by simp

lemma interp_imp_Interp: "C \<le> D \<Longrightarrow> D \<le> D' \<Longrightarrow> interp D \<Turnstile> C \<Longrightarrow> Interp D' \<Turnstile> C"
  using Interp_as_UNION interp_subseteq_Interp[of D'] interp_imp_general by simp

lemma interp_imp_INTERP: "C \<le> D \<Longrightarrow> interp D \<Turnstile> C \<Longrightarrow> INTERP \<Turnstile> C"
  using INTERP_def interp_subseteq_INTERP interp_imp_general linear by metis

lemma productive_imp_not_interp: "productive C \<Longrightarrow> \<not> interp C \<Turnstile> C"
  unfolding production_unfold by simp

text \<open>
This corresponds to Lemma 3.3:
\<close>

lemma productive_imp_Interp:
  assumes "productive C"
  shows "Interp C \<Turnstile> C"
proof -
  obtain A where a: "produces C A"
    using assms productive_imp_produces_Max_atom by blast
  then have a_in_c: "Pos A \<in># C"
    by (rule produces_imp_Pos_in_lits)
  moreover have "A \<in> Interp C"
    using a less_eq_imp_production_subseteq_Interp by blast
  ultimately show ?thesis
    by fast
qed

lemma productive_imp_INTERP: "productive C \<Longrightarrow> INTERP \<Turnstile> C"
  by (fast intro: productive_imp_Interp Interp_imp_INTERP)

text \<open>
This corresponds to Lemma 3.5:
\<close>

lemma max_pos_imp_Interp:
  assumes "C \<in> N" and "C \<noteq> {#}" and "Max_mset C = Pos A" and "S C = {#}"
  shows "Interp C \<Turnstile> C"
proof (cases "productive C")
  case True
  then show ?thesis
    by (fast intro: productive_imp_Interp)
next
  case False
  then have "interp C \<Turnstile> C"
    using assms unfolding production_unfold by simp
  then show ?thesis
    unfolding Interp_def using False by auto
qed

text \<open>
The following results correspond to Lemma 3.6:
\<close>

lemma max_atm_imp_Interp:
  assumes
    c_in_n: "C \<in> N" and
    pos_in: "Pos A \<in># C" and
    max_atm: "A = Max (atms_of C)" and
    s_c_e: "S C = {#}"
  shows "Interp C \<Turnstile> C"
proof (cases "Neg A \<in># C")
  case True
  then show ?thesis
    using pos_in pos_neg_in_imp_true by metis
next
  case False
  moreover have ne: "C \<noteq> {#}"
    using pos_in by auto
  ultimately have "Max_mset C = Pos A"
    using max_atm using Max_in_lits Max_lit_eq_pos_or_neg_Max_atm by metis
  then show ?thesis
    using ne c_in_n s_c_e by (blast intro: max_pos_imp_Interp)
qed

lemma not_Interp_imp_general:
  assumes
    d'_le_d: "D' \<le> D" and
    in_n_or_max_gt: "D' \<in> N \<and> S D' = {#} \<or> Max (atms_of D') < Max (atms_of D)" and
    d'_at_d: "\<not> Interp D \<Turnstile> D'" and
    d_lt_c: "D < C" and
    subs: "interp C \<subseteq> (\<Union>C \<in> CC. production C)"
  shows "\<not> (\<Union>C \<in> CC. production C) \<Turnstile> D'"
proof -
  {
    assume cc_blw_d': "(\<Union>C \<in> CC. production C) \<Turnstile> D'"
    have "Interp D \<subseteq> (\<Union>C \<in> CC. production C)"
      using less_imp_Interp_subseteq_interp d_lt_c subs by blast
    then obtain A where a_in_d': "Pos A \<in># D'" and a_blw_cc: "A \<in> (\<Union>C \<in> CC. production C)"
      using cc_blw_d' d'_at_d false_to_true_imp_ex_pos by metis
    from a_in_d' have a_at_d: "A \<notin> Interp D"
      using d'_at_d by fast
    from a_blw_cc obtain C' where prod_c': "production C' = {A}"
      by (fast intro!: in_production_imp_produces)
    have max_c': "Max (atms_of C') = A"
      using prod_c' productive_imp_produces_Max_atom by force
    have leq_dc': "D \<le> C'"
      using a_at_d d'_at_d prod_c' by (auto simp: Interp_def intro: not_interp_to_Interp_imp_le)
    then have "D' \<le> C'"
      using d'_le_d order_trans by blast
    then have max_d': "Max (atms_of D') = A"
      using a_in_d' max_c' by (fast intro: pos_lit_in_atms_of le_multiset_Max_in_imp_Max)

    {
      assume "D' \<in> N \<and> S D' = {#}"
      then have "Interp D' \<Turnstile> D'"
        using a_in_d' max_d' by (blast intro: max_atm_imp_Interp)
      then have "Interp D \<Turnstile> D'"
        using d'_le_d by (auto intro: Interp_imp_Interp simp: less_eq_multiset_def)
      then have False
        using d'_at_d by satx
    }
    moreover
    {
      assume "Max (atms_of D') < Max (atms_of D)"
      then have False
        using max_d' leq_dc' max_c' d'_le_d
        by (metis le_imp_less_or_eq le_multiset_empty_right less_eq_Max_atms_of less_imp_not_less)
    }
    ultimately have False
      using in_n_or_max_gt by satx
  }
  then show ?thesis
    by satx
qed

lemma not_Interp_imp_not_interp:
  "D' \<le> D \<Longrightarrow> D' \<in> N \<and> S D' = {#} \<or> Max (atms_of D') < Max (atms_of D) \<Longrightarrow> \<not> Interp D \<Turnstile> D' \<Longrightarrow>
   D < C \<Longrightarrow> \<not> interp C \<Turnstile> D'"
  using interp_def not_Interp_imp_general by simp

lemma not_Interp_imp_not_Interp:
  "D' \<le> D \<Longrightarrow> D' \<in> N \<and> S D' = {#} \<or> Max (atms_of D') < Max (atms_of D) \<Longrightarrow> \<not> Interp D \<Turnstile> D' \<Longrightarrow>
   D < C \<Longrightarrow> \<not> Interp C \<Turnstile> D'"
  using Interp_as_UNION interp_subseteq_Interp not_Interp_imp_general by metis

lemma not_Interp_imp_not_INTERP:
  "D' \<le> D \<Longrightarrow> D' \<in> N \<and> S D' = {#} \<or> Max (atms_of D') < Max (atms_of D) \<Longrightarrow> \<not> Interp D \<Turnstile> D' \<Longrightarrow>
   \<not> INTERP \<Turnstile> D'"
  using INTERP_def interp_subseteq_INTERP not_Interp_imp_general[OF _ _ _ le_multiset_right_total]
  by simp

text \<open>
Lemma 3.7 is a problem child. It is stated below but not proved; instead, a counterexample is
displayed. This is not much of a problem, because it is not invoked in the rest of the chapter.
\<close>

lemma
  assumes "D \<in> N" and "\<And>D'. D' < D \<Longrightarrow> Interp D' \<Turnstile> C"
  shows "interp D \<Turnstile> C"
  oops

lemma
  assumes d: "D = {#}" and n: "N = {D, C}" and c: "C = {#Pos A#}"
  shows "D \<in> N" and "\<And>D'. D' < D \<Longrightarrow> Interp D' \<Turnstile> C" and "\<not> interp D \<Turnstile> C"
  using n unfolding d c interp_def by auto

end

end

end


header {* Proof chains *}

theory Proofchain imports
  JHelper
begin

text {* An (@{typ 'a}, @{typ 'c}) chain is a sequence of alternating
  @{typ 'a}'s and @{typ 'c}'s, beginning and ending with an @{typ 'a}. Usually
  @{typ 'a} represents some sort of assertion, and @{typ 'c} represents some
  sort of command. Proof chains are useful for stating the SMain proof rule,
  and for conducting the proof of soundness. *}

datatype ('a,'c) chain =
  cNil "'a"                         ("\<lbrace> _ \<rbrace>")
| cCons "'a" "'c" "('a,'c) chain"   ("\<lbrace> _ \<rbrace> \<cdot> _ \<cdot> _" [0,0,0] 60)

text {* For example, @{term "\<lbrace> a \<rbrace> \<cdot> proof \<cdot> \<lbrace> chain \<rbrace> \<cdot> might \<cdot> \<lbrace> look \<rbrace> \<cdot>
  like \<cdot> \<lbrace> this \<rbrace>"}. *}

subsection {* Projections *}

text {* Project first assertion. *}
fun
  pre :: "('a,'c) chain \<Rightarrow> 'a"
where
  "pre \<lbrace> P \<rbrace> = P"
| "pre (\<lbrace> P \<rbrace> \<cdot> _ \<cdot> _) = P"

text {* Project final assertion. *}
fun
  post :: "('a,'c) chain \<Rightarrow> 'a"
where
  "post \<lbrace> P \<rbrace>  = P"
| "post (\<lbrace> _ \<rbrace> \<cdot> _ \<cdot> \<Pi>) = post \<Pi>"

text {* Project list of commands. *}
fun
  comlist :: "('a,'c) chain \<Rightarrow> 'c list"
where
  "comlist \<lbrace> _ \<rbrace> = []"
| "comlist (\<lbrace> _ \<rbrace> \<cdot> x \<cdot> \<Pi>) = x # (comlist \<Pi>)"

subsection {* Chain length *}

fun
  chainlen :: "('a,'c) chain \<Rightarrow> nat"
where
  "chainlen \<lbrace> _ \<rbrace> = 0"
| "chainlen (\<lbrace> _ \<rbrace> \<cdot> _ \<cdot> \<Pi>) = 1 + (chainlen \<Pi>)"

lemma len_comlist_chainlen:
  "length (comlist \<Pi>) = chainlen \<Pi>"
by (induct \<Pi>, auto)

subsection {* Extracting triples from chains *}

text {* @{term "nthtriple \<Pi> n"} extracts the @{term n}th triple of @{term \<Pi>},
  counting from 0. The function is well-defined when @{term "chainlen \<Pi> > n"}.
  *}
fun
  nthtriple :: "('a,'c) chain \<Rightarrow> nat \<Rightarrow> ('a * 'c * 'a)"
where
  "nthtriple (\<lbrace> P \<rbrace> \<cdot> x \<cdot> \<Pi>) 0 = (P, x, pre \<Pi>)"
| "nthtriple (\<lbrace> P \<rbrace> \<cdot> x \<cdot> \<Pi>) (Suc n) = nthtriple \<Pi> n"

text {* The list of middle components of @{term \<Pi>}'s triples is the list of
   @{term \<Pi>}'s commands. *}
lemma snds_of_triples_form_comlist:
  fixes \<Pi> i
  shows "i < chainlen \<Pi> \<Longrightarrow> snd3 (nthtriple \<Pi> i) = (comlist \<Pi>)!i"
apply (induct \<Pi> arbitrary: i)
apply simp
apply (case_tac i)
apply (auto simp add: snd3_def)
done

subsection {* Evaluating a predicate on each triple of a chain *}

text {* @{term "chain_all \<phi>"} holds of @{term \<Pi>} iff @{term \<phi>} holds for each
  of @{term \<Pi>}'s individual triples. *}
fun
  chain_all :: "(('a \<times> 'c \<times> 'a) \<Rightarrow> bool) \<Rightarrow> ('a,'c) chain \<Rightarrow> bool"
where
  "chain_all \<phi> \<lbrace> \<sigma> \<rbrace> = True"
| "chain_all \<phi> (\<lbrace> \<sigma> \<rbrace> \<cdot> x \<cdot> \<Pi>) = (\<phi> (\<sigma>,x,pre \<Pi>) \<and> chain_all \<phi> \<Pi>)"

lemma chain_all_mono [mono]:
  "x \<le> y \<Longrightarrow> chain_all x \<le> chain_all y"
proof (intro le_funI le_boolI)
  fix f g :: "('a \<times> 'b \<times> 'a) \<Rightarrow> bool"
  fix \<Pi> :: "('a, 'b) chain"
  assume "f \<le> g"
  assume "chain_all f \<Pi>"
  thus "chain_all g \<Pi>"
  apply (induct \<Pi>)
  apply simp
  apply (metis `f \<le> g` chain_all.simps(2) predicate1D)
  done
qed

lemma chain_all_nthtriple:
  "(chain_all \<phi> \<Pi>) = (\<forall>i < chainlen \<Pi>. \<phi> (nthtriple \<Pi> i))"
proof (intro iffI allI impI)
  fix i
  assume "chain_all \<phi> \<Pi>" and "i < chainlen \<Pi>"
  thus "\<phi> (nthtriple \<Pi> i)"
  proof (induct i arbitrary: \<Pi>)
    case 0
    then obtain \<sigma> x \<Pi>' where \<Pi>_def: "\<Pi> = \<lbrace> \<sigma> \<rbrace> \<cdot> x \<cdot> \<Pi>'"
    by (metis chain.exhaust chainlen.simps(1) less_nat_zero_code)
    show ?case
    by (insert "0.prems"(1), unfold \<Pi>_def, auto)
  next
    case (Suc i)
    then obtain \<sigma> x \<Pi>' where \<Pi>_def: "\<Pi> = \<lbrace> \<sigma> \<rbrace> \<cdot> x \<cdot> \<Pi>'"
    by (metis chain.exhaust chainlen.simps(1) less_nat_zero_code)
    show ?case
    apply (unfold \<Pi>_def nthtriple.simps)
    apply (intro Suc.hyps, insert Suc.prems, auto simp add: \<Pi>_def)
    done
  qed
next
  assume "\<forall>i<chainlen \<Pi>. \<phi> (nthtriple \<Pi> i)"
  hence "\<And>i. i < chainlen \<Pi> \<Longrightarrow> \<phi> (nthtriple \<Pi> i)" by auto
  thus "chain_all \<phi> \<Pi>"
  proof (induct \<Pi>)
    case (cCons \<sigma> x \<Pi>')
    show ?case
    apply (simp, intro conjI)
    apply (subgoal_tac "\<phi> (nthtriple (\<lbrace> \<sigma> \<rbrace> \<cdot> x \<cdot> \<Pi>') 0)", simp)
    apply (intro cCons.prems, simp)
    apply (intro cCons.hyps)
    proof -
      fix i
      assume "i < chainlen \<Pi>'"
      hence "Suc i < chainlen (\<lbrace> \<sigma> \<rbrace> \<cdot> x \<cdot> \<Pi>')" by auto
      from cCons.prems[OF this] show "\<phi> (nthtriple \<Pi>' i)" by auto
    qed
  qed(auto)
qed

subsection {* A map function for proof chains *}

text {* @{term "chainmap f g \<Pi>"} maps @{term f} over each of @{term \<Pi>}'s
  assertions, and @{term g} over each of @{term \<Pi>}'s commands. *}
fun
  chainmap :: "('a \<Rightarrow> 'b) \<Rightarrow> ('c \<Rightarrow> 'd) \<Rightarrow> ('a,'c) chain \<Rightarrow> ('b,'d) chain"
where
  "chainmap f g \<lbrace> P \<rbrace> = \<lbrace> f P \<rbrace>"
| "chainmap f g (\<lbrace> P \<rbrace> \<cdot> x \<cdot> \<Pi>) = \<lbrace> f P \<rbrace> \<cdot> g x \<cdot> chainmap f g \<Pi>"

text {* Mapping over a chain preserves its length. *}
lemma chainmap_preserves_length:
  "chainlen (chainmap f g \<Pi>) = chainlen \<Pi>"
by (induct \<Pi>, auto)

lemma pre_chainmap:
  "pre (chainmap f g \<Pi>) = f (pre \<Pi>)"
by (induct \<Pi>, auto)

lemma post_chainmap:
  "post (chainmap f g \<Pi>) = f (post \<Pi>)"
by (induct \<Pi>, auto)

lemma nthtriple_chainmap:
  assumes "i < chainlen \<Pi>"
  shows "nthtriple (chainmap f g \<Pi>) i
    = (\<lambda>t. (f (fst3 t), g (snd3 t), f (thd3 t))) (nthtriple \<Pi> i)"
using assms
proof (induct \<Pi> arbitrary: i)
  case cCons
  thus ?case
  by (induct i, auto simp add: pre_chainmap fst3_def snd3_def thd3_def)
qed (auto)

subsection {* Extending a chain on its right-hand side *}

fun
  cSnoc :: "('a,'c) chain \<Rightarrow> 'c \<Rightarrow> 'a \<Rightarrow> ('a,'c) chain"
where
  "cSnoc \<lbrace> \<sigma> \<rbrace> y \<tau> = \<lbrace> \<sigma> \<rbrace> \<cdot> y \<cdot> \<lbrace> \<tau> \<rbrace>"
| "cSnoc (\<lbrace> \<sigma> \<rbrace> \<cdot> x \<cdot> \<Pi>) y \<tau> = \<lbrace> \<sigma> \<rbrace> \<cdot> x \<cdot> (cSnoc \<Pi> y \<tau>)"

lemma len_snoc:
  fixes \<Pi> x P
  shows "chainlen (cSnoc \<Pi> x P) = 1 + (chainlen \<Pi>)"
by (induct \<Pi>, auto)

lemma pre_snoc:
  "pre (cSnoc \<Pi> x P) = pre \<Pi>"
by (induct \<Pi>, auto)

lemma post_snoc:
  "post (cSnoc \<Pi> x P) = P"
by (induct \<Pi>, auto)

end


(*  Title:       Deriving class instances for datatypes
    Author:      Christian Sternagel and René Thiemann  <christian.sternagel|rene.thiemann@uibk.ac.at>
    Maintainer:  Christian Sternagel and René Thiemann
    License:     LGPL
*)
section \<open>Checking Equality Without "="\<close>

theory Equality_Generator
imports
  "../Generator_Aux"
  "../Derive_Manager"
begin

typedecl ('a,'b,'c,'z)type

text \<open>In the following, we define a generator which for a given datatype @{typ "('a,'b,'c,'z)type"}
  constructs an equality-test function of type
  @{typ "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> ('z \<Rightarrow> 'z \<Rightarrow> bool) \<Rightarrow>
    (('a,'b,'c,'z)type \<Rightarrow> ('a,'b,'c,'z)type \<Rightarrow> bool)"}.
  These functions are essential to synthesize conditional equality functions in the container framework,
  where a strict membership in the @{class equal}-class must not be enforced.
\<close>

hide_type "type"

text \<open>Just a constant to define conjunction on lists of booleans, which will
  be used to merge the results when having compared the arguments of identical
  constructors.\<close>

definition list_all_eq :: "bool list \<Rightarrow> bool" where
  "list_all_eq = list_all id "

subsection \<open>Improved Code for Non-Lazy Languages\<close>

text \<open>The following equations will eliminate all occurrences of @{term list_all_eq}
  in the generated code of the equality functions.\<close>

lemma list_all_eq_unfold:
  "list_all_eq [] = True"
  "list_all_eq [b] = b"
  "list_all_eq (b1 # b2 # bs) = (b1 \<and> list_all_eq (b2 # bs))"
  unfolding list_all_eq_def
  by auto

lemma list_all_eq: "list_all_eq bs \<longleftrightarrow> (\<forall> b \<in> set bs. b)"
  unfolding list_all_eq_def list_all_iff by auto

subsection \<open>Partial Equality Property\<close>

text \<open>We require a partial property which can be used in inductive proofs.\<close>

type_synonym 'a equality = "'a \<Rightarrow> 'a \<Rightarrow> bool"

definition pequality :: "'a equality \<Rightarrow> 'a \<Rightarrow> bool"
where
  "pequality aeq x \<longleftrightarrow> (\<forall> y. aeq x y \<longleftrightarrow> x = y)"

lemma pequalityD: "pequality aeq x \<Longrightarrow> aeq x y \<longleftrightarrow> x = y"
  unfolding pequality_def by auto

lemma pequalityI: "(\<And> y. aeq x y \<longleftrightarrow> x = y) \<Longrightarrow> pequality aeq x"
  unfolding pequality_def by auto

subsection \<open>Global equality property\<close>

definition equality :: "'a equality \<Rightarrow> bool" where
  "equality aeq \<longleftrightarrow> (\<forall> x. pequality aeq x)"

lemma equalityD2: "equality aeq \<Longrightarrow> pequality aeq x"
  unfolding equality_def by blast

lemma equalityI2: "(\<And> x. pequality aeq x) \<Longrightarrow> equality aeq"
  unfolding equality_def by blast

lemma equalityD: "equality aeq \<Longrightarrow> aeq x y \<longleftrightarrow> x = y"
  by (rule pequalityD[OF equalityD2])

lemma equalityI: "(\<And> x y. aeq x y \<longleftrightarrow> x = y) \<Longrightarrow> equality aeq"
  by (intro equalityI2 pequalityI)

lemma equality_imp_eq:
  "equality aeq \<Longrightarrow> aeq = (=)"
  by (intro ext, auto dest: equalityD)

lemma eq_equality: "equality (=)"
  by (rule equalityI, simp)

lemma equality_def': "equality f = (f = (=))"
  using equality_imp_eq eq_equality by blast

subsection \<open>The Generator\<close>

ML_file \<open>equality_generator.ML\<close>

hide_fact (open) equalityI

end


(*  Title:      Sequents/LK/Hard_Quantifiers.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge

Hard examples with quantifiers.  Can be read to test the LK system.
From  F. J. Pelletier,
  Seventy-Five Problems for Testing Automatic Theorem Provers,
  J. Automated Reasoning 2 (1986), 191-216.
  Errata, JAR 4 (1988), 236-236.

Uses pc_tac rather than fast_tac when the former is significantly faster.
*)

theory Hard_Quantifiers
imports "../LK"
begin

lemma "|- (ALL x. P(x) & Q(x)) <-> (ALL x. P(x))  &  (ALL x. Q(x))"
  by fast

lemma "|- (EX x. P-->Q(x))  <->  (P --> (EX x. Q(x)))"
  by fast

lemma "|- (EX x. P(x)-->Q)  <->  (ALL x. P(x)) --> Q"
  by fast

lemma "|- (ALL x. P(x)) | Q  <->  (ALL x. P(x) | Q)"
  by fast

text "Problems requiring quantifier duplication"

(*Not provable by fast: needs multiple instantiation of ALL*)
lemma "|- (ALL x. P(x)-->P(f(x)))  &  P(d)-->P(f(f(f(d))))"
  by best_dup

(*Needs double instantiation of the quantifier*)
lemma "|- EX x. P(x) --> P(a) & P(b)"
  by fast_dup

lemma "|- EX z. P(z) --> (ALL x. P(x))"
  by best_dup

text "Hard examples with quantifiers"

text "Problem 18"
lemma "|- EX y. ALL x. P(y)-->P(x)"
  by best_dup

text "Problem 19"
lemma "|- EX x. ALL y z. (P(y)-->Q(z)) --> (P(x)-->Q(x))"
  by best_dup

text "Problem 20"
lemma "|- (ALL x y. EX z. ALL w. (P(x)&Q(y)-->R(z)&S(w)))
    --> (EX x y. P(x) & Q(y)) --> (EX z. R(z))"
  by fast

text "Problem 21"
lemma "|- (EX x. P-->Q(x)) & (EX x. Q(x)-->P) --> (EX x. P<->Q(x))"
  by best_dup

text "Problem 22"
lemma "|- (ALL x. P <-> Q(x))  -->  (P <-> (ALL x. Q(x)))"
  by fast

text "Problem 23"
lemma "|- (ALL x. P | Q(x))  <->  (P | (ALL x. Q(x)))"
  by best

text "Problem 24"
lemma "|- ~(EX x. S(x)&Q(x)) & (ALL x. P(x) --> Q(x)|R(x)) &
     ~(EX x. P(x)) --> (EX x. Q(x)) & (ALL x. Q(x)|R(x) --> S(x))
    --> (EX x. P(x)&R(x))"
  by pc

text "Problem 25"
lemma "|- (EX x. P(x)) &
        (ALL x. L(x) --> ~ (M(x) & R(x))) &
        (ALL x. P(x) --> (M(x) & L(x))) &
        ((ALL x. P(x)-->Q(x)) | (EX x. P(x)&R(x)))
    --> (EX x. Q(x)&P(x))"
  by best

text "Problem 26"
lemma "|- ((EX x. p(x)) <-> (EX x. q(x))) &
      (ALL x. ALL y. p(x) & q(y) --> (r(x) <-> s(y)))
  --> ((ALL x. p(x)-->r(x)) <-> (ALL x. q(x)-->s(x)))"
  by pc

text "Problem 27"
lemma "|- (EX x. P(x) & ~Q(x)) &
              (ALL x. P(x) --> R(x)) &
              (ALL x. M(x) & L(x) --> P(x)) &
              ((EX x. R(x) & ~ Q(x)) --> (ALL x. L(x) --> ~ R(x)))
          --> (ALL x. M(x) --> ~L(x))"
  by pc

text "Problem 28.  AMENDED"
lemma "|- (ALL x. P(x) --> (ALL x. Q(x))) &
        ((ALL x. Q(x)|R(x)) --> (EX x. Q(x)&S(x))) &
        ((EX x. S(x)) --> (ALL x. L(x) --> M(x)))
    --> (ALL x. P(x) & L(x) --> M(x))"
  by pc

text "Problem 29.  Essentially the same as Principia Mathematica *11.71"
lemma "|- (EX x. P(x)) & (EX y. Q(y))
    --> ((ALL x. P(x)-->R(x)) & (ALL y. Q(y)-->S(y))   <->
         (ALL x y. P(x) & Q(y) --> R(x) & S(y)))"
  by pc

text "Problem 30"
lemma "|- (ALL x. P(x) | Q(x) --> ~ R(x)) &
        (ALL x. (Q(x) --> ~ S(x)) --> P(x) & R(x))
    --> (ALL x. S(x))"
  by fast

text "Problem 31"
lemma "|- ~(EX x. P(x) & (Q(x) | R(x))) &
        (EX x. L(x) & P(x)) &
        (ALL x. ~ R(x) --> M(x))
    --> (EX x. L(x) & M(x))"
  by fast

text "Problem 32"
lemma "|- (ALL x. P(x) & (Q(x)|R(x))-->S(x)) &
        (ALL x. S(x) & R(x) --> L(x)) &
        (ALL x. M(x) --> R(x))
    --> (ALL x. P(x) & M(x) --> L(x))"
  by best

text "Problem 33"
lemma "|- (ALL x. P(a) & (P(x)-->P(b))-->P(c))  <->
     (ALL x. (~P(a) | P(x) | P(c)) & (~P(a) | ~P(b) | P(c)))"
  by fast

text "Problem 34  AMENDED (TWICE!!)"
(*Andrews's challenge*)
lemma "|- ((EX x. ALL y. p(x) <-> p(y))  <->
               ((EX x. q(x)) <-> (ALL y. p(y))))     <->
              ((EX x. ALL y. q(x) <-> q(y))  <->
               ((EX x. p(x)) <-> (ALL y. q(y))))"
  by best_dup

text "Problem 35"
lemma "|- EX x y. P(x,y) -->  (ALL u v. P(u,v))"
  by best_dup

text "Problem 36"
lemma "|- (ALL x. EX y. J(x,y)) &
         (ALL x. EX y. G(x,y)) &
         (ALL x y. J(x,y) | G(x,y) -->
         (ALL z. J(y,z) | G(y,z) --> H(x,z)))
         --> (ALL x. EX y. H(x,y))"
  by fast

text "Problem 37"
lemma "|- (ALL z. EX w. ALL x. EX y.
           (P(x,z)-->P(y,w)) & P(y,z) & (P(y,w) --> (EX u. Q(u,w)))) &
        (ALL x z. ~P(x,z) --> (EX y. Q(y,z))) &
        ((EX x y. Q(x,y)) --> (ALL x. R(x,x)))
    --> (ALL x. EX y. R(x,y))"
  by pc

text "Problem 38"
lemma "|- (ALL x. p(a) & (p(x) --> (EX y. p(y) & r(x,y))) -->
                 (EX z. EX w. p(z) & r(x,w) & r(w,z)))  <->
         (ALL x. (~p(a) | p(x) | (EX z. EX w. p(z) & r(x,w) & r(w,z))) &
                 (~p(a) | ~(EX y. p(y) & r(x,y)) |
                 (EX z. EX w. p(z) & r(x,w) & r(w,z))))"
  by pc

text "Problem 39"
lemma "|- ~ (EX x. ALL y. F(y,x) <-> ~F(y,y))"
  by fast

text "Problem 40.  AMENDED"
lemma "|- (EX y. ALL x. F(x,y) <-> F(x,x)) -->
         ~(ALL x. EX y. ALL z. F(z,y) <-> ~ F(z,x))"
  by fast

text "Problem 41"
lemma "|- (ALL z. EX y. ALL x. f(x,y) <-> f(x,z) & ~ f(x,x))
         --> ~ (EX z. ALL x. f(x,z))"
  by fast

text "Problem 42"
lemma "|- ~ (EX y. ALL x. p(x,y) <-> ~ (EX z. p(x,z) & p(z,x)))"
  oops

text "Problem 43"
lemma "|- (ALL x. ALL y. q(x,y) <-> (ALL z. p(z,x) <-> p(z,y)))
          --> (ALL x. (ALL y. q(x,y) <-> q(y,x)))"
  oops

text "Problem 44"
lemma "|- (ALL x. f(x) -->
                 (EX y. g(y) & h(x,y) & (EX y. g(y) & ~ h(x,y))))  &
         (EX x. j(x) & (ALL y. g(y) --> h(x,y)))
         --> (EX x. j(x) & ~f(x))"
  by fast

text "Problem 45"
lemma "|- (ALL x. f(x) & (ALL y. g(y) & h(x,y) --> j(x,y))
                      --> (ALL y. g(y) & h(x,y) --> k(y))) &
      ~ (EX y. l(y) & k(y)) &
      (EX x. f(x) & (ALL y. h(x,y) --> l(y))
                   & (ALL y. g(y) & h(x,y) --> j(x,y)))
      --> (EX x. f(x) & ~ (EX y. g(y) & h(x,y)))"
  by best

text "Problems (mainly) involving equality or functions"

text "Problem 48"
lemma "|- (a=b | c=d) & (a=c | b=d) --> a=d | b=c"
  by (fast add!: subst)

text "Problem 50"
lemma "|- (ALL x. P(a,x) | (ALL y. P(x,y))) --> (EX x. ALL y. P(x,y))"
  by best_dup

text "Problem 51"
lemma "|- (EX z w. ALL x y. P(x,y) <->  (x=z & y=w)) -->
         (EX z. ALL x. EX w. (ALL y. P(x,y) <-> y=w) <-> x=z)"
  by (fast add!: subst)

text "Problem 52"  (*Almost the same as 51. *)
lemma "|- (EX z w. ALL x y. P(x,y) <->  (x=z & y=w)) -->
         (EX w. ALL y. EX z. (ALL x. P(x,y) <-> x=z) <-> y=w)"
  by (fast add!: subst)

text "Problem 56"
lemma "|- (ALL x.(EX y. P(y) & x=f(y)) --> P(x)) <-> (ALL x. P(x) --> P(f(x)))"
  by (best add: symL subst)
  (*requires tricker to orient the equality properly*)

text "Problem 57"
lemma "|- P(f(a,b), f(b,c)) & P(f(b,c), f(a,c)) &
         (ALL x y z. P(x,y) & P(y,z) --> P(x,z))    -->   P(f(a,b), f(a,c))"
  by fast

text "Problem 58!"
lemma "|- (ALL x y. f(x)=g(y)) --> (ALL x y. f(f(x))=f(g(y)))"
  by (fast add!: subst)

text "Problem 59"
(*Unification works poorly here -- the abstraction %sobj prevents efficient
  operation of the occurs check*)

lemma "|- (ALL x. P(x) <-> ~P(f(x))) --> (EX x. P(x) & ~P(f(x)))"
  by best_dup

text "Problem 60"
lemma "|- ALL x. P(x,f(x)) <-> (EX y. (ALL z. P(z,y) --> P(z,f(x))) & P(x,y))"
  by fast

text "Problem 62 as corrected in JAR 18 (1997), page 135"
lemma "|- (ALL x. p(a) & (p(x) --> p(f(x))) --> p(f(f(x))))  <->
      (ALL x. (~p(a) | p(x) | p(f(f(x)))) &
              (~p(a) | ~p(f(x)) | p(f(f(x)))))"
  by fast

(*18 June 92: loaded in 372 secs*)
(*19 June 92: loaded in 166 secs except #34, using repeat_goal_tac*)
(*29 June 92: loaded in 370 secs*)
(*18 September 2005: loaded in 1.809 secs*)

end


(*  Title:       Subcategory
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2017
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter "Subcategory"

  text\<open>
    In this chapter we give a construction of the subcategory of a category
    defined by a predicate on arrows subject to closure conditions.  The arrows of
    the subcategory are directly identified with the arrows of the ambient category.
    We also define the related notions of full subcategory and inclusion functor.
\<close>

theory Subcategory
imports Functor
begin

  locale subcategory =
    C: category C
    for C :: "'a comp"      (infixr "\<cdot>\<^sub>C" 55)
    and Arr :: "'a \<Rightarrow> bool" +
    assumes inclusion: "Arr f \<Longrightarrow> C.arr f"
    and dom_closed: "Arr f \<Longrightarrow> Arr (C.dom f)"
    and cod_closed: "Arr f \<Longrightarrow> Arr (C.cod f)"
    and comp_closed: "\<lbrakk> Arr f; Arr g; C.cod f = C.dom g \<rbrakk> \<Longrightarrow> Arr (g \<cdot>\<^sub>C f)"
  begin

    no_notation C.in_hom    ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
    notation C.in_hom       ("\<guillemotleft>_ : _ \<rightarrow>\<^sub>C _\<guillemotright>")

    definition comp         (infixr "\<cdot>" 55)
    where "g \<cdot> f = (if Arr f \<and> Arr g \<and> C.cod f = C.dom g then g \<cdot>\<^sub>C f else C.null)"

    interpretation partial_magma comp
    proof
      show "\<exists>!n. \<forall>f. n \<cdot> f = n \<and> f \<cdot> n = n"
      proof
        show 1: "\<forall>f. C.null \<cdot> f = C.null \<and> f \<cdot> C.null = C.null"
          by (metis C.comp_null(1) C.ex_un_null comp_def)
        show "\<And>n. \<forall>f. n \<cdot> f = n \<and> f \<cdot> n = n \<Longrightarrow> n = C.null"
          using 1 C.ex_un_null by metis
      qed
    qed

    lemma null_char [simp]:
    shows "null = C.null"
    proof -
      have "\<forall>f. C.null \<cdot> f = C.null \<and> f \<cdot> C.null = C.null"
        by (metis C.comp_null(1) C.ex_un_null comp_def)
      thus ?thesis using ex_un_null by (metis comp_null(2))
    qed

    lemma ideI:
    assumes "Arr a" and "C.ide a"
    shows "ide a"
      unfolding ide_def
      using assms null_char C.ide_def comp_def by auto

    lemma Arr_iff_dom_in_domain:
    shows "Arr f \<longleftrightarrow> C.dom f \<in> domains f"
    proof
      show "C.dom f \<in> domains f \<Longrightarrow> Arr f"
        using domains_def comp_def ide_def by fastforce
      show "Arr f \<Longrightarrow> C.dom f \<in> domains f"
      proof -
        assume f: "Arr f"
        have "ide (C.dom f)"
          using f inclusion C.dom_in_domains C.has_domain_iff_arr C.domains_def
                dom_closed ideI
          by auto
        moreover have "f \<cdot> C.dom f \<noteq> null"
          using f comp_def dom_closed null_char inclusion C.comp_arr_dom by force
        ultimately show ?thesis
          using domains_def by simp
      qed
    qed

    lemma Arr_iff_cod_in_codomain:
    shows "Arr f \<longleftrightarrow> C.cod f \<in> codomains f"
    proof
      show "C.cod f \<in> codomains f \<Longrightarrow> Arr f"
        using codomains_def comp_def ide_def by fastforce
      show "Arr f \<Longrightarrow> C.cod f \<in> codomains f"
      proof -
        assume f: "Arr f"
        have "ide (C.cod f)"
          using f inclusion C.cod_in_codomains C.has_codomain_iff_arr C.codomains_def
                cod_closed ideI
          by auto
        moreover have "C.cod f \<cdot> f \<noteq> null"
          using f comp_def cod_closed null_char inclusion C.comp_cod_arr by force
        ultimately show ?thesis
          using codomains_def by simp
      qed
    qed

    lemma arr_char:
    shows "arr f \<longleftrightarrow> Arr f"
    proof
      show "Arr f \<Longrightarrow> arr f"
        using arr_def comp_def Arr_iff_dom_in_domain Arr_iff_cod_in_codomain by auto
      show "arr f \<Longrightarrow> Arr f"
      proof -
        assume f: "arr f"
        obtain a where a: "a \<in> domains f \<or> a \<in> codomains f"
          using f arr_def by auto
        have "f \<cdot> a \<noteq> C.null \<or> a \<cdot> f \<noteq> C.null"
          using a domains_def codomains_def null_char by auto
        thus "Arr f"
          using comp_def by metis
      qed
    qed

    lemma arrI [intro]:
    assumes "Arr f"
    shows "arr f"
      using assms arr_char by simp

    lemma arrE [elim]:
    assumes "arr f"
    shows "Arr f"
      using assms arr_char by simp

    interpretation category comp
      using comp_def null_char inclusion comp_closed dom_closed cod_closed
      apply unfold_locales
           apply auto[1]
          apply (metis Arr_iff_dom_in_domain Arr_iff_cod_in_codomain arr_char arr_def emptyE)
    proof -
      fix f g h
      assume gf: "seq g f" and hg: "seq h g"
      show 1: "seq (h \<cdot> g) f"
        using gf hg inclusion comp_closed comp_def by auto
      show "(h \<cdot> g) \<cdot> f = h \<cdot> g \<cdot> f"
        using gf hg 1 C.not_arr_null inclusion comp_def arr_char
        by (metis (full_types) C.cod_comp C.comp_assoc)
      next
      fix f g h
      assume hg: "seq h g" and hgf: "seq (h \<cdot> g) f"
      show "seq g f"
        using hg hgf comp_def null_char inclusion arr_char comp_closed
        by (metis (full_types) C.dom_comp)
      next
      fix f g h
      assume hgf: "seq h (g \<cdot> f)" and gf: "seq g f"
      show "seq h g"
        using hgf gf comp_def null_char arr_char comp_closed
        by (metis C.seqE C.ext C.match_2)
    qed

    theorem is_category:
    shows "category comp" ..

    notation in_hom     ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")

    lemma dom_simp [simp]:
    assumes "arr f"
    shows "dom f = C.dom f"
    proof -
      have "ide (C.dom f)"
        using assms ideI
        by (meson C.ide_dom arr_char dom_closed inclusion)
      moreover have "f \<cdot> C.dom f \<noteq> null"
        using assms inclusion comp_def null_char dom_closed not_arr_null C.comp_arr_dom arr_char
        by auto
      ultimately show ?thesis
        using dom_eqI ext by blast
    qed

    lemma cod_simp [simp]:
    assumes "arr f"
    shows "cod f = C.cod f"
    proof -
      have "ide (C.cod f)"
        using assms ideI
        by (meson C.ide_cod arr_char cod_closed inclusion)
      moreover have "C.cod f \<cdot> f \<noteq> null"
        using assms inclusion comp_def null_char cod_closed not_arr_null C.comp_cod_arr arr_char
        by auto
      ultimately show ?thesis
        using cod_eqI ext by blast
    qed

    lemma cod_char:
    shows "cod f = (if arr f then C.cod f else C.null)"
      using cod_simp cod_def arr_def by auto

    lemma in_hom_char:
    shows "\<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<longleftrightarrow> arr a \<and> arr b \<and> arr f \<and> \<guillemotleft>f : a \<rightarrow>\<^sub>C b\<guillemotright>"
      using inclusion arr_char cod_closed dom_closed
      by (metis C.arr_iff_in_hom C.in_homE arr_iff_in_hom cod_simp dom_simp in_homE)

    lemma ide_char:
    shows "ide a \<longleftrightarrow> arr a \<and> C.ide a"
      using ide_in_hom C.ide_in_hom in_hom_char by simp

    lemma seq_char:
    shows "seq g f \<longleftrightarrow> arr f \<and> arr g \<and> C.seq g f"
    proof
      show "arr f \<and> arr g \<and> C.seq g f \<Longrightarrow> seq g f"
        using arr_char dom_char cod_char by (intro seqI, auto)
      show "seq g f \<Longrightarrow> arr f \<and> arr g \<and> C.seq g f"
        apply (elim seqE, auto)
        using inclusion arr_char by auto
    qed

    lemma hom_char:
    shows "hom a b = C.hom a b \<inter> Collect Arr"
    proof
      show "hom a b \<subseteq> C.hom a b \<inter> Collect Arr"
        using in_hom_char by auto
      show "C.hom a b \<inter> Collect Arr \<subseteq> hom a b"
        using arr_char dom_char cod_char by force
    qed

    lemma comp_char:
    shows "g \<cdot> f = (if arr f \<and> arr g \<and> C.seq g f then g \<cdot>\<^sub>C f else C.null)"
      using arr_char comp_def comp_closed C.ext by force

    lemma comp_simp:
    assumes "seq g f"
    shows "g \<cdot> f = g \<cdot>\<^sub>C f"
      using assms comp_char seq_char by metis

    lemma inclusion_preserves_inverse:
    assumes "inverse_arrows f g"
    shows "C.inverse_arrows f g"
      using assms ide_char comp_simp arr_char
      by (intro C.inverse_arrowsI, auto)

    lemma iso_char:
    shows "iso f \<longleftrightarrow> C.iso f \<and> arr f \<and> arr (C.inv f)"
    proof
      assume f: "iso f"
      show "C.iso f \<and> arr f \<and> arr (C.inv f)"
      proof -
        have 1: "inverse_arrows f (inv f)"
          using f inv_is_inverse by auto
        have 2: "C.inverse_arrows f (inv f)"
          using 1 inclusion_preserves_inverse by blast
        moreover have "arr (inv f)"
          using 1 iso_is_arr iso_inv_iso by blast
        moreover have "inv f = C.inv f"
          using 1 2 C.inv_is_inverse C.inverse_arrow_unique by blast
        ultimately show ?thesis using f 2 iso_is_arr by auto
      qed
      next
      assume f: "C.iso f \<and> arr f \<and> arr (C.inv f)"
      show "iso f"
      proof
        have 1: "C.inverse_arrows f (C.inv f)"
          using f C.inv_is_inverse by blast
        show "inverse_arrows f (C.inv f)"
        proof
          have 2: "C.inv f \<cdot> f = C.inv f \<cdot>\<^sub>C f \<and> f \<cdot> C.inv f = f \<cdot>\<^sub>C C.inv f"
            using f 1 comp_char by fastforce
          have 3: "antipar f (C.inv f)"
            using f C.seqE seqI by simp
          show "ide (C.inv f \<cdot> f)"
            using 1 2 3 ide_char apply (elim C.inverse_arrowsE) by simp
          show "ide (f \<cdot> C.inv f)"
            using 1 2 3 ide_char apply (elim C.inverse_arrowsE) by simp
        qed
      qed
    qed

    lemma inv_char:
    assumes "iso f"
    shows "inv f = C.inv f"
    proof -
      have "C.inverse_arrows f (inv f)"
      proof
        have 1: "inverse_arrows f (inv f)"
          using assms iso_char inv_is_inverse by blast
        show "C.ide (inv f \<cdot>\<^sub>C f)"
        proof -
          have "inv f \<cdot> f = inv f \<cdot>\<^sub>C f"
            using assms 1 inv_in_hom iso_char [of f] comp_char [of "inv f" f] seq_char by auto
          thus ?thesis
            using 1 ide_char arr_char by force
        qed
        show "C.ide (f \<cdot>\<^sub>C inv f)"
        proof -
          have "f \<cdot> inv f = f \<cdot>\<^sub>C inv f"
            using assms 1 inv_in_hom iso_char [of f] comp_char [of f "inv f"] seq_char by auto
          thus ?thesis
            using 1 ide_char arr_char by force
        qed
      qed
      thus ?thesis using C.inverse_arrow_unique C.inv_is_inverse by blast
    qed

  end

  sublocale subcategory \<subseteq> category comp
    using is_category by auto

  section "Full Subcategory"

  locale full_subcategory =
    C: category C
    for C :: "'a comp"
    and Ide :: "'a \<Rightarrow> bool" +
    assumes inclusion: "Ide f \<Longrightarrow> C.ide f"

  sublocale full_subcategory \<subseteq> subcategory C "\<lambda>f. C.arr f \<and> Ide (C.dom f) \<and> Ide (C.cod f)"
      by (unfold_locales; simp)

  context full_subcategory
  begin

    text \<open>
      Isomorphisms in a full subcategory are inherited from the ambient category.
\<close>

    lemma iso_char:
    shows "iso f \<longleftrightarrow> arr f \<and> C.iso f"
    proof
      assume f: "iso f"
      obtain g where g: "inverse_arrows f g" using f by blast
      show "arr f \<and> C.iso f"
      proof -
        have "C.inverse_arrows f g"
          using g apply (elim inverse_arrowsE, intro C.inverse_arrowsI)
          using comp_simp ide_char arr_char by auto
        thus ?thesis
          using f iso_is_arr by blast
      qed
      next
      assume f: "arr f \<and> C.iso f"
      obtain g where g: "C.inverse_arrows f g" using f by blast
      have "inverse_arrows f g"
      proof
        show "ide (comp g f)"
          using f g
          by (metis (no_types, lifting) C.seqE C.ide_compE C.inverse_arrowsE
              arr_char dom_simp ide_dom comp_def)
        show "ide (comp f g)"
          using f g C.inverse_arrows_sym [of f g]
          by (metis (no_types, lifting) C.seqE C.ide_compE C.inverse_arrowsE
              arr_char dom_simp ide_dom comp_def)
      qed
      thus "iso f" by auto
    qed

  end

  section "Inclusion Functor"

  text \<open>
    If \<open>S\<close> is a subcategory of \<open>C\<close>, then there is an inclusion functor
    from \<open>S\<close> to \<open>C\<close>.  Inclusion functors are faithful embeddings.
\<close>

  locale inclusion_functor =
    C: category C +
    S: subcategory C Arr
  for C :: "'a comp"
  and Arr :: "'a \<Rightarrow> bool"
  begin

    interpretation "functor" S.comp C S.map
      using S.map_def S.arr_char S.inclusion S.dom_char S.cod_char
            S.dom_closed S.cod_closed S.comp_closed S.arr_char S.comp_char
      apply unfold_locales
          apply auto[4]
      by (elim S.seqE, auto)

    lemma is_functor:
    shows "functor S.comp C S.map" ..

    interpretation faithful_functor S.comp C S.map
      apply unfold_locales by simp

    lemma is_faithful_functor:
    shows "faithful_functor S.comp C S.map" ..

    interpretation embedding_functor S.comp C S.map
      apply unfold_locales by simp

  end

  sublocale inclusion_functor \<subseteq> faithful_functor S.comp C S.map
    using is_faithful_functor by auto
  sublocale inclusion_functor \<subseteq> embedding_functor S.comp C S.map
    using is_embedding_functor by auto

  text \<open>
    The inclusion of a full subcategory is a special case.
    Such functors are fully faithful.
\<close>

  locale full_inclusion_functor =
    C: category C +
    S: full_subcategory C Ide
  for C :: "'a comp"
  and Ide :: "'a \<Rightarrow> bool"

  sublocale full_inclusion_functor \<subseteq>
              inclusion_functor C "\<lambda>f. C.arr f \<and> Ide (C.dom f) \<and> Ide (C.cod f)" ..

  context full_inclusion_functor
  begin

    interpretation full_functor S.comp C S.map
      apply unfold_locales
      using S.ide_in_hom
      by (metis (no_types, lifting) C.in_homE S.arr_char S.in_hom_char S.map_simp)

    lemma is_full_functor:
    shows "full_functor S.comp C S.map" ..

  end

  sublocale full_inclusion_functor \<subseteq> full_functor S.comp C S.map
    using is_full_functor by auto
  sublocale full_inclusion_functor \<subseteq> fully_faithful_functor S.comp C S.map ..

end


(*  Title:       Executable Transitive Closures of Finite Relations
    Author:      Christian Sternagel <c.sternagel@gmail.com>
                 René Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  Christian Sternagel and René Thiemann
    License:     LGPL
*)

section {* Computing Images of Finite Transitive Closures *}

theory Finite_Transitive_Closure_Simprocs
imports Transitive_Closure_List_Impl
begin

lemma rtrancl_Image_eq:
  assumes "r = set r'" and "x = set x'"
  shows "r\<^sup>* `` x = set (rtrancl_list_impl r' x')"
  using assms by (auto simp: rtrancl_list_impl)

lemma trancl_Image_eq:
  assumes "r = set r'" and "x = set x'"
  shows "r\<^sup>+ `` x = set (trancl_list_impl r' x')"
  using assms by (auto simp: trancl_list_impl)

subsection \<open>A Simproc for Computing the Images of Finite Transitive Closures\<close>

ML \<open>
signature FINITE_TRANCL_IMAGE =
sig
  val trancl_simproc : Proof.context -> cterm -> thm option
  val rtrancl_simproc : Proof.context -> cterm -> thm option
end

structure Finite_Trancl_Image : FINITE_TRANCL_IMAGE =
struct

fun eval_tac ctxt =
  let val conv = Code_Runtime.dynamic_holds_conv ctxt
  in CONVERSION (Conv.params_conv ~1 (K (Conv.concl_conv ~1 conv)) ctxt) THEN' resolve_tac ctxt [TrueI] end

fun mk_rtrancl T = Const (@{const_name rtrancl_list_impl}, T);

fun mk_trancl T = Const (@{const_name trancl_list_impl}, T);

fun dest_rtrancl_Image
      (Const (@{const_name Image}, T) $ (Const (@{const_name rtrancl}, _) $ r) $ x) = (T, r, x)
  | dest_rtrancl_Image _ = raise Match

fun dest_trancl_Image
      (Const (@{const_name Image}, T) $ (Const (@{const_name trancl}, _) $ r) $ x) = (T, r, x)
  | dest_trancl_Image _ = raise Match

fun gen_simproc dest mk_const eq_thm ctxt ct =
  let
    val t = Thm.term_of ct;
    val (T, r, x) = t |> dest;
  in
    (*make sure that the relation as well as the given domain are finite sets*)
    (case (try HOLogic.dest_set r, try HOLogic.dest_set x) of
      (SOME xs, SOME ys) =>
        let
          (*types*)
          val setT = T |> dest_funT |> snd |> dest_funT |> fst;
          val eltT = setT |> HOLogic.dest_setT;
          val prodT = HOLogic.mk_prodT (eltT, eltT);
          val prod_listT = HOLogic.listT prodT;
          val listT = HOLogic.listT eltT;

          (*terms*)
          val set = Const (@{const_name List.set}, listT --> setT);
          val const = mk_const (prod_listT --> listT --> listT);
          val r' = HOLogic.mk_list prodT xs;
          val x' = HOLogic.mk_list eltT ys;
          val t' = set $ (const $ r' $ x')
          val u = Value_Command.value ctxt t';
          val eval = (t', u) |> HOLogic.mk_eq |> HOLogic.mk_Trueprop;

          val maybe_rule =
            try (Goal.prove ctxt [] [] eval) (fn {context, ...} => eval_tac context 1);
        in
          (case maybe_rule of
            SOME rule =>
            let
              val conv = (t, t') |> HOLogic.mk_eq |> HOLogic.mk_Trueprop;
              val eq_thm' = Goal.prove ctxt [] [] conv (fn {context = ctxt', ...} =>
                resolve_tac ctxt' [eq_thm] 1 THEN REPEAT (simp_tac ctxt' 1));
            in
              SOME (@{thm HOL.trans} OF [eq_thm', rule] RS @{thm eq_reflection})
            end
          | NONE => NONE)
        end
    | _ => NONE)
  end

val rtrancl_simproc = gen_simproc dest_rtrancl_Image mk_rtrancl @{thm rtrancl_Image_eq}
val trancl_simproc = gen_simproc dest_trancl_Image mk_trancl @{thm trancl_Image_eq}

end
\<close>

simproc_setup rtrancl_Image ("r\<^sup>* `` x") = \<open>K Finite_Trancl_Image.rtrancl_simproc\<close>
simproc_setup trancl_Image  ("r\<^sup>+ `` x") = \<open>K Finite_Trancl_Image.trancl_simproc\<close>

subsection \<open>Example\<close>

text \<open>
  The images of (reflexive) transitive closures are computed by evaluation.
\<close>
lemma
  "{(1::nat, 2), (2, 3), (3, 4), (4, 5)}\<^sup>* `` {1} = {1, 2, 3, 4, 5}"
  "{(1::nat, 2), (2, 3), (3, 4), (4, 5)}\<^sup>+ `` {1} = {2, 3, 4, 5}"
  apply simp_all
  apply auto
done

text \<open>
  Evaluation does not allow for free variables and thus fails in their presence.
\<close>
lemma
  "{(x, y)}\<^sup>* `` {x} = {x, y}"
  oops

end