\<^marker>\<open>creator Bernhard Pöttinger\<close>

chapter \<open>Contextual and Flow-Preserving Extensions of Flow Graphs\<close>
theory Flow_Extensions
  imports Flow_Base Chain
begin

paragraph \<open>Summary\<close>
text \<open>This theory defines two notions of extensions of flow graphs and
proofs the replacement theorem related to the simple extension.
The analogous result for the more difficult the extension can be found in
@{term Effectively_Acyclic_Maintain}.\<close>

paragraph \<open>Major Definitions\<close>
text \<open>
\<^item> @{term contextual_extension}: some condition that enables adding nodes to flow graphs using
  replacement lemma
\<^item> @{term subflow_preserving_extension}: some condition that enables adding nodes to effectively acyclic
  flow graphs using theorem @{term maintain_eff_acyclic_dom}
\<close>

paragraph \<open>Major Lemmas\<close>
text \<open>
\<^item> replacement theorem @{cite \<open>thm. 2\<close> krishna20}\<close>

paragraph \<open>Notation\<close>
text \<open>
\<^item> @{term contextual_extension}: @{text "i1 \<lesssim> i2"}
\<^item> @{term subflow_preserving_extension}: @{text "h1 \<lesssim>\<^sub>S h2"}
\<close>

section \<open>Contextual Extension\<close>

text \<open>@{cite \<open>def. 7\<close> krishna20}\<close>

definition contextual_extension
  :: "('n,'m) fi \<Rightarrow> ('n,'m::cancel_comm_monoid_add) fi \<Rightarrow> bool" ("_ \<lesssim> _")
where
  "contextual_extension \<equiv> \<lambda>i1 i2. dom_fi i1 \<subseteq> dom_fi i2 \<and>
    (inf_fi i1 = inf_fi i2 on dom_fi i1) \<and>
    (outf_fi i1 = outf_fi i2 on -dom_fi i2)"

text \<open>Contextual extension is transitive.\<close>

lemma contextual_extension_trans:
  assumes "i1 \<lesssim> i2" "i2 \<lesssim> i3"
  shows "i1 \<lesssim> i3"
proof -
  have "outf_fi i1 = outf_fi i3 on -dom_fi i3"
  proof
    fix x
    assume A: "x \<in> -dom_fi i3"
    then have B: "x \<in> -dom_fi i2" using assms unfolding contextual_extension_def by auto
    show "outf_fi i1 x = outf_fi i3 x"
      using A B assms unfolding contextual_extension_def by auto
  qed
  then show ?thesis
    using assms unfolding contextual_extension_def by auto
qed

text \<open>Contextual extension is reflexive.\<close>

lemma contextual_extension_refl:
  "i \<lesssim> i"
  unfolding contextual_extension_def
  by simp

text \<open>@{cite \<open>thm. 2\<close> krishna20}\<close>

theorem replacement:
  assumes "i = i1 + i2" "i1 \<lesssim> i1'" "i \<noteq> bot" "i1' \<noteq> bot"
    "dom_fi i1' \<inter> dom_fi i2 = {}" "outf_fi i2 = (\<lambda>_. 0) on (dom_fi i1' - dom_fi i1)"
  shows "\<exists>i'. i' = i1' + i2 \<and> i \<lesssim> i' \<and> i' \<noteq> bot"
proof -
  have *: "is_sum_fi i1 i2 i"
    using assms plus_fi_to_is_sum_fi by blast

  let ?n' = "dom_fi i1' \<union> dom_fi i2"
  let ?i' = "\<lambda>n. if n \<in> dom_fi i1' - dom_fi i1 then inf_fi i1' n else inf_fi i n"
  let ?o' = "\<lambda>n. outf_fi i n"

  have **: "-?n' \<subseteq> -dom_fi i"
    using assms * unfolding is_sum_fi_def contextual_extension_def by auto

  have "outf_fi i = \<lambda>n. outf_fi i1 n + outf_fi i2 n on - dom_fi i"
    using assms * unfolding is_sum_fi_def by auto
  hence **: "outf_fi (i1 + i2) = \<lambda>n. outf_fi i1 n + outf_fi i2 n on -?n'"
    using ** assms by auto

  have "is_sum_fi i1' i2 (fi ?n' ?i' ?o')"
    using assms * plus_fi_ops_exist(2) **
    unfolding is_sum_fi_def contextual_extension_def
    by auto
  then have A: "i1' + i2 = fi ?n' ?i' ?o'"
    using is_sum_fi_to_plus_fi by simp

  have B: "i \<lesssim> fi ?n' ?i' ?o'"
    using assms
    unfolding contextual_extension_def is_sum_fi_def
    by auto

  show ?thesis
    using A B
    by simp
qed

text \<open>0-interface is common starting point for applications of replacement theorem,
0-interface can be shown be extended by almost any interface quite easily:\<close>

lemma zero_lessim_fi:
  assumes "\<forall>x' \<in> -N1. o1 x' = 0" "finite N1"
  shows "0 \<lesssim> fi N1 i1 o1"
  using assms
  unfolding contextual_extension_def zero_fi_def
  by simp

section \<open>Subflow-Preserving Extension\<close>

text \<open>@{cite \<open>def. 13\<close> krishna20}\<close>

