(* Copyright 2021 (C) Mihails Milehins *)

section\<open>Digraph\label{sec:digraph}\<close>
theory CZH_DG_Digraph
  imports CZH_DG_Introduction
begin

subsection\<open>Background\<close>

named_theorems dg_field_simps

definition Obj :: V where [dg_field_simps]: "Obj = 0"
definition Arr :: V where [dg_field_simps]: "Arr = 1\<^sub>\<nat>"
definition Dom :: V where [dg_field_simps]: "Dom = 2\<^sub>\<nat>"
definition Cod :: V where [dg_field_simps]: "Cod = 3\<^sub>\<nat>"

subsection\<open>Arrow with a domain and a codomain\<close>

text\<open>
The definition of and notation for an arrow with a domain and codomain is
adapted from Chapter I-1 in \<^cite>\<open>"mac_lane_categories_2010"\<close>.
The definition is applicable to digraphs and all other relevant derived
entities, such as semicategories and categories, that are presented in
the subsequent chapters.

In this work, by convention, the definition of an arrow with a domain and a
codomain is nearly always preferred to the explicit use of the domain
and codomain functions for the specification of the fundamental properties
of arrows.
Thus, to say that \<open>f\<close> is an arrow with the domain \<open>a\<close>, it is preferable
to write \<open>f : a \<mapsto>\<^bsub>\<CC>\<^esub> b\<close> (\<open>b\<close> can be assumed to be arbitrary) instead
of \<^term>\<open>f \<in>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>\<close> and \<^term>\<open>\<CC>\<lparr>Dom\<rparr>\<lparr>f\<rparr> = a\<close>.
\<close>

definition is_arr :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> bool"
  where "is_arr \<CC> a b f \<longleftrightarrow> f \<in>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr> \<and> \<CC>\<lparr>Dom\<rparr>\<lparr>f\<rparr> = a \<and> \<CC>\<lparr>Cod\<rparr>\<lparr>f\<rparr> = b"

syntax "_is_arr" :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> bool" (\<open>_ : _ \<mapsto>\<index> _\<close> [51, 51, 51] 51)
translations "f : a \<mapsto>\<^bsub>\<CC>\<^esub> b" \<rightleftharpoons> "CONST is_arr \<CC> a b f"

text\<open>Rules.\<close>

mk_ide is_arr_def
  |intro is_arrI|
  |dest is_arrD[dest]|
  |elim is_arrE[elim]|

lemmas [dg_shared_cs_intros, dg_cs_intros] = is_arrD(1)
lemmas [dg_shared_cs_simps, dg_cs_simps] = is_arrD(2,3)

subsection\<open>\<open>Hom\<close>-set\<close>

text\<open>See Chapter I-8 in \<^cite>\<open>"mac_lane_categories_2010"\<close>.\<close>

abbreviation Hom :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V"
  where "Hom \<CC> a b \<equiv> set {f. f : a \<mapsto>\<^bsub>\<CC>\<^esub> b}"

lemma small_Hom[simp]: "small {f. f : a \<mapsto>\<^bsub>\<CC>\<^esub> b}" unfolding is_arr_def by simp

text\<open>Rules.\<close>

lemma HomI[dg_shared_cs_intros, dg_cs_intros]:
  assumes "f : a \<mapsto>\<^bsub>\<CC>\<^esub> b"
  shows "f \<in>\<^sub>\<circ> Hom \<CC> a b"
  using assms by auto

lemma in_Hom_iff[dg_shared_cs_simps, dg_cs_simps]:
  "f \<in>\<^sub>\<circ> Hom \<CC> a b \<longleftrightarrow> f : a \<mapsto>\<^bsub>\<CC>\<^esub> b"
  by simp

text\<open>
The \<open>Hom\<close>-sets in a given digraph are pairwise disjoint. This property
was exposed as Axiom (v) in an alternative definition of a category presented
in Chapter I-8 in \<^cite>\<open>"mac_lane_categories_2010"\<close>. Within the scope of the
definitional framework employed in this study, this property holds
unconditionally.
\<close>

lemma Hom_vdisjnt:
  assumes "a \<noteq> a' \<or> b \<noteq> b'"
    and "a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
    and "a' \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
    and "b \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
    and "b' \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
  shows "vdisjnt (Hom \<CC> a b) (Hom \<CC> a' b')"
proof(intro vdisjntI, unfold in_Hom_iff)
  fix g f assume "g : a \<mapsto>\<^bsub>\<CC>\<^esub> b" and "f : a' \<mapsto>\<^bsub>\<CC>\<^esub> b'"
  then have "g \<in>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>"
    and "f \<in>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>"
    and "\<CC>\<lparr>Dom\<rparr>\<lparr>g\<rparr> = a"
    and "\<CC>\<lparr>Cod\<rparr>\<lparr>g\<rparr> = b"
    and "\<CC>\<lparr>Dom\<rparr>\<lparr>f\<rparr> = a'"
    and "\<CC>\<lparr>Cod\<rparr>\<lparr>f\<rparr> = b'"
    by (cs_concl cs_shallow cs_simp: dg_cs_simps cs_intro: dg_cs_intros)+
  with assms(1) have "\<CC>\<lparr>Dom\<rparr>\<lparr>g\<rparr> \<noteq> \<CC>\<lparr>Dom\<rparr>\<lparr>f\<rparr> \<or> \<CC>\<lparr>Cod\<rparr>\<lparr>g\<rparr> \<noteq> \<CC>\<lparr>Cod\<rparr>\<lparr>f\<rparr>" by auto
  then show "g \<noteq> f" by clarsimp
qed

subsection\<open>Digraph: background information\<close>

text\<open>
The definition of a digraph that is employed in this work is similar
to the definition of a \<open>directed graph\<close> presented in Chapter I-2 in
\<^cite>\<open>"mac_lane_categories_2010"\<close>. However, there are notable differences.
More specifically, the definition is parameterized by a limit ordinal \<open>\<alpha>\<close>,
such that \<open>\<omega> < \<alpha>\<close>; the set of objects is assumed to be a subset
of the set \<open>V\<^sub>\<alpha>\<close> in the von Neumann hierarchy of sets (e.g.,
see \<^cite>\<open>"takeuti_introduction_1971"\<close>). Such digraphs are called \<open>\<alpha>\<close>-\<open>digraphs\<close>
to make the dependence on the parameter \<open>\<alpha>\<close> explicit.\footnote{
The prefix ``\<open>\<alpha>\<close>-'' may be omitted whenever it is possible to infer the value
of \<open>\<alpha>\<close> from the context. This applies not only to the digraphs, but all
other entities that are parameterized by a limit ordinal \<open>\<alpha>\<close> such that
\<open>\<omega> < \<alpha>\<close>.} This definition was inspired by the ideas expressed in
\<^cite>\<open>"feferman_set-theoretical_1969"\<close>, \<^cite>\<open>"sica_doing_2006"\<close> and
\<^cite>\<open>"shulman_set_2008"\<close>.

In ZFC in HOL, the predicate \<^term>\<open>small\<close> is used for distinguishing the
terms of any type of the form \<^typ>\<open>'a set\<close> that are isomorphic to elements
of a term of the type \<^typ>\<open>V\<close> (the elements can be exposed via the predicate
\<^const>\<open>elts\<close>). Thus, the collection of the elements associated with any term of
the type \<^typ>\<open>V\<close> (e.g., \<^term>\<open>elts (a::V)\<close>) is always small
(see the theorem @{thm [source] small_elts} in \<^cite>\<open>"paulson_zermelo_2019"\<close>).
Therefore, in this study, in an attempt to avoid confusion, the term ``small''
is never used to refer to digraphs.
Instead, a new terminology is introduced in this body of work.

Thus, in this work, an \<open>\<alpha>\<close>-digraph is a tiny \<open>\<alpha>\<close>-digraph if and only if
the set of its objects and the set of its arrows both belong to the set \<open>V\<^sub>\<alpha>\<close>.
This notion is similar to the notion of a small category in the sense of
the definition employed in Chapter I-6 in \<^cite>\<open>"mac_lane_categories_2010"\<close>,
if it is assumed that the ``smallness'' is determined with respect to the
set \<open>V\<^sub>\<alpha>\<close> instead of the universe \<open>U\<close>. Also, in what follows, any member of
the set \<open>V\<^sub>\<alpha>\<close> will be referred to as an \<open>\<alpha>\<close>-tiny set.

All of the large (i.e. non-tiny) digraphs
that are considered within the scope of this work have a slightly
unconventional condition associated with the size of their \<open>Hom\<close>-sets.
This condition implies that all \<open>Hom\<close>-sets of a digraph
are tiny, but it is not equivalent to
all \<open>Hom\<close>-sets being tiny. The condition was introduced in an attempt to
resolve some of the issues related to the lack of an analogue of the
Axiom Schema of Replacement closed with respect to \<open>V\<^sub>\<alpha>\<close>.
\<close>

subsection\<open>Digraph: definition and elementary properties\<close>

locale digraph = \<Z> \<alpha> + vfsequence \<CC> + Dom: vsv \<open>\<CC>\<lparr>Dom\<rparr>\<close> + Cod: vsv \<open>\<CC>\<lparr>Cod\<rparr>\<close>
  for \<alpha> \<CC> +
  assumes dg_length[dg_cs_simps]: "vcard \<CC> = 4\<^sub>\<nat>"
    and dg_Dom_vdomain[dg_cs_simps]: "\<D>\<^sub>\<circ> (\<CC>\<lparr>Dom\<rparr>) = \<CC>\<lparr>Arr\<rparr>"
    and dg_Dom_vrange: "\<R>\<^sub>\<circ> (\<CC>\<lparr>Dom\<rparr>) \<subseteq>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
    and dg_Cod_vdomain[dg_cs_simps]: "\<D>\<^sub>\<circ> (\<CC>\<lparr>Cod\<rparr>) = \<CC>\<lparr>Arr\<rparr>"
    and dg_Cod_vrange: "\<R>\<^sub>\<circ> (\<CC>\<lparr>Cod\<rparr>) \<subseteq>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
    and dg_Obj_vsubset_Vset: "\<CC>\<lparr>Obj\<rparr> \<subseteq>\<^sub>\<circ> Vset \<alpha>"
    and dg_Hom_vifunion_in_Vset[dg_cs_intros]:
      "\<lbrakk> A \<subseteq>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>; B \<subseteq>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>; A \<in>\<^sub>\<circ> Vset \<alpha>; B \<in>\<^sub>\<circ> Vset \<alpha> \<rbrakk> \<Longrightarrow>
        (\<Union>\<^sub>\<circ>a\<in>\<^sub>\<circ>A. \<Union>\<^sub>\<circ>b\<in>\<^sub>\<circ>B. Hom \<CC> a b) \<in>\<^sub>\<circ> Vset \<alpha>"

lemmas [dg_cs_simps] =
  digraph.dg_length
  digraph.dg_Dom_vdomain
  digraph.dg_Cod_vdomain

lemmas [dg_cs_intros] =
  digraph.dg_Hom_vifunion_in_Vset

text\<open>Rules.\<close>

lemma (in digraph) digraph_axioms'[dg_cs_intros]:
  assumes "\<alpha>' = \<alpha>"
  shows "digraph \<alpha>' \<CC>"
  unfolding assms by (rule digraph_axioms)

mk_ide rf digraph_def[unfolded digraph_axioms_def]
  |intro digraphI|
  |dest digraphD[dest]|
  |elim digraphE[elim]|

text\<open>Elementary properties.\<close>

lemma dg_eqI:
  assumes "digraph \<alpha> \<AA>"
    and "digraph \<alpha> \<BB>"
    and "\<AA>\<lparr>Obj\<rparr> = \<BB>\<lparr>Obj\<rparr>"
    and "\<AA>\<lparr>Arr\<rparr> = \<BB>\<lparr>Arr\<rparr>"
    and "\<AA>\<lparr>Dom\<rparr> = \<BB>\<lparr>Dom\<rparr>"
    and "\<AA>\<lparr>Cod\<rparr> = \<BB>\<lparr>Cod\<rparr>"
  shows "\<AA> = \<BB>"
proof-
  interpret \<AA>: digraph \<alpha> \<AA> by (rule assms(1))
  interpret \<BB>: digraph \<alpha> \<BB> by (rule assms(2))
  show ?thesis
  proof(rule vsv_eqI)
    have dom_lhs: "\<D>\<^sub>\<circ> \<AA> = 4\<^sub>\<nat>"
      by (cs_concl cs_shallow cs_simp: V_cs_simps dg_cs_simps)
    show "a \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> \<AA> \<Longrightarrow> \<AA>\<lparr>a\<rparr> = \<BB>\<lparr>a\<rparr>" for a
      by (unfold dom_lhs, elim_in_numeral, insert assms)
        (auto simp: dg_field_simps)
  qed
    (
      cs_concl cs_shallow
        cs_simp: V_cs_simps dg_cs_simps cs_intro: V_cs_intros
    )+
qed

lemma (in digraph) dg_def: "\<CC> = [\<CC>\<lparr>Obj\<rparr>, \<CC>\<lparr>Arr\<rparr>, \<CC>\<lparr>Dom\<rparr>, \<CC>\<lparr>Cod\<rparr>]\<^sub>\<circ>"
proof(rule vsv_eqI)
  have dom_lhs: "\<D>\<^sub>\<circ> \<CC> = 4\<^sub>\<nat>"
    by (cs_concl cs_shallow cs_simp: V_cs_simps dg_cs_simps)
  have dom_rhs: "\<D>\<^sub>\<circ> [\<CC>\<lparr>Obj\<rparr>, \<CC>\<lparr>Arr\<rparr>, \<CC>\<lparr>Dom\<rparr>, \<CC>\<lparr>Cod\<rparr>]\<^sub>\<circ> = 4\<^sub>\<nat>"
    by (simp add: nat_omega_simps)
  then show "\<D>\<^sub>\<circ> \<CC> = \<D>\<^sub>\<circ> [\<CC>\<lparr>Obj\<rparr>, \<CC>\<lparr>Arr\<rparr>, \<CC>\<lparr>Dom\<rparr>, \<CC>\<lparr>Cod\<rparr>]\<^sub>\<circ>"
    unfolding dom_lhs dom_rhs by simp
  show "a \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> \<CC> \<Longrightarrow> \<CC>\<lparr>a\<rparr> = [\<CC>\<lparr>Obj\<rparr>, \<CC>\<lparr>Arr\<rparr>, \<CC>\<lparr>Dom\<rparr>, \<CC>\<lparr>Cod\<rparr>]\<^sub>\<circ>\<lparr>a\<rparr>" for a
    by (unfold dom_lhs, elim_in_numeral, unfold dg_field_simps)
      (simp_all add: nat_omega_simps)
qed (auto simp: vsv_axioms)

lemma (in digraph) dg_Obj_if_Dom_vrange:
  assumes "a \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (\<CC>\<lparr>Dom\<rparr>)"
  shows "a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
  using assms dg_Dom_vrange by auto

lemma (in digraph) dg_Obj_if_Cod_vrange:
  assumes "a \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (\<CC>\<lparr>Cod\<rparr>)"
  shows "a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
  using assms dg_Cod_vrange by auto

lemma (in digraph) dg_is_arrD:
  assumes "f : a \<mapsto>\<^bsub>\<CC>\<^esub> b"
  shows "f \<in>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>"
    and "a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
    and "b \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
    and "\<CC>\<lparr>Dom\<rparr>\<lparr>f\<rparr> = a"
    and "\<CC>\<lparr>Cod\<rparr>\<lparr>f\<rparr> = b"
