section {*control\_theory\_on\_languages\_\_characterization\_of\_controllable\_sublanguage*}
theory
  control_theory_on_languages__characterization_of_controllable_sublanguage

imports
  control_theory_on_languages__alternative_characterization_of_controllable_language

begin

definition controllable_subset :: "
  '\<Sigma> list set
  \<Rightarrow> '\<Sigma> set
  \<Rightarrow> '\<Sigma> list set
  \<Rightarrow> '\<Sigma> list set" where
  "controllable_subset A \<Sigma>UC L \<equiv>
  {w \<in> A. controllable_sublanguage (prefix_closure {w}) (alphabet_to_language \<Sigma>UC) L A}"

definition star_controllable_subset :: "
  '\<Sigma> list set
  \<Rightarrow> '\<Sigma> set
  \<Rightarrow> '\<Sigma> list set
  \<Rightarrow> '\<Sigma> list set" where
  "star_controllable_subset A \<Sigma>UC L \<equiv>
  {w \<in> A. controllable_sublanguage (prefix_closure {w}) (kleene_star \<Sigma>UC) L A}"

corollary star_controllable_subset_unequal_to_controllable_subset: "
  A = {[],[u]}
  \<Longrightarrow> L = {[],[u],[u,u]}
  \<Longrightarrow> \<Sigma>UC = {u}
  \<Longrightarrow> controllable_subset A \<Sigma>UC L = {[]}
  \<and> star_controllable_subset A \<Sigma>UC L = {}"
  apply(unfold star_controllable_subset_def controllable_subset_def)
  apply(rule conjI)
   apply(simp add: star_controllable_language_def star_controllable_subset_def controllable_language_def controllable_subset_def append_alphabet_def append_language_def alphabet_to_language_def controllable_word_def controllable_sublanguage_def prefix_closure_def kleene_star_def prefix_def)
   apply(rule antisym)
    apply(clarsimp)
    apply(erule_tac
      x="[u]"
      in allE)
    apply(clarsimp)
   apply(clarsimp)
  apply(rule antisym)
   prefer 2
   apply(force)
  apply(clarsimp)
  apply(rename_tac x)(*strict*)
  apply(simp add: star_controllable_language_def star_controllable_subset_def controllable_language_def controllable_subset_def append_alphabet_def append_language_def alphabet_to_language_def controllable_word_def controllable_sublanguage_def prefix_closure_def kleene_star_def prefix_def)
  apply(case_tac "x")
   apply(rename_tac x)(*strict*)
   apply(force)
  apply(rename_tac x a list)(*strict*)
  apply(erule_tac
      x="[u]"
      in allE)
  apply(clarsimp)
  apply(force)
  done

corollary star_controllable_subset_is_subset_of_controllable_subset: "
  star_controllable_subset A \<Sigma>UC L \<subseteq> controllable_subset A \<Sigma>UC L"
  apply(unfold star_controllable_subset_def controllable_subset_def)
  apply(clarsimp)
  apply(rename_tac x)(*strict*)
  apply(simp add: star_controllable_language_def star_controllable_subset_def controllable_language_def controllable_subset_def append_alphabet_def append_language_def alphabet_to_language_def controllable_word_def controllable_sublanguage_def prefix_closure_def kleene_star_def prefix_def)
  apply(clarsimp)
  done

definition uncontrollable_subset :: "
  '\<Sigma> list set
  \<Rightarrow> '\<Sigma> set
  \<Rightarrow> '\<Sigma> set
  \<Rightarrow> '\<Sigma> list set
  \<Rightarrow> '\<Sigma> list set" where
  "uncontrollable_subset A \<Sigma>UC \<Sigma> L \<equiv>
  append_language
    ((right_quotient (L - A) (alphabet_to_language \<Sigma>UC)) \<inter> A)
    (kleene_star \<Sigma>)"

definition star_uncontrollable_subset :: "
  '\<Sigma> list set
  \<Rightarrow> '\<Sigma> set
  \<Rightarrow> '\<Sigma> set
  \<Rightarrow> '\<Sigma> list set
  \<Rightarrow> '\<Sigma> list set" where
  "star_uncontrollable_subset A \<Sigma>UC \<Sigma> L \<equiv>
  append_language
    ((right_quotient (L - A) (kleene_star \<Sigma>UC)) \<inter> A)
    (kleene_star \<Sigma>)"

corollary controllable_subset_prefix_closed: "
  A = prefix_closure A
  \<Longrightarrow> controllable_subset A \<Sigma>UC L = prefix_closure (controllable_subset A \<Sigma>UC L)"
  apply(simp add: controllable_subset_def prefix_closure_def controllable_sublanguage_def)
  apply(rule antisym)
   apply(clarsimp)
   apply(rename_tac x)(*strict*)
   apply(rule_tac
      x="x"
      in exI)
   apply(simp add: prefix_def)
  apply(clarsimp)
  apply(rename_tac x v)(*strict*)
  apply(rule conjI)
   apply(rename_tac x v)(*strict*)
   apply(blast)
  apply(rename_tac x v)(*strict*)
  apply(clarsimp)
  apply(rename_tac x v w)(*strict*)
  apply(simp add: controllable_word_def prefix_def)
  apply(clarsimp)
  done

corollary star_controllable_subset_prefix_closed: "
  A = prefix_closure A
  \<Longrightarrow> star_controllable_subset A \<Sigma>UC L = prefix_closure (star_controllable_subset A \<Sigma>UC L)"
  apply(simp add: star_controllable_subset_def prefix_closure_def)
  apply(rule antisym)
   apply(clarsimp)
   apply(rename_tac x)(*strict*)
   apply(rule_tac
      x="x"
      in exI)
   apply(simp add: prefix_def)
  apply(clarsimp)
  apply(rename_tac x v)(*strict*)
  apply(rule conjI)
   apply(rename_tac x v)(*strict*)
   apply(blast)
  apply(rename_tac x v)(*strict*)
  apply(simp add: controllable_word_def prefix_def controllable_sublanguage_def)
  apply(clarsimp)
  done

corollary uncontrollable_subset_extension_closed: "
  set x \<subseteq> \<Sigma>
  \<Longrightarrow> prefix w' x
  \<Longrightarrow> w' \<in> uncontrollable_subset A \<Sigma>UC \<Sigma> L
  \<Longrightarrow> x \<in> uncontrollable_subset A \<Sigma>UC \<Sigma> L"
  apply(simp add: uncontrollable_subset_def append_alphabet_def append_language_def alphabet_to_language_def kleene_star_def)
  apply(clarsimp)
  apply(rename_tac a b)(*strict*)
  apply(rule_tac
      x="a"
      in bexI)
   apply(rename_tac a b)(*strict*)
   apply(simp add: prefix_def)
   apply(erule exE)
   apply(rename_tac a b c)(*strict*)
   apply(rule_tac
      x="b@c"
      in exI)
   apply(clarsimp)
   apply(rename_tac a b c x)(*strict*)
   apply(blast)
  apply(rename_tac a b)(*strict*)
  apply(blast)
  done

corollary star_uncontrollable_subset_extension_closed: "
  set x \<subseteq> \<Sigma>
  \<Longrightarrow> prefix w' x
  \<Longrightarrow> w' \<in> star_uncontrollable_subset A \<Sigma>UC \<Sigma> L
  \<Longrightarrow> x \<in> star_uncontrollable_subset A \<Sigma>UC \<Sigma> L"
  apply(simp add: star_uncontrollable_subset_def append_alphabet_def append_language_def alphabet_to_language_def kleene_star_def)
  apply(clarsimp)
  apply(rename_tac a b)(*strict*)
  apply(rule_tac
      x="a"
      in bexI)
   apply(rename_tac a b)(*strict*)
   apply(simp add: prefix_def)
   apply(erule exE)
   apply(rename_tac a b c)(*strict*)
   apply(rule_tac
      x="b@c"
      in exI)
   apply(clarsimp)
   apply(rename_tac a b c x)(*strict*)
   apply(blast)
  apply(rename_tac a b)(*strict*)
  apply(blast)
  done

lemma apply_controllability2: "
  append_language A (kleene_star \<Sigma>UC) \<inter> L \<subseteq> A
  \<Longrightarrow> w \<in> A
  \<Longrightarrow> u \<in> (kleene_star \<Sigma>UC)
  \<Longrightarrow> w @ u \<in> L
  \<Longrightarrow> w @ u \<in> A"
  apply(simp add: append_alphabet_def append_language_def alphabet_to_language_def)
  apply(force)
  done