definition subflow_preserving_extension ("_ \<lesssim>\<^sub>S _") where
"h \<lesssim>\<^sub>S h' \<equiv> int_fg h \<lesssim> int_fg h' \<and>
(\<forall>n \<in> dom_fg h. \<forall>n' \<in> -dom_fg h'. \<forall>m \<le> inf_fg h n. cap_fg h n n' m = cap_fg h' n n' m) \<and>
(\<forall>n \<in> dom_fg h' - dom_fg h. \<forall>n' \<in> -dom_fg h'. \<forall>m \<le> inf_fg h' n. cap_fg h' n n' m = 0)"

text \<open>Subflow-preserving extension is reflexive:\<close>

lemma subflow_preserving_extension_refl:
  "h \<lesssim>\<^sub>S h"
  unfolding subflow_preserving_extension_def
  using contextual_extension_refl by simp

text \<open>Subflow-preserving extension is transitive:\<close>

lemma subflow_preserving_extension_trans:
  assumes "h1 \<lesssim>\<^sub>S h2" "h2 \<lesssim>\<^sub>S h3" "h1 \<noteq> bot" "h2 \<noteq> bot" "h3 \<noteq> bot"
  shows "h1 \<lesssim>\<^sub>S h3"
proof -
  have x12: "\<forall>n \<in> dom_fg h1. \<forall>n' \<in> -dom_fg h2. \<forall>m \<le> inf_fg h1 n. cap_fg h1 n n' m = cap_fg h2 n n' m"
    and x23: "\<forall>n \<in> dom_fg h2. \<forall>n' \<in> -dom_fg h3. \<forall>m \<le> inf_fg h2 n. cap_fg h2 n n' m = cap_fg h3 n n' m"
    using assms
    unfolding subflow_preserving_extension_def
    by auto

  have dom: "dom_fg h1 \<subseteq> dom_fg h2" "dom_fg h2 \<subseteq> dom_fg h3"
    using assms
    unfolding subflow_preserving_extension_def contextual_extension_def
    by auto

  have infeq: "inf_fg h1 = inf_fg h2 on dom_fg h1"
    using assms inf_fg_int_fg[of h1] inf_fg_int_fg[of h2]
    unfolding subflow_preserving_extension_def contextual_extension_def
    by simp

  have *: "\<forall>n \<in> dom_fg h1. \<forall>n' \<in> -dom_fg h3. \<forall>m \<le> inf_fg h1 n. cap_fg h1 n n' m = cap_fg h3 n n' m"
  proof (safe, goal_cases)
    case (1 n n' m)
    then have "cap_fg h1 n n' m = cap_fg h2 n n' m" using x12 dom by auto
    also have "... = cap_fg h3 n n' m" using x23 infeq dom 1 by auto
    finally show ?case .
  qed

  have **: "\<forall>n \<in> dom_fg h3 - dom_fg h1. \<forall>n' \<in> -dom_fg h3. \<forall>m \<le> inf_fg h3 n. cap_fg h3 n n' m = 0"
  proof (safe, goal_cases)
    case (1 n n' m)
    then show ?case
    proof (cases "n \<in> dom_fg h2")
      case True
      then have N: "n \<in> dom_fg h2 - dom_fg h1" using 1 by blast
      moreover have "n' \<in> -dom_fg h2" using True 1 dom by blast
      moreover have "m \<le> inf_fi (int_fg h2) n"
        using assms dom N 1 unfolding subflow_preserving_extension_def contextual_extension_def
        by (simp add: inf_fg_int_fg)
      ultimately have X1: "cap_fg h2 n n' m = 0"
        using assms dom
        unfolding subflow_preserving_extension_def by (simp add: inf_fg_int_fg)

      from 1 True have "n \<in> dom_fg h2" "n' \<in> -dom_fg h3" by auto
      moreover have "m \<le> inf_fi (int_fg h2) n"
        using assms dom N 1 unfolding subflow_preserving_extension_def contextual_extension_def
        by (simp add: inf_fg_int_fg)
      ultimately have X2: "cap_fg h2 n n' m = cap_fg h3 n n' m"
        using assms dom unfolding subflow_preserving_extension_def
        by (simp add: inf_fg_int_fg)

      show ?thesis using X1 X2 by simp
    next
      case False
      then show ?thesis
        using assms dom 1
        unfolding subflow_preserving_extension_def
        by auto
    qed
  qed

  show ?thesis
    using assms contextual_extension_trans * **
    unfolding subflow_preserving_extension_def
    by auto
qed

end


(*
    File:        SubOcc.thy
    Time-stamp:  <2020-06-22T04:12:54Z>
    Author:      JRF
    Web:         http://jrf.cocolog-nifty.com/software/2016/01/post.html
    Logic Image: Logics_ZF (of Isabelle2020)
*)

theory SubOcc imports OccTools begin

definition Occ_Subtree :: "[i, i] => i" where
"Occ_Subtree(m, X) == {z. y: X, EX l T. z = <l, T> & y = <m@l, T>}"

definition Term_cons_inj_cond :: "[i, i, i=>i, [i,i]=>i]=>o" where
  "Term_cons_inj_cond(Terms, Tag, Arity, Term_cons)
        == ALL T: Tag. ALL U: Tag. ALL l: list(Terms). ALL m: list(Terms).
              Term_cons(T, l): Terms -->
           (Term_cons(T, l) = Term_cons(U, m) <-> T = U &
                 (ALL z: Arity(T). nth(z, l) = nth(z, m)))"

(** Occ_Subtree **)
lemma Occ_SubtreeI:
  "[| m: list(A); <m@l, T>: X |] ==> <l, T>: Occ_Subtree(m, X)"
apply (unfold Occ_Subtree_def)
apply (rule ReplaceI)
prefer 2 apply assumption
apply (rule refl conjI exI)+
apply (elim conjE exE)
apply simp
done

lemma Occ_SubtreeD:
  "<l, T>: Occ_Subtree(m, X) ==> <m@l, T>: X"
apply (unfold Occ_Subtree_def)
apply blast
done

lemma Occ_SubtreeE:
  "[| x: Occ_Subtree(m, X);
      !!l T. [| x = <l, T>; <m@l, T>: X |] ==> R |]==> R"
apply (unfold Occ_Subtree_def)
apply blast
done

lemma Occ_SubtreeE2:
  "[| <l, T>: Occ_Subtree(m, X);
      <m@l, T>: X ==> R |] ==> R"
apply (unfold Occ_Subtree_def)
apply blast
done

lemma Occ_Subtree_0:
  "Occ_Subtree(m, 0) = 0"
apply (unfold Occ_Subtree_def)
apply blast
done

lemma Occ_Subtree_Nil:
  "X <= A * B ==> Occ_Subtree([], X) = X"
apply (unfold Occ_Subtree_def)
apply simp
apply blast
done

lemma Occ_Subtree_Cons:
  "l: list(A) ==>
      Occ_Subtree(Cons(a, l), X) = Occ_Subtree(l, Occ_subtree(a, X))"
apply (unfold Occ_Subtree_def)
apply simp
apply (rule equalityI)
apply (safe elim!: Occ_subtreeE)
apply (rule ReplaceI)
apply (erule_tac [2] Occ_subtreeI)
apply (rule_tac [3] ReplaceI)
prefer 4 apply assumption
prefer 3
apply (assumption | rule refl exI conjI)+
apply (elim exE conjE)
apply simp
apply (elim exE conjE)
apply simp
done

lemma Occ_Subtree_app:
  assumes prem1: "l: list(A)"
  and prem2: "m: list(A)"
  and prem3: "X <= list(C) * D"
  shows "Occ_Subtree(l@m, X) = Occ_Subtree(m, Occ_Subtree(l, X))"
apply (rule prem3 [THEN rev_mp])
apply (rule_tac x="X" in spec)
apply (insert prem2)
apply (rule prem1 [THEN list.induct])
apply (simp_all add: Occ_Subtree_Nil Occ_Subtree_Cons)
apply (intro impI allI)
apply (drule Occ_subtree_preserves_domain)
apply (drule spec)
apply (drule mp, assumption)
apply assumption
done

lemma Occ_Subtree_in_Occ_range:
  assumes major: "<l, T>: X"
  and prem: "X: Occ_range(Tag, Arity)"
  shows "Occ_Subtree(l, X): Occ_range(Tag, Arity)"
apply (rule prem [THEN rev_mp])
apply (rule major [THEN rev_mp])
apply (rule_tac x="X" in spec)
apply (rule list.induct
    [OF major [THEN prem
       [THEN Occ_range_domain_lemma, THEN subsetD, THEN SigmaD1]]])
apply (intro impI allI)
apply (frule Occ_range_domain_lemma)
apply (simp add: Occ_Subtree_Nil)
apply (intro impI allI)
apply (frule Occ_range_domain_lemma)
apply (simp add: Occ_Subtree_Cons)
apply (erule spec [THEN mp, THEN mp])
apply (erule Occ_subtreeI)
apply (rule Occ_subtree_in_Occ_range)
apply assumption+
done

(** Term_cons_inj_cond **)
lemma Term_cons_inj_condI:
  assumes
  "!! T U l m.
    [| T: Tag; U: Tag; l: list(Terms); m: list(Terms);
      Term_cons(T, l): Terms
    |] ==> Term_cons(T, l) = Term_cons(U, m) <->
          T = U & (ALL z: Arity(T). nth(z, l) = nth(z, m))"
  shows "Term_cons_inj_cond(Terms, Tag, Arity, Term_cons)"
apply (unfold Term_cons_inj_cond_def)
apply (assumption | rule assms ballI impI)+
done

lemma Term_cons_inj_condD:
  "[| Term_cons_inj_cond(Terms, Tag, Arity, Term_cons);
      T: Tag; U: Tag; l: list(Terms); m: list(Terms);
      Term_cons(T, l): Terms
   |] ==> Term_cons(T, l) = Term_cons(U, m) <->
           T = U & (ALL z: Arity(T). nth(z, l) = nth(z, m))"
apply (unfold Term_cons_inj_cond_def)
apply blast
done

lemma Term_cons_inj_condD1:
  "[| Term_cons_inj_cond(Terms, Tag, Arity, Term_cons);
      Term_cons(T, l) = Term_cons(U, m);
      T: Tag; U: Tag; l: list(Terms); m: list(Terms);
      Term_cons(T, l): Terms
   |] ==> T = U & (ALL z: Arity(T). nth(z, l) = nth(z, m))"
apply (unfold Term_cons_inj_cond_def)
apply blast
done

lemma Occ_ind_cond_Term_cons_lemma:
  "[| Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons);
      M: Terms |] ==> EX T: Tag. EX l: list(Terms).
          M = Term_cons(T, l) & Arity(T) = length(l)"
apply (erule Occ_ind_condD)
apply (assumption | rule refl bexI conjI)+
done

lemma Term_cons_inj_cond_induct_lemma:
  assumes hind: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and hinj: "Term_cons_inj_cond(Terms, Tag, Arity, Term_cons)"
  and major: "M: Terms"
  and indstep:
     "!! l T. [| T: Tag; l: list(Terms);
            Term_cons(T, l): Terms;
            Arity(T) = length(l);
            Occ(Term_cons(T, l)) = Occ_cons(T, map(Occ, l));
            ALL z: length(l). ALL U: Tag. ALL m: list(Terms).
               nth(z, l) = Term_cons(U, m) & Arity(U) = length(m)
               --> P(nth(z, l), U, m)
      |]  ==> P(Term_cons(T, l), T, l)"
  shows
    "ALL T. ALL l. M = Term_cons(T, l) & Arity(T) = length(l) &
          T: Tag & l: list(Terms) --> P(M, T, l)"
apply (rule Occ_ind_condD [OF hind major])
apply (intro impI allI)
apply (elim conjE)
apply (drule hinj [THEN Term_cons_inj_condD1])
apply assumption+
apply (erule conjE)
apply hypsubst
apply (rename_tac m)
apply (subgoal_tac "l = m")
prefer 2
apply (rule nth_inj)
apply simp
apply simp
apply assumption+
apply hypsubst
apply (rule indstep)
apply assumption+
apply (intro ballI impI)
apply (erule conjE)
apply (drule bspec)
apply assumption
apply (drule spec [THEN spec, THEN mp])
apply (assumption | rule conjI)+
done

lemma Term_cons_inj_cond_induct:
  assumes hind: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and hinj: "Term_cons_inj_cond(Terms, Tag, Arity, Term_cons)"
  and major: "Term_cons(T, l): Terms"
  and t_tag: "T: Tag"
  and l_list: "l: list(Terms)"
  and lencond: "Arity(T) = length(l)"
  and indstep:
     "!! l T. [| T: Tag; l: list(Terms);
          Term_cons(T, l): Terms;
          Arity(T) = length(l);
          Occ(Term_cons(T, l)) = Occ_cons(T, map(Occ, l));
          ALL z: length(l). ALL U: Tag. ALL m: list(Terms).
             nth(z, l) = Term_cons(U, m) & Arity(U) = length(m)
               --> P(U, m)
      |]  ==> P(T, l)"
  shows "P(T, l)"
apply (rule Term_cons_inj_cond_induct_lemma [OF hind hinj major,
         THEN spec, THEN spec, THEN mp])
prefer 2
apply (assumption | rule refl t_tag l_list lencond conjI)+
apply (rule indstep)
apply assumption+
done

lemma Occ_Term_cons:
  assumes hind: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and hinj: "Term_cons_inj_cond(Terms, Tag, Arity, Term_cons)"
  and major: "Term_cons(T, l): Terms"
  and t_tag: "T: Tag"
  and l_list: "l: list(Terms)"
  and lencond: "Arity(T) = length(l)"
  shows "Occ(Term_cons(T, l)) = Occ_cons(T, map(Occ, l))"
apply (rule Term_cons_inj_cond_induct [OF hind hinj major t_tag l_list lencond])
apply assumption
done

lemma def_Sub_type:
  assumes hcons: "Occ_cons_cond(Terms, Occ, Tag, Arity)"
  and hind: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and hinv: "!!x. Occinv(x) == THE M. M: Terms & x = Occ(M)"
  and hsub: "!!M. Sub(M) == {<l, Occinv(Occ_Subtree(l, Occ(M)))>. <l, T>: Occ(M)}"
  and major: "M: Terms"
  shows "Sub(M) <= list(nat)*Terms"