proof-
  from assms show prems: "f \<in>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>"
    and fa[symmetric]: "\<CC>\<lparr>Dom\<rparr>\<lparr>f\<rparr> = a"
    and fb[symmetric]: "\<CC>\<lparr>Cod\<rparr>\<lparr>f\<rparr> = b"
    by (cs_concl cs_shallow cs_simp: dg_cs_simps cs_intro: dg_cs_intros)+
  from digraph_axioms prems have "f \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (\<CC>\<lparr>Dom\<rparr>)" "f \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (\<CC>\<lparr>Cod\<rparr>)"
    by (cs_concl cs_shallow cs_simp: dg_cs_simps)+
  with assms show "a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" "b \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
    by
      (
        cs_concl
          cs_intro: dg_Obj_if_Dom_vrange dg_Obj_if_Cod_vrange V_cs_intros
          cs_simp: fa fb
      )+
qed

lemmas [dg_cs_intros] = digraph.dg_is_arrD(1-3)

lemma (in digraph) dg_is_arrE[elim]:
  assumes "f : a \<mapsto>\<^bsub>\<CC>\<^esub> b"
  obtains "f \<in>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>"
    and "a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
    and "b \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
    and "\<CC>\<lparr>Dom\<rparr>\<lparr>f\<rparr> = a"
    and "\<CC>\<lparr>Cod\<rparr>\<lparr>f\<rparr> = b"
  using assms by (blast dest: dg_is_arrD)

lemma (in digraph) dg_in_ArrE[elim]:
  assumes "f \<in>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>"
  obtains a b where "f : a \<mapsto>\<^bsub>\<CC>\<^esub> b" and "a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" and "b \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
  using assms by (auto dest: dg_is_arrD(2,3) is_arrI)

lemma (in digraph) dg_Hom_in_Vset[dg_cs_intros]:
  assumes "a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" and "b \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
  shows "Hom \<CC> a b \<in>\<^sub>\<circ> Vset \<alpha>"
proof-
  let ?A = \<open>set {a}\<close> and ?B = \<open>set {b}\<close>
  from assms have A: "?A \<subseteq>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" and B: "?B \<subseteq>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" by auto
  from assms dg_Obj_vsubset_Vset have "a \<in>\<^sub>\<circ> Vset \<alpha>" and "b \<in>\<^sub>\<circ> Vset \<alpha>" by auto
  then have a: "set {a} \<in>\<^sub>\<circ> Vset \<alpha>" and b: "set {b} \<in>\<^sub>\<circ> Vset \<alpha>"
    by (metis Axiom_of_Pairing insert_absorb2)+
  from dg_Hom_vifunion_in_Vset[OF A B a b] show "Hom \<CC> a b \<in>\<^sub>\<circ> Vset \<alpha>" by simp
qed

lemmas [dg_cs_intros] = digraph.dg_Hom_in_Vset

text\<open>Size.\<close>

lemma (in digraph) dg_Arr_vsubset_Vset: "\<CC>\<lparr>Arr\<rparr> \<subseteq>\<^sub>\<circ> Vset \<alpha>"
proof(intro vsubsetI)
  fix f assume "f \<in>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>"
  then obtain a b
    where f: "f : a \<mapsto>\<^bsub>\<CC>\<^esub> b" and a: "a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" and b: "b \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
    by blast
  show "f \<in>\<^sub>\<circ> Vset \<alpha>"
    by (rule Vset_trans, rule HomI[OF f], rule dg_Hom_in_Vset[OF a b])
qed

lemma (in digraph) dg_Dom_vsubset_Vset: "\<CC>\<lparr>Dom\<rparr> \<subseteq>\<^sub>\<circ> Vset \<alpha>"
  by
    (
      rule Dom.vbrelation_Limit_vsubset_VsetI,
      unfold dg_cs_simps,
      insert dg_Dom_vrange dg_Obj_vsubset_Vset
    )
    (auto intro!: dg_Arr_vsubset_Vset)

lemma (in digraph) dg_Cod_vsubset_Vset: "\<CC>\<lparr>Cod\<rparr> \<subseteq>\<^sub>\<circ> Vset \<alpha>"
  by
    (
      rule Cod.vbrelation_Limit_vsubset_VsetI,
      unfold dg_cs_simps,
      insert dg_Cod_vrange dg_Obj_vsubset_Vset
    )
    (auto intro!: dg_Arr_vsubset_Vset)

lemma (in digraph) dg_digraph_in_Vset_4: "\<CC> \<in>\<^sub>\<circ> Vset (\<alpha> + 4\<^sub>\<nat>)"
proof-
  note [folded VPow_iff, folded Vset_succ[OF Ord_\<alpha>], dg_cs_intros] =
    dg_Obj_vsubset_Vset
    dg_Arr_vsubset_Vset
    dg_Dom_vsubset_Vset
    dg_Cod_vsubset_Vset
  show ?thesis
    by (subst dg_def, succ_of_numeral)
      (
        cs_concl
          cs_simp: plus_V_succ_right V_cs_simps
          cs_intro: dg_cs_intros V_cs_intros
      )
qed

lemma (in digraph) dg_Obj_in_Vset:
  assumes "\<Z> \<beta>" and "\<alpha> \<in>\<^sub>\<circ> \<beta>"
  shows "\<CC>\<lparr>Obj\<rparr> \<in>\<^sub>\<circ> Vset \<beta>"
  using assms dg_Obj_vsubset_Vset Vset_in_mono by auto

lemma (in digraph) dg_in_Obj_in_Vset[dg_cs_intros]:
  assumes "a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
  shows "a \<in>\<^sub>\<circ> Vset \<alpha>"
  using assms dg_Obj_vsubset_Vset by auto

lemma (in digraph) dg_Arr_in_Vset:
  assumes "\<Z> \<beta>" and "\<alpha> \<in>\<^sub>\<circ> \<beta>"
  shows "\<CC>\<lparr>Arr\<rparr> \<in>\<^sub>\<circ> Vset \<beta>"
  using assms dg_Arr_vsubset_Vset Vset_in_mono by auto

lemma (in digraph) dg_in_Arr_in_Vset[dg_cs_intros]:
  assumes "a \<in>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>"
  shows "a \<in>\<^sub>\<circ> Vset \<alpha>"
  using assms dg_Arr_vsubset_Vset by auto

lemma (in digraph) dg_Dom_in_Vset:
  assumes "\<Z> \<beta>" and "\<alpha> \<in>\<^sub>\<circ> \<beta>"
  shows "\<CC>\<lparr>Dom\<rparr> \<in>\<^sub>\<circ> Vset \<beta>"
  by (meson assms dg_Dom_vsubset_Vset Vset_in_mono vsubset_in_VsetI)

lemma (in digraph) dg_Cod_in_Vset:
  assumes "\<Z> \<beta>" and "\<alpha> \<in>\<^sub>\<circ> \<beta>"
  shows "\<CC>\<lparr>Cod\<rparr> \<in>\<^sub>\<circ> Vset \<beta>"
  by (meson assms dg_Cod_vsubset_Vset Vset_in_mono vsubset_in_VsetI)

lemma (in digraph) dg_in_Vset:
  assumes "\<Z> \<beta>" and "\<alpha> \<in>\<^sub>\<circ> \<beta>"
  shows "\<CC> \<in>\<^sub>\<circ> Vset \<beta>"
proof-
  interpret \<beta>: \<Z> \<beta> by (rule assms(1))
  note [dg_cs_intros] =
    dg_Obj_in_Vset dg_Arr_in_Vset dg_Dom_in_Vset dg_Cod_in_Vset
  from assms(2) show ?thesis
    by (subst dg_def)
      (cs_concl cs_shallow cs_intro: dg_cs_intros V_cs_intros)
 qed

lemma (in digraph) dg_digraph_if_ge_Limit:
  assumes "\<Z> \<beta>" and "\<alpha> \<in>\<^sub>\<circ> \<beta>"
  shows "digraph \<beta> \<CC>"
proof(rule digraphI)
  show "vfsequence \<CC>" by (simp add: vfsequence_axioms)
  show "\<CC>\<lparr>Obj\<rparr> \<subseteq>\<^sub>\<circ> Vset \<beta>"
    by (rule vsubsetI)
      (meson Vset_in_mono Vset_trans assms(2) dg_Obj_vsubset_Vset vsubsetE)
  fix A B assume "A \<subseteq>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" "B \<subseteq>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" "A \<in>\<^sub>\<circ> Vset \<beta>" "B \<in>\<^sub>\<circ> Vset \<beta>"
  then have "(\<Union>\<^sub>\<circ>a\<in>\<^sub>\<circ>A. \<Union>\<^sub>\<circ>b\<in>\<^sub>\<circ>B. Hom \<CC> a b) \<subseteq>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>" by auto
  moreover note dg_Arr_vsubset_Vset
  moreover have "Vset \<alpha> \<in>\<^sub>\<circ> Vset \<beta>" by (simp add: Vset_in_mono assms(2))
  ultimately show "(\<Union>\<^sub>\<circ>a\<in>\<^sub>\<circ>A. \<Union>\<^sub>\<circ>b\<in>\<^sub>\<circ>B. Hom \<CC> a b) \<in>\<^sub>\<circ> Vset \<beta>" by auto
qed (auto simp: assms(1) dg_Dom_vrange dg_Cod_vrange dg_cs_simps)

lemma small_digraph[simp]: "small {\<CC>. digraph \<alpha> \<CC>}"
proof(cases \<open>\<Z> \<alpha>\<close>)
  case True
  with digraph.dg_in_Vset show ?thesis
    by (intro down[of _ \<open>Vset (\<alpha> + \<omega>)\<close>] subsetI)
      (auto simp: \<Z>.\<Z>_Limit_\<alpha>\<omega> \<Z>.\<Z>_\<omega>_\<alpha>\<omega> \<Z>.intro \<Z>.\<Z>_\<alpha>_\<alpha>\<omega>)
next
  case False
  then have "{\<CC>. digraph \<alpha> \<CC>} = {}" by auto
  then show ?thesis by simp
qed

lemma (in \<Z>) digraphs_in_Vset:
  assumes "\<Z> \<beta>" and "\<alpha> \<in>\<^sub>\<circ> \<beta>"
  shows "set {\<CC>. digraph \<alpha> \<CC>} \<in>\<^sub>\<circ> Vset \<beta>"
proof(rule vsubset_in_VsetI)
  interpret \<beta>: \<Z> \<beta> by (rule assms(1))
  show "set {\<CC>. digraph \<alpha> \<CC>} \<subseteq>\<^sub>\<circ> Vset (\<alpha> + 4\<^sub>\<nat>)"
  proof(intro vsubsetI)
    fix \<CC> assume "\<CC> \<in>\<^sub>\<circ> set {\<CC>. digraph \<alpha> \<CC>}"
    then interpret digraph \<alpha> \<CC> by simp
    show "\<CC> \<in>\<^sub>\<circ> Vset (\<alpha> + 4\<^sub>\<nat>)"
      unfolding VPow_iff by (rule dg_digraph_in_Vset_4)
  qed
  from assms(2) show "Vset (\<alpha> + 4\<^sub>\<nat>) \<in>\<^sub>\<circ> Vset \<beta>"
    by (cs_concl cs_shallow cs_intro: V_cs_intros Ord_cs_intros)
qed

lemma digraph_if_digraph:
  assumes "digraph \<beta> \<CC>"
    and "\<Z> \<alpha>"
    and "\<CC>\<lparr>Obj\<rparr> \<subseteq>\<^sub>\<circ> Vset \<alpha>"
    and "\<And>A B. \<lbrakk> A \<subseteq>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>; B \<subseteq>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>; A \<in>\<^sub>\<circ> Vset \<alpha>; B \<in>\<^sub>\<circ> Vset \<alpha> \<rbrakk> \<Longrightarrow>
      (\<Union>\<^sub>\<circ>a\<in>\<^sub>\<circ>A. \<Union>\<^sub>\<circ>b\<in>\<^sub>\<circ>B. Hom \<CC> a b) \<in>\<^sub>\<circ> Vset \<alpha>"
  shows "digraph \<alpha> \<CC>"
proof-
  interpret digraph \<beta> \<CC> by (rule assms(1))
  interpret \<alpha>: \<Z> \<alpha> by (rule assms(2))
  show ?thesis
  proof(intro digraphI)
    show "vfsequence \<CC>" by (simp add: vfsequence_axioms)
    show "(\<Union>\<^sub>\<circ>a\<in>\<^sub>\<circ>A. \<Union>\<^sub>\<circ>b\<in>\<^sub>\<circ>B. Hom \<CC> a b) \<in>\<^sub>\<circ> Vset \<alpha>"
      if "A \<subseteq>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" "B \<subseteq>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" "A \<in>\<^sub>\<circ> Vset \<alpha>" "B \<in>\<^sub>\<circ> Vset \<alpha>" for A B
      by (rule assms(4)[OF that])
  qed (auto simp: assms(3) dg_Cod_vrange dg_cs_simps intro!: dg_Dom_vrange)
qed

text\<open>Further properties.\<close>

lemma (in digraph) dg_Dom_app_in_Obj:
  assumes "f \<in>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>"
  shows "\<CC>\<lparr>Dom\<rparr>\<lparr>f\<rparr> \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
  using assms dg_Dom_vrange by (auto simp: Dom.vsv_vimageI2)

lemma (in digraph) dg_Cod_app_in_Obj:
  assumes "f \<in>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>"
  shows "\<CC>\<lparr>Cod\<rparr>\<lparr>f\<rparr> \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
  using assms dg_Cod_vrange by (auto simp: Cod.vsv_vimageI2)

lemma (in digraph) dg_Arr_vempty_if_Obj_vempty:
  assumes "\<CC>\<lparr>Obj\<rparr> = 0"
  shows "\<CC>\<lparr>Arr\<rparr> = 0"
  by (metis assms eq0_iff dg_Cod_app_in_Obj)

lemma (in digraph) dg_Dom_vempty_if_Arr_vempty:
  assumes "\<CC>\<lparr>Arr\<rparr> = 0"
  shows "\<CC>\<lparr>Dom\<rparr> = 0"
  using assms Dom.vdomain_vrange_is_vempty
  by (auto intro: Dom.vsv_vrange_vempty simp: dg_cs_simps)

lemma (in digraph) dg_Cod_vempty_if_Arr_vempty:
  assumes "\<CC>\<lparr>Arr\<rparr> = 0"
  shows "\<CC>\<lparr>Cod\<rparr> = 0"
  using assms Cod.vdomain_vrange_is_vempty
  by (auto intro: Cod.vsv_vrange_vempty simp: dg_cs_simps)

subsection\<open>Opposite digraph\<close>

subsubsection\<open>Definition and elementary properties\<close>

text\<open>See Chapter II-2 in \<^cite>\<open>"mac_lane_categories_2010"\<close>.\<close>

definition op_dg :: "V \<Rightarrow> V"
  where "op_dg \<CC> = [\<CC>\<lparr>Obj\<rparr>, \<CC>\<lparr>Arr\<rparr>, \<CC>\<lparr>Cod\<rparr>, \<CC>\<lparr>Dom\<rparr>]\<^sub>\<circ>"

text\<open>Components.\<close>

lemma op_dg_components[dg_op_simps]:
  shows "op_dg \<CC>\<lparr>Obj\<rparr> = \<CC>\<lparr>Obj\<rparr>"
    and "op_dg \<CC>\<lparr>Arr\<rparr> = \<CC>\<lparr>Arr\<rparr>"
    and "op_dg \<CC>\<lparr>Dom\<rparr> = \<CC>\<lparr>Cod\<rparr>"
    and "op_dg \<CC>\<lparr>Cod\<rparr> = \<CC>\<lparr>Dom\<rparr>"
  unfolding op_dg_def dg_field_simps by (auto simp: nat_omega_simps)

