(*  Title:       SetCat
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter SetCat

theory SetCat
imports SetCategory ConcreteCategory
begin

  text\<open>
    This theory proves the consistency of the \<open>set_category\<close> locale by giving
    a particular concrete construction of an interpretation for it.
    Applying the general construction given by @{locale concrete_category},
    we define arrows to be terms \<open>MkArr A B F\<close>, where \<open>A\<close> and \<open>B\<close> are sets
    and \<open>F\<close> is an extensional function that maps \<open>A\<close> to \<open>B\<close>.
\<close>

  text\<open>
    This locale uses an extra dummy parameter just to fix the element type for sets.
    Without this, a type is used for each interpretation, which makes it impossible to
    construct set categories whose element types are related to the context.
  \<close>

  locale setcat =
  fixes dummy :: 'e
  and \<AA> :: "'a rel"
  assumes cardinal: "Card_order \<AA> \<and> infinite (Field \<AA>)"
  begin

    lemma finite_imp_card_less:
    assumes "finite A"
    shows "|A| <o \<AA>"
    proof -
      have "finite (Field |A| )"
        using assms by simp
      thus ?thesis
        using cardinal card_of_Well_order card_order_on_def finite_ordLess_infinite
        by blast
    qed

    type_synonym 'b arr = "('b set, 'b \<Rightarrow> 'b) concrete_category.arr"

    interpretation concrete_category \<open>{A :: 'e set. |A| <o \<AA>}\<close> \<open>\<lambda>A B. extensional A \<inter> (A \<rightarrow> B)\<close>
                     \<open>\<lambda>A. \<lambda>x \<in> A. x\<close> \<open>\<lambda>C B A g f. compose A g f\<close>
      using compose_Id Id_compose
      apply unfold_locales
          apply auto[3]
       apply blast
      by (metis IntD2 compose_assoc)

    abbreviation comp :: "'e setcat.arr comp"     (infixr "\<cdot>" 55)
    where "comp \<equiv> COMP"
    notation in_hom                               ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")

    lemma MkArr_expansion:
    assumes "arr f"
    shows "f = MkArr (Dom f) (Cod f) (\<lambda>x \<in> Dom f. Map f x)"
    proof (intro arr_eqI)
      show "arr f" by fact
      show "arr (MkArr (Dom f) (Cod f) (\<lambda>x \<in> Dom f. Map f x))"
        using assms arr_char
        by (metis (mono_tags, lifting) Int_iff MkArr_Map extensional_restrict)
      show "Dom f = Dom (MkArr (Dom f) (Cod f) (\<lambda>x \<in> Dom f. Map f x))"
        by simp
      show "Cod f = Cod (MkArr (Dom f) (Cod f) (\<lambda>x \<in> Dom f. Map f x))"
        by simp
      show "Map f = Map (MkArr (Dom f) (Cod f) (\<lambda>x \<in> Dom f. Map f x))"
        using assms arr_char
        by (metis (mono_tags, lifting) Int_iff MkArr_Map extensional_restrict)
    qed

    lemma arr_char:
    shows "arr f \<longleftrightarrow> f \<noteq> Null \<and> |Dom f| <o \<AA> \<and> |Cod f| <o \<AA> \<and>
                     Map f \<in> extensional (Dom f) \<inter> (Dom f \<rightarrow> Cod f)"
      using arr_char by auto

    lemma terminal_char:
    shows "terminal a \<longleftrightarrow> (\<exists>x. a = MkIde {x})"
    proof
      show "\<exists>x. a = MkIde {x} \<Longrightarrow> terminal a"
      proof -
        assume a: "\<exists>x. a = MkIde {x}"
        from this obtain x where x: "a = MkIde {x}" by blast
        have "terminal (MkIde {x})"
        proof
          show 1: "ide (MkIde {x})"
            using finite_imp_card_less ide_MkIde by auto
          show "\<And>a. ide a \<Longrightarrow> \<exists>!f. \<guillemotleft>f : a \<rightarrow> MkIde {x}\<guillemotright>"
          proof
            fix a :: "'e setcat.arr"
            assume a: "ide a"
            show "\<guillemotleft>MkArr (Dom a) {x} (\<lambda>_\<in>Dom a. x) : a \<rightarrow> MkIde {x}\<guillemotright>"
            proof
              show 2: "arr (MkArr (Dom a) {x} (\<lambda>_ \<in> Dom a. x))"
                using a 1 arr_MkArr [of "Dom a" "{x}"] ide_char by force
              show "dom (MkArr (Dom a) {x} (\<lambda>_ \<in> Dom a. x)) = a"
                using a 2 dom_MkArr by force
              show "cod (MkArr (Dom a) {x} (\<lambda>_\<in>Dom a. x)) = MkIde {x}"
                using 2 cod_MkArr by blast
            qed
            fix f :: "'e setcat.arr"
            assume f: "\<guillemotleft>f : a \<rightarrow> MkIde {x}\<guillemotright>"
            show "f = MkArr (Dom a) {x} (\<lambda>_ \<in> Dom a. x)"
            proof -
              have 1: "Dom f = Dom a \<and> Cod f = {x}"
                using a f by (metis (mono_tags, lifting) Dom.simps(1) in_hom_char)
              moreover have "Map f = (\<lambda>_ \<in> Dom a. x)"
              proof
                fix z
                have "z \<notin> Dom a \<Longrightarrow> Map f z = (\<lambda>_ \<in> Dom a. x) z"
                  using f 1 MkArr_expansion
                  by (metis (mono_tags, lifting) Map.simps(1) in_homE restrict_apply)
                moreover have "z \<in> Dom a \<Longrightarrow> Map f z = (\<lambda>_ \<in> Dom a. x) z"
                  using f 1 arr_char [of f] by fastforce
                ultimately show "Map f z = (\<lambda>_ \<in> Dom a. x) z" by auto
              qed
              ultimately show ?thesis
               using f MkArr_expansion [of f] by fastforce
            qed
          qed
        qed
        thus "terminal a" using x by simp
      qed
      show "terminal a \<Longrightarrow> \<exists>x. a = MkIde {x}"
      proof -
        assume a: "terminal a"
        hence ide_a: "ide a" using terminal_def by auto
        have 1: "\<exists>!x. x \<in> Dom a"
        proof -
          have "Dom a = {} \<Longrightarrow> \<not>terminal a"
          proof -
            assume "Dom a = {}"
            hence 1: "a = MkIde {}"
              using MkIde_Dom' \<open>ide a\<close> by fastforce
            have "\<And>f. f \<in> hom (MkIde {undefined}) (MkIde ({} :: 'e set))
                         \<Longrightarrow> Map f \<in> {undefined} \<rightarrow> {}"
            proof -
              fix f
              assume f: "f \<in> hom (MkIde {undefined}) (MkIde ({} :: 'e set))"
              show "Map f \<in> {undefined} \<rightarrow> {}"
                using f MkArr_expansion arr_char [of f] in_hom_char by auto
            qed
            hence "hom (MkIde {undefined}) a = {}" using 1 by auto
            moreover have "ide (MkIde {undefined})"
              using finite_imp_card_less
              by (metis (mono_tags, lifting) finite.intros(1-2) ide_MkIde mem_Collect_eq)
            ultimately show "\<not>terminal a" by blast
          qed
          moreover have "\<And>x x'. x \<in> Dom a \<and> x' \<in> Dom a \<and> x \<noteq> x' \<Longrightarrow> \<not>terminal a"
          proof -
            fix x x'
            assume 1: "x \<in> Dom a \<and> x' \<in> Dom a \<and> x \<noteq> x'"
            let ?f = "MkArr {undefined} (Dom a) (\<lambda>_ \<in> {undefined}. x)"
            let ?f' = "MkArr {undefined} (Dom a) (\<lambda>_ \<in> {undefined}. x')"
            have "\<guillemotleft>?f : MkIde {undefined} \<rightarrow> a\<guillemotright>"
            proof
              show 2: "arr ?f"
              proof (intro arr_MkArr)
                show "{undefined} \<in> {A. |A| <o \<AA>}"
                  by (simp add: finite_imp_card_less)
                show "Dom a \<in> {A. |A| <o \<AA>}"
                  using ide_a ide_char by blast
                show "(\<lambda>_ \<in> {undefined}. x) \<in> extensional {undefined} \<inter> ({undefined} \<rightarrow> Dom a)"
                  using 1 by blast
              qed
              show "dom ?f = MkIde {undefined}"
                using 2 dom_MkArr by auto
              show "cod ?f = a"
                using 2 cod_MkArr ide_a by force
            qed
            moreover have "\<guillemotleft>?f' : MkIde {undefined} \<rightarrow> a\<guillemotright>"
            proof
              show 2: "arr ?f'"
                using 1 ide_a ide_char arr_MkArr [of "{undefined}" "Dom a"]
                      finite_imp_card_less
              proof (intro arr_MkArr)
                show "{undefined} \<in> {A. |A| <o \<AA>}"
                  by (simp add: finite_imp_card_less)
                show "Dom a \<in> {A. |A| <o \<AA>}"
                  using ide_a ide_char by blast
                show "(\<lambda>_ \<in> {undefined}. x') \<in> extensional {undefined} \<inter> ({undefined} \<rightarrow> Dom a)"
                  using 1 by blast
              qed
              show "dom ?f' = MkIde {undefined}"
                using 2 dom_MkArr by auto
              show "cod ?f' = a"
                using 2 cod_MkArr ide_a by force
            qed
            moreover have "?f \<noteq> ?f'"
              using 1 by (metis arr.inject restrict_apply' singletonI)
            ultimately show "\<not>terminal a"
              using terminal_arr_unique
              by (metis (mono_tags, lifting) in_homE)
          qed
          ultimately show ?thesis
            using a by auto
        qed
        hence "Dom a = {THE x. x \<in> Dom a}"
          using theI [of "\<lambda>x. x \<in> Dom a"] by auto
        hence "a = MkIde {THE x. x \<in> Dom a}"
          using a terminal_def by (metis (mono_tags, lifting) MkIde_Dom')
        thus "\<exists>x. a = MkIde {x}"
          by auto
      qed
    qed

    definition IMG :: "'e setcat.arr \<Rightarrow> 'e setcat.arr"
    where "IMG f = MkIde (Map f ` Dom f)"

    interpretation set_category_data comp IMG ..

    lemma terminal_unity:
    shows "terminal unity"
      using terminal_char unity_def someI_ex [of terminal]
      by (metis (mono_tags, lifting))

    text\<open>
      The inverse maps @{term UP} and @{term DOWN} are used to pass back and forth between
      the inhabitants of type @{typ 'a} and the corresponding terminal objects.
      These are exported so that a client of the theory can relate the concrete
      element type @{typ 'a} to the otherwise abstract arrow type.
\<close>

    definition UP :: "'e \<Rightarrow> 'e setcat.arr"
    where "UP x \<equiv> MkIde {x}"

    definition DOWN :: "'e setcat.arr \<Rightarrow> 'e"
    where "DOWN t \<equiv> the_elem (Dom t)"

    abbreviation U
    where "U \<equiv> DOWN unity"

    lemma UP_mapsto:
    shows "UP \<in> UNIV \<rightarrow> Univ"
      using terminal_char UP_def by fast

    lemma DOWN_mapsto:
    shows "DOWN \<in> Univ \<rightarrow> UNIV"
      by auto

    lemma DOWN_UP [simp]:
    shows "DOWN (UP x) = x"
      by (simp add: DOWN_def UP_def)

    lemma UP_DOWN [simp]:
    assumes "t \<in> Univ"
    shows "UP (DOWN t) = t"
      using assms terminal_char UP_def DOWN_def
      by (metis (mono_tags, lifting) mem_Collect_eq DOWN_UP)

    lemma inj_UP:
    shows "inj UP"
      by (metis DOWN_UP injI)

    lemma bij_UP:
    shows "bij_betw UP UNIV Univ"
    proof (intro bij_betwI)
      interpret category comp using is_category by auto
      show DOWN_UP: "\<And>x :: 'e. DOWN (UP x) = x" by simp
      show UP_DOWN: "\<And>t. t \<in> Univ \<Longrightarrow> UP (DOWN t) = t" by simp
      show "UP \<in> UNIV \<rightarrow> Univ" using UP_mapsto by auto
      show "DOWN \<in> Collect terminal \<rightarrow> UNIV" by auto
    qed

    lemma Dom_terminal:
    assumes "terminal t"
    shows "Dom t = {DOWN t}"
      using assms UP_def
      by (metis (mono_tags, lifting) Dom.simps(1) DOWN_def terminal_char the_elem_eq)

    text\<open>
      The image of a point @{term "p \<in> hom unity a"} is a terminal object, which is given
      by the formula @{term "(UP o Fun p o DOWN) unity"}.
\<close>

    lemma IMG_point:
    assumes "\<guillemotleft>p : unity \<rightarrow> a\<guillemotright>"
    shows "IMG \<in> hom unity a \<rightarrow> Univ"
    and "IMG p = (UP o Map p o DOWN) unity"
    proof -
      show "IMG \<in> hom unity a \<rightarrow> Univ"
      proof
        fix f
        assume f: "f \<in> hom unity a"
        have "terminal (MkIde (Map f ` Dom unity))"
        proof -
          obtain u :: 'e where u: "unity = MkIde {u}"
            using terminal_unity terminal_char
            by (metis (mono_tags, lifting))
          have "Map f ` Dom unity = {Map f u}"
            using u by simp
          thus ?thesis
            using terminal_char by auto
        qed
        hence "MkIde (Map f ` Dom unity) \<in> Univ" by simp
        moreover have "MkIde (Map f ` Dom unity) = IMG f"
          using f IMG_def in_hom_char
          by (metis (mono_tags, lifting) mem_Collect_eq)
        ultimately show "IMG f \<in> Univ" by auto
      qed
      have "IMG p = MkIde (Map p ` Dom p)" using IMG_def by blast
      also have "... = MkIde (Map p ` {U})"
        using assms in_hom_char terminal_unity Dom_terminal
        by (metis (mono_tags, lifting))
      also have "... = (UP o Map p o DOWN) unity" by (simp add: UP_def)
      finally show "IMG p = (UP o Map p o DOWN) unity" using assms by auto
    qed

    text\<open>
      The function @{term IMG} is injective on @{term "hom unity a"} and its inverse takes
      a terminal object @{term t} to the arrow in @{term "hom unity a"} corresponding to the
      constant-@{term t} function.
\<close>

    abbreviation MkElem :: "'e setcat.arr => 'e setcat.arr => 'e setcat.arr"
    where "MkElem t a \<equiv> MkArr {U} (Dom a) (\<lambda>_ \<in> {U}. DOWN t)"

    lemma MkElem_in_hom:
    assumes "arr f" and "x \<in> Dom f"
    shows "\<guillemotleft>MkElem (UP x) (dom f) : unity \<rightarrow> dom f\<guillemotright>"
    proof -
      have "(\<lambda>_ \<in> {U}. DOWN (UP x)) \<in> {U} \<rightarrow> Dom (dom f)"
        using assms dom_char [of f] by simp
      moreover have "MkIde {U} = unity"
        using terminal_char terminal_unity
        by (metis (mono_tags, lifting) DOWN_UP UP_def)
      moreover have "MkIde (Dom (dom f)) = dom f"
        using assms dom_char MkIde_Dom' ide_dom by blast
      ultimately show ?thesis
        using assms MkArr_in_hom [of "{U}" "Dom (dom f)" "\<lambda>_ \<in> {U}. DOWN (UP x)"]
        by (metis (no_types, lifting) Dom.simps(1) Dom_in_Obj IntI arr_dom ideD(1)
            restrict_extensional terminal_def terminal_unity)
    qed

    lemma MkElem_IMG:
    assumes "p \<in> hom unity a"
    shows "MkElem (IMG p) a = p"
    proof -
      have 0: "IMG p = UP (Map p U)"
        using assms IMG_point(2) by auto
      have 1: "Dom p = {U}"
        using assms terminal_unity Dom_terminal
        by (metis (mono_tags, lifting) in_hom_char mem_Collect_eq)
      moreover have "Cod p = Dom a"
        using assms
        by (metis (mono_tags, lifting) in_hom_char mem_Collect_eq)
      moreover have "Map p = (\<lambda>_ \<in> {U}. DOWN (IMG p))"
      proof
        fix e
        show "Map p e = (\<lambda>_ \<in> {U}. DOWN (IMG p)) e"
        proof -
          have "Map p e = (\<lambda>x \<in> Dom p. Map p x) e"
            using assms MkArr_expansion [of p]
            by (metis (mono_tags, lifting) CollectD Map.simps(1) in_homE)
          also have "... = (\<lambda>_ \<in> {U}. DOWN (IMG p)) e"
            using assms 0 1 by simp
          finally show ?thesis by blast
        qed
      qed
      ultimately show "MkElem (IMG p) a = p"
        using assms MkArr_Map CollectD
        by (metis (mono_tags, lifting) in_homE mem_Collect_eq)
    qed

    lemma inj_IMG:
    assumes "ide a"
    shows "inj_on IMG (hom unity a)"
    proof (intro inj_onI)
      fix x y
      assume x: "x \<in> hom unity a"
      assume y: "y \<in> hom unity a"
      assume eq: "IMG x = IMG y"
      show "x = y"
      proof (intro arr_eqI)
        show "arr x" using x by blast
        show "arr y" using y by blast
        show "Dom x = Dom y"
          using x y in_hom_char by (metis (mono_tags, lifting) CollectD)
        show "Cod x = Cod y"
          using x y in_hom_char by (metis (mono_tags, lifting) CollectD)
        show "Map x = Map y"
        proof -
          have "\<And>a. y \<in> hom unity a \<Longrightarrow> MkArr {U} (Dom a) (\<lambda>e\<in>{U}. DOWN (IMG x)) = y"
            using MkElem_IMG eq by presburger
          hence "y = x"
            using MkElem_IMG x y by blast
          thus ?thesis by meson
        qed
      qed
    qed

    lemma set_char:
    assumes "ide a"
    shows "set a = UP ` Dom a"
    proof
      show "set a \<subseteq> UP ` Dom a"
      proof
        fix t
        assume "t \<in> set a"
        from this obtain p where p: "\<guillemotleft>p : unity \<rightarrow> a\<guillemotright> \<and> t = IMG p"
          using set_def by blast
        have "t = (UP o Map p o DOWN) unity"
          using p IMG_point(2) by blast
        moreover have "(Map p o DOWN) unity \<in> Dom a"
          using p arr_char in_hom_char Dom_terminal terminal_unity
          by (metis (mono_tags, lifting) IntD2 Pi_split_insert_domain o_apply)
        ultimately show "t \<in> UP ` Dom a" by simp
      qed
      show "UP ` Dom a \<subseteq> set a"
      proof
        fix t
        assume "t \<in> UP ` Dom a"
        from this obtain x where x: "x \<in> Dom a \<and> t = UP x" by blast
        let ?p = "MkElem (UP x) a"
        have p: "?p \<in> hom unity a"
          using assms x MkElem_in_hom [of "dom a"] ideD(1-2) by force
        moreover have "IMG ?p = t"
          using p x DOWN_UP IMG_def UP_def
          by (metis (no_types, lifting) Dom.simps(1) Map.simps(1) image_empty
              image_insert image_restrict_eq)
        ultimately show "t \<in> set a" using set_def by blast
      qed
    qed

    lemma Map_via_comp:
    assumes "arr f"
    shows "Map f = (\<lambda>x \<in> Dom f. Map (f \<cdot> MkElem (UP x) (dom f)) U)"
    proof
      fix x
      have "x \<notin> Dom f \<Longrightarrow> Map f x = (\<lambda>x \<in> Dom f. Map (f \<cdot> MkElem (UP x) (dom f)) U) x"
        using assms arr_char [of f] IntD1 extensional_arb restrict_apply by fastforce
      moreover have
           "x \<in> Dom f \<Longrightarrow> Map f x = (\<lambda>x \<in> Dom f. Map (f \<cdot> MkElem (UP x) (dom f)) U) x"
      proof -
        assume x: "x \<in> Dom f"
        let ?X = "MkElem (UP x) (dom f)"
        have "\<guillemotleft>?X : unity \<rightarrow> dom f\<guillemotright>"
          using assms x MkElem_in_hom by auto
        moreover have "Dom ?X = {U} \<and> Map ?X = (\<lambda>_ \<in> {U}. x)"
          using x by simp
        ultimately have
          "Map (f \<cdot> MkElem (UP x) (dom f)) = compose {U} (Map f) (\<lambda>_ \<in> {U}. x)"
          using assms x Map_comp [of "MkElem (UP x) (dom f)" f]
          by (metis (mono_tags, lifting) Cod.simps(1) Dom_dom arr_iff_in_hom seqE seqI')
        thus ?thesis
          using x by (simp add: compose_eq restrict_apply' singletonI)
      qed
      ultimately show "Map f x = (\<lambda>x \<in> Dom f. Map (f \<cdot> MkElem (UP x) (dom f)) U) x"
        by auto
    qed

    text \<open>
      We need to show that the cardinality constraint on the sets that determine objects
      implies a corresponding constraint on the sets of global elements of those objects.
    \<close>

    lemma card_points_less:
    assumes "ide a"
    shows "|hom unity a| <o \<AA>"
    proof -
      have "bij_betw (\<lambda>f. Map f U) (hom unity a) (Dom a)"
      proof (intro bij_betwI')
        show "\<And>x. x \<in> hom unity a \<Longrightarrow> Map x (DOWN unity) \<in> Dom a"
          using arr_char Dom_terminal terminal_unity in_hom_char by auto
        show "\<And>x y. \<lbrakk>x \<in> hom unity a; y \<in> hom unity a\<rbrakk> \<Longrightarrow> Map x U = Map y U \<longleftrightarrow> x = y"
        proof -
          fix x y
          assume x: "x \<in> hom unity a" and y: "y \<in> hom unity a"
          have 1: "Map x \<in> extensional {U} \<and> Map y \<in> extensional {U}"
            using x y in_hom_char Dom_terminal terminal_unity
            by (metis (mono_tags, lifting) Map_via_comp mem_Collect_eq restrict_extensional)
          show "Map x U = Map y U \<longleftrightarrow> x = y"
          proof
            show "x = y \<Longrightarrow> Map x U = Map y U"
              by simp
            show "Map x U = Map y U \<Longrightarrow> x = y"
            proof -
              assume 2: "Map x U = Map y U"
              have "Map x = Map y"
              proof
                fix z
                show "Map x z = Map y z"
                  using 1 2 extensional_arb [of "Map x"] extensional_arb [of "Map y"]
                  by (cases "z = U") auto
              qed
              thus "x = y"
                using x y 1 in_hom_char
                by (intro arr_eqI) auto
            qed
          qed
        qed
        show "\<And>y. y \<in> Dom a \<Longrightarrow> \<exists>x \<in> hom unity a. y = Map x (DOWN unity)"
        proof -
          fix y
          assume y: "y \<in> Dom a"
          let ?x = "MkArr {DOWN unity} (Dom a) (\<lambda>_ \<in> {U}. y)"
          have "arr ?x"
          proof (intro arr_MkArr)
            show "{U} \<in> {A. |A| <o \<AA>}"
              by (metis (mono_tags, lifting) Dom_terminal ide_char terminal_def terminal_unity)
            show "Dom a \<in> {A. |A| <o \<AA>}"
              using assms ide_char by blast
            show "(\<lambda>_ \<in> {U}. y) \<in> extensional {U} \<inter> ({U} \<rightarrow> Dom a)"
              using assms y by blast
          qed
          hence "?x \<in> hom unity a"
            using UP_DOWN UP_def assms cod_MkArr dom_char in_homI terminal_unity by simp
          moreover have "y = Map ?x (DOWN unity)"
            by simp
          ultimately show "\<exists>x \<in> hom unity a. y = Map x (DOWN unity)"
            by auto
        qed
      qed
      hence "|hom unity a| =o |Dom a|"
        using card_of_ordIsoI by auto
      moreover have "|Dom a| <o \<AA>"
        using assms ide_char by auto
      ultimately show "|hom unity a| <o \<AA>"
        using ordIso_ordLess_trans by auto
    qed

    text\<open>
      The main result, which establishes the consistency of the \<open>set_category\<close> locale
      and provides us with a way of obtaining ``set categories'' at arbitrary types.
\<close>

    theorem is_set_category:
    shows "set_category comp \<AA>"
    proof
      show "\<exists>img :: 'e setcat.arr \<Rightarrow> 'e setcat.arr. set_category_given_img comp img \<AA>"
      proof
        show "set_category_given_img (comp :: 'e setcat.arr comp) IMG \<AA>"
        proof
          show "Card_order \<AA> \<and> infinite (Field \<AA> )"
            using cardinal by simp
          show "Univ \<noteq> {}" using terminal_char by blast
          fix a :: "'e setcat.arr"
          assume a: "ide a"
          show "IMG \<in> hom unity a \<rightarrow> Univ" using IMG_point terminal_unity by blast
          show "|hom unity a| <o \<AA>" using a card_points_less by simp
          show "inj_on IMG (hom unity a)" using a inj_IMG terminal_unity by blast
          next
          fix t :: "'e setcat.arr"
          assume t: "terminal t"
          show "t \<in> IMG ` hom unity t"
          proof -
            have "t \<in> set t"
              using t set_char [of t]
              by (metis (mono_tags, lifting) Dom.simps(1) image_insert insertI1 UP_def
                  terminal_char terminal_def)
            thus ?thesis
              using t set_def [of t] by simp
          qed
          next
          fix A :: "'e setcat.arr set"
          assume A: "A \<subseteq> Univ" and 0: "|A| <o \<AA>"
          show "\<exists>a. ide a \<and> set a = A"
          proof
            let ?a = "MkArr (DOWN ` A) (DOWN ` A) (\<lambda>x \<in> (DOWN ` A). x)"
            show "ide ?a \<and> set ?a = A"
            proof
              have "|DOWN ` A| <o \<AA>"
                using 0 card_of_image ordLeq_ordLess_trans by blast
              thus 1: "ide ?a"
                using ide_char [of ?a] by simp
              show "set ?a = A"
              proof -
                have 2: "\<And>x. x \<in> A \<Longrightarrow> x = UP (DOWN x)"
                  using A UP_DOWN by force
                hence "UP ` DOWN ` A = A"
                  using A UP_DOWN by auto
                thus ?thesis
                  using 1 A set_char [of ?a] by simp
              qed
            qed
          qed
          next
          fix a b :: "'e setcat.arr"
          assume a: "ide a" and b: "ide b" and ab: "set a = set b"
          show "a = b"
            using a b ab set_char inj_UP inj_image_eq_iff dom_char in_homE ide_in_hom
            by (metis (mono_tags, lifting))
          next
          fix f f' :: "'e setcat.arr"
          assume par: "par f f'" and ff': "\<And>x. \<guillemotleft>x : unity \<rightarrow> dom f\<guillemotright> \<Longrightarrow> f \<cdot> x = f' \<cdot> x"
          show "f = f'" using par ff' arr_eqI' by blast
          next
          fix a b :: "'e setcat.arr" and F :: "'e setcat.arr \<Rightarrow> 'e setcat.arr"
          assume a: "ide a" and b: "ide b" and F: "F \<in> hom unity a \<rightarrow> hom unity b"
          show "\<exists>f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> (\<forall>x. \<guillemotleft>x : unity \<rightarrow> dom f\<guillemotright> \<longrightarrow> f \<cdot> x = F x)"
          proof
            let ?f = "MkArr (Dom a) (Dom b) (\<lambda>x \<in> Dom a. Map (F (MkElem (UP x) a)) U)"
            have 1: "\<guillemotleft>?f : a \<rightarrow> b\<guillemotright>"
            proof -
              have "(\<lambda>x \<in> Dom a. Map (F (MkElem (UP x) a)) U)
                      \<in> extensional (Dom a) \<inter> (Dom a \<rightarrow> Dom b)"
              proof
                show "(\<lambda>x \<in> Dom a. Map (F (MkElem (UP x) a)) U) \<in> extensional (Dom a)"
                  using a F by simp
                show "(\<lambda>x \<in> Dom a. Map (F (MkElem (UP x) a)) U) \<in> Dom a \<rightarrow> Dom b"
                proof
                  fix x
                  assume x: "x \<in> Dom a"
                  have "MkElem (UP x) a \<in> hom unity a"
                    using x a MkElem_in_hom [of a x] ide_char ideD(1-2) by force
                  hence 1: "F (MkElem (UP x) a) \<in> hom unity b"
                    using F by auto
                  moreover have "Dom (F (MkElem (UP x) a)) = {U}"
                    using 1 MkElem_IMG
                    by (metis (mono_tags, lifting) Dom.simps(1))
                  moreover have "Cod (F (MkElem (UP x) a)) = Dom b"
                    using 1 by (metis (mono_tags, lifting) CollectD in_hom_char)
                  ultimately have "Map (F (MkElem (UP x) a)) \<in> {U} \<rightarrow> Dom b"
                    using arr_char [of "F (MkElem (UP x) a)"] by blast
                  thus "Map (F (MkElem (UP x) a)) U \<in> Dom b" by blast
                qed
              qed
              hence "\<guillemotleft>?f : MkIde (Dom a) \<rightarrow> MkIde (Dom b)\<guillemotright>"
                using a b MkArr_in_hom ide_char by blast
              thus ?thesis
                using a b by simp
            qed
            moreover have "\<And>x. \<guillemotleft>x : unity \<rightarrow> dom ?f\<guillemotright> \<Longrightarrow> ?f \<cdot> x = F x"
            proof -
              fix x
              assume x: "\<guillemotleft>x : unity \<rightarrow> dom ?f\<guillemotright>"
              have 2: "x = MkElem (IMG x) a"
                using a x 1 MkElem_IMG [of x a]
                by (metis (mono_tags, lifting) in_homE mem_Collect_eq)
              moreover have 5: "Dom x = {U} \<and> Cod x = Dom a \<and>
                                Map x = (\<lambda>_ \<in> {U}. DOWN (IMG x))"
                using x 2
                by (metis (no_types, lifting) Cod.simps(1) Dom.simps(1) Map.simps(1))
              moreover have "Cod ?f = Dom b" using 1 by simp
              ultimately have
                   3: "?f \<cdot> x =
                       MkArr {U} (Dom b) (compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (IMG x)))"
                using 1 x comp_char [of ?f "MkElem (IMG x) a"]
                by (metis (mono_tags, lifting) in_homE seqI)
              have 4: "compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (IMG x)) = Map (F x)"
              proof
                fix y
                have "y \<notin> {U} \<Longrightarrow>
                        compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (IMG x)) y = Map (F x) y"
                proof -
                  assume y: "y \<notin> {U}"
                  have "compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (IMG x)) y = undefined"
                    using y compose_def extensional_arb by simp
                  also have "... = Map (F x) y"
                  proof -
                    have 5: "F x \<in> hom unity b" using x F 1 by fastforce
                    hence "Dom (F x) = {U}"
                      by (metis (mono_tags, lifting) "2" CollectD Dom.simps(1) in_hom_char x)
                    thus ?thesis
                      using x y F 5 arr_char [of "F x"] extensional_arb [of "Map (F x)" "{U}" y]
                      by (metis (mono_tags, lifting) CollectD Int_iff in_hom_char)
                  qed
                  ultimately show ?thesis by auto
                qed
                moreover have
                    "y \<in> {U} \<Longrightarrow>
                       compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (IMG x)) y = Map (F x) y"
                proof -
                  assume y: "y \<in> {U}"
                  have "compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (IMG x)) y =
                        Map ?f (DOWN (IMG x))"
                    using y by (simp add: compose_eq restrict_apply')
                  also have "... = (\<lambda>x. Map (F (MkElem (UP x) a)) U) (DOWN (IMG x))"
                  proof -
                    have "DOWN (IMG x) \<in> Dom a"
                      using x y a 5 arr_char in_homE restrict_apply by force
                    thus ?thesis
                      using restrict_apply by simp
                  qed
                  also have "... = Map (F x) y"
                    using x y 1 2 MkElem_IMG [of x a] by simp
                  finally show
                      "compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (IMG x)) y = Map (F x) y"
                    by auto
                qed
                ultimately show
                    "compose {U} (Map ?f) (\<lambda>_ \<in> {U}. DOWN (IMG x)) y = Map (F x) y"
                  by auto
              qed
              show "?f \<cdot> x = F x"
              proof (intro arr_eqI)
                have 5: "?f \<cdot> x \<in> hom unity b" using 1 x by blast
                have 6: "F x \<in> hom unity b"
                  using x F 1
                  by (metis (mono_tags, lifting) PiE in_homE mem_Collect_eq)
                show "arr (comp ?f x)" using 5 by blast
                show "arr (F x)" using 6 by blast
                show "Dom (comp ?f x) = Dom (F x)"
                  using 5 6 by (metis (mono_tags, lifting) CollectD in_hom_char)
                show "Cod (comp ?f x) = Cod (F x)"
                  using 5 6 by (metis (mono_tags, lifting) CollectD in_hom_char)
                show "Map (comp ?f x) = Map (F x)"
                  using 3 4 by simp
              qed
            qed
            thus "\<guillemotleft>?f : a \<rightarrow> b\<guillemotright> \<and> (\<forall>x. \<guillemotleft>x : unity \<rightarrow> dom ?f\<guillemotright> \<longrightarrow> comp ?f x = F x)"
              using 1 by blast
          qed
        qed
      qed
    qed

    text\<open>
      \<open>SetCat\<close> can be viewed as a concrete set category over its own element type
      @{typ 'a}, using @{term UP} as the required injection from @{typ 'a} to the universe
      of \<open>SetCat\<close>.
\<close>

    corollary is_concrete_set_category:
    shows "concrete_set_category comp \<AA> UNIV UP"
    proof -
      interpret S: set_category comp \<AA> using is_set_category by auto
      show ?thesis
      proof
        show 1: "UP \<in> UNIV \<rightarrow> S.Univ"
          using UP_def terminal_char by force
        show "inj_on UP UNIV"
          using inj_UP by blast
      qed
    qed

    text\<open>
      As a consequence of the categoricity of the \<open>set_category\<close> axioms,
      if @{term S} interprets \<open>set_category\<close>, and if @{term \<phi>} is a bijection between
      the universe of @{term S} and the elements of type @{typ 'a}, then @{term S} is isomorphic
      to the category \<open>setcat\<close> of @{typ 'a} sets and functions between them constructed here.
\<close>

    corollary set_category_iso_SetCat:
    fixes S :: "'s comp" and \<phi> :: "'s \<Rightarrow> 'e"
    assumes "set_category S \<AA>"
    and "bij_betw \<phi> (Collect (category.terminal S)) UNIV"
    shows "\<exists>\<Phi>. invertible_functor S (comp :: 'e setcat.arr comp) \<Phi>
                 \<and> (\<forall>m. set_category.incl S \<AA> m \<longrightarrow> set_category.incl comp \<AA> (\<Phi> m))"
    proof -
      interpret S: set_category S using assms by auto
      let ?\<psi> = "inv_into S.Univ \<phi>"
      have "bij_betw (UP o \<phi>) S.Univ (Collect terminal)"
      proof (intro bij_betwI)
        show "UP o \<phi> \<in> S.Univ \<rightarrow> Collect terminal"
          using assms(2) UP_mapsto by auto
        show "?\<psi> o DOWN \<in> Collect terminal \<rightarrow> S.Univ"
        proof
          fix x :: "'e setcat.arr"
          assume x: "x \<in> Univ"
          show "(inv_into S.Univ \<phi> \<circ> DOWN) x \<in> S.Univ"
            using x assms(2) bij_betw_def comp_apply inv_into_into
            by (metis UNIV_I)
        qed
        fix t
        assume "t \<in> S.Univ"
        thus "(?\<psi> o DOWN) ((UP o \<phi>) t) = t"
          using assms(2) bij_betw_inv_into_left
          by (metis comp_apply DOWN_UP)
        next
        fix t' :: "'e setcat.arr"
        assume "t' \<in> Collect terminal"
        thus "(UP o \<phi>) ((?\<psi> o DOWN) t') = t'"
          using assms(2) by (simp add: bij_betw_def f_inv_into_f)
      qed
      thus ?thesis
        using assms(1) set_category_is_categorical [of S \<AA> comp "UP o \<phi>"] is_set_category
        by auto
    qed

  end

  sublocale setcat \<subseteq> set_category comp \<AA>
    using is_set_category by simp
  sublocale setcat \<subseteq> concrete_set_category comp \<AA> UNIV UP
    using is_concrete_set_category by simp

  text\<open>
    By using a large enough cardinal, we can effectively eliminate the cardinality constraint
    on the sets that determine objects and thereby obtain a set category that is replete.
    This is the normal use case, which we want to streamline as much as possible,
    so it is useful to introduce a special locale for this purpose.
  \<close>

  locale replete_setcat =
  fixes dummy :: 'e
  begin

    interpretation SC: setcat dummy
                         \<open>cardSuc (cmax (card_of (UNIV :: 'e setcat.arr set)) natLeq)\<close>
    proof
      show "Card_order (cardSuc (cmax (card_of (UNIV :: 'e setcat.arr set)) natLeq)) \<and>
            infinite (Field (cardSuc (cmax (card_of (UNIV :: 'e setcat.arr set)) natLeq)))"
      by (metis Card_order_cmax Field_natLeq cardSuc_Card_order cardSuc_finite
          card_of_Card_order finite_cmax infinite_UNIV_char_0 natLeq_Card_order)
    qed

    text\<open>
      We don't want to expose the concrete details of the construction used to obtain
      the interpretation \<open>SC\<close>; instead, we want any facts proved about it to be derived
      solely from the assumptions of the @{locale set_category} locales.
      So we create another level of definitions here.
    \<close>

    definition comp
    where "comp \<equiv> SC.comp"

    definition UP
    where "UP \<equiv> SC.UP"

    definition DOWN
    where "DOWN \<equiv> SC.DOWN"

    sublocale set_category comp \<open>cardSuc (cmax (card_of (UNIV :: 'e setcat.arr set)) natLeq)\<close>
      using SC.is_set_category comp_def by simp

    sublocale concrete_set_category comp
                \<open>cardSuc (cmax (card_of (UNIV :: 'e setcat.arr set)) natLeq)\<close> UNIV UP
      using SC.is_concrete_set_category comp_def UP_def by simp

    sublocale replete_set_category comp ..

    lemma UP_mapsto:
    shows "UP \<in> UNIV \<rightarrow> Univ"
      using SC.UP_mapsto
      by (simp add: UP_def comp_def)

    lemma DOWN_mapsto:
    shows "DOWN \<in> Univ \<rightarrow> UNIV"
      by auto

    lemma DOWN_UP [simp]:
    shows "DOWN (UP x) = x"
      by (simp add: DOWN_def UP_def)

    lemma UP_DOWN [simp]:
    assumes "t \<in> Univ"
    shows "UP (DOWN t) = t"
      using assms DOWN_def UP_def
      by (simp add: DOWN_def UP_def comp_def)

    lemma inj_UP:
    shows "inj UP"
      by (metis DOWN_UP injI)

    lemma bij_UP:
    shows "bij_betw UP UNIV Univ"
      by (metis SC.bij_UP UP_def comp_def)

  end

end


(*
  Author: Frederik Lyhne Andersen, DTU Compute, 2023
*)

theory DatalogBase
  imports Main
begin

section \<open>Datatypes\<close>

datatype tm = Const nat | Var nat
datatype atom = Pre nat \<open>tm list\<close>
datatype rule = Rule atom \<open>atom list\<close>

section \<open>Util\<close>

subsection \<open>Definitions\<close>

primrec is_var where
  \<open>is_var (Const _) \<longleftrightarrow> False\<close> |
  \<open>is_var (Var _) \<longleftrightarrow> True\<close>

primrec is_const where
  \<open>is_const (Const _) \<longleftrightarrow> True\<close> |
  \<open>is_const (Var _) \<longleftrightarrow> False\<close>

primrec sym where
  \<open>sym (Pre n _) = n\<close>

primrec syms_r where
  \<open>syms_r (Rule h b) = {sym h} \<union> sym ` set b\<close>

definition \<open>syms i \<equiv> sym ` i\<close>

definition \<open>syms_p p \<equiv> \<Union>r \<in> p. syms_r r\<close>

primrec vars_a where
  \<open>vars_a (Pre _ tms) = {tm \<in> set tms. is_var tm}\<close>

primrec vars_r where
  \<open>vars_r (Rule h b) = vars_a h \<union> (\<Union>a \<in> set b. vars_a a)\<close>

definition \<open>vars i \<equiv> \<Union>a \<in> i. vars_a a\<close>

definition \<open>vars_p p \<equiv> \<Union>r \<in> p. vars_r r\<close>

primrec adom_a where
  \<open>adom_a (Pre _ tms) = {tm \<in> set tms. is_const tm}\<close>

primrec adom_r where
  \<open>adom_r (Rule h b) = adom_a h \<union> (\<Union>a \<in> set b. adom_a a)\<close>

definition \<open>adom i \<equiv> \<Union>a \<in> i. adom_a a\<close>

definition \<open>adom_p p \<equiv> (\<Union>r \<in> p. adom_r r)\<close>

subsection \<open>Proofs\<close>

lemma adom_a_interp:
    \<open>\<not> adom_a a \<subseteq> adom i \<Longrightarrow>
     a \<notin> i\<close>
  unfolding adom_def
  by (induct a) auto

lemma vars_a_finite:
    \<open>finite (vars_a a)\<close>
  by (induct a) simp

lemma vars_finite:
    \<open>finite i \<Longrightarrow>
     finite (vars i)\<close>
  unfolding vars_def
  using vars_a_finite
  by simp

lemma adom_a_finite:
    \<open>finite (adom_a a)\<close>
  by (induct a) simp

lemma adom_r_finite:
    \<open>finite (adom_r r)\<close>
  using adom_a_finite
  by (induct r) simp

lemma adom_p_finite:
    \<open>finite p \<Longrightarrow>
     finite (adom_p p)\<close>
  unfolding adom_p_def
  using adom_r_finite
  by simp

lemma syms_r_finite:
    \<open>finite (syms_r r)\<close>
  by (induct r) simp

lemma syms_p_finite:
    \<open>finite p \<Longrightarrow>
     finite (syms_p p)\<close>
  unfolding syms_p_def
  using syms_r_finite
  by simp

lemma adom_finite:
    \<open>finite i \<Longrightarrow>
     finite (adom i)\<close>
  unfolding adom_def
  using adom_a_finite
  by simp

lemma const_not_var:
    \<open>is_const tm \<noteq> is_var tm\<close>
  by (induct tm) simp_all

lemma adom_a_adom_interp:
    \<open>a \<in> i \<Longrightarrow>
     adom_a a \<subseteq> adom i\<close>
  unfolding adom_def
  by auto

lemma adom_a_const:
    \<open>tm \<in> adom_a a \<Longrightarrow>
     is_const tm\<close>
  by (induct a) simp

lemma adom_const:
    \<open>tm \<in> adom i \<Longrightarrow>
     is_const tm\<close>
  unfolding adom_def
  using adom_a_const
  by auto

lemma adom_r_const:
    \<open>tm \<in> adom_r r \<Longrightarrow>
     is_const tm\<close>
  using adom_a_const
  by (induct r) auto

lemma adom_p_const:
    \<open>tm \<in> adom_p p \<Longrightarrow>
     is_const tm\<close>
  unfolding adom_p_def
  using adom_r_const
  by auto

lemma vars_a_var:
    \<open>tm \<in> vars_a a \<Longrightarrow>
     is_var tm\<close>
  by (induct a) simp

lemma vars_var:
    \<open>tm \<in> vars i \<Longrightarrow>
     is_var tm\<close>
  unfolding vars_def
  using vars_a_var
  by auto

lemma vars_r_var:
    \<open>tm \<in> vars_r r \<Longrightarrow>
     is_var tm\<close>
  using vars_a_var
  by (induct r) auto

lemma vars_p_var:
    \<open>tm \<in> vars_p p \<Longrightarrow>
     is_var tm\<close>
  unfolding vars_p_def
  using vars_r_var
  by auto

lemma adom_subset:
    \<open>i1 \<subseteq> i2 \<Longrightarrow>
     adom i1 \<subseteq> adom i2\<close>
  unfolding adom_def
  by auto

lemma adom_p_subset:
    \<open>p1 \<subseteq> p2 \<Longrightarrow>
     adom_p p1 \<subseteq> adom_p p2\<close>
  unfolding adom_p_def
  by auto

lemma syms_subset:
    \<open>i1 \<subseteq> i2 \<Longrightarrow>
     syms i1 \<subseteq> syms i2\<close>
  unfolding syms_def
  by auto

lemma syms_p_subset:
    \<open>p1 \<subseteq> p2 \<Longrightarrow>
     syms_p p1 \<subseteq> syms_p p2\<close>
  unfolding syms_p_def
  by auto

lemma head_adom_in_program:
    \<open>Rule h b \<in> p \<Longrightarrow>
     adom_a h \<subseteq> adom_p p\<close>
  unfolding adom_p_def
  by (induct h) auto

lemma rule_head_pred_in_syms:
    \<open>Rule (Pre n tms) b \<in> p \<Longrightarrow>
     n \<in> syms_p p\<close>
  unfolding syms_p_def
  by force

lemma rule_head_pred_in_syms2:
    \<open>Rule h b \<in> p \<Longrightarrow>
     sym h \<in> syms_p p\<close>
  unfolding syms_p_def
  by force

section \<open>Well Formedness and Safety\<close>

subsection \<open>Definitions\<close>

primrec safe_r where
  \<open>safe_r (Rule h b) \<longleftrightarrow> vars_a h \<subseteq> vars (set b)\<close>

definition \<open>safe_p p \<equiv> \<forall>r \<in> p. safe_r r\<close>

primrec wf_a where
  \<open>wf_a (Pre n tms) ar \<longleftrightarrow> ar n = length tms\<close>

primrec wf_r where
  \<open>wf_r (Rule h b) ar \<longleftrightarrow> wf_a h ar \<and> (\<forall>a \<in> set b. wf_a a ar)\<close>

primrec ground_a where
  \<open>ground_a (Pre _ tms) \<longleftrightarrow> (\<forall>tm \<in> set tms. is_const tm)\<close>

definition \<open>wf_i i ar \<equiv> finite i \<and> (\<forall>a \<in> i. ground_a a \<and> wf_a a ar)\<close>

definition \<open>wf_p p ar \<equiv> finite p \<and> p \<noteq> {} \<and> (\<forall>r \<in> p. wf_r r ar)\<close>

subsection \<open>Proofs\<close>

lemma wf_p_subset:
    \<open>wf_p p1 ar \<Longrightarrow>
     p2 \<noteq> {} \<Longrightarrow>
     p2 \<subseteq> p1 \<Longrightarrow>
     wf_p p2 ar\<close>
  unfolding wf_p_def
  using finite_subset
  by auto

lemma wf_p_subset2:
    \<open>wf_p p1 ar \<Longrightarrow>
     \<forall>p2 \<le> p1. p2 \<noteq> {} \<longrightarrow> wf_p p2 ar\<close>
  unfolding wf_p_def
  using finite_subset
  by auto

lemma wf_p_union:
    \<open>wf_p p1 ar \<Longrightarrow>
     wf_p p2 ar \<Longrightarrow>
     wf_p (p1 \<union> p2) ar\<close>
  unfolding wf_p_def
  by auto

lemma safe_p_subset:
    \<open>safe_p p1 \<Longrightarrow>
     p2 \<subseteq> p1 \<Longrightarrow>
     safe_p p2\<close>
  unfolding safe_p_def
  by auto

lemma safe_p_subset2:
    \<open>safe_p p1 \<Longrightarrow>
     \<forall>p2 \<le> p1. safe_p p2\<close>
  unfolding safe_p_def
  by auto

lemma safe_p_union:
    \<open>safe_p p1 \<Longrightarrow>
     safe_p p2 \<Longrightarrow>
     safe_p (p1 \<union> p2)\<close>
  unfolding safe_p_def
  by auto

lemma no_vars_ground_a:
    \<open>vars_a a = {} \<longleftrightarrow> ground_a a\<close>
  using const_not_var
  by (induct a) auto

lemma ground_a_safe_r:
    \<open>ground_a h \<Longrightarrow>
     safe_r (Rule h b)\<close>
  using const_not_var
  by (induct h) auto

section \<open>Satisfiability\<close>

subsection \<open>Definitions\<close>

primrec assign_tm :: \<open>tm \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> tm\<close> (\<open>\<lbrakk>_\<rbrakk>\<^sub>t\<^sub>m_\<close> [100,100]) where
  \<open>\<lbrakk>Const n\<rbrakk>\<^sub>t\<^sub>mv = Const n\<close> |
  \<open>\<lbrakk>Var n\<rbrakk>\<^sub>t\<^sub>mv = Const (v n)\<close>

primrec assign :: \<open>atom \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> atom\<close> (\<open>\<lbrakk>_\<rbrakk>\<^sub>a_\<close> [100,100]) where
  \<open>\<lbrakk>Pre n tms\<rbrakk>\<^sub>av = Pre n (map (\<lambda>tm. \<lbrakk>tm\<rbrakk>\<^sub>t\<^sub>mv) tms)\<close>

primrec sat_rule :: \<open>atom set \<Rightarrow> rule \<Rightarrow> bool\<close> (infix \<open>\<Turnstile>\<^sub>r\<close> 100) where
  \<open>i \<Turnstile>\<^sub>r Rule h b \<longleftrightarrow> (\<forall>v. (\<forall>a \<in> set b. \<lbrakk>a\<rbrakk>\<^sub>av \<in> i) \<longrightarrow> \<lbrakk>h\<rbrakk>\<^sub>av \<in> i)\<close>

definition sat_prog :: \<open>atom set \<Rightarrow> rule set \<Rightarrow> bool\<close> (infix \<open>\<Turnstile>\<^sub>p\<close> 100) where
  \<open>i \<Turnstile>\<^sub>p p \<equiv> \<forall>r \<in> p. i \<Turnstile>\<^sub>r r\<close>

definition min_model :: \<open>atom set \<Rightarrow> rule set \<Rightarrow> bool\<close> (infix \<open>\<Turnstile>\<^sub>m\<^sub>i\<^sub>n\<close> 100) where
  \<open>i \<Turnstile>\<^sub>m\<^sub>i\<^sub>n p \<equiv> i \<Turnstile>\<^sub>p p \<and> \<not>(\<exists>m \<subset> i. m \<Turnstile>\<^sub>p p)\<close>

definition min :: \<open>rule set \<Rightarrow> atom set\<close> where
  \<open>min p \<equiv> THE i. i \<Turnstile>\<^sub>m\<^sub>i\<^sub>n p\<close>

subsection \<open>Proofs\<close>

lemma sat_rule_UNIV:
    \<open>UNIV \<Turnstile>\<^sub>r r\<close>
  by (induct r) auto

lemma sat_prog_UNIV:
    \<open>UNIV \<Turnstile>\<^sub>p p\<close>
  unfolding sat_prog_def
  using sat_rule_UNIV
  by simp

theorem prog_has_model:
    \<open>\<exists>m. m \<Turnstile>\<^sub>p p\<close>
  using sat_prog_UNIV
  by auto

lemma sat_prog_union:
    \<open>i \<Turnstile>\<^sub>p (p1 \<union> p2) \<longleftrightarrow> i \<Turnstile>\<^sub>p p1 \<and> i \<Turnstile>\<^sub>p p2\<close>
  using sat_prog_def
  by auto

lemma prog_subset_sat:
    \<open>p1 \<subseteq> p2 \<Longrightarrow>
     i \<Turnstile>\<^sub>p p2 \<Longrightarrow>
     i \<Turnstile>\<^sub>p p1\<close>
  unfolding sat_prog_def
  by auto

lemma prog_subset_sat2:
    \<open>i \<Turnstile>\<^sub>p p \<Longrightarrow>
     \<forall>ps \<le> p. i \<Turnstile>\<^sub>p ps\<close>
  using prog_subset_sat
  by simp

lemma const_assign_to_self:
    \<open>is_const tm \<Longrightarrow>
     \<lbrakk>tm\<rbrakk>\<^sub>t\<^sub>mv = tm\<close>
  by (induct tm) auto

lemma assign_tm_const:
    \<open>is_const (\<lbrakk>tm\<rbrakk>\<^sub>t\<^sub>mv)\<close>
  by (induct tm) auto

lemma ground_a_assign:
    \<open>ground_a a \<Longrightarrow>
     \<lbrakk>a\<rbrakk>\<^sub>av = a\<close>
proof (induct a)
  case (Pre n tms)
  then show ?case
  proof -
    assume \<open>ground_a (Pre n tms)\<close>
    then have \<open>\<forall>tm \<in> set tms. is_const tm\<close>
      by simp
    then have \<open>\<forall>tm \<in> set tms. \<lbrakk>tm\<rbrakk>\<^sub>t\<^sub>mv = tm\<close>
      using const_assign_to_self
      by simp
    then have \<open>map (\<lambda>tm. \<lbrakk>tm\<rbrakk>\<^sub>t\<^sub>mv) tms = tms\<close>
      using map_idI
      by metis
    then show \<open>\<lbrakk>Pre n tms\<rbrakk>\<^sub>av = Pre n tms\<close>
      by simp
  qed
qed

lemma assign_ground_a:
    \<open>ground_a (\<lbrakk>a\<rbrakk>\<^sub>av)\<close>
  using assign_tm_const
  by (induct a) simp

lemma assign_wf_a:
    \<open>wf_a a ar \<Longrightarrow>
     wf_a (\<lbrakk>a\<rbrakk>\<^sub>av) ar\<close>
  by (induct a) auto

lemma assign_same_sym:
    \<open>sym a \<in> syms_p p \<Longrightarrow>
     sym (\<lbrakk>a\<rbrakk>\<^sub>av) \<in> syms_p p\<close>
  by (induct a) auto

lemma fact_in_interp_rule:
    \<open>safe_r (Rule h []) \<Longrightarrow>
     i \<Turnstile>\<^sub>r Rule h [] \<Longrightarrow>
     h \<in> i\<close>
  using vars_def ground_a_assign no_vars_ground_a
  by auto

lemma fact_in_interp:
    \<open>safe_p p \<Longrightarrow>
     Rule h [] \<in> p \<Longrightarrow>
     i \<Turnstile>\<^sub>p p \<Longrightarrow>
     h \<in> i\<close>
  unfolding safe_p_def sat_prog_def
  using fact_in_interp_rule
  by blast

lemma const_not_in_adom:
    \<open>Const (v x) \<notin> adom_a (\<lbrakk>a\<rbrakk>\<^sub>av) \<Longrightarrow>
     Var x \<notin> vars_a a\<close>
proof (induct a)
  case (Pre n tms)
  then show ?case
  proof -
    assume \<open>Const (v x) \<notin> adom_a (\<lbrakk>Pre n tms\<rbrakk>\<^sub>av)\<close>
    then have \<open>Const (v x) \<notin> (\<lambda>tm. \<lbrakk>tm\<rbrakk>\<^sub>t\<^sub>mv) ` set tms\<close>
      by simp
    then have \<open>\<lbrakk>Var x\<rbrakk>\<^sub>t\<^sub>mv \<notin> (\<lambda>tm. \<lbrakk>tm\<rbrakk>\<^sub>t\<^sub>mv) ` set tms\<close>
      by simp
    then have \<open>Var x \<notin> set tms\<close>
      by blast
    then show \<open>Var x \<notin> vars_a (Pre n tms)\<close>
      by simp
  qed
qed

lemma adom_assign_subset_head_body:
    \<open>safe_r (Rule h b) \<Longrightarrow>
     tm \<in> adom_a (\<lbrakk>h\<rbrakk>\<^sub>av) \<Longrightarrow>
     tm \<notin> adom_a h \<Longrightarrow>
     tm \<in> adom {\<lbrakk>a\<rbrakk>\<^sub>av | a. a \<in> set b}\<close>
proof (induct tm)
  case (Const x)
  then show ?case
  proof (induct h)
    case (Pre n tmsn)
    then show ?case
    proof -
      assume a1: \<open>safe_r (Rule (Pre n tmsn) b)\<close>
      assume a2: \<open>Const x \<in> adom_a (\<lbrakk>Pre n tmsn\<rbrakk>\<^sub>av)\<close>
      assume a3: \<open>Const x \<notin> adom_a (Pre n tmsn)\<close>
      then have a4: \<open>Const x \<notin> {tm \<in> set tmsn. is_const tm}\<close>
        by simp
      have \<open>Const x \<in> set (map (\<lambda>tm. \<lbrakk>tm\<rbrakk>\<^sub>t\<^sub>mv) tmsn)\<close>
        using a2
        by simp
      then have \<open>Const x \<in> {tm \<in> set tmsn. is_const tm} \<union>
                           (\<lambda>tm. \<lbrakk>tm\<rbrakk>\<^sub>t\<^sub>mv) ` {tm \<in> set tmsn. is_var tm}\<close>
        using const_assign_to_self const_not_var
        by force
      then have \<open>Const x \<in> (\<lambda>tm. \<lbrakk>tm\<rbrakk>\<^sub>t\<^sub>mv) ` {tm \<in> set tmsn. is_var tm}\<close>
        using a4
        by simp
      then have \<open>Const x \<in> (\<lambda>tm. \<lbrakk>tm\<rbrakk>\<^sub>t\<^sub>mv) ` \<Union> (vars_a ` set b)\<close>
        using a1 vars_def
        by auto
      then have \<open>\<exists>a\<in>set b. Const x \<in> (\<lambda>tm. \<lbrakk>tm\<rbrakk>\<^sub>t\<^sub>mv) ` (vars_a a)\<close>
        by auto
      then obtain j tmsj where \<open>Pre j tmsj \<in> set b \<and>
                                Const x \<in> (\<lambda>tm. \<lbrakk>tm\<rbrakk>\<^sub>t\<^sub>mv) ` (vars_a (Pre j tmsj))\<close>
        using atom.exhaust
        by metis
      then have \<open>Pre j tmsj \<in> set b \<and>
                 Const x \<in> (\<lambda>tm. \<lbrakk>tm\<rbrakk>\<^sub>t\<^sub>mv) ` {tm \<in> set tmsj. is_var tm}\<close>
        by simp
      then have \<open>Pre j tmsj \<in> set b \<and> Const x \<in> set (map (\<lambda>tm. \<lbrakk>tm\<rbrakk>\<^sub>t\<^sub>mv) tmsj)\<close>
        by auto
      then have \<open>Pre j tmsj \<in> set b \<and> Const x \<in> adom_a (\<lbrakk>Pre j tmsj\<rbrakk>\<^sub>av)\<close>
        by auto
      then have \<open>\<exists>a\<in>set b. Const x \<in> adom_a (\<lbrakk>a\<rbrakk>\<^sub>av)\<close>
        by blast
      then show \<open>Const x \<in> adom {\<lbrakk>a\<rbrakk>\<^sub>av | a. a \<in> set b}\<close>
        using adom_def
        by auto
    qed
  qed
next
  case (Var x)
  then show ?case
  proof -
    assume \<open>Var x \<in> adom_a (\<lbrakk>h\<rbrakk>\<^sub>av)\<close>
    then have a1: \<open>is_const (Var x)\<close>
      using adom_a_const
      by blast
    have \<open>is_var (Var x)\<close>
      by simp
    then have \<open>False\<close>
      using a1 const_not_var
      by simp
    then show \<open>Var x \<in> adom {\<lbrakk>a\<rbrakk>\<^sub>av |a. a \<in> set b}\<close>
      by simp
  qed
qed

section \<open>Herbrand Base\<close>

subsection \<open>Definitions\<close>

definition \<open>lists_len i len \<equiv> {tms. set tms \<subseteq> i \<and> length tms = len}\<close>

definition \<open>sym_atoms n i len \<equiv> {Pre n tms | tms. tms \<in> lists_len i len}\<close>

definition herbrand :: \<open>rule set \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> atom set\<close> (\<open>\<bool>\<lparr>_\<rparr>\<^bsub>_\<^esub>\<close>) where
  \<open>\<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub>\<equiv> \<Union>n \<in> syms_p p. sym_atoms n (adom_p p) (ar n)\<close>

subsection \<open>Proofs\<close>

subsubsection \<open>Finiteness\<close>

lemma lists_len_finite:
    \<open>finite i \<Longrightarrow>
     finite (lists_len i len)\<close>
  unfolding lists_len_def
  using finite_lists_length_eq
  by auto

lemma sym_atoms_finite:
    \<open>finite i \<Longrightarrow>
     finite (sym_atoms n i len)\<close>
proof -
  assume \<open>finite i\<close>
  then have \<open>finite (lists_len i len)\<close>
    using lists_len_finite
    by auto
  then have a1: \<open>finite (Pre n ` {tms. tms \<in> lists_len i len})\<close>
    by simp
  have \<open>Pre n ` {tms. tms \<in> lists_len i len} = sym_atoms n i len\<close>
    using sym_atoms_def
    by auto
  then show \<open>finite (sym_atoms n i len)\<close>
    using sym_atoms_def a1
    by simp
qed

theorem herbrand_finite:
    \<open>finite p \<Longrightarrow>
     finite \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub>\<close>
  unfolding herbrand_def
  using adom_p_finite sym_atoms_finite syms_p_finite
  by simp

subsubsection \<open>Satisfiability\<close>

theorem wf_ground_a_in_herbrand:
      \<open>wf_a a ar \<Longrightarrow>
       ground_a a \<Longrightarrow>
       sym a \<in> syms_p p \<Longrightarrow>
       adom_a a \<subseteq> adom_p p \<Longrightarrow>
       a \<in> \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub>\<close>
  unfolding herbrand_def sym_atoms_def lists_len_def
  by (induct a) auto

lemma replicate_atom_in_herbrand:
    \<open>wf_a (Pre n tms) ar \<Longrightarrow>
     tm \<in> adom_a (Pre n tms) \<Longrightarrow>
     Rule (Pre n tms) b \<in> p \<Longrightarrow>
     Pre n (replicate (length tms) tm) \<in> \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub>\<close>
proof -
  assume a1: \<open>wf_a (Pre n tms) ar\<close>
  assume a2: \<open>tm \<in> adom_a (Pre n tms)\<close>
  assume a3: \<open>Rule (Pre n tms) b \<in> p\<close>
  have a4 :\<open>n \<in> syms_p p\<close>
    using rule_head_pred_in_syms a3
    by simp
  have \<open>adom_a (Pre n tms) \<subseteq> adom_p p\<close>
    using head_adom_in_program a3
    by blast
  then have \<open>set (replicate (length tms) tm) \<subseteq> adom_p p\<close>
    using a2
    by auto
  then have \<open>replicate (length tms) tm \<in>
             {tms. set tms \<subseteq> adom_p p \<and> length tms = ar n}\<close>
    using a1
    by auto
  then have \<open>Pre n (replicate (length tms) tm) \<in>
             {Pre n tms |tms. tms \<in> lists_len (adom_p p) (ar n)}\<close>
    using lists_len_def
    by blast
  then have \<open>Pre n (replicate (length tms) tm) \<in>
             (\<Union>n\<in>syms_p p. sym_atoms n (adom_p p) (ar n))\<close>
    using sym_atoms_def a4
    by auto
  then show \<open>Pre n (replicate (length tms) tm) \<in> \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub>\<close>
    using herbrand_def
    by simp
qed

lemma in_adom_replicate_in_herbrand:
    \<open>tm \<in> adom_a (Pre n tms) \<Longrightarrow>
     Pre n (replicate (length tms) tm) \<in> \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub> \<Longrightarrow>
     tm \<in> adom \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub>\<close>
proof -
  assume a1: \<open>tm \<in> adom_a (Pre n tms)\<close>
  assume a2: \<open>Pre n (replicate (length tms) tm) \<in> \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub>\<close>
  then have a3: \<open>adom_a (Pre n (replicate (length tms) tm)) \<subseteq> adom \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub>\<close>
    using adom_a_adom_interp
    by blast
  have \<open>adom_a (Pre n (replicate (length tms) tm)) = {tm}\<close>
    using a1
    by auto
  then show \<open>tm \<in> adom \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub>\<close>
    using a3
    by simp
qed

lemma adom_head_adom_herbrand:
    \<open>wf_a h ar \<Longrightarrow>
     Rule h b \<in> p \<Longrightarrow>
     adom_a h \<subseteq> adom \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub>\<close>
proof -
  assume a1: \<open>wf_a h ar\<close>
  assume a2: \<open>Rule h b \<in> p\<close>
  obtain n tms where a3: \<open>h = Pre n tms\<close>
    using atom.exhaust
    by auto
  then have \<open>\<forall>tm. tm \<in> adom_a (Pre n tms) \<longrightarrow>
                  Pre n (replicate (length tms) tm) \<in> \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub>\<close>
    using replicate_atom_in_herbrand a1 a2
    by simp
  then have \<open>\<forall>tm. tm \<in> adom_a (Pre n tms) \<longrightarrow> tm \<in> adom \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub>\<close>
    using in_adom_replicate_in_herbrand
    by auto
  then show \<open>adom_a h \<subseteq> adom \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub>\<close>
    using a3
    by auto
qed

lemma adom_assign_head_adom_herbrand:
    \<open>wf_r (Rule h b) ar \<Longrightarrow>
     safe_r (Rule h b) \<Longrightarrow>
     Rule h b \<in> p \<Longrightarrow>
     \<forall>a\<in>set b. \<lbrakk>a\<rbrakk>\<^sub>av \<in> \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub> \<Longrightarrow>
     adom_a (\<lbrakk>h\<rbrakk>\<^sub>av) \<subseteq> adom \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub>\<close>
proof -
  assume a1: \<open>wf_r (Rule h b) ar\<close>
  assume a2: \<open>safe_r (Rule h b)\<close>
  assume a3: \<open>Rule h b \<in> p\<close>
  assume a4: \<open>\<forall>a\<in>set b. \<lbrakk>a\<rbrakk>\<^sub>av \<in> \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub>\<close>
  have a5: \<open>adom_a (\<lbrakk>h\<rbrakk>\<^sub>av) \<subseteq> adom {\<lbrakk>a\<rbrakk>\<^sub>av |a. a \<in> set b} \<union> adom_a h\<close>
    using adom_assign_subset_head_body a2
    by auto
  have \<open>wf_a h ar\<close>
    using a1
    by simp
  then have a6:\<open>adom_a h \<subseteq> adom \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub>\<close>
    using a3 adom_head_adom_herbrand
    by simp
  have \<open>adom {\<lbrakk>a\<rbrakk>\<^sub>av |a. a \<in> set b} \<subseteq> adom \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub>\<close>
    using adom_def a4
    by auto
  then have \<open>adom_a h \<union> adom {\<lbrakk>a\<rbrakk>\<^sub>av |a. a \<in> set b} \<subseteq> adom \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub>\<close>
    using a6
    by simp
  then show \<open>adom_a (\<lbrakk>h\<rbrakk>\<^sub>av) \<subseteq> adom \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub>\<close>
    using a5
    by auto
qed

lemma adom_herbrand_adom_p:
    \<open>adom \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub> \<subseteq> adom_p p\<close>
  unfolding herbrand_def sym_atoms_def lists_len_def adom_def
  by auto

lemma herbrand_sat_rule:
    \<open>wf_p p ar \<Longrightarrow>
     safe_p p \<Longrightarrow>
     r \<in> p \<Longrightarrow>
     \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub> \<Turnstile>\<^sub>r r\<close>
proof (induct r)
  case (Rule h b)
  then show ?case
  proof -
    assume a1: \<open>wf_p p ar\<close>
    assume a2: \<open>safe_p p\<close>
    assume a3: \<open>Rule h b \<in> p\<close>
    have a7: \<open>wf_r (Rule h b) ar\<close>
      using a1 a3 wf_p_def
      by auto
    then have \<open>wf_a h ar\<close>
      by auto
    then have a9: \<open>\<forall>v. wf_a (\<lbrakk>h\<rbrakk>\<^sub>av) ar\<close>
      using assign_wf_a
      by simp
    have a10: \<open>\<forall>v. ground_a (\<lbrakk>h\<rbrakk>\<^sub>av)\<close>
      using assign_ground_a
      by simp
    have a11: \<open>\<forall>v. sym (\<lbrakk>h\<rbrakk>\<^sub>av) \<in> syms_p p\<close>
      using rule_head_pred_in_syms2 a3 assign_same_sym
      by simp
    have \<open>safe_r (Rule h b)\<close>
      using a2 a3 safe_p_def
      by blast
    then have \<open>\<forall>v. (\<forall>a\<in>set b. \<lbrakk>a\<rbrakk>\<^sub>av \<in> \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub>) \<longrightarrow>
                   adom_a (\<lbrakk>h\<rbrakk>\<^sub>av) \<subseteq> adom \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub>\<close>
      using a7 a3 adom_assign_head_adom_herbrand
      by blast
    then have \<open>\<forall>v. (\<forall>a\<in>set b. \<lbrakk>a\<rbrakk>\<^sub>av \<in> \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub>) \<longrightarrow>
                   adom_a (\<lbrakk>h\<rbrakk>\<^sub>av) \<subseteq> adom_p p\<close>
      using adom_herbrand_adom_p
      by blast
    then have \<open>\<forall>v. (\<forall>a\<in>set b. \<lbrakk>a\<rbrakk>\<^sub>av \<in> \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub>) \<longrightarrow>
                   \<lbrakk>h\<rbrakk>\<^sub>av \<in> \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub>\<close>
      using a9 a10 a11 wf_ground_a_in_herbrand
      by simp
    then show \<open>\<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub> \<Turnstile>\<^sub>r Rule h b\<close>
      by simp
  qed
qed

theorem herbrand_sat_prog:
    \<open>safe_p p \<Longrightarrow>
     wf_p p ar \<Longrightarrow>
     \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub> \<Turnstile>\<^sub>p p\<close>
  unfolding sat_prog_def
  using herbrand_sat_rule
  by auto

theorem safe_wf_p_finite:
    \<open>safe_p p \<Longrightarrow>
     wf_p p ar \<Longrightarrow>
     \<exists>m. m \<Turnstile>\<^sub>p p \<and> finite m\<close>
proof -
  assume a1: \<open>safe_p p\<close>
  assume a2: \<open>wf_p p ar\<close>
  then have a3: \<open>finite \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub>\<close>
    using herbrand_finite wf_p_def
    by simp
  have \<open>\<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub> \<Turnstile>\<^sub>p p\<close>
    using herbrand_sat_prog a1 a2
    by simp
  then show \<open>\<exists>m. m \<Turnstile>\<^sub>p p \<and> finite m\<close>
    using a3
    by auto
qed

subsubsection \<open>Other proofs\<close>

lemma sym_atoms_ground:
    \<open>a \<in> sym_atoms n (adom_p p) len \<Longrightarrow>
     ground_a a\<close>
proof -
  assume \<open>a \<in> sym_atoms n (adom_p p) len\<close>
  then have a1: \<open>a \<in> {Pre n tms |tms. tms \<in> {tms. set tms \<subseteq> adom_p p \<and>
                                                   length tms = len}}\<close>
    using sym_atoms_def lists_len_def
    by metis
  then obtain tms where a2: \<open>a = Pre n tms\<close>
    by blast
  then have \<open>set tms \<subseteq> adom_p p\<close>
    using a1
    by blast
  then have \<open>\<forall>tm \<in> set tms. is_const tm\<close>
    using adom_p_const
    by auto
  then show \<open>ground_a a\<close>
    using a2
    by simp
qed

theorem herbrand_ground:
    \<open>a \<in> \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub> \<Longrightarrow>
     ground_a a\<close>
  unfolding herbrand_def
  using sym_atoms_ground
  by auto

lemma wf_a_herbrand:
    \<open>a \<in> \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub> \<Longrightarrow>
     wf_a a ar\<close>
  unfolding herbrand_def sym_atoms_def lists_len_def
  by auto

theorem herbrand_wf_i:
    \<open>wf_p p ar \<Longrightarrow>
     wf_i \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub> ar\<close>
  unfolding wf_i_def
  using herbrand_ground wf_a_herbrand herbrand_finite wf_p_def
  by auto

theorem herbrand_union:
    \<open>\<bool>\<lparr>p1\<rparr>\<^bsub>ar\<^esub> \<union> \<bool>\<lparr>p2\<rparr>\<^bsub>ar\<^esub> \<subseteq> \<bool>\<lparr>p1 \<union> p2\<rparr>\<^bsub>ar\<^esub>\<close>
  unfolding herbrand_def syms_p_def sym_atoms_def lists_len_def adom_p_def
  by auto

lemma herbrand_atom_sym_in_prog_syms:
    \<open>Pre n tms \<in> \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub> \<Longrightarrow>
     n \<in> syms_p p\<close>
  unfolding herbrand_def syms_p_def sym_atoms_def lists_len_def
  by auto

theorem syms_herbrand_in_prog_syms:
    \<open>n \<in> syms \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub> \<Longrightarrow>
     n \<in> syms_p p\<close>
proof -
  fix n
  assume \<open>n \<in> syms (\<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub>)\<close>
  then have \<open>\<exists>a \<in> \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub>. sym a = n\<close>
    using syms_def
    by auto
  then obtain tmsn where \<open>Pre n tmsn \<in> \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub>\<close>
    using atom.exhaust sym.simps
    by metis
  then have \<open>\<exists>tms. Pre n tms \<in> \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub>\<close>
    by auto
  then show \<open>n \<in> syms_p p\<close>
    using herbrand_atom_sym_in_prog_syms
    by auto
qed

end


(*  Title:      HOL/HOLCF/Map_Functions.thy
    Author:     Brian Huffman
*)

section \<open>Map functions for various types\<close>

theory Map_Functions
  imports Deflation Sprod Ssum Sfun Up
begin

subsection \<open>Map operator for continuous function space\<close>

default_sort cpo

definition cfun_map :: "('b \<rightarrow> 'a) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> ('a \<rightarrow> 'c) \<rightarrow> ('b \<rightarrow> 'd)"
  where "cfun_map = (\<Lambda> a b f x. b\<cdot>(f\<cdot>(a\<cdot>x)))"

lemma cfun_map_beta [simp]: "cfun_map\<cdot>a\<cdot>b\<cdot>f\<cdot>x = b\<cdot>(f\<cdot>(a\<cdot>x))"
  by (simp add: cfun_map_def)

lemma cfun_map_ID: "cfun_map\<cdot>ID\<cdot>ID = ID"
  by (simp add: cfun_eq_iff)

lemma cfun_map_map: "cfun_map\<cdot>f1\<cdot>g1\<cdot>(cfun_map\<cdot>f2\<cdot>g2\<cdot>p) = cfun_map\<cdot>(\<Lambda> x. f2\<cdot>(f1\<cdot>x))\<cdot>(\<Lambda> x. g1\<cdot>(g2\<cdot>x))\<cdot>p"
  by (rule cfun_eqI) simp

lemma ep_pair_cfun_map:
  assumes "ep_pair e1 p1" and "ep_pair e2 p2"
  shows "ep_pair (cfun_map\<cdot>p1\<cdot>e2) (cfun_map\<cdot>e1\<cdot>p2)"
proof
  interpret e1p1: ep_pair e1 p1 by fact
  interpret e2p2: ep_pair e2 p2 by fact
  show "cfun_map\<cdot>e1\<cdot>p2\<cdot>(cfun_map\<cdot>p1\<cdot>e2\<cdot>f) = f" for f
    by (simp add: cfun_eq_iff)
  show "cfun_map\<cdot>p1\<cdot>e2\<cdot>(cfun_map\<cdot>e1\<cdot>p2\<cdot>g) \<sqsubseteq> g" for g
    apply (rule cfun_belowI, simp)
    apply (rule below_trans [OF e2p2.e_p_below])
    apply (rule monofun_cfun_arg)
    apply (rule e1p1.e_p_below)
    done
qed

lemma deflation_cfun_map:
  assumes "deflation d1" and "deflation d2"
  shows "deflation (cfun_map\<cdot>d1\<cdot>d2)"
proof
  interpret d1: deflation d1 by fact
  interpret d2: deflation d2 by fact
  fix f
  show "cfun_map\<cdot>d1\<cdot>d2\<cdot>(cfun_map\<cdot>d1\<cdot>d2\<cdot>f) = cfun_map\<cdot>d1\<cdot>d2\<cdot>f"
    by (simp add: cfun_eq_iff d1.idem d2.idem)
  show "cfun_map\<cdot>d1\<cdot>d2\<cdot>f \<sqsubseteq> f"
    apply (rule cfun_belowI, simp)
    apply (rule below_trans [OF d2.below])
    apply (rule monofun_cfun_arg)
    apply (rule d1.below)
    done
qed

lemma finite_range_cfun_map:
  assumes a: "finite (range (\<lambda>x. a\<cdot>x))"
  assumes b: "finite (range (\<lambda>y. b\<cdot>y))"
  shows "finite (range (\<lambda>f. cfun_map\<cdot>a\<cdot>b\<cdot>f))"  (is "finite (range ?h)")
proof (rule finite_imageD)
  let ?f = "\<lambda>g. range (\<lambda>x. (a\<cdot>x, g\<cdot>x))"
  show "finite (?f ` range ?h)"
  proof (rule finite_subset)
    let ?B = "Pow (range (\<lambda>x. a\<cdot>x) \<times> range (\<lambda>y. b\<cdot>y))"
    show "?f ` range ?h \<subseteq> ?B"
      by clarsimp
    show "finite ?B"
      by (simp add: a b)
  qed
  show "inj_on ?f (range ?h)"
  proof (rule inj_onI, rule cfun_eqI, clarsimp)
    fix x f g
    assume "range (\<lambda>x. (a\<cdot>x, b\<cdot>(f\<cdot>(a\<cdot>x)))) = range (\<lambda>x. (a\<cdot>x, b\<cdot>(g\<cdot>(a\<cdot>x))))"
    then have "range (\<lambda>x. (a\<cdot>x, b\<cdot>(f\<cdot>(a\<cdot>x)))) \<subseteq> range (\<lambda>x. (a\<cdot>x, b\<cdot>(g\<cdot>(a\<cdot>x))))"
      by (rule equalityD1)
    then have "(a\<cdot>x, b\<cdot>(f\<cdot>(a\<cdot>x))) \<in> range (\<lambda>x. (a\<cdot>x, b\<cdot>(g\<cdot>(a\<cdot>x))))"
      by (simp add: subset_eq)
    then obtain y where "(a\<cdot>x, b\<cdot>(f\<cdot>(a\<cdot>x))) = (a\<cdot>y, b\<cdot>(g\<cdot>(a\<cdot>y)))"
      by (rule rangeE)
    then show "b\<cdot>(f\<cdot>(a\<cdot>x)) = b\<cdot>(g\<cdot>(a\<cdot>x))"
      by clarsimp
  qed
qed

lemma finite_deflation_cfun_map:
  assumes "finite_deflation d1" and "finite_deflation d2"
  shows "finite_deflation (cfun_map\<cdot>d1\<cdot>d2)"
proof (rule finite_deflation_intro)
  interpret d1: finite_deflation d1 by fact
  interpret d2: finite_deflation d2 by fact
  from d1.deflation_axioms d2.deflation_axioms show "deflation (cfun_map\<cdot>d1\<cdot>d2)"
    by (rule deflation_cfun_map)
  have "finite (range (\<lambda>f. cfun_map\<cdot>d1\<cdot>d2\<cdot>f))"
    using d1.finite_range d2.finite_range
    by (rule finite_range_cfun_map)
  then show "finite {f. cfun_map\<cdot>d1\<cdot>d2\<cdot>f = f}"
    by (rule finite_range_imp_finite_fixes)
qed

text \<open>Finite deflations are compact elements of the function space\<close>

lemma finite_deflation_imp_compact: "finite_deflation d \<Longrightarrow> compact d"
  apply (frule finite_deflation_imp_deflation)
  apply (subgoal_tac "compact (cfun_map\<cdot>d\<cdot>d\<cdot>d)")
   apply (simp add: cfun_map_def deflation.idem eta_cfun)
  apply (rule finite_deflation.compact)
  apply (simp only: finite_deflation_cfun_map)
  done

subsection \<open>Map operator for product type\<close>

definition prod_map :: "('a \<rightarrow> 'b) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> 'a \<times> 'c \<rightarrow> 'b \<times> 'd"
  where "prod_map = (\<Lambda> f g p. (f\<cdot>(fst p), g\<cdot>(snd p)))"

lemma prod_map_Pair [simp]: "prod_map\<cdot>f\<cdot>g\<cdot>(x, y) = (f\<cdot>x, g\<cdot>y)"
  by (simp add: prod_map_def)

lemma prod_map_ID: "prod_map\<cdot>ID\<cdot>ID = ID"
  by (auto simp: cfun_eq_iff)

lemma prod_map_map: "prod_map\<cdot>f1\<cdot>g1\<cdot>(prod_map\<cdot>f2\<cdot>g2\<cdot>p) = prod_map\<cdot>(\<Lambda> x. f1\<cdot>(f2\<cdot>x))\<cdot>(\<Lambda> x. g1\<cdot>(g2\<cdot>x))\<cdot>p"
  by (induct p) simp

lemma ep_pair_prod_map:
  assumes "ep_pair e1 p1" and "ep_pair e2 p2"
  shows "ep_pair (prod_map\<cdot>e1\<cdot>e2) (prod_map\<cdot>p1\<cdot>p2)"
proof
  interpret e1p1: ep_pair e1 p1 by fact
  interpret e2p2: ep_pair e2 p2 by fact
  show "prod_map\<cdot>p1\<cdot>p2\<cdot>(prod_map\<cdot>e1\<cdot>e2\<cdot>x) = x" for x
    by (induct x) simp
  show "prod_map\<cdot>e1\<cdot>e2\<cdot>(prod_map\<cdot>p1\<cdot>p2\<cdot>y) \<sqsubseteq> y" for y
    by (induct y) (simp add: e1p1.e_p_below e2p2.e_p_below)
qed

lemma deflation_prod_map:
  assumes "deflation d1" and "deflation d2"
  shows "deflation (prod_map\<cdot>d1\<cdot>d2)"
proof
  interpret d1: deflation d1 by fact
  interpret d2: deflation d2 by fact
  fix x
  show "prod_map\<cdot>d1\<cdot>d2\<cdot>(prod_map\<cdot>d1\<cdot>d2\<cdot>x) = prod_map\<cdot>d1\<cdot>d2\<cdot>x"
    by (induct x) (simp add: d1.idem d2.idem)
  show "prod_map\<cdot>d1\<cdot>d2\<cdot>x \<sqsubseteq> x"
    by (induct x) (simp add: d1.below d2.below)
qed

lemma finite_deflation_prod_map:
  assumes "finite_deflation d1" and "finite_deflation d2"
  shows "finite_deflation (prod_map\<cdot>d1\<cdot>d2)"
proof (rule finite_deflation_intro)
  interpret d1: finite_deflation d1 by fact
  interpret d2: finite_deflation d2 by fact
  from d1.deflation_axioms d2.deflation_axioms show "deflation (prod_map\<cdot>d1\<cdot>d2)"
    by (rule deflation_prod_map)
  have "{p. prod_map\<cdot>d1\<cdot>d2\<cdot>p = p} \<subseteq> {x. d1\<cdot>x = x} \<times> {y. d2\<cdot>y = y}"
    by auto
  then show "finite {p. prod_map\<cdot>d1\<cdot>d2\<cdot>p = p}"
    by (rule finite_subset, simp add: d1.finite_fixes d2.finite_fixes)
qed

subsection \<open>Map function for lifted cpo\<close>

definition u_map :: "('a \<rightarrow> 'b) \<rightarrow> 'a u \<rightarrow> 'b u"
  where "u_map = (\<Lambda> f. fup\<cdot>(up oo f))"

lemma u_map_strict [simp]: "u_map\<cdot>f\<cdot>\<bottom> = \<bottom>"
  by (simp add: u_map_def)

lemma u_map_up [simp]: "u_map\<cdot>f\<cdot>(up\<cdot>x) = up\<cdot>(f\<cdot>x)"
  by (simp add: u_map_def)

lemma u_map_ID: "u_map\<cdot>ID = ID"
  by (simp add: u_map_def cfun_eq_iff eta_cfun)

lemma u_map_map: "u_map\<cdot>f\<cdot>(u_map\<cdot>g\<cdot>p) = u_map\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>p"
  by (induct p) simp_all

lemma u_map_oo: "u_map\<cdot>(f oo g) = u_map\<cdot>f oo u_map\<cdot>g"
  by (simp add: cfcomp1 u_map_map eta_cfun)

lemma ep_pair_u_map: "ep_pair e p \<Longrightarrow> ep_pair (u_map\<cdot>e) (u_map\<cdot>p)"
  apply standard
  subgoal for x by (cases x) (simp_all add: ep_pair.e_inverse)
  subgoal for y by (cases y) (simp_all add: ep_pair.e_p_below)
  done

lemma deflation_u_map: "deflation d \<Longrightarrow> deflation (u_map\<cdot>d)"
  apply standard
  subgoal for x by (cases x) (simp_all add: deflation.idem)
  subgoal for x by (cases x) (simp_all add: deflation.below)
  done

lemma finite_deflation_u_map:
  assumes "finite_deflation d"
  shows "finite_deflation (u_map\<cdot>d)"
proof (rule finite_deflation_intro)
  interpret d: finite_deflation d by fact
  from d.deflation_axioms show "deflation (u_map\<cdot>d)"
    by (rule deflation_u_map)
  have "{x. u_map\<cdot>d\<cdot>x = x} \<subseteq> insert \<bottom> ((\<lambda>x. up\<cdot>x) ` {x. d\<cdot>x = x})"
    by (rule subsetI, case_tac x, simp_all)
  then show "finite {x. u_map\<cdot>d\<cdot>x = x}"
    by (rule finite_subset) (simp add: d.finite_fixes)
qed

subsection \<open>Map function for strict products\<close>

default_sort pcpo

definition sprod_map :: "('a \<rightarrow> 'b) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> 'a \<otimes> 'c \<rightarrow> 'b \<otimes> 'd"
  where "sprod_map = (\<Lambda> f g. ssplit\<cdot>(\<Lambda> x y. (:f\<cdot>x, g\<cdot>y:)))"

lemma sprod_map_strict [simp]: "sprod_map\<cdot>a\<cdot>b\<cdot>\<bottom> = \<bottom>"
  by (simp add: sprod_map_def)

lemma sprod_map_spair [simp]: "x \<noteq> \<bottom> \<Longrightarrow> y \<noteq> \<bottom> \<Longrightarrow> sprod_map\<cdot>f\<cdot>g\<cdot>(:x, y:) = (:f\<cdot>x, g\<cdot>y:)"
  by (simp add: sprod_map_def)

lemma sprod_map_spair': "f\<cdot>\<bottom> = \<bottom> \<Longrightarrow> g\<cdot>\<bottom> = \<bottom> \<Longrightarrow> sprod_map\<cdot>f\<cdot>g\<cdot>(:x, y:) = (:f\<cdot>x, g\<cdot>y:)"
  by (cases "x = \<bottom> \<or> y = \<bottom>") auto

lemma sprod_map_ID: "sprod_map\<cdot>ID\<cdot>ID = ID"
  by (simp add: sprod_map_def cfun_eq_iff eta_cfun)

lemma sprod_map_map:
  "\<lbrakk>f1\<cdot>\<bottom> = \<bottom>; g1\<cdot>\<bottom> = \<bottom>\<rbrakk> \<Longrightarrow>
    sprod_map\<cdot>f1\<cdot>g1\<cdot>(sprod_map\<cdot>f2\<cdot>g2\<cdot>p) =
     sprod_map\<cdot>(\<Lambda> x. f1\<cdot>(f2\<cdot>x))\<cdot>(\<Lambda> x. g1\<cdot>(g2\<cdot>x))\<cdot>p"
proof (induct p)
  case bottom
  then show ?case by simp
next
  case (spair x y)
  then show ?case
    apply (cases "f2\<cdot>x = \<bottom>", simp)
    apply (cases "g2\<cdot>y = \<bottom>", simp)
    apply simp
    done
qed

lemma ep_pair_sprod_map:
  assumes "ep_pair e1 p1" and "ep_pair e2 p2"
  shows "ep_pair (sprod_map\<cdot>e1\<cdot>e2) (sprod_map\<cdot>p1\<cdot>p2)"
proof
  interpret e1p1: pcpo_ep_pair e1 p1 unfolding pcpo_ep_pair_def by fact
  interpret e2p2: pcpo_ep_pair e2 p2 unfolding pcpo_ep_pair_def by fact
  show "sprod_map\<cdot>p1\<cdot>p2\<cdot>(sprod_map\<cdot>e1\<cdot>e2\<cdot>x) = x" for x
    by (induct x) simp_all
  show "sprod_map\<cdot>e1\<cdot>e2\<cdot>(sprod_map\<cdot>p1\<cdot>p2\<cdot>y) \<sqsubseteq> y" for y
  proof (induct y)
    case bottom
    then show ?case by simp
  next
    case (spair x y)
    then show ?case
      apply simp
      apply (cases "p1\<cdot>x = \<bottom>", simp, cases "p2\<cdot>y = \<bottom>", simp)
      apply (simp add: monofun_cfun e1p1.e_p_below e2p2.e_p_below)
      done
  qed
qed

lemma deflation_sprod_map:
  assumes "deflation d1" and "deflation d2"
  shows "deflation (sprod_map\<cdot>d1\<cdot>d2)"
proof
  interpret d1: deflation d1 by fact
  interpret d2: deflation d2 by fact
  fix x
  show "sprod_map\<cdot>d1\<cdot>d2\<cdot>(sprod_map\<cdot>d1\<cdot>d2\<cdot>x) = sprod_map\<cdot>d1\<cdot>d2\<cdot>x"
  proof (induct x)
    case bottom
    then show ?case by simp
  next
    case (spair x y)
    then show ?case
      apply (cases "d1\<cdot>x = \<bottom>", simp, cases "d2\<cdot>y = \<bottom>", simp)
      apply (simp add: d1.idem d2.idem)
      done
  qed
  show "sprod_map\<cdot>d1\<cdot>d2\<cdot>x \<sqsubseteq> x"
  proof (induct x)
    case bottom
    then show ?case by simp
  next
    case spair
    then show ?case by (simp add: monofun_cfun d1.below d2.below)
  qed
qed

lemma finite_deflation_sprod_map:
  assumes "finite_deflation d1" and "finite_deflation d2"
  shows "finite_deflation (sprod_map\<cdot>d1\<cdot>d2)"
proof (rule finite_deflation_intro)
  interpret d1: finite_deflation d1 by fact
  interpret d2: finite_deflation d2 by fact
  from d1.deflation_axioms d2.deflation_axioms show "deflation (sprod_map\<cdot>d1\<cdot>d2)"
    by (rule deflation_sprod_map)
  have "{x. sprod_map\<cdot>d1\<cdot>d2\<cdot>x = x} \<subseteq>
      insert \<bottom> ((\<lambda>(x, y). (:x, y:)) ` ({x. d1\<cdot>x = x} \<times> {y. d2\<cdot>y = y}))"
    by (rule subsetI, case_tac x, auto simp add: spair_eq_iff)
  then show "finite {x. sprod_map\<cdot>d1\<cdot>d2\<cdot>x = x}"
    by (rule finite_subset) (simp add: d1.finite_fixes d2.finite_fixes)
qed

subsection \<open>Map function for strict sums\<close>

definition ssum_map :: "('a \<rightarrow> 'b) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> 'a \<oplus> 'c \<rightarrow> 'b \<oplus> 'd"
  where "ssum_map = (\<Lambda> f g. sscase\<cdot>(sinl oo f)\<cdot>(sinr oo g))"

lemma ssum_map_strict [simp]: "ssum_map\<cdot>f\<cdot>g\<cdot>\<bottom> = \<bottom>"
  by (simp add: ssum_map_def)

lemma ssum_map_sinl [simp]: "x \<noteq> \<bottom> \<Longrightarrow> ssum_map\<cdot>f\<cdot>g\<cdot>(sinl\<cdot>x) = sinl\<cdot>(f\<cdot>x)"
  by (simp add: ssum_map_def)

lemma ssum_map_sinr [simp]: "x \<noteq> \<bottom> \<Longrightarrow> ssum_map\<cdot>f\<cdot>g\<cdot>(sinr\<cdot>x) = sinr\<cdot>(g\<cdot>x)"
  by (simp add: ssum_map_def)

lemma ssum_map_sinl': "f\<cdot>\<bottom> = \<bottom> \<Longrightarrow> ssum_map\<cdot>f\<cdot>g\<cdot>(sinl\<cdot>x) = sinl\<cdot>(f\<cdot>x)"
  by (cases "x = \<bottom>") simp_all

lemma ssum_map_sinr': "g\<cdot>\<bottom> = \<bottom> \<Longrightarrow> ssum_map\<cdot>f\<cdot>g\<cdot>(sinr\<cdot>x) = sinr\<cdot>(g\<cdot>x)"
  by (cases "x = \<bottom>") simp_all

lemma ssum_map_ID: "ssum_map\<cdot>ID\<cdot>ID = ID"
  by (simp add: ssum_map_def cfun_eq_iff eta_cfun)

lemma ssum_map_map:
  "\<lbrakk>f1\<cdot>\<bottom> = \<bottom>; g1\<cdot>\<bottom> = \<bottom>\<rbrakk> \<Longrightarrow>
    ssum_map\<cdot>f1\<cdot>g1\<cdot>(ssum_map\<cdot>f2\<cdot>g2\<cdot>p) =
     ssum_map\<cdot>(\<Lambda> x. f1\<cdot>(f2\<cdot>x))\<cdot>(\<Lambda> x. g1\<cdot>(g2\<cdot>x))\<cdot>p"
proof (induct p)
  case bottom
  then show ?case by simp
next
  case (sinl x)
  then show ?case by (cases "f2\<cdot>x = \<bottom>") simp_all
next
  case (sinr y)
  then show ?case by (cases "g2\<cdot>y = \<bottom>") simp_all
qed

lemma ep_pair_ssum_map:
  assumes "ep_pair e1 p1" and "ep_pair e2 p2"
  shows "ep_pair (ssum_map\<cdot>e1\<cdot>e2) (ssum_map\<cdot>p1\<cdot>p2)"
proof
  interpret e1p1: pcpo_ep_pair e1 p1 unfolding pcpo_ep_pair_def by fact
  interpret e2p2: pcpo_ep_pair e2 p2 unfolding pcpo_ep_pair_def by fact
  show "ssum_map\<cdot>p1\<cdot>p2\<cdot>(ssum_map\<cdot>e1\<cdot>e2\<cdot>x) = x" for x
    by (induct x) simp_all
  show "ssum_map\<cdot>e1\<cdot>e2\<cdot>(ssum_map\<cdot>p1\<cdot>p2\<cdot>y) \<sqsubseteq> y" for y
  proof (induct y)
    case bottom
    then show ?case by simp
  next
    case (sinl x)
    then show ?case by (cases "p1\<cdot>x = \<bottom>") (simp_all add: e1p1.e_p_below)
  next
    case (sinr y)
    then show ?case by (cases "p2\<cdot>y = \<bottom>") (simp_all add: e2p2.e_p_below)
  qed
qed

lemma deflation_ssum_map:
  assumes "deflation d1" and "deflation d2"
  shows "deflation (ssum_map\<cdot>d1\<cdot>d2)"
proof
  interpret d1: deflation d1 by fact
  interpret d2: deflation d2 by fact
  fix x
  show "ssum_map\<cdot>d1\<cdot>d2\<cdot>(ssum_map\<cdot>d1\<cdot>d2\<cdot>x) = ssum_map\<cdot>d1\<cdot>d2\<cdot>x"
  proof (induct x)
    case bottom
    then show ?case by simp
  next
    case (sinl x)
    then show ?case by (cases "d1\<cdot>x = \<bottom>") (simp_all add: d1.idem)
  next
    case (sinr y)
    then show ?case by (cases "d2\<cdot>y = \<bottom>") (simp_all add: d2.idem)
  qed
  show "ssum_map\<cdot>d1\<cdot>d2\<cdot>x \<sqsubseteq> x"
  proof (induct x)
    case bottom
    then show ?case by simp
  next
    case (sinl x)
    then show ?case by (cases "d1\<cdot>x = \<bottom>") (simp_all add: d1.below)
  next
    case (sinr y)
    then show ?case by (cases "d2\<cdot>y = \<bottom>") (simp_all add: d2.below)
  qed
qed

lemma finite_deflation_ssum_map:
  assumes "finite_deflation d1" and "finite_deflation d2"
  shows "finite_deflation (ssum_map\<cdot>d1\<cdot>d2)"
proof (rule finite_deflation_intro)
  interpret d1: finite_deflation d1 by fact
  interpret d2: finite_deflation d2 by fact
  from d1.deflation_axioms d2.deflation_axioms show "deflation (ssum_map\<cdot>d1\<cdot>d2)"
    by (rule deflation_ssum_map)
  have "{x. ssum_map\<cdot>d1\<cdot>d2\<cdot>x = x} \<subseteq>
        (\<lambda>x. sinl\<cdot>x) ` {x. d1\<cdot>x = x} \<union>
        (\<lambda>x. sinr\<cdot>x) ` {x. d2\<cdot>x = x} \<union> {\<bottom>}"
    by (rule subsetI, case_tac x, simp_all)
  then show "finite {x. ssum_map\<cdot>d1\<cdot>d2\<cdot>x = x}"
    by (rule finite_subset, simp add: d1.finite_fixes d2.finite_fixes)
qed

subsection \<open>Map operator for strict function space\<close>

definition sfun_map :: "('b \<rightarrow> 'a) \<rightarrow> ('c \<rightarrow> 'd) \<rightarrow> ('a \<rightarrow>! 'c) \<rightarrow> ('b \<rightarrow>! 'd)"
  where "sfun_map = (\<Lambda> a b. sfun_abs oo cfun_map\<cdot>a\<cdot>b oo sfun_rep)"

lemma sfun_map_ID: "sfun_map\<cdot>ID\<cdot>ID = ID"
  by (simp add: sfun_map_def cfun_map_ID cfun_eq_iff)

lemma sfun_map_map:
  assumes "f2\<cdot>\<bottom> = \<bottom>" and "g2\<cdot>\<bottom> = \<bottom>"
  shows "sfun_map\<cdot>f1\<cdot>g1\<cdot>(sfun_map\<cdot>f2\<cdot>g2\<cdot>p) =
    sfun_map\<cdot>(\<Lambda> x. f2\<cdot>(f1\<cdot>x))\<cdot>(\<Lambda> x. g1\<cdot>(g2\<cdot>x))\<cdot>p"
  by (simp add: sfun_map_def cfun_eq_iff strictify_cancel assms cfun_map_map)

lemma ep_pair_sfun_map:
  assumes 1: "ep_pair e1 p1"
  assumes 2: "ep_pair e2 p2"
  shows "ep_pair (sfun_map\<cdot>p1\<cdot>e2) (sfun_map\<cdot>e1\<cdot>p2)"
proof
  interpret e1p1: pcpo_ep_pair e1 p1
    unfolding pcpo_ep_pair_def by fact
  interpret e2p2: pcpo_ep_pair e2 p2
    unfolding pcpo_ep_pair_def by fact
  show "sfun_map\<cdot>e1\<cdot>p2\<cdot>(sfun_map\<cdot>p1\<cdot>e2\<cdot>f) = f" for f
    unfolding sfun_map_def
    apply (simp add: sfun_eq_iff strictify_cancel)
    apply (rule ep_pair.e_inverse)
    apply (rule ep_pair_cfun_map [OF 1 2])
    done
  show "sfun_map\<cdot>p1\<cdot>e2\<cdot>(sfun_map\<cdot>e1\<cdot>p2\<cdot>g) \<sqsubseteq> g" for g
    unfolding sfun_map_def
    apply (simp add: sfun_below_iff strictify_cancel)
    apply (rule ep_pair.e_p_below)
    apply (rule ep_pair_cfun_map [OF 1 2])
    done
qed

lemma deflation_sfun_map:
  assumes 1: "deflation d1"
  assumes 2: "deflation d2"
  shows "deflation (sfun_map\<cdot>d1\<cdot>d2)"
  apply (simp add: sfun_map_def)
  apply (rule deflation.intro)
   apply simp
   apply (subst strictify_cancel)
    apply (simp add: cfun_map_def deflation_strict 1 2)
   apply (simp add: cfun_map_def deflation.idem 1 2)
  apply (simp add: sfun_below_iff)
  apply (subst strictify_cancel)
   apply (simp add: cfun_map_def deflation_strict 1 2)
  apply (rule deflation.below)
  apply (rule deflation_cfun_map [OF 1 2])
  done

lemma finite_deflation_sfun_map:
  assumes "finite_deflation d1"
    and "finite_deflation d2"
  shows "finite_deflation (sfun_map\<cdot>d1\<cdot>d2)"
proof (intro finite_deflation_intro)
  interpret d1: finite_deflation d1 by fact
  interpret d2: finite_deflation d2 by fact
  from d1.deflation_axioms d2.deflation_axioms show "deflation (sfun_map\<cdot>d1\<cdot>d2)"
    by (rule deflation_sfun_map)
  from assms have "finite_deflation (cfun_map\<cdot>d1\<cdot>d2)"
    by (rule finite_deflation_cfun_map)
  then have "finite {f. cfun_map\<cdot>d1\<cdot>d2\<cdot>f = f}"
    by (rule finite_deflation.finite_fixes)
  moreover have "inj (\<lambda>f. sfun_rep\<cdot>f)"
    by (rule inj_onI) (simp add: sfun_eq_iff)
  ultimately have "finite ((\<lambda>f. sfun_rep\<cdot>f) -` {f. cfun_map\<cdot>d1\<cdot>d2\<cdot>f = f})"
    by (rule finite_vimageI)
  with \<open>deflation d1\<close> \<open>deflation d2\<close> show "finite {f. sfun_map\<cdot>d1\<cdot>d2\<cdot>f = f}"
    by (simp add: sfun_map_def sfun_eq_iff strictify_cancel deflation_strict)
qed

end