apply (unfold hsub)
apply safe
apply (frule Occ_ind_cond_Occ_domain [OF hind major, THEN subsetD])
apply (erule SigmaE)
apply hypsubst
apply simp
apply (insert major)
apply (blast intro: def_Occinv_type [OF hcons hind hinv]
               Occ_Subtree_in_Occ_range
               hind [THEN Occ_ind_cond_Occ_in_Occ_range])
done

lemma def_Sub_rec:
  assumes hcons: "Occ_cons_cond(Terms, Occ, Tag, Arity)"
  and hind: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and hinv: "!!x. Occinv(x) == THE M. M: Terms & x = Occ(M)"
  and hsub: "!!M. Sub(M) == {<l, Occinv(Occ_Subtree(l, Occ(M)))>. <l, T>: Occ(M)}"
  and hinj: "Term_cons_inj_cond(Terms, Tag, Arity, Term_cons)"
  and major: "Term_cons(T, l): Terms"
  and t_tag: "T: Tag"
  and l_list: "l: list(Terms)"
  and lencond: "Arity(T) = length(l)"
  shows "Sub(Term_cons(T, l)) = Occ_cons(Term_cons(T, l), map(Sub, l))"
apply (unfold hsub)
apply (rule Term_cons_inj_cond_induct [OF hind hinj major t_tag l_list lencond])
apply (rule equalityI)
apply safe
apply (frule hind [THEN Occ_ind_cond_Occ_domain])
apply (frule subsetD)
apply assumption
apply (erule SigmaE)
apply hypsubst
apply simp
apply (rename_tac v y)
apply (rule_tac a="v" in list.cases)
apply assumption
apply hypsubst
apply (drule_tac a="Occ(Term_cons(T, l))" in sym)
apply (simp add: def_Occinv_Occ [OF hcons hind hinv]
         Occ_Subtree_Nil)
apply (rule Occ_consI1)
apply simp
apply (erule Occ_cons_ConsE)
apply (subgoal_tac "map(Occ, l): list(Pow(list(nat) * Tag))")
apply (simp add: Occ_subtree_Occ_cons Occ_Subtree_Cons)
apply (rule Occ_consI2)
apply simp
apply (simp add: nth_map)
apply (rule bexI)
prefer 2
apply assumption
apply simp

apply (erule map_type)
apply (erule hind [THEN Occ_ind_cond_Occ_domain, THEN PowI])

apply (erule Occ_consE)
apply hypsubst
apply (rule RepFun_eqI)
prefer 2
apply simp
apply (rule Occ_consI1)
apply (frule hind [THEN Occ_ind_cond_Occ_domain])
apply (drule_tac a="Occ(Term_cons(T, l))" in sym)
apply (simp add: def_Occinv_Occ [OF hcons hind hinv]
              Occ_Subtree_Nil)
apply hypsubst
apply (simp add: nth_map)
apply (erule bexE)
apply (subgoal_tac "nth(a, l): Terms")
apply (frule_tac M="nth(a, l)" in hind [THEN Occ_ind_cond_Occ_domain])
apply (drule subsetD, assumption)
apply (erule SigmaE)
apply hypsubst
apply simp
apply (rename_tac n y)
apply (rule_tac x="<Cons(a, n), y>" in bexI)
apply (rule_tac [2] Occ_consI2)
apply (subgoal_tac "a: nat" "map(Occ, l): list(Pow(list(nat) * Tag))")
apply (simp add: nth_map Occ_subtree_Occ_cons Occ_Subtree_Cons)
apply (erule map_type)
apply (erule hind [THEN Occ_ind_cond_Occ_domain, THEN PowI])
apply (erule mem_nat_in_nat)
apply (erule length_type)
apply simp
apply (simp add: nth_map)
apply (rule nth_type2)
apply assumption
apply (erule ltI)
apply (erule length_type [THEN nat_into_Ord])
done

lemma def_Sub_functional:
  assumes hcons: "Occ_cons_cond(Terms, Occ, Tag, Arity)"
  and hind: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and hinv: "!!x. Occinv(x) == THE M. M: Terms & x = Occ(M)"
  and hsub: "!!M. Sub(M) == {<l, Occinv(Occ_Subtree(l, Occ(M)))>. <l, T>: Occ(M)}"
  and hinj: "Term_cons_inj_cond(Terms, Tag, Arity, Term_cons)"
  and major: "M: Terms"
  shows "functional(Sub(M))"
apply (rule Occ_ind_condD [OF hind major])
apply (simp add: def_Sub_rec [OF hcons hind hinv hsub hinj])
apply (rule functionalI)
apply (elim Occ_consE)
apply (simp_all add: nth_map)
apply clarify
apply (drule bspec)
apply (erule_tac [2] functionalD)
apply assumption+
done

lemma def_subterm_Nil:
  assumes hcons: "Occ_cons_cond(Terms, Occ, Tag, Arity)"
  and hind: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and hinv: "!!x. Occinv(x) == THE M. M: Terms & x = Occ(M)"
  and hsub: "!!M. Sub(M) == {<l, Occinv(Occ_Subtree(l, Occ(M)))>. <l, T>: Occ(M)}"
  and hinj: "Term_cons_inj_cond(Terms, Tag, Arity, Term_cons)"
  and hsubterm: "!!M l. subterm(M, l) == THE N. <l, N>: Sub(M)"
  and major: "M: Terms"
  shows "subterm(M, []) = M"
apply (unfold hsubterm)
apply (subgoal_tac "<[], M>: Sub(M)")
apply (rule the_equality)
apply assumption
apply (rule def_Sub_functional [OF hcons hind hinv hsub hinj major,
                                THEN functionalD])
apply assumption+
apply (rule Occ_ind_condD [OF hind major])
apply (simp add: def_Sub_rec [OF hcons hind hinv hsub hinj])
apply (rule Occ_consI1)
done

lemma def_subterm_Cons:
  assumes hcons: "Occ_cons_cond(Terms, Occ, Tag, Arity)"
  and hind: "Occ_ind_cond(Terms, Occ, Tag, Arity, Term_cons)"
  and hinv: "!!x. Occinv(x) == THE M. M: Terms & x = Occ(M)"
  and hsub: "!!M. Sub(M) == {<l, Occinv(Occ_Subtree(l, Occ(M)))>. <l, T>: Occ(M)}"
  and hinj: "Term_cons_inj_cond(Terms, Tag, Arity, Term_cons)"
  and hsubterm: "!!M l. subterm(M, l) == THE N. <l, N>: Sub(M)"
  and major: "Term_cons(T, l): Terms"
  and t_tag: "T: Tag"
  and l_list: "l: list(Terms)"
  and hlen: "Arity(T) = length(l)"
  and prem1: "m: list(nat)"
  and prem2: "a: length(l)"
  shows "subterm(Term_cons(T, l), Cons(a, m)) = subterm(nth(a, l), m)"
apply (unfold hsubterm)
apply (insert major t_tag l_list hlen prem1 prem2)
apply (simp add: def_Sub_rec [OF hcons hind hinv hsub hinj])
apply (subgoal_tac "nth(a, l): Terms")
prefer 2
apply (rule nth_type2, assumption)
apply (erule ltI)
apply (erule length_type [THEN nat_into_Ord])
apply (case_tac "EX X. <m, X>: Sub(nth(a, l))")
prefer 2
apply (rule the_0 [THEN sym, THEN [2] trans])
prefer 2
apply (rule notI)
apply (erule notE)
apply blast
apply (rule the_0)
apply (rule notI)
apply (erule notE)
apply (erule ex1E)
apply (erule Occ_cons_ConsE)
apply (rule exI)
apply (simp add: nth_map)
apply (rule the_equality)
apply (rule_tac [2] the_equality [THEN sym])
apply (erule_tac [3] Occ_cons_ConsE)
apply (erule_tac [2] Occ_cons_ConsE)
apply (rule Occ_consI2)
apply (simp_all add: nth_map)
prefer 2
apply (rule def_Sub_functional [OF hcons hind hinv hsub hinj,
                                THEN functionalD])
prefer 2 apply assumption
prefer 2 apply assumption
apply simp
apply (rule theI)
apply (erule exE)
apply (rule ex1I)
apply assumption
apply (rule def_Sub_functional [OF hcons hind hinv hsub hinj,
                                THEN functionalD])
prefer 2 apply assumption
apply simp
apply assumption
done

end


theory ColimitFunctoriality
  imports Main
          PointedSet
         "Category3.FreeCategory"
begin

locale functor_to_cat =
  C : category C
  for C :: "'c comp"
  and F_ob :: "'c \<Rightarrow> ('d comp)"
  and F_arr :: "'c \<Rightarrow> ('d \<Rightarrow> 'd)" +
assumes Fcat : "\<And>c. C.ide c \<Longrightarrow> category (F_ob c)"
    and Ffun : "\<And>c. C.arr c \<Longrightarrow> functor (F_ob (C.dom c))
                                        (F_ob (C.cod c))
                                        (F_arr c)"
    and Ffun_id : "\<And>c. C.ide c \<Longrightarrow> F_arr c = identity_functor.map (F_ob c)"
    and Ffun_comp : "\<And>g f. C.seq g f \<Longrightarrow> (F_arr (C g f)) =
                                         (F_arr g) \<circ> (F_arr f)"
begin
end

lemma (in vertical_composite) precompose_horizontally :
  assumes "functor D A I"
  shows "vertical_composite D B (F \<circ> I) (G \<circ> I) (H \<circ> I) (\<sigma> \<circ> I) (\<tau> \<circ> I)"
  unfolding vertical_composite_def