lemma op_dg_component_intros[dg_op_intros]:
  shows "a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr> \<Longrightarrow> a \<in>\<^sub>\<circ> op_dg \<CC>\<lparr>Obj\<rparr>"
    and "f \<in>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr> \<Longrightarrow> f \<in>\<^sub>\<circ> op_dg \<CC>\<lparr>Arr\<rparr>"
  unfolding dg_op_simps by simp_all

text\<open>Elementary properties.\<close>

lemma op_dg_is_arr[dg_op_simps]: "f : b \<mapsto>\<^bsub>op_dg \<CC>\<^esub> a \<longleftrightarrow> f : a \<mapsto>\<^bsub>\<CC>\<^esub> b"
  unfolding dg_op_simps is_arr_def by auto

lemmas [dg_op_intros] = op_dg_is_arr[THEN iffD2]

lemma op_dg_Hom[dg_op_simps]: "Hom (op_dg \<CC>) a b = Hom \<CC> b a"
  unfolding dg_op_simps by simp

subsubsection\<open>Further properties\<close>

lemma (in digraph) digraph_op[dg_op_intros]: "digraph \<alpha> (op_dg \<CC>)"
proof(intro digraphI, unfold op_dg_components dg_op_simps)
  show "vfsequence (op_dg \<CC>)" unfolding op_dg_def by simp
  show "vcard (op_dg \<CC>) = 4\<^sub>\<nat>"
    unfolding op_dg_def by (simp add: nat_omega_simps)
  fix A B assume "A \<subseteq>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" "B \<subseteq>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" "A \<in>\<^sub>\<circ> Vset \<alpha>" "B \<in>\<^sub>\<circ> Vset \<alpha>"
  then show "\<Union>\<^sub>\<circ>((\<lambda>a\<in>\<^sub>\<circ>A. \<Union>\<^sub>\<circ>((\<lambda>aa\<in>\<^sub>\<circ>B. Hom \<CC> aa a) `\<^sub>\<circ> B)) `\<^sub>\<circ> A) \<in>\<^sub>\<circ> Vset \<alpha>"
    by (subst vifunion_vifunion_flip) (intro dg_Hom_vifunion_in_Vset)
qed (auto simp: dg_Dom_vrange dg_Cod_vrange dg_Obj_vsubset_Vset dg_cs_simps)

lemmas digraph_op[dg_op_intros] = digraph.digraph_op

lemma (in digraph) dg_op_dg_op_dg[dg_op_simps]: "op_dg (op_dg \<CC>) = \<CC>"
  by (rule dg_eqI[of \<alpha>], unfold dg_op_simps)
    (simp_all add: digraph_axioms digraph.digraph_op digraph_op)

lemmas dg_op_dg_op_dg[dg_op_simps] = digraph.dg_op_dg_op_dg

lemma eq_op_dg_iff[dg_op_simps]:
  assumes "digraph \<alpha> \<AA>" and "digraph \<alpha> \<BB>"
  shows "op_dg \<AA> = op_dg \<BB> \<longleftrightarrow> \<AA> = \<BB>"
proof
  interpret \<AA>: digraph \<alpha> \<AA> by (rule assms(1))
  interpret \<BB>: digraph \<alpha> \<BB> by (rule assms(2))
  assume prems: "op_dg \<AA> = op_dg \<BB>"
  show "\<AA> = \<BB>"
  proof(rule dg_eqI[of \<alpha>])
    from prems show
      "\<AA>\<lparr>Obj\<rparr> = \<BB>\<lparr>Obj\<rparr>" "\<AA>\<lparr>Arr\<rparr> = \<BB>\<lparr>Arr\<rparr>" "\<AA>\<lparr>Dom\<rparr> = \<BB>\<lparr>Dom\<rparr>" "\<AA>\<lparr>Cod\<rparr> = \<BB>\<lparr>Cod\<rparr>"
      by (metis prems \<AA>.dg_op_dg_op_dg \<BB>.dg_op_dg_op_dg)+
  qed (simp_all add: assms)
qed auto

text\<open>\newpage\<close>

end


subsection\<open>Semantics\<close>
theory Sema
imports Formulas
begin

type_synonym 'a valuation = "'a \<Rightarrow> bool"
text\<open>The implicit statement here is that an assignment or valuation is always defined on all atoms (because HOL is a total logic).
Thus, there are no unsuitable assignments.\<close>

primrec formula_semantics :: "'a valuation \<Rightarrow> 'a formula \<Rightarrow> bool" (infix "\<Turnstile>" 51) where
"\<A> \<Turnstile> Atom k = \<A> k" |
"_ \<Turnstile> \<bottom> = False" |
"\<A> \<Turnstile> Not F = (\<not> \<A> \<Turnstile> F)" |
"\<A> \<Turnstile> And F G = (\<A> \<Turnstile> F \<and> \<A> \<Turnstile> G)" |
"\<A> \<Turnstile> Or F G = (\<A> \<Turnstile> F \<or> \<A> \<Turnstile> G)" |
"\<A> \<Turnstile> Imp F G = (\<A> \<Turnstile> F \<longrightarrow> \<A> \<Turnstile> G)"

abbreviation valid ("\<Turnstile> _" 51) where
"\<Turnstile> F \<equiv> \<forall>A. A \<Turnstile> F"

lemma irrelevant_atom[simp]: "A \<notin> atoms F \<Longrightarrow> (\<A>(A := V)) \<Turnstile> F \<longleftrightarrow> \<A> \<Turnstile> F"
  by (induction F; simp)
lemma relevant_atoms_same_semantics: "\<forall>k \<in> atoms F. \<A>\<^sub>1 k = \<A>\<^sub>2 k \<Longrightarrow> \<A>\<^sub>1 \<Turnstile> F \<longleftrightarrow> \<A>\<^sub>2 \<Turnstile> F"
  by(induction F; simp)

context begin
text\<open>Just a definition more similar to~\<^cite>\<open>\<open>p. 5\<close> in "schoening1987logik"\<close>.
Unfortunately, using this as the main definition would get in the way of automated reasoning all the time.\<close>
private primrec formula_semantics_alt where
"formula_semantics_alt \<A> (Atom k) = \<A> k" |
"formula_semantics_alt \<A> (Bot) = False" |
"formula_semantics_alt \<A> (Not a) = (if formula_semantics_alt \<A> a then False else True)" |
"formula_semantics_alt \<A> (And a b) = (if formula_semantics_alt \<A> a then formula_semantics_alt \<A> b else False)" |
"formula_semantics_alt \<A> (Or a b) = (if formula_semantics_alt \<A> a then True else formula_semantics_alt \<A> b)" |
"formula_semantics_alt \<A> (Imp a b) = (if formula_semantics_alt \<A> a then formula_semantics_alt \<A> b else True)"
private lemma "formula_semantics_alt \<A> F \<longleftrightarrow> \<A> \<Turnstile> F"
  by(induction F; simp)

text\<open>If you fancy a definition more similar to~\<^cite>\<open>\<open>p. 39\<close> in "gallier2015logic"\<close>,
this is probably the closest you can go without going incredibly ugly.\<close>
private primrec formula_semantics_tt where
"formula_semantics_tt \<A> (Atom k) = \<A> k" |
"formula_semantics_tt \<A> (Bot) = False" |
"formula_semantics_tt \<A> (Not a) = (case formula_semantics_tt \<A> a of True \<Rightarrow> False | False \<Rightarrow> True)" |
"formula_semantics_tt \<A> (And a b) = (case (formula_semantics_tt \<A> a, formula_semantics_tt \<A> b) of
  (False, False) \<Rightarrow> False
| (False, True) \<Rightarrow> False
| (True, False) \<Rightarrow> False
| (True, True) \<Rightarrow> True)" |
"formula_semantics_tt \<A> (Or a b) = (case (formula_semantics_tt \<A> a, formula_semantics_tt \<A> b) of
  (False, False) \<Rightarrow> False
| (False, True) \<Rightarrow> True
| (True, False) \<Rightarrow> True
| (True, True) \<Rightarrow> True)" |
"formula_semantics_tt \<A> (Imp a b) = (case (formula_semantics_tt \<A> a, formula_semantics_tt \<A> b) of
  (False, False) \<Rightarrow> True
| (False, True) \<Rightarrow> True
| (True, False) \<Rightarrow> False
| (True, True) \<Rightarrow> True)"
private lemma "A \<Turnstile> F \<longleftrightarrow> formula_semantics_tt A F"
  by(induction F; simp split: prod.splits bool.splits)
end

definition entailment :: "'a formula set \<Rightarrow> 'a formula \<Rightarrow> bool" ("(_ \<TTurnstile>/ _)" (* \TTurnstile *) [53,53] 53) where
"\<Gamma> \<TTurnstile> F \<equiv> (\<forall>\<A>. ((\<forall>G \<in> \<Gamma>. \<A> \<Turnstile> G) \<longrightarrow> (\<A> \<Turnstile> F)))"
text\<open>We write entailment differently than semantics (\<open>\<Turnstile>\<close> vs. \<open>\<TTurnstile>\<close>).
For humans, it is usually pretty clear what is meant in a specific situation,
but it often needs to be decided from context that Isabelle/HOL does not have.\<close>

text\<open>Some helpers for the derived connectives\<close>
lemma top_semantics[simp,intro!]: "A \<Turnstile> \<top>" unfolding Top_def by simp
lemma BigAnd_semantics[simp]: "A \<Turnstile> \<^bold>\<And>F \<longleftrightarrow> (\<forall>f \<in> set F. A \<Turnstile> f)" by(induction F; simp)
lemma BigOr_semantics[simp]: "A \<Turnstile> \<^bold>\<Or>F \<longleftrightarrow> (\<exists>f \<in> set F. A \<Turnstile> f)" by(induction F; simp)

text\<open>Definitions for sets of formulae, used for compactness and model existence.\<close>

definition "sat S \<equiv> \<exists>\<A>. \<forall>F \<in> S. \<A> \<Turnstile> F"
definition "fin_sat S \<equiv> (\<forall>s \<subseteq> S. finite s \<longrightarrow> sat s)"

lemma pn_atoms_updates: "p \<notin> snd (pn_atoms F) \<Longrightarrow> n \<notin> fst (pn_atoms F) \<Longrightarrow>
  ((M \<Turnstile> F \<longrightarrow> (M(p := True) \<Turnstile> F \<and> M(n := False) \<Turnstile> F))) \<and> ((\<not>(M \<Turnstile> F)) \<longrightarrow> \<not>(M(n := True) \<Turnstile> F) \<and> \<not>(M(p := False) \<Turnstile> F))"
proof(induction F arbitrary: n p)
  case (Imp F G)
  from Imp.prems have prems:
     "p \<notin> fst (pn_atoms F)" "p \<notin> snd (pn_atoms G)"
     "n \<notin> snd (pn_atoms F)" "n \<notin> fst (pn_atoms G)"
    by(simp_all add: prod_unions_def split: prod.splits)
  have IH1: "M \<Turnstile> F \<Longrightarrow> M(n := True) \<Turnstile> F" " M \<Turnstile> F \<Longrightarrow> M(p := False) \<Turnstile> F" "\<not> M \<Turnstile> F \<Longrightarrow> \<not> M(p := True) \<Turnstile> F" "\<not> M \<Turnstile> F \<Longrightarrow> \<not> M(n := False) \<Turnstile> F"
    using Imp.IH(1)[OF prems(3) prems(1)] by blast+
  have IH2: "M \<Turnstile> G \<Longrightarrow> M(p := True) \<Turnstile> G" "M \<Turnstile> G \<Longrightarrow> M(n := False) \<Turnstile> G" "\<not> M \<Turnstile> G \<Longrightarrow> \<not> M(n := True) \<Turnstile> G" "\<not> M \<Turnstile> G \<Longrightarrow> \<not> M(p := False) \<Turnstile> G"
    using Imp.IH(2)[OF prems(2) prems(4)] by blast+
   show ?case proof(intro conjI; intro impI)
     assume "M \<Turnstile> F \<^bold>\<rightarrow> G"
     then consider "\<not> M \<Turnstile> F" | "M \<Turnstile>G" by auto
     thus "M(p := True) \<Turnstile> F \<^bold>\<rightarrow> G \<and> M(n := False) \<Turnstile> F \<^bold>\<rightarrow> G" using IH1(3,4) IH2(1,2) by cases simp_all
   next
     assume "\<not>(M \<Turnstile> F \<^bold>\<rightarrow> G)"
     hence "M \<Turnstile> F" "\<not>M \<Turnstile> G" by simp_all
     thus "\<not> M(n := True) \<Turnstile> F \<^bold>\<rightarrow> G \<and> \<not> M(p := False) \<Turnstile> F \<^bold>\<rightarrow> G" using IH1(1,2) IH2(3,4) by simp
   qed
 next
  case (And F G)
  from And.prems have prems:
     "p \<notin> snd (pn_atoms F)" "p \<notin> snd (pn_atoms G)"
     "n \<notin> fst (pn_atoms F)" "n \<notin> fst (pn_atoms G)"
    by(simp_all add: prod_unions_def split: prod.splits)
  have IH1: "M \<Turnstile> F \<Longrightarrow> M(p := True) \<Turnstile> F" " M \<Turnstile> F \<Longrightarrow> M(n := False) \<Turnstile> F" "\<not> M \<Turnstile> F \<Longrightarrow> \<not> M(n := True) \<Turnstile> F" "\<not> M \<Turnstile> F \<Longrightarrow> \<not> M(p := False) \<Turnstile> F"
    using And.IH(1)[OF prems(1) prems(3)] by blast+
  have IH2: "M \<Turnstile> G \<Longrightarrow> M(p := True) \<Turnstile> G" "M \<Turnstile> G \<Longrightarrow> M(n := False) \<Turnstile> G" "\<not> M \<Turnstile> G \<Longrightarrow> \<not> M(n := True) \<Turnstile> G" "\<not> M \<Turnstile> G \<Longrightarrow> \<not> M(p := False) \<Turnstile> G"
    using And.IH(2)[OF prems(2) prems(4)] by blast+
  show ?case proof(intro conjI; intro impI)
    assume "\<not>M \<Turnstile> F \<^bold>\<and> G"
    then consider "\<not> M \<Turnstile> F" | "\<not> M \<Turnstile>G" by auto
    thus "\<not> M(n := True) \<Turnstile> F \<^bold>\<and> G \<and> \<not> M(p := False) \<Turnstile> F \<^bold>\<and> G" using IH1 IH2 by cases simp_all
  next
    assume "M \<Turnstile> F \<^bold>\<and> G"
    hence "M \<Turnstile> F" "M \<Turnstile> G" by simp_all
    thus "M(p := True) \<Turnstile> F \<^bold>\<and> G \<and> M(n := False) \<Turnstile> F \<^bold>\<and> G " using IH1 IH2 by simp
  qed
