theory PartialMonoid
  imports Main
begin

section {* Partial monoid *}

no_notation
  one_class.one ("1") and
  times (infixl "*" 70)

notation bot ("\<bottom>")

text {* Signature of our classes *}

class pmult =
  fixes pmult :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "*" 80)

class pmult_defined =
  fixes pmult_defined :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "##" 55)

class pmult_one =
  fixes pmult_one :: "'a" ("1")

text {* Domain theoretical way of defining pmult semigroups, i.e., adding a \<bottom> (seeking) element. *}

class partial_semigroup_bot = pmult + bot +
  assumes pbot_assoc: "(x * y) * z = x * (y * z)"
  and botl [simp]: "x * \<bottom> = \<bottom>"
  and botr [simp]: "\<bottom> * x = \<bottom>"

text {*
  Let the binary relation ## be: x ## y \<longleftrightarrow> x + y \<noteq> \<bottom>, one can naturally define the
  following class based on the pmult semigroup with bottom element.
*}

class partial_semigroup_var = pmult + pmult_defined +
  assumes pmult_defr: "x ## (y * z) \<Longrightarrow> y ## z"
  and pmult_defl: "(x * y) ## z \<Longrightarrow> x ## y"
  and pmult_def_assoc: "x ## (y * z) = (x * y) ## z"
  and pmult_assoc_var: "x ## (y * z) \<Longrightarrow> (x * y) * z = x * (y * z)"

text {*
  A simpler pmult semigroup can be defined where it states that if x * y and (x * y) * z
  are defined, then y * z is also defined.
*}

class partial_semigroup = pmult + pmult_defined +
  assumes pmult_def: "(x * y) ## z \<and> x ## y \<longleftrightarrow> x ## (y * z) \<and> y ## z"
  and pmult_assoc: "\<lbrakk>x ## (y * z); x ## y\<rbrakk> \<Longrightarrow> (x * y) * z = x * (y * z)"

class totality = pmult_defined +
  assumes totality[simp]: "x ## y"

class total_semigroup = partial_semigroup + totality
begin

lemma total_assoc: "(x * y) * z = x * (y * z)"
  by (metis pmult_assoc totality)

sublocale semigroup "op *"
  by default (simp add: total_assoc)

end

text {*
  As expected, the pmult semigroup with bottom element is the strongest, where one can
  derive the other classes.
*}

sublocale partial_semigroup_bot \<subseteq> partial_semigroup_var "op *" "\<lambda>x y. x * y \<noteq> \<bottom>"
  by (default, metis botl, metis botr, (metis pbot_assoc)+)

sublocale partial_semigroup_var \<subseteq> partial_semigroup
  by default (metis pmult_def_assoc pmult_defl pmult_defr, metis pmult_assoc_var)

sublocale partial_semigroup_bot \<subseteq> partial_semigroup "op *" "\<lambda>x y. x * y \<noteq> \<bottom>" ..

text {*
  We select the weakest pmult semigroup to continue our hierarchy up to commutative monoid.
*}

class partial_ab_semigroup = pmult + pmult_defined +
  assumes pmult_ab_def: "(x * y) ## z \<and> x ## y \<Longrightarrow> x ## (y * z) \<and> y ## z"
  and pmult_ab_assoc: "\<lbrakk>x ## (y * z); x ## y\<rbrakk> \<Longrightarrow> (x * y) * z = x * (y * z)"
  and pmult_comm_def: "x ## y \<Longrightarrow> y ## x"
  and pmult_comm: "x ## y \<Longrightarrow> x * y = y * x"
begin

lemma "x ## y = y ## x"
  by (metis pmult_comm_def)

lemma pmult_def_eq: "(x * y) ## z \<and> x ## y \<longleftrightarrow> x ## (y * z) \<and> y ## z"
  by (metis pmult_comm_def pmult_ab_def)

subclass partial_semigroup
  by default (metis pmult_def_eq, metis pmult_ab_assoc)

end

class total_ab_semigroup = partial_ab_semigroup + totality
begin

lemma total_assoc: "(x * y) * z = x * (y * z)"
  by (metis pmult_assoc totality)

lemma total_comm: "x * y = y * x"
  by (metis pmult_comm totality)

subclass total_semigroup ..

end

class partial_monoid = partial_semigroup + pmult_one +
  assumes pmult_one_defr [simp]: "x ## 1"
  and pmult_one_defl [simp]: "1 ## x"
  and pmult_oner: "x * 1 = x"
  and pmult_onel: "1 * x = x"

class total_monoid = partial_monoid + totality
begin
subclass total_semigroup ..

sublocale monoid "op *" 1
  by default (simp_all add: pmult_oner pmult_onel)

end

class partial_comm_monoid = partial_ab_semigroup + pmult_one +
  assumes pone_defr: "x ## 1"
  and poner: "x * 1 = x"
begin

subclass partial_monoid
  by default (auto simp: pone_defr poner pmult_comm pmult_comm_def)

end

class total_comm_monoid = partial_comm_monoid + totality
begin
subclass total_ab_semigroup ..
subclass total_monoid ..

sublocale comm_monoid "op *" 1
  by default (simp_all add: total_comm)
end

section {* Models of partial monoids *}

text {*
  The natural model of a partial monoid is partial functions.
*}

typedef ('a, 'b) pfun = "UNIV :: ('a \<Rightarrow> 'b option) set" ..
setup_lifting type_definition_pfun

instantiation pfun :: (type, type) partial_semigroup
begin
lift_definition pmult_pfun :: "('a, 'b) pfun \<Rightarrow> ('a, 'b) pfun \<Rightarrow> ('a, 'b) pfun" is map_add .
lift_definition pmult_defined_pfun :: "('a, 'b) pfun \<Rightarrow> ('a, 'b) pfun \<Rightarrow> bool" is "\<lambda>x y. dom x \<inter> dom y = {}" .
instance
  by default (transfer, fastforce)+
end

instantiation pfun :: (type, type) partial_monoid
begin
lift_definition pmult_one_pfun :: "('a, 'b) pfun" is empty .
instance
  by default (transfer, fastforce)+
end

text {*
  We can also have a model where we add a new bottom element.
*}

typedef ('a, 'b) pfun_bot = "UNIV :: ('a \<Rightarrow> ('b option) option) set" ..
setup_lifting type_definition_pfun_bot

instantiation pfun_bot :: (type, type) partial_semigroup_bot
begin
lift_definition bot_pfun_bot :: "('a, 'b) pfun_bot" is "\<lambda>x. Some None" .
lift_definition pmult_pfun_bot :: "('a, 'b) pfun_bot \<Rightarrow> ('a, 'b) pfun_bot \<Rightarrow> ('a, 'b) pfun_bot"
  is "\<lambda>x y. if dom x \<inter> dom y = {} then map_add x y else (\<lambda>x. Some None)" .
instance
  by default (transfer, fastforce)+
end

text {*
  And obviously, it is also a model for our weaker semigroup.
*}

instantiation pfun_bot :: (type, type) partial_semigroup
begin
lift_definition pmult_defined_pfun_bot :: "('a, 'b) pfun_bot \<Rightarrow> ('a, 'b) pfun_bot \<Rightarrow> bool" is
  "\<lambda>x y. dom x \<inter> dom y = {}" .
instance
  by default (transfer, auto)+
end

text {*
  We could instantiate the heap as a partial function from nat to nat
*}
(*type_synonym heap = "(nat, nat) pfun"*)

notation one_class.one ("1")
end


theory Llist_of_tree_of2
    imports Main "$HIPSTER_HOME/IsaHipster"
begin

setup Tactic_Data.set_coinduct_sledgehammer