proof-
  have Inat : "natural_transformation D A I I I"
    using functor_is_transformation [OF \<open>functor D A I\<close>].
  have I\<sigma>nat: "natural_transformation D B (F \<circ> I) (G \<circ> I) (\<sigma> \<circ> I)"
    apply (rule_tac horizontal_composite.is_natural_transformation)
    unfolding horizontal_composite_def
    using \<sigma>.natural_transformation_axioms Inat
    unfolding natural_transformation_def
    by auto
  have I\<tau>nat: "natural_transformation D B (G \<circ> I) (H \<circ> I) (\<tau> \<circ> I)"
    apply (rule_tac horizontal_composite.is_natural_transformation)
    unfolding horizontal_composite_def
    using \<tau>.natural_transformation_axioms Inat
    unfolding natural_transformation_def
    by auto
  show "(category D \<and> category (\<cdot>\<^sub>B) \<and> functor D (\<cdot>\<^sub>B) (F \<circ> I)) \<and>
    (functor D (\<cdot>\<^sub>B) (G \<circ> I) \<and> functor D (\<cdot>\<^sub>B) (H \<circ> I)) \<and>
    natural_transformation D (\<cdot>\<^sub>B) (F \<circ> I) (G \<circ> I) (\<sigma> \<circ> I) \<and>
    natural_transformation D (\<cdot>\<^sub>B) (G \<circ> I) (H \<circ> I) (\<tau> \<circ> I)"
    using I\<sigma>nat I\<tau>nat
    unfolding natural_transformation_def
    by auto
qed

lemma (in vertical_composite) postcompose_horizontally :
  assumes "functor B C I"
  shows "vertical_composite A C (I \<circ> F) (I \<circ> G) (I \<circ> H) (I \<circ> \<sigma>) (I \<circ> \<tau>)"
  unfolding vertical_composite_def
proof-
  have Inat : "natural_transformation B C I I I"
    using functor_is_transformation [OF \<open>functor B C I\<close>].
  have I\<sigma>nat: "natural_transformation (\<cdot>\<^sub>A) C (I \<circ> F) (I \<circ> G) (I \<circ> \<sigma>)"
    apply (rule_tac horizontal_composite.is_natural_transformation)
    unfolding horizontal_composite_def
    using \<sigma>.natural_transformation_axioms Inat
    unfolding natural_transformation_def
    by auto
  have I\<tau>nat: "natural_transformation (\<cdot>\<^sub>A) C (I \<circ> G) (I \<circ> H) (I \<circ> \<tau>)"
    apply (rule_tac horizontal_composite.is_natural_transformation)
    unfolding horizontal_composite_def
    using \<tau>.natural_transformation_axioms Inat
    unfolding natural_transformation_def
    by auto
  show "(category (\<cdot>\<^sub>A) \<and> category C \<and> functor (\<cdot>\<^sub>A) C (I \<circ> F)) \<and>
    (functor (\<cdot>\<^sub>A) C (I \<circ> G) \<and> functor (\<cdot>\<^sub>A) C (I \<circ> H)) \<and>
    natural_transformation (\<cdot>\<^sub>A) C (I \<circ> F) (I \<circ> G) (I \<circ> \<sigma>) \<and>
    natural_transformation (\<cdot>\<^sub>A) C (I \<circ> G) (I \<circ> H) (I \<circ> \<tau>)"
    using I\<sigma>nat I\<tau>nat
    unfolding natural_transformation_def
    by auto
qed

locale functor_to_cat_overX =
  F : functor_to_cat C F_ob F_arr +
  S : category S
  for C :: "'c comp"
  and S :: "'s comp"
  and F_ob :: "'c \<Rightarrow> ('d comp)"
  and F_arr :: "'c \<Rightarrow> ('d \<Rightarrow> 'd)"
  and \<tau> :: "'c \<Rightarrow> ('d \<Rightarrow> 's)" +
assumes \<tau>fun : "\<And>c. F.C.ide c \<Longrightarrow> functor (F_ob c) S (\<tau> c)"
    and \<tau>nat : "\<And>c. F.C.arr c \<Longrightarrow>
          natural_transformation (F_ob (F.C.dom c)) S
            (\<tau> (F.C.dom c)) (\<tau> (F.C.cod c) \<circ> (F_arr c)) (\<tau> c)"
    and \<tau>comp : "\<And>g f. F.C.seq g f \<Longrightarrow>
                 \<tau> (C g f) = vertical_composite.map (F_ob (F.C.dom f)) S
             (\<tau> f)  (\<tau> g \<circ> F_arr f)"
begin

lemma conj_comm: "A \<and> B \<Longrightarrow> B \<and> A"
  by simp

lemma extend_by_functor :
  assumes "functor S T G"
  shows "functor_to_cat_overX C T F_ob F_arr (\<lambda>c. G \<circ> (\<tau> c))"
  unfolding functor_to_cat_overX_def
  apply safe
    apply (rule_tac F.functor_to_cat_axioms)
  using \<open>functor S T G\<close>
  unfolding functor_def apply simp
  unfolding functor_to_cat_overX_axioms_def
  apply safe
proof-
  fix c
  show "F.C.ide c \<Longrightarrow> functor (F_ob c) T (G \<circ> \<tau> c)"
    apply (rule_tac functor_comp)
    using \<tau>fun apply blast
    using \<open>functor S T G\<close> by simp
  assume "F.C.arr c"
  show "natural_transformation (F_ob (F.C.dom c)) T (G \<circ> \<tau> (F.C.dom c))
          (G \<circ> \<tau> (F.C.cod c) \<circ> F_arr c) (G \<circ> \<tau> c)"
    apply (subst comp_assoc)
    apply (rule_tac horizontal_composite.is_natural_transformation)
    unfolding horizontal_composite_def
    using \<open>functor S T G\<close> functor_def apply auto
  proof-
    show "category (F_ob (F.C.dom c))"
      using F.Fcat [OF F.C.ide_dom [OF \<open>F.C.arr c\<close>]].
    show "functor (F_ob (F.C.dom c)) S (\<tau> (F.C.dom c))"
      using \<tau>fun [OF F.C.ide_dom [OF \<open>F.C.arr c\<close>]].
    show "functor (F_ob (F.C.dom c)) S (\<tau> (F.C.cod c) \<circ> F_arr c)"
      apply (rule_tac functor_comp)
      using F.Ffun [OF \<open>F.C.arr c\<close>] apply simp
      using \<tau>fun [OF F.C.ide_cod [OF \<open>F.C.arr c\<close>]].
    show "natural_transformation (F_ob (F.C.dom c)) S (\<tau> (F.C.dom c))
     (\<tau> (F.C.cod c) \<circ> F_arr c) (\<tau> c)"
      using \<tau>nat [OF \<open>F.C.arr c\<close>].
  qed
next
  fix g f
  assume arr_gf : "F.C.seq g f"
  from arr_gf have arr_f : "F.C.arr f" by blast
  from arr_gf have arr_g : "F.C.arr g" by blast
  from arr_gf have seq : "F.C.dom g = F.C.cod f" by blast

  have fnat : "natural_transformation (F_ob (F.C.dom f)) S (\<tau> (F.C.dom g) \<circ> F_arr f)
     (\<tau> (F.C.cod g) \<circ> F_arr g \<circ> F_arr f) (\<tau> g \<circ> F_arr f)"
    apply (rule_tac horizontal_composite.is_natural_transformation)
    unfolding horizontal_composite_def
    using functor_is_transformation [OF F.Ffun [OF arr_f]]
          \<tau>nat [OF arr_g]
    unfolding natural_transformation_def
    apply (rule_tac conj_comm)
    using seq by auto

  have vert_comp1 : "vertical_composite (F_ob (F.C.dom f)) S
                     (\<tau> (F.C.dom f))
                     (\<tau> (F.C.dom g) \<circ> F_arr f)
                     (\<tau> (F.C.cod g) \<circ> F_arr g \<circ> F_arr f)
                     (\<tau> f) (\<tau> g \<circ> F_arr f)"
    unfolding vertical_composite_def
    using \<tau>nat [OF arr_f]
          fnat
    unfolding natural_transformation_def
    using seq by auto

  show "G \<circ> \<tau> (C g f) =
           vertical_composite.map (F_ob (F.C.dom f)) T (G \<circ> \<tau> f)
            (G \<circ> \<tau> g \<circ> F_arr f)"
    apply (subst \<tau>comp [OF arr_gf])
    unfolding vertical_composite.map_def [OF vert_comp1]
    apply (subst comp_assoc)
    unfolding vertical_composite.map_def
          [OF vertical_composite.postcompose_horizontally
          [OF vert_comp1 \<open>functor S T G\<close>]]
  proof
    fix fa
    show "(G \<circ> (\<lambda>fa. if partial_magma.arr (F_ob (F.C.dom f)) fa
                     then S ((\<tau> g \<circ> F_arr f)
                              (partial_magma.cod (F_ob (F.C.dom f)) fa))
                           (\<tau> f fa)
                     else S.null))
           fa =
          (if partial_magma.arr (F_ob (F.C.dom f)) fa
           then T ((G \<circ> (\<tau> g \<circ> F_arr f))
                    (partial_magma.cod (F_ob (F.C.dom f)) fa))
                 ((G \<circ> \<tau> f) fa)
           else partial_magma.null T)"
      apply auto
    proof-
      show "\<not> partial_magma.arr (F_ob (F.C.dom f)) fa \<Longrightarrow>
    G S.null = partial_magma.null T"
        apply (subst functor.is_extensional [OF \<open>functor S T G\<close>])
        using S.not_arr_null apply blast
        by simp
      assume arr_fa : "partial_magma.arr (F_ob (F.C.dom f)) fa"

      have arr_cod : "partial_magma.arr (F_ob (F.C.dom f))
                       (partial_magma.cod (F_ob (F.C.dom f)) fa)"
        using category.ide_cod [OF F.Fcat [OF F.C.ide_dom [OF arr_f]] arr_fa]
        unfolding category.ide_char [OF F.Fcat [OF F.C.ide_dom [OF arr_f]]]
        by simp

      show "G (S (\<tau> g (F_arr f (partial_magma.cod (F_ob (F.C.dom f)) fa))) (\<tau> f fa)) =
    T (G (\<tau> g (F_arr f (partial_magma.cod (F_ob (F.C.dom f)) fa))))
     (G (\<tau> f fa))"
        apply (rule_tac functor.preserves_comp [OF \<open>functor S T G\<close>])
        apply (rule_tac S.seqI)
          apply (subst natural_transformation.preserves_reflects_arr
                 [OF \<tau>nat [OF arr_f]])
        using arr_fa apply simp
         apply (subst natural_transformation.preserves_reflects_arr
                 [OF \<tau>nat [OF arr_g]])
         apply (subst seq)
         apply (rule_tac functor.preserves_arr [OF F.Ffun [OF arr_f]])
        using category.ide_cod [OF F.Fcat [OF F.C.ide_dom [OF arr_f]] arr_fa]
        unfolding category.ide_char [OF F.Fcat [OF F.C.ide_dom [OF arr_f]]]
         apply simp
      proof-
        define a where "a = partial_magma.dom (F_ob (F.C.dom f)) fa"
        define b where "b = partial_magma.cod (F_ob (F.C.dom f)) fa"

        have in_hom1: "S.in_hom (\<tau> f fa) (\<tau> (F.C.dom f) a) ((\<tau> (F.C.cod f) \<circ> F_arr f) b)"
          apply (rule_tac natural_transformation.preserves_hom
                 [OF \<tau>nat [OF arr_f]])
          unfolding a_def b_def
          using arr_fa
          by (simp add: F.Fcat arr_f category.in_homI)

        define c where "c = (F_arr f (partial_magma.cod (F_ob (F.C.dom f)) fa))"

        have in_hom2 : "S.in_hom (\<tau> g c) (\<tau> (F.C.dom g) c) ((\<tau> (F.C.cod g) \<circ> F_arr g) c)"
          apply (rule_tac natural_transformation.preserves_hom [OF \<tau>nat [OF arr_g]])
          apply (rule_tac category.in_homI
                [OF F.Fcat [OF F.C.ide_dom [OF arr_g]]])
          unfolding c_def seq
            apply (rule_tac functor.preserves_arr [OF F.Ffun [OF arr_f]])
          using arr_cod apply simp
           apply (subst functor.preserves_dom [OF F.Ffun [OF arr_f]])
          using arr_cod apply simp
           apply (subst category.ideD(2) [OF F.Fcat [OF F.C.ide_dom [OF arr_f]]])
          using category.ide_cod [OF F.Fcat [OF F.C.ide_dom [OF arr_f]]] arr_fa apply simp
           apply simp
           apply (subst functor.preserves_cod [OF F.Ffun [OF arr_f]])
          using arr_cod apply simp
          apply (subst category.ideD(3) [OF F.Fcat [OF F.C.ide_dom [OF arr_f]]])
          using category.ide_cod [OF F.Fcat [OF F.C.ide_dom [OF arr_f]]] arr_fa apply simp
          by simp

        show "S.dom (\<tau> g (F_arr f (partial_magma.cod (F_ob (F.C.dom f)) fa))) =
    S.cod (\<tau> f fa)"
          apply (rule_tac S.in_homE [OF in_hom1])
          apply (rule_tac S.in_homE [OF in_hom2])
          unfolding c_def b_def
          by (simp add: seq)
      qed
    qed
  qed