next
  case (Or F G)
  from Or.prems have prems:
     "p \<notin> snd (pn_atoms F)" "p \<notin> snd (pn_atoms G)"
     "n \<notin> fst (pn_atoms F)" "n \<notin> fst (pn_atoms G)"
    by(simp_all add: prod_unions_def split: prod.splits)
  have IH1: "M \<Turnstile> F \<Longrightarrow> M(p := True) \<Turnstile> F" " M \<Turnstile> F \<Longrightarrow> M(n := False) \<Turnstile> F" "\<not> M \<Turnstile> F \<Longrightarrow> \<not> M(n := True) \<Turnstile> F" "\<not> M \<Turnstile> F \<Longrightarrow> \<not> M(p := False) \<Turnstile> F"
    using Or.IH(1)[OF prems(1) prems(3)] by blast+
  have IH2: "M \<Turnstile> G \<Longrightarrow> M(p := True) \<Turnstile> G" "M \<Turnstile> G \<Longrightarrow> M(n := False) \<Turnstile> G" "\<not> M \<Turnstile> G \<Longrightarrow> \<not> M(n := True) \<Turnstile> G" "\<not> M \<Turnstile> G \<Longrightarrow> \<not> M(p := False) \<Turnstile> G"
    using Or.IH(2)[OF prems(2) prems(4)] by blast+
  show ?case proof(intro conjI; intro impI)
    assume "M \<Turnstile> F \<^bold>\<or> G"
    then consider "M \<Turnstile> F" | "M \<Turnstile>G" by auto
    thus "M(p := True) \<Turnstile> F \<^bold>\<or> G \<and> M(n := False) \<Turnstile> F \<^bold>\<or> G" using IH1 IH2 by cases simp_all
  next
    assume "\<not>M \<Turnstile> F \<^bold>\<or> G"
    hence "\<not>M \<Turnstile> F" "\<not>M \<Turnstile> G" by simp_all
    thus "\<not>M(n := True) \<Turnstile> F \<^bold>\<or> G \<and> \<not>M(p := False) \<Turnstile> F \<^bold>\<or> G " using IH1 IH2 by simp
  qed
qed simp_all

lemma const_simplifier_correct: "\<A> \<Turnstile> simplify_consts F \<longleftrightarrow> \<A> \<Turnstile> F"
  by (induction F) (auto simp add: Let_def isstop_def Top_def split: formula.splits)

end


(*  Title:      HOL/Datatype_Examples/Derivation_Trees/Parallel_Composition.thy
    Author:     Andrei Popescu, TU Muenchen
    Copyright   2012

Parallel composition.
*)

section \<open>Parallel Composition\<close>

theory Parallel_Composition
imports DTree
begin

no_notation plus_class.plus (infixl "+" 65)

consts Nplus :: "N \<Rightarrow> N \<Rightarrow> N" (infixl "+" 60)

axiomatization where
    Nplus_comm: "(a::N) + b = b + (a::N)"
and Nplus_assoc: "((a::N) + b) + c = a + (b + c)"

subsection\<open>Corecursive Definition of Parallel Composition\<close>

fun par_r where "par_r (tr1,tr2) = root tr1 + root tr2"
fun par_c where
"par_c (tr1,tr2) =
 Inl ` (Inl -` (cont tr1 \<union> cont tr2)) \<union>
 Inr ` (Inr -` cont tr1 \<times> Inr -` cont tr2)"

declare par_r.simps[simp del]  declare par_c.simps[simp del]

definition par :: "dtree \<times> dtree \<Rightarrow> dtree" where
"par \<equiv> unfold par_r par_c"

abbreviation par_abbr (infixr "\<parallel>" 80) where "tr1 \<parallel> tr2 \<equiv> par (tr1, tr2)"

lemma finite_par_c: "finite (par_c (tr1, tr2))"
unfolding par_c.simps apply(rule finite_UnI)
  apply (metis finite_Un finite_cont finite_imageI finite_vimageI inj_Inl)
  apply(intro finite_imageI finite_cartesian_product finite_vimageI)
  using finite_cont by auto

lemma root_par: "root (tr1 \<parallel> tr2) = root tr1 + root tr2"
using unfold(1)[of par_r par_c "(tr1,tr2)"] unfolding par_def par_r.simps by simp

lemma cont_par:
"cont (tr1 \<parallel> tr2) = (id \<oplus> par) ` par_c (tr1,tr2)"
using unfold(2)[of par_c "(tr1,tr2)" par_r, OF finite_par_c]
unfolding par_def ..

lemma Inl_cont_par[simp]:
"Inl -` (cont (tr1 \<parallel> tr2)) = Inl -` (cont tr1 \<union> cont tr2)"
unfolding cont_par par_c.simps by auto

lemma Inr_cont_par[simp]:
"Inr -` (cont (tr1 \<parallel> tr2)) = par ` (Inr -` cont tr1 \<times> Inr -` cont tr2)"
unfolding cont_par par_c.simps by auto

lemma Inl_in_cont_par:
"Inl t \<in> cont (tr1 \<parallel> tr2) \<longleftrightarrow> (Inl t \<in> cont tr1 \<or> Inl t \<in> cont tr2)"
using Inl_cont_par[of tr1 tr2] unfolding vimage_def by auto

lemma Inr_in_cont_par:
"Inr t \<in> cont (tr1 \<parallel> tr2) \<longleftrightarrow> (t \<in> par ` (Inr -` cont tr1 \<times> Inr -` cont tr2))"
using Inr_cont_par[of tr1 tr2] unfolding vimage_def by auto

subsection\<open>Structural Coinduction Proofs\<close>

lemma rel_set_rel_sum_eq[simp]:
"rel_set (rel_sum (=) \<phi>) A1 A2 \<longleftrightarrow>
 Inl -` A1 = Inl -` A2 \<and> rel_set \<phi> (Inr -` A1) (Inr -` A2)"
unfolding rel_set_rel_sum rel_set_eq ..

(* Detailed proofs of commutativity and associativity: *)
theorem par_com: "tr1 \<parallel> tr2 = tr2 \<parallel> tr1"
proof-
  let ?\<theta> = "\<lambda> trA trB. \<exists> tr1 tr2. trA = tr1 \<parallel> tr2 \<and> trB = tr2 \<parallel> tr1"
  {fix trA trB
   assume "?\<theta> trA trB" hence "trA = trB"
   apply (induct rule: dtree_coinduct)
   unfolding rel_set_rel_sum rel_set_eq unfolding rel_set_def proof safe
     fix tr1 tr2  show "root (tr1 \<parallel> tr2) = root (tr2 \<parallel> tr1)"
     unfolding root_par by (rule Nplus_comm)
   next
     fix n tr1 tr2 assume "Inl n \<in> cont (tr1 \<parallel> tr2)" thus "n \<in> Inl -` (cont (tr2 \<parallel> tr1))"
     unfolding Inl_in_cont_par by auto
   next
     fix n tr1 tr2 assume "Inl n \<in> cont (tr2 \<parallel> tr1)" thus "n \<in> Inl -` (cont (tr1 \<parallel> tr2))"
     unfolding Inl_in_cont_par by auto
   next
     fix tr1 tr2 trA' assume "Inr trA' \<in> cont (tr1 \<parallel> tr2)"
     then obtain tr1' tr2' where "trA' = tr1' \<parallel> tr2'"
     and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
     unfolding Inr_in_cont_par by auto
     thus "\<exists> trB' \<in> Inr -` (cont (tr2 \<parallel> tr1)). ?\<theta> trA' trB'"
     apply(intro bexI[of _ "tr2' \<parallel> tr1'"]) unfolding Inr_in_cont_par by auto
   next
     fix tr1 tr2 trB' assume "Inr trB' \<in> cont (tr2 \<parallel> tr1)"
     then obtain tr1' tr2' where "trB' = tr2' \<parallel> tr1'"
     and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
     unfolding Inr_in_cont_par by auto
     thus "\<exists> trA' \<in> Inr -` (cont (tr1 \<parallel> tr2)). ?\<theta> trA' trB'"
     apply(intro bexI[of _ "tr1' \<parallel> tr2'"]) unfolding Inr_in_cont_par by auto
   qed
  }
  thus ?thesis by blast
qed

lemma par_assoc: "(tr1 \<parallel> tr2) \<parallel> tr3 = tr1 \<parallel> (tr2 \<parallel> tr3)"
proof-
  let ?\<theta> =
  "\<lambda> trA trB. \<exists> tr1 tr2 tr3. trA = (tr1 \<parallel> tr2) \<parallel> tr3 \<and> trB = tr1 \<parallel> (tr2 \<parallel> tr3)"
  {fix trA trB
   assume "?\<theta> trA trB" hence "trA = trB"
   apply (induct rule: dtree_coinduct)
   unfolding rel_set_rel_sum rel_set_eq unfolding rel_set_def proof safe
     fix tr1 tr2 tr3  show "root ((tr1 \<parallel> tr2) \<parallel> tr3) = root (tr1 \<parallel> (tr2 \<parallel> tr3))"
     unfolding root_par by (rule Nplus_assoc)
   next
     fix n tr1 tr2 tr3 assume "Inl n \<in> (cont ((tr1 \<parallel> tr2) \<parallel> tr3))"
     thus "n \<in> Inl -` (cont (tr1 \<parallel> tr2 \<parallel> tr3))" unfolding Inl_in_cont_par by simp
   next
     fix n tr1 tr2 tr3 assume "Inl n \<in> (cont (tr1 \<parallel> tr2 \<parallel> tr3))"
     thus "n \<in> Inl -` (cont ((tr1 \<parallel> tr2) \<parallel> tr3))" unfolding Inl_in_cont_par by simp
   next
     fix trA' tr1 tr2 tr3 assume "Inr trA' \<in> cont ((tr1 \<parallel> tr2) \<parallel> tr3)"
     then obtain tr1' tr2' tr3' where "trA' = (tr1' \<parallel> tr2') \<parallel> tr3'"
     and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
     and "Inr tr3' \<in> cont tr3" unfolding Inr_in_cont_par by auto
     thus "\<exists> trB' \<in> Inr -` (cont (tr1 \<parallel> tr2 \<parallel> tr3)). ?\<theta> trA' trB'"
     apply(intro bexI[of _ "tr1' \<parallel> tr2' \<parallel> tr3'"])
     unfolding Inr_in_cont_par by auto
   next
     fix trB' tr1 tr2 tr3 assume "Inr trB' \<in> cont (tr1 \<parallel> tr2 \<parallel> tr3)"
     then obtain tr1' tr2' tr3' where "trB' = tr1' \<parallel> (tr2' \<parallel> tr3')"
     and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
     and "Inr tr3' \<in> cont tr3" unfolding Inr_in_cont_par by auto
     thus "\<exists> trA' \<in> Inr -` cont ((tr1 \<parallel> tr2) \<parallel> tr3). ?\<theta> trA' trB'"
     apply(intro bexI[of _ "(tr1' \<parallel> tr2') \<parallel> tr3'"])
     unfolding Inr_in_cont_par by auto
   qed
  }
  thus ?thesis by blast
qed

end


section "Miscellaneous lemmas"

theory MiscLemmas imports "HOL-Library.Sublist" begin

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
  refl[simp,intro]: "star r x x"
| step: "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

inductive star_n :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
  refl_n: "star_n r 0 x x"
| step_n: "r x y \<Longrightarrow> star_n r n y z \<Longrightarrow> star_n r (Suc n) x z"

declare star_n.intros[simp, intro]

