(* Copyright 2021 (C) Mihails Milehins *)

section\<open>Initial and terminal objects as limits and colimits\<close>
theory CZH_UCAT_Limit_IT
  imports
    CZH_UCAT_Limit
    CZH_Elementary_Categories.CZH_ECAT_Comma
begin

subsection\<open>Initial and terminal objects as limits/colimits of an empty diagram\<close>

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

text\<open>
See
\<^cite>\<open>"noauthor_nlab_nodate"\<close>\footnote{
\url{https://ncatlab.org/nlab/show/initial+object}
}, \<^cite>\<open>"noauthor_nlab_nodate"\<close>\footnote{
\url{https://ncatlab.org/nlab/show/terminal+object}
} and Chapter X-1 in \<^cite>\<open>"mac_lane_categories_2010"\<close>.
\<close>

locale is_cat_obj_empty_terminal = is_cat_limit \<alpha> cat_0 \<CC> \<open>cf_0 \<CC>\<close> z \<ZZ>
  for \<alpha> \<CC> z \<ZZ>

syntax "_is_cat_obj_empty_terminal" :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> bool"
  (\<open>(_ :/ _ <\<^sub>C\<^sub>F\<^sub>.\<^sub>1 0\<^sub>C\<^sub>F :/ 0\<^sub>C \<mapsto>\<mapsto>\<^sub>C\<index> _)\<close> [51, 51] 51)
translations "\<ZZ> : z <\<^sub>C\<^sub>F\<^sub>.\<^sub>1 0\<^sub>C\<^sub>F : 0\<^sub>C \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>" \<rightleftharpoons>
  "CONST is_cat_obj_empty_terminal \<alpha> \<CC> z \<ZZ>"

locale is_cat_obj_empty_initial = is_cat_colimit \<alpha> cat_0 \<CC> \<open>cf_0 \<CC>\<close> z \<ZZ>
  for \<alpha> \<CC> z \<ZZ>

syntax "_is_cat_obj_empty_initial" :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> bool"
  (\<open>(_ :/ 0\<^sub>C\<^sub>F >\<^sub>C\<^sub>F\<^sub>.\<^sub>0 _ :/ 0\<^sub>C \<mapsto>\<mapsto>\<^sub>C\<index> _)\<close> [51, 51] 51)
translations "\<ZZ> : 0\<^sub>C\<^sub>F >\<^sub>C\<^sub>F\<^sub>.\<^sub>0 z : 0\<^sub>C \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>" \<rightleftharpoons>
  "CONST is_cat_obj_empty_initial \<alpha> \<CC> z \<ZZ>"

text\<open>Rules.\<close>

lemma (in is_cat_obj_empty_terminal)
  is_cat_obj_empty_terminal_axioms'[cat_lim_cs_intros]:
  assumes "\<alpha>' = \<alpha>" and "z' = z" and "\<CC>' = \<CC>"
  shows "\<ZZ> : z' <\<^sub>C\<^sub>F\<^sub>.\<^sub>1 0\<^sub>C\<^sub>F : 0\<^sub>C \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>'\<^esub> \<CC>'"
  unfolding assms by (rule is_cat_obj_empty_terminal_axioms)

mk_ide rf is_cat_obj_empty_terminal_def
  |intro is_cat_obj_empty_terminalI|
  |dest is_cat_obj_empty_terminalD[dest]|
  |elim is_cat_obj_empty_terminalE[elim]|

lemmas [cat_lim_cs_intros] = is_cat_obj_empty_terminalD

lemma (in is_cat_obj_empty_initial)
  is_cat_obj_empty_initial_axioms'[cat_lim_cs_intros]:
  assumes "\<alpha>' = \<alpha>" and "z' = z" and "\<CC>' = \<CC>"
  shows "\<ZZ> : 0\<^sub>C\<^sub>F >\<^sub>C\<^sub>F\<^sub>.\<^sub>0 z' : 0\<^sub>C \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>'\<^esub> \<CC>'"
  unfolding assms by (rule is_cat_obj_empty_initial_axioms)

mk_ide rf is_cat_obj_empty_initial_def
  |intro is_cat_obj_empty_initialI|
  |dest is_cat_obj_empty_initialD[dest]|
  |elim is_cat_obj_empty_initialE[elim]|

lemmas [cat_lim_cs_intros] = is_cat_obj_empty_initialD

text\<open>Duality.\<close>

lemma (in is_cat_obj_empty_terminal) is_cat_obj_empty_initial_op:
  "op_ntcf \<ZZ> : 0\<^sub>C\<^sub>F >\<^sub>C\<^sub>F\<^sub>.\<^sub>0 z : 0\<^sub>C \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> op_cat \<CC>"
  by (intro is_cat_obj_empty_initialI)
    (
      cs_concl cs_shallow
        cs_simp: cat_op_simps op_cf_cf_0 cs_intro: cat_cs_intros cat_op_intros
    )

lemma (in is_cat_obj_empty_terminal) is_cat_obj_empty_initial_op'[cat_op_intros]:
  assumes "\<CC>' = op_cat \<CC>"
  shows "op_ntcf \<ZZ> : 0\<^sub>C\<^sub>F >\<^sub>C\<^sub>F\<^sub>.\<^sub>0 z : 0\<^sub>C \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>'"
  unfolding assms by (rule is_cat_obj_empty_initial_op)

lemmas [cat_op_intros] = is_cat_obj_empty_terminal.is_cat_obj_empty_initial_op'

lemma (in is_cat_obj_empty_initial) is_cat_obj_empty_terminal_op:
  "op_ntcf \<ZZ> : z <\<^sub>C\<^sub>F\<^sub>.\<^sub>1 0\<^sub>C\<^sub>F : 0\<^sub>C \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> op_cat \<CC>"
  by (intro is_cat_obj_empty_terminalI)
    (
      cs_concl cs_shallow
        cs_simp: cat_op_simps op_cf_cf_0 cs_intro: cat_cs_intros cat_op_intros
    )

lemma (in is_cat_obj_empty_initial) is_cat_obj_empty_terminal_op'[cat_op_intros]:
  assumes "\<CC>' = op_cat \<CC>"
  shows "op_ntcf \<ZZ> : z <\<^sub>C\<^sub>F\<^sub>.\<^sub>1 0\<^sub>C\<^sub>F : 0\<^sub>C \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>'"
  unfolding assms by (rule is_cat_obj_empty_terminal_op)

lemmas [cat_op_intros] = is_cat_obj_empty_initial.is_cat_obj_empty_terminal_op'

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

lemma (in is_cat_obj_empty_terminal) cat_oet_ntcf_0: "\<ZZ> = ntcf_0 \<CC>"
  by (rule is_ntcf_is_ntcf_0_if_cat_0)
    (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)

lemma (in is_cat_obj_empty_initial) cat_oei_ntcf_0: "\<ZZ> = ntcf_0 \<CC>"
  by (rule is_ntcf_is_ntcf_0_if_cat_0)
    (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)

subsubsection\<open>
Initial and terminal objects as limits/colimits of an empty diagram
are initial and terminal objects
\<close>

lemma (in category) cat_obj_terminal_is_cat_obj_empty_terminal:
  assumes "obj_terminal \<CC> z"
  shows "ntcf_0 \<CC> : z <\<^sub>C\<^sub>F\<^sub>.\<^sub>1 0\<^sub>C\<^sub>F : 0\<^sub>C \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
proof-

  from assms have z: "z \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" by auto
  from z have [cat_cs_simps]: "cf_const cat_0 \<CC> z = cf_0 \<CC>"
    by (intro is_functor_is_cf_0_if_cat_0) (cs_concl cs_intro: cat_cs_intros)
  note obj_terminalD = obj_terminalD[OF assms]

  show ?thesis
  proof
    (
      intro is_cat_obj_empty_terminalI is_cat_limitI is_cat_coneI,
      unfold cat_cs_simps
    )
    show "\<exists>!f'. f' : r' \<mapsto>\<^bsub>\<CC>\<^esub> z \<and> u' = ntcf_0 \<CC> \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const cat_0 \<CC> f'"
      if "u' : r' <\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>n\<^sub>e cf_0 \<CC> : cat_0 \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>" for u' r'
    proof-
      interpret u': is_cat_cone \<alpha> r' cat_0 \<CC> \<open>cf_0 \<CC>\<close> u' by (rule that)
      from z have [cat_cs_simps]: "cf_const cat_0 \<CC> r' = cf_0 \<CC>"
        by (intro is_functor_is_cf_0_if_cat_0)
          (cs_concl cs_shallow cs_intro: cat_cs_intros)
      have u'_def: "u' = ntcf_0 \<CC>"
        by
          (
            rule is_ntcf_is_ntcf_0_if_cat_0[
              OF u'.is_ntcf_axioms, unfolded cat_cs_simps
              ]
          )
      from obj_terminalD(2)[OF u'.cat_cone_obj] obtain f'
        where f': "f' : r' \<mapsto>\<^bsub>\<CC>\<^esub> z"
          and f'_unique: "f'' : r' \<mapsto>\<^bsub>\<CC>\<^esub> z \<Longrightarrow> f'' = f'"
        for f''
        by auto
      from f' have [cat_cs_simps]: "ntcf_const cat_0 \<CC> f' = ntcf_0 \<CC>"
        by (intro is_ntcf_is_ntcf_0_if_cat_0(1))
          (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
      show ?thesis
      proof(intro ex1I conjI; (elim conjE)?)
        show "u' = ntcf_0 \<CC> \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const cat_0 \<CC> f'"
          by
            (
              cs_concl cs_shallow
                cs_simp: u'_def cat_cs_simps cs_intro: cat_cs_intros
            )
        fix f'' assume prems:
          "f'' : r' \<mapsto>\<^bsub>\<CC>\<^esub> z" "u' = ntcf_0 \<CC> \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const cat_0 \<CC> f''"
        show "f'' = f'" by (rule f'_unique[OF prems(1)])
      qed (rule f')
    qed
  qed (cs_concl cs_simp: cat_cs_simps cs_intro: z cat_cs_intros)

qed

lemma (in category) cat_obj_initial_is_cat_obj_empty_initial:
  assumes "obj_initial \<CC> z"
  shows "ntcf_0 \<CC> : 0\<^sub>C\<^sub>F >\<^sub>C\<^sub>F\<^sub>.\<^sub>0 z : 0\<^sub>C \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
proof-
  have z: "obj_terminal (op_cat \<CC>) z" unfolding cat_op_simps by (rule assms)
  show ?thesis
    by
      (
        rule is_cat_obj_empty_terminal.is_cat_obj_empty_initial_op
          [
            OF category.cat_obj_terminal_is_cat_obj_empty_terminal[
              OF category_op z, folded op_ntcf_ntcf_0
              ],
            unfolded cat_op_simps op_ntcf_ntcf_0
          ]
      )
qed

lemma (in is_cat_obj_empty_terminal) cat_oet_obj_terminal: "obj_terminal \<CC> z"
proof-
  show "obj_terminal \<CC> z"
  proof(rule obj_terminalI)
    fix a assume prems: "a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
    have [cat_cs_simps]: "cf_const cat_0 \<CC> a = cf_0 \<CC>"
      by (rule is_functor_is_cf_0_if_cat_0)
        (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros prems)
    from prems have "ntcf_0 \<CC> : a <\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>n\<^sub>e cf_0 \<CC> : cat_0 \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
      by (intro is_cat_coneI)
        (cs_concl cs_shallow cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    from cat_lim_ua_fo[OF this] obtain f'
      where f': "f' : a \<mapsto>\<^bsub>\<CC>\<^esub> z"
        and "ntcf_0 \<CC> = \<ZZ> \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const cat_0 \<CC> f'"
        and f'_unique:
          "\<lbrakk> f'' : a \<mapsto>\<^bsub>\<CC>\<^esub> z; ntcf_0 \<CC> = \<ZZ> \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const cat_0 \<CC> f'' \<rbrakk> \<Longrightarrow>
            f'' = f'"
      for f''
      by metis
    show "\<exists>!f'. f' : a \<mapsto>\<^bsub>\<CC>\<^esub> z"
    proof(intro ex1I)
      fix f'' assume prems': "f'' : a \<mapsto>\<^bsub>\<CC>\<^esub> z"
      from prems' have "ntcf_0 \<CC> = ntcf_0 \<CC> \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const cat_0 \<CC> f''"
        by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
      from f'_unique[OF prems', unfolded cat_oet_ntcf_0, OF this]
      show "f'' = f'".
    qed (rule f')
  qed (rule cat_cone_obj)
qed

lemma (in is_cat_obj_empty_initial) cat_oei_obj_initial: "obj_initial \<CC> z"
  by
    (
      rule is_cat_obj_empty_terminal.cat_oet_obj_terminal[
        OF is_cat_obj_empty_initial.is_cat_obj_empty_terminal_op[
          OF is_cat_obj_empty_initial_axioms
          ],
        unfolded cat_op_simps
        ]
    )

lemma (in category) cat_is_cat_obj_empty_terminal_obj_terminal_iff:
  "(ntcf_0 \<CC> : z <\<^sub>C\<^sub>F\<^sub>.\<^sub>1 0\<^sub>C\<^sub>F : 0\<^sub>C \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>) \<longleftrightarrow> obj_terminal \<CC> z"
  using
    cat_obj_terminal_is_cat_obj_empty_terminal
    is_cat_obj_empty_terminal.cat_oet_obj_terminal
  by auto

lemma (in category) cat_is_cat_obj_empty_initial_obj_initial_iff:
  "(ntcf_0 \<CC> : 0\<^sub>C\<^sub>F >\<^sub>C\<^sub>F\<^sub>.\<^sub>0 z : 0\<^sub>C \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>) \<longleftrightarrow> obj_initial \<CC> z"
  using
    cat_obj_initial_is_cat_obj_empty_initial
    is_cat_obj_empty_initial.cat_oei_obj_initial
  by auto

subsection\<open>Initial cone and terminal cocone\<close>

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

definition ntcf_initial :: "V \<Rightarrow> V \<Rightarrow> V"
  where "ntcf_initial \<CC> z =
    [
      (\<lambda>b\<in>\<^sub>\<circ>\<CC>\<lparr>Obj\<rparr>. THE f. f : z \<mapsto>\<^bsub>\<CC>\<^esub> b),
      cf_const \<CC> \<CC> z,
      cf_id \<CC>,
      \<CC>,
      \<CC>
    ]\<^sub>\<circ>"

definition ntcf_terminal :: "V \<Rightarrow> V \<Rightarrow> V"
  where "ntcf_terminal \<CC> z =
    [
      (\<lambda>b\<in>\<^sub>\<circ>\<CC>\<lparr>Obj\<rparr>. THE f. f : b \<mapsto>\<^bsub>\<CC>\<^esub> z),
      cf_id \<CC>,
      cf_const \<CC> \<CC> z,
      \<CC>,
      \<CC>
    ]\<^sub>\<circ>"

text\<open>Components.\<close>

lemma ntcf_initial_components:
  shows "ntcf_initial \<CC> z\<lparr>NTMap\<rparr> = (\<lambda>c\<in>\<^sub>\<circ>\<CC>\<lparr>Obj\<rparr>. THE f. f : z \<mapsto>\<^bsub>\<CC>\<^esub> c)"
    and "ntcf_initial \<CC> z\<lparr>NTDom\<rparr> = cf_const \<CC> \<CC> z"
    and "ntcf_initial \<CC> z\<lparr>NTCod\<rparr> = cf_id \<CC>"
    and "ntcf_initial \<CC> z\<lparr>NTDGDom\<rparr> = \<CC>"
    and "ntcf_initial \<CC> z\<lparr>NTDGCod\<rparr> = \<CC>"
  unfolding ntcf_initial_def nt_field_simps
  by (simp_all add: nat_omega_simps)

lemmas [cat_lim_cs_simps] = ntcf_initial_components(2-5)

lemma ntcf_terminal_components:
  shows "ntcf_terminal \<CC> z\<lparr>NTMap\<rparr> = (\<lambda>c\<in>\<^sub>\<circ>\<CC>\<lparr>Obj\<rparr>. THE f. f : c \<mapsto>\<^bsub>\<CC>\<^esub> z)"
    and "ntcf_terminal \<CC> z\<lparr>NTDom\<rparr> = cf_id \<CC>"
    and "ntcf_terminal \<CC> z\<lparr>NTCod\<rparr> = cf_const \<CC> \<CC> z"
    and "ntcf_terminal \<CC> z\<lparr>NTDGDom\<rparr> = \<CC>"
    and "ntcf_terminal \<CC> z\<lparr>NTDGCod\<rparr> = \<CC>"
  unfolding ntcf_terminal_def nt_field_simps
  by (simp_all add: nat_omega_simps)

lemmas [cat_lim_cs_simps] = ntcf_terminal_components(2-5)

text\<open>Duality.\<close>

lemma ntcf_initial_op[cat_op_simps]:
  "op_ntcf (ntcf_initial \<CC> z) = ntcf_terminal (op_cat \<CC>) z"
  unfolding
    ntcf_initial_def ntcf_terminal_def op_ntcf_def
    nt_field_simps cat_op_simps
  by (auto simp: nat_omega_simps cat_op_simps)

lemma ntcf_cone_terminal_op[cat_op_simps]:
  "op_ntcf (ntcf_terminal \<CC> z) = ntcf_initial (op_cat \<CC>) z"
  unfolding
    ntcf_initial_def ntcf_terminal_def op_ntcf_def
    nt_field_simps cat_op_simps
  by (auto simp: nat_omega_simps cat_op_simps)

subsubsection\<open>Natural transformation map\<close>

mk_VLambda ntcf_initial_components(1)
  |vsv ntcf_initial_vsv[cat_lim_cs_intros]|
  |vdomain ntcf_initial_vdomain[cat_lim_cs_simps]|
  |app ntcf_initial_app|

mk_VLambda ntcf_terminal_components(1)
  |vsv ntcf_terminal_vsv[cat_lim_cs_intros]|
  |vdomain ntcf_terminal_vdomain[cat_lim_cs_simps]|
  |app ntcf_terminal_app|

lemma (in category)
  assumes "obj_initial \<CC> z" and "c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
  shows ntcf_initial_NTMap_app_is_arr:
    "ntcf_initial \<CC> z\<lparr>NTMap\<rparr>\<lparr>c\<rparr> : z \<mapsto>\<^bsub>\<CC>\<^esub> c"
    and ntcf_initial_NTMap_app_unique:
      "\<And>f'. f' : z \<mapsto>\<^bsub>\<CC>\<^esub> c \<Longrightarrow> f' = ntcf_initial \<CC> z\<lparr>NTMap\<rparr>\<lparr>c\<rparr>"
proof-
  from obj_initialD(2)[OF assms(1,2)] obtain f
    where f: "f : z \<mapsto>\<^bsub>\<CC>\<^esub> c"
      and f_unique: "f' : z \<mapsto>\<^bsub>\<CC>\<^esub> c \<Longrightarrow> f' = f"
    for f'
    by auto
  show is_arr: "ntcf_initial \<CC> z\<lparr>NTMap\<rparr>\<lparr>c\<rparr> : z \<mapsto>\<^bsub>\<CC>\<^esub> c"
  proof(cs_concl_step ntcf_initial_app, rule assms(2), rule theI)
    fix f' assume "f' : z \<mapsto>\<^bsub>\<CC>\<^esub> c"
    from f_unique[OF this] show "f' = f".
  qed (rule f)
  fix f' assume "f' : z \<mapsto>\<^bsub>\<CC>\<^esub> c"
  from f_unique[OF this, folded f_unique[OF is_arr]]
  show "f' = ntcf_initial \<CC> z\<lparr>NTMap\<rparr>\<lparr>c\<rparr>".
qed

lemma (in category) ntcf_initial_NTMap_app_is_arr'[cat_lim_cs_intros]:
  assumes "obj_initial \<CC> z"
    and "c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
    and "\<CC>' = \<CC>"
    and "z' = z"
    and "c' = c"
  shows "ntcf_initial \<CC> z\<lparr>NTMap\<rparr>\<lparr>c\<rparr> : z' \<mapsto>\<^bsub>\<CC>'\<^esub> c'"
  using assms(1,2)
  unfolding assms(3-5)
  by (rule ntcf_initial_NTMap_app_is_arr)

lemma (in category)
  assumes "obj_terminal \<CC> z" and "c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
  shows ntcf_terminal_NTMap_app_is_arr:
    "ntcf_terminal \<CC> z\<lparr>NTMap\<rparr>\<lparr>c\<rparr> : c \<mapsto>\<^bsub>\<CC>\<^esub> z"
    and ntcf_terminal_NTMap_app_unique:
      "\<And>f'. f' : c \<mapsto>\<^bsub>\<CC>\<^esub> z \<Longrightarrow> f' = ntcf_terminal \<CC> z\<lparr>NTMap\<rparr>\<lparr>c\<rparr>"
proof-
  from obj_terminalD(2)[OF assms(1,2)] obtain f
    where f: "f : c \<mapsto>\<^bsub>\<CC>\<^esub> z"
      and f_unique: "f' : c \<mapsto>\<^bsub>\<CC>\<^esub> z \<Longrightarrow> f' = f"
    for f'
    by auto
  show is_arr: "ntcf_terminal \<CC> z\<lparr>NTMap\<rparr>\<lparr>c\<rparr> : c \<mapsto>\<^bsub>\<CC>\<^esub> z"
  proof(cs_concl_step ntcf_terminal_app, rule assms(2), rule theI)
    fix f' assume "f' : c \<mapsto>\<^bsub>\<CC>\<^esub> z"
    from f_unique[OF this] show "f' = f".
  qed (rule f)
  fix f' assume "f' : c \<mapsto>\<^bsub>\<CC>\<^esub> z"
  from f_unique[OF this, folded f_unique[OF is_arr]]
  show "f' = ntcf_terminal \<CC> z\<lparr>NTMap\<rparr>\<lparr>c\<rparr>".
qed

lemma (in category) ntcf_terminal_NTMap_app_is_arr'[cat_lim_cs_intros]:
  assumes "obj_terminal \<CC> z"
    and "c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
    and "\<CC>' = \<CC>"
    and "z' = z"
    and "c' = c"
  shows "ntcf_terminal \<CC> z\<lparr>NTMap\<rparr>\<lparr>c\<rparr> : c' \<mapsto>\<^bsub>\<CC>'\<^esub> z'"
  using assms(1,2)
  unfolding assms(3-5)
  by (rule ntcf_terminal_NTMap_app_is_arr)

subsection\<open>
Initial and terminal objects as limits/colimits of the identity functor
\<close>

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

text\<open>
See
\<^cite>\<open>"noauthor_nlab_nodate"\<close>\footnote{
\url{https://ncatlab.org/nlab/show/initial+object}
}, \<^cite>\<open>"noauthor_nlab_nodate"\<close>\footnote{
\url{https://ncatlab.org/nlab/show/terminal+object}
} and Chapter X-1 in \<^cite>\<open>"mac_lane_categories_2010"\<close>.
\<close>

locale is_cat_obj_id_initial = is_cat_limit \<alpha> \<CC> \<CC> \<open>cf_id \<CC>\<close> z \<ZZ> for \<alpha> \<CC> z \<ZZ>

syntax "_is_cat_obj_id_initial" :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> bool"
  (\<open>(_ :/ _ <\<^sub>C\<^sub>F\<^sub>.\<^sub>0 id\<^sub>C :/ \<mapsto>\<mapsto>\<^sub>C\<index> _)\<close> [51, 51, 51] 51)
translations "\<ZZ> : z <\<^sub>C\<^sub>F\<^sub>.\<^sub>0 id\<^sub>C : \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>" \<rightleftharpoons>
  "CONST is_cat_obj_id_initial \<alpha> \<CC> z \<ZZ>"

locale is_cat_obj_id_terminal = is_cat_colimit \<alpha> \<CC> \<CC> \<open>cf_id \<CC>\<close> z \<ZZ> for \<alpha> \<CC> z \<ZZ>

syntax "_is_cat_obj_id_terminal" :: "V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V \<Rightarrow> bool"
  (\<open>(_ :/ id\<^sub>C >\<^sub>C\<^sub>F\<^sub>.\<^sub>1 _ :/ \<mapsto>\<mapsto>\<^sub>C\<index> _)\<close> [51, 51, 51] 51)
translations "\<ZZ> : id\<^sub>C >\<^sub>C\<^sub>F\<^sub>.\<^sub>1 z : \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>" \<rightleftharpoons>
  "CONST is_cat_obj_id_terminal \<alpha> \<CC> z \<ZZ>"

text\<open>Rules.\<close>

lemma (in is_cat_obj_id_initial)
  is_cat_obj_id_initial_axioms'[cat_lim_cs_intros]:
  assumes "\<alpha>' = \<alpha>" and "z' = z" and "\<CC>' = \<CC>"
  shows "\<ZZ> : z' <\<^sub>C\<^sub>F\<^sub>.\<^sub>0 id\<^sub>C : \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>'"
  unfolding assms by (rule is_cat_obj_id_initial_axioms)

mk_ide rf is_cat_obj_id_initial_def
  |intro is_cat_obj_id_initialI|
  |dest is_cat_obj_id_initialD[dest]|
  |elim is_cat_obj_id_initialE[elim]|

lemmas [cat_lim_cs_intros] = is_cat_obj_id_initialD

lemma (in is_cat_obj_id_terminal)
  is_cat_obj_id_terminal_axioms'[cat_lim_cs_intros]:
  assumes "\<alpha>' = \<alpha>" and "z' = z" and "\<CC>' = \<CC>"
  shows "\<ZZ> : id\<^sub>C >\<^sub>C\<^sub>F\<^sub>.\<^sub>1 z' : \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>'\<^esub> \<CC>'"
  unfolding assms by (rule is_cat_obj_id_terminal_axioms)

mk_ide rf is_cat_obj_id_terminal_def
  |intro is_cat_obj_id_terminalI|
  |dest is_cat_obj_id_terminalD[dest]|
  |elim is_cat_obj_id_terminalE[elim]|

lemmas [cat_lim_cs_intros] = is_cat_obj_id_terminalD

text\<open>Duality.\<close>

lemma (in is_cat_obj_id_initial) is_cat_obj_id_terminal_op:
  "op_ntcf \<ZZ> : id\<^sub>C >\<^sub>C\<^sub>F\<^sub>.\<^sub>1 z : \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> op_cat \<CC>"
  by (intro is_cat_obj_id_terminalI)
    (cs_concl cs_shallow cs_simp: cat_op_simps cs_intro: cat_op_intros)

lemma (in is_cat_obj_id_initial) is_cat_obj_id_terminal_op'[cat_op_intros]:
  assumes "\<CC>' = op_cat \<CC>"
  shows "op_ntcf \<ZZ> : id\<^sub>C >\<^sub>C\<^sub>F\<^sub>.\<^sub>1 z : \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>'"
  unfolding assms by (rule is_cat_obj_id_terminal_op)

lemmas [cat_op_intros] = is_cat_obj_id_initial.is_cat_obj_id_terminal_op'

lemma (in is_cat_obj_id_terminal) is_cat_obj_id_initial_op:
  "op_ntcf \<ZZ> : z <\<^sub>C\<^sub>F\<^sub>.\<^sub>0 id\<^sub>C : \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> op_cat \<CC>"
  by (intro is_cat_obj_id_initialI)
    (cs_concl cs_shallow cs_simp: cat_op_simps cs_intro: cat_op_intros)

lemma (in is_cat_obj_id_terminal) is_cat_obj_id_initial_op'[cat_op_intros]:
  assumes "\<CC>' = op_cat \<CC>"
  shows "op_ntcf \<ZZ> : z <\<^sub>C\<^sub>F\<^sub>.\<^sub>0 id\<^sub>C : \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>'"
  unfolding assms by (rule is_cat_obj_id_initial_op)

lemmas [cat_op_intros] = is_cat_obj_id_terminal.is_cat_obj_id_initial_op'

subsubsection\<open>
Initial and terminal objects as limits/colimits are initial and terminal objects
\<close>

lemma (in category) cat_obj_initial_is_cat_obj_id_initial:
  assumes "obj_initial \<CC> z"
  shows "ntcf_initial \<CC> z : z <\<^sub>C\<^sub>F\<^sub>.\<^sub>0 id\<^sub>C : \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
proof(intro is_cat_obj_id_initialI is_cat_limitI)

  from assms have z: "z \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" by auto
  note obj_initialD = obj_initialD[OF assms]

  show "ntcf_initial \<CC> z : z <\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>n\<^sub>e cf_id \<CC> : \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
  proof(intro is_cat_coneI is_ntcfI', unfold cat_lim_cs_simps)
    show "vfsequence (ntcf_initial \<CC> z)"
      unfolding ntcf_initial_def by auto
    show "vcard (ntcf_initial \<CC> z) = 5\<^sub>\<nat>"
      unfolding ntcf_initial_def by (simp add: nat_omega_simps)
    show "ntcf_initial \<CC> z\<lparr>NTMap\<rparr>\<lparr>a\<rparr> :
      cf_const \<CC> \<CC> z\<lparr>ObjMap\<rparr>\<lparr>a\<rparr> \<mapsto>\<^bsub>\<CC>\<^esub> cf_id \<CC>\<lparr>ObjMap\<rparr>\<lparr>a\<rparr>"
      if "a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" for a
      using that assms(1)
      by
        (
          cs_concl
            cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_lim_cs_intros
         )
    show
      "ntcf_initial \<CC> z\<lparr>NTMap\<rparr>\<lparr>b\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> cf_const \<CC> \<CC> z\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> =
        cf_id \<CC>\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> ntcf_initial \<CC> z\<lparr>NTMap\<rparr>\<lparr>a\<rparr>"
      if "f : a \<mapsto>\<^bsub>\<CC>\<^esub> b" for a b f
    proof-
      from that assms(1) have
        "f \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> ntcf_initial \<CC> z\<lparr>NTMap\<rparr>\<lparr>a\<rparr> : z \<mapsto>\<^bsub>\<CC>\<^esub> b"
        by (cs_concl cs_intro: cat_cs_intros cat_lim_cs_intros)
      note [cat_cs_simps] = ntcf_initial_NTMap_app_unique[
          OF assms(1) cat_is_arrD(3)[OF that] this
          ]
      from that assms(1) show ?thesis
        by
          (
            cs_concl
              cs_simp: cat_cs_simps cs_intro: cat_cs_intros cat_lim_cs_intros
          )
    qed
  qed (use z in \<open>cs_concl cs_intro: cat_cs_intros cat_lim_cs_intros\<close>)+
  then interpret i: is_cat_cone \<alpha> z \<CC> \<CC> \<open>cf_id \<CC>\<close> \<open>ntcf_initial \<CC> z\<close> .

  fix u r assume "u : r <\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>n\<^sub>e cf_id \<CC> : \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
  then interpret u: is_cat_cone \<alpha> r \<CC> \<CC> \<open>cf_id \<CC>\<close> u .

  from obj_initialD(2)[OF u.cat_cone_obj] obtain f
    where f: "f : z \<mapsto>\<^bsub>\<CC>\<^esub> r" and f_unique: "f' : z \<mapsto>\<^bsub>\<CC>\<^esub> r \<Longrightarrow> f' = f" for f'
    by auto
  note u.cat_cone_Comp_commute[cat_cs_simps del]
  from u.ntcf_Comp_commute[OF f] f have "u\<lparr>NTMap\<rparr>\<lparr>r\<rparr> = f \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> u\<lparr>NTMap\<rparr>\<lparr>z\<rparr>"
    by (cs_prems cs_simp: cat_cs_simps cs_intro: cat_cs_intros)

  show "\<exists>!f'.
    f' : r \<mapsto>\<^bsub>\<CC>\<^esub> z \<and>
    u = ntcf_initial \<CC> z \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const \<CC> \<CC> f'"
  proof(intro ex1I conjI; (elim conjE)?)
    from f show "u\<lparr>NTMap\<rparr>\<lparr>z\<rparr> : r \<mapsto>\<^bsub>\<CC>\<^esub> z"
      by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    show "u = ntcf_initial \<CC> z \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const \<CC> \<CC> (u\<lparr>NTMap\<rparr>\<lparr>z\<rparr>)"
    proof(rule ntcf_eqI, rule u.is_ntcf_axioms)
      show "ntcf_initial \<CC> z \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const \<CC> \<CC> (u\<lparr>NTMap\<rparr>\<lparr>z\<rparr>) :
        cf_const \<CC> \<CC> r \<mapsto>\<^sub>C\<^sub>F cf_id \<CC> : \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
        by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
      from z have dom_rhs:
        "\<D>\<^sub>\<circ> ((ntcf_initial \<CC> z \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const \<CC> \<CC> (u\<lparr>NTMap\<rparr>\<lparr>z\<rparr>))\<lparr>NTMap\<rparr>) =
          \<CC>\<lparr>Obj\<rparr>"
        by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
      show "u\<lparr>NTMap\<rparr> =
        (ntcf_initial \<CC> z \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const \<CC> \<CC> (u\<lparr>NTMap\<rparr>\<lparr>z\<rparr>))\<lparr>NTMap\<rparr>"
      proof(rule vsv_eqI, unfold dom_rhs u.ntcf_NTMap_vdomain)
        fix c assume prems: "c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
        then have ic: "ntcf_initial \<CC> z\<lparr>NTMap\<rparr>\<lparr>c\<rparr> : z \<mapsto>\<^bsub>\<CC>\<^esub> c"
          by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
        from u.ntcf_Comp_commute[OF ic] ic have [cat_cs_simps]:
          "ntcf_initial \<CC> z\<lparr>NTMap\<rparr>\<lparr>c\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> u\<lparr>NTMap\<rparr>\<lparr>z\<rparr> = u\<lparr>NTMap\<rparr>\<lparr>c\<rparr>"
          by (cs_prems cs_simp: cat_cs_simps cs_intro: cat_cs_intros) simp
        from prems z show "u\<lparr>NTMap\<rparr>\<lparr>c\<rparr> =
          (ntcf_initial \<CC> z \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const \<CC> \<CC> (u\<lparr>NTMap\<rparr>\<lparr>z\<rparr>))\<lparr>NTMap\<rparr>\<lparr>c\<rparr>"
          by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
      qed (auto intro: cat_cs_intros)
    qed simp_all
    fix f' assume prems:
      "f' : r \<mapsto>\<^bsub>\<CC>\<^esub> z"
      "u = ntcf_initial \<CC> z \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const \<CC> \<CC> f'"
    from z have "ntcf_initial \<CC> z\<lparr>NTMap\<rparr>\<lparr>z\<rparr> : z \<mapsto>\<^bsub>\<CC>\<^esub> z"
      by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    note [cat_cs_simps] = cat_obj_initial_CId[OF assms this, symmetric]
    from prems(2) have
      "u\<lparr>NTMap\<rparr>\<lparr>z\<rparr> = (ntcf_initial \<CC> z \<bullet>\<^sub>N\<^sub>T\<^sub>C\<^sub>F ntcf_const \<CC> \<CC> f')\<lparr>NTMap\<rparr>\<lparr>z\<rparr>"
      by simp
    from this prems(1) show "f' = u\<lparr>NTMap\<rparr>\<lparr>z\<rparr>"
      by (cs_prems cs_simp: cat_cs_simps cs_intro: cat_cs_intros) simp
  qed
qed

lemma (in category) cat_obj_terminal_is_cat_obj_id_terminal:
  assumes "obj_terminal \<CC> z"
  shows "ntcf_terminal \<CC> z : id\<^sub>C >\<^sub>C\<^sub>F\<^sub>.\<^sub>1 z : \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
  by
    (
      rule is_cat_obj_id_initial.is_cat_obj_id_terminal_op
        [
          OF category.cat_obj_initial_is_cat_obj_id_initial[
            OF category_op op_cat_obj_initial[THEN iffD2, OF assms(1)]
            ],
          unfolded cat_op_simps
        ]
    )

lemma cat_cone_CId_obj_initial:
  assumes "\<ZZ> : z <\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>n\<^sub>e cf_id \<CC> : \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>" and "\<ZZ>\<lparr>NTMap\<rparr>\<lparr>z\<rparr> = \<CC>\<lparr>CId\<rparr>\<lparr>z\<rparr>"
  shows "obj_initial \<CC> z"
proof(intro obj_initialI)
  interpret \<ZZ>: is_cat_cone \<alpha> z \<CC> \<CC> \<open>cf_id \<CC>\<close> \<ZZ> by (rule assms(1))
  show "z \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" by (cs_concl cs_intro: cat_cs_intros)
  fix c assume prems: "c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
  show "\<exists>!f. f : z \<mapsto>\<^bsub>\<CC>\<^esub> c"
  proof(intro ex1I)
    from prems show \<ZZ>c: "\<ZZ>\<lparr>NTMap\<rparr>\<lparr>c\<rparr> : z \<mapsto>\<^bsub>\<CC>\<^esub> c"
      by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    fix f assume prems': "f : z \<mapsto>\<^bsub>\<CC>\<^esub> c"
    from \<ZZ>.ntcf_Comp_commute[OF prems'] prems' \<ZZ>c show "f = \<ZZ>\<lparr>NTMap\<rparr>\<lparr>c\<rparr>"
      by (cs_prems cs_simp: cat_cs_simps assms(2) cs_intro: cat_cs_intros) simp
  qed
qed

lemma cat_cocone_CId_obj_terminal:
  assumes "\<ZZ> : cf_id \<CC> >\<^sub>C\<^sub>F\<^sub>.\<^sub>c\<^sub>o\<^sub>c\<^sub>o\<^sub>n\<^sub>e z : \<CC> \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>" and "\<ZZ>\<lparr>NTMap\<rparr>\<lparr>z\<rparr> = \<CC>\<lparr>CId\<rparr>\<lparr>z\<rparr>"
  shows "obj_terminal \<CC> z"
proof-
  interpret \<ZZ>: is_cat_cocone \<alpha> z \<CC> \<CC> \<open>cf_id \<CC>\<close> \<ZZ> by (rule assms(1))
  show ?thesis
    by
      (
        rule cat_cone_CId_obj_initial
          [
            OF \<ZZ>.is_cat_cone_op[unfolded cat_op_simps],
            unfolded cat_op_simps,
            OF assms(2)
          ]
      )
qed

lemma (in is_cat_obj_id_initial) cat_oii_obj_initial: "obj_initial \<CC> z"
proof(rule cat_cone_CId_obj_initial, rule is_cat_cone_axioms)
  from cat_lim_unique_cone'[OF is_cat_cone_axioms] obtain f
    where f: "f : z \<mapsto>\<^bsub>\<CC>\<^esub> z"
      and \<ZZ>'j: "\<And>j. j \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr> \<Longrightarrow> \<ZZ>\<lparr>NTMap\<rparr>\<lparr>j\<rparr> = \<ZZ>\<lparr>NTMap\<rparr>\<lparr>j\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> f"
      and f_unique:
        "\<lbrakk>
          f' : z \<mapsto>\<^bsub>\<CC>\<^esub> z;
          \<And>j. j \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr> \<Longrightarrow> \<ZZ>\<lparr>NTMap\<rparr>\<lparr>j\<rparr> = \<ZZ>\<lparr>NTMap\<rparr>\<lparr>j\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> f'
         \<rbrakk> \<Longrightarrow> f' = f"
    for f'
    by metis
  have CId_z: "\<CC>\<lparr>CId\<rparr>\<lparr>z\<rparr> : z \<mapsto>\<^bsub>\<CC>\<^esub> z"
    by (cs_concl cs_intro: cat_cs_intros)
  have "\<ZZ>\<lparr>NTMap\<rparr>\<lparr>j\<rparr> = \<ZZ>\<lparr>NTMap\<rparr>\<lparr>j\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> \<CC>\<lparr>CId\<rparr>\<lparr>z\<rparr>" if "j \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" for j
    using that by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
  from f_unique[OF CId_z this] have CId_f: "\<CC>\<lparr>CId\<rparr>\<lparr>z\<rparr> = f" .
  have \<ZZ>z: "\<ZZ>\<lparr>NTMap\<rparr>\<lparr>z\<rparr> : z \<mapsto>\<^bsub>\<CC>\<^esub> z"
    by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
  have "\<ZZ>\<lparr>NTMap\<rparr>\<lparr>c\<rparr> = \<ZZ>\<lparr>NTMap\<rparr>\<lparr>c\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> \<ZZ>\<lparr>NTMap\<rparr>\<lparr>z\<rparr>" if "c \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>" for c
  proof-
    from that have \<ZZ>c: "\<ZZ>\<lparr>NTMap\<rparr>\<lparr>c\<rparr> : z \<mapsto>\<^bsub>\<CC>\<^esub> c"
      by (cs_concl cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
    note cat_cone_Comp_commute[cat_cs_simps del]
    from ntcf_Comp_commute[OF \<ZZ>c] \<ZZ>c show
      "\<ZZ>\<lparr>NTMap\<rparr>\<lparr>c\<rparr> = \<ZZ>\<lparr>NTMap\<rparr>\<lparr>c\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> \<ZZ>\<lparr>NTMap\<rparr>\<lparr>z\<rparr>"
      by (cs_prems cs_simp: cat_cs_simps cs_intro: cat_cs_intros)
  qed
  from f_unique[OF \<ZZ>z this] have "\<ZZ>\<lparr>NTMap\<rparr>\<lparr>z\<rparr> = f" .
  with CId_f show "\<ZZ>\<lparr>NTMap\<rparr>\<lparr>z\<rparr> = \<CC>\<lparr>CId\<rparr>\<lparr>z\<rparr>" by simp
qed

lemma (in is_cat_obj_id_terminal) cat_oit_obj_terminal: "obj_terminal \<CC> z"
  by
    (
      rule is_cat_obj_id_initial.cat_oii_obj_initial[
        OF is_cat_obj_id_initial_op, unfolded cat_op_simps
        ]
    )

lemma (in category) cat_is_cat_obj_id_initial_obj_initial_iff:
  "(ntcf_initial \<CC> z : z <\<^sub>C\<^sub>F\<^sub>.\<^sub>0 id\<^sub>C : \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>) \<longleftrightarrow> obj_initial \<CC> z"
  using
    cat_obj_initial_is_cat_obj_id_initial
    is_cat_obj_id_initial.cat_oii_obj_initial
  by auto

lemma (in category) cat_is_cat_obj_id_terminal_obj_terminal_iff:
  "(ntcf_terminal \<CC> z : id\<^sub>C >\<^sub>C\<^sub>F\<^sub>.\<^sub>1 z : \<mapsto>\<mapsto>\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>) \<longleftrightarrow> obj_terminal \<CC> z"
  using
    cat_obj_terminal_is_cat_obj_id_terminal
    is_cat_obj_id_terminal.cat_oit_obj_terminal
  by auto

text\<open>\newpage\<close>

end


section \<open>Definition and Soundness of Refinement Mappings,
  Forward Simulations, and Backward Simulations\<close>

theory Simulations
imports IOA
begin

context IOA
begin

definition trace_match where trace_match_def[simp]:
  "trace_match A a e \<equiv> let tr = trace (ioa.asig A) e in
                    if a \<in> ext A then tr = [a] else tr = []"

definition refines where
  "refines e s a t A f \<equiv> fst e = f s \<and> last_state e = f t \<and> is_exec_frag_of A e
            \<and> trace_match A a e"

definition
  is_ref_map :: "('s1 \<Rightarrow> 's2) \<Rightarrow> ('s1,'a)ioa \<Rightarrow> ('s2,'a)ioa \<Rightarrow> bool" where
  "is_ref_map f B A \<equiv>
    (\<forall> s \<in> start B . f s \<in> start A) \<and> (\<forall> s t a. reachable B s \<and> s \<midarrow>a\<midarrow>B\<longrightarrow> t
      \<longrightarrow> (\<exists> e . refines e s a t A f ))"

definition
  is_forward_sim :: "('s1 \<Rightarrow> ('s2 set)) \<Rightarrow> ('s1,'a)ioa \<Rightarrow> ('s2,'a)ioa \<Rightarrow> bool" where
  "is_forward_sim f B A \<equiv>
   (\<forall> s \<in> start B . f s \<inter> start A \<noteq> {})
   \<and> (\<forall> s s' t a. s' \<in> f s \<and> s \<midarrow>a\<midarrow>B\<longrightarrow> t \<and> reachable B s
        \<longrightarrow> (\<exists> e . fst e = s' \<and> last_state e \<in> f t \<and> is_exec_frag_of A e
              \<and> trace_match A a e))"

definition
  is_backward_sim :: "('s1 \<Rightarrow> ('s2 set)) \<Rightarrow> ('s1,'a)ioa \<Rightarrow> ('s2,'a)ioa \<Rightarrow> bool" where
  "is_backward_sim f B A \<equiv>
   (\<forall> s . f s \<noteq> {}) \<comment> \<open> Restricting this to reachable states would suffice \<close>
   \<and> (\<forall> s \<in> start B . f s \<subseteq> start A)
   \<and> (\<forall> s t a t'. t' \<in> f t \<and> s \<midarrow>a\<midarrow>B\<longrightarrow> t \<and> reachable B s
        \<longrightarrow> (\<exists> e . fst e \<in> f s \<and> last_state e = t' \<and> is_exec_frag_of A e
                \<and> trace_match A a e))"

subsection "A series of lemmas that will be useful in the soundness proofs"

context begin

private
lemma step_eq_traces:
  fixes e_B' A e e_A' a t
  defines "e_A \<equiv> append_exec e_A' e" and "e_B \<equiv> cons_exec e_B' (a,t)"
  and "tr \<equiv> trace (ioa.asig A) e"
  assumes 1:"trace (ioa.asig A) e_A' = trace (ioa.asig A) e_B'"
  and 2:"if a \<in> ext A then tr = [a] else tr = []"
  shows "trace (ioa.asig A) e_A = trace (ioa.asig A) e_B"
proof -
  have 3:"trace (ioa.asig A) e_B =
         (if a \<in> ext A then a # (trace (ioa.asig A) e_B') else trace (ioa.asig A) e_B')"
    using e_B_def by (auto simp add:traces_simps cons_exec_def)
  have 4:"trace (ioa.asig A) e_A =
         (if a \<in> ext A then a # trace (ioa.asig A) e_A' else trace (ioa.asig A) e_A')"
    using 2 trace_append_is_append_trace[of "ioa.asig A" e_A' e]
      by (auto simp add:e_A_def tr_def split:if_split_asm)
  show ?thesis using 1 3 4 by simp
qed

private
lemma exec_inc_imp_trace_inc:
  fixes A B
  assumes "ext B = ext A"
  and "\<And> e_B . is_exec_of B e_B
    \<Longrightarrow> \<exists> e_A . is_exec_of A e_A \<and> trace (ioa.asig A) e_A = trace (ioa.asig A) e_B"
  shows "traces B \<subseteq> traces A"
proof -
  { fix t
    assume "t \<in> traces B"
    with this obtain e where 1:"t = trace (ioa.asig B) e" and 2:"is_exec_of B e"
      using traces_alt assms(1) by blast
    from 1 and assms(1) have 3:"t = trace (ioa.asig A) e" by (simp add:trace_def)
    from 2 3 and assms(2) obtain e' where
      "is_exec_of A e' \<and> trace (ioa.asig A) e' = trace (ioa.asig A) e" by blast
    hence "t \<in> traces A" using 3 traces_alt by fastforce }
  thus ?thesis by fast
qed

subsection "Soundness of Refinement Mappings"

private
lemma ref_map_execs:
  fixes A::"('sA,'a)ioa" and B::"('sB,'a)ioa" and f::"'sB \<Rightarrow> 'sA" and e_B
  assumes "is_ref_map f B A" and "is_exec_of B e_B"
  shows "\<exists> e_A .  is_exec_of A e_A
    \<and> trace (ioa.asig A) e_A = trace (ioa.asig A) e_B"
proof -
  note assms(2)
  hence "\<exists> e_A .  is_exec_of A e_A
                  \<and> trace (ioa.asig A) e_A = trace (ioa.asig A) e_B
                  \<and> last_state e_A = f (last_state e_B)"
  proof (induction "snd e_B" arbitrary:e_B)
    case Nil
    let ?e_A = "(f (fst e_B), [])"
    have "\<And> s . s \<in> start B \<Longrightarrow> f s \<in> start A" using assms(1) by (simp add:is_ref_map_def)
    hence "is_exec_of A ?e_A" using Nil.prems(1) by (simp add:is_exec_of_def)
    moreover
    have "trace (ioa.asig A) ?e_A = trace (ioa.asig A) e_B"
      using Nil.hyps by (simp add:traces_simps)
    moreover
    have "last_state ?e_A = f (last_state e_B)"
      using Nil.hyps by (metis last_state.simps(1) prod.collapse)
    ultimately show ?case by fast
  next
    case (Cons p ps e_B)
    let ?e_B' = "(fst e_B, ps)"
    let ?s = "last_state ?e_B'" let ?t = "snd p" let ?a = "fst p"
    have 1:"is_exec_of B ?e_B'" and 2:"?s\<midarrow>?a\<midarrow>B\<longrightarrow>?t"
      using Cons.prems and Cons.hyps(2)
        by (simp_all add:is_exec_of_def,
            cases "(B,fst e_B,p#ps)" rule:is_exec_frag_of.cases, auto,
            cases "(B,fst e_B,p#ps)" rule:is_exec_frag_of.cases, auto)
    with Cons.hyps(1) obtain e_A' where ih1:"is_exec_of A e_A'"
      and ih2:"trace (ioa.asig A) e_A' = trace (ioa.asig A) ?e_B'"
      and ih3:"last_state e_A' = f ?s" by fastforce
    from 1 have 3:"reachable B ?s" using last_state_reachable by fast
    obtain e where 4:"fst e = f ?s" and 5:"last_state e = f ?t"
    and 6:"is_exec_frag_of A e"
    and 7:"let tr = trace (ioa.asig A) e in if ?a \<in> ext A
      then tr = [?a] else tr = []"
        using 2 and 3 and assms(1)
          by (force simp add:is_ref_map_def refines_def)
    let ?e_A = "append_exec e_A' e"
    have "is_exec_of A ?e_A"
      using ih1 ih3 4 6 append_exec_frags_is_exec_frag[of A e e_A']
        by (metis append_exec_def append_exec_frags_is_exec_frag
          fst_conv is_exec_of_def)
    moreover
    have "trace (ioa.asig A) ?e_A = trace (ioa.asig A) e_B"
      using ih2 Cons.hyps(2) 7 step_eq_traces[of A e_A' ?e_B' ?a e]
        by (auto simp add:cons_exec_def) (metis prod.collapse)
    moreover have "last_state ?e_A = f ?t" using ih3 4 5 last_state_of_append
      by metis
    ultimately show ?case using Cons.hyps(2)
      by (metis last_state.simps(2) surjective_pairing)
  qed
  thus ?thesis by blast
qed

theorem ref_map_soundness:
  fixes A::"('sA,'a)ioa" and B::"('sB,'a)ioa" and f::"'sB \<Rightarrow> 'sA"
  assumes "is_ref_map f B A" and "ext A = ext B"
  shows "traces B \<subseteq> traces A"
  using assms ref_map_execs exec_inc_imp_trace_inc by metis

subsection "Soundness of Forward Simulations"

private
lemma forward_sim_execs:
  fixes A::"('sA,'a)ioa" and B::"('sB,'a)ioa" and f::"'sB \<Rightarrow> 'sA set" and e_B
  assumes "is_forward_sim f B A" and "is_exec_of B e_B"
  shows "\<exists> e_A .  is_exec_of A e_A
    \<and> trace (ioa.asig A) e_A = trace (ioa.asig A) e_B"
proof -
  note assms(2)
  hence "\<exists> e_A .  is_exec_of A e_A
                  \<and> trace (ioa.asig A) e_A = trace (ioa.asig A) e_B
                  \<and> last_state e_A \<in> f (last_state e_B)"
  proof (induction "snd e_B" arbitrary:e_B)
    case Nil
    have "\<And> s . s \<in> start B \<Longrightarrow> f s \<inter> start A \<noteq> {}"
      using assms(1) by (simp add:is_forward_sim_def)
    with this obtain s' where 1:"s' \<in> f (fst e_B)" and 2:"s' \<in> start A"
      by (metis Int_iff Nil.prems all_not_in_conv is_exec_of_def)
    let ?e_A = "(s', [])"
    have "is_exec_of A ?e_A" using 2 by (simp add:is_exec_of_def)
    moreover
    have "trace (ioa.asig A) ?e_A = trace (ioa.asig A) e_B" using Nil.hyps
      by (simp add:trace_def schedule_def filter_act_def)
    moreover
    have "last_state ?e_A \<in> f (last_state e_B)"
      using Nil.hyps 1 by (metis last_state.simps(1) surjective_pairing)
    ultimately show ?case by fast
  next
    case (Cons p ps e_B)
    let ?e_B' = "(fst e_B, ps)"
    let ?s = "last_state ?e_B'" let ?t = "snd p" let ?a = "fst p"
    have 1:"is_exec_of B ?e_B'" and 2:"?s\<midarrow>?a\<midarrow>B\<longrightarrow>?t"
      using Cons.prems and Cons.hyps(2)
        by (simp_all add:is_exec_of_def,
            cases "(B,fst e_B,p#ps)" rule:is_exec_frag_of.cases, auto,
            cases "(B,fst e_B,p#ps)" rule:is_exec_frag_of.cases, auto)
    with Cons.hyps(1) obtain e_A' where ih1:"is_exec_of A e_A'"
      and ih2:"trace (ioa.asig A) e_A' = trace (ioa.asig A) ?e_B'"
      and ih3:"last_state e_A' \<in> f ?s" by fastforce
    from 1 have 3:"reachable B ?s" using last_state_reachable by fast
    obtain e where 4:"fst e = last_state e_A'" and 5:"last_state e \<in> f ?t"
    and 6:"is_exec_frag_of A e"
    and 7:"let tr = trace (ioa.asig A) e in if ?a \<in> ext A then tr = [?a] else tr = []"
      using 2 3 assms(1) ih3 by (simp add:is_forward_sim_def)
        (metis prod.collapse prod.inject)
    let ?e_A = "append_exec e_A' e"
    have "is_exec_of A ?e_A"
      using ih1 ih3 4 6 append_exec_frags_is_exec_frag[of A e e_A']
        by (metis append_exec_def append_exec_frags_is_exec_frag
            fst_conv is_exec_of_def)
    moreover
    have "trace (ioa.asig A) ?e_A = trace (ioa.asig A) e_B"
      using ih2 Cons.hyps(2) 7 step_eq_traces[of A e_A' ?e_B' ?a e]
        by (auto simp add:cons_exec_def Let_def) (metis prod.collapse)
    moreover have "last_state ?e_A \<in> f ?t" using ih3 4 5 last_state_of_append
      by metis
    ultimately show ?case using Cons.hyps(2)
      by (metis last_state.simps(2) surjective_pairing)
  qed
  thus ?thesis by blast
qed

theorem forward_sim_soundness:
  fixes A::"('sA,'a)ioa" and B::"('sB,'a)ioa" and f::"'sB \<Rightarrow> 'sA set"
  assumes "is_forward_sim f B A" and "ext A = ext B"
  shows "traces B \<subseteq> traces A"
  using assms forward_sim_execs exec_inc_imp_trace_inc by metis

subsection "Soundness of Backward Simulations"

private
lemma backward_sim_execs:
  fixes A::"('sA,'a)ioa" and B::"('sB,'a)ioa" and f::"'sB \<Rightarrow> 'sA set" and e_B
  assumes "is_backward_sim f B A" and "is_exec_of B e_B"
  shows "\<exists> e_A .  is_exec_of A e_A
    \<and> trace (ioa.asig A) e_A = trace (ioa.asig A) e_B"
proof -
  note assms(2)
  hence "\<forall> s \<in> f (last_state e_B). \<exists> e_A .
          is_exec_of A e_A
          \<and> trace (ioa.asig A) e_A = trace (ioa.asig A) e_B
          \<and> last_state e_A = s"
  proof (induction "snd e_B" arbitrary:e_B)
    case Nil
    { fix s' assume 1:"s' \<in> f(last_state e_B)"
      have 2:"\<And> s . s \<in> start B \<Longrightarrow> f s \<subseteq> start A "
        using assms(1) by (simp add:is_backward_sim_def)
      from Nil 1 2 have 3:"s' \<in> start A"
        by (metis (full_types) is_exec_of_def last_state.simps(1) set_mp surjective_pairing)
      let ?e_A = "(s', [])"
      have 4:"is_exec_of A ?e_A" using 3 by (simp add:is_exec_of_def)
      have 5:"trace (ioa.asig A) ?e_A = trace (ioa.asig A) e_B" using Nil.hyps
        by (simp add:trace_def schedule_def filter_act_def)
      have 6:"last_state ?e_A \<in> f (last_state e_B)"
        using Nil.hyps 1 by (metis last_state.simps(1))
      note 4 5 6 }
    thus ?case by fastforce
  next
    case (Cons p ps e_B)
    { fix t' assume 8:"t' \<in> f (last_state e_B)"
      let ?e_B' = "(fst e_B, ps)"
      let ?s = "last_state ?e_B'" let ?t = "snd p" let ?a = "fst p"
      have 5:"?t = last_state e_B" using Cons.hyps(2)
        by (metis last_state.simps(2) prod.collapse)
      have 1:"is_exec_of B ?e_B'" and 2:"?s\<midarrow>?a\<midarrow>B\<longrightarrow>?t"
        using Cons.prems and Cons.hyps(2)
          by (simp_all add:is_exec_of_def,
              cases "(B,fst e_B, p#ps)" rule:is_exec_frag_of.cases, auto,
              cases "(B,fst e_B, p#ps)" rule:is_exec_frag_of.cases, auto)
      from 1 have 3:"reachable B ?s" using last_state_reachable by fast
      obtain e where 4:"fst e \<in> f ?s" and 5:"last_state e = t'"
      and 6:"is_exec_frag_of A e"
      and 7:"let tr = trace (ioa.asig A) e in
        if ?a \<in> ext A then tr = [?a] else tr = []"
        using 2 assms(1) 8 5 3 by (auto simp add: is_backward_sim_def, metis)
      obtain e_A' where ih1:"is_exec_of A e_A'"
        and ih2:"trace (ioa.asig A) e_A' = trace (ioa.asig A) ?e_B'"
        and ih3:"last_state e_A' = fst e"
          using 1 4 Cons.hyps(1) by (metis snd_conv)
      let ?e_A = "append_exec e_A' e"
      have "is_exec_of A ?e_A"
        using ih1 ih3 4 6 append_exec_frags_is_exec_frag[of A e e_A']
          by (metis append_exec_def append_exec_frags_is_exec_frag
            fst_conv is_exec_of_def)
      moreover
      have "trace (ioa.asig A) ?e_A = trace (ioa.asig A) e_B"
        using ih2 Cons.hyps(2) 7 step_eq_traces[of A e_A' ?e_B' ?a e]
          by (auto simp add:cons_exec_def Let_def) (metis prod.collapse)
      moreover have "last_state ?e_A = t'" using ih3 5 last_state_of_append
        by metis
      ultimately have "\<exists> e_A . is_exec_of A e_A
        \<and> trace (ioa.asig A) e_A = trace (ioa.asig A) e_B
        \<and> last_state e_A = t'" by blast }
    thus ?case by blast
  qed
  moreover
  from assms(1) have total:"\<And> s . f s \<noteq> {}" by (simp add:is_backward_sim_def)
  ultimately show ?thesis by fast
qed

theorem backward_sim_soundness:
  fixes A::"('sA,'a)ioa" and B::"('sB,'a)ioa" and f::"'sB \<Rightarrow> 'sA set"
  assumes "is_backward_sim f B A" and "ext A = ext B"
  shows "traces B \<subseteq> traces A"
  using assms backward_sim_execs exec_inc_imp_trace_inc by metis

declare trace_match_def[simp del]

end

end

end


theory Flow_Congs
  imports Reachability_Analysis
begin

lemma lipschitz_on_congI:
  assumes "L'-lipschitz_on s' g'"
  assumes "s' = s"
  assumes "L' \<le> L"
  assumes "\<And>x y. x \<in> s \<Longrightarrow> g' x = g x"
  shows "L-lipschitz_on s g"
  using assms
  by (auto simp: lipschitz_on_def intro!: order_trans[OF _ mult_right_mono[OF \<open>L' \<le> L\<close>]])

lemma local_lipschitz_congI:
  assumes "local_lipschitz s' t' g'"
  assumes "s' = s"
  assumes "t' = t"
  assumes "\<And>x y. x \<in> s \<Longrightarrow> y \<in> t \<Longrightarrow> g' x y = g x y"
  shows "local_lipschitz s t g"
proof -
  from assms have "local_lipschitz s t g'"
    by (auto simp: local_lipschitz_def)
  then show ?thesis
    apply (auto simp: local_lipschitz_def)
    apply (drule_tac bspec, assumption)
    apply (drule_tac bspec, assumption)
    apply auto
    subgoal for x y u L
    apply (rule exI[where x=u])
      apply (auto intro!: exI[where x=L])
      apply (drule bspec)
      apply simp
      apply (rule lipschitz_on_congI, assumption, rule refl, rule order_refl)
      using assms
      apply (auto)
      done
    done
qed

context ll_on_open_it\<comment> \<open>TODO: do this more generically for @{const ll_on_open_it}\<close>
begin

context fixes S Y g assumes cong: "X = Y" "T = S" "\<And>x t. x \<in> Y \<Longrightarrow> t \<in> S \<Longrightarrow> f t x = g t x"
begin

lemma ll_on_open_congI: "ll_on_open S g Y"
proof -
  interpret Y: ll_on_open_it S f Y t0
    apply (subst cong(1)[symmetric])
    apply (subst cong(2)[symmetric])
    by unfold_locales
  show ?thesis
    apply standard
    subgoal
      using local_lipschitz
      apply (rule local_lipschitz_congI)
      using cong by simp_all
    subgoal apply (subst continuous_on_cong) prefer 3 apply (rule cont)
      using cong by (auto)
    subgoal using open_domain by (auto simp: cong)
    subgoal using open_domain by (auto simp: cong)
    done
qed

lemma existence_ivl_subsetI:
  assumes t: "t \<in> existence_ivl t0 x0"
  shows "t \<in> ll_on_open.existence_ivl S g Y t0 x0"
proof -
  from assms have \<open>t0 \<in> T\<close> "x0 \<in> X"
    by (rule mem_existence_ivl_iv_defined)+
  interpret Y: ll_on_open S g Y by (rule ll_on_open_congI)
  have "(flow t0 x0 solves_ode f) (existence_ivl t0 x0) X"
    by (rule flow_solves_ode) (auto simp: \<open>x0 \<in> X\<close> \<open>t0 \<in> T\<close>)
  then have "(flow t0 x0 solves_ode f) {t0--t} X"
    by (rule solves_ode_on_subset)
     (auto simp add: t local.closed_segment_subset_existence_ivl)
  then have "(flow t0 x0 solves_ode g) {t0--t} Y"
    apply (rule solves_ode_congI)
       apply (auto intro!: assms cong)
    using \<open>(flow t0 x0 solves_ode f) {t0--t} X\<close> local.cong(1) solves_ode_domainD apply blast
    using \<open>t0 \<in> T\<close> assms closed_segment_subset_domainI general.mem_existence_ivl_subset local.cong(2)
    by blast
  then show ?thesis
    apply (rule Y.existence_ivl_maximal_segment)
    subgoal by (simp add: \<open>t0 \<in> T\<close> \<open>x0 \<in> X\<close>)
    apply (subst cong[symmetric])
    using \<open>t0 \<in> T\<close> assms closed_segment_subset_domainI general.mem_existence_ivl_subset local.cong(2)
    by blast
qed

lemma existence_ivl_cong:
  shows "existence_ivl t0 x0 = ll_on_open.existence_ivl S g Y t0 x0"
proof -
  interpret Y: ll_on_open S g Y by (rule ll_on_open_congI)
  show ?thesis
    apply (auto )
    subgoal by (rule existence_ivl_subsetI)
    subgoal
      apply (rule Y.existence_ivl_subsetI)
      using cong
      by auto
    done
qed

lemma flow_cong:
  assumes "t \<in> existence_ivl t0 x0"
  shows "flow t0 x0 t = ll_on_open.flow S g Y t0 x0 t"
proof -
  interpret Y: ll_on_open S g Y by (rule ll_on_open_congI)
  from assms have "t0 \<in> T" "x0 \<in> X"
    by (rule mem_existence_ivl_iv_defined)+
  from cong \<open>x0 \<in> X\<close> have "x0 \<in> Y" by auto
  from cong \<open>t0 \<in> T\<close> have "t0 \<in> S" by auto
  show ?thesis
    apply (rule Y.equals_flowI[where T'="existence_ivl t0 x0"])
    subgoal using \<open>t0 \<in> T\<close> \<open>x0 \<in> X\<close>  by auto
    subgoal using \<open>x0 \<in> X\<close> by auto
    subgoal by (auto simp: existence_ivl_cong \<open>x0 \<in> X\<close>)
    subgoal
      apply (rule solves_ode_congI)
          apply (rule flow_solves_ode[OF \<open>t0 \<in> T\<close> \<open>x0 \<in> X\<close>])
      using existence_ivl_subset[of x0]
      by (auto simp: cong(2)[symmetric] cong(1)[symmetric] assms flow_in_domain intro!: cong)
    subgoal using \<open>t0 \<in> S\<close> \<open>t0 \<in> T\<close> \<open>x0 \<in> X\<close> \<open>x0 \<in> Y\<close>
      by (auto simp:)
    subgoal by fact
    done
qed

end

end

context auto_ll_on_open begin

context fixes Y g assumes cong: "X = Y" "\<And>x t. x \<in> Y \<Longrightarrow> f x = g x"
begin

lemma auto_ll_on_open_congI: "auto_ll_on_open g Y"
  apply unfold_locales
  subgoal
    using local_lipschitz
    apply (rule local_lipschitz_congI)
    using cong by auto
  subgoal
    using open_domain
    using cong by auto
  done

lemma existence_ivl0_cong:
  shows "existence_ivl0 x0 = auto_ll_on_open.existence_ivl0 g Y x0"
proof -
  interpret Y: auto_ll_on_open g Y by (rule auto_ll_on_open_congI)
  show ?thesis
    unfolding Y.existence_ivl0_def
    apply (rule existence_ivl_cong)
    using cong by auto
qed

lemma flow0_cong:
  assumes "t \<in> existence_ivl0 x0"
  shows "flow0 x0 t = auto_ll_on_open.flow0 g Y x0 t"
proof -
  interpret Y: auto_ll_on_open g Y by (rule auto_ll_on_open_congI)
  show ?thesis
    unfolding Y.flow0_def
    apply (rule flow_cong)
    using cong assms by auto
qed

end

end

context c1_on_open_euclidean begin

context fixes Y g assumes cong: "X = Y" "\<And>x t. x \<in> Y \<Longrightarrow> f x = g x"
begin

lemma f'_cong: "(g has_derivative blinfun_apply (f' x)) (at x)" if "x \<in> Y"
proof -
  from derivative_rhs[of x] that cong
  have "(f has_derivative blinfun_apply (f' x)) (at x within Y)"
    by (auto intro!: has_derivative_at_withinI)
  then have "(g has_derivative blinfun_apply (f' x)) (at x within Y)"
    by (rule has_derivative_transform_within[OF _ zero_less_one that])
       (auto simp: cong)
  then show ?thesis
    using at_within_open[OF that] cong open_dom
    by (auto simp: )
qed

lemma c1_on_open_euclidean_congI: "c1_on_open_euclidean g f' Y"
proof -
  interpret Y: c1_on_open_euclidean f f' Y unfolding cong[symmetric] by unfold_locales
  show ?thesis
    apply standard
    subgoal using cong by simp
    subgoal by (rule f'_cong)
    subgoal by (simp add: cong[symmetric] continuous_derivative)
    done
qed

lemma vareq_cong: "vareq x0 t = c1_on_open_euclidean.vareq g f' Y x0 t"
  if "t \<in> existence_ivl0 x0"
proof -
  interpret Y: c1_on_open_euclidean g f' Y by (rule c1_on_open_euclidean_congI)
  show ?thesis
    unfolding vareq_def Y.vareq_def
    apply (rule arg_cong[where f=f'])
    apply (rule flow0_cong)
    using cong that by auto
qed

lemma Dflow_cong:
  assumes "t \<in> existence_ivl0 x0"
  shows "Dflow x0 t = c1_on_open_euclidean.Dflow g f' Y x0 t"
proof -
  interpret Y: c1_on_open_euclidean g f' Y by (rule c1_on_open_euclidean_congI)
  from assms have "x0 \<in> X"
    by (rule mem_existence_ivl_iv_defined)
  from cong \<open>x0 \<in> X\<close> have "x0 \<in> Y" by auto
  show ?thesis
    unfolding Dflow_def Y.Dflow_def
    apply (rule mvar.equals_flowI[symmetric, OF _ _ order_refl])
    subgoal using \<open>x0 \<in> X\<close> by auto
    subgoal using \<open>x0 \<in> X\<close> by auto
    subgoal
      apply (rule solves_ode_congI)
          apply (rule Y.mvar.flow_solves_ode)
           prefer 3 apply (rule refl)
      subgoal using \<open>x0 \<in> X\<close> \<open>x0 \<in> Y\<close> by auto
      subgoal using \<open>x0 \<in> X\<close> \<open>x0 \<in> Y\<close> by auto
      subgoal for t
        apply (subst vareq_cong)
         apply (subst (asm) Y.mvar_existence_ivl_eq_existence_ivl)
        subgoal using \<open>x0 \<in> Y\<close> by simp
        subgoal
          using cong
          by (subst (asm) existence_ivl0_cong[symmetric]) auto
        subgoal using \<open>x0 \<in> Y\<close> by simp
        done
      subgoal using \<open>x0 \<in> X\<close> \<open>x0 \<in> Y\<close>
        apply (subst mvar_existence_ivl_eq_existence_ivl)
        subgoal by simp
        apply (subst Y.mvar_existence_ivl_eq_existence_ivl)
        subgoal by simp
        using cong
        by (subst existence_ivl0_cong[symmetric]) auto
      subgoal by simp
      done
    subgoal using \<open>x0 \<in> X\<close> \<open>x0 \<in> Y\<close> by auto
    subgoal
      apply (subst mvar_existence_ivl_eq_existence_ivl)
       apply auto
       apply fact+
      done
    done
qed

lemma flowsto_congI1:
  assumes "flowsto A B C D"
  shows "c1_on_open_euclidean.flowsto g f' Y A B C D"
proof -
  interpret Y: c1_on_open_euclidean g f' Y by (rule c1_on_open_euclidean_congI)
  show ?thesis
    using assms
    unfolding flowsto_def Y.flowsto_def
    apply (auto simp: existence_ivl0_cong[OF cong]  flow0_cong[OF cong])
       apply (drule bspec, assumption)
    apply clarsimp
    apply (rule bexI)
    apply (rule conjI)
       apply assumption
    apply (subst flow0_cong[symmetric, OF cong])
     apply auto
      apply (subst existence_ivl0_cong[OF cong])
    apply auto
    apply (subst Dflow_cong[symmetric])
     apply auto
      apply (subst existence_ivl0_cong[OF cong])
    apply auto
    apply (drule bspec, assumption)
    apply (subst flow0_cong[symmetric, OF cong])
     apply auto
      apply (subst existence_ivl0_cong[OF cong])
    apply auto defer
    apply (subst Dflow_cong[symmetric])
     apply auto
      apply (subst existence_ivl0_cong[OF cong])
    apply auto
    apply (drule Y.closed_segment_subset_existence_ivl)
    by (auto simp: open_segment_eq_real_ivl closed_segment_eq_real_ivl split: if_splits)
qed

lemma flowsto_congI2:
  assumes "c1_on_open_euclidean.flowsto g f' Y A B C D"
  shows "flowsto A B C D"
proof -
  interpret Y: c1_on_open_euclidean g f' Y by (rule c1_on_open_euclidean_congI)
  show ?thesis
    apply (rule Y.flowsto_congI1)
    using assms
    by (auto simp: cong)
qed

lemma flowsto_congI: "flowsto A B C D = c1_on_open_euclidean.flowsto g f' Y A B C D"
  using flowsto_congI1[of A B C D] flowsto_congI2[of A B C D] by auto

lemma
  returns_to_congI1:
  assumes "returns_to A x"
  shows "auto_ll_on_open.returns_to g Y A x"
proof -
  interpret Y: c1_on_open_euclidean g f' Y by (rule c1_on_open_euclidean_congI)
  from assms obtain t where t:
    "\<forall>\<^sub>F t in at_right 0. flow0 x t \<notin> A"
    "0 < t" "t \<in> existence_ivl0 x" "flow0 x t \<in> A"
    by (auto simp: returns_to_def)

  note t(1)
  moreover
  have "\<forall>\<^sub>F s in at_right 0. s < t"
    using tendsto_ident_at \<open>0 < t\<close>
    by (rule order_tendstoD)
  moreover have "\<forall>\<^sub>F s in at_right 0. 0 < s"
    by (auto simp: eventually_at_topological)
  ultimately have "\<forall>\<^sub>F t in at_right 0. Y.flow0 x t \<notin> A"
    apply eventually_elim
    using ivl_subset_existence_ivl[OF \<open>t \<in> _\<close>]
    apply (subst (asm) flow0_cong[OF cong])
    by (auto simp: )

  moreover have "\<exists>t>0. t \<in> Y.existence_ivl0 x \<and> Y.flow0 x t \<in> A"
    using t
    by (auto intro!: exI[where x=t] simp: flow0_cong[OF cong] existence_ivl0_cong[OF cong])
  ultimately show ?thesis
    by (auto simp: Y.returns_to_def)
qed

lemma
  returns_to_congI2:
  assumes "auto_ll_on_open.returns_to g Y x A"
  shows "returns_to x A"
proof -
  interpret Y: c1_on_open_euclidean g f' Y by (rule c1_on_open_euclidean_congI)
  show ?thesis
    by (rule Y.returns_to_congI1) (auto simp: assms cong)
qed

lemma returns_to_cong: "auto_ll_on_open.returns_to g Y A x = returns_to A x"
  using returns_to_congI1 returns_to_congI2 by blast

lemma
  return_time_cong:
  shows "return_time A x = auto_ll_on_open.return_time g Y A x"
proof -
  interpret Y: c1_on_open_euclidean g f' Y by (rule c1_on_open_euclidean_congI)
  have P_eq: "0 < t \<and> t \<in> existence_ivl0 x \<and> flow0 x t \<in> A \<and> (\<forall>s\<in>{0<..<t}. flow0 x s \<notin> A) \<longleftrightarrow>
    0 < t \<and> t \<in> Y.existence_ivl0 x \<and> Y.flow0 x t \<in> A \<and> (\<forall>s\<in>{0<..<t}. Y.flow0 x s \<notin> A)"
    for t
    using ivl_subset_existence_ivl[of t x]
    apply (auto simp: existence_ivl0_cong[OF cong] flow0_cong[OF cong])
     apply (drule bspec)
      apply force
     apply (subst (asm) flow0_cong[OF cong])
    apply auto
    apply (auto simp: existence_ivl0_cong[OF cong, symmetric] flow0_cong[OF cong])
     apply (subst (asm) flow0_cong[OF cong])
    apply auto
    done
  show ?thesis
    unfolding return_time_def Y.return_time_def
    by (auto simp: returns_to_cong P_eq)
qed

lemma poincare_mapsto_congI1:
  assumes "poincare_mapsto A B C D E" "closed A"
  shows "c1_on_open_euclidean.poincare_mapsto g Y A B C D E"
proof -
  interpret Y: c1_on_open_euclidean g f' Y by (rule c1_on_open_euclidean_congI)
  show ?thesis
    using assms
    unfolding poincare_mapsto_def Y.poincare_mapsto_def
    apply auto
    subgoal for a b
      by (rule returns_to_congI1) auto
    subgoal for a b
      by (subst return_time_cong[abs_def, symmetric]) auto
    subgoal for a b
      unfolding poincare_map_def Y.poincare_map_def
      apply (drule bspec, assumption)
      apply safe
      subgoal for D
        apply (auto intro!: exI[where x=D])
        subgoal premises prems
        proof -
          have "\<forall>\<^sub>F y in at a within C. returns_to A y"
            apply (rule eventually_returns_to_continuousI)
              apply fact apply fact
            apply (rule differentiable_imp_continuous_within)
            apply fact
            done
          moreover have "\<forall>\<^sub>F y in at a within C. y \<in> C"
            by (auto simp: eventually_at_filter)
          ultimately have "\<forall>\<^sub>F x' in at a within C. flow0 x' (return_time A x') = Y.flow0 x' (Y.return_time A x')"
          proof eventually_elim
            case (elim x')
            then show ?case
              apply (subst flow0_cong[OF cong, symmetric], force)
               apply (subst return_time_cong[symmetric])
              using prems
               apply (auto intro!: return_time_exivl)
              apply (subst return_time_cong[symmetric])
              apply auto
              done
          qed
          with prems(7)
          show ?thesis
            apply (rule has_derivative_transform_eventually)
            using prems
             apply (subst flow0_cong[OF cong, symmetric], force)
              apply (subst return_time_cong[symmetric])
            using prems
              apply (auto intro!: return_time_exivl)
            apply (subst return_time_cong[symmetric])
            apply auto
            done
        qed
        subgoal
          apply (subst flow0_cong[OF cong, symmetric], force)
           apply (subst return_time_cong[symmetric])
           apply (auto intro!: return_time_exivl)
          apply (subst return_time_cong[symmetric])
          apply auto
          done
        done
      done
    subgoal for a b t
      apply (drule bspec, assumption)
      apply (subst flow0_cong[OF cong, symmetric])
        apply auto
       apply (subst (asm) return_time_cong[symmetric])
       apply (rule less_return_time_imp_exivl)
          apply (rule less_imp_le, assumption)
         apply (auto simp: return_time_cong)
      done
    done
qed

lemma poincare_mapsto_congI2:
  assumes "c1_on_open_euclidean.poincare_mapsto g Y A B C D E" "closed A"
  shows "poincare_mapsto A B C D E"
proof -
  interpret Y: c1_on_open_euclidean g f' Y by (rule c1_on_open_euclidean_congI)
  show ?thesis
    apply (rule Y.poincare_mapsto_congI1)
    using assms
    by (auto simp: cong)
qed

lemma poincare_mapsto_cong: "closed A \<Longrightarrow>
    poincare_mapsto A B C D E = c1_on_open_euclidean.poincare_mapsto g Y A B C D E"
  using poincare_mapsto_congI1[of A B C] poincare_mapsto_congI2[of A B C] by auto

end

end

end


(* IsageoCoq2_R1

Tarski_Gupta_Model.thy

Version 2.2.0 IsaGeoCoq2_R1, Port part of GeoCoq 3.4.0
Copyright (C) 2021-2023 Roland Coghetto roland.coghetto ( a t ) cafr-msa2p.be
License: LGPGL

History
Version 1.0.0: IsaGeoCoq
Port part of GeoCoq 3.4.0 (https://geocoq.github.io/GeoCoq/) in Isabelle/Hol (Isabelle2021)

Copyright (C) 2021  Roland Coghetto roland_coghetto (at) hotmail.com

License: LGPL

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
*)
(*<*)
theory Tarski_Gupta_Model

imports Gupta

begin
  (*>*)

context Gupta_neutral_dimensionless

begin

interpretation Interpretation_Tarski_neutral_dimensionless: Tarski_neutral_dimensionless
  where TPA = GPA and TPB = GPB and TPC = GPC and Bet = BetG and Cong = CongG
proof
  show "\<forall>a b. CongG a b b a"
    by (simp add: cong_pseudo_reflexivityG)
  show "\<forall>a b p q r s. CongG a b p q \<and> CongG a b r s \<longrightarrow> CongG p q r s"
    using cong_inner_transitivityG by blast
  show "\<forall>a b c. CongG a b c c \<longrightarrow> a = b"
    by (simp add: cong_identityG)
  show "\<forall>a b c q. \<exists>x. BetG q a x \<and> CongG a x b c"
    by (simp add: segment_constructionG)
  show "\<forall>a b c d a' b' c' d'. a \<noteq> b \<and> BetG a b c \<and> BetG a' b' c' \<and>
         CongG a b a' b' \<and> CongG b c b' c' \<and> CongG a d a' d' \<and> CongG b d b' d' \<longrightarrow>
       CongG c d c' d'"
    using five_segmentG by blast
  show "\<forall>a b. BetG a b a \<longrightarrow> a = b"
    by (simp add: between_identityT)
  show "\<forall>a b c p q. BetG a p c \<and> BetG b q c \<longrightarrow> (\<exists>x. BetG p x b \<and> BetG q x a)"
    using inner_paschT by blast
  show "\<not> BetG GPA GPB GPC \<and> \<not> BetG GPB GPC GPA \<and> \<not> BetG GPC GPA GPB"
    using lower_dimG by blast
qed

subsection "Transport theorem from Tarski Neutral for Gupta Euclidean Model"

lemma g_l5_2:
  assumes "A \<noteq> B" and
    "BetG A B C" and
    "BetG A B D"
  shows "BetG B C D \<or> BetG B D C"
  using Interpretation_Tarski_neutral_dimensionless.l5_2 assms(1) assms(2) assms(3) by blast

lemma g_l5_3:
  assumes "BetG A B D" and
    "BetG A C D"
  shows "BetG A B C \<or> BetG A C B"
  using Interpretation_Tarski_neutral_dimensionless.l5_3 assms(1) assms(2) by blast

lemma g_between_exchange4:
  assumes "BetG A B C" and
    "BetG A C D"
  shows "BetG A B D"
  using assms(1) assms(2)
    Interpretation_Tarski_neutral_dimensionless.between_exchange4 by blast

lemma g_between_inner_transitivity:
  assumes "BetG A B D" and
    "BetG B C D"
  shows "BetG A B C"
  using assms(1) assms(2)
    Interpretation_Tarski_neutral_dimensionless.between_inner_transitivity by blast

lemma g_not_bet_distincts:
  assumes "\<not> BetG A B C"
  shows "A \<noteq> B \<and> B \<noteq> C"
  using assms Interpretation_Tarski_neutral_dimensionless.not_bet_distincts by blast

lemma g_between_symmetry:
  assumes "BetG A B C"
  shows "BetG C B A"
  using assms Interpretation_Tarski_neutral_dimensionless.between_symmetry by blast

lemma g_between_trivial:
  shows "BetG A B B"
  using Interpretation_Tarski_neutral_dimensionless.between_trivial by blast

end

context Gupta_neutral_2D

begin

interpretation Interpretation_Tarski_neutral_2D : Tarski_2D
  where TPA = GPA and TPB = GPB and TPC = GPC and Bet = BetG and Cong = CongG
proof
  show "\<forall>a b. CongG a b b a"
    by (simp add: cong_pseudo_reflexivityG)
  show "\<forall>a b p q r s. CongG a b p q \<and> CongG a b r s \<longrightarrow> CongG p q r s"
    using cong_inner_transitivityG by blast
  show "\<forall>a b c. CongG a b c c \<longrightarrow> a = b"
    by (simp add: cong_identityG)
  show "\<forall>a b c q. \<exists>x. BetG q a x \<and> CongG a x b c"
    by (simp add: segment_constructionG)
  show "\<forall>a b c d a' b' c' d'. a \<noteq> b \<and> BetG a b c \<and> BetG a' b' c' \<and>
         CongG a b a' b' \<and> CongG b c b' c' \<and> CongG a d a' d' \<and> CongG b d b' d' \<longrightarrow>
       CongG c d c' d'"
    using five_segmentG by blast
  show "\<forall>a b. BetG a b a \<longrightarrow> a = b"
    by (simp add: between_identityT)
  show "\<forall>a b c p q. BetG a p c \<and> BetG b q c \<longrightarrow> (\<exists>x. BetG p x b \<and> BetG q x a)"
    using inner_paschT by blast
  show "\<not> BetG GPA GPB GPC \<and> \<not> BetG GPB GPC GPA \<and> \<not> BetG GPC GPA GPB"
    using lower_dimG by blast
  show "\<forall>a b c p q.
       p \<noteq> q \<and> CongG a p a q \<and> CongG b p b q \<and> CongG c p c q \<longrightarrow>
       BetG a b c \<or> BetG b c a \<or> BetG c a b" using upper_dimT by blast
qed

end
end


section "Stack Machine and Compilation"

(* Exercise 3.10. A stack underflow occurs when executing an ADD instruc-
tion on a stack of size less than 2. In our semantics a term exec1 ADD s stk
where length stk < 2 is simply some unspecified value, not an error or ex-
ception — HOL does not have those concepts. Modify theory ASM such that
stack underflow is modelled by None and normal execution by Some, i.e.,
the execution functions have return type stack option. Modify all theorems
and proofs accordingly. *)

theory Chapter3ASM imports "~~/src/HOL/IMP/AExp" begin

subsection "Stack Machine"

text_raw\<open>\snip{ASMinstrdef}{0}{1}{%\<close>
datatype instr = LOADI val | LOAD vname | ADD
text_raw\<open>}%endsnip\<close>

text_raw\<open>\snip{ASMstackdef}{1}{2}{%\<close>
type_synonym stack = "val list"
text_raw\<open>}%endsnip\<close>

text\<open>\noindent Abbreviations are transparent: they are unfolded after
parsing and folded back again before printing. Internally, they do not
exist.\<close>

text_raw\<open>\snip{ASMexeconedef}{0}{1}{%\<close>
fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
"exec1 (LOADI n) _ stk  = Some (n # stk)" |
"exec1 (LOAD x) s stk  = Some (s(x) # stk)" |
"exec1  ADD _ stk  = (case stk of
                      (x # y # ys) \<Rightarrow> Some ((x + y) # ys) |
                      (xs) \<Rightarrow> None)"
text_raw\<open>}%endsnip\<close>

text_raw\<open>\snip{ASMexecdef}{1}{2}{%\<close>
fun exec :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
"exec [] _ stk = (Some stk)" |
"exec (i#is) s stk = (case exec1 i s stk of
                      Some stk2 \<Rightarrow> exec is s stk2 |
                      None \<Rightarrow> None)"
text_raw\<open>}%endsnip\<close>

value "exec [LOADI 5, LOAD ''y'', ADD] <''x'' := 42, ''y'' := 43> [50]"

lemma exec_append:
  "exec is1 s stk = Some stk2 \<Longrightarrow> exec (is1@is2) s stk = exec is2 s stk2"
  apply(induction is1 arbitrary: stk)
apply (auto split: option.split)
done

subsection "Compilation"

text_raw\<open>\snip{ASMcompdef}{0}{2}{%\<close>
fun comp :: "aexp \<Rightarrow> instr list" where
"comp (N n) = [LOADI n]" |
"comp (V x) = [LOAD x]" |
"comp (Plus e\<^sub>1 e\<^sub>2) = comp e\<^sub>1 @ comp e\<^sub>2 @ [ADD]"
text_raw\<open>}%endsnip\<close>

value "comp (Plus (Plus (V ''x'') (N 1)) (V ''z''))"

theorem exec_comp: "exec (comp a) s stk = Some (aval a s # stk)"
apply(induction a arbitrary: stk)
    apply (auto split: option.split simp: exec_append)
done

end


(*
  Title:  Example Completeness Proof for System K
  Author: Asta Halkjær From
*)

chapter \<open>Example: Modal Logic\<close>

theory Example_Modal_Logic imports Derivations begin

section \<open>Syntax\<close>

datatype ('i, 'p) fm
  = Fls (\<open>\<^bold>\<bottom>\<close>)
  | Pro 'p (\<open>\<^bold>\<ddagger>\<close>)
  | Imp \<open>('i, 'p) fm\<close> \<open>('i, 'p) fm\<close> (infixr \<open>\<^bold>\<longrightarrow>\<close> 55)
  | Box 'i \<open>('i, 'p) fm\<close> (\<open>\<^bold>\<box>\<close>)

abbreviation Neg (\<open>\<^bold>\<not> _\<close> [70] 70) where
  \<open>\<^bold>\<not> p \<equiv> p \<^bold>\<longrightarrow> \<^bold>\<bottom>\<close>

section \<open>Semantics\<close>

datatype ('i, 'p, 'w) model =
  Model (\<W>: \<open>'w set\<close>) (\<R>: \<open>'i \<Rightarrow> 'w \<Rightarrow> 'w set\<close>) (\<V>: \<open>'w \<Rightarrow> 'p \<Rightarrow> bool\<close>)

type_synonym ('i, 'p, 'w) ctx = \<open>('i, 'p, 'w) model \<times> 'w\<close>

fun semantics :: \<open>('i, 'p, 'w) ctx \<Rightarrow> ('i, 'p) fm \<Rightarrow> bool\<close> (\<open>_ \<Turnstile> _\<close> [50, 50] 50) where
  \<open>_ \<Turnstile> \<^bold>\<bottom> \<longleftrightarrow> False\<close>
| \<open>(M, w) \<Turnstile> \<^bold>\<ddagger>P \<longleftrightarrow> \<V> M w P\<close>
| \<open>(M, w) \<Turnstile> p \<^bold>\<longrightarrow> q \<longleftrightarrow> (M, w) \<Turnstile> p \<longrightarrow> (M, w) \<Turnstile> q\<close>
| \<open>(M, w) \<Turnstile> \<^bold>\<box> i p \<longleftrightarrow> (\<forall>v \<in> \<W> M \<inter> \<R> M i w. (M, v) \<Turnstile> p)\<close>

section \<open>Calculus\<close>

primrec eval :: \<open>('p \<Rightarrow> bool) \<Rightarrow> (('i, 'p) fm \<Rightarrow> bool) \<Rightarrow> ('i, 'p) fm \<Rightarrow> bool\<close> where
  \<open>eval _ _ \<^bold>\<bottom> = False\<close>
| \<open>eval g _ (\<^bold>\<ddagger>P) = g P\<close>
| \<open>eval g h (p \<^bold>\<longrightarrow> q) = (eval g h p \<longrightarrow> eval g h q)\<close>
| \<open>eval _ h (\<^bold>\<box> i p) = h (\<^bold>\<box> i p)\<close>

abbreviation \<open>tautology p \<equiv> \<forall>g h. eval g h p\<close>

inductive Calculus :: \<open>('i, 'p) fm \<Rightarrow> bool\<close> (\<open>\<turnstile>\<^sub>\<box> _\<close> [50] 50) where
  A1: \<open>tautology p \<Longrightarrow> \<turnstile>\<^sub>\<box> p\<close>
| A2: \<open>\<turnstile>\<^sub>\<box> \<^bold>\<box> i (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> \<^bold>\<box> i p \<^bold>\<longrightarrow> \<^bold>\<box> i q\<close>
| R1: \<open>\<turnstile>\<^sub>\<box> p \<Longrightarrow> \<turnstile>\<^sub>\<box> p \<^bold>\<longrightarrow> q \<Longrightarrow> \<turnstile>\<^sub>\<box> q\<close>
| R2: \<open>\<turnstile>\<^sub>\<box> p \<Longrightarrow> \<turnstile>\<^sub>\<box> \<^bold>\<box> i p\<close>

primrec imply :: \<open>('i, 'p) fm list \<Rightarrow> ('i, 'p) fm \<Rightarrow> ('i, 'p) fm\<close> (infixr \<open>\<^bold>\<leadsto>\<close> 56) where
  \<open>([] \<^bold>\<leadsto> p) = p\<close>
| \<open>(q # A \<^bold>\<leadsto> p) = (q \<^bold>\<longrightarrow> A \<^bold>\<leadsto> p)\<close>

abbreviation Calculus_assms (\<open>_ \<turnstile>\<^sub>\<box> _\<close> [50, 50] 50) where
  \<open>A \<turnstile>\<^sub>\<box> p \<equiv> \<turnstile>\<^sub>\<box> A \<^bold>\<leadsto> p\<close>

section \<open>Soundness\<close>

lemma eval_semantics: \<open>eval (g w) (\<lambda>q. (Model W r g, w) \<Turnstile> q) p = ((Model W r g, w) \<Turnstile> p)\<close>
  by (induct p) simp_all

lemma tautology:
  assumes \<open>tautology p\<close>
  shows \<open>(M, w) \<Turnstile> p\<close>
proof -
  from assms have \<open>eval (g w) (\<lambda>q. (Model W r g, w) \<Turnstile> q) p\<close> for W g r
    by simp
  then have \<open>(Model W r g, w) \<Turnstile> p\<close> for W g r
    using eval_semantics by fast
  then show \<open>(M, w) \<Turnstile> p\<close>
    by (metis model.exhaust)
qed

theorem soundness:
  assumes \<open>\<And>M w p. A p \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> (M, w) \<Turnstile> p\<close>
  shows \<open>\<turnstile>\<^sub>\<box> p \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> (M, w) \<Turnstile> p\<close>
  by (induct p arbitrary: w rule: Calculus.induct) (auto simp: assms tautology)

section \<open>Admissible rules\<close>

lemma K_imply_head: \<open>p # A \<turnstile>\<^sub>\<box> p\<close>
proof -
  have \<open>tautology (p # A \<^bold>\<leadsto> p)\<close>
    by (induct A) simp_all
  then show ?thesis
    using A1 by blast
qed

lemma K_imply_Cons:
  assumes \<open>A \<turnstile>\<^sub>\<box> q\<close>
  shows \<open>p # A \<turnstile>\<^sub>\<box> q\<close>
proof -
  have \<open>\<turnstile>\<^sub>\<box> (A \<^bold>\<leadsto> q \<^bold>\<longrightarrow> p # A \<^bold>\<leadsto> q)\<close>
    by (simp add: A1)
  with R1 assms show ?thesis .
qed

lemma K_right_mp:
  assumes \<open>A \<turnstile>\<^sub>\<box> p\<close> \<open>A \<turnstile>\<^sub>\<box> p \<^bold>\<longrightarrow> q\<close>
  shows \<open>A \<turnstile>\<^sub>\<box> q\<close>
proof -
  have \<open>tautology (A \<^bold>\<leadsto> p \<^bold>\<longrightarrow> A \<^bold>\<leadsto> (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> A \<^bold>\<leadsto> q)\<close>
    by (induct A) simp_all
  with A1 have \<open>\<turnstile>\<^sub>\<box> A \<^bold>\<leadsto> p \<^bold>\<longrightarrow> A \<^bold>\<leadsto> (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> A \<^bold>\<leadsto> q\<close> .
  then show ?thesis
    using assms R1 by blast
qed

lemma deduct1: \<open>A \<turnstile>\<^sub>\<box> p \<^bold>\<longrightarrow> q \<Longrightarrow> p # A \<turnstile>\<^sub>\<box> q\<close>
  by (meson K_right_mp K_imply_Cons K_imply_head)

lemma imply_append [iff]: \<open>(A @ B \<^bold>\<leadsto> r) = (A \<^bold>\<leadsto> B \<^bold>\<leadsto> r)\<close>
  by (induct A) simp_all

lemma imply_swap_append: \<open>A @ B \<turnstile>\<^sub>\<box> r \<Longrightarrow> B @ A \<turnstile>\<^sub>\<box> r\<close>
proof (induct B arbitrary: A)
  case Cons
  then show ?case
    by (metis deduct1 imply.simps(2) imply_append)
qed simp

lemma K_ImpI: \<open>p # A \<turnstile>\<^sub>\<box> q \<Longrightarrow> A \<turnstile>\<^sub>\<box> p \<^bold>\<longrightarrow> q\<close>
  by (metis imply.simps imply_append imply_swap_append)

lemma imply_mem [simp]: \<open>p \<in> set A \<Longrightarrow> A \<turnstile>\<^sub>\<box> p\<close>
  using K_imply_head K_imply_Cons by (induct A) fastforce+

lemma add_imply [simp]: \<open>\<turnstile>\<^sub>\<box> q \<Longrightarrow> A \<turnstile>\<^sub>\<box> q\<close>
  using K_imply_head R1 by auto

lemma K_imply_weaken: \<open>A \<turnstile>\<^sub>\<box> q \<Longrightarrow> set A \<subseteq> set A' \<Longrightarrow> A' \<turnstile>\<^sub>\<box> q\<close>
  by (induct A arbitrary: q) (simp, metis K_right_mp K_ImpI imply_mem insert_subset list.set(2))

lemma K_Boole:
  assumes \<open>(\<^bold>\<not> p) # A \<turnstile>\<^sub>\<box> \<^bold>\<bottom>\<close>
  shows \<open>A \<turnstile>\<^sub>\<box> p\<close>
proof -
  have \<open>A \<turnstile>\<^sub>\<box> \<^bold>\<not> \<^bold>\<not> p\<close>
    using assms K_ImpI by blast
  moreover have \<open>tautology (A \<^bold>\<leadsto> \<^bold>\<not> \<^bold>\<not> p \<^bold>\<longrightarrow> A \<^bold>\<leadsto> p)\<close>
    by (induct A) simp_all
  then have \<open>\<turnstile>\<^sub>\<box> (A \<^bold>\<leadsto> \<^bold>\<not> \<^bold>\<not> p \<^bold>\<longrightarrow> A \<^bold>\<leadsto> p)\<close>
    using A1 by blast
  ultimately show ?thesis
    using R1 by blast
qed

lemma K_distrib_K_imp:
  assumes \<open>\<turnstile>\<^sub>\<box> \<^bold>\<box> i (A \<^bold>\<leadsto> q)\<close>
  shows \<open>map (\<^bold>\<box> i) A \<turnstile>\<^sub>\<box> \<^bold>\<box> i q\<close>
proof -
  have \<open>\<turnstile>\<^sub>\<box> \<^bold>\<box> i (A \<^bold>\<leadsto> q) \<^bold>\<longrightarrow> map (\<^bold>\<box> i) A \<^bold>\<leadsto> \<^bold>\<box> i q\<close>
  proof (induct A)
    case Nil
    then show ?case
      by (simp add: A1)
  next
    case (Cons a A)
    have \<open>\<turnstile>\<^sub>\<box> \<^bold>\<box> i (a # A \<^bold>\<leadsto> q) \<^bold>\<longrightarrow> \<^bold>\<box> i a \<^bold>\<longrightarrow> \<^bold>\<box> i (A \<^bold>\<leadsto> q)\<close>
      by (simp add: A2)
    moreover have
      \<open>\<turnstile>\<^sub>\<box> ((\<^bold>\<box> i (a # A \<^bold>\<leadsto> q) \<^bold>\<longrightarrow> \<^bold>\<box> i a \<^bold>\<longrightarrow> \<^bold>\<box> i (A \<^bold>\<leadsto> q)) \<^bold>\<longrightarrow>
        (\<^bold>\<box> i (A \<^bold>\<leadsto> q) \<^bold>\<longrightarrow> map (\<^bold>\<box> i) A \<^bold>\<leadsto> \<^bold>\<box> i q) \<^bold>\<longrightarrow>
        (\<^bold>\<box> i (a # A \<^bold>\<leadsto> q) \<^bold>\<longrightarrow> \<^bold>\<box> i a \<^bold>\<longrightarrow> map (\<^bold>\<box> i) A \<^bold>\<leadsto> \<^bold>\<box> i q))\<close>
      by (simp add: A1)
    ultimately have \<open>\<turnstile>\<^sub>\<box> \<^bold>\<box> i (a # A \<^bold>\<leadsto> q) \<^bold>\<longrightarrow> \<^bold>\<box> i a \<^bold>\<longrightarrow> map (\<^bold>\<box> i) A \<^bold>\<leadsto> \<^bold>\<box> i q\<close>
      using Cons R1 by blast
    then show ?case
      by simp
  qed
  then show ?thesis
    using assms R1 by blast
qed

interpretation Derivations Calculus_assms
proof
  fix A B and p :: \<open>('i, 'p) fm\<close>
  assume \<open>\<turnstile>\<^sub>\<box> A \<^bold>\<leadsto> p\<close> \<open>set A \<subseteq> set B\<close>
  then show \<open>\<turnstile>\<^sub>\<box> B \<^bold>\<leadsto> p\<close>
    using K_imply_weaken by blast
qed

section \<open>Maximal Consistent Sets\<close>

definition consistent :: \<open>('i, 'p) fm set \<Rightarrow> bool\<close> where
  \<open>consistent S \<equiv> \<nexists>S'. set S' \<subseteq> S \<and> S' \<turnstile>\<^sub>\<box> \<^bold>\<bottom>\<close>

interpretation MCS_No_Saturation consistent
proof
  fix S S' :: \<open>('i, 'p) fm set\<close>
  assume \<open>consistent S\<close> \<open>S' \<subseteq> S\<close>
  then show \<open>consistent S'\<close>
    unfolding consistent_def by fast
next
  fix S :: \<open>('i, 'p) fm set\<close>
  assume \<open>\<not> consistent S\<close>
  then show \<open>\<exists>S' \<subseteq> S. finite S' \<and> \<not> consistent S'\<close>
    unfolding consistent_def by blast
next
  show \<open>infinite (UNIV :: ('i, 'p) fm set)\<close>
    using infinite_UNIV_size[of \<open>\<lambda>p. p \<^bold>\<longrightarrow> p\<close>] by simp
qed

interpretation Derivations_MCS_Cut Calculus_assms consistent \<open>\<^bold>\<bottom>\<close>
proof
  fix S :: \<open>('i, 'p) fm set\<close>
  show \<open>consistent S = (\<nexists>S'. set S' \<subseteq> S \<and> S' \<turnstile>\<^sub>\<box> \<^bold>\<bottom>)\<close>
    unfolding consistent_def ..
next
  fix A and p :: \<open>('i, 'p) fm\<close>
  assume \<open>p \<in> set A\<close>
  then show \<open>A \<turnstile>\<^sub>\<box> p\<close>
    by (metis K_imply_head K_imply_weaken Un_upper2 set_append split_list_first)
next
  fix A B and p q :: \<open>('i, 'p) fm\<close>
  assume \<open>A \<turnstile>\<^sub>\<box> p\<close> \<open>p # B \<turnstile>\<^sub>\<box> q\<close>
  then show \<open>A @ B \<turnstile>\<^sub>\<box> q\<close>
    by (metis K_imply_head K_right_mp R1 imply.simps(2) imply_append)
qed

lemma exists_finite_inconsistent:
  assumes \<open>\<not> consistent ({\<^bold>\<not> p} \<union> V)\<close>
  obtains W where \<open>{\<^bold>\<not> p} \<union> W \<subseteq> {\<^bold>\<not> p} \<union> V\<close> \<open>(\<^bold>\<not> p) \<notin> W\<close> \<open>finite W\<close> \<open>\<not> consistent ({\<^bold>\<not> p} \<union> W)\<close>
proof -
  obtain W' where W': \<open>set W' \<subseteq> {\<^bold>\<not> p} \<union> V\<close> \<open>W' \<turnstile>\<^sub>\<box> \<^bold>\<bottom>\<close>
    using assms unfolding consistent_def by blast
  let ?S = \<open>removeAll (\<^bold>\<not> p) W'\<close>
  have \<open>\<not> consistent ({\<^bold>\<not> p} \<union> set ?S)\<close>
    unfolding consistent_def using W'(2) by auto
  moreover have \<open>finite (set ?S)\<close>
    by blast
  moreover have \<open>{\<^bold>\<not> p} \<union> set ?S \<subseteq> {\<^bold>\<not> p} \<union> V\<close>
    using W'(1) by auto
  moreover have \<open>(\<^bold>\<not> p) \<notin> set ?S\<close>
    by simp
  ultimately show ?thesis
    by (meson that)
qed

lemma MCS_consequent:
  assumes \<open>consistent V\<close> \<open>maximal V\<close> \<open>p \<^bold>\<longrightarrow> q \<in> V\<close> \<open>p \<in> V\<close>
  shows \<open>q \<in> V\<close>
  using assms MCS_derive
  by (metis (mono_tags, lifting) K_imply_Cons K_imply_head K_right_mp insert_subset list.simps(15))

theorem deriv_in_maximal:
  assumes \<open>consistent V\<close> \<open>maximal V\<close> \<open>\<turnstile>\<^sub>\<box> p\<close>
  shows \<open>p \<in> V\<close>
  using assms R1 derive_split1 unfolding consistent_def maximal_def by (metis imply.simps(2))

theorem exactly_one_in_maximal:
  assumes \<open>consistent V\<close> \<open>maximal V\<close>
  shows \<open>p \<in> V \<longleftrightarrow> (\<^bold>\<not> p) \<notin> V\<close>
  using assms MCS_derive MCS_derive_fls by (metis K_Boole K_imply_Cons K_imply_head K_right_mp)

section \<open>Truth Lemma\<close>

abbreviation val :: \<open>('i, 'p) fm set \<Rightarrow> 'p \<Rightarrow> bool\<close> where
  \<open>val V P \<equiv> \<^bold>\<ddagger>P \<in> V\<close>

abbreviation known :: \<open>('i, 'p) fm set \<Rightarrow> 'i \<Rightarrow> ('i, 'p) fm set\<close> where
  \<open>known V i \<equiv> {p. \<^bold>\<box> i p \<in> V}\<close>

abbreviation reach :: \<open>'i \<Rightarrow> ('i, 'p) fm set \<Rightarrow> ('i, 'p) fm set set\<close> where
  \<open>reach i V \<equiv> {W. known V i \<subseteq> W}\<close>

abbreviation mcss :: \<open>('i, 'p) fm set set\<close> where
  \<open>mcss \<equiv> {W. consistent W \<and> maximal W}\<close>

abbreviation canonical :: \<open>('i, 'p, ('i, 'p) fm set) model\<close> where
  \<open>canonical \<equiv> Model mcss reach val\<close>

fun semics ::
  \<open>('i, 'p, 'w) ctx \<Rightarrow> (('i, 'p, 'w) ctx \<Rightarrow> ('i, 'p) fm \<Rightarrow> bool) \<Rightarrow> ('i, 'p) fm \<Rightarrow> bool\<close> where
  \<open>semics _ _ \<^bold>\<bottom> \<longleftrightarrow> False\<close>
| \<open>semics (M, w) _ (\<^bold>\<ddagger>P) \<longleftrightarrow> \<V> M w P\<close>
| \<open>semics (M, w) rel (p \<^bold>\<longrightarrow> q) \<longleftrightarrow> rel (M, w) p \<longrightarrow> rel (M, w) q\<close>
| \<open>semics (M, w) rel (\<^bold>\<box> i p) \<longleftrightarrow> (\<forall>v \<in> \<W> M \<inter> \<R> M i w. rel (M, v) p)\<close>

fun rel :: \<open>('i, 'p) fm set \<Rightarrow> ('i, 'p, ('i, 'p) fm set) ctx \<Rightarrow> ('i, 'p) fm \<Rightarrow> bool\<close> where
  \<open>rel _ (_, w) p = (p \<in> w)\<close>

lemma Hintikka_model':
  fixes V :: \<open>('i, 'p) fm set\<close>
  assumes \<open>\<And>(V :: ('i, 'p) fm set) p. V \<in> mcss \<Longrightarrow> semics (canonical, V) (rel H) p \<longleftrightarrow> p \<in> V\<close>
  shows \<open>V \<in> mcss \<Longrightarrow> (canonical, V) \<Turnstile> p \<longleftrightarrow> p \<in> V\<close>
proof (induct p arbitrary: V rule: wf_induct[where r=\<open>measure size\<close>])
  case 1
  then show ?case ..
next
  case (2 x)
  then show ?case
    using assms[of V x] by (cases x) auto
qed

lemma maximal_extension:
  assumes \<open>consistent V\<close>
  shows \<open>\<exists>W. V \<subseteq> W \<and> consistent W \<and> maximal W\<close>
  using assms MCS_Extend' Extend_subset by meson

lemma Hintikka_canonical:
  assumes \<open>V \<in> mcss\<close>
  shows \<open>semics (canonical, V) (rel H) p \<longleftrightarrow> rel H (canonical, V) p\<close>
proof (cases p)
  case Fls
  have \<open>\<^bold>\<bottom> \<notin> V\<close>
    using assms MCS_derive unfolding consistent_def by blast
  then show ?thesis
    using Fls by simp
next
  case (Imp p q)
  have \<open>(p \<in> V \<longrightarrow> q \<in> V) \<longleftrightarrow> p \<^bold>\<longrightarrow> q \<in> V\<close>
    using assms MCS_derive MCS_derive_fls MCS_consequent
    by (metis (no_types, lifting) CollectD K_Boole K_ImpI K_imply_Cons)
  then show ?thesis
    using Imp by simp
next
  case (Box i p)
  have \<open>(\<forall>v \<in> mcss \<inter> reach i V. p \<in> v) = (\<^bold>\<box> i p \<in> V)\<close>
  proof
    assume \<open>\<^bold>\<box> i p \<in> V\<close>
    then show \<open>\<forall>v \<in> mcss \<inter> reach i V. p \<in> v\<close>
      by auto
  next
    assume *: \<open>\<forall>v \<in> mcss \<inter> reach i V. p \<in> v\<close>

    have \<open>consistent V\<close> \<open>maximal V\<close>
      using \<open>V \<in> mcss\<close> by blast+

    have \<open>\<not> consistent ({\<^bold>\<not> p} \<union> known V i)\<close>
    proof
      assume \<open>consistent ({\<^bold>\<not> p} \<union> known V i)\<close>
      then obtain W where W: \<open>{\<^bold>\<not> p} \<union> known V i \<subseteq> W\<close> \<open>consistent W\<close> \<open>maximal W\<close>
        using \<open>V \<in> mcss\<close> maximal_extension by blast
      then have \<open>(canonical, W) \<Turnstile> \<^bold>\<not> p\<close>
        using "*" exactly_one_in_maximal by auto
      moreover have \<open>W \<in> reach i V\<close> \<open>W \<in> mcss\<close>
        using W by simp_all
      ultimately have \<open>(canonical, V) \<Turnstile> \<^bold>\<not> \<^bold>\<box> i p\<close>
        by auto
      then show False
        using * W(1) \<open>W \<in> mcss\<close> exactly_one_in_maximal by auto
    qed

    then obtain W where W:
      \<open>{\<^bold>\<not> p} \<union> W \<subseteq> {\<^bold>\<not> p} \<union> known V i\<close> \<open>(\<^bold>\<not> p) \<notin> W\<close> \<open>finite W\<close> \<open>\<not> consistent ({\<^bold>\<not> p} \<union> W)\<close>
      using exists_finite_inconsistent by metis

    obtain L where L: \<open>set L = W\<close>
      using \<open>finite W\<close> finite_list by blast
    then have \<open>\<turnstile>\<^sub>\<box> L \<^bold>\<leadsto> p\<close>
      using W(4) derive_split1 unfolding consistent_def by (meson K_Boole K_imply_weaken)
    then have \<open>\<turnstile>\<^sub>\<box> \<^bold>\<box> i (L \<^bold>\<leadsto> p)\<close>
      using R2 by fast
    then have \<open>map (\<^bold>\<box> i) L \<turnstile>\<^sub>\<box> \<^bold>\<box> i p\<close>
      using K_distrib_K_imp by fast
    then have \<open>(map (\<^bold>\<box> i) L \<^bold>\<leadsto> \<^bold>\<box> i p) \<in> V\<close>
      using deriv_in_maximal \<open>V \<in> mcss\<close> by blast
    then show \<open>\<^bold>\<box> i p \<in> V\<close>
      using L W(1-2)
    proof (induct L arbitrary: W)
      case (Cons a L)
      then have \<open>\<^bold>\<box> i a \<in> V\<close>
        by auto
      then have \<open>(map (\<^bold>\<box> i) L \<^bold>\<leadsto> \<^bold>\<box> i p) \<in> V\<close>
        using Cons(2) \<open>consistent V\<close> \<open>maximal V\<close> MCS_consequent by auto
      then show ?case
        using Cons by auto
    qed simp
  qed
  then show ?thesis
    using Box by simp
qed simp

interpretation Truth_No_Saturation consistent semics semantics
  \<open>\<lambda>_. {(canonical, V) |V. V \<in> mcss}\<close> rel
proof
  fix p and M :: \<open>('i, 'p, ('i, 'p) fm set) ctx\<close>
  show \<open>(M \<Turnstile> p) = semics M semantics p\<close>
    by (cases M, induct p) simp_all
next
  fix p and H :: \<open>('i, 'p) fm set\<close> and M :: \<open>('i, 'p, ('i, 'p) fm set) ctx\<close>
  assume \<open>\<forall>M\<in>{(canonical, V) |V. V \<in> mcss}. \<forall>p. semics M (rel H) p = rel H M p\<close>
    \<open>M \<in> {(canonical, V) |V. V \<in> mcss}\<close>
  then show \<open>(M \<Turnstile> p) = rel H M p\<close>
    using Hintikka_model'[of H _ p] by auto
next
  fix H :: \<open>('i, 'p) fm set\<close>
  assume \<open>consistent H\<close> \<open>maximal H\<close>
  then show \<open>\<forall>M\<in>{(canonical, V) |V. V \<in> mcss}. \<forall>p. semics M (rel H) p = rel H M p\<close>
    using Hintikka_canonical by blast
qed

lemma Truth_lemma:
  assumes \<open>consistent V\<close> \<open>maximal V\<close>
  shows \<open>(canonical, V) \<Turnstile> p \<longleftrightarrow> p \<in> V\<close>
  using assms truth_lemma_no_saturation by fastforce

lemma canonical_model:
  assumes \<open>consistent S\<close> \<open>p \<in> S\<close>
  defines \<open>V \<equiv> Extend S\<close> and \<open>M \<equiv> canonical\<close>
  shows \<open>(M, V) \<Turnstile> p\<close> \<open>consistent V\<close> \<open>maximal V\<close>
proof -
  have \<open>consistent V\<close>
    using \<open>consistent S\<close> unfolding V_def using consistent_Extend by auto
  have \<open>maximal V\<close>
    unfolding V_def using maximal_Extend by blast
  { fix x
    assume \<open>x \<in> S\<close>
    then have \<open>x \<in> V\<close>
      unfolding V_def using Extend_subset by blast
    then have \<open>(M, V) \<Turnstile> x\<close>
      unfolding M_def using Truth_lemma \<open>consistent V\<close> \<open>maximal V\<close> by blast }
  then show \<open>(M, V) \<Turnstile> p\<close>
    using \<open>p \<in> S\<close> by blast+
  show \<open>consistent V\<close> \<open>maximal V\<close>
    by fact+
qed

section \<open>Completeness\<close>

theorem strong_completeness:
  assumes \<open>\<forall>M :: ('i, 'p, ('i, 'p) fm set) model. \<forall>w \<in> \<W> M.
    (\<forall>q \<in> X. (M, w) \<Turnstile> q) \<longrightarrow> (M, w) \<Turnstile> p\<close>
  shows \<open>\<exists>A. set A \<subseteq> X \<and> A \<turnstile>\<^sub>\<box> p\<close>
proof (rule ccontr)
  assume \<open>\<nexists>A. set A \<subseteq> X \<and> A \<turnstile>\<^sub>\<box> p\<close>
  then have *: \<open>\<forall>A. set A \<subseteq> X \<longrightarrow> \<not> (\<^bold>\<not> p) # A \<turnstile>\<^sub>\<box> \<^bold>\<bottom>\<close>
    using K_Boole by blast

  let ?S = \<open>{\<^bold>\<not> p} \<union> X\<close>
  let ?V = \<open>Extend ?S\<close>

  have \<open>consistent ?S\<close>
    using * derive_split1 unfolding consistent_def by meson
  then have \<open>(canonical, ?V) \<Turnstile> (\<^bold>\<not> p)\<close> \<open>\<forall>q \<in> X. (canonical, ?V) \<Turnstile> q\<close>
    using canonical_model by fastforce+
  moreover have \<open>?V \<in> mcss\<close>
    using \<open>consistent ?S\<close> maximal_Extend canonical_model(2) by blast
  ultimately have \<open>(canonical, ?V) \<Turnstile> p\<close>
    using assms by simp
  then show False
    using \<open>(canonical, ?V) \<Turnstile> (\<^bold>\<not> p)\<close> by simp
qed

abbreviation valid :: \<open>('i, 'p) fm \<Rightarrow> bool\<close> where
  \<open>valid p \<equiv> \<forall>(M :: ('i, 'p, ('i, 'p) fm set) model). \<forall>w \<in> \<W> M. (M, w) \<Turnstile> p\<close>

corollary completeness: \<open>valid p \<Longrightarrow> \<turnstile>\<^sub>\<box> p\<close>
  using strong_completeness[where X=\<open>{}\<close>] by simp

theorem main: \<open>valid p \<longleftrightarrow> \<turnstile>\<^sub>\<box> p\<close>
  using soundness completeness by meson

end