qed

end

definition cocone where
  "cocone C D F x \<tau> = natural_transformation C D F (constant_functor.map C D x) \<tau>"

locale colimit =
  C: category C +
  D: category D +
  F: "functor" C D F +
  \<tau>: natural_transformation C D F "(constant_functor.map C D d)" \<tau>
  for C :: "'c comp"
  and D :: "'d comp"
  and F :: "'c \<Rightarrow> 'd"
  and d :: "'d"
  and \<tau> :: "'c \<Rightarrow> 'd"
  and UP_map :: "'d \<Rightarrow> ('c \<Rightarrow> 'd) \<Rightarrow> 'd" +
assumes d_obj : "D.ide d"
  and cocone : "cocone C D F d \<tau>"
  and UP_existence : "\<And> \<sigma> x. cocone C D F x \<sigma> \<Longrightarrow> D.ide x \<Longrightarrow>
                    D.in_hom (UP_map x \<sigma>) d x \<and>
              (\<forall>c. C.ide c \<longrightarrow> \<sigma> c = D (UP_map x \<sigma>) (\<tau> c))"
  and UP_uniqueness : "\<And>f \<sigma> x. cocone C D F x \<sigma> \<Longrightarrow> D.ide x \<Longrightarrow>
                  ( D.in_hom f d x \<and>
              (\<forall>c. C.ide c \<longrightarrow> \<sigma> c = D f (\<tau> c))) \<Longrightarrow>
                   f = (UP_map x \<sigma>)"
begin

lemma cocone_id : "d = (UP_map d \<tau>)"
  apply (rule_tac UP_uniqueness)
   apply (rule_tac cocone)
  apply safe
  using D.ide_in_hom d_obj apply blast
proof-
  show "D.in_hom d d d"
    using \<open>D.ide d\<close>
  by (simp add: D.ide_in_hom)
  fix c
  assume "C.ide c"
  have d_in_hom: "D.in_hom (UP_map d \<tau>) d d"
    using UP_existence [OF cocone \<open>D.ide d\<close>] by simp
  have eq: "\<tau> c = D (UP_map d \<tau>) (\<tau> c)"
    using UP_existence [OF cocone \<open>D.ide d\<close>] \<open>C.ide c\<close> by simp
  show "\<tau> c = D d (\<tau> c)"
    by (metis D.comp_assoc D.comp_cod_arr D.in_homE d_in_hom eq)
qed

end

locale colimit_functoriality =
  F : functor_to_cat_overX C S F_ob F_arr \<tau>
  for C :: "'c comp"
  and S :: "'s comp"
  and F_ob :: "'c \<Rightarrow> ('d comp)"
  and F_arr :: "'c \<Rightarrow> ('d \<Rightarrow> 'd)"
  and \<tau> :: "'c \<Rightarrow> ('d \<Rightarrow> 's)"
  and colim :: "'c \<Rightarrow> 's"
  and cocone_map :: "'c \<Rightarrow> ('d \<Rightarrow> 's)"
  and colim_UP_map :: "'c \<Rightarrow> 's \<Rightarrow> ('d \<Rightarrow> 's) \<Rightarrow> 's" +
assumes
  colimit_existence : "\<And>c. F.F.C.ide c \<Longrightarrow>
                       colimit (F_ob c) S (\<tau> c)
                       (colim c) (cocone_map c) (colim_UP_map c)"
begin

definition colim_functor :: "'c \<Rightarrow> 's" where
  "colim_functor  = MkFunctor C S
                    (\<lambda>f. colim_UP_map (F.F.C.dom f) (colim (F.F.C.cod f))
                         (vertical_composite.map (F_ob (F.F.C.dom f)) S
                            (\<tau> f) ((cocone_map (F.F.C.cod f)) \<circ> F_arr f)))"

lemma colim_UP_map_in_hom :
  assumes "F.F.C.ide c"
  and "cocone (F_ob c) S (\<tau> c) x \<sigma>" and "F.S.ide x"
shows "F.S.in_hom (colim_UP_map c x \<sigma>) (colim c) x"
proof-
  have "colimit_axioms (F_ob c) S (\<tau> c) (colim c) (cocone_map c)
   (colim_UP_map c)"
    using colimit_existence [OF \<open>F.F.C.ide c\<close>]
    unfolding colimit_def by simp
  then have "(\<forall>\<sigma> x. cocone (F_ob c) S (\<tau> c) x \<sigma> \<longrightarrow> F.S.ide x \<longrightarrow>
         F.S.in_hom (colim_UP_map c x \<sigma>) (colim c) x \<and>
         (\<forall>ca. partial_magma.ide (F_ob c) ca \<longrightarrow>
               \<sigma> ca = S (colim_UP_map c x \<sigma>) (cocone_map c ca)))"
    unfolding colimit_axioms_def by simp
  then show "F.S.in_hom (colim_UP_map c x \<sigma>) (colim c) x"
    by (simp add: \<open>cocone (F_ob c) S (\<tau> c) x \<sigma>\<close> \<open>F.S.ide x\<close>)
qed
lemma colim_UP_map_arr :
  assumes "F.F.C.ide c"
  and "cocone (F_ob c) S (\<tau> c) x \<sigma>" \<open>F.S.ide x\<close>
shows "F.S.arr (colim_UP_map c x \<sigma>)"
  using colim_UP_map_in_hom [OF \<open>F.F.C.ide c\<close>
        \<open>cocone (F_ob c) S (\<tau> c) x \<sigma>\<close> \<open>F.S.ide x\<close>]
  by auto

lemma vert_comp: assumes arr_f : "F.F.C.arr f"
  shows "vertical_composite (F_ob (F.F.C.dom f)) S (\<tau> (F.F.C.dom f))
     (\<tau> (F.F.C.cod f) \<circ> F_arr f)
     (constant_functor.map (F_ob (F.F.C.dom f)) S (colim (F.F.C.cod f))) (\<tau> f)
     (cocone_map (F.F.C.cod f) \<circ> F_arr f)"