lemma star_n_decompose:
  "star_n r n x y \<Longrightarrow> star_n r n' x z \<Longrightarrow> n' < n
    \<Longrightarrow> (\<And>x y z. r x y \<Longrightarrow> r x z \<Longrightarrow> y = z)
    \<Longrightarrow> (\<And>n x y z. star_n r n x y \<Longrightarrow> star_n r n x z \<Longrightarrow> y = z)
    \<Longrightarrow> star_n r (n - n') z y"
  apply (induct arbitrary: n' z rule: star_n.induct, simp)
  apply clarsimp
  apply (rename_tac n z n' za)
  apply (subgoal_tac "Suc n - n' = Suc (n - n')")
   prefer 2
   apply simp
  apply simp
  apply (case_tac "n' < n", simp)
   apply (case_tac n')
    apply clarsimp
    apply (erule star_n.cases[of _ 0]; simp)
   apply (rename_tac z' m)
   apply simp
   apply (drule_tac x=m and y=z' in meta_spec2)
   apply (subgoal_tac "Suc (n - Suc m) = n - m")
    prefer 2
    apply arith
   apply simp
   apply (erule meta_mp)
   apply (erule_tac ?a1.0="Suc m" in star_n.cases; simp)
   apply clarsimp
   apply (rename_tac y n z x y' n' z')
   apply (drule_tac x=x and y=y in meta_spec2)
   apply (drule_tac x=y' in meta_spec)
   apply simp
  apply (subgoal_tac "n' = n")
   prefer 2
   apply arith
  apply simp
  apply (case_tac n; simp)
   apply clarsimp
   apply (erule star_n.cases; simp)
   apply (erule star_n.cases; simp)
  apply (rename_tac za m)
  apply (drule_tac x="n - (Suc 0)" and y=za in meta_spec2)
  apply simp
  apply (erule meta_mp)
  apply (drule_tac x=m and y=y in meta_spec2)
  apply (rotate_tac -1)
  apply (drule_tac x=z and y=za in meta_spec2)
  apply (erule star_n.cases; simp)
  apply (erule star_n.cases; simp)
  by fastforce

lemma star_n_add:
  "star_n r n x z \<longleftrightarrow> (\<exists>n1 n2 y. star_n r n1 x y \<and> star_n r n2 y z \<and> n = n1 + n2)"
proof (rule iffI)
  assume "star_n r n x z"
  from this show "\<exists>n1 n2 y. star_n r n1 x y \<and> star_n r n2 y z \<and> n = n1 + n2"
    by (induct rule: star_n.induct; fastforce)
next
  assume H0: "\<exists>n1 n2 y. star_n r n1 x y \<and> star_n r n2 y z \<and> n = n1 + n2"
  have H: "star_n r n1 x y \<Longrightarrow>
       star_n r n2 y z \<Longrightarrow> star_n r (n1 + n2) x z" for y n1 n2
    by (induct rule: star_n.induct; simp)
  show "star_n r n x z " using H0 H by blast
qed

lemma star_star_n:
  "star r x y \<Longrightarrow> \<exists>n. star_n r n x y"
  by (induct rule: star.induct; fastforce)

lemma star_n_star:
  "star_n r n x y \<Longrightarrow> star r x y"
  by (induct rule: star_n.induct; fastforce elim!: step)

lemma star_eq_star_n:
  "star r x y = (\<exists>n. star_n r n x y)"
  by (meson star_n_star star_star_n)

lemma star_trans:
  "star r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"
  by (meson star_eq_star_n star_n_add)

lemma step_rev:
  "star r x y \<Longrightarrow> r y z \<Longrightarrow> star r x z"
  by (meson star.simps star_trans)

lemma star_n_trans:
  "star_n r n x y \<Longrightarrow> star_n r n' y z \<Longrightarrow> star_n r (n + n') x z"
  using star_n_add by force

lemma step_n_rev:
  "star_n r n x y \<Longrightarrow> r y z \<Longrightarrow> star_n r (Suc n) x z"
  by (induct rule: star_n.induct; clarsimp)

lemma star_n_lastE:
  "star_n r (Suc n) x z \<Longrightarrow>
   (\<And>n' x' y' z'. n = n' \<Longrightarrow> x = x' \<Longrightarrow> z = z'
     \<Longrightarrow> star_n r n' x' y' \<Longrightarrow> r y' z' \<Longrightarrow> P) \<Longrightarrow> P"
proof (induct n arbitrary: x z)
  case 0
  then show ?case
    by cases (erule star_n.cases; force)
next
  case (Suc n)
  then show ?case
    by cases (erule star_n.cases; force)+
qed

lemma
  star_n_conjunct1: "star_n (\<lambda>x y. P x y \<and> Q x y) n s t \<Longrightarrow> star_n P n s t" and
  star_n_conjunct2: "star_n (\<lambda>x y. P x y \<and> Q x y) n s t \<Longrightarrow> star_n Q n s t" and
  star_n_commute: "star_n (\<lambda>x y. P x y \<and> Q x y) n s t \<Longrightarrow> star_n (\<lambda>x y. Q x y \<and> P x y) n s t"
  by (induct rule: star_n.induct; clarsimp)+

lemma forall_swap4:
  "(\<forall>x y z w. P x y z w) \<longleftrightarrow> (\<forall>z w y x. P x y z w)" by auto

lemma prefix_drop_append:
  "prefix xs ys \<Longrightarrow> xs @ drop (length xs) ys = ys"
  by (metis append_eq_conv_conj prefix_def)

lemma min_prefix:
  "\<forall>i. prefix (f i) (f (Suc i)) \<Longrightarrow> (\<forall>i. prefix (f 0) (f i))"
  apply clarsimp
  using prefix_order.lift_Suc_mono_le by blast

definition wf_to_wfP where
  "wf_to_wfP r \<equiv> \<lambda>x y. (x, y) \<in> r"

end


(* Factorization of polynomials with real algebraic coefficients *)

subsection \<open>Real Algebraic Coefficients\<close>

text \<open>We basically perform a factorization via complex algebraic numbers,
  take all real roots, and
  then merge each pair of conjugate roots into a quadratic factor.\<close>

theory Factor_Real_Poly
  imports
    Factor_Complex_Poly
begin

hide_const (open) Coset.order

fun delete_cnj :: "complex \<Rightarrow> nat \<Rightarrow> (complex \<times> nat) list \<Rightarrow> (complex \<times> nat) list" where
  "delete_cnj x i ((y,j) # yjs) = (if x = y then if Suc j = i then yjs else if Suc j > i then
    ((y,j - i) # yjs) else delete_cnj x (i - Suc j) yjs else (y,j) # delete_cnj x i yjs)"
| "delete_cnj _ _ [] = []"

lemma delete_cnj_length[termination_simp]: "length (delete_cnj x i yjs) \<le> length yjs"
  by (induct x i yjs rule: delete_cnj.induct, auto)

fun complex_roots_to_real_factorization :: "(complex \<times> nat) list \<Rightarrow> (real poly \<times> nat)list" where
  "complex_roots_to_real_factorization [] = []"
| "complex_roots_to_real_factorization ((x,i) # xs) = (if x \<in> \<real> then
    ([:-(Re x),1:],Suc i) # complex_roots_to_real_factorization xs else
    let xx = cnj x; ys = delete_cnj xx (Suc i) xs; p = map_poly Re ([:-x,1:] * [:-xx,1:])
    in (p,Suc i) # complex_roots_to_real_factorization ys)"

definition factor_real_poly :: "real poly \<Rightarrow> real \<times> (real poly \<times> nat) list" where
  "factor_real_poly p \<equiv> case factor_complex_main (map_poly of_real p) of
    (c,ris) \<Rightarrow> (Re c, complex_roots_to_real_factorization ris) "

lemma delete_cnj: assumes
  "order x (\<Prod>(x, i)\<leftarrow>xis. [:- x, 1:] ^ Suc i) \<ge> si" "si \<noteq> 0"
  shows "(\<Prod>(x, i)\<leftarrow>xis. [:- x, 1:] ^ Suc i) =
    [:- x, 1:] ^ si * (\<Prod>(x, i)\<leftarrow>delete_cnj x si xis. [:- x, 1:] ^ Suc i)"
using assms
proof (induct x si xis rule: delete_cnj.induct)
  case (2 x si)
  hence "order x 1 \<ge> 1" by auto
  hence "[:-x,1:]^1 dvd 1" unfolding order_divides by simp
  from power_le_dvd[OF this, of 1] \<open>si \<noteq> 0\<close> have "[:- x, 1:] dvd 1" by simp
  from divides_degree[OF this]
  show ?case by auto
next
  case (1 x i y j yjs)
  note IH = 1(1-2)
  let ?yj = "[:-y,1:]^Suc j"
  let ?yjs = "(\<Prod>(x,i)\<leftarrow>yjs. [:- x, 1:] ^ Suc i)"
  let ?x = "[: - x, 1 :]"
  let ?xi = "?x ^ i"
  have "monic (\<Prod>(x,i)\<leftarrow>(y, j) # yjs. [:- x, 1:] ^ Suc i)"
    by (rule monic_prod_list_pow) then have "monic (?yj * ?yjs)" by simp
  from monic_imp_nonzero[OF this] have yy0: "?yj * ?yjs \<noteq> 0" by auto
  have id: "(\<Prod>(x,i)\<leftarrow>(y, j) # yjs. [:- x, 1:] ^ Suc i) = ?yj * ?yjs" by simp
  from 1(3-) have ord: "i \<le> order x (?yj * ?yjs)" and i: "i \<noteq> 0" unfolding id by auto
  from ord[unfolded order_mult[OF yy0]] have ord: "i \<le> order x ?yj + order x ?yjs" .
  from this[unfolded order_linear_power']
  have ord: "i \<le> (if y = x then Suc j else 0) + order x ?yjs" by simp
  show ?case
  proof (cases "x = y")
    case False
    from ord False have "i \<le> order x ?yjs" by simp
    note IH = IH(2)[OF False this i]
    from False have del: "delete_cnj x i ((y, j) # yjs) = (y,j) # delete_cnj x i yjs" by simp
    show ?thesis unfolding del id IH
      by (simp add: ac_simps)
  next
    case True note xy = this
    note IH = IH(1)[OF True]
    show ?thesis
    proof (cases "Suc j \<ge> i")
      case False
      from ord have ord: "i - Suc j \<le> order x ?yjs" unfolding xy by simp
      have "?xi = ?x ^ (Suc j + (i - Suc j))" using False by simp
      also have "\<dots> = ?x ^ Suc j * ?x ^ (i - Suc j)"
        unfolding power_add by simp
      finally have xi: "?xi = ?x ^ Suc j * ?x ^ (i - Suc j)" .
      from False have "Suc j \<noteq> i" "\<not> i < Suc j" "i - Suc j \<noteq> 0" by auto
      note IH = IH[OF this(1,2) ord this(3)]
      from xy False have del: "delete_cnj x i ((y, j) # yjs) = delete_cnj x (i - Suc j) yjs" by auto
      show ?thesis unfolding del id unfolding IH xi unfolding xy by simp
    next
      case True
      hence "Suc j = i \<or> i < Suc j" by auto
      thus ?thesis
      proof
        assume i: "Suc j = i"
        from xy i have del: "delete_cnj x i ((y, j) # yjs) = yjs" by simp
        show ?thesis unfolding id del unfolding xy i by simp
      next
        assume ij: "i < Suc j"
        with xy i have del: "delete_cnj x i ((y, j) # yjs) = (y, j - i) # yjs" by simp
        from ij have idd: "Suc j = i + Suc (j - i)" by simp
        show ?thesis unfolding id del unfolding xy idd power_add by simp
      qed
    qed
  qed
qed

theorem factor_real_poly: assumes fp: "factor_real_poly p = (c,qis)"
  shows "p = smult c (\<Prod>(q, i)\<leftarrow>qis. q ^ i)"
    "(q,j) \<in> set qis \<Longrightarrow> irreducible q \<and> j \<noteq> 0 \<and> monic q \<and> degree q \<in> {1,2}"
proof -
  interpret map_poly_inj_idom_hom of_real..
  have "(p = smult c (\<Prod>(q, i)\<leftarrow>qis. q ^ i)) \<and> ((q,j) \<in> set qis \<longrightarrow> irreducible q \<and> j \<noteq> 0 \<and> monic q \<and> degree q \<in> {1,2})"
  proof (cases "p = 0")
    case True
    have yun: "yun_rf (yun_polys (0 :: complex poly)) = (0,[])"
      by (transfer, auto simp: yun_factorization_def)
    have "factor_real_poly p = (0,[])" unfolding True
      by (simp add: factor_real_poly_def factor_complex_main_def yun)
    with fp have id: "c = 0" "qis = []" by auto
    thus ?thesis unfolding True by simp
  next
    case False note p0 = this
    let ?c = complex_of_real
    let ?rp = "map_poly Re"
    let ?cp = "map_poly ?c"
    let ?p = "?cp p"
    from fp[unfolded factor_real_poly_def]
      obtain d xis where fp: "factor_complex_main ?p = (d,xis)"
      and c: "c = Re d" and qis: "qis = complex_roots_to_real_factorization xis"
        by (cases "factor_complex_main ?p", auto)
    from factor_complex_main[OF fp] have p: "?p = smult d (\<Prod>(x, i)\<leftarrow>xis. [:- x, 1:] ^ Suc i)"
      (is "_ = smult d ?q") .
    from arg_cong[OF this, of "\<lambda> p. coeff p (degree p)"]
    have "coeff ?p (degree ?p) = coeff (smult d ?q) (degree (smult d ?q))" .
    also have "coeff ?p (degree ?p) = ?c (coeff p (degree p))" by simp
    also have "coeff (smult d ?q) (degree (smult d ?q)) = d * coeff ?q (degree ?q)"
      by simp
    also have "monic ?q" by (rule monic_prod_list_pow)
    finally have d: "d = ?c (coeff p (degree p))" by auto
    from arg_cong[OF this, of Re, folded c] have c: "c = coeff p (degree p)" by auto
    have "set (coeffs ?p) \<subseteq> \<real>" by auto
    with p have q': "set (coeffs (smult d ?q)) \<subseteq> \<real>" by auto
    from d p0 have d0: "d \<noteq> 0" by auto
    have "smult d ?q = [:d:] * ?q" by auto
    from real_poly_factor[OF q'[unfolded this]] d0 d
    have q: "set (coeffs ?q) \<subseteq> \<real>" by auto
    have "p = ?rp ?p"
      by (rule sym, subst map_poly_map_poly, force, rule map_poly_idI, auto)
    also have "\<dots> = ?rp (smult d ?q)" unfolding p ..
    also have "?q = ?cp (?rp ?q)"
      by (rule sym, rule map_poly_of_real_Re, insert q, auto)
    also have "d = ?c c" unfolding d c ..
    also have "smult (?c c) (?cp (?rp ?q)) = ?cp (smult c (?rp ?q))" by (simp add: hom_distribs)
    also have "?rp \<dots> = smult c (?rp ?q)"
      by (subst map_poly_map_poly, force, rule map_poly_idI, auto)
    finally have p: "p = smult c (?rp ?q)" .
    let ?fact = complex_roots_to_real_factorization
    have "?rp ?q = (\<Prod>(q, i)\<leftarrow>qis. q ^ i) \<and>
      ((q, j) \<in> set qis \<longrightarrow> irreducible q \<and> j \<noteq> 0 \<and> monic q \<and> degree q \<in> {1, 2})"
      using q unfolding qis
    proof (induct xis rule: complex_roots_to_real_factorization.induct)
      case 1
      show ?case by simp
    next
      case (2 x i xis)
      note IH = 2(1-2)
      note prems = 2(3)
      let ?xi = "[:- x, 1:] ^ Suc i"
      let ?xis = "(\<Prod>(x, i)\<leftarrow>xis. [:- x, 1:] ^ Suc i)"
      have id: "(\<Prod>(x, i)\<leftarrow>((x,i) # xis). [:- x, 1:] ^ Suc i) = ?xi * ?xis"
        by simp
      show ?case
      proof (cases "x \<in> \<real>")
        case True
        have xi: "set (coeffs ?xi) \<subseteq> \<real>"
          by (rule real_poly_power, insert True, auto)
        have xis: "set (coeffs ?xis) \<subseteq> \<real>"
          by (rule real_poly_factor[OF prems[unfolded id] xi], rule linear_power_nonzero)
        note IH = IH(1)[OF True xis]
        have "?rp (?xi * ?xis) = ?rp ?xi * ?rp ?xis"
          by (rule map_poly_Re_mult[OF xi xis])
        also have "?rp ?xi = (?rp [: -x,1 :])^Suc i"
          by (rule map_poly_Re_power, insert True, auto)
        also have "?rp [: -x,1 :] = [:-(Re x),1:]" by auto
        also have "?rp ?xis = (\<Prod> (a,b) \<leftarrow> ?fact xis. a ^ b)"
          using IH by auto
        also have "[:- Re x, 1:] ^ Suc i * (\<Prod> (a,b) \<leftarrow> ?fact xis. a ^ b) =
          (\<Prod> (a,b) \<leftarrow> ?fact ((x,i) # xis). a ^ b)" using True by simp
        finally have idd: "?rp (?xi * ?xis) = (\<Prod> (a,b) \<leftarrow> ?fact ((x,i) # xis). a ^ b)" .
        show ?thesis unfolding id idd
        proof (intro conjI, force, intro impI)
          assume "(q, j) \<in> set (?fact ((x, i) # xis))"
          hence "(q,j) \<in> set (?fact xis) \<or> (q = [:- Re x, 1:] \<and> j = Suc i)"
            using True by auto
          thus "irreducible q \<and> j \<noteq> 0 \<and> monic q \<and> degree q \<in> {1, 2}"
          proof
            assume "(q,j) \<in> set (?fact xis)"
            with IH show ?thesis by auto
          next
            assume "q = [:- Re x, 1:] \<and> j = Suc i"
            with linear_irreducible_field[of "[:- Re x, 1:]"] show ?thesis by auto
          qed
        qed
      next
        case False
        define xi where "xi = [:Re x * Re x + Im x * Im x, - (2 * Re x), 1:]"
        obtain xx where xx: "xx = cnj x" by auto
        have xi: "xi = ?rp ([:-x,1:] * [:-xx,1:])" unfolding xx xi_def by auto
        have cpxi: "?cp xi = [:-x,1:] * [:-xx,1:]" unfolding xi_def
          by (cases x, auto simp: xx legacy_Complex_simps)
        obtain yis where yis: "yis = delete_cnj xx (Suc i) xis" by auto
        from False have fact: "?fact ((x,i) # xis) = ((xi,Suc i) # ?fact yis)"
          unfolding xi_def xx yis by simp
        note IH = IH(2)[OF False xx yis xi]
        have "irreducible xi"
          apply (fold irreducible_connect_field)
        proof (rule irreducible\<^sub>dI)
          show "degree xi > 0" unfolding xi by auto
          fix q p :: "real poly"
          assume "degree q > 0" "degree q < degree xi" and qp: "xi = q * p"
          hence dq: "degree q = 1" unfolding xi by auto
          have dxi: "degree xi = 2" "xi \<noteq> 0" unfolding xi by auto
          with qp have "q \<noteq> 0" "p \<noteq> 0" by auto
          hence "degree xi = degree q + degree p" unfolding qp
            by (rule degree_mult_eq)
          with dq have dp: "degree p = 1" unfolding dxi by simp
          {
            fix c :: complex
            assume rt: "poly (?cp xi) c = 0"
            hence "poly (?cp q * ?cp p) c = 0" by (simp add: qp hom_distribs)
            hence "(poly (?cp q) c = 0 \<or> poly (?cp p) c = 0)" by auto
            hence "c = roots1 (?cp q) \<or> c = roots1 (?cp p)"
              using roots1[of "?cp q"] roots1[of "?cp p"] dp dq by auto
            hence "c \<in> \<real>" unfolding roots1_def by auto
            hence "c \<noteq> x" using False by auto
          }
          hence "poly (?cp xi) x \<noteq> 0" by auto
          thus False unfolding cpxi by simp
        qed
        hence xi': "irreducible xi" "monic xi" "degree xi = 2"
          unfolding xi by auto
        let ?xxi = "[:- xx, 1:] ^ Suc i"
        let ?yis = "(\<Prod>(x, i)\<leftarrow>yis. [:- x, 1:] ^ Suc i)"
        let ?yi = "(?cp xi)^Suc i"
        have yi: "set (coeffs ?yi) \<subseteq> \<real>"
          by (rule real_poly_power, auto simp: xi)
        have mon: "monic (\<Prod>(x, i)\<leftarrow>(x, i) # xis. [:- x, 1:] ^ Suc i)"
          by (rule monic_prod_list_pow)
        from monic_imp_nonzero[OF this] have xixis: "?xi * ?xis \<noteq> 0" unfolding id by auto
        from False have xxx: "xx \<noteq> x" unfolding xx by (cases x, auto simp: legacy_Complex_simps Reals_def)
        from prems[unfolded id] have prems: "set (coeffs (?xi * ?xis)) \<subseteq> \<real>" .
        from id have "[:- x, 1:] ^ Suc i dvd ?xi * ?xis" by auto
        from xixis this[unfolded order_divides]
        have "order x (?xi * ?xis) \<ge> Suc i" by auto
        with complex_conjugate_order[OF prems xixis, of x, folded xx]
        have "order xx (?xi * ?xis) \<ge> Suc i" by auto
        hence "order xx ?xi + order xx ?xis \<ge> Suc i" unfolding order_mult[OF xixis] .
        also have "order xx ?xi = 0" unfolding order_linear_power' using xxx by simp
        finally have "order xx ?xis \<ge> Suc i" by simp
        hence yis: "?xis = ?xxi * ?yis" unfolding yis
          by (rule delete_cnj, simp)
        hence "?xi * ?xis = (?xi * ?xxi) * ?yis" by (simp only: ac_simps)
        also have "?xi * ?xxi = ([:- x, 1:] * [:- xx, 1:])^Suc i"
          by (metis power_mult_distrib)
        also have "[:- x, 1:] * [:- xx, 1:] = ?cp xi" unfolding cpxi ..
        finally have idd: "?xi * ?xis = (?cp xi)^Suc i * ?yis" by simp
        from prems[unfolded idd] have R: "set (coeffs ((?cp xi)^Suc i * ?yis)) \<subseteq> \<real>" .
        have yis: "set (coeffs ?yis) \<subseteq> \<real>"
          by (rule real_poly_factor[OF R yi], auto, auto simp: xi_def)
        note IH = IH[OF yis]
        have "?rp (?xi * ?xis) = ?rp ?yi * ?rp ?yis" unfolding idd
          by (rule map_poly_Re_mult[OF yi yis])
        also have "?rp ?yi = xi^Suc i" by (fold hom_distribs, rule map_poly_Re_of_real)
        also have "?rp ?yis = (\<Prod> (a,b) \<leftarrow> ?fact yis. a ^ b)"
          using IH by auto
        also have "xi ^ Suc i * (\<Prod> (a,b) \<leftarrow> ?fact yis. a ^ b) =
          (\<Prod> (a,b) \<leftarrow> ?fact ((x,i) # xis). a ^ b)" unfolding fact by simp
        finally have idd: "?rp (?xi * ?xis) = (\<Prod> (a,b) \<leftarrow> ?fact ((x,i) # xis). a ^ b)" .
        show ?thesis unfolding id idd fact using IH xi' by auto
      qed
    qed
    thus ?thesis unfolding p by simp
  qed
  thus "p = smult c (\<Prod>(q, i)\<leftarrow>qis. q ^ i)"
  "(q,j) \<in> set qis \<Longrightarrow> irreducible q \<and> j \<noteq> 0 \<and> monic q \<and> degree q \<in> {1,2}" by blast+
qed

end


(*  Title:      HOL/MicroJava/DFA/Listn.thy
    Author:     Tobias Nipkow
    Copyright   2000 TUM
*)

section {* Fixed Length Lists *}

theory Listn
imports Err
begin

definition list :: "nat \<Rightarrow> 'a set \<Rightarrow> 'a list set" where
"list n A == {xs. length xs = n & set xs <= A}"

definition le :: "'a ord \<Rightarrow> ('a list)ord" where
"le r == list_all2 (%x y. x <=_r y)"

abbreviation
  lesublist_syntax :: "'a list \<Rightarrow> 'a ord \<Rightarrow> 'a list \<Rightarrow> bool"
       ("(_ /<=[_] _)" [50, 0, 51] 50)
  where "x <=[r] y == x <=_(le r) y"

abbreviation
  lesssublist_syntax :: "'a list \<Rightarrow> 'a ord \<Rightarrow> 'a list \<Rightarrow> bool"
       ("(_ /<[_] _)" [50, 0, 51] 50)
  where "x <[r] y == x <_(le r) y"

definition map2 :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'c list" where
"map2 f == (%xs ys. map (split f) (zip xs ys))"

abbreviation
  plussublist_syntax :: "'a list \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b list \<Rightarrow> 'c list"
       ("(_ /+[_] _)" [65, 0, 66] 65)
  where "x +[f] y == x +_(map2 f) y"

primrec coalesce :: "'a err list \<Rightarrow> 'a list err" where
  "coalesce [] = OK[]"
| "coalesce (ex#exs) = Err.sup (op #) ex (coalesce exs)"

definition sl :: "nat \<Rightarrow> 'a sl \<Rightarrow> 'a list sl" where
"sl n == %(A,r,f). (list n A, le r, map2 f)"

definition sup :: "('a \<Rightarrow> 'b \<Rightarrow> 'c err) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'c list err" where
"sup f == %xs ys. if size xs = size ys then coalesce(xs +[f] ys) else Err"

definition upto_esl :: "nat \<Rightarrow> 'a esl \<Rightarrow> 'a list esl" where
"upto_esl m == %(A,r,f). (Union{list n A |n. n <= m}, le r, sup f)"

lemmas [simp] = set_update_subsetI

lemma unfold_lesub_list:
  "xs <=[r] ys == Listn.le r xs ys"
  by (simp add: lesub_def)

lemma Nil_le_conv [iff]:
  "([] <=[r] ys) = (ys = [])"
apply (unfold lesub_def Listn.le_def)
apply simp
done

lemma Cons_notle_Nil [iff]:
  "~ x#xs <=[r] []"
apply (unfold lesub_def Listn.le_def)
apply simp
done

lemma Cons_le_Cons [iff]:
  "x#xs <=[r] y#ys = (x <=_r y & xs <=[r] ys)"
apply (unfold lesub_def Listn.le_def)
apply simp
done

lemma Cons_less_Conss [simp]:
  "order r \<Longrightarrow>
  x#xs <_(Listn.le r) y#ys =
  (x <_r y & xs <=[r] ys  |  x = y & xs <_(Listn.le r) ys)"
apply (unfold lesssub_def)
apply blast
done

lemma list_update_le_cong:
  "\<lbrakk> i<size xs; xs <=[r] ys; x <=_r y \<rbrakk> \<Longrightarrow> xs[i:=x] <=[r] ys[i:=y]"
apply (unfold unfold_lesub_list)
apply (unfold Listn.le_def)
apply (simp add: list_all2_conv_all_nth nth_list_update)
done

lemma le_listD:
  "\<lbrakk> xs <=[r] ys; p < size xs \<rbrakk> \<Longrightarrow> xs!p <=_r ys!p"
apply (unfold Listn.le_def lesub_def)
apply (simp add: list_all2_conv_all_nth)
done

lemma le_list_refl:
  "!x. x <=_r x \<Longrightarrow> xs <=[r] xs"
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
done

lemma le_list_trans:
  "\<lbrakk> order r; xs <=[r] ys; ys <=[r] zs \<rbrakk> \<Longrightarrow> xs <=[r] zs"
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
apply clarify
apply simp
apply (blast intro: order_trans)
done

lemma le_list_antisym:
  "\<lbrakk> order r; xs <=[r] ys; ys <=[r] xs \<rbrakk> \<Longrightarrow> xs = ys"
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
apply (rule nth_equalityI)
 apply blast
apply clarify
apply simp
apply (blast intro: order_antisym)
done

lemma order_listI [simp, intro!]:
  "order r \<Longrightarrow> order(Listn.le r)"
apply (subst Semilat.order_def)
apply (blast intro: le_list_refl le_list_trans le_list_antisym
             dest: order_refl)
done

lemma lesub_list_impl_same_size [simp]:
  "xs <=[r] ys \<Longrightarrow> size ys = size xs"
apply (unfold Listn.le_def lesub_def)
apply (simp add: list_all2_conv_all_nth)
done

lemma lesssub_list_impl_same_size:
  "xs <_(Listn.le r) ys \<Longrightarrow> size ys = size xs"
apply (unfold lesssub_def)
apply auto
done

lemma le_list_appendI:
  "\<And>b c d. a <=[r] b \<Longrightarrow> c <=[r] d \<Longrightarrow> a@c <=[r] b@d"
apply (induct a)
 apply simp
apply (case_tac b)
apply auto
done

lemma le_listI:
  "length a = length b \<Longrightarrow> (\<And>n. n < length a \<Longrightarrow> a!n <=_r b!n) \<Longrightarrow> a <=[r] b"
  apply (unfold lesub_def Listn.le_def)
  apply (simp add: list_all2_conv_all_nth)
  done

lemma listI:
  "\<lbrakk> length xs = n; set xs <= A \<rbrakk> \<Longrightarrow> xs : list n A"
apply (unfold list_def)
apply blast
done

lemma listE_length [simp]:
   "xs : list n A \<Longrightarrow> length xs = n"
apply (unfold list_def)
apply blast
done

lemma less_lengthI:
  "\<lbrakk> xs : list n A; p < n \<rbrakk> \<Longrightarrow> p < length xs"
  by simp

lemma listE_set [simp]:
  "xs : list n A \<Longrightarrow> set xs <= A"
apply (unfold list_def)
apply blast
done

lemma list_0 [simp]:
  "list 0 A = {[]}"
apply (unfold list_def)
apply auto
done

lemma in_list_Suc_iff:
  "(xs : list (Suc n) A) = (\<exists>y\<in> A. \<exists>ys\<in> list n A. xs = y#ys)"
apply (unfold list_def)
apply (case_tac "xs")
apply auto
done

lemma Cons_in_list_Suc [iff]:
  "(x#xs : list (Suc n) A) = (x\<in> A & xs : list n A)"
apply (simp add: in_list_Suc_iff)
done

lemma list_not_empty:
  "\<exists>a. a\<in> A \<Longrightarrow> \<exists>xs. xs : list n A"
apply (induct "n")
 apply simp
apply (simp add: in_list_Suc_iff)
apply blast
done

lemma nth_in [rule_format, simp]:
  "!i n. length xs = n \<longrightarrow> set xs <= A \<longrightarrow> i < n \<longrightarrow> (xs!i) : A"
apply (induct "xs")
 apply simp
apply (simp add: nth_Cons split: nat.split)
done

lemma listE_nth_in:
  "\<lbrakk> xs : list n A; i < n \<rbrakk> \<Longrightarrow> (xs!i) : A"
  by auto

lemma listn_Cons_Suc [elim!]:
  "l#xs \<in> list n A \<Longrightarrow> (\<And>n'. n = Suc n' \<Longrightarrow> l \<in> A \<Longrightarrow> xs \<in> list n' A \<Longrightarrow> P) \<Longrightarrow> P"
  by (cases n) auto

lemma listn_appendE [elim!]:
  "a@b \<in> list n A \<Longrightarrow> (\<And>n1 n2. n=n1+n2 \<Longrightarrow> a \<in> list n1 A \<Longrightarrow> b \<in> list n2 A \<Longrightarrow> P) \<Longrightarrow> P"
proof -
  have "\<And>n. a@b \<in> list n A \<Longrightarrow> \<exists>n1 n2. n=n1+n2 \<and> a \<in> list n1 A \<and> b \<in> list n2 A"
    (is "\<And>n. ?list a n \<Longrightarrow> \<exists>n1 n2. ?P a n n1 n2")
  proof (induct a)
    fix n assume "?list [] n"
    hence "?P [] n 0 n" by simp
    thus "\<exists>n1 n2. ?P [] n n1 n2" by fast
  next
    fix n l ls
    assume "?list (l#ls) n"
    then obtain n' where n: "n = Suc n'" "l \<in> A" and list_n': "ls@b \<in> list n' A" by fastforce
    assume "\<And>n. ls @ b \<in> list n A \<Longrightarrow> \<exists>n1 n2. n = n1 + n2 \<and> ls \<in> list n1 A \<and> b \<in> list n2 A"
    hence "\<exists>n1 n2. n' = n1 + n2 \<and> ls \<in> list n1 A \<and> b \<in> list n2 A" by this (rule list_n')
    then obtain n1 n2 where "n' = n1 + n2" "ls \<in> list n1 A" "b \<in> list n2 A" by fast
    with n have "?P (l#ls) n (n1+1) n2" by simp
    thus "\<exists>n1 n2. ?P (l#ls) n n1 n2" by fastforce
  qed
  moreover
  assume "a@b \<in> list n A" "\<And>n1 n2. n=n1+n2 \<Longrightarrow> a \<in> list n1 A \<Longrightarrow> b \<in> list n2 A \<Longrightarrow> P"
  ultimately
  show ?thesis by blast
qed

lemma listt_update_in_list [simp, intro!]:
  "\<lbrakk> xs : list n A; x\<in> A \<rbrakk> \<Longrightarrow> xs[i := x] : list n A"
apply (unfold list_def)
apply simp
done

lemma plus_list_Nil [simp]:
  "[] +[f] xs = []"
apply (unfold plussub_def map2_def)
apply simp
done

lemma plus_list_Cons [simp]:
  "(x#xs) +[f] ys = (case ys of [] \<Rightarrow> [] | y#ys \<Rightarrow> (x +_f y)#(xs +[f] ys))"
  by (simp add: plussub_def map2_def split: list.split)

lemma length_plus_list [rule_format, simp]:
  "!ys. length(xs +[f] ys) = min(length xs) (length ys)"
apply (induct xs)
 apply simp
apply clarify
apply (simp (no_asm_simp) split: list.split)
done

lemma nth_plus_list [rule_format, simp]:
  "!xs ys i. length xs = n \<longrightarrow> length ys = n \<longrightarrow> i<n \<longrightarrow>
  (xs +[f] ys)!i = (xs!i) +_f (ys!i)"
apply (induct n)
 apply simp
apply clarify
apply (case_tac xs)
 apply simp
apply (force simp add: nth_Cons split: list.split nat.split)
done

lemma (in Semilat) plus_list_ub1 [rule_format]:
 "\<lbrakk> set xs <= A; set ys <= A; size xs = size ys \<rbrakk>
  \<Longrightarrow> xs <=[r] xs +[f] ys"
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
done

lemma (in Semilat) plus_list_ub2:
 "\<lbrakk>set xs <= A; set ys <= A; size xs = size ys \<rbrakk>
  \<Longrightarrow> ys <=[r] xs +[f] ys"
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
done

lemma (in Semilat) plus_list_lub [rule_format]:
shows "!xs ys zs. set xs <= A \<longrightarrow> set ys <= A \<longrightarrow> set zs <= A
  \<longrightarrow> size xs = n & size ys = n \<longrightarrow>
  xs <=[r] zs & ys <=[r] zs \<longrightarrow> xs +[f] ys <=[r] zs"
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
done

lemma (in Semilat) list_update_incr [rule_format]:
 "x\<in> A \<Longrightarrow> set xs <= A \<longrightarrow>
  (!i. i<size xs \<longrightarrow> xs <=[r] xs[i := x +_f xs!i])"
apply (unfold unfold_lesub_list)
apply (simp add: Listn.le_def list_all2_conv_all_nth)
apply (induct xs)
 apply simp
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp add: nth_Cons split: nat.split)
done

lemma acc_le_listI [intro!]:
  "\<lbrakk> order r; acc r \<rbrakk> \<Longrightarrow> acc(Listn.le r)"
apply (unfold acc_def)
apply (subgoal_tac
 "wf(UN n. {(ys,xs). size xs = n \<and> size ys = n \<and> xs <_(Listn.le r) ys})")
 apply (erule wf_subset)
 apply (blast intro: lesssub_list_impl_same_size)
apply (rule wf_UN)
 prefer 2
 apply clarify
 apply (rename_tac m n)
 apply (case_tac "m=n")
  apply simp
 apply (fast intro!: equals0I dest: not_sym)
apply clarify
apply (rename_tac n)
apply (induct_tac n)
 apply (simp add: lesssub_def cong: conj_cong)
apply (rename_tac k)
apply (simp add: wf_eq_minimal)
apply (simp (no_asm) add: length_Suc_conv cong: conj_cong)
apply clarify
apply (rename_tac M m)
apply (case_tac "\<exists>x xs. size xs = k \<and> x#xs \<in> M")
 prefer 2
 apply (erule thin_rl)
 apply (erule thin_rl)
 apply blast
apply (erule_tac x = "{a. \<exists>xs. size xs = k \<and> a#xs:M}" in allE)
apply (erule impE)
 apply blast
apply (thin_tac "\<exists>x xs. ?P x xs")
apply clarify
apply (rename_tac maxA xs)
apply (erule_tac x = "{ys. size ys = size xs \<and> maxA#ys \<in> M}" in allE)
apply (erule impE)
 apply blast
apply clarify
apply (thin_tac "m \<in> M")
apply (thin_tac "maxA#xs \<in> M")
apply (rule bexI)
 prefer 2
 apply assumption
apply clarify
apply simp
apply blast
done

lemma closed_listI:
  "closed S f \<Longrightarrow> closed (list n S) (map2 f)"
apply (unfold closed_def)
apply (induct n)
 apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply simp
done

lemma Listn_sl_aux:
assumes "semilat (A, r, f)" shows "semilat (Listn.sl n (A,r,f))"
proof -
  interpret Semilat A r f using assms by (rule Semilat.intro)
show ?thesis
apply (unfold Listn.sl_def)
apply (simp (no_asm) only: semilat_Def split_conv)
apply (rule conjI)
 apply simp
apply (rule conjI)
 apply (simp only: closedI closed_listI)
apply (simp (no_asm) only: list_def)
apply (simp (no_asm_simp) add: plus_list_ub1 plus_list_ub2 plus_list_lub)
done
qed

lemma Listn_sl: "\<And>L. semilat L \<Longrightarrow> semilat (Listn.sl n L)"
 by(simp add: Listn_sl_aux split_tupled_all)

lemma coalesce_in_err_list [rule_format]:
  "!xes. xes : list n (err A) \<longrightarrow> coalesce xes : err(list n A)"
apply (induct n)
 apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp (no_asm) add: plussub_def Err.sup_def lift2_def split: err.split)
apply force
done

lemma lem: "\<And>x xs. x +_(op #) xs = x#xs"
  by (simp add: plussub_def)

lemma coalesce_eq_OK1_D [rule_format]:
  "semilat(err A, Err.le r, lift2 f) \<Longrightarrow>
  !xs. xs : list n A \<longrightarrow> (!ys. ys : list n A \<longrightarrow>
  (!zs. coalesce (xs +[f] ys) = OK zs \<longrightarrow> xs <=[r] zs))"
apply (induct n)
  apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp split: err.split_asm add: lem Err.sup_def lift2_def)
apply (force simp add: semilat_le_err_OK1)
done

lemma coalesce_eq_OK2_D [rule_format]:
  "semilat(err A, Err.le r, lift2 f) \<Longrightarrow>
  !xs. xs : list n A \<longrightarrow> (!ys. ys : list n A \<longrightarrow>
  (!zs. coalesce (xs +[f] ys) = OK zs \<longrightarrow> ys <=[r] zs))"
apply (induct n)
 apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp split: err.split_asm add: lem Err.sup_def lift2_def)
apply (force simp add: semilat_le_err_OK2)
done

lemma lift2_le_ub:
  "\<lbrakk> semilat(err A, Err.le r, lift2 f); x\<in> A; y\<in> A; x +_f y = OK z;
      u\<in> A; x <=_r u; y <=_r u \<rbrakk> \<Longrightarrow> z <=_r u"
apply (unfold semilat_Def plussub_def err_def)
apply (simp add: lift2_def)
apply clarify
apply (rotate_tac -3)
apply (erule thin_rl)
apply (erule thin_rl)
apply force
done

lemma coalesce_eq_OK_ub_D [rule_format]:
  "semilat(err A, Err.le r, lift2 f) \<Longrightarrow>
  !xs. xs : list n A \<longrightarrow> (!ys. ys : list n A \<longrightarrow>
  (!zs us. coalesce (xs +[f] ys) = OK zs & xs <=[r] us & ys <=[r] us
           & us : list n A \<longrightarrow> zs <=[r] us))"
apply (induct n)
 apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp (no_asm_use) split: err.split_asm add: lem Err.sup_def lift2_def)
apply clarify
apply (rule conjI)
 apply (blast intro: lift2_le_ub)
apply blast
done

lemma lift2_eq_ErrD:
  "\<lbrakk> x +_f y = Err; semilat(err A, Err.le r, lift2 f); x\<in> A; y\<in> A \<rbrakk>
  \<Longrightarrow> ~(\<exists>u\<in> A. x <=_r u & y <=_r u)"
  by (simp add: OK_plus_OK_eq_Err_conv [THEN iffD1])

lemma coalesce_eq_Err_D [rule_format]:
  "\<lbrakk> semilat(err A, Err.le r, lift2 f) \<rbrakk>
  \<Longrightarrow> !xs. xs\<in> list n A \<longrightarrow> (!ys. ys\<in> list n A \<longrightarrow>
      coalesce (xs +[f] ys) = Err \<longrightarrow>
      ~(\<exists>zs\<in> list n A. xs <=[r] zs & ys <=[r] zs))"
apply (induct n)
 apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp split: err.split_asm add: lem Err.sup_def lift2_def)
 apply (blast dest: lift2_eq_ErrD)
done

lemma closed_err_lift2_conv:
  "closed (err A) (lift2 f) = (\<forall>x\<in> A. \<forall>y\<in> A. x +_f y : err A)"
apply (unfold closed_def)
apply (simp add: err_def)
done

lemma closed_map2_list [rule_format]:
  "closed (err A) (lift2 f) \<Longrightarrow>
  \<forall>xs. xs : list n A \<longrightarrow> (\<forall>ys. ys : list n A \<longrightarrow>
  map2 f xs ys : list n (err A))"
apply (unfold map2_def)
apply (induct n)
 apply simp
apply clarify
apply (simp add: in_list_Suc_iff)
apply clarify
apply (simp add: plussub_def closed_err_lift2_conv)
done

lemma err_semilat_sup:
  "err_semilat (A,r,f) \<Longrightarrow>
  err_semilat (list n A, Listn.le r, sup f)"
apply (unfold Err.sl_def)
apply (simp only: split_conv)
apply (simp (no_asm) only: semilat_Def plussub_def)
apply (simp (no_asm_simp) only: Semilat.closedI [OF Semilat.intro] closed_lift2_sup)
apply (rule conjI)
 apply (drule Semilat.orderI [OF Semilat.intro])
 apply simp
apply (simp (no_asm) only: unfold_lesub_err Err.le_def err_def sup_def lift2_def)
apply (simp (no_asm_simp) add: coalesce_eq_OK1_D coalesce_eq_OK2_D split: err.split)
apply (blast intro: coalesce_eq_OK_ub_D dest: coalesce_eq_Err_D)
done

lemma err_semilat_upto_esl:
  "\<And>L. err_semilat L \<Longrightarrow> err_semilat(upto_esl m L)"
apply (unfold Listn.upto_esl_def)
apply (simp (no_asm_simp) only: split_tupled_all)
apply simp
apply (fastforce intro!: err_semilat_UnionI err_semilat_sup
                dest: lesub_list_impl_same_size
                simp add: plussub_def Listn.sup_def)
done

end


(*  Title:       Termination of McCarthy's 91 function
    Author:      Jasmin Blanchette <jasmin.blanchette at inria.fr>, 2017
    Maintainer:  Jasmin Blanchette <jasmin.blanchette at inria.fr>
*)

section \<open>Termination of McCarthy's 91 Function\<close>

theory McCarthy_91
imports "HOL-Library.Multiset_Order"
begin

(* TODO: move to Isabelle *)
lemma funpow_rec: "f ^^ n = (if n = 0 then id else f \<circ> f ^^ (n - 1))"
  by (induct n) auto

text \<open>
The \<open>f\<close> function captures the semantics of McCarthy's 91 function. The
\<open>g\<close> function is a tail-recursive implementation of the function, whose
termination is established using the multiset order. The definitions follow
Dershowitz and Manna.
\<close>

definition f :: "int \<Rightarrow> int" where
  "f x = (if x > 100 then x - 10 else 91)"

definition \<tau> :: "nat \<Rightarrow> int \<Rightarrow> int multiset" where
  "\<tau> n z = mset (map (\<lambda>i. (f ^^ nat i) z) [0..int n - 1])"

function g :: "nat \<Rightarrow> int \<Rightarrow> int" where
  "g n z = (if n = 0 then z else if z > 100 then g (n - 1) (z - 10) else g (n + 1) (z + 11))"
  by pat_completeness auto
termination
proof -
  define lt :: "(int \<times> int) set" where
    "lt = {(a, b). b < a \<and> a \<le> 111}"

  have lt_trans: "trans lt"
    unfolding trans_def lt_def by simp
  have lt_irrefl: "irrefl lt"
    unfolding irrefl_def lt_def by simp

  let ?LT = "mult lt"
  let ?T = "\<lambda>(n, z). \<tau> n z"
  let ?R = "inv_image ?LT ?T"

  show ?thesis
  proof (relation ?R)
    show "wf ?R"
      by (auto simp: lt_def intro!: wf_inv_image[OF wf_mult]
        wf_subset[OF wf_measure[of "\<lambda>z. nat (111 - z)"]])
  next
    fix n :: nat and z :: int
    assume n_ne_0: "n \<noteq> 0"

    {
      assume z_gt_100: "z > 100"

      have "map (\<lambda>i. (f ^^ nat i) (z - 10)) [0..int n - 2] =
        map (\<lambda>i. (f ^^ nat i) z) [1..int n - 1]"
        using n_ne_0
      proof (induct n rule: less_induct)
        case (less n)
        note ih = this(1) and n_ne_0 = this(2)
        show ?case
        proof (cases "n = 1")
          case True
          thus ?thesis
            by simp
        next
          case False
          hence n_ge_2: "n \<ge> 2"
            using n_ne_0 by simp

          have
            split_l: "[0..int n - 2] = [0..int (n - 1) - 2] @ [int n - 2]" and
            split_r: "[1..int n - 1] = [1..int (n - 1) - 1] @ [int n - 1]"
            using n_ge_2 by (induct n) (auto simp: upto_rec2)
          have f_repeat: "(f ^^ (n - 2)) (z - 10) = (f ^^ (n - 1)) z"
            using z_gt_100 n_ge_2 by (induct n, simp) (rename_tac m; case_tac m; simp add: f_def)+

          show ?thesis
            using n_ge_2 by (auto intro!: ih simp: split_l split_r f_repeat nat_diff_distrib')
        qed
      qed
      hence image_mset_eq: "{#(f ^^ nat i) (z - 10). i \<in># mset [0..int n - 2]#} =
        {#(f ^^ nat i) z. i \<in># mset [1..int n - 1]#}"
        by (fold mset_map) (intro arg_cong[of _ _ mset])

      have mset_eq_add_0_mset: "mset [0..int n - 1] = add_mset 0 (mset [1..int n - 1])"
        using n_ne_0 by (induct n) (auto simp: upto.simps)

      have nm1m1: "int (n - 1) - 1 = int n - 2"
        using n_ne_0 by simp

      show "((n - 1, z - 10), (n, z)) \<in> ?R"
        by (auto simp: image_mset_eq mset_eq_add_0_mset nm1m1 \<tau>_def simp del: One_nat_def
          intro: subset_implies_mult image_mset_subset_mono)
    }
    {
      assume z_le_100: "\<not> z > 100"

      have map_eq: "map (\<lambda>x. (f ^^ nat x) (z + 11)) [2..int n] =
        map (\<lambda>i. (f ^^ nat i) z) [1..int n - 1]"
        using n_ne_0
      proof (induct n rule: less_induct)
        case (less n)
        note ih = this(1) and n_ne_0 = this(2)
        show ?case
        proof (cases "n = 1")
          case True
          thus ?thesis
            by simp
        next
          case False
          hence n_ge_2: "n \<ge> 2"
            using n_ne_0 by simp

          have
            split_l: "[2..int n] = [2..int (n - 1)] @ [int n]" and
            split_r: "[1..int n - 1] = [1..int (n - 1) - 1] @ [int n - 1]"
            using n_ge_2 by (induct n) (auto simp: upto_rec2)
          from z_le_100 have f_f_z_11: "f (f (z + 11)) = f z"
            by (simp add: f_def)
          moreover define m where "m = n - 2"
          with n_ge_2 have "n = m + 2"
            by simp
          ultimately have f_repeat: "(f ^^ n) (z + 11) = (f ^^ (n - 1)) z"
            by (simp add: funpow_Suc_right del: funpow.simps)
          with n_ge_2 show ?thesis
            by (auto intro: ih [of "nat (int n - 1)"]
              simp: less.hyps split_l split_r nat_add_distrib nat_diff_distrib)
        qed
      qed

      have "[0..int n] = [0..1] @ [2..int n]"
        using n_ne_0 by (simp add: upto_rec1)
      hence "{#(f ^^ nat x) (z + 11). x \<in># mset [0..int n]#} =
        {#(f ^^ nat x) (z + 11). x \<in># mset [0..1]#}
        + {#(f ^^ nat x) (z + 11). x \<in># mset [2..int n]#}"
        by auto
      hence factor_out_first_two: "{#(f ^^ nat x) (z + 11). x \<in># mset [0..int n]#} =
        {#z + 11, f (z + 11)#} + {#(f ^^ nat x) (z + 11). x \<in># mset [2..int n]#}"
        by (auto simp: upto_rec1)

      let ?etc1 = "{#(f ^^ nat i) (z + 11). i \<in># mset [2..int n]#}"
      let ?etc2 = "{#(f ^^ nat i) z. i \<in># mset [1..int n - 1]#}"

      show "((n + 1, z + 11), (n, z)) \<in> ?R"
      proof (cases "z \<ge> 90")
        case z_ge_90: True

        have "{#z + 11, f (z + 11)#} + ?etc1 = {#z + 11, z + 1#} + ?etc2"
          using z_ge_90
          by (auto intro!: arg_cong2[of _ _ _ _ add_mset] simp: map_eq f_def mset_map[symmetric]
            simp del: mset_map)
        hence image_mset_eq: "{#(f ^^ nat x) (z + 11). x \<in># mset [0..int n]#} =
          {#z + 11, z + 1#} + ?etc2"
          using factor_out_first_two by presburger

        have "({#z + 11, z + 1#}, {#z#}) \<in> mult1 lt"
          using z_le_100 z_ge_90 by (auto intro!: mult1I simp: lt_def)
        hence "({#z + 11, z + 1#}, {#z#}) \<in> mult lt"
          unfolding mult_def by simp
        hence "({#z + 11, z + 1#} + ?etc2, {#z#} + ?etc2) \<in> mult lt"
          by (rule mult_cancel[THEN iffD2, OF lt_trans lt_irrefl])
        thus ?thesis
          using n_ne_0 by (auto simp: image_mset_eq \<tau>_def upto_rec1[of 0 "int n - 1"])
      next
        case z_lt_90: False

        have "{#z + 11, f (z + 11)#} + ?etc1 = {#z + 11, 91#} + ?etc2"
          using z_lt_90
          by (auto intro!: arg_cong2[of _ _ _ _ add_mset] simp: map_eq f_def mset_map[symmetric]
            simp del: mset_map)
        hence image_mset_eq: "{#(f ^^ nat x) (z + 11). x \<in># mset [0..int n]#} =
          {#z + 11, 91#} + ?etc2"
          using factor_out_first_two by presburger

        have "({#z + 11, 91#}, {#z#}) \<in> mult1 lt"
          using z_le_100 z_lt_90 by (auto intro!: mult1I simp: lt_def)
        hence "({#z + 11, 91#}, {#z#}) \<in> mult lt"
          unfolding mult_def by simp
        hence "({#z + 11, 91#} + ?etc2, {#z#} + ?etc2) \<in> mult lt"
          by (rule mult_cancel[THEN iffD2, OF lt_trans lt_irrefl])
        thus ?thesis
          using n_ne_0 by (auto simp: image_mset_eq \<tau>_def upto_rec1[of 0 "int n - 1"])
      qed
    }
  qed
qed

declare g.simps [simp del]

end


(* Author: Tobias Nipkow *)

section \<open>2-3 Tree Implementation of Maps\<close>

theory Tree23_Map
imports
  Tree23_Set
  Map_Specs
begin

fun lookup :: "('a::linorder * 'b) tree23 \<Rightarrow> 'a \<Rightarrow> 'b option" where
"lookup Leaf x = None" |
"lookup (Node2 l (a,b) r) x = (case cmp x a of
  LT \<Rightarrow> lookup l x |
  GT \<Rightarrow> lookup r x |
  EQ \<Rightarrow> Some b)" |
"lookup (Node3 l (a1,b1) m (a2,b2) r) x = (case cmp x a1 of
  LT \<Rightarrow> lookup l x |
  EQ \<Rightarrow> Some b1 |
  GT \<Rightarrow> (case cmp x a2 of
          LT \<Rightarrow> lookup m x |
          EQ \<Rightarrow> Some b2 |
          GT \<Rightarrow> lookup r x))"

fun upd :: "'a::linorder \<Rightarrow> 'b \<Rightarrow> ('a*'b) tree23 \<Rightarrow> ('a*'b) upI" where
"upd x y Leaf = OF Leaf (x,y) Leaf" |
"upd x y (Node2 l ab r) = (case cmp x (fst ab) of
   LT \<Rightarrow> (case upd x y l of
           TI l' => TI (Node2 l' ab r)
         | OF l1 ab' l2 => TI (Node3 l1 ab' l2 ab r)) |
   EQ \<Rightarrow> TI (Node2 l (x,y) r) |
   GT \<Rightarrow> (case upd x y r of
           TI r' => TI (Node2 l ab r')
         | OF r1 ab' r2 => TI (Node3 l ab r1 ab' r2)))" |
"upd x y (Node3 l ab1 m ab2 r) = (case cmp x (fst ab1) of
   LT \<Rightarrow> (case upd x y l of
           TI l' => TI (Node3 l' ab1 m ab2 r)
         | OF l1 ab' l2 => OF (Node2 l1 ab' l2) ab1 (Node2 m ab2 r)) |
   EQ \<Rightarrow> TI (Node3 l (x,y) m ab2 r) |
   GT \<Rightarrow> (case cmp x (fst ab2) of
           LT \<Rightarrow> (case upd x y m of
                   TI m' => TI (Node3 l ab1 m' ab2 r)
                 | OF m1 ab' m2 => OF (Node2 l ab1 m1) ab' (Node2 m2 ab2 r)) |
           EQ \<Rightarrow> TI (Node3 l ab1 m (x,y) r) |
           GT \<Rightarrow> (case upd x y r of
                   TI r' => TI (Node3 l ab1 m ab2 r')
                 | OF r1 ab' r2 => OF (Node2 l ab1 m) ab2 (Node2 r1 ab' r2))))"

definition update :: "'a::linorder \<Rightarrow> 'b \<Rightarrow> ('a*'b) tree23 \<Rightarrow> ('a*'b) tree23" where
"update a b t = treeI(upd a b t)"

fun del :: "'a::linorder \<Rightarrow> ('a*'b) tree23 \<Rightarrow> ('a*'b) upD" where
"del x Leaf = TD Leaf" |
"del x (Node2 Leaf ab1 Leaf) = (if x=fst ab1 then UF Leaf else TD(Node2 Leaf ab1 Leaf))" |
"del x (Node3 Leaf ab1 Leaf ab2 Leaf) = TD(if x=fst ab1 then Node2 Leaf ab2 Leaf
  else if x=fst ab2 then Node2 Leaf ab1 Leaf else Node3 Leaf ab1 Leaf ab2 Leaf)" |
"del x (Node2 l ab1 r) = (case cmp x (fst ab1) of
  LT \<Rightarrow> node21 (del x l) ab1 r |
  GT \<Rightarrow> node22 l ab1 (del x r) |
  EQ \<Rightarrow> let (ab1',t) = split_min r in node22 l ab1' t)" |
"del x (Node3 l ab1 m ab2 r) = (case cmp x (fst ab1) of
  LT \<Rightarrow> node31 (del x l) ab1 m ab2 r |
  EQ \<Rightarrow> let (ab1',m') = split_min m in node32 l ab1' m' ab2 r |
  GT \<Rightarrow> (case cmp x (fst ab2) of
           LT \<Rightarrow> node32 l ab1 (del x m) ab2 r |
           EQ \<Rightarrow> let (ab2',r') = split_min r in node33 l ab1 m ab2' r' |
           GT \<Rightarrow> node33 l ab1 m ab2 (del x r)))"

definition delete :: "'a::linorder \<Rightarrow> ('a*'b) tree23 \<Rightarrow> ('a*'b) tree23" where
"delete x t = treeD(del x t)"

subsection \<open>Functional Correctness\<close>

lemma lookup_map_of:
  "sorted1(inorder t) \<Longrightarrow> lookup t x = map_of (inorder t) x"
by (induction t) (auto simp: map_of_simps split: option.split)

lemma inorder_upd:
  "sorted1(inorder t) \<Longrightarrow> inorder(treeI(upd x y t)) = upd_list x y (inorder t)"
by(induction t) (auto simp: upd_list_simps split: upI.splits)

corollary inorder_update:
  "sorted1(inorder t) \<Longrightarrow> inorder(update x y t) = upd_list x y (inorder t)"
by(simp add: update_def inorder_upd)

lemma inorder_del: "\<lbrakk> complete t ; sorted1(inorder t) \<rbrakk> \<Longrightarrow>
  inorder(treeD (del x t)) = del_list x (inorder t)"
by(induction t rule: del.induct)
  (auto simp: del_list_simps inorder_nodes split_minD split!: if_split prod.splits)

corollary inorder_delete: "\<lbrakk> complete t ; sorted1(inorder t) \<rbrakk> \<Longrightarrow>
  inorder(delete x t) = del_list x (inorder t)"
by(simp add: delete_def inorder_del)

subsection \<open>Balancedness\<close>

lemma complete_upd: "complete t \<Longrightarrow> complete (treeI(upd x y t)) \<and> hI(upd x y t) = height t"
by (induct t) (auto split!: if_split upI.split)(* 16 secs in 2015 *)

corollary complete_update: "complete t \<Longrightarrow> complete (update x y t)"
by (simp add: update_def complete_upd)

lemma height_del: "complete t \<Longrightarrow> hD(del x t) = height t"
by(induction x t rule: del.induct)
  (auto simp add: heights max_def height_split_min split: prod.split)

lemma complete_treeD_del: "complete t \<Longrightarrow> complete(treeD(del x t))"
by(induction x t rule: del.induct)
  (auto simp: completes complete_split_min height_del height_split_min split: prod.split)

corollary complete_delete: "complete t \<Longrightarrow> complete(delete x t)"
by(simp add: delete_def complete_treeD_del)

subsection \<open>Overall Correctness\<close>

interpretation M: Map_by_Ordered
where empty = empty and lookup = lookup and update = update and delete = delete
and inorder = inorder and inv = complete
proof (standard, goal_cases)
  case 1 thus ?case by(simp add: empty_def)
next
  case 2 thus ?case by(simp add: lookup_map_of)
next
  case 3 thus ?case by(simp add: inorder_update)
next
  case 4 thus ?case by(simp add: inorder_delete)
next
  case 5 thus ?case by(simp add: empty_def)
next
  case 6 thus ?case by(simp add: complete_update)
next
  case 7 thus ?case by(simp add: complete_delete)
qed

end


(*  Title:      HOL/ex/Groebner_Examples.thy
    Author:     Amine Chaieb, TU Muenchen
*)

section \<open>Groebner Basis Examples\<close>

theory Groebner_Examples
imports "~~/src/HOL/Groebner_Basis"
begin

subsection \<open>Basic examples\<close>

lemma
  fixes x :: int
  shows "x ^ 3 = x ^ 3"
  apply (tactic \<open>ALLGOALS (CONVERSION
    (Conv.arg_conv (Conv.arg1_conv (Semiring_Normalizer.semiring_normalize_conv @{context}))))\<close>)
  by (rule refl)

lemma
  fixes x :: int
  shows "(x - (-2))^5 = x ^ 5 + (10 * x ^ 4 + (40 * x ^ 3 + (80 * x\<^sup>2 + (80 * x + 32))))"
  apply (tactic \<open>ALLGOALS (CONVERSION
    (Conv.arg_conv (Conv.arg1_conv (Semiring_Normalizer.semiring_normalize_conv @{context}))))\<close>)
  by (rule refl)

schematic_goal
  fixes x :: int
  shows "(x - (-2))^5  * (y - 78) ^ 8 = ?X"
  apply (tactic \<open>ALLGOALS (CONVERSION
    (Conv.arg_conv (Conv.arg1_conv (Semiring_Normalizer.semiring_normalize_conv @{context}))))\<close>)
  by (rule refl)

lemma "((-3) ^ (Suc (Suc (Suc 0)))) == (X::'a::{comm_ring_1})"
  apply (simp only: power_Suc power_0)
  apply (simp only: semiring_norm)
  oops

lemma "((x::int) + y)^3 - 1 = (x - z)^2 - 10 \<Longrightarrow> x = z + 3 \<Longrightarrow> x = - y"
  by algebra

lemma "(4::nat) + 4 = 3 + 5"
  by algebra

lemma "(4::int) + 0 = 4"
  apply algebra?
  by simp

lemma
  assumes "a * x\<^sup>2 + b * x + c = (0::int)" and "d * x\<^sup>2 + e * x + f = 0"
  shows "d\<^sup>2 * c\<^sup>2 - 2 * d * c * a * f + a\<^sup>2 * f\<^sup>2 - e * d * b * c - e * b * a * f +
    a * e\<^sup>2 * c + f * d * b\<^sup>2 = 0"
  using assms by algebra

lemma "(x::int)^3  - x^2  - 5*x - 3 = 0 \<longleftrightarrow> (x = 3 \<or> x = -1)"
  by algebra

theorem "x* (x\<^sup>2 - x  - 5) - 3 = (0::int) \<longleftrightarrow> (x = 3 \<or> x = -1)"
  by algebra

lemma
  fixes x::"'a::idom"
  shows "x\<^sup>2*y = x\<^sup>2 & x*y\<^sup>2 = y\<^sup>2 \<longleftrightarrow>  x = 1 & y = 1 | x = 0 & y = 0"
  by algebra

subsection \<open>Lemmas for Lagrange's theorem\<close>

definition
  sq :: "'a::times => 'a" where
  "sq x == x*x"

lemma
  fixes x1 :: "'a::{idom}"
  shows
  "(sq x1 + sq x2 + sq x3 + sq x4) * (sq y1 + sq y2 + sq y3 + sq y4) =
    sq (x1*y1 - x2*y2 - x3*y3 - x4*y4)  +
    sq (x1*y2 + x2*y1 + x3*y4 - x4*y3)  +
    sq (x1*y3 - x2*y4 + x3*y1 + x4*y2)  +
    sq (x1*y4 + x2*y3 - x3*y2 + x4*y1)"
  by (algebra add: sq_def)

lemma
  fixes p1 :: "'a::{idom}"
  shows
  "(sq p1 + sq q1 + sq r1 + sq s1 + sq t1 + sq u1 + sq v1 + sq w1) *
   (sq p2 + sq q2 + sq r2 + sq s2 + sq t2 + sq u2 + sq v2 + sq w2)
    = sq (p1*p2 - q1*q2 - r1*r2 - s1*s2 - t1*t2 - u1*u2 - v1*v2 - w1*w2) +
      sq (p1*q2 + q1*p2 + r1*s2 - s1*r2 + t1*u2 - u1*t2 - v1*w2 + w1*v2) +
      sq (p1*r2 - q1*s2 + r1*p2 + s1*q2 + t1*v2 + u1*w2 - v1*t2 - w1*u2) +
      sq (p1*s2 + q1*r2 - r1*q2 + s1*p2 + t1*w2 - u1*v2 + v1*u2 - w1*t2) +
      sq (p1*t2 - q1*u2 - r1*v2 - s1*w2 + t1*p2 + u1*q2 + v1*r2 + w1*s2) +
      sq (p1*u2 + q1*t2 - r1*w2 + s1*v2 - t1*q2 + u1*p2 - v1*s2 + w1*r2) +
      sq (p1*v2 + q1*w2 + r1*t2 - s1*u2 - t1*r2 + u1*s2 + v1*p2 - w1*q2) +
      sq (p1*w2 - q1*v2 + r1*u2 + s1*t2 - t1*s2 - u1*r2 + v1*q2 + w1*p2)"
  by (algebra add: sq_def)

subsection \<open>Colinearity is invariant by rotation\<close>

type_synonym point = "int \<times> int"

definition collinear ::"point \<Rightarrow> point \<Rightarrow> point \<Rightarrow> bool" where
  "collinear \<equiv> \<lambda>(Ax,Ay) (Bx,By) (Cx,Cy).
    ((Ax - Bx) * (By - Cy) = (Ay - By) * (Bx - Cx))"

lemma collinear_inv_rotation:
  assumes "collinear (Ax, Ay) (Bx, By) (Cx, Cy)" and "c\<^sup>2 + s\<^sup>2 = 1"
  shows "collinear (Ax * c - Ay * s, Ay * c + Ax * s)
    (Bx * c - By * s, By * c + Bx * s) (Cx * c - Cy * s, Cy * c + Cx * s)"
  using assms
  by (algebra add: collinear_def split_def fst_conv snd_conv)

lemma "EX (d::int). a*y - a*x = n*d \<Longrightarrow> EX u v. a*u + n*v = 1 \<Longrightarrow> EX e. y - x = n*e"
  by algebra

end


theory T159
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory T17
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end