codatatype (lset: 'a) Llist =
    lnull: LNil
    | LCons (lhd: 'a) (ltl: "'a Llist")
where
 "ltl LNil = LNil"

codatatype 'a Tree = is_Leaf: Leaf |
           Node (left: "'a Tree") (val: 'a) (right: "'a Tree")
where
  "left Leaf = Leaf"
| "right Leaf = Leaf"

primcorec chop :: "'a Tree \<Rightarrow> 'a Tree"
where
  "is_Leaf t \<or> is_Leaf (left t) \<and> is_Leaf (right t) \<Longrightarrow> is_Leaf (chop t)"
| "val (chop t) = (if is_Leaf (left t) then val (right t) else val (left t))"
| "left (chop t) = (if is_Leaf (left t) then left (right t) else right t)"
| "right (chop t) = (if is_Leaf (left t) then right (right t) else chop (left t))"

primcorec llist_of :: "'a Tree \<Rightarrow> 'a Llist"
where
  "is_Leaf t \<Longrightarrow> lnull (llist_of t)"
| "lhd (llist_of t) = val t"
| "ltl (llist_of t) = llist_of (chop t)"

(* Converts Llist to left-leaning tree *)
primcorec tree_of2 :: "'a Llist \<Rightarrow> 'a Tree" where
  "lnull xs \<Longrightarrow> is_Leaf (tree_of2 xs)"
| "val (tree_of2 xs) = lhd xs"
| "left (tree_of2 xs) = tree_of2 (ltl xs)"
| "right (tree_of2 xs) = Leaf"

hipster tree_of2 chop
lemma lemma_a [thy_expl]: "Node Leaf y Leaf = tree_of2 (LCons y LNil)"
  apply (coinduction  arbitrary: y rule: Llist_of_tree_of2.Tree.coinduct_strong)
  by (simp_all add: tree_of2.ctr(1))

lemma lemma_aa [thy_expl]: "Node (tree_of2 z) y Leaf = tree_of2 (LCons y z)"
apply (coinduction  arbitrary: y z rule: Llist_of_tree_of2.Tree.coinduct_strong)
  by simp

hipster llist_of
lemma unknown [thy_expl]: "left (left y) = Leaf"
  oops

hipster llist_of tree_of2
lemma unknown [thy_expl]: "left (left (left y)) = Leaf"
  oops

theorem llist_of_tree_of2 : "llist_of (tree_of2 xs) = xs"
  (*by hipster_coinduct_sledgehammer *)
  apply(coinduction arbitrary: xs rule: Llist.coinduct_strong)
  by (simp add: chop.code llist_of.code tree_of2.simps(4))
end


(*  Title:      RSAPSS/Cryptinverts.thy
    Author:     Christina Lindenberg, Kai Wirt, Technische Universität Darmstadt
    Copyright:  2005 - Technische Universität Darmstadt
*)

header "Correctness proof for RSA"

theory Cryptinverts
imports  Crypt Productdivides  "~~/src/HOL/Number_Theory/Residues"
begin

text {*
  In this theory we show, that a RSA encrypted message can be decrypted
*}

primrec pred:: "nat \<Rightarrow> nat"
where
  "pred 0 = 0"
| "pred (Suc a) = a"

lemma fermat:
  assumes "prime p" "m mod p \<noteq> 0" shows "m^(p-(1::nat)) mod p = 1"
using fermat_theorem_nat [of p m] assms
by (metis cong_nat_def dvd_eq_mod_eq_0 Divides.mod_less prime_gt_1_nat)

lemma cryptinverts_hilf1: "prime p \<Longrightarrow> (m * m ^(k * pred p)) mod p = m mod p"
  apply (cases "m mod p = 0")
  apply (simp add: mod_mult_left_eq)
  apply (simp only: mult.commute [of k "pred p"]
    power_mult mod_mult_right_eq [of "m" "(m^pred p)^k" "p"]
    remainderexp [of "m^pred p" "p" "k", symmetric])
  apply (insert fermat [of p m], auto)
by (metis Cryptinverts.pred.simps Suc_pred mod_mult_right_eq mult_cancel1 mult_eq_1_iff mult.assoc mult.commute nat_power_eq_Suc_0_iff not_gr0)

lemma cryptinverts_hilf2: "prime p \<Longrightarrow> m*(m^(k * (pred p) * (pred q))) mod p = m mod p"
  apply (simp add: mult.commute [of "k * pred p" "pred q"] mult.assoc [symmetric])
  apply (rule cryptinverts_hilf1 [of "p" "m" "(pred q) * k"])
  apply simp
  done

lemma cryptinverts_hilf3: "prime q \<Longrightarrow> m*(m^(k * (pred p) * (pred q))) mod q = m mod q"
  apply (simp only: mult.assoc)
  apply (simp add: mult.commute [of "pred p" "pred q"])
  apply (simp only: mult.assoc [symmetric])
  apply (rule cryptinverts_hilf2)
  apply simp
  done

lemma cryptinverts_hilf4:
    "\<lbrakk>prime p; prime q; p \<noteq> q; m < p*q; x mod ((pred p)*(pred q)) = 1\<rbrakk> \<Longrightarrow> m^x mod (p*q) = m"
  apply (frule cryptinverts_hilf2 [of p m k q])
  apply (frule cryptinverts_hilf3 [of q m k p])
  apply (frule mod_eqD)
  apply (elim exE)
  apply (rule specializedtoprimes1a)
  apply (simp add: cryptinverts_hilf2 cryptinverts_hilf3 mult.assoc [symmetric])+
  done

lemma primmultgreater: fixes p::nat shows "\<lbrakk> prime p; prime q; p \<noteq> 2; q \<noteq> 2\<rbrakk> \<Longrightarrow> 2 < p*q"
  apply (simp add: prime_nat_def)
  apply (insert mult_le_mono [of 2 p 2 q])
  apply auto
  done

lemma primmultgreater2: fixes p::nat shows "\<lbrakk>prime p; prime q; p \<noteq> q\<rbrakk> \<Longrightarrow>  2 < p*q"
  apply (cases "p = 2")
   apply simp+
  apply (simp add: prime_nat_def)
  apply (cases "q = 2")
   apply (simp add: prime_nat_def)
  apply (erule primmultgreater)
  apply auto
  done

lemma cryptinverts: "\<lbrakk> prime p; prime q; p \<noteq> q; n = p*q; m < n;
    e*d mod ((pred p)*(pred q)) = 1\<rbrakk> \<Longrightarrow> rsa_crypt (rsa_crypt m e n) d n = m"
  apply (insert cryptinverts_hilf4 [of p q m "e*d"])
  apply (insert cryptcorrect [of "p*q" "rsa_crypt m e (p * q)" d])
  apply (insert cryptcorrect [of "p*q" m e])
  apply (insert primmultgreater2 [of p q])
  apply (simp add: prime_nat_def)
  apply (simp add: cryptcorrect remainderexp [of "m^e" "p*q" d] power_mult [symmetric])
  done

end


section \<open> Prealgebra.thy \<close>

theory Prealgebra
imports Main Function Space Poset Presheaf
begin

(* Prealgebra type (poset-valued presheaf) *)

record ('A, 'a) Prealgebra =
  space :: "'A Space"
  ob :: "('A Open, 'a Poset) Function "
  ar :: "('A Inclusion, ('a, 'a) PosetMap) Function"

definition valid :: "('A, 'a) Prealgebra \<Rightarrow> bool" where
  "valid F \<equiv>
    let
      T = space F;
      F0 = ob F;
      F1 = ar F;

      welldefined = Space.valid T
                    \<and> (Function.valid_map F0) \<and> (Function.valid_map F1)
                    \<and> (\<forall>A. A \<in> opens T \<longrightarrow> Poset.valid (F0 \<cdot> A))
                    \<and> (\<forall>i. i \<in> inclusions T \<longrightarrow> Poset.valid_map (F1 \<cdot> i)
                           \<and>  Poset.dom (F1 \<cdot> i) = F0 \<cdot> Space.cod i
                           \<and>  Poset.cod (F1 \<cdot> i) = F0 \<cdot> Space.dom i );
      identity = (\<forall>A. A \<in> opens T \<longrightarrow> (F1 \<cdot> (Space.ident A)) = Poset.ident (F0 \<cdot> A));
      composition = (\<forall>j i. j \<in> inclusions T \<longrightarrow> i \<in> inclusions T \<longrightarrow>  Space.dom j = Space.cod i
        \<longrightarrow>  F1 \<cdot> (j \<propto> i) = (F1 \<cdot> i) \<diamondop> (F1 \<cdot> j))
    in
    welldefined \<and> identity \<and> composition"

(* PrealgebraMap type (natural transformation *)

record ('A, 'a, 'b) PrealgebraMap =
  dom :: "('A, 'a) Prealgebra"
  cod :: "('A, 'b) Prealgebra"
  nat :: "('A Open, ('a, 'b) PosetMap) Function"

abbreviation map_space :: "('A, 'a, 'b) PrealgebraMap \<Rightarrow> 'A Space" where
"map_space f \<equiv> space (dom f)"

definition valid_map :: "('A, 'a, 'b) PrealgebraMap \<Rightarrow> bool" where
 "valid_map f \<equiv>
    let
      T = (map_space f);

      welldefined = Space.valid T
                    \<and> T = space (cod f)
                    \<and> valid (dom f) \<and> valid (cod f)
                    \<and> (Function.valid_map (nat f))
                    \<and> (\<forall>A. A \<in> opens T \<longrightarrow> Poset.valid_map (nat f \<cdot> A))
                    \<and> (\<forall>A. A \<in> opens T \<longrightarrow> Poset.dom (nat f \<cdot> A) = (ob (dom f) \<cdot> A))
                    \<and> (\<forall>A. A \<in> opens T \<longrightarrow> Poset.cod (nat f \<cdot> A) = (ob (cod f) \<cdot> A));
      naturality = (\<forall>i. i \<in> inclusions T \<longrightarrow>
          (nat f \<cdot> Space.dom i) \<diamondop> (ar (dom f) \<cdot> i) = (ar (cod f) \<cdot> i) \<diamondop> (nat f \<cdot> Space.cod i))
    in
    (welldefined \<and> naturality)"

(* Presheaf validity *)

lemma validI [intro] :
  fixes F :: "('A,'a) Prealgebra"
  defines "T \<equiv> space F"
  defines "F0 \<equiv> ob F"
  defines "F1 \<equiv> ar F"
  assumes welldefined : "(Space.valid T)
                    \<and> (Function.valid_map F0) \<and> (Function.valid_map F1)
                    \<and> (\<forall>A. A \<in> opens T \<longrightarrow> Poset.valid (F0 \<cdot> A))
                    \<and> (\<forall>i. i \<in> inclusions T \<longrightarrow> Poset.valid_map (F1 \<cdot> i)
                           \<and>  Poset.dom (F1 \<cdot> i) = (F0 \<cdot> Space.cod i)
                           \<and>  Poset.cod (F1 \<cdot> i) = (F0 \<cdot> Space.dom i) )"
  assumes identity : "(\<forall>A. A \<in> opens T \<longrightarrow> (F1 \<cdot> (Space.ident A)) = Poset.ident (F0 \<cdot> A))"
  assumes composition :" (\<forall> i j. j \<in> inclusions T \<longrightarrow> i \<in> inclusions T \<longrightarrow>
        Space.dom j = Space.cod i \<longrightarrow> (F1 \<cdot> (j \<propto> i )) = (F1 \<cdot> i) \<diamondop> (F1 \<cdot> j))"
  shows "valid F"
  unfolding valid_def
  apply (simp add: Let_def)
  apply safe
  using T_def welldefined apply blast
  using F0_def welldefined apply blast
  using F1_def welldefined apply fastforce
  using T_def F0_def welldefined apply presburger
  using T_def F1_def welldefined apply blast
  using T_def F0_def F1_def welldefined apply blast
  using T_def F0_def F1_def welldefined apply blast
  using T_def F0_def F1_def identity apply blast
  using T_def F1_def composition by blast

lemma valid_welldefined  : "valid F \<Longrightarrow> let T = space F; F0 = ob F; F1 = ar F in (Space.valid T)
                    \<and> (Function.valid_map F0) \<and> (Function.valid_map F1)
                    \<and> (\<forall>A. A \<in> opens T \<longrightarrow> Poset.valid (F0 \<cdot> A))
                    \<and> (\<forall>i. i \<in> inclusions T \<longrightarrow> Poset.valid_map (F1 \<cdot> i)
                           \<and>  Poset.dom (F1 \<cdot> i) = (F0 \<cdot> Space.cod i)
                           \<and>  Poset.cod (F1 \<cdot> i) = (F0 \<cdot> Space.dom i) )"
  unfolding valid_def by (simp add: Let_def)

lemma valid_space  : "valid F \<Longrightarrow> T = space F \<Longrightarrow> (Space.valid T)"
  by (meson Prealgebra.valid_welldefined)

lemma valid_ob  : "valid F \<Longrightarrow> A \<in> opens (space F) \<Longrightarrow> obA = ob F \<cdot> A \<Longrightarrow> Poset.valid obA"
  unfolding valid_def by (simp add: Let_def)

lemma valid_ar  :
  fixes F :: "('A, 'a) Prealgebra" and i :: "'A Inclusion"
  assumes "valid F"
  and "i \<in> inclusions (space F)"
  shows "Poset.valid_map (ar F \<cdot> i)"
proof -
  define "F1" where "F1 = Prealgebra.ar F"
  define "T" where "T = Prealgebra.space F"
  have "(\<forall>i. i \<in> inclusions T \<longrightarrow> Poset.valid_map (F1 \<cdot> i))"  using valid_welldefined
    by (metis (mono_tags, lifting) CollectD CollectI F1_def T_def assms(1))
    moreover have "i \<in> inclusions T"
      using T_def assms(2) by fastforce
    moreover have "Poset.valid_map (F1 \<cdot> i)"
      using calculation(1) calculation(2) by auto
    ultimately show ?thesis
      using F1_def by force
  qed

lemma valid_dom  : "valid F \<Longrightarrow> i \<in> inclusions (space F) \<Longrightarrow> Poset.dom (ar F \<cdot> i) = ob F \<cdot> Space.cod i"
  unfolding valid_def
  by (simp add: Let_def)

lemma valid_cod  : "valid F \<Longrightarrow> i \<in> inclusions (space F) \<Longrightarrow> Poset.cod (ar F \<cdot> i) = ob F \<cdot> Space.dom i"
  unfolding valid_def
  by (simp add: Let_def)

lemma valid_identity  : "valid F \<Longrightarrow> A \<in> opens (space F) \<Longrightarrow> ar F \<cdot> (Space.ident A) = Poset.ident (ob F \<cdot> A)"
  unfolding valid_def by (simp add: Let_def)

lemma valid_composition :
  "valid F \<Longrightarrow> j \<in> inclusions (space F) \<Longrightarrow> i \<in> inclusions (space F) \<Longrightarrow> Space.dom j = Space.cod i \<Longrightarrow>
    ar F \<cdot> (j \<propto> i) = (ar F \<cdot> i) \<diamondop> (ar F \<cdot> j)"
  unfolding valid_def
  by meson

(* PresheafMap validity *)

lemma valid_mapI [intro] :
  fixes f :: "('A,'a,'b) PrealgebraMap"
  defines "T \<equiv> map_space f"
  defines "F \<equiv> dom f"
  defines "F' \<equiv> cod f"
  assumes welldefined : "Space.valid T
                    \<and> T = space (cod f)
                    \<and> (Function.valid_map (nat f))
                    \<and> valid F \<and> valid F'
                    \<and> (\<forall>A. A \<in> opens T \<longrightarrow> Poset.valid_map (nat f \<cdot> A))
                    \<and> (\<forall>A. A \<in> opens T \<longrightarrow> Poset.dom (nat f \<cdot> A) = (ob F \<cdot> A))
                    \<and> (\<forall>A. A \<in> opens T \<longrightarrow> Poset.cod (nat f \<cdot> A) = (ob F' \<cdot> A))"
  assumes naturality : "(\<forall>i. i \<in> inclusions T \<longrightarrow>
          (nat f \<cdot> Space.dom i) \<diamondop> (ar F \<cdot> i) = (ar F' \<cdot> i) \<diamondop> (nat f \<cdot> Space.cod i))"
  shows "valid_map f"
  unfolding valid_map_def
  apply (simp add: Let_def)
  apply safe
  using T_def welldefined apply blast
  using T_def welldefined apply blast
  using F_def welldefined apply blast
  using F'_def welldefined apply blast
  using welldefined apply blast
  using T_def welldefined apply blast
  apply (simp add: F_def T_def welldefined)
  apply (simp add: F'_def T_def welldefined)
  using F'_def F_def T_def naturality by blast

lemma valid_map_welldefined :
  "valid_map f \<Longrightarrow> let F = dom f; F' = cod f; T = map_space f in (Space.valid T)
                    \<and> (Function.valid_map (nat f))
                    \<and> valid F \<and> valid F'
                    \<and> (\<forall>A. A \<in> opens T \<longrightarrow> Poset.valid_map (nat f \<cdot> A))
                    \<and> (\<forall>A. A \<in> opens T \<longrightarrow> Poset.dom (nat f \<cdot> A) = (ob F \<cdot> A))
                    \<and> (\<forall>A. A \<in> opens T \<longrightarrow> Poset.cod (nat f \<cdot> A) = (ob F' \<cdot> A))"
  by (meson Prealgebra.valid_map_def)

lemma valid_map_space : "valid_map f \<Longrightarrow> Space.valid (map_space f)"
  by (meson Prealgebra.valid_map_welldefined)

lemma valid_map_dom : "valid_map f \<Longrightarrow> valid (dom f)"
  unfolding valid_map_def by (simp add: Let_def)

lemma valid_map_cod : "valid_map f \<Longrightarrow> valid (cod f)"
  unfolding valid_map_def by (simp add: Let_def)

lemma valid_map_nat : "valid_map f \<Longrightarrow> Function.valid_map (nat f)"
  unfolding valid_map_def by (simp add: Let_def)

lemma valid_map_nat_welldefined :
  "valid_map f \<Longrightarrow> A \<in> opens (map_space f) \<Longrightarrow> Poset.valid_map (nat f \<cdot> A)"
  unfolding valid_map_def by (simp add: Let_def)

lemma valid_map_nat_dom : "valid_map f \<Longrightarrow> A \<in> opens (map_space f) \<Longrightarrow> Poset.dom ((nat f) \<cdot> A) = ob (dom f) \<cdot> A"
  by (meson Prealgebra.valid_map_welldefined)

lemma valid_map_nat_cod : "valid_map f \<Longrightarrow> A \<in> opens (map_space f) \<Longrightarrow> Poset.cod ((nat f) \<cdot> A) = ob (cod f) \<cdot> A"
  by (meson Prealgebra.valid_map_welldefined)

lemma valid_map_naturality :
  "valid_map f \<Longrightarrow> i \<in> inclusions (map_space f) \<Longrightarrow>
     (ar (cod f) \<cdot> i) \<diamondop> (nat f \<cdot> Space.cod i) = (nat f \<cdot> Space.dom i) \<diamondop> (ar (dom f) \<cdot> i)"
  unfolding valid_map_def by (simp add: Let_def)

lemma valid_map_image :
  fixes f :: "('A, 'a, 'b) PrealgebraMap" and A :: "'A Open" and a :: "'a"
  defines "FA \<equiv> Prealgebra.ob (dom f) \<cdot> A"
  defines "F'A \<equiv> Prealgebra.ob (cod f) \<cdot> A"
  defines "fA \<equiv> (nat f) \<cdot> A"
  assumes f_valid :"valid_map f"
  and A_open : "A \<in> opens (map_space f)"
  and a_dom : "a \<in> Poset.el FA"
shows "fA \<star> a \<in> Poset.el F'A"
proof -
  have "valid_map f"
    using f_valid by force
  moreover have "A \<in> opens (map_space f)"
    using A_open by blast
  moreover have "a \<in> Poset.el FA"
    using a_dom by blast
  moreover have "Poset.dom fA = FA"
    by (metis A_open Prealgebra.valid_map_welldefined FA_def f_valid fA_def)
  moreover have "Poset.valid_map fA"
    by (metis A_open Prealgebra.valid_map_welldefined f_valid fA_def)
  moreover have "Poset.cod fA = F'A"
    by (metis A_open Prealgebra.valid_map_welldefined F'A_def f_valid fA_def)
  ultimately show ?thesis
    by (meson Poset.fun_app2)
qed

(* Application *)

lemma ident_app [simp] :
 "valid F \<Longrightarrow> A \<in> opens (space F) \<Longrightarrow> a \<in> el obA \<Longrightarrow>
  ar F \<cdot> (Space.ident A) \<star> a = Poset.ident (ob F \<cdot> A) \<star> a"
  by (simp add: valid_identity)

lemma image : "valid F \<Longrightarrow> i \<in> inclusions (space F) \<Longrightarrow> a \<in> Poset.el (ob F \<cdot> (Space.cod i)) \<Longrightarrow>
    ((ar F \<cdot> i) \<star> a) \<in> Poset.el (ob F \<cdot> (Space.dom i)) "
  using Poset.fun_app2 valid_ar
  using valid_cod valid_dom by fastforce

lemma restricted_element :
  fixes F :: "('A, 'a) Prealgebra" and A B :: "'A Open" and a :: "'a"
  assumes F_valid :"valid F"
  and A_open : "A \<in> opens (space F)" and B_open : "B \<in> opens (space F)"
  and B_le_A : "B \<subseteq> A"
  and x_el : "a \<in> el (ob F \<cdot> A)"
defines "i \<equiv> make_inc B A"
shows "(ar F \<cdot> i) \<star> a \<in> el (ob F \<cdot> B)"
  using valid_ar [where ?F=F and ?i=i]
  by (metis (no_types, lifting) A_open B_le_A B_open CollectI F_valid Inclusion.select_convs(1) Inclusion.select_convs(2) i_def image x_el)

(* Restriction *)

lemma res_dom [simp] : "valid F \<Longrightarrow> i \<in> inclusions (space F) \<Longrightarrow> B = Space.cod i \<Longrightarrow> Poset.dom (ar F \<cdot> i) = ob F \<cdot> B"
  using valid_dom by blast

lemma res_cod [simp] : "valid F \<Longrightarrow> i \<in> inclusions (space F) \<Longrightarrow> A = Space.dom i \<Longrightarrow> Poset.cod (ar F \<cdot> i) = ob F \<cdot> A"
  using valid_cod by blast

lemma res_monotone :
  fixes F :: "('A,'a) Prealgebra" and i :: "'A Inclusion" and A B :: "'A Open" and a a' :: "'a"
  defines "FA \<equiv> Prealgebra.ob F \<cdot> A"
  defines "FB \<equiv> Prealgebra.ob F \<cdot> B"
  defines "Fi \<equiv> Prealgebra.ar F \<cdot> i"
  assumes F_valid : "valid F"
  and i_inc : "i \<in> inclusions (space F)"
  and A_open : "A = Space.cod i" and B_open : "B = Space.dom i"
  and a_elem : "a \<in> Poset.el FA" and a'_elem : "a' \<in> Poset.el FA"
  and a_le_a' : "Poset.le FA a a'"
shows "Poset.le FB (Fi \<star> a) (Fi \<star> a')"
proof -
  have "Poset.valid_map Fi"
    using F_valid Fi_def i_inc valid_ar by blast
 moreover have "FA = Poset.dom Fi"
   using A_open FA_def F_valid Fi_def i_inc by auto
moreover have "FB = Poset.cod Fi"
  using B_open FB_def F_valid Fi_def i_inc by force
  moreover have "a \<in> Poset.el FA"
    using A_open FA_def F_valid Fi_def a_elem i_inc by auto
  moreover have "a' \<in> Poset.el FA"
    using A_open FA_def F_valid Fi_def a'_elem i_inc by auto
  ultimately show ?thesis using assms Poset.valid_map_monotone [where ?f="ar F \<cdot> i" and ?a=a and
        ?a'=a']
    by fastforce
qed

lemma diamond_rule :
  fixes F :: "('A, 'a) Prealgebra" and A B C D :: "'A Open" and a :: "'a"
  assumes F_valid :"valid F"
  and A_open : "A \<in> opens (space F)" and B_open : "B \<in> opens (space F)"
  and C_open : "C \<in> opens (space F)" and D_open : "D \<in> opens (space F)"
  and B_le_A : "B \<subseteq> A" and C_le_A : "C \<subseteq> A"
  and D_le_B : "D \<subseteq> B" and D_le_C : "D \<subseteq> C"
  and a_el : "a \<in> el (ob F \<cdot> A)"
  defines "i_BA \<equiv> make_inc B A"
  and "i_CA \<equiv> make_inc C A"
  and "i_DB \<equiv> make_inc D B"
  and "i_DC \<equiv> make_inc D C"
shows "(ar F \<cdot> i_DB) \<star> ((ar F \<cdot> i_BA) \<star> a) = (ar F \<cdot> i_DC) \<star> ((ar F \<cdot> i_CA) \<star> a)"
proof -
  define "i" where "i \<equiv> make_inc D A"
  have "i \<in> inclusions (space F)"
    using A_open B_le_A D_le_B D_open i_def by auto
   moreover have "i_BA \<in> inclusions (space F) \<and> i_CA \<in> inclusions (space F) \<and> i_DB \<in> inclusions (space F) \<and> i_DC \<in> inclusions (space F)"
     by (simp add: A_open B_le_A B_open C_le_A C_open D_le_B D_le_C D_open i_BA_def i_CA_def i_DB_def i_DC_def)
  moreover have "i = i_BA \<propto> i_DB"
    by (simp add: i_BA_def i_DB_def i_def)
  moreover have "i = i_CA \<propto> i_DC"
    by (simp add: i_CA_def i_DC_def i_def)
  moreover have "(ar F \<cdot> i_DB) \<star> ((ar F \<cdot> i_BA) \<star>  a) = (ar F \<cdot> i) \<star> a"
    by (simp add: A_open B_le_A B_open D_le_B D_open F_valid Poset.compose_app_assoc a_el calculation(3) i_BA_def i_DB_def valid_ar valid_composition)
  moreover have "(ar F \<cdot> i_DC) \<star> ((ar F \<cdot> i_CA) \<star>  a) = (ar F \<cdot> i) \<star> a"
    by (simp add: A_open C_le_A C_open D_le_C D_open F_valid Poset.compose_app_assoc a_el calculation(4) i_CA_def i_DC_def valid_ar valid_composition)
  ultimately show ?thesis
    by presburger
qed

(* Forgetful functor from [T, Pos] to [T, Set] *)

definition forget ::  "('A, 'a) Prealgebra \<Rightarrow> ('A, 'a) Presheaf" where
  "forget F \<equiv>
    \<lparr> Presheaf.space = space F,

      ob = \<lparr> Function.cod = { el P | P . P \<in> Function.cod (ob F) },
             func = { (A, el (ob F \<cdot> A)) | A . A \<in> opens (space F) } \<rparr>,

      ar =  \<lparr> Function.cod = { Poset.forget_map f | f . f \<in> Function.cod (ar F) },
             func = { (i, Poset.forget_map (ar F \<cdot> i)) | i . i \<in> inclusions (space F) } \<rparr> \<rparr>"

lemma forget_valid : "valid F \<Longrightarrow> Presheaf.valid (forget F)"
proof (intro Presheaf.validI, clarsimp, goal_cases)
  case 1
  then show ?case using Poset.forget_map_valid forget_def [where ?F=F]
    oops

(* Examples *)

definition const ::  "'A Space \<Rightarrow> ('A, 'a) Prealgebra" where
  "const T \<equiv>
    let
      ob = Function.const (opens T) UNIV Poset.discrete;
      ar = Function.const (inclusions T) UNIV (Poset.ident Poset.discrete)
    in
    \<lparr> space = T, ob = ob, ar = ar \<rparr>"

lemma const_ob [simp] : "Space.valid T \<Longrightarrow> A \<in> opens T \<Longrightarrow> ob (const T) \<cdot> A = Poset.discrete"
  by (smt (verit) Function.const_app Prealgebra.Prealgebra.select_convs(2) Prealgebra.const_def UNIV_I)

lemma const_ar [simp] : "Space.valid T \<Longrightarrow> i \<in> inclusions T \<Longrightarrow> ar (const T) \<cdot> i = Poset.ident Poset.discrete"
  by (metis (no_types, lifting) CollectD CollectI Function.const_app Prealgebra.Prealgebra.select_convs(3) Prealgebra.const_def UNIV_I)

lemma const_value_res [simp] : "Space.valid T \<Longrightarrow> i \<in> inclusions T \<Longrightarrow> a \<in> el (ob (const T) \<cdot> (Space.cod i))
\<Longrightarrow> (ar (const T) \<cdot> i) \<star> a = a"
  by (simp add: discrete_valid)

lemma const_valid : "Space.valid T \<Longrightarrow> valid (const T)"
proof (intro validI, safe, goal_cases)
  case 1
  then show ?case
    by (simp add: Prealgebra.const_def)
next
  case 2
  then show ?case
    by (metis (no_types, lifting) Function.const_valid Prealgebra.Prealgebra.select_convs(2) Prealgebra.const_def UNIV_I valid_universe)
next
  case 3
  then show ?case
    by (metis (no_types, lifting) Function.const_valid Prealgebra.Prealgebra.select_convs(3) Prealgebra.const_def Space.valid_def UNIV_I valid_ident_inc)
next
  case (4 A)
  then show ?case
    by (metis (no_types, lifting) Prealgebra.Prealgebra.select_convs(1) Prealgebra.const_def const_ob discrete_valid)
next
  case (5 i)
  then show ?case
    by (metis (no_types, lifting) Poset.ident_valid Prealgebra.Prealgebra.select_convs(1) Prealgebra.const_def const_ar discrete_valid mem_Collect_eq)
next
  case (6 i)
  then show ?case
    by (metis (no_types, lifting) Poset.ident_dom Prealgebra.Prealgebra.select_convs(1) Prealgebra.const_def const_ar const_ob mem_Collect_eq)
next
  case (7 i)
  then show ?case
    by (metis (no_types, lifting) Poset.ident_cod Prealgebra.Prealgebra.select_convs(1) Prealgebra.const_def const_ar const_ob mem_Collect_eq)
next
  case (8 A)
  then show ?case
    by (metis (no_types, lifting) Prealgebra.Prealgebra.select_convs(1) Prealgebra.const_def const_ar const_ob valid_ident_inc)
next
  case (9 i j)
  then show ?case
    by (smt (verit) Poset.compose_ident_left Poset.ident_cod Poset.ident_valid Prealgebra.Prealgebra.select_convs(1) Prealgebra.const_def cod_compose_inc compose_inc_valid const_ar discrete_valid dom_compose_inc mem_Collect_eq)
qed

abbreviation terminal :: "'A Space \<Rightarrow> ('A, unit) Prealgebra" where
"terminal \<equiv> const"

lemma terminal_ob [simp] : "Space.valid T \<Longrightarrow> A \<in> opens T \<Longrightarrow> ob (terminal T) \<cdot> A = Poset.discrete"
  by simp

lemma terminal_ar [simp] : "Space.valid T \<Longrightarrow> i \<in> inclusions T \<Longrightarrow> ar (terminal T) \<cdot> i = Poset.ident Poset.discrete"
  by simp

lemma terminal_value [simp] : "Space.valid T \<Longrightarrow> A \<in> opens T \<Longrightarrow> Poset.el (ob (terminal T) \<cdot> A) = {()}"
  by (simp add: Poset.discrete_def UNIV_unit)

lemma terminal_value_res [simp] : "Space.valid T \<Longrightarrow> i \<in> inclusions T \<Longrightarrow> (ar (terminal T) \<cdot> i) \<star> a = ()"
  by simp

lemma terminal_valid : "Space.valid T \<Longrightarrow> valid (terminal T)"
  by (simp add: Prealgebra.const_valid)

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_HSortSorts
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Heap = Node "Heap" "int" "Heap" | Nil

fun toHeap :: "int list => Heap list" where
  "toHeap (nil2) = nil2"
| "toHeap (cons2 y z) = cons2 (Node Nil y Nil) (toHeap z)"

fun ordered :: "int list => bool" where
  "ordered (nil2) = True"
| "ordered (cons2 y (nil2)) = True"
| "ordered (cons2 y (cons2 y2 xs)) =
     ((y <= y2) & (ordered (cons2 y2 xs)))"

fun hmerge :: "Heap => Heap => Heap" where
  "hmerge (Node z x2 x3) (Node x4 x5 x6) =
   (if x2 <= x5 then Node (hmerge x3 (Node x4 x5 x6)) x2 z else
      Node (hmerge (Node z x2 x3) x6) x5 x4)"
| "hmerge (Node z x2 x3) (Nil) = Node z x2 x3"
| "hmerge (Nil) y = y"

fun hpairwise :: "Heap list => Heap list" where
  "hpairwise (nil2) = nil2"
| "hpairwise (cons2 p (nil2)) = cons2 p (nil2)"
| "hpairwise (cons2 p (cons2 q qs)) =
     cons2 (hmerge p q) (hpairwise qs)"

(*fun did not finish the proof*)
function hmerging :: "Heap list => Heap" where
  "hmerging (nil2) = Nil"
| "hmerging (cons2 p (nil2)) = p"
| "hmerging (cons2 p (cons2 z x2)) =
     hmerging (hpairwise (cons2 p (cons2 z x2)))"
  by pat_completeness auto

fun toHeap2 :: "int list => Heap" where
  "toHeap2 x = hmerging (toHeap x)"

(*fun did not finish the proof*)
function toList :: "Heap => int list" where
  "toList (Node p y q) = cons2 y (toList (hmerge p q))"
| "toList (Nil) = nil2"
  by pat_completeness auto

fun hsort :: "int list => int list" where
  "hsort x = toList (toHeap2 x)"

theorem property0 :
  "ordered (hsort xs)"
  oops

end


theory ETCS
  imports Main
begin

(* Avoid HOL names interfering *)
hide_const id

(* Declare types for category-theoretic sets and functions *)
typedecl cset
typedecl cfunc

section \<open>Axiom 1: Sets is a Category\<close>

(* Each cfunc is a morphism from its domain to its codomain *)
axiomatization
  domain :: "cfunc \<Rightarrow> cset" and
  codomain :: "cfunc \<Rightarrow> cset" and
  comp :: "cfunc \<Rightarrow> cfunc \<Rightarrow> cfunc" (infixr "\<circ>\<^sub>c" 55) and
  id :: "cset \<Rightarrow> cfunc"
where
  comp_domain: "domain g = codomain f \<Longrightarrow> domain (g \<circ>\<^sub>c f) = domain f" and
  comp_codomain: "domain g = codomain f \<Longrightarrow> codomain (g \<circ>\<^sub>c f) = codomain g" and
  comp_associative: "domain h = codomain g \<Longrightarrow> domain g = codomain f \<Longrightarrow>
    h \<circ>\<^sub>c (g \<circ>\<^sub>c f) = (h \<circ>\<^sub>c g) \<circ>\<^sub>c f" and
  id_domain: "domain (id X) = X" and
  id_codomain: "codomain (id X) = X" and
  id_right_unit: "domain f = X \<Longrightarrow> f \<circ>\<^sub>c id X = f" and
  id_left_unit: "codomain f = Y \<Longrightarrow>  id Y \<circ>\<^sub>c f = f"

definition has_type :: "cfunc \<Rightarrow> cset \<Rightarrow> cset \<Rightarrow> bool" ("_ : _ \<rightarrow> _" [50,50,50]50) where
  "has_type f X Y \<equiv> domain f = X \<and> codomain f = Y"

named_theorems type_rule

lemma comp_type[type_rule]: "f : X \<rightarrow> Y \<Longrightarrow> g : Y \<rightarrow> Z \<Longrightarrow> g \<circ>\<^sub>c f : X \<rightarrow> Z"
  unfolding has_type_def by (simp add: comp_codomain comp_domain)

lemma id_type[type_rule]: "id X : X \<rightarrow> X"
  unfolding has_type_def by (simp add: id_codomain id_domain)

definition monomorphism :: "cfunc \<Rightarrow> bool" where
  "monomorphism f \<longleftrightarrow>
    (\<forall> g h. (codomain g = domain f \<and> codomain h = domain f) \<longrightarrow> (f \<circ>\<^sub>c g = f \<circ>\<^sub>c h \<longrightarrow> g = h))"

definition epimorphism :: "cfunc \<Rightarrow> bool" where
  "epimorphism f \<longleftrightarrow>
    (\<forall> g h. (domain g = codomain f \<and> domain h  = codomain f) \<longrightarrow> (g \<circ>\<^sub>c f = h \<circ>\<^sub>c f \<longrightarrow> g = h))"

ML \<open>
  fun check_cfunc binder_typs (t : term) =
    case fastype_of1 (binder_typs, t) of
      Type (name, []) => name = "ETCS.cfunc"
    | _ => false
\<close>

ML \<open>check_cfunc [] @{term "(\<lambda>x. x \<circ>\<^sub>c f) (id X)"};\<close>

ML \<open>
  fun find_cfunc_terms binder_typs (a $ b) =
        (if check_cfunc binder_typs (a $ b) then [(a $ b)] else [])
          @ find_cfunc_terms binder_typs a @ find_cfunc_terms binder_typs b
    | find_cfunc_terms binder_typs (Abs (n, typ, t)) =
        (if check_cfunc binder_typs (Abs (n, typ, t)) then [(Abs (n, typ, t))] else [])
          @ find_cfunc_terms (typ::binder_typs) t
    | find_cfunc_terms binder_typs t = if check_cfunc binder_typs t then [t] else []
\<close>

ML_val \<open>find_cfunc_terms [] @{term "\<lambda>X. id Y \<circ>\<^sub>c f \<circ>\<^sub>c id X"}\<close>

ML_val \<open>Syntax.pretty_term @{context} @{term "(\<lambda>x. x \<circ>\<^sub>c f) (id X)"};\<close>

ML_val \<open>map (Syntax.pretty_term @{context}) (find_cfunc_terms [] @{term "(\<lambda>x. x \<circ>\<^sub>c f) (id X)"});\<close>

ML \<open>fun match_term bound_typs pat t =
        let fun match_term' bound_typs (pat1 $ pat2) (t1 $ t2) =
                let val (matches1, success1) = match_term' bound_typs pat1 t1
                    val (matches2, success2) = match_term' bound_typs pat2 t2
                in (matches1 @ matches2, success1 andalso success2)
                end
            | match_term' bound_typs (Abs (_, patty, pat)) (Abs (_, ty, t)) =
                let val (matches, success) = match_term' (ty::bound_typs) pat t
                in (matches, success andalso patty = ty)
                end
            | match_term' bound_typs (Var (var, patty)) t =
                if fastype_of1 (bound_typs, t) = patty then ([(var, t)], true) else ([], false)
            | match_term' _ pat t = ([], pat aconv t)
            val (matches, success) = match_term' bound_typs pat t
        in if success then SOME matches else NONE
        end\<close>

ML_val \<open>match_term [] (Thm.full_prop_of @{thm id_type}) @{term "Trueprop (id X : X \<rightarrow> X)"};\<close>

ML \<open>fun extract_type_rule_term rule =
          case Thm.concl_of rule of
            Const ("HOL.Trueprop", _) $ boolrule =>
              (case boolrule of
                (Const ("ETCS.has_type", _) $ t) $ _ $ _ => SOME t
              | _ => NONE)
          | _ => NONE
                \<close>

ML_val \<open>extract_type_rule_term @{thm comp_type}\<close>

ML \<open>fun certify_instantiations ctxt bound_typs =
      List.map (fn (x : indexname, t) => ((x, fastype_of1 (bound_typs, t)), Thm.cterm_of ctxt t)) \<close>

ML \<open>fun match_type_rule ctxt bound_typs t rule =
          let val opt_insts =
                case extract_type_rule_term rule of
                  SOME pat => match_term bound_typs pat t
                | NONE => NONE
              val opt_insts' = Option.map (certify_instantiations ctxt bound_typs) opt_insts
          in case opt_insts' of
              SOME insts => SOME (Thm.instantiate ([], insts) rule)
            | NONE => NONE
          end\<close>

(* avoid creating an exception -- tactics aren't supposed to raise exceptions *)
(*ML \<open>exception CFUNC_TYPE of string * term list * thm list\<close>*)

ML \<open>fun find_type_rule _ _ _ [] = NONE (* no typing rules left *)
      | find_type_rule ctxt bound_typs t (rule::rules) =
          case match_type_rule ctxt bound_typs t rule of
            SOME rule' => SOME rule'
          | NONE => find_type_rule ctxt bound_typs t rules\<close>

ML_val \<open>match_type_rule @{context} [] @{term "f \<circ>\<^sub>c id X"} @{thm comp_type}\<close>

ML \<open>fun elim_type_rule_prem _ _ _ [] = NONE (* no lemmas match the premise *)
      | elim_type_rule_prem ctxt thm prem (lem::lems) =
          case match_term [] prem (Thm.prop_of lem) of
            SOME insts =>
              let val insts' = certify_instantiations ctxt [] insts
                  val inst_thm = Thm.instantiate ([], insts') thm
              in SOME (Thm.implies_elim inst_thm lem)
              end
          | NONE => elim_type_rule_prem ctxt thm prem lems\<close>

ML_val \<open>let val type_rule = the (match_type_rule @{context} [] @{term "f \<circ>\<^sub>c id X"} @{thm comp_type})
        in elim_type_rule_prem @{context} type_rule (List.hd (Thm.prems_of type_rule))
              [the (match_type_rule @{context} [] @{term "id X"} @{thm id_type})]
        end\<close>

ML \<open>fun elim_type_rule_prems ctxt thm lems =
          let fun elim_type_rule_prems' thm [] = thm
                | elim_type_rule_prems' thm (prem::prems) =
                    case elim_type_rule_prem ctxt thm prem lems of
                      SOME thm' => elim_type_rule_prems' thm' prems
                    | NONE => (* can't eliminate premise, shift it to the back and continue *)
                        elim_type_rule_prems' (Thm.permute_prems 0 1 thm) prems
          in elim_type_rule_prems' thm (Thm.prems_of thm)
          end\<close>

ML_val \<open>let val type_rule = the (match_type_rule @{context} [] @{term "f \<circ>\<^sub>c id X"} @{thm comp_type})
        in elim_type_rule_prems @{context} type_rule
              [the (match_type_rule @{context} [] @{term "id X"} @{thm id_type}),
                Thm.assume (Thm.cterm_of @{context} @{term "Trueprop (f : X \<rightarrow> Y)"})]
        end\<close>

ML \<open>fun construct_cfunc_type_lemma ctxt rules binder_typs lems t =
          case find_type_rule ctxt binder_typs t rules of
            SOME rule => [elim_type_rule_prems ctxt rule lems]
          | NONE => []\<close>

ML \<open>fun construct_cfunc_type_lemmas1 ctxt rules binder_typs (t $ u) =
          let val left_lems = construct_cfunc_type_lemmas1 ctxt rules binder_typs t
              val right_lems = construct_cfunc_type_lemmas1 ctxt rules binder_typs u
              val sublems = left_lems @ right_lems
              val this_lem =
                if check_cfunc binder_typs (t $ u)
                then construct_cfunc_type_lemma ctxt rules binder_typs sublems (t $ u)
                else []
          in this_lem @ sublems
          end
      | construct_cfunc_type_lemmas1 ctxt rules binder_typs (Abs (n, typ, t)) =
          let val sublems = construct_cfunc_type_lemmas1 ctxt rules (typ::binder_typs) t
              val this_lem = if check_cfunc binder_typs (Abs (n, typ, t))
                then construct_cfunc_type_lemma ctxt rules binder_typs sublems (Abs (n, typ, t))
                else []
          in this_lem @ sublems
          end
      | construct_cfunc_type_lemmas1 ctxt rules binder_typs t =
          if check_cfunc binder_typs t then construct_cfunc_type_lemma ctxt rules binder_typs [] t else []\<close>

(* assume there are no binders at the toplevel *)
ML \<open>fun construct_cfunc_type_lemmas ctxt rules t = construct_cfunc_type_lemmas1 ctxt rules [] t\<close>

ML_val \<open>let val type_rules = [Thm.assume (Thm.cterm_of @{context} @{term "Trueprop (f : X \<rightarrow> Y)"}),
                  @{thm id_type}, @{thm comp_type}]
        in construct_cfunc_type_lemmas @{context} type_rules @{term "id Y \<circ>\<^sub>c f \<circ>\<^sub>c id X"}
        end;\<close>

ML \<open>fun extract_prems ((@{term Trueprop}) $ P) = extract_prems P
      | extract_prems (@{term "Pure.imp"} $ P $ Q) = P::extract_prems Q
      | extract_prems _ = []\<close>

ML \<open>fun typecheck_cfuncs_subtac ctxt type_rules (subgoal, n) =
          let val type_rules' = type_rules @ Named_Theorems.get ctxt "ETCS.type_rule"
              val lems = construct_cfunc_type_lemmas ctxt type_rules' subgoal
          in (Method.insert_tac ctxt lems n THEN asm_full_simp_tac ctxt n)
          end\<close>

ML \<open>fun typecheck_cfuncs_tac ctxt type_rules = SUBGOAL (typecheck_cfuncs_subtac ctxt type_rules)\<close>

ML \<open>fun typecheck_cfuncs_method ctxt = (fn thms => CONTEXT_TACTIC (typecheck_cfuncs_tac ctxt thms 1)) : Method.method\<close>

method_setup typecheck_cfuncs =
  \<open>Scan.succeed typecheck_cfuncs_method\<close>
  "Check types of cfuncs in current goal and add as assumptions of the current goal"

  print_methods

section \<open>Axiom 2: Cartesian Products\<close>

axiomatization
  cart_prod :: "cset \<Rightarrow> cset \<Rightarrow> cset" (infixr "\<times>\<^sub>c" 70) and
  left_cart_proj :: "cset \<Rightarrow> cset \<Rightarrow> cfunc" and
  right_cart_proj :: "cset \<Rightarrow> cset \<Rightarrow> cfunc" and
  cfunc_prod :: "cfunc \<Rightarrow> cfunc \<Rightarrow> cfunc" ("\<langle>_,_\<rangle>")
where
  left_cart_proj_type: "left_cart_proj X Y : X \<times>\<^sub>c Y \<rightarrow> X" and
  right_cart_proj_type: "right_cart_proj X Y : X \<times>\<^sub>c Y \<rightarrow> Y" and
  cfunc_prod_type: "f : Z \<rightarrow> X \<Longrightarrow> g : Z \<rightarrow> Y \<Longrightarrow> \<langle>f,g\<rangle> : Z \<rightarrow> X \<times>\<^sub>c Y" and
  left_cart_proj_cfunc_prod: "f : Z \<rightarrow> X \<Longrightarrow> g : Z \<rightarrow> Y \<Longrightarrow> left_cart_proj X Y \<circ>\<^sub>c \<langle>f,g\<rangle> = f" and
  right_cart_proj_cfunc_prod: "f : Z \<rightarrow> X \<Longrightarrow> g : Z \<rightarrow> Y \<Longrightarrow> right_cart_proj X Y \<circ>\<^sub>c \<langle>f,g\<rangle> = g" and
  cfunc_prod_unique: "f : Z \<rightarrow> X \<Longrightarrow> g : Z \<rightarrow> Y \<Longrightarrow> h : Z \<rightarrow> X \<times>\<^sub>c Y \<Longrightarrow>
    left_cart_proj X Y \<circ>\<^sub>c h = f \<Longrightarrow> right_cart_proj X Y \<circ>\<^sub>c h = g \<Longrightarrow> h = \<langle>f,g\<rangle>"

subsection \<open>Function cross product\<close>

definition cfunc_cross_prod :: "cfunc \<Rightarrow> cfunc \<Rightarrow> cfunc" (infixr "\<times>\<^sub>f" 65) where
  "f \<times>\<^sub>f g = \<langle>f \<circ>\<^sub>c left_cart_proj (domain f) (domain g), g \<circ>\<^sub>c right_cart_proj (domain f) (domain g)\<rangle>"

lemma cfunc_cross_prod_def2:
  assumes "domain f = X" "domain g = Y"
  shows "f \<times>\<^sub>f g = \<langle>f \<circ>\<^sub>c left_cart_proj X Y, g \<circ>\<^sub>c right_cart_proj X Y\<rangle>"
  unfolding cfunc_cross_prod_def using assms by auto

lemma cfunc_cross_prod_domain:
  "f : X \<rightarrow> Z \<Longrightarrow> g : Y \<rightarrow> W \<Longrightarrow> f \<times>\<^sub>f g : X \<times>\<^sub>c Y \<rightarrow> Z \<times>\<^sub>c W"
  unfolding cfunc_cross_prod_def unfolding has_type_def
  apply (auto simp add: cfunc_prod_type comp_type left_cart_proj_type right_cart_proj_type)
  using cfunc_prod_type comp_type has_type_def left_cart_proj_type right_cart_proj_type apply auto[1]

lemma left_cfunc_cross_prod:
  assumes "f : X \<rightarrow> Z" "g : Y \<rightarrow> W"
  shows "left_cart_proj Z W \<circ>\<^sub>c (f \<times>\<^sub>f g) = f \<circ>\<^sub>c left_cart_proj X Y"
  unfolding cfunc_cross_prod_def
  by (simp add: assms comp_type left_cart_proj_cfunc_prod left_cart_proj_type right_cart_proj_type)

lemma right_cfunc_cross_prod:
  assumes "f : X \<rightarrow> Z" "g : Y \<rightarrow> W"
  shows "right_cart_proj Z W \<circ>\<^sub>c (f \<times>\<^sub>f g) = g \<circ>\<^sub>c right_cart_proj X Y"
  using assms type_rules by (unfold cfunc_cross_prod_def2, simp add: right_cart_proj_cfunc_prod)

lemma cfunc_cross_prod_unique:
  "f : W \<rightarrow> Y \<Longrightarrow> g : X \<rightarrow> Z \<Longrightarrow> h : W \<times>\<^sub>c X \<rightarrow> Y \<times>\<^sub>c Z \<Longrightarrow>
    left_cart_proj Y Z \<circ>\<^sub>c h = f \<circ>\<^sub>c left_cart_proj W X \<Longrightarrow>
    right_cart_proj Y Z \<circ>\<^sub>c h = g \<circ>\<^sub>c right_cart_proj W X \<Longrightarrow> h = f \<times>\<^sub>f g"
  by (simp add: cfunc_cross_prod_def2 cfunc_prod_unique type_rules)

lemma cross_prod_comp_dist:
  assumes f_type: "f : A \<rightarrow> B" and g_type: "g : B \<rightarrow> C" and h_type: "h : X \<rightarrow> Y"
  shows "h \<times>\<^sub>f (g \<circ>\<^sub>c f) = (h \<times>\<^sub>f g) \<circ>\<^sub>c (id X \<times>\<^sub>f f)"
proof -
  have left: "left_cart_proj Y C \<circ>\<^sub>c h \<times>\<^sub>f g \<circ>\<^sub>c id X \<times>\<^sub>f f = h \<circ>\<^sub>c left_cart_proj X A"
    (is "?lhs = ?rhs")
  proof -
    have "?lhs = (h \<circ>\<^sub>c left_cart_proj X B) \<circ>\<^sub>c id X \<times>\<^sub>f f"
      using assms type_rules comp_associative left_cfunc_cross_prod by auto
    also have "... = h \<circ>\<^sub>c (left_cart_proj X B \<circ>\<^sub>c id X \<times>\<^sub>f f)"
      using assms type_rules comp_associative by auto
    also have "... = ?rhs"
      using assms type_rules left_cfunc_cross_prod id_left_unit by auto
    then show ?thesis using calculation by auto
  qed

  have right: "right_cart_proj Y C \<circ>\<^sub>c h \<times>\<^sub>f g \<circ>\<^sub>c id X \<times>\<^sub>f f = g \<circ>\<^sub>c f \<circ>\<^sub>c right_cart_proj X A"
    (is "?lhs = ?rhs")
  proof -
    have "?lhs = (g \<circ>\<^sub>c right_cart_proj X B) \<circ>\<^sub>c id X \<times>\<^sub>f f"
      using assms type_rules comp_associative right_cfunc_cross_prod by auto
    also have "... = g \<circ>\<^sub>c (right_cart_proj X B \<circ>\<^sub>c id X \<times>\<^sub>f f)"
      using assms type_rules comp_associative by auto
    also have "... = ?rhs"
      using assms type_rules right_cfunc_cross_prod id_left_unit by auto
    then show ?thesis using calculation by auto
  qed

  print_methods

  have "h \<times>\<^sub>f g \<circ>\<^sub>c id Y \<times>\<^sub>f f = h \<times>\<^sub>f (g \<circ>\<^sub>c f)"
    using assms left right type_rules
    apply (subst cfunc_cross_prod_unique[where h="(h \<times>\<^sub>f g) \<circ>\<^sub>c (id Y \<times>\<^sub>f f)", where f=h, where g = "g \<circ>\<^sub>c f", where W=X, where Y=Y, where X=A, where Z=C])
    using assms left right type_rules apply (auto)

    thm type_rules
      thm comp_assoc

      thm cfunc_cross_prod_unique
  thm cfunc_cross_prod_unique[where h="(h \<times>\<^sub>f g) \<circ>\<^sub>c (id Y \<times>\<^sub>f f)", where f=h, where g = "g \<circ>\<^sub>c f", where W=X, where Y=Y, where X=A, where Z=C]
  thm cfunc_cross_prod_unique[where f=h, where g = "g \<circ>\<^sub>c f", where W=X, where Y=Y, where X=A, where Z=C]

  have "left_cart_proj X C \<circ>\<^sub>c (h \<times>\<^sub>f g) \<circ>\<^sub>c (h \<times>\<^sub>f f) = h"

  from cfunc_cross_prod_unique
  have uniqueness: "\<forall>h. h : X \<times>\<^sub>c A \<rightarrow> X \<times>\<^sub>c C \<and>
    left_cart_proj X C \<circ>\<^sub>c h = id\<^sub>c X \<circ>\<^sub>c left_cart_proj X A \<and>
    right_cart_proj X C \<circ>\<^sub>c h = (g \<circ>\<^sub>c f) \<circ>\<^sub>c right_cart_proj X A \<longrightarrow>
    h = id\<^sub>c X \<times>\<^sub>f (g \<circ>\<^sub>c f)"
    by (meson comp_type f_type g_type id_type)

  have step1: "(id\<^sub>c X \<times>\<^sub>f g) \<circ>\<^sub>c (id\<^sub>c X \<times>\<^sub>f f) : X \<times>\<^sub>c A \<rightarrow> X \<times>\<^sub>c C"
    by (meson cfunc_cross_prod_type comp_type f_type g_type id_type)
  have step2: "left_cart_proj X C \<circ>\<^sub>c (id\<^sub>c X \<times>\<^sub>f g) \<circ>\<^sub>c (id\<^sub>c X \<times>\<^sub>f f) = id\<^sub>c X \<circ>\<^sub>c left_cart_proj X A"
    by (smt comp_associative f_type g_type id_domain id_right_unit id_type left_cart_proj_cfunc_cross_prod)
  have step3: "right_cart_proj X C \<circ>\<^sub>c (id\<^sub>c X \<times>\<^sub>f g) \<circ>\<^sub>c (id\<^sub>c X \<times>\<^sub>f f) = (g \<circ>\<^sub>c f) \<circ>\<^sub>c right_cart_proj X A"
    by (smt comp_associative f_type g_type id_type right_cart_proj_cfunc_cross_prod)

  show "id\<^sub>c X \<times>\<^sub>f (g \<circ>\<^sub>c f) = id\<^sub>c X \<times>\<^sub>f g \<circ>\<^sub>c id\<^sub>c X \<times>\<^sub>f f"
    using uniqueness step1 step2 step3 by force
qed

lemma id_cross_prod: "id X \<times>\<^sub>f id Y = id (X \<times>\<^sub>c Y)"
  unfolding cfunc_cross_prod_def
  by (metis cfunc_prod_unique id_left_unit id_right_unit id_type left_cart_proj_type right_cart_proj_type)

section \<open>Axiom 3: Terminal Objects\<close>

axiomatization
  terminal_func :: "cset \<Rightarrow> cfunc" ("\<beta>\<^bsub>_\<^esub>" 100) and
  one :: "cset" ("\<^bold>1")
where
  terminal_func_type: "\<beta>\<^bsub>X\<^esub> : X \<rightarrow> \<^bold>1" and
  terminal_func_unique: "h :  X \<rightarrow> \<^bold>1 \<Longrightarrow> h = \<beta>\<^bsub>X\<^esub>" and
  one_separator: "f : X \<rightarrow> Y \<Longrightarrow> g : X \<rightarrow> Y \<Longrightarrow> (\<And> x. x : \<^bold>1 \<rightarrow> X \<Longrightarrow> f \<circ>\<^sub>c x = g \<circ>\<^sub>c x) \<Longrightarrow> f = g"

section \<open>Membership and subsets\<close>

abbreviation member :: "cfunc \<Rightarrow> cset \<Rightarrow> bool" (infix "\<in>\<^sub>c" 50) where
  "x \<in>\<^sub>c X \<equiv> (x : one \<rightarrow> X)"

definition subobject_of :: "cset \<times> cfunc \<Rightarrow> cset \<Rightarrow> bool" (infix "\<subseteq>\<^sub>c" 50)
  where "B \<subseteq>\<^sub>c X \<longleftrightarrow> (snd B : fst B \<rightarrow> X \<and> monomorphism (snd B))"

lemma subobject_of_def2:
  "(B,m) \<subseteq>\<^sub>c X = (m : B \<rightarrow> X \<and> monomorphism m)"
  by (simp add: subobject_of_def)

definition relative_subset :: "cset \<times> cfunc \<Rightarrow> cset \<Rightarrow> cset \<times> cfunc \<Rightarrow> bool" ("_\<subseteq>\<^bsub>_\<^esub>_" [51,50,51]50)
  where "B \<subseteq>\<^bsub>X\<^esub> A  \<longleftrightarrow>
    (snd B : fst B \<rightarrow> X \<and> monomorphism (snd B) \<and> snd A : fst A \<rightarrow> X \<and> monomorphism (snd A)
          \<and> (\<exists> k. k: fst B \<rightarrow> fst A \<and> snd A \<circ>\<^sub>c k = snd B))"

lemma relative_subset_def2:
  "(B,m) \<subseteq>\<^bsub>X\<^esub> (A,n) = (m : B \<rightarrow> X \<and> monomorphism m \<and> n : A \<rightarrow> X \<and> monomorphism n
          \<and> (\<exists> k. k: B \<rightarrow> A \<and> n \<circ>\<^sub>c k = m))"
  unfolding relative_subset_def by auto

lemma subobject_is_relative_subset: "(B,m) \<subseteq>\<^sub>c A \<longleftrightarrow> (B,m) \<subseteq>\<^bsub>A\<^esub> (A, id(A))"
  unfolding relative_subset_def2 subobject_of_def2 by (metis id_left_unit id_type monomorphism_def)

definition factors_through :: "cfunc  \<Rightarrow> cfunc \<Rightarrow> bool" (infix "factorsthru" 90)
  where "g factorsthru f \<longleftrightarrow> (\<exists> h. (h: domain(g)\<rightarrow> domain(f)) \<and> f \<circ>\<^sub>c h = g)"

definition relative_member :: "cfunc \<Rightarrow> cset \<Rightarrow> cset \<times> cfunc \<Rightarrow> bool" ("_ \<in>\<^bsub>_\<^esub> _" [51,50,51]50) where
  "x \<in>\<^bsub>X\<^esub> B \<longleftrightarrow> (x \<in>\<^sub>c X \<and> monomorphism (snd B) \<and> snd B : fst B \<rightarrow> X \<and> x factorsthru (snd B))"

lemma relative_member_def2:
  "x \<in>\<^bsub>X\<^esub> (B, m) = (x \<in>\<^sub>c X \<and> monomorphism m \<and> m : B \<rightarrow> X \<and> x factorsthru m)"
  unfolding relative_member_def by auto

section \<open>Axiom 4: Equalizers\<close>

definition equalizer :: "cset \<Rightarrow> cfunc \<Rightarrow> cfunc \<Rightarrow> cfunc \<Rightarrow> bool" where
  "equalizer E m f g \<longleftrightarrow> (\<exists> X Y. (f : X \<rightarrow> Y) \<and> (g : X \<rightarrow> Y) \<and> (m : E \<rightarrow> X)
    \<and> (f \<circ>\<^sub>c m = g \<circ>\<^sub>c m)
    \<and> (\<forall> h F. (h : F \<rightarrow> X \<and> (f \<circ>\<^sub>c h = g \<circ>\<^sub>c h)) \<longrightarrow> (\<exists>! k. (k : F \<rightarrow> E) \<and> m \<circ>\<^sub>c k = h)))"

axiomatization where
  equalizer_exists: "f : X \<rightarrow> Y \<Longrightarrow> g : X \<rightarrow> Y \<Longrightarrow> \<exists> E m. equalizer E m f g"

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

definition square_commutes :: "cset \<Rightarrow> cset \<Rightarrow> cset \<Rightarrow> cset \<Rightarrow> cfunc \<Rightarrow> cfunc \<Rightarrow> cfunc \<Rightarrow> cfunc \<Rightarrow> bool" where
  "square_commutes A B C D ab bd ac cd \<longleftrightarrow>
    ((ab : A \<rightarrow> B) \<and> (bd : B \<rightarrow> D) \<and> (ac : A \<rightarrow> C) \<and> (cd : C \<rightarrow> D) \<and> (bd \<circ>\<^sub>c ab = cd \<circ>\<^sub>c ac))"

definition is_pullback :: "cset \<Rightarrow> cset \<Rightarrow> cset \<Rightarrow> cset \<Rightarrow> cfunc \<Rightarrow> cfunc \<Rightarrow> cfunc \<Rightarrow> cfunc \<Rightarrow> bool" where
  "is_pullback A B C D ab bd ac cd \<longleftrightarrow>
    (square_commutes A B C D ab bd ac cd \<and>
    (\<forall> Z k h. (k : Z \<rightarrow> B \<and> h : Z \<rightarrow> C \<and> bd \<circ>\<^sub>c k = cd \<circ>\<^sub>c h)  \<longrightarrow>
      (\<exists>! j. j : Z \<rightarrow> A \<and> ab \<circ>\<^sub>c j = k \<and> ac \<circ>\<^sub>c j = h)))"

axiomatization
  true_func :: "cfunc" ("\<t>") and
  false_func  :: "cfunc" ("\<f>") and
  truth_value_set :: "cset" ("\<Omega>")
where
  true_func_type: "\<t> \<in>\<^sub>c \<Omega>" and
  false_func_type: "\<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>. \<chi> : X \<rightarrow> \<Omega> \<and> \<t> \<circ>\<^sub>c \<beta>\<^bsub>B\<^esub> = \<chi> \<circ>\<^sub>c m \<and>
        (\<forall>Z k h. k : Z \<rightarrow> \<^bold>1 \<and> h : Z \<rightarrow> X \<and> \<t> \<circ>\<^sub>c k = \<chi> \<circ>\<^sub>c h \<longrightarrow>
          (\<exists>!j. j : Z \<rightarrow> B \<and> \<beta>\<^bsub>B\<^esub> \<circ>\<^sub>c j = k \<and> m \<circ>\<^sub>c j = h)))"
  (* is_pullback B one X \<Omega> (\<beta>\<^bsub>B\<^esub>) \<t> m \<chi> *)

section  \<open>Axiom 6: Equivalence Classes\<close>

definition reflexive :: "cset \<Rightarrow> bool" where
  "reflexive R = (\<exists> X m. (R,m) \<subseteq>\<^sub>c X\<times>\<^sub>cX \<and>
    (\<forall>x. x \<in>\<^sub>c X \<longrightarrow>
      (\<langle>x,x\<rangle> \<in>\<^bsub>X\<times>\<^sub>cX\<^esub> (R, m))))"

definition symmetric :: "cset \<Rightarrow> bool" where
  "symmetric R = (\<exists> X m. (R,m)  \<subseteq>\<^sub>c X\<times>\<^sub>cX \<and>
    (\<forall>x y. x \<in>\<^sub>c X \<and>  y \<in>\<^sub>c X \<longrightarrow>
      (\<langle>x,y\<rangle> \<in>\<^bsub>X\<times>\<^sub>cX\<^esub> (R, m) \<longrightarrow> \<langle>y,x\<rangle> \<in>\<^bsub>X\<times>\<^sub>cX\<^esub> (R, m))))"

definition transitive :: "cset \<Rightarrow> bool" where
  "transitive R = (\<exists> X m. (R,m)  \<subseteq>\<^sub>c X\<times>\<^sub>cX \<and>
    (\<forall>x y z. x \<in>\<^sub>c X \<and>  y \<in>\<^sub>c X \<and> z \<in>\<^sub>c X  \<longrightarrow>
      (\<langle>x,y\<rangle> \<in>\<^bsub>X\<times>\<^sub>cX\<^esub> (R, m) \<and> \<langle>y,z\<rangle> \<in>\<^bsub>X\<times>\<^sub>cX\<^esub> (R, m)
        \<longrightarrow> \<langle>x,z\<rangle> \<in>\<^bsub>X\<times>\<^sub>cX\<^esub> (R, m))))"

definition equivalance_rel :: "cset \<Rightarrow> bool" where
  "equivalance_rel R  \<longleftrightarrow> (reflexive R \<and> symmetric R \<and> transitive R)"

section  \<open>Axiom 7: Coproducts\<close>

axiomatization
  coprod :: "cset \<Rightarrow> cset \<Rightarrow> cset" (infixr "\<Coprod>" 65) and
  left_coproj :: "cset \<Rightarrow> cset \<Rightarrow> cfunc" and
  right_coproj :: "cset \<Rightarrow> cset \<Rightarrow> cfunc" and
  cfunc_coprod :: "cfunc \<Rightarrow> cfunc \<Rightarrow> cfunc" (infixr "\<amalg>" 65)
where
  left_proj_type: "left_coproj X Y : X \<rightarrow> X\<Coprod>Y" and
  right_proj_type: "right_coproj X Y : Y \<rightarrow> X\<Coprod>Y" and
  cfunc_coprod_type: "f : X \<rightarrow> Z \<Longrightarrow> g : Y \<rightarrow> Z \<Longrightarrow> f\<amalg>g :  X\<Coprod>Y \<rightarrow> Z" and
  left_coproj_cfunc_coprod: "f : X \<rightarrow> Z \<and> g : Y \<rightarrow> Z \<Longrightarrow> f\<amalg>g \<circ>\<^sub>c (left_coproj X Y) = f" and
  right_coproj_cfunc_coprod: "f : X \<rightarrow> Z \<Longrightarrow> g : Y \<rightarrow> Z \<Longrightarrow> f\<amalg>g \<circ>\<^sub>c (right_coproj X Y)  = g" and
  cfunc_coprod_unique: "f : X \<rightarrow> Z \<Longrightarrow> g : Y \<rightarrow> Z \<Longrightarrow>
    h : X \<Coprod> Y \<rightarrow> Z \<Longrightarrow> (h \<circ>\<^sub>c left_coproj X Y = f) \<Longrightarrow> (h \<circ>\<^sub>c right_coproj X Y = g) \<Longrightarrow>  h = f\<amalg>g"

section  \<open>Axiom 8: Empty Set\<close>

axiomatization
  initial_func :: "cset \<Rightarrow> cfunc" ("\<alpha>\<^bsub>_\<^esub>" 100) and
  emptyset :: "cset" ("\<emptyset>")
where
  initial_func_type: "\<alpha>\<^bsub>X\<^esub> : \<emptyset> \<rightarrow> X" and
  initial_func_unique: "h : \<emptyset> \<rightarrow> X \<Longrightarrow> h = \<alpha>\<^bsub>X\<^esub>" and
  emptyset_is_empty: "\<not> (x \<in>\<^sub>c \<emptyset>)"

section \<open>Axiom 9: Exponential Objects\<close>

axiomatization
  exp_set :: "cset \<Rightarrow> cset \<Rightarrow> cset" ("_\<^bsup>_\<^esup>" [100,100]100) and
  eval_func  :: "cset \<Rightarrow> cset \<Rightarrow> cfunc" and
  transpose_func :: "cfunc \<Rightarrow> cfunc" ("_\<^sup>\<sharp>" [100]100)
where
  eval_func_type: "eval_func X A : A\<times>\<^sub>c X\<^bsup>A\<^esup> \<rightarrow> X" and
  transpose_func_def: "f : A \<times>\<^sub>c Z \<rightarrow> X \<Longrightarrow> f\<^sup>\<sharp> : Z \<rightarrow> X\<^bsup>A\<^esup> \<and> (eval_func X A) \<circ>\<^sub>c (id A) \<times>\<^sub>f (f\<^sup>\<sharp>) = f" and
  transpose_func_unique: "f : A\<times>\<^sub>cZ \<rightarrow> X \<Longrightarrow> g: Z \<rightarrow> X\<^bsup>A\<^esup> \<Longrightarrow> (eval_func X A) \<circ>\<^sub>c (id A) \<times>\<^sub>f g = f \<Longrightarrow> g = f\<^sup>\<sharp>"

section \<open>Axiom 10: Natural Number Object\<close>

axiomatization
  natural_numbers :: "cset" ("\<nat>\<^sub>c") and
  zero :: "cfunc" and
  successor :: "cfunc"
  where
  zero_type: "zero \<in>\<^sub>c \<nat>\<^sub>c" and
  successor_type: "successor: \<nat>\<^sub>c \<rightarrow> \<nat>\<^sub>c" and
  natural_number_object_property:
    "q : one \<rightarrow> X \<Longrightarrow> f: X \<rightarrow> X \<Longrightarrow> (\<exists>!u. u: \<nat>\<^sub>c \<rightarrow> X \<and> u \<circ>\<^sub>c zero = q \<and> u \<circ>\<^sub>c successor = f \<circ>\<^sub>c u)"

section \<open>Axiom 11: Axiom of Choice\<close>

definition section_of :: "cfunc \<Rightarrow> cfunc \<Rightarrow> bool" (infix "sectionof" 90)
  where "s sectionof f \<longleftrightarrow> s : codomain(f) \<rightarrow> domain(f) \<and> f \<circ>\<^sub>c s = id (codomain(f))"

axiomatization
  where
  axiom_of_choice :"epimorphism(f) \<longrightarrow> (\<exists> g . g sectionof f)"

end


theory Minimal
  imports VDMToolkit
begin

text \<open>VDM constans defined with abbreviation\<close>

abbreviation
  M :: "VDMInt"
where
  "M \<equiv> 10"

text \<open>VDM types and invariant defined with type synonym and definition\<close>

type_synonym T1 = VDMNat1

(* Blue = free; Green = bound; Black = previously defined *)
definition
  inv_T1 :: "VDMNat1 \<Rightarrow> \<bool>"
  where
  "inv_T1 t \<equiv> inv_VDMNat1 t \<and> t \<le> M"

value "inv_T1 (-1)"

text \<open>VDM functions defined in stages: explicit definition followed by pre/post specification\<close>

definition
  f :: "T1 \<Rightarrow> T1"
  where
  "f x \<equiv> x + 1"

definition
  pre_f :: "T1 \<Rightarrow> \<bool>"
  where
  "pre_f x \<equiv>
    inv_T1 x
    \<and>
    True"

definition
  post_f :: "T1 \<Rightarrow> T1 \<Rightarrow> \<bool>"
  where
  "post_f x RESULT \<equiv>
    inv_T1 RESULT
    \<and>
    x < RESULT"

text \<open>VDM PO for feasibility of function\<close>

definition
  PO_Minimal_f_FSB :: "\<bool>"
  where
  "PO_Minimal_f_FSB \<equiv> \<forall> x . pre_f x \<longrightarrow> (\<exists> RESULT . RESULT = f x \<and> post_f x RESULT)"

lemma PO_Minimal_f_simp:
  "PO_Minimal_f_FSB = (\<forall> x . pre_f x \<longrightarrow> post_f x (x+1))"
  unfolding PO_Minimal_f_FSB_def f_def
  by simp

definition
  PO_Minimal_f_FSBs :: "\<bool>"
  where
  "PO_Minimal_f_FSBs \<equiv> \<forall> x . pre_f x \<longrightarrow> post_f x (x+1)"

theorem PO_Minimal_f_FSBs
  unfolding PO_Minimal_f_FSBs_def
  apply safe
  unfolding pre_f_def post_f_def
  apply simp
  unfolding inv_T1_def inv_VDMNat1_def
  apply simp
  nitpick
  oops

theorem PO_Minimal_f_FSBs
  unfolding PO_Minimal_f_FSBs_def
  unfolding pre_f_def post_f_def inv_T1_def inv_VDMNat1_def
  nitpick
  oops

text \<open> Exercise: fix pre of f to satisfy its FSB PO \<close>

text \<open>VDM state is modelled state as a record, and operations as functions with
      extra state parameters

   Records are created with "banana brackets": "(" + "|" and "|" ")".\<close>

record S =
  t1 :: "T1"
  t2 :: "T1"

(* s.t1.   t1: S \<Rightarrow> T1
   s.t2    t2: S \<Rightarrow> T1
*)

term "t1"
value "\<lparr>t1 = 1, t2 = 10\<rparr>"

value "t2 \<lparr>t1 = 1, t2 = 10\<rparr>"

text \<open>The record fields are assessed via projection functions @{term t1} and @{term t2}
      That is, given an S, (t1 S) returns the T1 value for t1 in S; the same for T2\<close>

term t1 term t2

text \<open>Record values in VDM use a mk_S(2,1) constructor, whereas in Isabelle we
      have banana-brackets. \<close>
value "\<lparr>t1 = 2, t2 = 1\<rparr>"

text \<open>Record projection in VDM is with "." notation, as in S.t1, whereas in Isabelle this is
    through functions as in (t1 S), where t1 is a function from S to the type of t1, which is T1.

   Notice this makes t1 and t2 defined names, which cannot be reused (e.g. parameters to op)\<close>

value "t1 \<lparr>t1 = 2, t2 = 1\<rparr> = 2"
value "t2 \<lparr>t1 = 2, t2 = 1\<rparr> = 1"

text \<open>Like with types, the state invariant and initialisation is defined with definition\<close>

definition
  inv_S :: "S \<Rightarrow> \<bool>"
  where
  "inv_S s \<equiv> inv_T1 (t1 s) \<and> inv_T1 (t2 s) \<and> (t1 s) < (t2 s)"
(* t1(s) (t1 s) *)

definition
  init_S :: "S"
  where
  "init_S \<equiv> \<lparr>t1 = 1, t2 = 10\<rparr>"

value "inv_S \<lparr>t1 = 9, t2 = 7\<rparr>"
value "inv_S init_S"

text \<open>We also have to show (i.e. it's a VDM PO) that the initialisation satisfied the state invariant.\<close>
definition
  inv_init_S :: "\<bool>"
  where
  "inv_init_S \<equiv> inv_S init_S"

lemma inv_init_S
  unfolding inv_init_S_def inv_S_def
            init_S_def inv_T1_def inv_VDMNat1_def
  by simp

text \<open> Record updates can be made either explicitly with ":=", or the record can be reconstructed\<close>
value "let s = \<lparr>t1 = 2, t2 = 1\<rparr> in s\<lparr>t1 := 4\<rparr>"
value "let s = \<lparr>t1 = 2, t2 = 1\<rparr> in \<lparr>t1 = 4, t2 = (t2 s)\<rparr>"
value "let s = \<lparr>t1 = 2, t2 = 1\<rparr> in s\<lparr>t1 := 4\<rparr> = \<lparr>t1 = 4, t2 = (t2 s)\<rparr>"

text \<open>For operations, input parameters and state are given and state updates and results have
      to be returned. There are different approaches, yet chained let assignments can be used to
      represent various imperative constructs such as sequential composition, assignments,
      selection/if/case, etc.

   Notice Isabelle prefers Curried functions (i,e. each parameter is a function in itself)\<close>

definition
  op :: "T1 \<Rightarrow> S \<Rightarrow> T1 \<times> S"
  where
  "op t bst \<equiv> (t, bst)"

text \<open>Value can be used evaluate the result of running op\<close>
value "op 4 \<lparr>t1 = 1, t2 = 3 \<rparr>"

text \<open>Explicit definition for opE. Notice the encoding of sequential composition\<close>

definition
  opE :: "T1 \<Rightarrow> S \<Rightarrow> T1 \<times> S"
  where
  "opE t bst \<equiv>
      let t1'    = (t1 bst) + t;
          RESULT = (t2 bst) - t1'
       in
          (RESULT, bst\<lparr>t1 := t1'\<rparr>)"

value "opE 4 \<lparr>t1 = 1, t2 = 3\<rparr>"
value "inv_T1 (-2)"
value "opE 4 init_S"

text \<open>Well sortedness error has to do with Isabelle not knowing how to enumerate a type\<close>
value "2=2"
value "(2::nat)=2"

text \<open>Operation preconditions must ensure state and input invariants hold alongside
      user defined pre\<close>
definition
  pre_opE :: "T1 \<Rightarrow> S \<Rightarrow> \<bool>"
  where
  "pre_opE t bst \<equiv> inv_S bst \<and> inv_T1 t \<and> True"

text \<open>Operation preconditions must ensure before/after state and input/output invariants
   hold alongside user defined post. There are multiple ways to set this up; below I use
   one that matches with the definition of op above, where the RESULT is a call to the operation.

   Notice that the frame (ext clause) is also implicitly included: here it says that t2
   cannot change whereas t1 can\<close>
definition
  post_opE :: "T1 \<Rightarrow> S \<Rightarrow> T1 \<times> S \<Rightarrow> \<bool>"
  where
  "post_opE t bst opr \<equiv>
     let (RESULT, ast) = opr in
       inv_S ast \<and> inv_T1 RESULT
     \<and> (t2 bst) = (t2 ast)
     \<and> (t1 bst) < (t1 ast)
     \<and> RESULT < (t2 ast)"

definition
  PO_opE_FSB :: "\<bool>"
  where
  "PO_opE_FSB \<equiv> \<forall> s t . pre_opE t s \<longrightarrow> post_opE t s (opE t s)"

declare [[show_types=false]]
theorem PO_opE_FSB
  unfolding PO_opE_FSB_def pre_opE_def post_opE_def opE_def
  apply safe
  unfolding inv_S_def inv_T1_def inv_VDMNat1_def
  apply (safe, simp)+
  (* unfolding Let_def apply safe *)
  nitpick
  (* too weak pre_op, counter example
    s = \<lparr>t1 = 6, t2 = M\<rparr>
    t = 6
  *)
  oops

lemma "t1 (s\<lparr>t1 := t1 s + t\<rparr>) = t1 s + t" apply simp done

declare [[show_types=false]]
theorem PO_opE_FSB
  unfolding PO_opE_FSB_def
  apply safe
  unfolding pre_opE_def post_opE_def opE_def
  apply (safe,simp)
  unfolding inv_S_def inv_T1_def inv_VDMNat1_def
  apply (simp)
  apply safe
  unfolding Let_def
           apply safe
  apply simp_all
  nitpick
  (* too weak pre_op, counter example
    s = \<lparr>t1 = 6, t2 = M\<rparr>
    t = 6
  *)
    defer
  nitpick
(*   s = \<lparr>t1 = 1, t2 = M\<rparr>
    t = M
*)
  oops

declare [[show_types=false]]
theorem "PO_opE_FSB"
  unfolding PO_opE_FSB_def pre_opE_def post_opE_def opE_def
  apply safe
  unfolding inv_S_def inv_T1_def inv_VDMNat1_def
  apply (safe, simp)+
  unfolding Let_def
  apply (safe, simp_all)
  oops

text \<open> Exercise: fix pre of opE to satisfy its FSB PO\<close>

text \<open>For pure operations you can avoid the result state parameter,
  given there can't be any change from bst. This simplifies calls to opEP. \<close>

definition
  opEP :: "T1 \<Rightarrow> S \<Rightarrow> T1"
  where
  "opEP t bst \<equiv> (t2 bst) - ((t1 bst) + t)"

definition
  pre_opEP :: "T1 \<Rightarrow> S \<Rightarrow> \<bool>"
  where
  "pre_opEP t bst \<equiv> inv_S bst \<and> inv_T1 t"

definition
  post_opEP :: "T1 \<Rightarrow> T1 \<Rightarrow> S \<Rightarrow> S \<Rightarrow> \<bool>"
  where
  "post_opEP t RESULT bst ast \<equiv>
      inv_S ast \<and> inv_T1 RESULT
    \<and> RESULT = opEP t bst
    \<and> RESULT < (t2 ast)"

definition
  PO_opEP_FSB :: "\<bool>"
  where
  "PO_opEP_FSB \<equiv>
    \<forall> t bst . pre_opEP t bst \<longrightarrow>
      (\<exists> ast RESULT .
          ast = bst
        \<and> post_opEP t RESULT bst ast
        \<and> RESULT = opEP t bst)"

theorem PO_opEP_FSB
  nitpick oops

theorem PO_opEP_FSB
  unfolding PO_opEP_FSB_def
  apply simp
  apply safe
  unfolding pre_opEP_def post_opEP_def
  apply simp
  unfolding opEP_def inv_S_def inv_T1_def inv_VDMNat1_def
  apply simp
  apply safe
  nitpick
  oops

text \<open> Exercise: fix pre of opEP to satisfy its FSB PO \<close>

text \<open>For extended explicit operations you have to define a framing
  predicate, which is part of the post condition. \<close>

definition
  pre_opEE :: "T1 \<Rightarrow> S \<Rightarrow> \<bool>"
  where
  "pre_opEE t bst \<equiv> inv_S bst \<and> inv_T1 t"

text \<open>A frame specification can be used for defining how the state is
  allowed to change. In a pure operation, nothing changes. In an
  extended explicit opration, it follows the wr/rd ext clauses\<close>

definition
  frame_opEE :: "T1 \<Rightarrow> S \<Rightarrow> S  \<Rightarrow> \<bool>"
  where
  "frame_opEE t bst ast \<equiv> (t2 bst) = (t2 ast)"

definition
  post_opEE :: "T1 \<Rightarrow> T1 \<Rightarrow> S \<Rightarrow> S \<Rightarrow> \<bool>"
  where
  "post_opEE t r bst ast \<equiv>
      inv_S ast \<and> inv_T1 r
    \<and> frame_opEE t bst ast
    \<and> (t1 bst) < (t1 ast)
    \<and> r < (t2 ast)
    \<and> r < opEP t bst"

definition
  PO_opEE_FSB :: "\<bool>"
  where
  "PO_opEE_FSB \<equiv>
    \<forall> t bst . pre_opEE t bst \<longrightarrow>
      (\<exists> ast RESULT .
          post_opEE t RESULT bst ast
        \<and> (RESULT, ast) = opE t bst)"

definition
  PO_opEE_FSB' :: "\<bool>"
  where
  "PO_opEE_FSB' \<equiv>
    \<forall> t bst . pre_opEE t bst \<longrightarrow>
      (let (RESULT, ast) = opE t bst in
         post_opEE t RESULT bst ast)"

theorem PO_opEE_FSB
  nitpick
  (* bst = \<lparr>t1 = 8, t2 = M\<rparr>
    t = 9
  *)
  oops

text \<open> Exercise: fix pre of opEE to satisfy its FSB PO\<close>
text \<open> Exercise: fix post of opEE to take opEP specification into account\<close>

end


theory continuous imports topological_space  subspace  begin

     (*
definition
  is_inj :: "'a set \<Rightarrow> 'b set \<Rightarrow> bool" where
  "is_inj A B \<longleftrightarrow> (inj_on f A) \<and> (f: A \<longrightarrow> B) "

definition
  SUR :: "'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<Rightarrow> 'b) set" where
  "SUR A B = {f. f : A \<rightarrow> B \<and> (\<forall> y\<in>B. \<exists> x\<in>A. y = f x)}"

definition
  BIJ :: "'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<Rightarrow> 'b) set" where
  "BIJ A B = INJ A B \<inter> SUR A B"

definition
  card_le :: "'a set \<Rightarrow> 'b set \<Rightarrow> bool" (infix "cardle" 50) where
  "A cardle B \<longleftrightarrow> (\<exists>f. f \<in> SUR B A)"
*)

definition fun_image :: "['a\<Rightarrow> 'b,'a set , 'b set] \<Rightarrow> 'b set" where
  "fun_image (f::'a\<Rightarrow>'b ) A Y = {b .\<exists>a\<in>A.  b = (f a) \<and> b\<in> Y }"

definition fun_preimage  :: "['a\<Rightarrow> 'b,'b set, 'a set] \<Rightarrow> 'a set" where
  "fun_preimage (f::'a\<Rightarrow>'b ) B  X= {a .(f a \<in> B)\<and> a \<in> X }"

definition
   continuous ::
   "['a \<Rightarrow> 'b, 'a set,'a set set,
      'b set ,'b set set  ] \<Rightarrow>bool"
      where
   "continuous f  X Tx Y Ty == (f: X \<rightarrow> Y)
       \<and>(topological_space X Tx)
       \<and> (topological_space Y Ty)
       \<and> (\<forall>V. (topological_space.open_set Ty V )\<longrightarrow>
          ( topological_space.open_set Tx
              (fun_preimage f V X))  )"

lemma closed_set_continuous_1:
  assumes  a1 : "f:X \<rightarrow> Y"
  and      a2 : "topological_space X Tx"
  and      a3 : "topological_space Y Ty"
  and      a4 : "\<forall>V. topological_space.closed_set Y Ty V \<longrightarrow> topological_space.closed_set X Tx (fun_preimage f V X) "
  and      a5 : "topological_space.open_set Ty A"
  shows   "topological_space.open_set Tx  (fun_preimage f A X)"
proof-
     from a3  a5 have s1 : "A \<in> Ty "  apply (simp add: topological_space.open_set_def)  done
     from a3 s1 have s2  : "Ty \<subseteq>  Pow Y" apply (simp add :topological_space_def) done
     from s1 s2 have s3 : "A \<subseteq> Y"  apply blast done
     from s3 have s4 : "Y - A \<subseteq> Y"  apply blast done
     from s3 s4 have s5: "Y - (Y - A) = A" apply blast done
     from a3 a5 s4 s5 have s6 : "topological_space.closed_set Y Ty  (Y - A)"
             apply (simp add: topological_space.closed_set_def)  done
     from a4 s6 have s7: "topological_space.closed_set X Tx  (fun_preimage f (Y-A) X )"
             apply simp done
     from s7 a2  have s8: "(X - (fun_preimage f (Y-A) X)) \<in> Tx "
             apply (simp add:topological_space.closed_set_def topological_space.open_set_def)  done
       have s8_1 : " X - {a. f a \<in> Y \<and> f a \<notin> A \<and> a \<in> X} = {a. (f a \<notin> Y \<or> f a \<in> A) \<and> a \<in> X}" apply blast done
       have s8_2 : "{a. (f a \<notin> Y \<or> f a \<in> A) \<and> a \<in> X} = {a. (f a \<notin> Y) \<and> a \<in> X} \<union> {a. (f a \<in>  Y \<and>  f a \<in>   A) \<and> a \<in> X}" apply blast  done
       from a1 have s8_3:"\<forall>a\<in>X. f a \<in> Y  "  apply (simp add: Pi_def) done
       from s8_3 have s8_4 : "{a. (f a \<notin> Y) \<and> a \<in> X} = {}"  apply blast done
       from s8_2 s8_4 have s8_5 : "{a. (f a \<notin> Y \<or> f a \<in> A) \<and> a \<in> X} = {a. (f a \<in>  Y \<and>  f a \<in>   A) \<and> a \<in> X}"  apply simp done
       from s8_1 s8_5 have s8_6 : " X - {a. f a \<in> Y \<and> f a \<notin> A \<and> a \<in> X} = {a. (f a \<in>  Y \<and>  f a \<in>   A) \<and> a \<in> X}"  apply  simp done
       have s8_7 : "X - {a. f a \<in> Y \<and> f a \<notin> A \<and> a \<in> X} = X - (fun_preimage f (Y-A) X) "  apply  (simp add: fun_preimage_def) done
       from s3 have s8_8 : "{a. (f a \<in>  Y \<and>  f a \<in>   A) \<and> a \<in> X} = {a. (f a \<in> A) \<and> a \<in> X}" apply blast done
       have s8_9 : "{a. (f a \<in> A) \<and> a \<in> X} = (fun_preimage f A X)" apply (simp add: fun_preimage_def) done
       from s8_9 s8_8 s8_6 s8_7  have s8_10 : "X - (fun_preimage f (Y-A) X) = (fun_preimage f A X) "  apply simp done
       from s8 s8_10 have s9: " (fun_preimage f A X) \<in> Tx" apply simp done
       from a2 s9 show ?thesis  apply  (simp add:topological_space.open_set_def) done
qed

lemma closed_set_continuous_2:
 "\<And>A. \<lbrakk> f:X \<rightarrow> Y;
        topological_space X Tx ;
        topological_space Y Ty;
        \<forall>V. (topological_space.closed_set Y Ty  V) \<longrightarrow> (topological_space.closed_set X Tx (fun_preimage f V X));
         (topological_space.open_set Ty  A)
      \<rbrakk> \<Longrightarrow> (topological_space.open_set Tx  (fun_preimage f A X)) "
apply (rule closed_set_continuous_1)
apply simp+
done
(*lemma "A \<and> B \<longrightarrow> B \<and> A"
proof
 assume AB:"A \<and> B"
 from AB show "B \<and> A"
*)

lemma closed_set_continuous:
  assumes  a1 : "f:X \<rightarrow> Y"
  and      a2 : "topological_space X Tx"
  and      a3 : "topological_space Y Ty"
  and      a4 : "\<forall>V. topological_space.closed_set Y Ty  V \<longrightarrow> topological_space.closed_set X Tx(fun_preimage f V X) "
  shows   "continuous f X Tx Y Ty"
proof-
  from a1 a2 a3 a4  have s1:"\<And>A. \<lbrakk> (topological_space.open_set Ty A)\<rbrakk> \<Longrightarrow> topological_space.open_set Tx  (fun_preimage f A X)  " apply (rule  closed_set_continuous_1) apply simp+ done
  from s1 have s2 : "\<forall>A. (topological_space.open_set Ty A) \<longrightarrow>  (topological_space.open_set Tx (fun_preimage f A X)) " apply simp done
  from  a1 a2 a3 s2  show ?thesis  apply (simp add:  continuous_def) done
qed

lemma continuous_2_closed_set_1:
  assumes a1 : "continuous f X Tx Y Ty"
  and     a2 : "topological_space.closed_set Y Ty  A "
  shows   "topological_space.closed_set X Tx (fun_preimage f A X)"
proof-
  from a1 have s1: "f:X \<rightarrow> Y" apply (simp add:continuous_def) done
  from a1 have s2: "topological_space X Tx" apply (simp add:continuous_def)  done
  from a1 have s3: "topological_space Y Ty" apply (simp add:continuous_def)  done
  from a1 have s4: "\<forall>V. topological_space.open_set Ty  V \<longrightarrow> topological_space.open_set Tx  (fun_preimage f V X)"
                    apply(simp add:continuous_def) done
  from s3 a2 have s5 : "topological_space.open_set Ty (Y-A)"  apply (simp add: topological_space.closed_set_def) done
  from s4 s5 have s6 : "topological_space.open_set Tx  (fun_preimage f (Y-A) X)" apply (simp) done
  from s2 s6 have s7 : " (fun_preimage f (Y-A) X) \<subseteq> X"  apply (simp add: fun_preimage_def)  apply blast done
  from s7 have s8 : "(X- (fun_preimage f (Y-A) X)) \<subseteq> X" apply blast done
  from s7 s8 have s9 : "(X - (X - (fun_preimage f (Y - A) X))) = (fun_preimage f (Y - A) X )"  apply blast done
  from s2 s6 s8 s9 have s10 : "topological_space.closed_set X Tx (X- (fun_preimage f (Y-A) X))" apply (simp add:topological_space.closed_set_def) done
   have s11_1 : "X - {a. f a \<in> Y \<and> f a \<notin> A \<and> a \<in> X}={a. (f a \<notin> Y \<or> f a \<in> A ) \<and> a \<in> X} "apply blast done
   have s11_2 : "{a. (f a \<notin> Y \<or> f a \<in> A) \<and> a \<in> X} = {a. (f a \<notin> Y) \<and> a \<in> X} \<union> {a. (f a \<in> A \<and>   f a \<in> Y) \<and> a \<in> X} "
                     apply blast done
   from s1 have s11_3 : "{a. (f a \<notin> Y) \<and> a \<in> X} ={}"  apply (simp add:Pi_def) apply blast done
   from a2 s3  have s11_4 : "A \<subseteq> Y" apply (simp add:topological_space.closed_set_def)  done
   from s11_4 have s11_5: "{a. (f a \<in> A \<and>   f a \<in> Y) \<and> a \<in> X} = {a. (f a \<in> A ) \<and> a \<in> X}" apply blast  done
   from s11_1 s11_2 s11_3 s11_5  have s11_6 : "{a. f a \<in> A \<and> a \<in> X} = X - {a. f a \<in> Y \<and> f a \<notin> A \<and> a \<in> X}"
                                                   apply simp done
   have s11: "(fun_preimage f A X) = (X- (fun_preimage f (Y-A) X))"
         apply (simp add:fun_preimage_def s11_6)  done
   from s10 s11 show ?thesis apply simp done
qed
lemma continuous_2_closed_set:
   "\<And>V. \<lbrakk>(continuous f X Tx Y Ty); (topological_space.closed_set Y Ty V)\<rbrakk> \<Longrightarrow>  (topological_space.closed_set X Tx  (fun_preimage f V X))"
apply (simp add:  continuous_2_closed_set_1)
done

lemma  pasting_lemma_1:
    assumes       a1: "\<And>x. \<lbrakk>x\<in> A\<rbrakk> \<Longrightarrow>  h x = f x "
    shows    "{a. h a \<in> C \<and> a \<in> A} ={a. f a \<in> C \<and> a \<in> A}"
proof-
       have t1: "\<And>x.  \<lbrakk>x\<in> {a. h a \<in> C \<and> a \<in> A}\<rbrakk>\<Longrightarrow>  x\<in> A \<and> h x \<in> C"  apply simp done
       from  a1  have  t2:"\<And>x.  \<lbrakk> x\<in> A; h x \<in> C\<rbrakk> \<Longrightarrow> h x  = f x " apply simp  done
       from t2 have t3 : "\<And>x.  \<lbrakk> x\<in> A; h x \<in> C\<rbrakk> \<Longrightarrow> f x \<in> C \<and> x \<in> A" apply simp  done
       from t3  have t4 : "\<And>x.  \<lbrakk>x\<in> {a. h a \<in> C \<and> a \<in> A}\<rbrakk>\<Longrightarrow> f x \<in> C \<and> x \<in> A" apply simp done
       have t5: " \<lbrakk>x\<in> A ; f x \<in> C \<rbrakk> \<Longrightarrow>x \<in> {a. f a \<in> C \<and> a\<in> A} " apply simp done
       from t4 t5 have t6: "\<And>x.  \<lbrakk>x\<in> {a. h a \<in> C \<and> a \<in> A}\<rbrakk>\<Longrightarrow>x \<in> {a. f a \<in> C \<and> a\<in> A}" apply blast  done
       from t6 have t7: "{a. h a \<in> C \<and> a \<in> A} \<subseteq> {a. f a \<in> C \<and> a\<in> A} " apply blast done
       have t8:"\<And>x.  \<lbrakk>x\<in> {a. f a \<in> C \<and> a \<in> A}\<rbrakk>\<Longrightarrow>  x\<in> A \<and> f x \<in> C"  apply simp done
       from  a1  have  t9:"\<And>x.  \<lbrakk> x\<in> A; f x \<in> C\<rbrakk> \<Longrightarrow> h x  = f x " apply simp  done
       from t9  have t10 : "\<And>x.  \<lbrakk> x\<in> A; f x \<in> C\<rbrakk> \<Longrightarrow> h x \<in> C \<and> x \<in> A" apply simp  done
       from t10  have t11 : "\<And>x.  \<lbrakk>x\<in> {a. f a \<in> C \<and> a \<in> A}\<rbrakk>\<Longrightarrow> h x \<in> C \<and> x \<in> A" apply simp done
       have t12: " \<lbrakk>x\<in> A ; h x \<in> C \<rbrakk> \<Longrightarrow>x \<in> {a. h a \<in> C \<and> a\<in> A} " apply simp done
       from t11 t12 have t13: "\<And>x.  \<lbrakk>x\<in> {a. f a \<in> C \<and> a \<in> A}\<rbrakk>\<Longrightarrow>x \<in> {a. h a \<in> C \<and> a\<in> A}" apply blast  done
       from t13 have t14: "{a. f a \<in> C \<and> a \<in> A} \<subseteq> {a. h a \<in> C \<and> a\<in> A} " apply blast done
       from t7 t14  show ?thesis apply simp done
qed

thm topological_space.subspace_topology_def

lemma sub_open :
  assumes  a1: "topological_space  X T"
  and      a2: "A \<subseteq> X"
  and      a3: "topological_space.open_set T A"
  and      a4: "topological_space.open_set (topological_space.subspace_topology T A)  B"
  shows    "topological_space.open_set T  B"
proof-
   from a1 a2    have s1: "topological_space A (topological_space.subspace_topology T A)"
        apply (rule topological_space.subspace_is_top) done
   from  a4 s1  have s2:"B \<in> (topological_space.subspace_topology T A) "
        apply (simp add: topological_space.open_set_def ) done
   from a1 a3 have s3 : "A \<in> T"
        apply (simp add:topological_space.open_set_def) done
   from  a1 a2 a3 a4 s1 s2 have s4: "\<exists>u\<in>T. B = u \<inter>  A  "
        apply  (simp add:topological_space.open_set_def
                         topological_space.subspace_topology_def)
        apply blast  done
   from a1 s3 s4 have s5: "\<And>u.  \<lbrakk> u\<in> T; B = u \<inter>  A \<rbrakk> \<Longrightarrow>  B \<in> T   "
        apply (simp add: topological_space.O4) done
   from s5 s4  have s6: "B \<in> T"  apply simp apply blast done
   from a1 s6  show  ?thesis
        apply (simp add:topological_space.open_set_def) done
qed

lemma union_eq:
 "\<lbrakk> A = B \<rbrakk> \<Longrightarrow> A \<union> C = B \<union> C"
apply blast
done

lemma sub_closed:
  assumes a1:  "topological_space X T"
  and     a2:  "A \<subseteq> X"
  and     a3:  "topological_space.closed_set X T A"
  and     a4:  "topological_space.closed_set A (topological_space.subspace_topology T A) B"
  shows    "topological_space.closed_set X T B"
proof-
 from a1 a2 have s1: "topological_space A (topological_space.subspace_topology T A)"
      apply (rule topological_space.subspace_is_top) done
 from  a4  s1  have s2:" A - B \<in>  (topological_space.subspace_topology T A) "
      apply (simp add:topological_space.closed_set_def
                      topological_space.open_set_def ) done
 from a1 a3 have s3: " X-A \<in> T"
      apply (simp add:topological_space.closed_set_def
                      topological_space.open_set_def)  done
 from a1 a2 a3 a4 s1 s2 have s4: "\<exists>u\<in>T.  A - B = ( A \<inter> u)  "
      apply  (simp add:topological_space.closed_set_def
                       topological_space.open_set_def
                       topological_space.subspace_topology_def)  done
 from a2 have s5: "(A - B) = A \<inter> (X - B)" apply blast done
 from a2 s5 have s6: "(A \<inter> (X - B)) \<union> (X - A) = (X -B) \<union> (X - A) "  apply blast done
 from a1  a2 a3 a4 s1 have s7: "B \<subseteq> A"
      apply (simp add:topological_space.closed_set_def) done
 from a2 s7  have s8: "(X - B) \<union> (X - A) = X - B "  apply blast done
 from s5 s6 s7 s8 have s9 : "(A - B)\<union> (X - A) = X -B  " apply blast done
 from a2 have s10 : "\<And> u.  (A \<inter> u)\<union> (X - A) =  X\<inter>   (u \<union> (X - A))"  apply blast done
 from s4 have s11 : "\<And>u.  \<lbrakk> A - B = A \<inter> u\<rbrakk> \<Longrightarrow> (A - B) \<union> (X -A) = (A \<inter> u) \<union> (X -A) "  apply simp done
 from s9 s11 have s12: "\<And>u. \<lbrakk> A - B = A \<inter> u\<rbrakk> \<Longrightarrow> X - B = (A \<inter> u) \<union> (X - A) " apply simp done
 from s12 s10 have s13: "\<And>u. \<lbrakk> A - B = A \<inter> u\<rbrakk> \<Longrightarrow> X - B = X \<inter> (u \<union> (X -A)) "  apply simp done
 from  a1 s3 have s14 : "\<And>u. \<lbrakk> u\<in> T\<rbrakk> \<Longrightarrow>X \<inter>  (u \<union> (X - A))\<in> T "
      apply (simp add: topological_space.O3
                       topological_space.O4
                       topological_space.union_in_T )
     done
 from s13 s14 have s15: "\<And>u. \<lbrakk> u\<in>T; A - B = A \<inter> u  \<rbrakk> \<Longrightarrow> X - B \<in> T "  apply simp done
 from s15 s4 have s16 : "X - B \<in> T" apply blast  done
 from a1 s16 a2 s7 show ?thesis
    apply (simp add:topological_space.closed_set_def
                    topological_space.open_set_def) done
qed

lemma pasting_lemma_2[simp]:
  assumes    a1:  "topological_space X Tx"
  and        a2:  "topological_space Y Ty"
  and        a3:  "X = A \<union>  B"
  and        a4:  "topological_space.open_set Tx  A"
  and        a5:  "topological_space.open_set Tx  B"
  and        a6:  "f: A \<rightarrow> Y"
  and        a7:  "g: B \<rightarrow> Y"
  and        a8:  "continuous f A (topological_space.subspace_topology Tx  A)  Y Ty"
  and        a9:  "continuous g B (topological_space.subspace_topology Tx  B)  Y Ty"
  and        a10:  "\<And>x. \<lbrakk>x\<in> A \<inter> B\<rbrakk> \<Longrightarrow> f x = g x "
  and        a11: "\<And>x. \<lbrakk>x\<in> A\<rbrakk> \<Longrightarrow>  h x = f x "
  and        a12: "\<And>x. \<lbrakk>x\<in> B\<rbrakk> \<Longrightarrow> h x = g x "
  and        a13: "topological_space.open_set Ty C"
  shows      "topological_space.open_set Tx (fun_preimage h C X)"
proof-
    from a3 a6 a7 a10 a11 a12 have s1: "h \<in> X \<rightarrow>Y"  apply( simp add :Pi_def)  done
    from  a11    have s2: "{a. h a \<in> C \<and> a \<in> A} ={a. f  a \<in> C \<and> a \<in> A}"
       apply (rule  pasting_lemma_1) apply blast done
    from a12    have s3: "{a. h a \<in> C \<and> a \<in> B} ={a. g  a \<in> C \<and> a \<in> B}"
       apply (rule  pasting_lemma_1) apply blast done
    from  a3 a13 have s4 : "{a . h a \<in> C \<and> a \<in> X } = {a. h a \<in> C \<and>  a \<in> A} \<union> {a. h a \<in> C \<and> a \<in> B} "
       apply blast done
    from  s2 s3 s4 have s5 :"{a . h a \<in> C \<and> a \<in> X } ={a. f  a \<in> C \<and> a \<in> A} \<union> {a. g  a \<in> C \<and> a \<in> B}"
       apply simp done
    from  s4 s5 have   s6:  "fun_preimage h C X = (fun_preimage f C A) \<union> (fun_preimage g C B)" apply (simp add:fun_preimage_def) done
    from a3 have s7:"A \<subseteq> X" apply blast done
    from a1 a3 s7  have s8: "topological_space A (topological_space.subspace_topology Tx A)"
        apply  (simp add:topological_space.subspace_is_top) done
    from a1 a4 a13 a8  s8 have s9:
         "topological_space.open_set (topological_space.subspace_topology Tx A) (fun_preimage f C A)"
         apply (simp add:continuous_def) done
    from  a1  a4  s7 s9 have s10: "topological_space.open_set Tx (fun_preimage f C A)"
         apply (simp add: sub_open)  done
    from a3 have s11:"B \<subseteq> X" apply blast done
    from a1 a3 s11  have s12:
           "topological_space B (topological_space.subspace_topology Tx B)"
         apply  (simp add:topological_space.subspace_is_top) done
    from a1 a5 a13 a9  s12 have s13:
            "topological_space.open_set
                (topological_space.subspace_topology Tx B)
                (fun_preimage g C B)"
           apply (simp add:continuous_def) done
    from  a1  a5 s11 s13 have s14:
             "topological_space.open_set Tx (fun_preimage g C B)"
           apply (simp add: sub_open) done
    from  a1 s10   have s15: "(fun_preimage f C A) \<in> Tx "
           apply (simp add: topological_space.open_set_def)   done
    from  a1 s14   have s16: "(fun_preimage g C B) \<in> Tx "
           apply (simp add: topological_space.open_set_def)   done
    from  a1 s15 s16 have s17: "(fun_preimage f C A)  \<union> (fun_preimage g C B) \<in> Tx "
           apply (simp add:topological_space.union_in_T) done
    from s17 s6 have s18 : "(fun_preimage h C X)\<in> Tx "  apply simp done
    from a1 s18 show ?thesis
          apply (simp add:topological_space.open_set_def) done
qed

lemma pasting_lemma_3:
  "\<And>C. \<lbrakk>topological_space X Tx;
         topological_space Y Ty;
        X = A \<union>  B;
        topological_space.open_set Tx  A ;
        topological_space.open_set Tx  B ;
        f: A \<rightarrow> Y;
        g: B \<rightarrow> Y;
        continuous f A (topological_space.subspace_topology Tx  A)  Y Ty ;
        continuous g B (topological_space.subspace_topology Tx  B)  Y Ty;
        \<And>x. \<lbrakk>x\<in> A \<inter> B\<rbrakk> \<Longrightarrow> f x = g x ;
        \<And>x. \<lbrakk>x\<in> A\<rbrakk> \<Longrightarrow>  h x = f x ;
        \<And>x. \<lbrakk>x\<in> B\<rbrakk> \<Longrightarrow> h x = g x ;
        topological_space.open_set Ty C
   \<rbrakk>  \<Longrightarrow> topological_space.open_set Tx (fun_preimage h C X) "
apply (rule  pasting_lemma_2)
apply simp+
done

lemma pasting_lemma_open_set:
 assumes a1:  "topological_space X Tx"
 and     a2:  "topological_space Y Ty"
 and     a3:  "X = A \<union> B"
 and     a4:  "topological_space.open_set Tx  A"
 and     a5:  "topological_space.open_set Tx  B"
 and     a6:  "f: A \<rightarrow> Y"
 and     a7:  "g: B \<rightarrow> Y"
 and     a8:  "continuous f A
    (topological_space.subspace_topology Tx A) Y Ty"
 and     a9:  "continuous g B
    (topological_space.subspace_topology Tx B) Y Ty"
 and     a10:  "\<And>x. \<lbrakk>x\<in> A \<inter> B\<rbrakk> \<Longrightarrow> f x = g x "
 and     a11: "\<And>x. \<lbrakk>x\<in> A\<rbrakk> \<Longrightarrow>  h x = f x "
 and     a12: "\<And>x. \<lbrakk>x\<in> B\<rbrakk> \<Longrightarrow> h x = g x "
 shows   "continuous h X Tx  Y Ty"

proof-
  from a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 have s1:
        "\<And>C. \<lbrakk> (topological_space.open_set Ty C)\<rbrakk> \<Longrightarrow>
            topological_space.open_set Tx (fun_preimage h C X) "
        apply (rule  pasting_lemma_3) apply simp+ done
  from s1 have s2 : "\<forall>C. (topological_space.open_set Ty C) \<longrightarrow>
          (topological_space.open_set Tx (fun_preimage h C X)) "
        apply simp done
   from a3 a6 a7 a10 a11 a12 have s3:"h \<in> X \<rightarrow>Y"
        apply( simp add :Pi_def)  done
  from  a1 a2 s2 s3 show ?thesis
        apply (simp add:  continuous_def) done
qed

lemma pasting_lemma_closed_set_1[simp]:
 assumes a1: "topological_space X Tx"
 and     a2: "topological_space Y Ty"
 and     a3: "X = A \<union> B"
 and     a4: "topological_space.closed_set X Tx A"
 and     a5: "topological_space.closed_set X Tx B"
 and     a6: "f: A \<rightarrow> Y"
 and     a7: "g: B \<rightarrow> Y"
 and     a8: "continuous f A
    (topological_space.subspace_topology Tx A) Y Ty"
 and     a9: "continuous g B
    (topological_space.subspace_topology Tx B) Y Ty"
 and        a10: "\<And>x. \<lbrakk>x\<in> A \<inter> B\<rbrakk> \<Longrightarrow> f x = g x "
 and        a11: "\<And>x. \<lbrakk>x\<in> A\<rbrakk> \<Longrightarrow>  h x = f x "
 and        a12: "\<And>x. \<lbrakk>x\<in> B\<rbrakk> \<Longrightarrow> h x = g x "
 and        a13:" topological_space.closed_set Y Ty C"
 shows  "topological_space.closed_set X Tx  (fun_preimage h C X)"
proof-
    from a3 a6 a7 a10 a11 a12 have s1: "h \<in> X \<rightarrow>Y"
        apply( simp add :Pi_def)  done
    from  a11    have s2:
       "{a. h a \<in> C \<and> a \<in> A} ={a. f  a \<in> C \<and> a \<in> A}"
        apply (rule  pasting_lemma_1)
        apply blast done
    from a12    have s3:
        "{a. h a \<in> C \<and> a \<in> B} ={a. g  a \<in> C \<and> a \<in> B}"
        apply (rule  pasting_lemma_1)
        apply blast done
    from  a3 a13 have s4 :
        "{a . h a \<in> C \<and> a \<in> X } = {a. h a \<in> C \<and>  a \<in> A} \<union> {a. h a \<in> C \<and> a \<in> B} "
        apply blast done
    from  s2 s3 s4 have s5 :"{a . h a \<in> C \<and> a \<in> X } ={a. f  a \<in> C \<and> a \<in> A} \<union> {a. g  a \<in> C \<and> a \<in> B}"
        apply simp done
    from  s4 s5 have   s6:  "fun_preimage h C X = (fun_preimage f C A) \<union> (fun_preimage g C B)"
        apply (simp add:fun_preimage_def) done
    from a3 have s7:"A \<subseteq> X" apply blast done
    from a1 a3 s7  have s8:
        "topological_space A (topological_space.subspace_topology Tx A) "
        apply  (simp add:topological_space.subspace_is_top) done
    from a1 a4 a13 a8  s8 have s9:
         "topological_space.closed_set
                A (topological_space.subspace_topology Tx A)
               (fun_preimage f C A)"
         apply (simp add:continuous_2_closed_set) done
    from  a1  a4 s7 s9 have s10:
          "topological_space.closed_set X Tx (fun_preimage f C A)"
          apply (simp add: sub_closed) done
    from a3 have s11:"B \<subseteq> X"
          apply blast done
    from a1 a3 s11  have s12:
         "topological_space B (topological_space.subspace_topology Tx B) "
         apply  (simp add:topological_space.subspace_is_top) done
    from a1 a5 a13 a9  s12 have s13:
          "topological_space.closed_set
               B (topological_space.subspace_topology Tx B)
              (fun_preimage g C B)"
           apply (simp add:continuous_2_closed_set) done
    from  a1  a5 s11 s13 have s14:
          "topological_space.closed_set X Tx (fun_preimage g C B)"
          apply (simp add: sub_closed) done
    from  a1 s10   have s15: "X - (fun_preimage f C A) \<in> Tx "
          apply (simp add: topological_space.closed_set_def
                           topological_space.open_set_def)   done
    from  a1 s14   have s16: "X - (fun_preimage g C B) \<in> Tx "
          apply (simp add: topological_space.closed_set_def
                           topological_space.open_set_def)   done
    from a1 s15 s16 have s17:
         "(X - (fun_preimage f C A)) \<inter> (X - (fun_preimage g C B)) \<in> Tx "
          apply (simp add:topological_space_def) done
    have s18: "(X - (fun_preimage f C A)) \<inter>  (X - (fun_preimage g C B))
                  =
               (X - ((fun_preimage f C A)  \<union>   (fun_preimage g C B))) "
           apply blast done
   from s17 s18 have  s19:
          "(X - ((fun_preimage f C A)  \<union>   (fun_preimage g C B))) \<in> Tx"
            apply simp done
   from s19 s6 have s20 : "X -(fun_preimage h C X)\<in> Tx "
            apply simp done
   have s21 : "(fun_preimage h C X) \<subseteq> X"
          apply  (simp add: fun_preimage_def)
          apply blast done
    from a1 s20 s21 show ?thesis
          apply (simp add:topological_space.closed_set_def
                          topological_space.open_set_def) done
qed

lemma pasting_lemma_closed_set_2:
  "\<And>C. \<lbrakk>topological_space X Tx;
        topological_space Y Ty;
        X = A \<union>  B;
        topological_space.closed_set X Tx A;
        topological_space.closed_set X Tx B;
        f: A \<rightarrow> Y;
        g: B \<rightarrow> Y;
        continuous f A (topological_space.subspace_topology Tx  A)  Y Ty ;
        continuous g B (topological_space.subspace_topology Tx  B)  Y Ty;
        \<And>x. \<lbrakk>x\<in> A \<inter> B\<rbrakk> \<Longrightarrow> f x = g x ;
        \<And>x. \<lbrakk>x\<in> A\<rbrakk> \<Longrightarrow>  h x = f x ;
        \<And>x. \<lbrakk>x\<in> B\<rbrakk> \<Longrightarrow> h x = g x ;
        topological_space.closed_set Y Ty C
   \<rbrakk>  \<Longrightarrow> topological_space.closed_set X Tx (fun_preimage h C X) "
apply (rule  pasting_lemma_closed_set_1)
apply simp+
done

lemma pasting_lemma_closed_set:
 assumes a1: "topological_space X Tx"
 and     a2: "topological_space Y Ty"
 and     a3: "X = A \<union> B"
 and     a4: "topological_space.closed_set X Tx  A"
 and     a5: "topological_space.closed_set X Tx  B"
 and     a6: "f: A \<rightarrow> Y"
 and     a7: "g: B \<rightarrow> Y"
 and     a8: "continuous f A
   (topological_space.subspace_topology Tx A) Y Ty"
 and     a9:  "continuous g B
   (topological_space.subspace_topology Tx B) Y Ty"
 and     a10: "\<And>x. \<lbrakk>x\<in> A \<inter> B\<rbrakk> \<Longrightarrow> f x = g x "
 and     a11: "\<And>x. \<lbrakk>x\<in> A\<rbrakk> \<Longrightarrow>  h x = f x "
 and     a12: "\<And>x. \<lbrakk>x\<in> B\<rbrakk> \<Longrightarrow> h x = g x "
 shows   "continuous h X Tx  Y Ty"
proof-
  from a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 have s1:
      "\<And>C. \<lbrakk> (topological_space.closed_set Y Ty  C)\<rbrakk> \<Longrightarrow>
         topological_space.closed_set X Tx  (fun_preimage h C X)"
      apply (rule  pasting_lemma_closed_set_2)
      apply simp+ done
  from s1 have s2 : "\<forall>C. (topological_space.closed_set Y Ty C)
         \<longrightarrow>  (topological_space.closed_set X Tx (fun_preimage h C X)) " apply simp done
   from a3 a6 a7 a10 a11 a12 have s3:"h \<in> X \<rightarrow>Y"  apply( simp add :Pi_def)  done
  from  a1 a2 s2 s3 show ?thesis  apply (simp add:  closed_set_continuous) done
qed

end