proof-
  have ide_dom : "F.F.C.ide (F.F.C.dom f)"
    using F.F.C.ide_dom [OF arr_f].
  have ide_cod : "F.F.C.ide (F.F.C.cod f)"
    using F.F.C.ide_cod [OF arr_f].

  have ide_colim : "F.S.ide (colim (F.F.C.cod f))"
    using colimit.d_obj [OF colimit_existence [OF ide_cod]].

  have const_functor_dom : "constant_functor (F_ob (F.F.C.dom f)) S (colim (F.F.C.cod f))"
    unfolding constant_functor_def
    apply safe
      apply (rule_tac F.F.Fcat [OF ide_dom])
     apply (rule_tac F.S.category_axioms)
    unfolding constant_functor_axioms_def
    using ide_colim by simp
  have const_functor_cod : "constant_functor (F_ob (F.F.C.cod f)) S (colim (F.F.C.cod f))"
    unfolding constant_functor_def
    apply safe
      apply (rule_tac F.F.Fcat [OF ide_cod])
     apply (rule_tac F.S.category_axioms)
    unfolding constant_functor_axioms_def
    using ide_colim by simp

  have const_eq: "constant_functor.map (F_ob (F.F.C.dom f)) S (colim (F.F.C.cod f)) =
        constant_functor.map (F_ob (F.F.C.cod f)) S (colim (F.F.C.cod f)) \<circ> F_arr f"
  proof
    fix x
    have not_arr_null: "\<not> partial_magma.arr (F_ob (F.F.C.cod f))
     (partial_magma.null (F_ob (F.F.C.cod f)))"
      using F.F.Fcat [OF ide_cod]
      using category_def partial_magma.not_arr_null by blast

    show "constant_functor.map (F_ob (F.F.C.dom f)) S (colim (F.F.C.cod f)) x =
         (constant_functor.map (F_ob (F.F.C.cod f)) S (colim (F.F.C.cod f)) \<circ>
          F_arr f)
          x"
      unfolding constant_functor.map_def [OF const_functor_dom]
                constant_functor.map_def [OF const_functor_cod]
      by (simp add: functor.preserves_arr [OF F.F.Ffun [OF arr_f]]
                       functor.is_extensional [OF F.F.Ffun [OF arr_f]]
                       not_arr_null)
  qed
  have hori_comp : "horizontal_composite (F_ob (F.F.C.dom f)) (F_ob (F.F.C.cod f)) S (F_arr f) (F_arr f)
     (\<tau> (F.F.C.cod f))
     (constant_functor.map (F_ob (F.F.C.cod f)) S (colim (F.F.C.cod f)))
     (F_arr f) (cocone_map (F.F.C.cod f))"
    unfolding horizontal_composite_def
    using colimit.cocone[OF colimit_existence [OF ide_cod]]
    unfolding cocone_def
    using functor_is_transformation [OF F.F.Ffun [OF arr_f]]
    unfolding natural_transformation_def
    by auto
  show "vertical_composite (F_ob (F.F.C.dom f)) S (\<tau> (F.F.C.dom f))
     (\<tau> (F.F.C.cod f) \<circ> F_arr f)
     (constant_functor.map (F_ob (F.F.C.dom f)) S (colim (F.F.C.cod f))) (\<tau> f)
     (cocone_map (F.F.C.cod f) \<circ> F_arr f)"
    unfolding vertical_composite_def
    using horizontal_composite.is_natural_transformation [OF hori_comp]
          F.\<tau>nat [OF arr_f]
    unfolding natural_transformation_def
    using const_eq by auto
qed

lemma colim_functor_ide : assumes ide_f : "F.F.C.ide f"
  shows "F.S.ide (colim_functor f)"
proof-

  have EQ1: "(vertical_composite.map (F_ob f) S (\<tau> f) (cocone_map f \<circ> F_arr f)) =
        cocone_map f"
    apply (subst F.F.Ffun_id [OF ide_f])
    apply (subst hcomp_ide_dom)
    using colimit.cocone [OF colimit_existence [OF ide_f]]
    unfolding cocone_def apply simp
    apply (rule_tac vcomp_ide_dom)
    using colimit.cocone [OF colimit_existence [OF ide_f]]
    unfolding cocone_def.

  have EQ2: "colim f = colim_UP_map f (colim f) (cocone_map f)"
    using colimit.cocone_id [OF colimit_existence [OF ide_f]].

  show "F.S.ide (colim_functor f)"
    unfolding colim_functor_def apply (simp add: ide_f)
    apply (subst EQ1)
    apply (subst reverse_equality [OF EQ2])
    using colimit.d_obj [OF colimit_existence [OF ide_f]].
qed

lemma colim_functor_dom : assumes arr_f: "F.F.C.arr f"
  shows "F.S.dom (colim_functor f) = colim (F.F.C.dom f)"
  unfolding colim_functor_def apply (simp add: arr_f)
  using colim_UP_map_in_hom [OF F.F.C.ide_dom [OF arr_f]
      colimit.cocone [OF colimit_existence [OF F.F.C.ide_dom [OF arr_f]]]]
  by (meson F.F.C.ide_cod F.F.C.ide_dom F.S.in_homE assms
             cocone_def colim_UP_map_in_hom colimit.d_obj
                              colimit_existence vert_comp
            vertical_composite.is_natural_transformation)

lemma colim_functor_cod : assumes arr_f: "F.F.C.arr f"
  shows "F.S.cod (colim_functor f) = colim (F.F.C.cod f)"
  unfolding colim_functor_def apply (simp add: arr_f)
  using colim_UP_map_in_hom [OF F.F.C.ide_cod [OF arr_f]
      colimit.cocone [OF colimit_existence [OF F.F.C.ide_cod [OF arr_f]]]]
  by (meson F.F.C.ide_cod F.F.C.ide_dom F.S.in_homE assms
             cocone_def colim_UP_map_in_hom colimit.d_obj
                              colimit_existence vert_comp
            vertical_composite.is_natural_transformation)

lemma colim_ide :
  assumes "F.F.C.ide c"
  shows "F.S.ide (colim c)"
  using colimit_existence [OF \<open>F.F.C.ide c\<close>]
  unfolding colimit_def
  unfolding colimit_axioms_def
  by simp

lemma is_functor: "functor C S colim_functor"
  unfolding functor_def
  apply (simp add: F.F.C.category_axioms F.S.category_axioms)
  unfolding functor_axioms_def
  apply safe
proof-
  fix f
  show "\<not> F.F.C.arr f \<Longrightarrow> colim_functor f = F.S.null"
    unfolding colim_functor_def by simp
  assume arr_f : "F.F.C.arr f"
  have ide_dom : "F.F.C.ide (F.F.C.dom f)"
    using F.F.C.ide_dom [OF arr_f].
  have ide_cod : "F.F.C.ide (F.F.C.cod f)"
    using F.F.C.ide_cod [OF arr_f].

  show "F.S.arr (colim_functor f)"
    unfolding colim_functor_def apply (simp add: arr_f)
    apply (rule_tac colim_UP_map_arr)
    using F.F.C.ide_dom [OF arr_f] apply simp
    unfolding cocone_def
    apply (rule_tac vertical_composite.is_natural_transformation)
    using vert_comp [OF arr_f] apply simp
    using colim_ide [OF F.F.C.ide_cod [OF arr_f]].

  have dom_eq: "F.S.dom (colim_functor f) = F.S.dom (colim_functor (F.F.C.dom f))"
    apply (subst colim_functor_dom [OF arr_f])
    apply (subst colim_functor_dom)
    using arr_f apply simp
    unfolding colim_functor_def by (simp add: arr_f)

  show "F.S.dom (colim_functor f) = colim_functor (F.F.C.dom f)"
    apply (subst dom_eq)
    using F.S.ideD(2) [OF colim_functor_ide [OF ide_dom]].

  have cod_eq: "F.S.cod (colim_functor f) = F.S.cod (colim_functor (F.F.C.cod f))"
    apply (subst colim_functor_cod [OF arr_f])
    apply (subst colim_functor_cod)
    using arr_f apply simp
    unfolding colim_functor_def by (simp add: arr_f)

  show "F.S.cod (colim_functor f) = colim_functor (F.F.C.cod f)"
    apply (subst cod_eq)
    using F.S.ideD(3) [OF colim_functor_ide [OF ide_cod]].