corollary controllable_subset_FP_implies_controllable_language: "
  A = prefix_closure A
  \<Longrightarrow> A = controllable_subset A \<Sigma>UC L
  \<Longrightarrow> controllable_language A \<Sigma>UC L"
  apply(simp add: controllable_subset_def controllable_language_def controllable_sublanguage_def controllable_word_def alphabet_to_language_def prefix_closure_def)
  apply(clarsimp)
  apply(rename_tac x)(*strict*)
  apply(simp add: append_alphabet_def append_language_def alphabet_to_language_def)
  apply(clarsimp)
  apply(rename_tac v s)(*strict*)
  apply(subgoal_tac "\<forall>w'. w' \<sqsubseteq> v \<longrightarrow> (\<forall>x\<in> \<Sigma>UC. w' @ [x] \<in> L \<longrightarrow> w' @ [x] \<in> A)")
   apply(rename_tac v s)(*strict*)
   apply(erule_tac
      x="v"
      in allE)
   apply(erule impE)
    apply(rename_tac v s)(*strict*)
    apply(rule prefix_reflexive)
   apply(rename_tac v s)(*strict*)
   apply(erule_tac
      x="s"
      in ballE)
    apply(rename_tac v s)(*strict*)
    apply(clarsimp)
   apply(rename_tac v s)(*strict*)
   apply(clarsimp)
  apply(rename_tac v s)(*strict*)
  apply(simp add: prefix_def)
  apply(clarsimp)
  apply(rename_tac s w' x c)(*strict*)
  apply(subgoal_tac "w' \<in> A")
   apply(rename_tac s w' x c)(*strict*)
   prefer 2
   apply(force)
  apply(rename_tac s w' x c)(*strict*)
  apply(subgoal_tac "w' \<in> {w \<in> A. \<forall>wa. (\<exists>c. wa @ c = w) \<longrightarrow> (\<forall>u. (\<exists>v\<in> \<Sigma>UC. u = [v]) \<longrightarrow> wa @ u \<in> L \<longrightarrow> wa @ u \<in> A)}")
   apply(rename_tac s w' x c)(*strict*)
   prefer 2
   apply(rule_tac
      t="{w \<in> A. \<forall>wa. (\<exists>c. wa @ c = w) \<longrightarrow> (\<forall>u. (\<exists>v\<in> \<Sigma>UC. u = [v]) \<longrightarrow> wa @ u \<in> L \<longrightarrow> wa @ u \<in> A)}"
      and s="A"
      in ssubst)
    apply(rename_tac s w' x c)(*strict*)
    apply(force)
   apply(rename_tac s w' x c)(*strict*)
   apply(force)
  apply(rename_tac s w' x c)(*strict*)
  apply(simp (no_asm_use))
  apply(erule conjE)+
  apply(erule_tac
      x="w'"
      in allE)
  apply(erule impE)
   apply(rename_tac s w' x c)(*strict*)
   apply(force)
  apply(rename_tac s w' x c)(*strict*)
  apply(clarsimp)
  done

corollary controllable_language_implies_star_controllable_subset_FP: "
  L = prefix_closure L
  \<Longrightarrow> A = prefix_closure A
  \<Longrightarrow> controllable_language A \<Sigma>UC L
  \<Longrightarrow> A = star_controllable_subset A \<Sigma>UC L"
  apply(subgoal_tac "((append_language A (kleene_star \<Sigma>UC)) \<inter> L \<subseteq> A)")
   prefer 2
   apply(unfold controllable_language_def)
   apply(rule_tac
      Q="(((append_alphabet A \<Sigma>UC) \<inter> L) \<subseteq> A)"
      in HOL.iffD1)
    apply(rule sym)
    apply(fold star_controllable_language_def controllable_language_def)
    apply(rule star_controllable_language_vs_controllable_language)
    apply(force)
   apply(force)
  apply(unfold star_controllable_subset_def)
  apply(simp add: controllable_word_def prefix_def controllable_sublanguage_def)
  apply(rule equalityI)
   prefer 2
   apply(blast)
  apply(clarsimp)
  apply(rename_tac x w' xa)(*strict*)
  apply(rule_tac
      \<Sigma>UC="\<Sigma>UC"
      and L="L"
      in apply_controllability2)
     apply(rename_tac x w' xa)(*strict*)
     apply(simp add: star_controllable_language_def controllable_language_def)
    apply(rename_tac x w' xa)(*strict*)
    apply(simp add: prefix_closure_def prefix_def)
    apply(blast)
   apply(rename_tac x w' xa)(*strict*)
   apply(blast)
  apply(rename_tac x w' xa)(*strict*)
  apply(blast)
  done

corollary star_controllable_language_implies_controllable_subset_FP: "
  L = prefix_closure L
  \<Longrightarrow> A = prefix_closure A
  \<Longrightarrow> star_controllable_language A \<Sigma>UC L
  \<Longrightarrow> A = controllable_subset A \<Sigma>UC L"
  apply(subgoal_tac "((append_alphabet A \<Sigma>UC) \<inter> L \<subseteq> A)")
   prefer 2
   apply(unfold star_controllable_language_def)
   apply(rule_tac
      Q="(((append_language A (kleene_star \<Sigma>UC)) \<inter> L) \<subseteq> A)"
      in HOL.iffD1)
    apply(fold star_controllable_language_def controllable_language_def)
    apply(rule star_controllable_language_vs_controllable_language)
    apply(simp)+
  apply(unfold controllable_subset_def)
  apply(simp add: controllable_word_def prefix_def controllable_sublanguage_def)
  apply(rule equalityI)
   prefer 2
   apply(blast)
  apply(clarsimp)
  apply(rename_tac x w' xa)(*strict*)
  apply(rule_tac
      \<Sigma>UC="\<Sigma>UC"
      and L="L"
      in apply_controllability2)
     apply(rename_tac x w' xa)(*strict*)
     apply(simp add: star_controllable_language_def controllable_language_def alphabet_to_language_def)
    apply(rename_tac x w' xa)(*strict*)
    apply(simp add: prefix_closure_def prefix_def)
    apply(blast)
   apply(rename_tac x w' xa)(*strict*)
   apply(simp add: star_controllable_language_def controllable_language_def alphabet_to_language_def kleene_star_def)
   apply(clarsimp)
  apply(rename_tac x w' xa)(*strict*)
  apply(blast)
  done

corollary star_controllable_subset_FP_implies_star_controllable_language: "
  A = prefix_closure A
  \<Longrightarrow> A = star_controllable_subset A \<Sigma>UC L
  \<Longrightarrow> star_controllable_language A \<Sigma>UC L"
  apply(simp add: star_controllable_subset_def star_controllable_language_def)
  apply(clarsimp)
  apply(rename_tac x)(*strict*)
  apply(simp add: append_alphabet_def append_language_def alphabet_to_language_def)
  apply(clarsimp)
  apply(rename_tac a b)(*strict*)
  apply(subgoal_tac "\<forall>w'. w' \<sqsubseteq> a \<longrightarrow> (\<forall>x\<in> kleene_star \<Sigma>UC. w' @ x \<in> L \<longrightarrow> w' @ x \<in> A)")
   apply(rename_tac a b)(*strict*)
   apply(erule_tac
      x="a"
      in allE)
   apply(erule impE)
    apply(rename_tac a b)(*strict*)
    apply(rule prefix_reflexive)
   apply(rename_tac a b)(*strict*)
   apply(erule_tac
      x="b"
      in ballE)
    apply(rename_tac a b)(*strict*)
    apply(clarsimp)
   apply(rename_tac a b)(*strict*)
   apply(clarsimp)
  apply(rename_tac a b)(*strict*)
  apply(simp add: prefix_def prefix_closure_def controllable_sublanguage_def controllable_word_def kleene_star_def)
  apply(clarsimp)
  apply(rename_tac b w' c x)(*strict*)
  apply(subgoal_tac "w' \<in> A")
   apply(rename_tac b w' c x)(*strict*)
   prefer 2
   apply(force)
  apply(rename_tac b w' c x)(*strict*)
  apply(subgoal_tac "w' \<in> {w \<in> A. \<forall>wa. (\<exists>c. wa @ c = w) \<longrightarrow> (\<forall>u. set u \<subseteq> \<Sigma>UC \<longrightarrow> wa @ u \<in> L \<longrightarrow> wa @ u \<in> A)}")
   apply(rename_tac b w' c x)(*strict*)
   prefer 2
   apply(rule_tac
      t="{w \<in> A. \<forall>wa. (\<exists>c. wa @ c = w) \<longrightarrow> (\<forall>u. set u \<subseteq> \<Sigma>UC \<longrightarrow> wa @ u \<in> L \<longrightarrow> wa @ u \<in> A)}"
      and s="A"
      in ssubst)
    apply(rename_tac b w' c x)(*strict*)
    apply(force)
   apply(rename_tac b w' c x)(*strict*)
   apply(force)
  apply(rename_tac b w' c x)(*strict*)
  apply(simp (no_asm_use))
  apply(erule conjE)+
  apply(erule_tac
      x="w'"
      in allE)
  apply(erule impE)
   apply(rename_tac b w' c x)(*strict*)
   apply(force)
  apply(rename_tac b w' c x)(*strict*)
  apply(clarsimp)
  done

corollary controllable_subset_vs_uncontrollable_subset: "
  A = prefix_closure A
  \<Longrightarrow> A \<subseteq> kleene_star \<Sigma>
  \<Longrightarrow> controllable_subset A \<Sigma>UC L = A - uncontrollable_subset A \<Sigma>UC \<Sigma> L"
  apply(rule equalityI)
   apply(simp add: controllable_subset_def uncontrollable_subset_def append_alphabet_def append_language_def alphabet_to_language_def right_quotient_def prefix_def controllable_word_def)
   apply(simp add: controllable_word_def prefix_def controllable_sublanguage_def kleene_star_def prefix_closure_def)
   apply(clarsimp)
  apply(clarsimp)
  apply(rename_tac x)(*strict*)
  apply(simp add: controllable_subset_def uncontrollable_subset_def append_language_def alphabet_to_language_def prefix_def right_quotient_def controllable_word_def kleene_star_def controllable_sublanguage_def prefix_closure_def)
  apply(clarsimp)
  apply(rename_tac w' c xa)(*strict*)
  apply(case_tac "w'@[xa]\<in> A")
   apply(rename_tac w' c xa)(*strict*)
   apply(clarsimp)
  apply(rename_tac w' xa c)(*strict*)
  apply(erule_tac
      x="w'"
      in ballE)
   apply(rename_tac w' xa c)(*strict*)
   apply(clarsimp)
   apply(erule_tac
      x="xa"
      in allE)
   apply(erule impE)
    apply(rename_tac w' xa c)(*strict*)
    prefer 2
    apply(force)
   apply(rename_tac w' xa c)(*strict*)
   apply(force)
  apply(rename_tac w' xa c)(*strict*)
  apply(clarsimp)
  apply(erule_tac disjE)
   apply(rename_tac w' xa c)(*strict*)
   apply(erule_tac
      x="[c]"
      in allE)
   apply(clarsimp)
   apply(erule_tac
      x="c"
      in ballE)
    apply(rename_tac w' xa c)(*strict*)
    apply(clarsimp)
   apply(rename_tac w' xa c)(*strict*)
   apply(clarsimp)
  apply(rename_tac w' xa c)(*strict*)
  apply(subgoal_tac "w'\<in> A")
   apply(rename_tac w' xa c)(*strict*)
   apply(clarsimp)
  apply(rename_tac w' xa c)(*strict*)
  apply(rule prefixAlsoIn)
    apply(rename_tac w' xa c)(*strict*)
    apply(blast)
   apply(rename_tac w' xa c)(*strict*)
   apply(blast)
  apply(rename_tac w' xa c)(*strict*)
  apply(rule prefix_append)
  done

corollary star_controllable_subset_vs_star_uncontrollable_subset: "
  A = prefix_closure A
  \<Longrightarrow> A \<subseteq> kleene_star \<Sigma>
  \<Longrightarrow> star_controllable_subset A \<Sigma>UC L = A - star_uncontrollable_subset A \<Sigma>UC \<Sigma> L"
  apply(rule equalityI)
   apply(simp add: star_controllable_subset_def star_uncontrollable_subset_def append_alphabet_def append_language_def alphabet_to_language_def right_quotient_def prefix_def)
   apply(clarsimp)
   apply(rename_tac a b v)(*strict*)
   apply(simp add: controllable_word_def prefix_def controllable_sublanguage_def kleene_star_def prefix_closure_def)
  apply(clarsimp)
  apply(rename_tac x)(*strict*)
  apply(simp add: star_controllable_subset_def star_uncontrollable_subset_def append_alphabet_def append_language_def alphabet_to_language_def right_quotient_def prefix_def controllable_word_def controllable_sublanguage_def kleene_star_def prefix_closure_def)
  apply(rename_tac x)(*strict*)
  apply(clarsimp)
  apply(rename_tac w' xa c)(*strict*)
  apply(case_tac "w'@c\<in> A")
   apply(rename_tac w' xa c)(*strict*)
   apply(clarsimp)
  apply(rename_tac w' xa c)(*strict*)
  apply(erule_tac
      x="w'"
      in ballE)
   apply(rename_tac w' xa c)(*strict*)
   apply(clarsimp)
   apply(erule_tac
      x="xa"
      in allE)
   apply(rename_tac w' xa c)(*strict*)
   apply(force)
  apply(rename_tac w' xa c)(*strict*)
  apply(subgoal_tac "w'@c \<in> (kleene_star \<Sigma>)")
   apply(rename_tac w' xa c)(*strict*)
   apply(simp add: kleene_star_def)
   apply(rename_tac w' xa c)(*strict*)
   apply(force)
  apply(rename_tac w' xa c)(*strict*)
  apply(clarsimp)
  apply(erule_tac disjE)
   apply(rename_tac w' xa c)(*strict*)
   apply(clarsimp)
  apply(rename_tac w' xa c)(*strict*)
  apply(subgoal_tac "w'\<in> A")
   apply(rename_tac w' xa c)(*strict*)
   apply(clarsimp)
  apply(rename_tac w' xa c)(*strict*)
  apply(rule prefixAlsoIn)
    apply(rename_tac w' xa c)(*strict*)
    apply(blast)
   apply(rename_tac w' xa c)(*strict*)
   apply(blast)
  apply(rename_tac w' xa c)(*strict*)
  apply(rule prefix_append)
  done

definition supremal_controllable_language :: "'\<Sigma> list set \<Rightarrow> '\<Sigma> set \<Rightarrow> '\<Sigma> list set \<Rightarrow> '\<Sigma> list set" where
  "supremal_controllable_language A \<Sigma>UC L =
  \<Union>{A'. prefix_closure A' = A' \<and> A' \<subseteq> A \<and> controllable_language A' \<Sigma>UC L}"

definition supremal_star_controllable_language :: "'\<Sigma> list set \<Rightarrow> '\<Sigma> set \<Rightarrow> '\<Sigma> list set \<Rightarrow> '\<Sigma> list set" where
  "supremal_star_controllable_language A \<Sigma>UC L =
  \<Union>{A'. prefix_closure A' = A' \<and> A' \<subseteq> A \<and> star_controllable_language A' \<Sigma>UC L}"

corollary supremal_star_controllable_language_and_supremal_controllable_language_coincide: "
  A = prefix_closure A
  \<Longrightarrow> L = prefix_closure L
  \<Longrightarrow> supremal_star_controllable_language A \<Sigma>UC L = supremal_controllable_language A \<Sigma>UC L"
  apply(unfold supremal_star_controllable_language_def supremal_controllable_language_def)
  apply(rule antisym)
   apply(rule Sup_least)
   apply(rename_tac x)(*strict*)
   apply(rule Sup_upper)
   apply(clarsimp)
   apply (metis star_controllable_language_implies_controllable_language)
  apply(rule Sup_least)
  apply(rename_tac x)(*strict*)
  apply(rule Sup_upper)
  apply(clarsimp)
  apply (metis controllable_language_implies_star_controllable_language)
  done

lemma star_controllable_subset_idempotent: "
  A = prefix_closure A
  \<Longrightarrow> L = prefix_closure L
  \<Longrightarrow> star_controllable_subset A \<Sigma>UC L = star_controllable_subset (star_controllable_subset A \<Sigma>UC L) \<Sigma>UC L"
  apply(rule antisym)
   apply(simp add: star_controllable_subset_def controllable_sublanguage_def controllable_word_def alphabet_to_language_def prefix_closure_def prefix_def kleene_star_def)
   apply(clarsimp)
   apply(rename_tac w c u wa ca ua)(*strict*)
   apply(subgoal_tac "prefix wa w \<or> prefix w wa")
    apply(rename_tac w c u wa ca ua)(*strict*)
    prefer 2
    apply(rule mutual_prefix_prefix)
    apply(force)
   apply(rename_tac w c u wa ca ua)(*strict*)
   apply(erule disjE)
    apply(rename_tac w c u wa ca ua)(*strict*)
    apply(simp add: prefix_def)
    apply(clarsimp)
   apply(rename_tac w c u wa ca ua)(*strict*)
   apply(simp add: prefix_def)
   apply(clarsimp)
  apply(clarsimp)
  apply(rename_tac x)(*strict*)
  apply(simp add: star_controllable_subset_def controllable_sublanguage_def controllable_word_def alphabet_to_language_def prefix_closure_def prefix_def kleene_star_def)
  done

corollary star_controllable_subset_equal_to_supremal_star_controllable_language: "
  A = prefix_closure A
  \<Longrightarrow> L = prefix_closure L
  \<Longrightarrow> star_controllable_subset A \<Sigma>UC L = supremal_star_controllable_language A \<Sigma>UC L"
  apply(unfold supremal_star_controllable_language_def supremal_controllable_language_def)
  apply(rule antisym)
   apply(rule Sup_upper)
   apply(clarsimp)
   apply(rule conjI)
    apply(rule sym)
    apply(rule star_controllable_subset_prefix_closed)
    apply(force)
   apply(rule conjI)
    apply(simp add: star_controllable_subset_def)
    apply(force)
   apply(rule star_controllable_subset_FP_implies_star_controllable_language)
    apply(rule star_controllable_subset_prefix_closed)
    apply(force)
   apply(rule star_controllable_subset_idempotent)
    apply(force)
   apply(force)
  apply(rule Sup_least)
  apply(rename_tac x)(*strict*)
  apply(clarsimp)
  apply(rename_tac x xa)(*strict*)
  apply(simp add: star_controllable_language_def star_controllable_subset_def controllable_language_def controllable_subset_def append_alphabet_def append_language_def alphabet_to_language_def controllable_word_def controllable_sublanguage_def prefix_closure_def kleene_star_def prefix_def)
  apply(rule conjI)
   apply(rename_tac x xa)(*strict*)
   apply(force)
  apply(rename_tac x xa)(*strict*)
  apply(clarsimp)
  apply(rename_tac x w c u)(*strict*)
  apply(rule_tac
      A="x"
      in set_mp)
   apply(rename_tac x w c u)(*strict*)
   apply(force)
  apply(rename_tac x w c u)(*strict*)
  apply(rule_tac
      A="{w. \<exists>a\<in> x. \<exists>b. set b \<subseteq> \<Sigma>UC \<and> w = a @ b} \<inter> L"
      in set_mp)
   apply(rename_tac x w c u)(*strict*)
   apply(force)
  apply(rename_tac x w c u)(*strict*)
  apply(simp (no_asm))
  apply(rule conjI)
   apply(rename_tac x w c u)(*strict*)
   prefer 2
   apply(force)
  apply(rename_tac x w c u)(*strict*)
  apply(rule_tac
      x="w"
      in bexI)
   apply(rename_tac x w c u)(*strict*)
   apply(clarsimp)
  apply(rename_tac x w c u)(*strict*)
  apply(force)
  done

corollary supremal_star_controllable_language_smaller_than_controllable_subset: "
  A = prefix_closure A
  \<Longrightarrow> L = prefix_closure L
  \<Longrightarrow> supremal_star_controllable_language A \<Sigma>UC L \<subseteq> controllable_subset A \<Sigma>UC L"
  apply(unfold supremal_star_controllable_language_def supremal_controllable_language_def)
  apply(rule Sup_least)
  apply(rename_tac x)(*strict*)
  apply(clarsimp)
  apply(rename_tac x xa)(*strict*)
  apply(simp add: star_controllable_language_def star_controllable_subset_def controllable_language_def controllable_subset_def append_alphabet_def append_language_def alphabet_to_language_def controllable_word_def controllable_sublanguage_def prefix_closure_def kleene_star_def prefix_def)
  apply(rule conjI)
   apply(rename_tac x xa)(*strict*)
   apply(force)
  apply(rename_tac x xa)(*strict*)
  apply(clarsimp)
  apply(rename_tac x w c v)(*strict*)
  apply(rule_tac
      A="x"
      in set_mp)
   apply(rename_tac x w c v)(*strict*)
   apply(force)
  apply(rename_tac x w c v)(*strict*)
  apply(rule_tac
      A="{w. \<exists>a\<in> x. \<exists>b. set b \<subseteq> \<Sigma>UC \<and> w = a @ b} \<inter> L"
      in set_mp)
   apply(rename_tac x w c v)(*strict*)
   apply(force)
  apply(rename_tac x w c v)(*strict*)
  apply(clarsimp)
  apply(rule_tac
      x="w"
      in bexI)
   apply(rename_tac x w c v)(*strict*)
   apply(force)
  apply(rename_tac x w c v)(*strict*)
  apply(force)
  done

corollary supremal_star_controllable_language_unequal_to_controllable_subset: "
  A = {[],[u]}
  \<Longrightarrow> L = {[],[u],[u,u]}
  \<Longrightarrow> \<Sigma>UC = {u}
  \<Longrightarrow> controllable_subset A \<Sigma>UC L = {[]}
  \<and> supremal_controllable_language A \<Sigma>UC L = {}"
  apply(unfold supremal_star_controllable_language_def supremal_controllable_language_def)
  apply(rule conjI)
   apply(simp add: star_controllable_language_def star_controllable_subset_def controllable_language_def controllable_subset_def append_alphabet_def append_language_def alphabet_to_language_def controllable_word_def controllable_sublanguage_def prefix_closure_def kleene_star_def prefix_def)
   apply(rule antisym)
    apply(clarsimp)
    apply(erule_tac
      x="[u]"
      in allE)
    apply(clarsimp)
   apply(clarsimp)
  apply(rule antisym)
   prefer 2
   apply(force)
  apply(clarsimp)
  apply(rename_tac x)(*strict*)
  apply(simp add: star_controllable_language_def star_controllable_subset_def controllable_language_def controllable_subset_def append_alphabet_def append_language_def alphabet_to_language_def controllable_word_def controllable_sublanguage_def prefix_closure_def kleene_star_def prefix_def)
  apply(case_tac "x={}")
   apply(rename_tac x)(*strict*)
   apply(force)
  apply(rename_tac x)(*strict*)
  apply(subgoal_tac "\<exists>a. a \<in> x")
   apply(rename_tac x)(*strict*)
   prefer 2
   apply(force)
  apply(rename_tac x)(*strict*)
  apply(clarsimp)
  apply(rename_tac x a)(*strict*)
  apply(case_tac "a=[]")
   apply(rename_tac x a)(*strict*)
   apply(clarsimp)
   apply(rename_tac x)(*strict*)
   apply(force)
  apply(rename_tac x a)(*strict*)
  apply(subgoal_tac "a=[u]")
   apply(rename_tac x a)(*strict*)
   prefer 2
   apply(force)
  apply(rename_tac x a)(*strict*)
  apply(clarsimp)
  apply(rename_tac x)(*strict*)
  apply(subgoal_tac "[u,u]\<in> {w. \<exists>a\<in> x. w = a @ [u]}")
   apply(rename_tac x)(*strict*)
   apply(subgoal_tac "[u,u]\<in> x")
    apply(rename_tac x)(*strict*)
    apply(force)
   apply(rename_tac x)(*strict*)
   apply(force)
  apply(rename_tac x)(*strict*)
  apply(simp (no_asm))
  done

end


(*  Title:      Presburger-Automata/DFS.thy
    Author:     Toshiaki Nishihara and Yasuhiko Minamide
    Author:     Stefan Berghofer and Alex Krauss, TU Muenchen, 2008-2009
    Author:     Peter Gammie (data refinement futz), 2010
*)

(*<*)
theory DFS
imports Main
begin
(*>*)

subsection{* Generic DFS *}

text{*

\label{sec:dfs}

We use a generic DFS to construct the transitions and action function
of the implementation of the JKBP. This theory is largely due to
Stefan Berghofer and Alex Krauss
\citep{DBLP:conf/tphol/BerghoferR09}. All proofs are elided as the
fine details of how we explore the state space are inessential to the
synthesis algorithm.

The DFS itself is defined in the standard tail-recursive way:

*}

partial_function (tailrec) gen_dfs where
  "gen_dfs succs ins memb S wl = (case wl of
     [] \<Rightarrow> S
   | (x # xs) \<Rightarrow>
       if memb x S then gen_dfs succs ins memb S xs
       else gen_dfs succs ins memb (ins x S) (succs x @ xs))"
(*<*)
lemma gen_dfs_simps[code, simp]:
  "gen_dfs succs ins memb S [] = S"
  "gen_dfs succs ins memb S (x # xs) =
    (if memb x S then gen_dfs succs ins memb S xs
     else gen_dfs succs ins memb (ins x S) (succs x @ xs))"
  by (simp_all add: gen_dfs.simps)
(*>*)

text_raw{*
\begin{figure}
\begin{isabellebody}%
*}
locale DFS =
  fixes succs :: "'a \<Rightarrow> 'a list"
  and isNode :: "'a \<Rightarrow> bool"
  and invariant :: "'b \<Rightarrow> bool"
  and ins :: "'a \<Rightarrow> 'b \<Rightarrow> 'b"
  and memb :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
  and empt :: 'b
  and nodeAbs :: "'a \<Rightarrow> 'c"
  assumes ins_eq: "\<And>x y S. \<lbrakk> isNode x; isNode y; invariant S; \<not> memb y S \<rbrakk>
                       \<Longrightarrow> memb x (ins y S)
                       \<longleftrightarrow> ((nodeAbs x = nodeAbs y) \<or> memb x S)"
  and succs: "\<And>x y. \<lbrakk> isNode x; isNode y; nodeAbs x = nodeAbs y \<rbrakk>
                       \<Longrightarrow> nodeAbs ` set (succs x) = nodeAbs ` set (succs y)"
  and empt: "\<And>x. isNode x \<Longrightarrow> \<not> memb x empt"
  and succs_isNode: "\<And>x. isNode x \<Longrightarrow> list_all isNode (succs x)"
  and empt_invariant: "invariant empt"
  and ins_invariant: "\<And>x S. \<lbrakk> isNode x; invariant S; \<not> memb x S \<rbrakk>
                        \<Longrightarrow> invariant (ins x S)"
  and graph_finite: "finite (nodeAbs ` { x . isNode x})"
text_raw{*
\end{isabellebody}%
\begin{isamarkuptext}%
\caption{The @{text "DFS"} locale.}
\label{fig:kbps-theory-dfs-locale}
\end{isamarkuptext}%
\end{figure}
*}

text{*

The proofs are carried out in the locale of
Figure~\ref{fig:kbps-theory-dfs-locale}, which details our
requirements on the parameters for the DFS to behave as one would
expect. Intuitively we are traversing a graph defined by @{term
"succs"} from some initial work list @{term "wl"}, constructing an
object of type @{typ "'b"} as we go. The function @{term "ins"}
integrates the current node into this construction. The predicate
@{term "isNode"} is invariant over the set of states reachable from
the initial work list, and is respected by @{term "empt"} and @{term
"ins"}. We can also supply an invariant for the constructed object
(@{term "invariant"}). Inside the locale, @{term "dfs"} abbreviates
@{term "gen_dfs"} partially applied to the fixed parameters.

To support our data refinement
(\S\ref{sec:kbps-automata-synthesis-alg}) we also require that the
representation of nodes be adequate via the abstraction function
@{term "nodeAbs"}, which the transition relation @{term "succs"} and
visited predicate @{term "memb"} must respect. To ensure termination
it must be the case that there are only a finite number of states,
though there might be an infinity of representations.

We characterise the DFS traversal using the reflexive
transitive closure operator:

*}

definition (in DFS) reachable :: "'a set \<Rightarrow> 'a set" where
  "reachable xs \<equiv> {(x, y). y \<in> set (succs x)}\<^sup>* `` xs"
(*<*)

context DFS
begin

definition
  "succss xs \<equiv> \<Union>x\<in>xs. set (succs x)"

definition
  "set_of S \<equiv> {x. isNode x \<and> memb x S}"

abbreviation
  "dfs \<equiv> gen_dfs succs ins memb"

definition rel where
  "rel = inv_image finite_psubset (\<lambda>S. nodeAbs ` {n.  isNode n \<and> \<not> memb n S})"

(* Yuck, something to do with Skolems broke. *)
lemma nodeAbs_subset_grot:
  "\<lbrakk>invariant S; isNode x; list_all isNode xs; \<not>memb x S\<rbrakk>
     \<Longrightarrow> nodeAbs ` {n . isNode n \<and> \<not> memb n (ins x S)}
       \<subset> nodeAbs ` {n . isNode n \<and> \<not> memb n S}"
  apply rule
   apply (auto simp add: ins_eq cong: conj_cong)
  apply (subgoal_tac "nodeAbs x \<in> nodeAbs ` {n. isNode n \<and> \<not> memb n S}")
   apply (subgoal_tac "nodeAbs x \<notin> nodeAbs ` {n. isNode n \<and> nodeAbs n \<noteq> nodeAbs x \<and> \<not> memb n S}")
    apply blast
   apply rule
   apply (erule imageE) back
   apply auto[1]
  apply auto[1]
  done

lemma psubsetI2: "\<lbrakk> A \<subseteq> B; x \<in> A; x \<notin> B\<rbrakk> \<Longrightarrow> A \<subset> B"
  by (unfold less_le) blast

lemma dfs_induct[consumes 2, case_names base step]:
  assumes S: "invariant S"
  and xs: "list_all isNode xs"
  and I1: "\<And>S. invariant S \<Longrightarrow> P S []"
  and I2: "\<And>S x xs. invariant S \<Longrightarrow> isNode x \<Longrightarrow> list_all isNode xs \<Longrightarrow>
    (memb x S \<Longrightarrow> P S xs) \<Longrightarrow> (\<not> memb x S \<Longrightarrow> P (ins x S) (succs x @ xs)) \<Longrightarrow> P S (x # xs)"
  shows "P S xs" using I1 I2 S xs
  apply induction_schema
  apply atomize_elim
  apply (case_tac xs, simp+)
  apply atomize_elim
  apply (rule conjI)
  apply (rule ins_invariant, assumption+)
  apply (rule succs_isNode, assumption)
  apply (relation "rel <*lex*> measure length")
  apply (simp add: wf_lex_prod rel_def)
  apply simp
  apply simp
  apply (rule disjI1)
  apply (simp add: rel_def finite_psubset_def)
  apply (rule conjI)
  apply (erule (3) nodeAbs_subset_grot)
  apply (rule finite_subset[OF _ graph_finite])
  apply auto
  done

lemma visit_subset_dfs: "invariant S \<Longrightarrow> list_all isNode xs \<Longrightarrow>
  isNode y \<Longrightarrow> memb y S \<Longrightarrow> memb y (dfs S xs)"
  by (induct S xs rule: dfs_induct) (simp_all add: ins_eq)

lemma next_subset_dfs: "invariant S \<Longrightarrow> list_all isNode xs \<Longrightarrow>
  x \<in> set xs \<Longrightarrow> memb x (dfs S xs)"
proof (induct S xs rule: dfs_induct)
  case (step S y xs)
  then show ?case
    by (auto simp add: visit_subset_dfs ins_eq ins_invariant succs_isNode)
qed simp

lemma succss_closed_dfs':
  "invariant ys \<Longrightarrow> list_all isNode xs \<Longrightarrow>
   nodeAbs ` succss (set_of ys) \<subseteq> nodeAbs ` (set xs \<union> set_of ys) \<Longrightarrow> nodeAbs ` succss (set_of (dfs ys xs)) \<subseteq> nodeAbs ` set_of (dfs ys xs)"
proof(induct ys xs rule: dfs_induct)
  case (base S) thus ?case by simp
next
  case (step S x xs) thus ?case
    apply (auto simp add: succss_def set_of_def cong: conj_cong)
     apply (subgoal_tac "nodeAbs xa \<in> nodeAbs ` (\<Union>x\<in>{x. isNode x \<and> memb x (dfs S xs)}. set (succs x))")
      apply blast
     apply blast
    apply (subgoal_tac "nodeAbs ` (\<Union>x\<in>{xa. isNode xa \<and> memb xa (ins x S)}. set (succs x)) \<subseteq> nodeAbs ` (set (succs x) \<union> set xs \<union> {xa. isNode xa \<and> memb xa (ins x S)})")
     apply blast
    apply (auto simp add: ins_eq succss_def set_of_def cong: conj_cong)
    apply (subgoal_tac "\<exists>xc'. xc' \<in> set (succs x) \<and> nodeAbs xc' = nodeAbs xc")
     apply clarsimp
     apply (rule_tac x=xc' in image_eqI)
      apply simp
     apply simp
    apply (cut_tac x=xd and y=x in succs)
     apply simp_all
    apply (subgoal_tac "nodeAbs xc \<in> nodeAbs ` set (succs x)")
     apply auto[1]
    apply auto[1]
   apply (subgoal_tac "nodeAbs ` set (succs xd) \<subseteq> nodeAbs ` (\<Union>x\<in>{x. isNode x \<and> memb x S}. set (succs x))")
    defer
    apply auto[1]
   apply (subgoal_tac "nodeAbs xc \<in> nodeAbs ` set (succs xd)")
    defer
    apply auto[1]
   apply (subgoal_tac "nodeAbs xc \<in> insert (nodeAbs x) (nodeAbs ` (set xs \<union> {x. isNode x \<and> memb x S}))")
    defer
    apply (erule set_rev_mp)
    apply (erule subset_trans)
    apply blast
   apply auto
   done
qed

lemma succss_closed_dfs: "list_all isNode xs \<Longrightarrow>
  nodeAbs ` succss (set_of (dfs empt xs)) \<subseteq> nodeAbs ` set_of (dfs empt xs)"
  apply (rule succss_closed_dfs')
  apply (rule empt_invariant)
  apply assumption
  apply (simp add: succss_def)
  apply (rule subsetI)
  apply clarsimp
  unfolding set_of_def
  using empt
  apply clarsimp
  done

definition
  "succsr \<equiv> {(x, y). y \<in> set (succs x)}"

theorem succsr_isNode:
  assumes xy: "(x, y) \<in> succsr\<^sup>*"
  shows "isNode x \<Longrightarrow> isNode y" using xy
proof induct
  case (step y z)
  then have "isNode y" by simp
  then have "list_all isNode (succs y)"
    by (rule succs_isNode)
  with step show ?case
    by (simp add: succsr_def list_all_iff)
qed

lemma succss_closed:
  assumes inc: "nodeAbs ` succss X \<subseteq> nodeAbs ` X"
      and X: "X \<subseteq> { x . isNode x }"
  shows "nodeAbs ` reachable X = nodeAbs ` X"
proof
  show "nodeAbs ` X \<subseteq> nodeAbs ` reachable X"
    unfolding reachable_def by auto
next
  show "nodeAbs ` reachable X \<subseteq> nodeAbs ` X"
  proof(unfold reachable_def, auto)
    fix x y
    assume y: "y \<in> X"
    assume "(y, x) \<in> {(x, y). y \<in> set (succs x)}\<^sup>*"
    thus "nodeAbs x \<in> nodeAbs ` X" using y
    proof induct
      case base thus ?case by simp
    next
      case (step r s)
      from X step have "isNode r"
        using succsr_isNode[where x=y and y=r]
        unfolding succsr_def by fastforce
      with inc step show ?case
        apply clarsimp
        apply (subgoal_tac "isNode x")
         apply (cut_tac x=r and y=x in succs)
         apply auto
         apply (subgoal_tac "nodeAbs s \<in> nodeAbs ` set (succs x)")
         using X
         apply (auto simp: succss_def)
         done
     qed
   qed
qed

lemma dfs_isNode:
  assumes S: "invariant S"
      and xs: "list_all isNode xs"
  shows "set_of (dfs S xs) \<subseteq> {x . isNode x}"
  using assms
  by (induct S xs rule: dfs_induct) (auto simp: set_of_def)

lemma reachable_closed_dfs:
  assumes xs: "list_all isNode xs"
  shows "nodeAbs ` reachable (set xs) \<subseteq> nodeAbs ` set_of (dfs empt xs)"
proof -
  from xs have "reachable (set xs) \<subseteq> reachable (set_of (dfs empt xs))"
    apply (unfold reachable_def)
    apply (rule Image_mono)
    apply (auto simp add: set_of_def next_subset_dfs empt_invariant list_all_iff)
    done
  hence "nodeAbs ` reachable (set xs) \<subseteq> nodeAbs ` reachable (set_of (dfs empt xs))"
    by auto
  also from succss_closed_dfs[OF xs] have "\<dots> = nodeAbs ` set_of (dfs empt xs)"
    apply (rule succss_closed)
    apply (rule dfs_isNode[OF empt_invariant xs])
    done
  finally show ?thesis .
qed

lemma reachable_succs: "reachable (set (succs x)) \<subseteq> reachable {x}"
  by (auto simp add: reachable_def intro: converse_rtrancl_into_rtrancl)

lemma dfs_subset_reachable_visit_nodes:
  "invariant ys \<Longrightarrow> list_all isNode xs \<Longrightarrow>
   nodeAbs ` set_of (dfs ys xs) \<subseteq> nodeAbs ` (reachable (set xs) \<union> set_of ys)"
proof(induct ys xs rule: dfs_induct)
  case (step S x xs)
  show ?case
  proof (cases "memb x S")
    case True
    with step show ?thesis
      apply (auto simp add: reachable_def)
      apply (drule subsetD)
       apply blast
      apply blast
      done
  next
    case False
    have "reachable (set (succs x)) \<subseteq> reachable {x}"
      by (rule reachable_succs)
    then have "reachable (set (succs x @ xs)) \<subseteq> reachable (set (x # xs))"
      by (auto simp add: reachable_def)
    then show ?thesis using step
      apply (auto simp add: reachable_def set_of_def cong: conj_cong)
       apply (subgoal_tac "nodeAbs xa \<in> nodeAbs `
            ({(x, y). y \<in> set (succs x)}\<^sup>* `` set xs \<union>
             {x. isNode x \<and> memb x S})")
        apply auto[1]
       apply auto[1]
      apply (subgoal_tac "nodeAbs xa \<in> nodeAbs `
            ({(x, y). y \<in> set (succs x)}\<^sup>* `` (set (succs x) \<union> set xs) \<union>
             {xa. isNode xa \<and> memb xa (ins x S)})")
       defer
       apply auto[1]
      apply auto[1]
       apply (rule_tac x=xb in image_eqI)
        apply auto[1]
       apply auto[1]
      apply (auto iff: ins_eq)
      done
(* by (auto simp add: reachable_def ins_eq set_of_def cong: conj_cong) *)
  qed
qed (simp add: reachable_def)

theorem dfs_imp_reachable:
  assumes y: "isNode y"
      and xs: "list_all isNode xs"
      and m: "memb y (dfs empt xs)"
  shows "\<exists>y'. nodeAbs y' = nodeAbs y \<and> y' \<in> reachable (set xs)"
proof -
  from m dfs_subset_reachable_visit_nodes [OF empt_invariant xs] y
  obtain y'
    where "nodeAbs y' = nodeAbs y"
      and "y' \<in> reachable (set xs)"
    by (auto simp add: empt set_of_def)
  thus ?thesis by blast
qed

(*>*)
text{*

We make use of two results about the traversal. Firstly, that some
representation of each reachable node has been incorporated into the
final construction:

*}

theorem (in DFS) reachable_imp_dfs:
  assumes y: "isNode y"
      and xs: "list_all isNode xs"
      and m: "y \<in> reachable (set xs)"
  shows "\<exists>y'. nodeAbs y' = nodeAbs y \<and> memb y' (dfs empt xs)"
(*<*)
  using y m reachable_closed_dfs[OF xs]
  apply (auto simp add: set_of_def)
  apply (drule subsetD[where c="nodeAbs y"])
   apply simp
  apply auto
  done

theorem dfs_invariant' [consumes 2, case_names base step]:
  assumes S: "invariant S"
  and xs: "list_all isNode xs"
  and H: "I S"
  and I: "\<And>S x. \<not> memb x S \<Longrightarrow> isNode x \<Longrightarrow> invariant S \<Longrightarrow> I S \<Longrightarrow> I (ins x S)"
  shows "I (dfs S xs)"
proof -
  from S xs H
  have "I (dfs S xs) \<and> invariant (dfs S xs)"
  proof (induct S xs rule: dfs_induct)
    case (step S x xs)
    show ?case
    proof (cases "memb x S")
      case False
      then show ?thesis
        apply simp
        apply (rule step)
        apply assumption
        apply (rule I)
        apply assumption
        apply (rule step)+
        done
    qed (simp add: step)
  qed simp
  then show ?thesis ..
qed

end (* context DFS *)
(*>*)

text{*

Secondly, that if an invariant holds on the initial object then it
holds on the final one:

*}

theorem (in DFS) dfs_invariant:
  assumes "invariant S"
  assumes "list_all isNode xs"
  shows "invariant (dfs S xs)"
(*<*)
  using assms
  by (induct S xs rule: dfs_induct) auto
(*>*)

text{*

\FloatBarrier

*}

(*<*)
end
(*>*)


theory ETCS_Truth
  imports ETCS_Equalizer
begin

section  \<open>Axiom 5: Truth-Value Object\<close>

axiomatization
  true_func :: "cfunc" ("\<t>") and
  false_func  :: "cfunc" ("\<f>") and
  truth_value_set :: "cset" ("\<Omega>")
where
  true_func_type[type_rule]: "\<t> \<in>\<^sub>c \<Omega>" and
  false_func_type[type_rule]: "\<f> \<in>\<^sub>c \<Omega>" and
  true_false_distinct: "\<t> \<noteq> \<f>" and
  true_false_only_truth_values: "x \<in>\<^sub>c \<Omega> \<Longrightarrow> x = \<f> \<or> x = \<t>" and
  characteristic_function_exists:
    "m : B \<rightarrow> X \<Longrightarrow> monomorphism m \<Longrightarrow> \<exists>! \<chi>. is_pullback B one X \<Omega> (\<beta>\<^bsub>B\<^esub>) \<t> m \<chi>"

definition characteristic_func :: "cfunc \<Rightarrow> cfunc" where
  "characteristic_func m =
    (THE \<chi>. monomorphism m \<longrightarrow> is_pullback (domain m) one (codomain m) \<Omega> (\<beta>\<^bsub>domain m\<^esub>) \<t> m \<chi>)"

lemma characteristic_func_is_pullback:
  assumes "m : B \<rightarrow> X" "monomorphism m"
  shows "is_pullback B one X \<Omega> (\<beta>\<^bsub>B\<^esub>) \<t> m (characteristic_func m)"
proof -
  obtain \<chi> where chi_is_pullback: "is_pullback B one X \<Omega> (\<beta>\<^bsub>B\<^esub>) \<t> m \<chi>"
    using assms characteristic_function_exists by blast

  have "monomorphism m \<longrightarrow> is_pullback (domain m) one (codomain m) \<Omega> (\<beta>\<^bsub>domain m\<^esub>) \<t> m (characteristic_func m)"
  proof (unfold characteristic_func_def, rule theI', rule_tac a=\<chi> in ex1I, clarify)
    show "is_pullback (domain m) one (codomain m) \<Omega> (\<beta>\<^bsub>domain m\<^esub>) \<t> m \<chi>"
      using assms(1) cfunc_type_def chi_is_pullback by auto
    show "\<And>x. monomorphism m \<longrightarrow> is_pullback (domain m) one (codomain m) \<Omega> (\<beta>\<^bsub>domain m\<^esub>) \<t> m x \<Longrightarrow> x = \<chi>"
      using assms(1) assms(2) cfunc_type_def characteristic_function_exists chi_is_pullback by fastforce
  qed
  then show "is_pullback B one X \<Omega> (\<beta>\<^bsub>B\<^esub>) \<t> m (characteristic_func m)"
    using assms cfunc_type_def by auto
qed

lemma characteristic_func_type[type_rule]:
  assumes "m : B \<rightarrow> X" "monomorphism m"
  shows "characteristic_func m : X \<rightarrow> \<Omega>"
proof -
  have "is_pullback B one X \<Omega> (\<beta>\<^bsub>B\<^esub>) \<t> m (characteristic_func m)"
    using assms by (rule characteristic_func_is_pullback)
  then show "characteristic_func m : X \<rightarrow> \<Omega>"
    unfolding is_pullback_def square_commutes_def by auto
qed

lemma characteristic_func_eq:
  assumes "m : B \<rightarrow> X" "monomorphism m"
  shows "characteristic_func m \<circ>\<^sub>c m = \<t> \<circ>\<^sub>c \<beta>\<^bsub>B\<^esub>"
  using assms characteristic_func_is_pullback unfolding is_pullback_def square_commutes_def by auto

lemma characteristic_func_true_relative_member:
  assumes "m : B \<rightarrow> X" "monomorphism m" "x \<in>\<^sub>c X"
  assumes characteristic_func_true: "characteristic_func m \<circ>\<^sub>c x = \<t>"
  shows "x \<in>\<^bsub>X\<^esub> (B,m)"
proof (insert assms, unfold relative_member_def2 factors_through_def, auto)
  thm is_pullback_def

  have "is_pullback B one X \<Omega> (\<beta>\<^bsub>B\<^esub>) \<t> m (characteristic_func m)"
    by (simp add: assms characteristic_func_is_pullback)
  then have "\<exists>j. j : one \<rightarrow> B \<and> \<beta>\<^bsub>B\<^esub> \<circ>\<^sub>c j = id one \<and> m \<circ>\<^sub>c j = x"
    unfolding is_pullback_def using assms by (metis id_right_unit2 id_type true_func_type)
  then show "\<exists>j. j : domain x \<rightarrow> domain m \<and> m \<circ>\<^sub>c j = x"
    using assms(1) assms(3) cfunc_type_def by auto
qed

lemma characteristic_func_false_not_relative_member:
  assumes "m : B \<rightarrow> X" "monomorphism m" "x \<in>\<^sub>c X"
  assumes characteristic_func_true: "characteristic_func m \<circ>\<^sub>c x = \<f>"
  shows "\<not> (x \<in>\<^bsub>X\<^esub> (B,m))"
proof (insert assms, unfold relative_member_def2 factors_through_def, auto)
  fix h
  assume x_def: "x = m \<circ>\<^sub>c h"

  assume "h : domain (m \<circ>\<^sub>c h) \<rightarrow> domain m"
  then have h_type: "h \<in>\<^sub>c B"
    using assms(1) assms(3) cfunc_type_def x_def by auto

  have "is_pullback B one X \<Omega> (\<beta>\<^bsub>B\<^esub>) \<t> m (characteristic_func m)"
    by (simp add: assms characteristic_func_is_pullback)
  then have char_m_true: "characteristic_func m \<circ>\<^sub>c m = \<t> \<circ>\<^sub>c \<beta>\<^bsub>B\<^esub>"
    unfolding is_pullback_def square_commutes_def by auto

  then have "characteristic_func m \<circ>\<^sub>c m \<circ>\<^sub>c h = \<f>"
    using x_def characteristic_func_true by auto
  then have "(characteristic_func m \<circ>\<^sub>c m) \<circ>\<^sub>c h = \<f>"
    using assms h_type by (typecheck_cfuncs, simp add: comp_associative2)
  then have "(\<t> \<circ>\<^sub>c \<beta>\<^bsub>B\<^esub>) \<circ>\<^sub>c h = \<f>"
    using char_m_true by auto
  then have "\<t> = \<f>"
    by (metis cfunc_type_def comp_associative h_type id_right_unit2 id_type one_unique_element
        terminal_func_comp terminal_func_type true_func_type)
  then show "False"
    using true_false_distinct by auto
qed

definition eq_pred :: "cset \<Rightarrow> cfunc" where
  "eq_pred X = (THE \<chi>. is_pullback X one (X \<times>\<^sub>c X) \<Omega> (\<beta>\<^bsub>X\<^esub>) \<t> (diagonal X) \<chi>)"

lemma eq_pred_pullback: "is_pullback X one (X \<times>\<^sub>c X) \<Omega> (\<beta>\<^bsub>X\<^esub>) \<t> (diagonal X) (eq_pred X)"
  unfolding eq_pred_def
  by (rule the1I2, simp_all add: characteristic_function_exists diag_mono diagonal_type)

lemma eq_pred_type[type_rule]:
  "eq_pred X : X \<times>\<^sub>c X \<rightarrow> \<Omega>"
  using eq_pred_pullback unfolding is_pullback_def square_commutes_def by auto

lemma eq_pred_square: "eq_pred X \<circ>\<^sub>c diagonal X = \<t> \<circ>\<^sub>c \<beta>\<^bsub>X\<^esub>"
  using eq_pred_pullback unfolding is_pullback_def square_commutes_def by auto

lemma eq_pred_iff_eq:
  assumes "x : one \<rightarrow> X" "y : one \<rightarrow> X"
  shows "(x = y) = (eq_pred X \<circ>\<^sub>c \<langle>x, y\<rangle> = \<t>)"
proof auto
  assume x_eq_y: "x = y"

  have "(eq_pred X \<circ>\<^sub>c \<langle>id\<^sub>c X,id\<^sub>c X\<rangle>) \<circ>\<^sub>c y = (\<t> \<circ>\<^sub>c \<beta>\<^bsub>X\<^esub>) \<circ>\<^sub>c y"
    using eq_pred_square unfolding diagonal_def by auto
  then have "eq_pred X \<circ>\<^sub>c \<langle>y, y\<rangle> = (\<t> \<circ>\<^sub>c \<beta>\<^bsub>X\<^esub>) \<circ>\<^sub>c y"
    using assms diagonal_type id_type
    by (typecheck_cfuncs, smt cfunc_prod_comp comp_associative2 diagonal_def id_left_unit2)
  then show "eq_pred X \<circ>\<^sub>c \<langle>y, y\<rangle> = \<t>"
    using assms id_type
    by (typecheck_cfuncs, smt comp_associative2 terminal_func_comp terminal_func_type terminal_func_unique id_right_unit2)
next
  assume "eq_pred X \<circ>\<^sub>c \<langle>x,y\<rangle> = \<t>"
  then have "eq_pred X \<circ>\<^sub>c \<langle>x,y\<rangle> = \<t> \<circ>\<^sub>c id one"
    using id_right_unit2 true_func_type by auto
  then obtain j  where j_type: "j : one \<rightarrow> X" and "diagonal X \<circ>\<^sub>c j = \<langle>x,y\<rangle>"
    using eq_pred_pullback assms unfolding is_pullback_def by (metis cfunc_prod_type id_type)
  then have "\<langle>j,j\<rangle> = \<langle>x,y\<rangle>"
    using diag_on_elements by auto
  then show "x = y"
    using assms element_pair_eq j_type by auto
qed

lemma eq_pred_iff_eq_conv:
  assumes "x : one \<rightarrow> X" "y : one \<rightarrow> X"
  shows "(x \<noteq> y) = (eq_pred X \<circ>\<^sub>c \<langle>x, y\<rangle> = \<f>)"
proof(auto)
  assume "x \<noteq> y"
  show "eq_pred X \<circ>\<^sub>c \<langle>x,y\<rangle> = \<f>"
    using assms \<open>x \<noteq> y\<close> eq_pred_iff_eq true_false_only_truth_values by (typecheck_cfuncs, blast)
next
  show "eq_pred X \<circ>\<^sub>c \<langle>y,y\<rangle> = \<f> \<Longrightarrow> x = y \<Longrightarrow> False"
    by (metis assms(1) eq_pred_iff_eq true_false_distinct)
qed

lemma eq_pred_iff_eq_conv2:
  assumes "x : one \<rightarrow> X" "y : one \<rightarrow> X"
  shows "(x \<noteq> y) = (eq_pred X \<circ>\<^sub>c \<langle>x, y\<rangle> \<noteq> \<t>)"
  using assms(1) assms(2) eq_pred_iff_eq by presburger

lemma eq_pred_of_monomorphism:
  assumes m_type[type_rule]: "m : X \<rightarrow> Y" and m_mono: "monomorphism m"
  shows "eq_pred Y \<circ>\<^sub>c (m \<times>\<^sub>f m) = eq_pred X"
proof (rule one_separator[where X="X \<times>\<^sub>c X", where Y=\<Omega>])
  show "eq_pred Y \<circ>\<^sub>c m \<times>\<^sub>f m : X \<times>\<^sub>c X \<rightarrow> \<Omega>"
    by typecheck_cfuncs
  show "eq_pred X : X \<times>\<^sub>c X \<rightarrow> \<Omega>"
    by typecheck_cfuncs
next
  fix x
  assume "x \<in>\<^sub>c X \<times>\<^sub>c X"
  then obtain x1 x2 where x_def: "x = \<langle>x1, x2\<rangle>" and x1_type[type_rule]: "x1 \<in>\<^sub>c X" and x2_type[type_rule]: "x2 \<in>\<^sub>c X"
    using cart_prod_decomp by blast
  show "(eq_pred Y \<circ>\<^sub>c m \<times>\<^sub>f m) \<circ>\<^sub>c x = eq_pred X \<circ>\<^sub>c x"
  proof (unfold x_def, cases "(eq_pred Y \<circ>\<^sub>c m \<times>\<^sub>f m) \<circ>\<^sub>c \<langle>x1,x2\<rangle> = \<t>")
    assume LHS: "(eq_pred Y \<circ>\<^sub>c m \<times>\<^sub>f m) \<circ>\<^sub>c \<langle>x1,x2\<rangle> = \<t>"
    then have "eq_pred Y \<circ>\<^sub>c (m \<times>\<^sub>f m) \<circ>\<^sub>c \<langle>x1,x2\<rangle> = \<t>"
      by (typecheck_cfuncs, simp add: comp_associative2)
    then have "eq_pred Y \<circ>\<^sub>c \<langle>m \<circ>\<^sub>c x1, m \<circ>\<^sub>c x2\<rangle> = \<t>"
      by (typecheck_cfuncs, auto simp add: cfunc_cross_prod_comp_cfunc_prod)
    then have "m \<circ>\<^sub>c x1 = m \<circ>\<^sub>c x2"
      by (typecheck_cfuncs_prems, simp add: eq_pred_iff_eq)
    then have "x1 = x2"
      using m_mono m_type monomorphism_def3 x1_type x2_type by blast
    then have RHS: "eq_pred X \<circ>\<^sub>c \<langle>x1,x2\<rangle> = \<t>"
      by (typecheck_cfuncs, insert eq_pred_iff_eq, blast)

    show "(eq_pred Y \<circ>\<^sub>c m \<times>\<^sub>f m) \<circ>\<^sub>c \<langle>x1,x2\<rangle> = eq_pred X \<circ>\<^sub>c \<langle>x1,x2\<rangle>"
      using LHS RHS by auto
  next
    assume "(eq_pred Y \<circ>\<^sub>c m \<times>\<^sub>f m) \<circ>\<^sub>c \<langle>x1,x2\<rangle> \<noteq> \<t>"
    then have LHS: "(eq_pred Y \<circ>\<^sub>c m \<times>\<^sub>f m) \<circ>\<^sub>c \<langle>x1,x2\<rangle> = \<f>"
      by (typecheck_cfuncs, meson true_false_only_truth_values)
    then have "eq_pred Y \<circ>\<^sub>c (m \<times>\<^sub>f m) \<circ>\<^sub>c \<langle>x1,x2\<rangle> = \<f>"
      by (typecheck_cfuncs, simp add: comp_associative2)
    then have "eq_pred Y \<circ>\<^sub>c \<langle>m \<circ>\<^sub>c x1, m \<circ>\<^sub>c x2\<rangle> = \<f>"
      by (typecheck_cfuncs, auto simp add: cfunc_cross_prod_comp_cfunc_prod)
    then have "m \<circ>\<^sub>c x1 \<noteq> m \<circ>\<^sub>c x2"
      using eq_pred_iff_eq_conv by (typecheck_cfuncs_prems, blast)
    then have "x1 \<noteq> x2"
      by auto
    then have RHS: "eq_pred X \<circ>\<^sub>c \<langle>x1,x2\<rangle> = \<f>"
      using eq_pred_iff_eq_conv by (typecheck_cfuncs, blast)

    show "(eq_pred Y \<circ>\<^sub>c m \<times>\<^sub>f m) \<circ>\<^sub>c \<langle>x1,x2\<rangle> = eq_pred X \<circ>\<^sub>c \<langle>x1,x2\<rangle>"
      using LHS RHS by auto
  qed
qed

(* Proposition 2.2.1: see under Axiom 8 *)

(* Proposition 2.2.2 *)
lemma "card {x. x \<in>\<^sub>c \<Omega> \<times>\<^sub>c \<Omega>} = 4"
proof -
  have "{x. x \<in>\<^sub>c \<Omega> \<times>\<^sub>c \<Omega>} = {\<langle>\<t>,\<t>\<rangle>, \<langle>\<t>,\<f>\<rangle>, \<langle>\<f>,\<t>\<rangle>, \<langle>\<f>,\<f>\<rangle>}"
    apply (auto simp add: cfunc_prod_type true_func_type false_func_type)
    by (smt cfunc_prod_unique comp_type left_cart_proj_type right_cart_proj_type true_false_only_truth_values)
  then show "card {x. x \<in>\<^sub>c \<Omega> \<times>\<^sub>c \<Omega>} = 4"
    using element_pair_eq false_func_type true_false_distinct true_func_type by auto
qed

(* Exercise 2.2.3 *)
lemma regmono_is_mono: "regular_monomorphism(m) \<Longrightarrow> monomorphism(m)"
  using equalizer_is_monomorphism regular_monomorphism_def by blast

(* Proposition 2.2.4 *)
lemma mono_is_regmono:
  shows "monomorphism(m) \<Longrightarrow> regular_monomorphism(m)"
  unfolding regular_monomorphism_def
proof -
  assume m_mono: "monomorphism(m)"
  then obtain \<chi> where chi_pullback: "is_pullback (domain(m)) one  (codomain(m)) \<Omega> (\<beta>\<^bsub>domain(m)\<^esub>) \<t> m \<chi> "
    using cfunc_type_def characteristic_function_exists by blast

  have pullback: "\<And>k h Z. k : Z \<rightarrow> one \<and> h : Z \<rightarrow> codomain m \<and> \<t> \<circ>\<^sub>c k = \<chi> \<circ>\<^sub>c h \<longrightarrow>
     (\<exists>!j. j : Z \<rightarrow> domain m \<and> \<beta>\<^bsub>domain m\<^esub> \<circ>\<^sub>c j = k \<and> m \<circ>\<^sub>c j = h)"
    using chi_pullback unfolding is_pullback_def by auto

  have "equalizer (domain(m)) m (\<t> \<circ>\<^sub>c \<beta>\<^bsub>codomain(m)\<^esub>) \<chi>"
    unfolding equalizer_def
  proof (rule_tac x="codomain(m)" in exI, rule_tac x="\<Omega>" in exI, auto)
    show tbeta_type: "\<t> \<circ>\<^sub>c \<beta>\<^bsub>codomain(m)\<^esub> : codomain(m) \<rightarrow>  \<Omega>"
      using comp_type terminal_func_type true_func_type by blast
    show chi_type: "\<chi> : codomain(m) \<rightarrow>  \<Omega>"
      using chi_pullback is_pullback_def square_commutes_def by auto
    show m_type: "m : domain m \<rightarrow> codomain m"
      by (simp add: cfunc_type_def)

    have comm: "\<t> \<circ>\<^sub>c \<beta>\<^bsub>domain m\<^esub> = \<chi> \<circ>\<^sub>c m"
      using chi_pullback unfolding is_pullback_def square_commutes_def by auto
    then have "\<beta>\<^bsub>domain m\<^esub> = \<beta>\<^bsub>codomain m\<^esub> \<circ>\<^sub>c m"
      by (simp add: cfunc_type_def terminal_func_comp)
    then show "(\<t> \<circ>\<^sub>c \<beta>\<^bsub>codomain m\<^esub>) \<circ>\<^sub>c m = \<chi> \<circ>\<^sub>c m"
      using cfunc_type_def comm comp_associative terminal_func_type true_func_type by auto
  next
    fix h F
    assume  "h : F \<rightarrow> codomain m" "(\<t> \<circ>\<^sub>c \<beta>\<^bsub>codomain m\<^esub>) \<circ>\<^sub>c h = \<chi> \<circ>\<^sub>c h"
    then show "\<exists>k. k : F \<rightarrow> domain m \<and> m \<circ>\<^sub>c k = h"
      by (metis cfunc_type_def comp_associative pullback terminal_func_comp terminal_func_type true_func_type)
  next
    fix F k y
    assume "k : F \<rightarrow> domain m" "y : F \<rightarrow> domain m"
    then show "m \<circ>\<^sub>c y = m \<circ>\<^sub>c k \<Longrightarrow> k = y"
      using m_mono unfolding monomorphism_def by (simp add: cfunc_type_def)
  qed
  then show "\<exists>g h. domain g = codomain m \<and> domain h = codomain m \<and> equalizer (domain m) m g h"
    by (metis cfunc_type_def equalizer_def)
qed

(*Proposition 2.2.5*)
lemma epi_mon_is_iso:
  assumes "epimorphism(f)" "monomorphism(f)"
  shows "isomorphism(f)"
  using assms epi_regmon_is_iso mono_is_regmono by auto

(* Definition 2.2.6 *)
definition fiber :: "cfunc \<Rightarrow> cfunc \<Rightarrow> cset" ("_\<^sup>-\<^sup>1{_}" [100,100]100) where
  "f\<^sup>-\<^sup>1{y} = (f\<^sup>-\<^sup>1[one]\<^bsub>y\<^esub>)"

definition fiber_morphism :: "cfunc \<Rightarrow> cfunc \<Rightarrow> cfunc" where
  "fiber_morphism f y = left_cart_proj (domain f) one \<circ>\<^sub>c inverse_image_mapping f one y"

lemma fiber_morphism_type[type_rule]:
  assumes "f : X \<rightarrow> Y" "y \<in>\<^sub>c Y"
  shows "fiber_morphism f y : f\<^sup>-\<^sup>1{y} \<rightarrow> X"
  unfolding fiber_def fiber_morphism_def
  using assms cfunc_type_def element_monomorphism inverse_image_subobject subobject_of_def2
  by (typecheck_cfuncs, auto)

lemma fiber_subset:
  assumes "f : X \<rightarrow> Y" "y \<in>\<^sub>c Y"
  shows "(f\<^sup>-\<^sup>1{y}, fiber_morphism f y) \<subseteq>\<^sub>c X"
  unfolding fiber_def fiber_morphism_def
  using assms cfunc_type_def element_monomorphism inverse_image_subobject inverse_image_subobject_mapping_def
  by (typecheck_cfuncs, auto)

lemma fiber_morphism_monomorphism:
  assumes "f : X \<rightarrow> Y" "y \<in>\<^sub>c Y"
  shows "monomorphism (fiber_morphism f y)"
  using assms cfunc_type_def element_monomorphism fiber_morphism_def inverse_image_monomorphism by auto

lemma fiber_morphism_eq:
  assumes "f : X \<rightarrow> Y" "y \<in>\<^sub>c Y"
  shows "f \<circ>\<^sub>c fiber_morphism f y  = y \<circ>\<^sub>c \<beta>\<^bsub>f\<^sup>-\<^sup>1{y}\<^esub>"
proof -
  have "f \<circ>\<^sub>c fiber_morphism f y = f \<circ>\<^sub>c left_cart_proj (domain f) one \<circ>\<^sub>c inverse_image_mapping f one y"
    unfolding fiber_morphism_def by auto
  also have "... = y \<circ>\<^sub>c right_cart_proj X one \<circ>\<^sub>c inverse_image_mapping f one y"
    using assms cfunc_type_def element_monomorphism inverse_image_mapping_eq by auto
  also have "... = y \<circ>\<^sub>c \<beta>\<^bsub>f\<^sup>-\<^sup>1[one]\<^bsub>y\<^esub>\<^esub>"
    using assms by (typecheck_cfuncs, metis element_monomorphism terminal_func_unique)
  also have "... = y \<circ>\<^sub>c \<beta>\<^bsub>f\<^sup>-\<^sup>1{y}\<^esub>"
    unfolding fiber_def by auto
  then show ?thesis
    using calculation by auto
qed

(* Proposition 2.2.7 *)
lemma not_surjective_has_some_empty_preimage:
  assumes p_type[type_rule]: "p: X \<rightarrow> Y" and p_not_surj: "\<not>surjective(p)"
  shows "\<exists> y. (y\<in>\<^sub>c Y \<and>  \<not>nonempty(p\<^sup>-\<^sup>1{y}))"
proof -
  have nonempty: "nonempty(Y)"
    using assms(1) assms(2) cfunc_type_def nonempty_def surjective_def by auto
  obtain y0 where y0_type[type_rule]: "y0 \<in>\<^sub>c Y" "\<forall> x. x \<in>\<^sub>c X \<longrightarrow> p\<circ>\<^sub>c x \<noteq> y0"
    using assms(1) assms(2) cfunc_type_def surjective_def by auto
  (* then have "is_pullback (p\<^sup>-\<^sup>1{y0}) one X Y (\<beta>\<^bsub>p\<^sup>-\<^sup>1{y0}\<^esub>) (y0) m p" *)
  have "\<not>nonempty(p\<^sup>-\<^sup>1{y0})"
  proof (rule ccontr,auto)
    assume a1: "nonempty(p\<^sup>-\<^sup>1{y0})"
    obtain z where z_type[type_rule]: "z \<in>\<^sub>c p\<^sup>-\<^sup>1{y0}"
      using a1 nonempty_def by blast
    have fiber_z_type: "fiber_morphism p y0 \<circ>\<^sub>c z \<in>\<^sub>c X"
      using assms(1) comp_type fiber_morphism_type y0_type z_type by auto
    have contradiction: "p \<circ>\<^sub>c (fiber_morphism p y0 \<circ>\<^sub>c z) = y0"
      by (typecheck_cfuncs, smt (z3) comp_associative2 fiber_morphism_eq id_right_unit2 id_type one_unique_element terminal_func_comp terminal_func_type)
    have "p \<circ>\<^sub>c (fiber_morphism p y0 \<circ>\<^sub>c z) \<noteq> y0"
      by (simp add: fiber_z_type y0_type)
    then show False
      using contradiction by blast
  qed
  then show ?thesis
    using y0_type by blast
qed

lemma char_of_singleton1:
    assumes "x \<in>\<^sub>c X"
    shows  "eq_pred X \<circ>\<^sub>c \<langle>x \<circ>\<^sub>c \<beta>\<^bsub>X\<^esub>, id X\<rangle> \<circ>\<^sub>c x = \<t>"
    using assms cart_prod_extract_right eq_pred_iff_eq by fastforce

lemma char_of_singleton2:
    assumes "x \<in>\<^sub>c X"  "y \<in>\<^sub>c X" "x \<noteq> y"
    shows  "eq_pred X \<circ>\<^sub>c \<langle>x \<circ>\<^sub>c \<beta>\<^bsub>X\<^esub>, id X\<rangle> \<circ>\<^sub>c y = \<f>"
    using assms cart_prod_extract_right eq_pred_iff_eq true_false_only_truth_values  by (typecheck_cfuncs, fastforce)

(* Proposition 2.2.8 *)
lemma epi_is_surj:
  assumes "p: X \<rightarrow> Y" "epimorphism(p)"
  shows "surjective(p)"
  unfolding surjective_def
proof(rule ccontr)
  assume a1: "\<not> (\<forall>y. y \<in>\<^sub>c codomain p \<longrightarrow> (\<exists>x. x \<in>\<^sub>c domain p \<and> p \<circ>\<^sub>c x = y))"
  have "\<exists>y. y \<in>\<^sub>c Y \<and> \<not>(\<exists>x. x \<in>\<^sub>c X \<and> p \<circ>\<^sub>c x = y)"
    using a1 assms(1) cfunc_type_def by auto
  then obtain y0 where y_def: "y0 \<in>\<^sub>c Y \<and> (\<forall>x. x \<in>\<^sub>c X \<longrightarrow> p \<circ>\<^sub>c x \<noteq> y0)"
    by auto
  have mono: "monomorphism(y0)"
    using element_monomorphism y_def by blast
  obtain g where g_def: "g = eq_pred Y \<circ>\<^sub>c \<langle>y0 \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>, id Y\<rangle>"
    by simp
  have g_right_arg_type: "\<langle>y0 \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>, id Y\<rangle> : Y \<rightarrow> (Y\<times>\<^sub>cY)"
    by (meson cfunc_prod_type comp_type id_type terminal_func_type y_def)
  then have g_type: "g: Y \<rightarrow> \<Omega>"
    using comp_type eq_pred_type g_def by blast

  have gpx_Eqs_f: "\<forall>x. (x \<in>\<^sub>c X \<longrightarrow> g \<circ>\<^sub>c p \<circ>\<^sub>c x = \<f>)"
  proof(rule ccontr, auto)
    fix x
    assume x_type: "x \<in>\<^sub>c X"
    assume bwoc: "g \<circ>\<^sub>c p \<circ>\<^sub>c x \<noteq> \<f>"
    (*
    have contradiction: "\<exists>s. s \<in>\<^sub>c p\<^sup>-\<^sup>1{y0}"
      by (smt assms(1) bwoc cfunc_type_def char_of_singleton2 comp_associative comp_type eq_pred_type g_def g_right_arg_type x_type y_def)
    *)
    (*Incidently the above is not necessary and the justification is the same in both cases.*)
     show False
      by (smt assms(1) bwoc cfunc_type_def char_of_singleton2 comp_associative comp_type eq_pred_type g_def g_right_arg_type x_type y_def)
  qed
  obtain h where h_def: "h = \<f> \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>"
    by simp
  have h_type: "h: Y \<rightarrow> \<Omega>"
    using comp_type false_func_type h_def terminal_func_type by blast
  have hpx_eqs_f: "\<forall>x. (x \<in>\<^sub>c X \<longrightarrow> h \<circ>\<^sub>c p \<circ>\<^sub>c x = \<f>)"
    by (smt assms(1) cfunc_type_def codomain_comp comp_associative false_func_type h_def id_right_unit2 id_type terminal_func_comp terminal_func_type terminal_func_unique)
  have gp_eqs_hp: "g \<circ>\<^sub>c p = h \<circ>\<^sub>c p"
  proof(rule one_separator[where X=X,where Y=\<Omega>])
    show "g \<circ>\<^sub>c p : X \<rightarrow> \<Omega>"
      using assms(1) comp_type g_type by auto
    show "h \<circ>\<^sub>c p : X \<rightarrow> \<Omega>"
      using assms(1) comp_type h_type by blast
    show "\<And>x. x \<in>\<^sub>c X \<Longrightarrow> (g \<circ>\<^sub>c p) \<circ>\<^sub>c x = (h \<circ>\<^sub>c p) \<circ>\<^sub>c x"
      using assms(1) comp_associative2 g_type gpx_Eqs_f h_type hpx_eqs_f by auto
  qed
  have g_not_h: "g \<noteq> h"
  proof -
   have f1: "\<forall>c. \<beta>\<^bsub>codomain c\<^esub> \<circ>\<^sub>c c = \<beta>\<^bsub>domain c\<^esub>"
    by (simp add: cfunc_type_def terminal_func_comp)
   have f2: "domain \<langle>y0 \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>,id\<^sub>c Y\<rangle> = Y"
    using cfunc_type_def g_right_arg_type by blast
  have f3: "codomain \<langle>y0 \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>,id\<^sub>c Y\<rangle> = Y \<times>\<^sub>c Y"
    using cfunc_type_def g_right_arg_type by blast
  have f4: "codomain y0 = Y"
    using cfunc_type_def y_def by presburger
  have "\<forall>c. domain (eq_pred c) = c \<times>\<^sub>c c"
    using cfunc_type_def eq_pred_type by auto
  then have "g \<circ>\<^sub>c y0 \<noteq> \<f>"
    using f4 f3 f2 by (metis (no_types) char_of_singleton1 comp_associative g_def true_false_distinct y_def)
  then show ?thesis
    using f1 by (metis (no_types) cfunc_type_def comp_associative false_func_type h_def id_right_unit2 id_type one_unique_element terminal_func_type y_def)
qed
  then show False
    using gp_eqs_hp assms(1) assms(2) cfunc_type_def epimorphism_def g_type h_type by auto
qed

(* Proposition 2.2.9 *)
lemma pullback_of_epi_is_epi1:
assumes "f: Y \<rightarrow> Z" "epimorphism f" "is_pullback A Y X Z (q1) f (q0) g "
shows "epimorphism (q0)"
proof -
  have surj_f: "surjective f"
    using assms(1) assms(2) epi_is_surj by auto
  have "surjective (q0)"
    unfolding surjective_def
  proof(auto)
    fix y
    assume y_type: "y \<in>\<^sub>c codomain q0"
    then have codomain_gy: "g \<circ>\<^sub>c y \<in>\<^sub>c Z"
      using assms(3) cfunc_type_def comp_type is_pullback_def square_commutes_def by auto
    then have z_exists: "\<exists> z. z \<in>\<^sub>c Y \<and> f \<circ>\<^sub>c z = g \<circ>\<^sub>c y"
      using assms(1) cfunc_type_def surj_f surjective_def by auto
    then obtain z where z_def: "z \<in>\<^sub>c Y \<and> f \<circ>\<^sub>c z = g \<circ>\<^sub>c y"
      by blast
    then have "\<exists>! k. k: one \<rightarrow> A \<and> q0 \<circ>\<^sub>c k = y \<and> q1 \<circ>\<^sub>c k =z"
      by (smt (verit) assms(3) cfunc_type_def is_pullback_def square_commutes_def y_type z_def)
    then show "\<exists>x. x \<in>\<^sub>c domain q0 \<and> q0 \<circ>\<^sub>c x = y"
      using assms(3) cfunc_type_def is_pullback_def square_commutes_def by auto
  qed

  then show ?thesis
    using surjective_is_epimorphism by blast
qed

(* Proposition 2.2.9b *)
lemma pullback_of_epi_is_epi2:
assumes "g: X \<rightarrow> Z" "epimorphism g" "is_pullback A Y X Z (q1) f (q0) g "
shows "epimorphism (q1)"
proof -
  have surj_g: "surjective g"
    using assms(1) assms(2) epi_is_surj by auto
  have "surjective (q1)"
    unfolding surjective_def
  proof(auto)
    fix y
    assume y_type: "y \<in>\<^sub>c codomain q1"
    then have codomain_gy: "f \<circ>\<^sub>c y \<in>\<^sub>c Z"
      using assms(3) cfunc_type_def comp_type is_pullback_def square_commutes_def by auto
    then have z_exists: "\<exists> z. z \<in>\<^sub>c X \<and> g \<circ>\<^sub>c z = f \<circ>\<^sub>c y"
      using assms(1) cfunc_type_def surj_g surjective_def by auto
    then obtain z where z_def: "z \<in>\<^sub>c X \<and> g \<circ>\<^sub>c z = f \<circ>\<^sub>c y"
      by blast
    then have "\<exists>! k. k: one \<rightarrow> A \<and> q0 \<circ>\<^sub>c k = z \<and> q1 \<circ>\<^sub>c k =y"
      by (smt (verit, ccfv_threshold) assms(3) cfunc_type_def is_pullback_def square_commutes_def y_type)
    then show "\<exists>x. x \<in>\<^sub>c domain q1 \<and> q1 \<circ>\<^sub>c x = y"
      using assms(3) cfunc_type_def is_pullback_def square_commutes_def by auto
  qed
  then show ?thesis
    using surjective_is_epimorphism by blast
qed

(* Proposition 2.2.9c *)
lemma pullback_of_mono_is_mono1:
assumes "g: X \<rightarrow> Z" "monomorphism f" "is_pullback A Y X Z (q1) f (q0) g "
shows "monomorphism (q0)"
proof(unfold monomorphism_def2, auto)
  fix u v Q a x
  assume u_type: "u : Q \<rightarrow> a"  (*Q is arbitrary while "a" is actually just A, and we will establish this soon.*)
  assume v_type: "v : Q \<rightarrow> a"
  assume q0_type: "q0 :  a \<rightarrow> x" (* y is actually just Y*)
  assume equals: "q0 \<circ>\<^sub>c u = q0 \<circ>\<^sub>c v"

  have a_is_A: "a = A"
    using assms(3) cfunc_type_def is_pullback_def q0_type square_commutes_def by force
  have y_is_Y: "x = X"
    using assms(3) cfunc_type_def is_pullback_def q0_type square_commutes_def by fastforce
  have u_type2[type_rule]: "u : Q \<rightarrow> A"
    using a_is_A u_type by blast
  have v_type2[type_rule]: "v : Q \<rightarrow> A"
    using a_is_A v_type by blast
  have q1_type2[type_rule]: "q0 : A \<rightarrow> X"
    using a_is_A q0_type y_is_Y by blast

  have eqn1: "g \<circ>\<^sub>c (q0 \<circ>\<^sub>c u) = f \<circ>\<^sub>c (q1 \<circ>\<^sub>c v)"
  proof -
    have "g \<circ>\<^sub>c (q0 \<circ>\<^sub>c u) = g \<circ>\<^sub>c q0 \<circ>\<^sub>c v"
      by (simp add: equals)
    also have "... = f \<circ>\<^sub>c (q1 \<circ>\<^sub>c v)"
      using assms(3) cfunc_type_def comp_associative is_pullback_def square_commutes_def by (typecheck_cfuncs, force)
    then show ?thesis
      by (simp add: calculation)
  qed

  have eqn2: "q1 \<circ>\<^sub>c u =  q1  \<circ>\<^sub>c v"
  proof -
    have f1: "f \<circ>\<^sub>c q1 \<circ>\<^sub>c u = g \<circ>\<^sub>c q0 \<circ>\<^sub>c u"
      using assms(3) comp_associative2 is_pullback_def square_commutes_def by (typecheck_cfuncs, auto)
    also have "... = g \<circ>\<^sub>c q0 \<circ>\<^sub>c v"
      by (simp add: equals)
    also have "... = f \<circ>\<^sub>c q1 \<circ>\<^sub>c v"
      using eqn1 equals by fastforce
    then show ?thesis
      by (typecheck_cfuncs, smt (verit, ccfv_threshold) f1 assms(2) assms(3) eqn1 is_pullback_def monomorphism_def3 square_commutes_def)
  qed

  have uniqueness: "\<exists>! j. (j : Q \<rightarrow> A \<and> q1 \<circ>\<^sub>c j = q1 \<circ>\<^sub>c v \<and> q0 \<circ>\<^sub>c j = q0 \<circ>\<^sub>c u)"
   by (typecheck_cfuncs, smt (verit, ccfv_threshold) assms(3) eqn1 is_pullback_def square_commutes_def)
  then show "u = v"
    using eqn2 equals uniqueness by (typecheck_cfuncs, auto)
qed

(* Proposition 2.2.9d *)
lemma pullback_of_mono_is_mono2:
assumes "g: X \<rightarrow> Z" "monomorphism g" "is_pullback A Y X Z (q1) f (q0) g "
shows "monomorphism (q1)"
proof(unfold monomorphism_def2, auto)
  fix u v Q a y
  assume u_type: "u : Q \<rightarrow> a"  (*Q is arbitrary while "a" is actually just A, and we will establish this soon.*)
  assume v_type: "v : Q \<rightarrow> a"
  assume q1_type: "q1 :  a \<rightarrow> y" (* y is actually just Y*)
  assume equals: "q1 \<circ>\<^sub>c u = q1 \<circ>\<^sub>c v"

  have a_is_A: "a = A"
    using assms(3) cfunc_type_def is_pullback_def q1_type square_commutes_def by force
  have y_is_Y: "y = Y"
    using assms(3) cfunc_type_def is_pullback_def q1_type square_commutes_def by fastforce
  have u_type2[type_rule]: "u : Q \<rightarrow> A"
    using a_is_A u_type by blast
  have v_type2[type_rule]: "v : Q \<rightarrow> A"
    using a_is_A v_type by blast
  have q1_type2[type_rule]: "q1 : A \<rightarrow> Y"
    using a_is_A q1_type y_is_Y by blast

  have eqn1: "f \<circ>\<^sub>c (q1 \<circ>\<^sub>c u) = g \<circ>\<^sub>c (q0 \<circ>\<^sub>c v)"
  proof -
    have "f \<circ>\<^sub>c (q1 \<circ>\<^sub>c u) = f \<circ>\<^sub>c q1 \<circ>\<^sub>c v"
      by (simp add: equals)
    also have "... = g \<circ>\<^sub>c (q0 \<circ>\<^sub>c v)"
      using assms(3) cfunc_type_def comp_associative is_pullback_def square_commutes_def by (typecheck_cfuncs, force)
    then show ?thesis
      by (simp add: calculation)
  qed

  have eqn2: "q0 \<circ>\<^sub>c u =  q0  \<circ>\<^sub>c v"
  proof -
    have f1: "g \<circ>\<^sub>c q0 \<circ>\<^sub>c u = f \<circ>\<^sub>c q1 \<circ>\<^sub>c u"
      using assms(3) comp_associative2 is_pullback_def square_commutes_def by (typecheck_cfuncs, auto)
    also have "... = f \<circ>\<^sub>c q1 \<circ>\<^sub>c v"
      by (simp add: equals)
    also have "... = g \<circ>\<^sub>c q0 \<circ>\<^sub>c v"
      using eqn1 equals by fastforce
    then show ?thesis
      by (typecheck_cfuncs, smt (verit, ccfv_threshold) f1 assms(2) assms(3) eqn1 is_pullback_def monomorphism_def3 square_commutes_def)
  qed

  have uniqueness: "\<exists>! j. (j : Q \<rightarrow> A \<and> q0 \<circ>\<^sub>c j = q0 \<circ>\<^sub>c v \<and> q1 \<circ>\<^sub>c j = q1 \<circ>\<^sub>c u)"
   by (typecheck_cfuncs, smt (verit, ccfv_threshold) assms(3) eqn1 is_pullback_def square_commutes_def)

  then show "u = v"
    using eqn2 equals uniqueness by (typecheck_cfuncs, auto)
qed

lemma fib_prod_left_id_iso:
  assumes "g : Y \<rightarrow> X"
  shows  "(X \<^bsub>id(X)\<^esub>\<times>\<^sub>c\<^bsub>g\<^esub> Y) \<cong> Y"
proof -
  have is_pullback: "is_pullback (X \<^bsub>id(X)\<^esub>\<times>\<^sub>c\<^bsub>g\<^esub> Y) Y X X (fibered_product_right_proj X (id(X)) g Y) g (fibered_product_left_proj X (id(X)) g Y) (id(X)) "
    using assms fibered_product_is_pullback by (typecheck_cfuncs, blast)
  then have mono: "monomorphism(fibered_product_right_proj X (id(X)) g Y)"
    using assms by (typecheck_cfuncs, meson id_isomorphism iso_imp_epi_and_monic pullback_of_mono_is_mono2)
  have "epimorphism(fibered_product_right_proj X (id(X)) g Y)"
    by (meson id_isomorphism id_type is_pullback iso_imp_epi_and_monic pullback_of_epi_is_epi2)
  then have "isomorphism(fibered_product_right_proj X (id(X)) g Y)"
    by (simp add: epi_mon_is_iso mono)
  then show ?thesis
    using assms fibered_product_right_proj_type id_type is_isomorphic_def by blast
qed

lemma fib_prod_right_id_iso:
  assumes "f : X \<rightarrow> Y"
  shows  "(X \<^bsub>f\<^esub>\<times>\<^sub>c\<^bsub>id(Y)\<^esub> Y) \<cong> X"
proof -
  have is_pullback: "is_pullback (X \<^bsub>f\<^esub>\<times>\<^sub>c\<^bsub>id(Y)\<^esub> Y) Y X Y (fibered_product_right_proj X f (id(Y)) Y) (id(Y)) (fibered_product_left_proj X f (id(Y)) Y) f "
    using assms fibered_product_is_pullback by (typecheck_cfuncs, blast)

  then have mono: "monomorphism(fibered_product_left_proj X f (id(Y)) Y)"
    using assms by (typecheck_cfuncs, meson id_isomorphism is_pullback iso_imp_epi_and_monic pullback_of_mono_is_mono1)
  have "epimorphism(fibered_product_left_proj X f (id(Y)) Y)"
    by (meson id_isomorphism id_type is_pullback iso_imp_epi_and_monic pullback_of_epi_is_epi1)
  then have "isomorphism(fibered_product_left_proj X f (id(Y)) Y)"
    by (simp add: epi_mon_is_iso mono)
  then show ?thesis
    using assms fibered_product_left_proj_type id_type is_isomorphic_def by blast
qed

(*Can we give this a better name?*)
lemma pullback_iff_product:
  assumes "terminal_object(T)"
  assumes f_type: "f : Y \<rightarrow> T"
  assumes g_type: "g : X \<rightarrow> T"
  shows "(is_pullback P Y X T (pY) f (pX) g) = (is_cart_prod P pX pY X Y)"
proof(auto)
  assume pullback: "is_pullback P Y X T pY f pX g"
  have f_type[type_rule]: "f : Y \<rightarrow> T"
    using is_pullback_def pullback square_commutes_def by force
  have g_type[type_rule]: "g : X \<rightarrow> T"
    using is_pullback_def pullback square_commutes_def by force
  show "is_cart_prod P pX pY X Y"
  proof(unfold is_cart_prod_def, auto)
    show pX_type[type_rule]: "pX : P \<rightarrow> X"
      using pullback is_pullback_def square_commutes_def by force
    show pY_type[type_rule]: "pY : P \<rightarrow> Y"
      using pullback is_pullback_def square_commutes_def by force
    show "\<And>x y Z.
       x : Z \<rightarrow> X \<Longrightarrow>
       y : Z \<rightarrow> Y \<Longrightarrow>
       \<exists>h. h : Z \<rightarrow> P \<and>
           pX \<circ>\<^sub>c h = x \<and> pY \<circ>\<^sub>c h = y \<and> (\<forall>h2. h2 : Z \<rightarrow> P \<and> pX \<circ>\<^sub>c h2 = x \<and> pY \<circ>\<^sub>c h2 = y \<longrightarrow> h2 = h)"
    proof -
      fix x y Z
      assume x_type[type_rule]: "x : Z \<rightarrow> X"
      assume y_type[type_rule]: "y : Z \<rightarrow> Y"
      have  "\<And>Z k h. k : Z \<rightarrow> Y \<Longrightarrow> h : Z \<rightarrow> X \<Longrightarrow> f \<circ>\<^sub>c k = g \<circ>\<^sub>c h \<Longrightarrow> \<exists>j. j : Z \<rightarrow> P \<and> pY \<circ>\<^sub>c j = k \<and> pX \<circ>\<^sub>c j = h"
        using is_pullback_def pullback by blast
      then have "\<exists>h. h : Z \<rightarrow> P \<and>
           pX \<circ>\<^sub>c h = x \<and> pY \<circ>\<^sub>c h = y"
        by (smt (verit, ccfv_threshold) assms cfunc_type_def codomain_comp domain_comp f_type g_type terminal_object_def x_type y_type)
      then show "\<exists>h. h : Z \<rightarrow> P \<and>
           pX \<circ>\<^sub>c h = x \<and> pY \<circ>\<^sub>c h = y \<and> (\<forall>h2. h2 : Z \<rightarrow> P \<and> pX \<circ>\<^sub>c h2 = x \<and> pY \<circ>\<^sub>c h2 = y \<longrightarrow> h2 = h)"
        by (typecheck_cfuncs, smt (verit, ccfv_threshold) comp_associative2 is_pullback_def pullback square_commutes_def)
    qed
  qed
next
  assume prod: "is_cart_prod P pX pY X Y"
  show "is_pullback P Y X T pY f pX g"
  proof(unfold is_pullback_def, auto)
    show "square_commutes P Y X T pY f pX g"
      using prod assms
      by (typecheck_cfuncs, metis assms(1) comp_type is_cart_prod_def prod square_commutes_def terminal_object_def)
    show "\<And>Z k h. k : Z \<rightarrow> Y \<Longrightarrow> h : Z \<rightarrow> X \<Longrightarrow> f \<circ>\<^sub>c k = g \<circ>\<^sub>c h \<Longrightarrow> \<exists>j. j : Z \<rightarrow> P \<and> pY \<circ>\<^sub>c j = k \<and> pX \<circ>\<^sub>c j = h"
      using is_cart_prod_def prod by blast
    show "\<And>Z j y.
       pY \<circ>\<^sub>c j : Z \<rightarrow> Y \<Longrightarrow>
       pX \<circ>\<^sub>c j : Z \<rightarrow> X \<Longrightarrow>
       f \<circ>\<^sub>c pY \<circ>\<^sub>c j = g \<circ>\<^sub>c pX \<circ>\<^sub>c j \<Longrightarrow> j : Z \<rightarrow> P \<Longrightarrow> y : Z \<rightarrow> P \<Longrightarrow> pY \<circ>\<^sub>c y = pY \<circ>\<^sub>c j \<Longrightarrow> pX \<circ>\<^sub>c y = pX \<circ>\<^sub>c j \<Longrightarrow> j = y"
      using is_cart_prod_def prod by blast
  qed
qed

(*Now we use the previous lemma together with the fact that a Cartesian product of X and Y is
  isomorphic to X \<times>\<^sub>c Y  to prove the next two lemmas*)

lemma terminal_fib_prod_iso:
  "(X \<^bsub>\<beta>\<^bsub>X\<^esub>\<^esub>\<times>\<^sub>c\<^bsub>\<beta>\<^bsub>Y\<^esub>\<^esub> Y) \<cong> X \<times>\<^sub>c Y"
proof -
  have "(is_pullback (X \<^bsub>\<beta>\<^bsub>X\<^esub>\<^esub>\<times>\<^sub>c\<^bsub>\<beta>\<^bsub>Y\<^esub>\<^esub> Y) Y X one (fibered_product_right_proj X (\<beta>\<^bsub>X\<^esub>) (\<beta>\<^bsub>Y\<^esub>) Y) (\<beta>\<^bsub>Y\<^esub>) (fibered_product_left_proj X (\<beta>\<^bsub>X\<^esub>) (\<beta>\<^bsub>Y\<^esub>) Y) (\<beta>\<^bsub>X\<^esub>))"
    using pullback_iff_product
    by (typecheck_cfuncs, simp add: fibered_product_is_pullback)
  then  have "(is_cart_prod (X \<^bsub>\<beta>\<^bsub>X\<^esub>\<^esub>\<times>\<^sub>c\<^bsub>\<beta>\<^bsub>Y\<^esub>\<^esub> Y) (fibered_product_left_proj X (\<beta>\<^bsub>X\<^esub>) (\<beta>\<^bsub>Y\<^esub>) Y) (fibered_product_right_proj X (\<beta>\<^bsub>X\<^esub>) (\<beta>\<^bsub>Y\<^esub>) Y)  X Y)"
    by (meson one_terminal_object pullback_iff_product terminal_func_type)
  then show ?thesis
    by (metis canonical_cart_prod_is_cart_prod cart_prods_isomorphic fst_conv is_isomorphic_def snd_conv)
qed

(*The generalization of the previous lemma.*)
lemma terminal_fib_prod_iso2:
  assumes "terminal_object(T)"
  assumes f_type: "f : Y \<rightarrow> T"
  assumes g_type: "g : X \<rightarrow> T"
  shows "(X \<^bsub>g\<^esub>\<times>\<^sub>c\<^bsub>f\<^esub> Y) \<cong> X \<times>\<^sub>c Y"
proof -
  have "(is_pullback (X \<^bsub>g\<^esub>\<times>\<^sub>c\<^bsub>f\<^esub> Y) Y X T (fibered_product_right_proj X g f Y) f (fibered_product_left_proj X g f Y) g)"
    using assms pullback_iff_product fibered_product_is_pullback by (typecheck_cfuncs, force)
  then have "(is_cart_prod (X \<^bsub>g\<^esub>\<times>\<^sub>c\<^bsub>f\<^esub> Y) (fibered_product_left_proj X g f Y) (fibered_product_right_proj X g f Y)  X Y)"
    using assms by (meson one_terminal_object pullback_iff_product terminal_func_type)
  then show ?thesis
    using assms by (metis canonical_cart_prod_is_cart_prod cart_prods_isomorphic fst_conv is_isomorphic_def snd_conv)
qed

(*This is essentially a duplicate of cfunc_cross_prod_surj from the Terminal
Theory file.  If differs in style by proving the product of epis is epi rather
than proving the products of surjective maps is surjective.  It makes use of
pullbacks, but ultimately it's a duplicate. However, I think we should leave it
because it offers different insights into proof style.*)

(* Proposition 2.2.10 *)
lemma product_of_epis_is_epi:
  assumes f_type: "f: X \<rightarrow> Y" and f_epi: "epimorphism(f)"
  assumes g_type: "g: W \<rightarrow> Z" and g_epi: "epimorphism(g)"
  shows "epimorphism(f\<times>\<^sub>f g)"
proof - (*there are serious errors in the diagram in the book!*)
   have decompose_fxg: "f\<times>\<^sub>f g = (f\<times>\<^sub>f id(Z)) \<circ>\<^sub>c (id(X)\<times>\<^sub>f g)"
     using assms by (typecheck_cfuncs, simp add: cfunc_cross_prod_comp_cfunc_cross_prod id_left_unit2 id_right_unit2)

 (*First half proving (f\<times>\<^sub>f id(Z)) is an epimorphism.*)

   have pullback: "is_pullback (X\<times>\<^sub>cZ) X (Y\<times>\<^sub>cZ) Y (left_cart_proj X Z) f (f\<times>\<^sub>f id(Z)) (left_cart_proj Y Z)"
     unfolding is_pullback_def
   proof(auto)
     show "square_commutes (X \<times>\<^sub>c Z) X (Y \<times>\<^sub>c Z) Y (left_cart_proj X Z) f
     (f \<times>\<^sub>f id\<^sub>c Z) (left_cart_proj Y Z)"
       using assms by (typecheck_cfuncs, simp add: left_cart_proj_cfunc_cross_prod square_commutes_def)
     show "\<And>Za k h. k : Za \<rightarrow> X \<Longrightarrow> h : Za \<rightarrow> Y \<times>\<^sub>c Z \<Longrightarrow> f \<circ>\<^sub>c k = left_cart_proj Y Z \<circ>\<^sub>c h \<Longrightarrow>
       \<exists>j. j : Za \<rightarrow> X \<times>\<^sub>c Z \<and> left_cart_proj X Z \<circ>\<^sub>c j = k \<and> (f \<times>\<^sub>f id\<^sub>c Z) \<circ>\<^sub>c j = h"
     proof-
       fix Za k h
       assume k_type:  "k : Za \<rightarrow> X"
       assume h_type: "h : Za \<rightarrow> Y \<times>\<^sub>c Z"
       assume outer_square: "f \<circ>\<^sub>c k = left_cart_proj Y Z \<circ>\<^sub>c h"
       obtain j where j_def: "j = \<langle>k,right_cart_proj Y Z \<circ>\<^sub>c h\<rangle>"
         by simp
       then have j_type: "j: Za \<rightarrow> X \<times>\<^sub>c Z"
         using cfunc_prod_type comp_type h_type k_type right_cart_proj_type by auto
       have top_triangle: "left_cart_proj X Z \<circ>\<^sub>c j = k"
         using comp_type h_type j_def k_type left_cart_proj_cfunc_prod right_cart_proj_type by auto
       have bottom_triangle: "(f \<times>\<^sub>f id\<^sub>c Z) \<circ>\<^sub>c j = h"
       proof -
         have "(f \<times>\<^sub>f id\<^sub>c Z) \<circ>\<^sub>c j = \<langle>f \<circ>\<^sub>c k,id\<^sub>c Z \<circ>\<^sub>c right_cart_proj Y Z \<circ>\<^sub>c h\<rangle>"
           by (smt cfunc_cross_prod_comp_cfunc_prod comp_type f_type h_type id_type j_def k_type right_cart_proj_type)
         also have "... = \<langle>left_cart_proj Y Z \<circ>\<^sub>c h,right_cart_proj Y Z \<circ>\<^sub>c h\<rangle>"
           by (metis cart_prod_decomp h_type id_left_unit2 outer_square right_cart_proj_cfunc_prod)
         also have "... = h"
           by (metis cfunc_prod_unique comp_type f_type h_type k_type outer_square right_cart_proj_type)
       then show ?thesis
         by (simp add: calculation)
     qed
     then show "\<exists>j. j : Za \<rightarrow> X \<times>\<^sub>c Z \<and> left_cart_proj X Z \<circ>\<^sub>c j = k \<and> (f \<times>\<^sub>f id\<^sub>c Z) \<circ>\<^sub>c j = h"
       using j_type top_triangle by blast
   qed
     show "\<And>Za j y.
       left_cart_proj X Z \<circ>\<^sub>c j : Za \<rightarrow> X \<Longrightarrow>
       (f \<times>\<^sub>f id\<^sub>c Z) \<circ>\<^sub>c j : Za \<rightarrow> Y \<times>\<^sub>c Z \<Longrightarrow>
       f \<circ>\<^sub>c left_cart_proj X Z \<circ>\<^sub>c j =
       left_cart_proj Y Z \<circ>\<^sub>c (f \<times>\<^sub>f id\<^sub>c Z) \<circ>\<^sub>c j \<Longrightarrow>
       j : Za \<rightarrow> X \<times>\<^sub>c Z \<Longrightarrow>
       y : Za \<rightarrow> X \<times>\<^sub>c Z \<Longrightarrow>
       left_cart_proj X Z \<circ>\<^sub>c y = left_cart_proj X Z \<circ>\<^sub>c j \<Longrightarrow>
       (f \<times>\<^sub>f id\<^sub>c Z) \<circ>\<^sub>c y = (f \<times>\<^sub>f id\<^sub>c Z) \<circ>\<^sub>c j \<Longrightarrow> j = y"
         by (smt cart_prod_decomp cart_prod_eq2 cfunc_cross_prod_comp_cfunc_prod f_type id_left_unit2 id_type left_cart_proj_cfunc_prod)
     qed
     then have fid_epi: "epimorphism(f\<times>\<^sub>f id(Z))"
       using f_epi f_type pullback_of_epi_is_epi1 by blast

(*Second half proving (id(X)\<times>\<^sub>f g) is an epimorphism.*)

    have pullback2: "is_pullback (X\<times>\<^sub>cW) W (X\<times>\<^sub>cZ) Z (right_cart_proj X W) g (id(X)\<times>\<^sub>f g) (right_cart_proj X Z)"
         unfolding is_pullback_def
    proof(auto)
      show "square_commutes (X \<times>\<^sub>c W) W (X \<times>\<^sub>c Z) Z (right_cart_proj X W) g
     (id\<^sub>c X \<times>\<^sub>f g) (right_cart_proj X Z)"
        using assms by (typecheck_cfuncs, simp add: right_cart_proj_cfunc_cross_prod square_commutes_def)
      show "\<And>Za k h.
       k : Za \<rightarrow> W \<Longrightarrow>
       h : Za \<rightarrow> X \<times>\<^sub>c Z \<Longrightarrow>
       g \<circ>\<^sub>c k = right_cart_proj X Z \<circ>\<^sub>c h \<Longrightarrow>
       \<exists>j. j : Za \<rightarrow> X \<times>\<^sub>c W \<and>
           right_cart_proj X W \<circ>\<^sub>c j = k \<and> (id\<^sub>c X \<times>\<^sub>f g) \<circ>\<^sub>c j = h"
 proof-
       fix Za k h
       assume k_type:  "k : Za \<rightarrow> W"
       assume h_type: "h : Za \<rightarrow> X \<times>\<^sub>c Z"
       assume outer_square: "g \<circ>\<^sub>c k = right_cart_proj X Z \<circ>\<^sub>c h"
       obtain j where j_def: "j = \<langle>left_cart_proj X Z \<circ>\<^sub>c h,k\<rangle>"
         by simp
       then have j_type: "j : Za \<rightarrow> X \<times>\<^sub>c W"
         using cfunc_prod_type comp_type h_type k_type left_cart_proj_type by auto
       have top_triangle: "right_cart_proj X W \<circ>\<^sub>c j = k"
         using comp_type h_type j_def k_type left_cart_proj_type right_cart_proj_cfunc_prod by blast
       have bottom_triangle: "(id\<^sub>c X \<times>\<^sub>f g) \<circ>\<^sub>c j = h"
       proof -
         have "(id\<^sub>c X \<times>\<^sub>f g) \<circ>\<^sub>c j = \<langle>id\<^sub>c X \<circ>\<^sub>c left_cart_proj X Z \<circ>\<^sub>c h,g \<circ>\<^sub>c k\<rangle>"
           by (smt cfunc_cross_prod_comp_cfunc_prod comp_type g_type h_type id_type j_def k_type left_cart_proj_type)
         also have "... = \<langle>left_cart_proj X Z \<circ>\<^sub>c h,right_cart_proj X Z \<circ>\<^sub>c h\<rangle>"
           by (metis cart_prod_decomp h_type id_left_unit2 left_cart_proj_cfunc_prod outer_square)
         also have "... = h"
           by (metis cfunc_prod_unique comp_type g_type h_type k_type left_cart_proj_type outer_square)
         then show ?thesis
           by (simp add: calculation)
       qed
       then show "\<exists>j. j : Za \<rightarrow> X \<times>\<^sub>c W \<and>
           right_cart_proj X W \<circ>\<^sub>c j = k \<and> (id\<^sub>c X \<times>\<^sub>f g) \<circ>\<^sub>c j = h"
         using j_type top_triangle by blast
     qed
     show "\<And>Za j y.
       right_cart_proj X W \<circ>\<^sub>c j : Za \<rightarrow> W \<Longrightarrow>
       (id\<^sub>c X \<times>\<^sub>f g) \<circ>\<^sub>c j : Za \<rightarrow> X \<times>\<^sub>c Z \<Longrightarrow>
       g \<circ>\<^sub>c right_cart_proj X W \<circ>\<^sub>c j =
       right_cart_proj X Z \<circ>\<^sub>c (id\<^sub>c X \<times>\<^sub>f g) \<circ>\<^sub>c j \<Longrightarrow>
       j : Za \<rightarrow> X \<times>\<^sub>c W \<Longrightarrow>
       y : Za \<rightarrow> X \<times>\<^sub>c W \<Longrightarrow>
       right_cart_proj X W \<circ>\<^sub>c y = right_cart_proj X W \<circ>\<^sub>c j \<Longrightarrow>
       (id\<^sub>c X \<times>\<^sub>f g) \<circ>\<^sub>c y = (id\<^sub>c X \<times>\<^sub>f g) \<circ>\<^sub>c j \<Longrightarrow> j = y"
       by (smt cart_prod_decomp cart_prod_eq2 cfunc_cross_prod_comp_cfunc_prod g_type id_left_unit2 id_type right_cart_proj_cfunc_prod)
   qed
   then have "epimorphism(id(X)\<times>\<^sub>f g)"
     using g_epi g_type pullback_of_epi_is_epi1 by blast
   then show ?thesis
     using fid_epi cfunc_type_def composition_of_epi_pair_is_epi decompose_fxg is_pullback_def pullback pullback2 square_commutes_def by auto
 qed

definition set_subtraction :: "cset \<Rightarrow> cset \<times> cfunc \<Rightarrow> cset" (infix "\<setminus>" 60) where
  "Y \<setminus> X = (SOME E. \<exists> m'.  equalizer E m' (characteristic_func (snd X)) (\<f> \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>))"

lemma set_subtraction_equalizer:
  assumes "m : X \<rightarrow> Y" "monomorphism m"
  shows "\<exists> m'.  equalizer (Y \<setminus> (X,m)) m' (characteristic_func m) (\<f> \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>)"
proof -
  have "\<exists> E m'. equalizer E m' (characteristic_func m) (\<f> \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>)"
    using assms equalizer_exists by (typecheck_cfuncs, auto)
  then have "\<exists> m'.  equalizer (Y \<setminus> (X,m)) m' (characteristic_func (snd (X,m))) (\<f> \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>)"
    by (unfold set_subtraction_def, rule_tac someI_ex, auto)
  then show "\<exists> m'.  equalizer (Y \<setminus> (X,m)) m' (characteristic_func m) (\<f> \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>)"
    by auto
qed

definition complement_morphism :: "cfunc \<Rightarrow> cfunc" ("_\<^sup>c" [1000]) where
  "m\<^sup>c = (SOME m'.  equalizer (codomain m \<setminus> (domain m, m)) m' (characteristic_func m) (\<f> \<circ>\<^sub>c \<beta>\<^bsub>codomain m\<^esub>))"

lemma complement_morphism_equalizer:
  assumes "m : X \<rightarrow> Y" "monomorphism m"
  shows "equalizer (Y \<setminus> (X,m)) m\<^sup>c (characteristic_func m) (\<f> \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>)"
proof -
  have "\<exists> m'. equalizer (codomain m \<setminus> (domain m, m)) m' (characteristic_func m) (\<f> \<circ>\<^sub>c \<beta>\<^bsub>codomain m\<^esub>)"
    by (simp add: assms cfunc_type_def set_subtraction_equalizer)
  then have "equalizer (codomain m \<setminus> (domain m, m)) m\<^sup>c (characteristic_func m) (\<f> \<circ>\<^sub>c \<beta>\<^bsub>codomain m\<^esub>)"
    by (unfold complement_morphism_def, rule_tac someI_ex, auto)
  then show "equalizer (Y \<setminus> (X, m)) m\<^sup>c (characteristic_func m) (\<f> \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>)"
    using assms unfolding cfunc_type_def by auto
qed

lemma complement_morphism_type[type_rule]:
  assumes "m : X \<rightarrow> Y" "monomorphism m"
  shows "m\<^sup>c : Y \<setminus> (X,m) \<rightarrow> Y"
  using assms cfunc_type_def characteristic_func_type complement_morphism_equalizer equalizer_def by auto

lemma complement_morphism_mono:
  assumes "m : X \<rightarrow> Y" "monomorphism m"
  shows "monomorphism m\<^sup>c"
  using assms complement_morphism_equalizer equalizer_is_monomorphism by blast

lemma complement_morphism_eq:
  assumes "m : X \<rightarrow> Y" "monomorphism m"
  shows "characteristic_func m \<circ>\<^sub>c m\<^sup>c  = (\<f> \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>) \<circ>\<^sub>c m\<^sup>c"
  using assms complement_morphism_equalizer unfolding equalizer_def by auto

lemma characteristic_func_true_not_complement_member:
  assumes "m : B \<rightarrow> X" "monomorphism m" "x \<in>\<^sub>c X"
  assumes characteristic_func_true: "characteristic_func m \<circ>\<^sub>c x = \<t>"
  shows "\<not> x \<in>\<^bsub>X\<^esub> (X \<setminus> (B, m),m\<^sup>c)"
proof
  assume in_complement: "x \<in>\<^bsub>X\<^esub> (X \<setminus> (B, m), m\<^sup>c)"
  then obtain x' where x'_type: "x' \<in>\<^sub>c X \<setminus> (B,m)" and x'_def: "m\<^sup>c \<circ>\<^sub>c x' = x"
    using assms cfunc_type_def complement_morphism_type factors_through_def relative_member_def2
    by auto
  then have "characteristic_func m \<circ>\<^sub>c m\<^sup>c = (\<f> \<circ>\<^sub>c \<beta>\<^bsub>X\<^esub>) \<circ>\<^sub>c m\<^sup>c"
    using assms complement_morphism_equalizer equalizer_def by blast
  then have "characteristic_func m \<circ>\<^sub>c x = \<f> \<circ>\<^sub>c \<beta>\<^bsub>X\<^esub> \<circ>\<^sub>c x"
    using assms x'_type complement_morphism_type
    by (typecheck_cfuncs, smt x'_def assms cfunc_type_def comp_associative domain_comp)
  then have "characteristic_func m \<circ>\<^sub>c x = \<f>"
    using assms by (typecheck_cfuncs, metis id_right_unit2 id_type one_unique_element terminal_func_comp terminal_func_type)
  then show False
    using characteristic_func_true true_false_distinct by auto
qed

lemma characteristic_func_false_complement_member:
  assumes "m : B \<rightarrow> X" "monomorphism m" "x \<in>\<^sub>c X"
  assumes characteristic_func_false: "characteristic_func m \<circ>\<^sub>c x = \<f>"
  shows "x \<in>\<^bsub>X\<^esub> (X \<setminus> (B, m),m\<^sup>c)"
proof -
  have x_equalizes: "characteristic_func m \<circ>\<^sub>c x = \<f> \<circ>\<^sub>c \<beta>\<^bsub>X\<^esub> \<circ>\<^sub>c x"
    by (metis assms(3) characteristic_func_false false_func_type id_right_unit2 id_type one_unique_element terminal_func_comp terminal_func_type)
  have "\<And>h F. h : F \<rightarrow> X \<and> characteristic_func m \<circ>\<^sub>c h = (\<f> \<circ>\<^sub>c \<beta>\<^bsub>X\<^esub>) \<circ>\<^sub>c h \<longrightarrow>
                  (\<exists>!k. k : F \<rightarrow> X \<setminus> (B, m) \<and> m\<^sup>c \<circ>\<^sub>c k = h)"
    using assms complement_morphism_equalizer unfolding equalizer_def
    by (smt cfunc_type_def characteristic_func_type)
  then obtain x' where x'_type: "x' \<in>\<^sub>c X \<setminus> (B, m)" and x'_def: "m\<^sup>c \<circ>\<^sub>c x' = x"
    by (metis assms(3) cfunc_type_def comp_associative false_func_type terminal_func_type x_equalizes)
  then show "x \<in>\<^bsub>X\<^esub> (X \<setminus> (B, m),m\<^sup>c)"
    unfolding relative_member_def factors_through_def
    using assms complement_morphism_mono complement_morphism_type cfunc_type_def by auto
qed

lemma in_complement_not_in_subset:
  assumes "m : X \<rightarrow> Y" "monomorphism m" "x \<in>\<^sub>c Y"
  assumes "x \<in>\<^bsub>Y\<^esub> (Y \<setminus> (X,m), m\<^sup>c)"
  shows "\<not> x \<in>\<^bsub>Y\<^esub> (X, m)"
  using assms characteristic_func_false_not_relative_member
    characteristic_func_true_not_complement_member characteristic_func_type comp_type
    true_false_only_truth_values by blast

lemma not_in_subset_in_complement:
  assumes "m : X \<rightarrow> Y" "monomorphism m" "x \<in>\<^sub>c Y"
  assumes "\<not> x \<in>\<^bsub>Y\<^esub> (X, m)"
  shows "x \<in>\<^bsub>Y\<^esub> (Y \<setminus> (X,m), m\<^sup>c)"
  using assms characteristic_func_false_complement_member characteristic_func_true_relative_member
    characteristic_func_type comp_type true_false_only_truth_values by blast

lemma complement_disjoint:
  assumes "m : X \<rightarrow> Y" "monomorphism m"
  assumes "x \<in>\<^sub>c X" "x' \<in>\<^sub>c Y \<setminus> (X,m)"
  shows "m \<circ>\<^sub>c x \<noteq> m\<^sup>c \<circ>\<^sub>c x'"
proof
  assume "m \<circ>\<^sub>c x = m\<^sup>c \<circ>\<^sub>c x'"
  then have "characteristic_func m \<circ>\<^sub>c m \<circ>\<^sub>c x = characteristic_func m \<circ>\<^sub>c m\<^sup>c \<circ>\<^sub>c x'"
    by auto
  then have "(characteristic_func m \<circ>\<^sub>c m) \<circ>\<^sub>c x = (characteristic_func m \<circ>\<^sub>c m\<^sup>c) \<circ>\<^sub>c x'"
    using assms comp_associative2 by (typecheck_cfuncs, auto)
  then have "(\<t> \<circ>\<^sub>c \<beta>\<^bsub>X\<^esub>) \<circ>\<^sub>c x = ((\<f> \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>) \<circ>\<^sub>c m\<^sup>c) \<circ>\<^sub>c x'"
    using assms characteristic_func_eq complement_morphism_eq by auto
  then have "\<t> \<circ>\<^sub>c \<beta>\<^bsub>X\<^esub> \<circ>\<^sub>c x = \<f> \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub> \<circ>\<^sub>c m\<^sup>c \<circ>\<^sub>c x'"
    using assms comp_associative2 by (typecheck_cfuncs, smt terminal_func_comp terminal_func_type)
  then have "\<t> \<circ>\<^sub>c id one = \<f> \<circ>\<^sub>c id one"
    using assms by (smt cfunc_type_def comp_associative complement_morphism_type id_type one_unique_element terminal_func_comp terminal_func_type)
  then have "\<t> = \<f>"
    using false_func_type id_right_unit2 true_func_type by auto
  then show False
    using true_false_distinct by auto
qed

end