next
  fix g f
  assume arr_gf: "F.F.C.seq g f"
  then have gf_prop: "F.F.C.arr f \<and> F.F.C.arr g \<and> F.F.C.dom g = F.F.C.cod f"
    using F.F.C.seqE [OF arr_gf] by auto
  from gf_prop have arr_f : "F.F.C.arr f" by simp
  from gf_prop have arr_g : "F.F.C.arr g" by simp
  from gf_prop have seq : "F.F.C.dom g = F.F.C.cod f" by simp

  have in_hom_f: "F.S.in_hom (colim_UP_map (F.F.C.dom f) (colim (F.F.C.cod f))
       (vertical_composite.map (F_ob (F.F.C.dom f)) S (\<tau> f)
         (cocone_map (F.F.C.cod f) \<circ> F_arr f)))
     (colim (F.F.C.dom f)) (colim (F.F.C.cod f))"
    apply (rule_tac conjunct1 [OF colimit.UP_existence [OF colimit_existence]])
     apply (rule_tac F.F.C.ide_dom [OF arr_f])
    unfolding cocone_def
    apply (rule_tac vertical_composite.is_natural_transformation)
    using vert_comp [OF arr_f] apply simp
    using colim_ide [OF F.F.C.ide_cod [OF arr_f]].

  have in_hom_g: "F.S.in_hom
     (colim_UP_map (F.F.C.cod f) (colim (F.F.C.cod g))
       (vertical_composite.map (F_ob (F.F.C.cod f)) S (\<tau> g)
         (cocone_map (F.F.C.cod g) \<circ> F_arr g)))
     (colim (F.F.C.cod f)) (colim (F.F.C.cod g))"
    unfolding reverse_equality [OF seq]
    apply (rule_tac conjunct1 [OF colimit.UP_existence [OF colimit_existence]])
     apply (rule_tac F.F.C.ide_dom [OF arr_g])
    unfolding cocone_def
    apply (rule_tac vertical_composite.is_natural_transformation)
    using vert_comp [OF arr_g] apply simp
    using colim_ide [OF F.F.C.ide_cod [OF arr_g]].

  show "colim_functor (C g f) = S (colim_functor g) (colim_functor f)"
    unfolding colim_functor_def apply (simp add: gf_prop arr_gf)
    apply (rule_tac reverse_equality [OF colimit.UP_uniqueness [OF colimit_existence]])
      apply (rule_tac F.F.C.ide_dom [OF arr_f])
    unfolding cocone_def
     apply (rule_tac vertical_composite.is_natural_transformation)
    using vert_comp [OF arr_gf]
    unfolding F.F.C.dom_comp [OF arr_gf]
              F.F.C.cod_comp [OF arr_gf] apply simp
     apply safe
    using colim_ide [OF F.F.C.ide_cod [OF arr_g]] apply simp
     apply (rule_tac F.S.comp_in_homI)
      apply (rule_tac in_hom_f)
     apply (rule_tac in_hom_g)
  proof-

    fix x
    assume ide_x: "partial_magma.ide (F_ob (F.F.C.dom f)) x"
    then have ide_fx : "partial_magma.ide (F_ob (F.F.C.dom g)) (F_arr f x)"
      unfolding seq
      using functor.preserves_ide [OF F.F.Ffun [OF arr_f]] by simp

    from ide_x have arr_x : "partial_magma.arr (F_ob (F.F.C.dom f)) x"
      using F.F.Fcat [OF F.F.C.ide_dom [OF arr_f]]
      by (simp add: category.ideD(1))
    then have arr_fx : "partial_magma.arr (F_ob (F.F.C.dom g)) (F_arr f x)"
      unfolding seq
      using functor.preserves_arr [OF F.F.Ffun [OF arr_f]] by simp

    have "cocone (F_ob (F.F.C.dom g)) S (\<tau> (F.F.C.dom g)) (colim (F.F.C.cod g))
              (vertical_composite.map (F_ob (F.F.C.dom g)) S (\<tau> g)
         (cocone_map (F.F.C.cod g) \<circ> F_arr g))"
      unfolding cocone_def
      apply (rule_tac vertical_composite.is_natural_transformation)
      using vert_comp [OF arr_g].

    then have rule_g: "(\<And>c. partial_magma.ide (F_ob (F.F.C.dom g)) c \<Longrightarrow>
       ((vertical_composite.map (F_ob (F.F.C.dom g)) S (\<tau> g)
         (cocone_map (F.F.C.cod g) \<circ> F_arr g)) c) = S (colim_UP_map (F.F.C.dom g) (colim (F.F.C.cod g))
              (vertical_composite.map (F_ob (F.F.C.dom g)) S (\<tau> g)
         (cocone_map (F.F.C.cod g) \<circ> F_arr g))) (cocone_map (F.F.C.dom g) c))"
      using conjunct2 [OF colimit.UP_existence
                      [OF colimit_existence
                      [OF F.F.C.ide_dom [OF arr_g]]]]
      using colim_ide [OF F.F.C.ide_cod [OF arr_g]]
      by auto

    have "cocone (F_ob (F.F.C.dom f)) S (\<tau> (F.F.C.dom f)) (colim (F.F.C.cod f))
              (vertical_composite.map (F_ob (F.F.C.dom f)) S (\<tau> f)
         (cocone_map (F.F.C.cod f) \<circ> F_arr f))"
      unfolding cocone_def
      apply (rule_tac vertical_composite.is_natural_transformation)
      using vert_comp [OF arr_f].

    then have rule_f: "(\<And>c. partial_magma.ide (F_ob (F.F.C.dom f)) c \<Longrightarrow>
       ((vertical_composite.map (F_ob (F.F.C.dom f)) S (\<tau> f)
         (cocone_map (F.F.C.cod f) \<circ> F_arr f)) c) = S (colim_UP_map (F.F.C.dom f) (colim (F.F.C.cod f))
              (vertical_composite.map (F_ob (F.F.C.dom f)) S (\<tau> f)
         (cocone_map (F.F.C.cod f) \<circ> F_arr f))) (cocone_map (F.F.C.dom f) c))"
      using conjunct2 [OF colimit.UP_existence
                      [OF colimit_existence
                      [OF F.F.C.ide_dom [OF arr_f]]]]
      using colim_ide [OF F.F.C.ide_cod [OF arr_f]]
      by auto

    have hori_gf : "horizontal_composite
             (F_ob (F.F.C.dom f)) (F_ob (F.F.C.cod f)) S
                  (F_arr f) (F_arr f) (\<tau> (F.F.C.cod f))
         (\<tau> (F.F.C.cod g) \<circ> F_arr g) (F_arr f) (\<tau> g)"
      unfolding horizontal_composite_def
      using F.\<tau>nat [OF arr_g]
            functor_is_transformation [OF F.F.Ffun [OF arr_f]]
      unfolding natural_transformation_def
      using seq by auto

    have vert_gf : "vertical_composite (F_ob (F.F.C.dom f)) S
                    (\<tau> (F.F.C.dom f))
                    (\<tau> (F.F.C.cod f) \<circ> F_arr f)
                    (\<tau> (F.F.C.cod g) \<circ> F_arr g \<circ> F_arr f)
                    (\<tau> f) (\<tau> g \<circ> F_arr f)"
      unfolding vertical_composite_def
      using horizontal_composite.is_natural_transformation [OF hori_gf]
            F.\<tau>nat [OF arr_f]
      unfolding natural_transformation_def
      using seq by auto

    show "vertical_composite.map (F_ob (F.F.C.dom f)) S (\<tau> (C g f))
          (cocone_map (F.F.C.cod g) \<circ> F_arr (C g f)) x =
         S (S (colim_UP_map (F.F.C.cod f) (colim (F.F.C.cod g))
                (vertical_composite.map (F_ob (F.F.C.cod f)) S (\<tau> g)
                  (cocone_map (F.F.C.cod g) \<circ> F_arr g)))
             (colim_UP_map (F.F.C.dom f) (colim (F.F.C.cod f))
               (vertical_composite.map (F_ob (F.F.C.dom f)) S (\<tau> f)
                 (cocone_map (F.F.C.cod f) \<circ> F_arr f))))
          (cocone_map (F.F.C.dom f) x) "
      apply (subst F.S.comp_assoc)
      apply (subst reverse_equality [OF rule_f [OF ide_x]])
      apply (subst vertical_composite.map_def)
      using vert_comp [OF arr_gf]
      unfolding F.F.C.dom_comp [OF arr_gf]
                F.F.C.cod_comp [OF arr_gf] apply simp
      apply (simp add: arr_x)
      apply (subst category.ideD(3) [OF F.F.Fcat [OF F.F.C.ide_dom [OF arr_f]] ide_x])
      apply (subst vertical_composite.map_def)
      using vert_comp [OF arr_f] apply simp
      apply (simp add: arr_x)
      apply (subst category.ideD(3) [OF F.F.Fcat [OF F.F.C.ide_dom [OF arr_f]] ide_x])
      unfolding reverse_equality [OF seq]
      apply (subst reverse_equality [OF F.S.comp_assoc])
      apply (subst reverse_equality [OF rule_g])
      using functor.preserves_ide [OF F.F.Ffun [OF arr_f] ide_x] apply (simp add: seq)
      apply (subst F.\<tau>comp [OF arr_gf])
      apply (subst F.F.Ffun_comp [OF arr_gf])
      apply (subst vertical_composite.map_def)
       apply (rule_tac vert_gf)
      apply (simp add: arr_x)
      apply (subst vertical_composite.map_def)
       apply (rule_tac vert_comp [OF arr_g])
      apply (simp add: arr_fx)
      apply (subst category.ideD(3) [OF F.F.Fcat [OF F.F.C.ide_dom [OF arr_f]] ide_x])
      apply (subst category.ideD(3) [OF F.F.Fcat [OF F.F.C.ide_dom [OF arr_g]] ide_fx])
      apply (subst F.S.comp_assoc)
      by simp
  qed
qed

lemma colim_functor_obj_simp :
  assumes "F.F.C.ide A"
  shows "colim_functor A = colim A"
proof-
  interpret Col : colimit "F_ob A" S "\<tau> A" "colim A" "cocone_map A" "colim_UP_map A"
    using colimit_existence [OF assms].
  have EQ: "(vertical_composite.map (F_ob A) S (\<tau> A) (cocone_map A \<circ> F_arr A)) = cocone_map A"
    apply (rule_tac ext)
    apply (subst vertical_composite.map_def)
    using vert_comp [OF F.F.C.ideD(1) [OF assms]]
     apply (simp add: assms)
    apply auto
     apply (simp_all add: Col.\<tau>.is_extensional)
    apply (subst F.F.Ffun_id [OF assms])
    apply (subst Col.C.map_def)
    by simp

  have "F.S.dom (colim_functor A) = colim A"
    unfolding colim_functor_def
    apply (simp add: assms)
    apply (rule_tac F.S.in_hom_dom [OF colim_UP_map_in_hom])
      apply (simp add: assms)
    unfolding EQ
    using Col.cocone apply simp
    using colim_ide [OF assms].
  then show "colim_functor A = colim A"
    unfolding F.S.ideD(2) [OF functor.preserves_ide [OF is_functor assms]].
qed

end

locale coproduct_cocone =
  C : category C
  for C :: "'a comp"
  and obj :: "'a" +
assumes ide_obj : "C.ide obj"
begin
(*Here we construct a functor SetCat \<longrightarrow> {Categories over C} that sends each set S
  to the functor S \<longrightarrow> C that is constantly obj.*)

interpretation S : set_category SetCat.comp
  using SetCat.is_set_category.

lemma is_discrete_category : "discrete_category c"
  unfolding discrete_category_def free_category_def graph_def
  by simp

definition discrete_functor :: "('s SetCat.arr \<Rightarrow> 's SetCat.arr discrete_category.arr \<Rightarrow> 's SetCat.arr discrete_category.arr)" where
  "discrete_functor f = MkFunctor (discrete_category.comp (S.set (S.dom f)))
                                  (discrete_category.comp (S.set (S.cod f)))
                                  (\<lambda>x. discrete_category.mkIde (S.set (S.cod f))
                                  (S.Fun f (discrete_category.toObj x)))"

interpretation DF: functor_to_cat SetCat.comp
       "(\<lambda>S. discrete_category.comp (S.set S))"
       discrete_functor
  unfolding functor_to_cat_def
  apply (simp add: SetCat.is_category)
  unfolding functor_to_cat_axioms_def
  apply auto
proof-
  show cat: "\<And>c. S.ide c \<Longrightarrow> category (discrete_category.comp (S.set c))"
    apply (rule_tac discrete_category.is_category)
    using is_discrete_category.
  show func: "\<And>c. S.arr c \<Longrightarrow>
         functor (discrete_category.comp (S.Dom c)) (discrete_category.comp (S.Cod c)) (discrete_functor c)"
  proof-
    fix c :: "'s SetCat.arr"
    assume arr_c: "S.arr c"
    interpret Dom: discrete_category "(S.set (S.dom c))"
      using is_discrete_category.
    interpret Cod: discrete_category "(S.set (S.cod c))"
      using is_discrete_category.
    show "functor Dom.comp Cod.comp (discrete_functor c)"
      unfolding functor_def
      apply (simp add: Dom.is_category Cod.is_category)
      unfolding functor_axioms_def
      apply safe
          apply (simp add: discrete_functor_def)
    proof-
      show arr: "\<And>f. Dom.arr f \<Longrightarrow> Cod.arr (discrete_functor c f)"
        unfolding discrete_functor_def
        apply (simp add: arr_c)
        unfolding Cod.arr_char
        using S.Fun_mapsto [OF arr_c] Dom.toObj_in_Obj
        by auto
      show dom: "\<And>f. Dom.arr f \<Longrightarrow> Cod.dom (discrete_functor c f) = discrete_functor c (Dom.dom f)"
        unfolding Cod.dom_char
        by (simp add: arr)
      show cod: "\<And>f. Dom.arr f \<Longrightarrow> Cod.cod (discrete_functor c f) = discrete_functor c (Dom.cod f)"
        unfolding Cod.cod_char
        by (simp add: arr)
      fix g f
      assume arr_gf: "Dom.seq g f"
      have arr_dfg : "Cod.seq (discrete_functor c g) (discrete_functor c f)"
        apply (rule_tac Dom.seqE [OF arr_gf])
        apply (rule_tac Cod.seqI)
        unfolding dom cod
        by (simp_all add: arr)
      have if_helper : "\<And>P x y. P \<Longrightarrow> (if P then x else y) = x"
        by simp
      show "discrete_functor c (Dom.comp g f) = Cod.comp (discrete_functor c g) (discrete_functor c f)"
        apply (subst Cod.comp_char)
        unfolding if_helper [OF arr_dfg]
        apply (subst Dom.comp_char)
        unfolding if_helper [OF arr_gf]
        by simp
    qed
  qed
  show "\<And>c. S.ide c \<Longrightarrow> discrete_functor c = identity_functor.map (discrete_category.comp (S.set c))"
  proof-
    fix c :: "'s SetCat.arr"
    assume ide_c: "S.ide c"
    then have arr_c : "S.arr c" by simp
    have eq: "S.Dom c = S.set c \<and> S.Cod c = S.set c \<and> S.Fun c = (\<lambda>x\<in>S.Dom c. x)"
      using ide_c
      unfolding S.ide_char [OF arr_c] apply simp
      using S.ideD(3) [OF ide_c] by simp

    interpret D: discrete_category "S.set c"
      using is_discrete_category.
    show "discrete_functor c = D.map"
      apply (rule_tac ext)
      unfolding D.map_def
      unfolding discrete_functor_def
      unfolding conjunct1 [OF eq]
      unfolding conjunct1 [OF conjunct2 [OF eq]]
      unfolding conjunct2 [OF conjunct2 [OF eq]]
      apply auto
      unfolding S.ideD(2) [OF ide_c]
      using D.toObj_in_Obj by simp
  qed
  fix g f :: "'s SetCat.arr"
  assume arr_gf : "S.seq g f"
  then have arr_f: "S.arr f"
    by blast
  from arr_gf have seq_eq : "S.dom g = S.cod f"
    by blast

  interpret Domf : discrete_category "S.Dom f"
    using is_discrete_category.
  interpret Codf : discrete_category "S.Cod f"
    using is_discrete_category.
  interpret Codg : discrete_category "S.Cod g"
    using is_discrete_category.
  interpret F : "functor" Domf.comp Codf.comp "discrete_functor f"
    using func [OF arr_f].

  show "discrete_functor (SetCat.comp g f) = discrete_functor g \<circ> discrete_functor f"
    apply (rule_tac ext)
    apply (subst discrete_functor_def)
    unfolding S.dom_comp [OF arr_gf]
    unfolding S.cod_comp [OF arr_gf]
    apply auto
     apply (subst discrete_functor_def)
    unfolding seq_eq
     apply (simp add: F.preserves_arr)
     apply (subst discrete_functor_def)
    apply simp
    unfolding S.Fun_comp [OF arr_gf]
     apply (simp add : Domf.toObj_in_Obj)
     apply (subst Codf.toObj_mkIde)
    using S.Fun_mapsto [OF arr_f] Domf.toObj_in_Obj apply auto[2]
    unfolding seq_eq
    unfolding F.is_extensional
    unfolding discrete_functor_def seq_eq
    by simp
qed

definition cocone where
  "cocone f = constant_functor.map (discrete_category.comp (S.Dom f)) C obj"

lemma is_functor_to_cat :
  "functor_to_cat SetCat.comp
   (\<lambda>S. discrete_category.comp (S.set S))
   discrete_functor"
  using DF.functor_to_cat_axioms.

lemma const_fun :"\<And>c. S.ide c \<Longrightarrow> constant_functor (discrete_category.comp (S.set c)) C obj"
  unfolding constant_functor_def
  apply (subst discrete_category.is_category)
   apply (simp add: is_discrete_category)
  unfolding constant_functor_axioms_def
  by (simp add: C.category_axioms ide_obj)

lemma const_functor_overX: "functor_to_cat_overX SetCat.comp C
       (\<lambda>S. discrete_category.comp (S.set S))
       discrete_functor cocone"
  unfolding cocone_def
  unfolding functor_to_cat_overX_def
  apply (simp add: DF.functor_to_cat_axioms C.category_axioms)
  unfolding functor_to_cat_overX_axioms_def
  apply auto
proof-
  show "\<And>ca. S.ide ca \<Longrightarrow>
          functor (discrete_category.comp (S.set ca)) C
           (constant_functor.map (discrete_category.comp (S.set ca)) C obj)"
    apply (rule_tac constant_functor.is_functor)
    using const_fun.
  have eq: "\<And>c. S.arr c \<Longrightarrow>
           (constant_functor.map (discrete_category.comp (S.Cod c)) C obj \<circ>
           discrete_functor c) = (constant_functor.map (discrete_category.comp (S.Dom c)) C obj)"
    apply (rule_tac ext)
    apply (subst constant_functor.map_def)
     apply (rule_tac const_fun [OF S.ide_dom])
     apply auto
     apply (subst constant_functor.map_def)
      apply (rule_tac const_fun [OF S.ide_cod])
      apply simp
    using functor.preserves_arr [OF DF.Ffun]
     apply auto[1]
    by (meson DF.Ffun S.ide_cod const_fun constant_functor.map_def functor.preserves_reflects_arr)
  show nat: "\<And>c. S.arr c \<Longrightarrow>
         natural_transformation (discrete_category.comp (S.Dom c)) C
          (constant_functor.map (discrete_category.comp (S.Dom c)) C obj)
          (constant_functor.map (discrete_category.comp (S.Cod c)) C obj \<circ>
           discrete_functor c)
          (constant_functor.map (discrete_category.comp (S.Dom c)) C obj)"
    apply (simp add: eq)
    apply (rule_tac functor_is_transformation)
    apply (rule_tac constant_functor.is_functor)
    using const_fun [OF S.ide_dom].
  fix g f :: "'s SetCat.arr"
  assume arr_gf : "S.seq g f"
  then have seq_eq: "S.dom g = S.cod f" by blast
  from arr_gf have arr_f: "S.arr f" by blast
  interpret Const : constant_functor "(discrete_category.comp (S.Dom f))" C obj
    using const_fun [OF S.ide_dom [OF arr_f]].

  show "Const.map =
    vertical_composite.map (discrete_category.comp (S.Dom f)) C Const.map
     (constant_functor.map (discrete_category.comp (S.Dom g)) C obj \<circ> discrete_functor f)"
    unfolding seq_eq
    apply (rule_tac ext)
    apply (subst vertical_composite.map_def)
    unfolding vertical_composite_def
    using nat [OF arr_f]
    unfolding eq [OF arr_f]
    unfolding natural_transformation_def
     apply auto
    using ide_obj apply simp
    unfolding Const.map_def by simp
qed

end

end


theory simp_expr_unambig5
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Tok = C | D | X | Y | Pl
  datatype T = TX | TY
  datatype E = Plus "T" "E" | Term "T"
  fun linTerm :: "T => Tok list" where
  "linTerm (TX) = Cons2 X (Nil2)"
  | "linTerm (TY) = Cons2 Y (Nil2)"
  fun append :: "'a list => 'a list => 'a list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  fun lin :: "E => Tok list" where
  "lin (Plus a b) =
     append (append (linTerm a) (Cons2 Pl (Nil2))) (lin b)"
  | "lin (Term t) = linTerm t"
  (*hipster linTerm append lin*)
  theorem x0 :
    "!! (u :: E) (v :: E) . ((lin u) = (lin v)) ==> (u = v)"
    oops
end