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

chapter "Category with Finite Limits"

theory CategoryWithFiniteLimits
imports CartesianCategory CategoryWithPullbacks
begin

  text\<open>
    In this chapter we define ``category with finite limits'' and show that such
    categories coincide with those having pullbacks and a terminal object.

    Since we can't quantify over types in HOL, the best we can do at defining the notion
    ``category with finite limits'' is to state it for a fixed choice of type (e.g.~@{typ nat})
    for the arrows of the ``diagram shape''.  However, we then have to go to some
    trouble to show the existence of finite limits for diagram shapes at other types.
  \<close>

  locale category_with_finite_limits =
    category +
  assumes has_finite_limits:
            "\<lbrakk> category (J :: nat comp); finite (Collect (partial_magma.arr J)) \<rbrakk>
                 \<Longrightarrow> has_limits_of_shape J"
  begin

    text\<open>
      We show that a category with finite limits has pullbacks and a terminal object
      and is therefore also a cartesian category.
    \<close>

    interpretation category_with_pullbacks C
    proof -
      interpret J: cospan_shape
        by unfold_locales
      have 1: "finite (Collect J.arr)"
      proof -
        have "Collect J.arr = {J.AA, J.BB, J.TT, J.AT, J.BT}"
          using J.arr_char cospan_shape.Dom.cases by auto
        thus ?thesis by simp
      qed
      obtain J' :: "nat comp" where J': "isomorphic_categories J' J.comp"
        using 1 J.finite_imp_ex_iso_nat_comp by blast
      interpret J'J: isomorphic_categories J' J.comp
        using J' by simp
      obtain \<phi> \<psi> where \<phi>\<psi>: "inverse_functors J.comp J' \<phi> \<psi>"
        using J'J.iso inverse_functors_sym by blast
      interpret \<phi>\<psi>: inverse_functors J.comp J' \<phi> \<psi>
        using \<phi>\<psi> by simp
      interpret \<psi>: invertible_functor J.comp J' \<psi>
        using \<phi>\<psi>.inverse_functors_axioms
        by unfold_locales auto
      show "category_with_pullbacks C"
      proof
        show "has_pullbacks"
        proof (unfold has_pullbacks_def has_as_pullback_def, intro allI impI)
          fix f0 f1
          assume cospan: "cospan f0 f1"
          interpret D: cospan_diagram C f0 f1
            using cospan
            by (simp add: category_axioms cospan_diagram_axioms_def cospan_diagram_def)
          have 2: "has_limits_of_shape J.comp"
            using 1 bij_betw_finite J'J.A.category_axioms has_finite_limits \<psi>.bij_betw_arr_sets
                  has_limits_preserved_by_isomorphism J'J.isomorphic_categories_axioms
            by blast
          obtain a \<chi> where \<chi>: "limit_cone J.comp C D.map a \<chi>"
            using 2 D.diagram_axioms has_limits_of_shape_def by blast
          interpret \<chi>: limit_cone J.comp C D.map a \<chi>
            using \<chi> by simp
          have "D.map = cospan_diagram.map C f0 f1" by simp
          moreover have "a = dom (\<chi> J.AA)"
            using J.arr_char \<chi>.component_in_hom by force
          moreover have "\<chi> = cospan_diagram.mkCone (\<cdot>) f0 f1 (\<chi> J.AA) (\<chi> J.BB)"
            using D.mkCone_cone \<chi>.cone_axioms by auto
          ultimately have "limit_cone (\<cdot>\<^sub>J) (\<cdot>)
                             (cospan_diagram.map (\<cdot>) f0 f1) (dom (\<chi> J.AA))
                             (cospan_diagram.mkCone (\<cdot>) f0 f1 (\<chi> J.AA) (\<chi> J.BB))"
            using \<chi>.limit_cone_axioms by simp
          thus "\<exists>p0 p1. cospan f0 f1 \<and>
                        limit_cone (\<cdot>\<^sub>J) (\<cdot>)
                          (cospan_diagram.map (\<cdot>) f0 f1) (dom p0)
                          (cospan_diagram.mkCone (\<cdot>) f0 f1 p0 p1)"
            using cospan by auto
        qed
      qed
    qed

    lemma is_category_with_pullbacks:
    shows "category_with_pullbacks C"
      ..

    sublocale category_with_pullbacks C ..

    interpretation category_with_terminal_object C
    proof
      show "\<exists>a. terminal a"
      proof -
        interpret J: discrete_category \<open>{} :: nat set\<close> 0
          by unfold_locales simp
        have 1: "has_limits_of_shape J.comp"
          using has_finite_limits
          by (metis Collect_empty_eq J.arr_char J.is_category empty_iff finite.emptyI)
        interpret D: diagram J.comp C \<open>\<lambda>_. null\<close>
          by unfold_locales auto
        obtain t \<tau> where \<tau>: "D.limit_cone t \<tau>"
          using 1 D.diagram_axioms has_limits_of_shape_def by blast
        interpret \<tau>: limit_cone J.comp C \<open>\<lambda>_. null\<close> t \<tau>
          using \<tau> by simp
        have "terminal t"
        proof
          show "ide t"
            using \<tau>.ide_apex by simp
          fix a
          assume a: "ide a"
          show "\<exists>!f. \<guillemotleft>f : a \<rightarrow> t\<guillemotright>"
          proof -
            interpret a: constant_functor J.comp C a
              using a by unfold_locales
            interpret \<chi>: cone J.comp C \<open>\<lambda>_.null\<close> a \<open>\<lambda>_.null\<close>
              apply unfold_locales
                  apply simp
              using dom_null cod_null comp_null
              by blast+
            have "\<exists>!f. \<guillemotleft>f : a \<rightarrow> t\<guillemotright> \<and> D.cones_map f \<tau> = (\<lambda>_. null)"
              using \<tau>.induced_arrowI [of "\<lambda>_.null" a] \<chi>.cone_axioms
                    \<tau>.is_universal [of a "\<lambda>_. null"]
              by simp
            moreover have "\<And>f. \<guillemotleft>f : a \<rightarrow> t\<guillemotright> \<Longrightarrow> D.cones_map f \<tau> = (\<lambda>_. null)"
              using \<tau>.cone_axioms by auto
            ultimately show ?thesis by auto
          qed
        qed
        thus ?thesis by blast
      qed
    qed

    lemma is_category_with_terminal_object:
    shows "category_with_terminal_object C"
      ..

    sublocale category_with_terminal_object C ..

    sublocale category_with_finite_products
      using has_finite_limits has_finite_products_if_has_finite_limits
            has_limits_of_shape_def diagram_def
      by unfold_locales blast

    sublocale cartesian_category ..

  end

  locale category_with_pullbacks_and_terminal =
    category_with_pullbacks +
    category_with_terminal_object

  sublocale category_with_finite_limits \<subseteq> category_with_pullbacks_and_terminal ..

  text\<open>
    Conversely, we show that a category with pullbacks and a terminal object also
    has finite products and equalizers, and therefore has finite limits.
  \<close>

  context category_with_pullbacks_and_terminal
  begin

    interpretation ECP: elementary_category_with_pullbacks C prj0 prj1
      using extends_to_elementary_category_with_pullbacks by simp

    abbreviation prj0'
    where "prj0' a b \<equiv> (if ide a \<and> ide b then prj0 (trm a) (trm b) else null)"

    abbreviation prj1'
    where "prj1' a b \<equiv> (if ide a \<and> ide b then prj1 (trm a) (trm b) else null)"

    interpretation ECC: elementary_cartesian_category C prj0' prj1' \<one> trm
      using trm_naturality ECP.universal
      by unfold_locales auto

    interpretation category_with_equalizers C
    proof (unfold_locales, unfold has_equalizers_def, intro allI impI)
      fix f0 f1
      assume par: "par f0 f1"
      interpret J: parallel_pair
        by unfold_locales
      interpret D: parallel_pair_diagram C f0 f1
        using par by unfold_locales auto
      have 1: "cospan (ECC.prod f1 (dom f0)) (ECC.prod f0 (dom f0))"
        using par by simp
      let ?g0 = "ECC.prod f0 (dom f0) \<cdot> ECC.dup (dom f0)"
      let ?g1 = "ECC.prod f1 (dom f1) \<cdot> ECC.dup (dom f1)"
      have g0: "\<guillemotleft>?g0 : dom f0 \<rightarrow> ECC.prod (cod f0) (dom f0)\<guillemotright>"
        using par by simp
      have g1: "\<guillemotleft>?g1 : dom f1 \<rightarrow> ECC.prod (cod f1) (dom f1)\<guillemotright>"
        using par by simp
      define e0 where "e0 = prj0 ?g1 ?g0"
      define e1 where "e1 = prj1 ?g1 ?g0"
      have e0: "\<guillemotleft>e0 : dom e0 \<rightarrow> dom f0\<guillemotright>"
        using par 1 e0_def by auto
      have e1: "\<guillemotleft>e1 : dom e0 \<rightarrow> dom f1\<guillemotright>"
        using par 1 e1_def e0_def by auto
      have eq: "e0 = e1"
      proof -
        have "e1 = prj0' (cod f1) (dom f1) \<cdot> ?g1 \<cdot> e1"
        proof -
          have "((prj0' (cod f1) (dom f1) \<cdot> (ECC.prod f1 (dom f1))) \<cdot> ECC.dup (dom f1)) \<cdot> e1 =
                dom f1 \<cdot> e1"
            using par ECC.pr_naturality(1) [of "dom f1" "dom f1" "dom f1" f1 "dom f1" "cod f1"]
                  comp_cod_arr ECC.pr_dup(1)
            by auto
          also have "... = e1"
            using par e1 comp_cod_arr by blast
          finally show ?thesis
            using comp_assoc by simp
        qed
        also have "... = prj0' (cod f1) (dom f1) \<cdot> ?g0 \<cdot> e0"
          using par ECP.pullback_commutes
          unfolding commutative_square_def e0_def e1_def by simp
        also have "... = e0"
        proof -
          have "((prj0' (cod f1) (dom f1) \<cdot> (ECC.prod f0 (dom f0))) \<cdot> ECC.dup (dom f0)) \<cdot> e0 =
                dom f0 \<cdot> e0"
            using par ECC.pr_naturality(1) [of "dom f0" "dom f0" "dom f1" f0 "dom f0" "cod f0"]
                  comp_cod_arr ECC.pr_dup(1) ide_dom
            by auto
          also have "... = e0"
            using e0 comp_cod_arr by blast
          finally show ?thesis
            using comp_assoc by simp
        qed
        finally show ?thesis by auto
      qed
      have equalizes: "D.is_equalized_by e0"
      proof
        show "seq f0 e0"
          using par e0 by auto
        show "f0 \<cdot> e0 = f1 \<cdot> e0"
        proof -
          have "f0 \<cdot> e0 = (f0 \<cdot> dom f0) \<cdot> e0"
            using par comp_arr_dom by simp
          also have "... = (f0 \<cdot> (prj1' (dom f0) (dom f0) \<cdot> ECC.dup (dom f0))) \<cdot> e0"
            using par ECC.pr_dup(2) by auto
          also have "... = ((f0 \<cdot> prj1' (dom f0) (dom f0)) \<cdot> ECC.dup (dom f0)) \<cdot> e0"
            using comp_assoc by auto
          also have "... = prj1' (cod f1) (dom f1) \<cdot> ?g0 \<cdot> e0"
            using par ECC.pr_naturality(2) [of "dom f0" "dom f0" "dom f1" f0 "dom f0" "cod f0"]
            by (metis (no_types, lifting) arr_dom cod_dom dom_dom comp_assoc)
          also have "... = prj1' (cod f1) (dom f1) \<cdot> ?g1 \<cdot> e1"
            using par ECP.pullback_commutes [of ?g1 ?g0]
            unfolding commutative_square_def e0_def e1_def by simp
          also have "... = (prj1' (cod f1) (dom f1) \<cdot> ?g1) \<cdot> e1"
            using comp_assoc by simp
          also have "... = (f1 \<cdot> (prj1' (dom f1) (dom f1) \<cdot> ECC.dup (dom f1))) \<cdot> e1"
            using par ECC.pr_naturality(2) [of "dom f1" "dom f1" "dom f1" f1 "dom f1" "cod f1"]
            by (metis (no_types, lifting) arr_dom cod_dom dom_dom comp_assoc)
          also have "... = (f1 \<cdot> dom f1) \<cdot> e1"
            using par ECC.pr_dup(2) by auto
          also have "... = f1 \<cdot> e1"
            using par comp_arr_dom by simp
          also have "... = f1 \<cdot> e0"
            using eq by simp
          finally show ?thesis by simp
        qed
      qed
      show "\<exists>e. has_as_equalizer f0 f1 e"
      proof
        interpret E: constant_functor J.comp C \<open>dom e0\<close>
          using par e0 by unfold_locales auto
        interpret \<chi>: cone J.comp C D.map \<open>dom e0\<close> \<open>D.mkCone e0\<close>
          using equalizes D.cone_mkCone e0_def by auto
        interpret \<chi>: limit_cone J.comp C D.map \<open>dom e0\<close> \<open>D.mkCone e0\<close>
        proof
          show "\<And>a' \<chi>'. D.cone a' \<chi>' \<Longrightarrow>
                         \<exists>!f. \<guillemotleft>f : a' \<rightarrow> dom e0\<guillemotright> \<and> D.cones_map f (D.mkCone e0) = \<chi>'"
          proof -
            fix a' \<chi>'
            assume \<chi>': "D.cone a' \<chi>'"
            interpret \<chi>': cone J.comp C D.map a' \<chi>'
              using \<chi>' by simp
            have 3: "commutative_square ?g1 ?g0 (\<chi>' J.Zero) (\<chi>' J.Zero)"
            proof
              show "cospan ?g1 ?g0"
                using par g0 g1 by simp
              show 4: "span (\<chi>' J.Zero) (\<chi>' J.Zero)"
                using J.arr_char by simp
              show 5: "dom ?g1 = cod (\<chi>' J.Zero)"
                using par g1 J.arr_char D.map_def by simp
              show "?g1 \<cdot> \<chi>' J.Zero = ?g0 \<cdot> \<chi>' J.Zero"
              proof -
                have "?g1 \<cdot> \<chi>' J.Zero = ECC.prod f1 (dom f1) \<cdot> ECC.dup (dom f1) \<cdot> \<chi>' J.Zero"
                  using comp_assoc by simp
                also have "... = ECC.prod f1 (dom f1) \<cdot> ECC.tuple (\<chi>' J.Zero) (\<chi>' J.Zero)"
                  using par D.map_def J.arr_char comp_cod_arr by auto
                also have "... = ECC.tuple (f1 \<cdot> \<chi>' J.Zero) (\<chi>' J.Zero)"
                  using par ECC.prod_tuple [of "\<chi>' J.Zero" "\<chi>' J.Zero" f1 "dom f1"]
                        comp_cod_arr
                  by (metis (no_types, lifting) 4 5 g1 in_homE seqI)
                also have "... = ECC.tuple (f0 \<cdot> \<chi>' J.Zero) (\<chi>' J.Zero)"
                  using par D.is_equalized_by_cone \<chi>'.cone_axioms by auto
                also have "... = ECC.prod f0 (dom f0) \<cdot> ECC.tuple (\<chi>' J.Zero) (\<chi>' J.Zero)"
                  using par ECC.prod_tuple [of "\<chi>' J.Zero" "\<chi>' J.Zero" f0 "dom f0"]
                        comp_cod_arr
                  by (metis (no_types, lifting) 4 5 g1 in_homE seqI)
                also have "... = ECC.prod f0 (dom f0) \<cdot> ECC.dup (dom f0) \<cdot> \<chi>' J.Zero"
                  using par D.map_def J.arr_char comp_cod_arr by auto
                also have "... = ?g0 \<cdot> \<chi>' J.Zero"
                  using comp_assoc by simp
                finally show ?thesis by blast
              qed
            qed
            show "\<exists>!f. \<guillemotleft>f : a' \<rightarrow> dom e0\<guillemotright> \<and> D.cones_map f (D.mkCone e0) = \<chi>'"
            proof
              define f where "f = ECP.tuple (\<chi>' J.Zero) ?g1 ?g0 (\<chi>' J.Zero)"
              have 4: "e0 \<cdot> f = \<chi>' J.Zero"
                using ECP.universal by (simp add: "3" e1_def eq f_def)
              have f: "\<guillemotleft>f : a' \<rightarrow> dom e0\<guillemotright>"
              proof -
                have "a' = dom (\<chi>' J.Zero)"
                  by (simp add: J.arr_char)
                thus ?thesis
                  using 3 f_def e0_def g0 g1 ECP.tuple_in_hom ECP.pbdom_def by simp
              qed
              moreover have 5: "D.cones_map f (D.mkCone e0) = \<chi>'"
              proof -
                have "\<And>j. J.arr j \<Longrightarrow> D.mkCone e0 j \<cdot> f = \<chi>' j"
                proof -
                  fix j
                  assume j: "J.arr j"
                  show "D.mkCone e0 j \<cdot> f = \<chi>' j"
                  proof (cases "j = J.Zero")
                    case True
                    moreover have "e0 \<cdot> f = \<chi>' J.Zero"
                      using 4 by simp
                    ultimately show ?thesis
                      unfolding f_def D.mkCone_def comp_assoc
                      using J.arr_char by simp
                    next
                    case F: False
                    hence 1: "(f0 \<cdot> e0) \<cdot> f = f0 \<cdot> \<chi>' J.Zero"
                      using 4 comp_assoc by simp
                    also have "... = \<chi>' j"
                      by (metis (no_types, lifting) F D.mkCone_cone D.mkCone_def
                          \<chi>'.cone_axioms j)
                    finally show ?thesis
                      by (simp add: F D.mkCone_def j)
                  qed
                qed
                thus ?thesis
                  using f e0 \<chi>.cone_axioms \<chi>'.is_extensional by auto
              qed
              ultimately show "\<guillemotleft>f : a' \<rightarrow> dom e0\<guillemotright> \<and> D.cones_map f (D.mkCone e0) = \<chi>'"
                by simp
              fix f'
              assume f': "\<guillemotleft>f' : a' \<rightarrow> dom e0\<guillemotright> \<and> D.cones_map f' (D.mkCone e0) = \<chi>'"
              show "f' = f"
              proof -
                have "e0 \<cdot> f' = \<chi>' J.Zero"
                  using f' D.mkCone_cone D.mkCone_def \<chi>'.cone_axioms
                        comp_assoc J.arr_char \<chi>.cone_axioms
                  by auto
                thus ?thesis
                  using f' 3 4 eq ECP.universal [of ?g1 ?g0 "e1 \<cdot> f'" "e0 \<cdot> f'"] e0_def e1_def
                  by (metis (no_types, lifting))
              qed
            qed
          qed
        qed
        show "has_as_equalizer f0 f1 e0"
        proof -
          have "par f0 f1"
            by fact
          moreover have "D.has_as_equalizer e0"
            ..
          ultimately show ?thesis
            using has_as_equalizer_def by blast
        qed
      qed
    qed

    interpretation category_with_finite_products C
      by (simp add: ECC.is_cartesian_category cartesian_category.is_category_with_finite_products)

    lemma has_finite_products:
    shows "category_with_finite_products C"
      ..

    lemma has_finite_limits:
    shows "category_with_finite_limits C"
    proof
      fix J :: "nat comp"
      assume J: "category J"
      interpret J: category J
        using J by simp
      assume finite: "finite (Collect J.arr)"
      show "has_limits_of_shape J"
      proof -
        have "Collect (partial_magma.ide J) \<subseteq> Collect J.arr"
          by auto
        hence 1: "finite (Collect J.ide)"
          using finite finite_subset by blast
        have "has_products (Collect (partial_magma.ide J))"
          using 1 J.ideD(1) J.not_arr_null category_with_finite_products.has_finite_products
                is_category_with_finite_products
          by simp
        moreover have "Collect (partial_magma.ide J) \<noteq> UNIV"
          using J.not_arr_null by blast
        moreover have "Collect (partial_magma.arr J) \<noteq> UNIV"
          using J.not_arr_null by blast
        ultimately show ?thesis
          using finite 1 J.category_axioms has_limits_if_has_products
                has_finite_products' [of "Collect J.ide"]
                has_finite_products' [of "Collect J.arr"]
          by simp
      qed
    qed

    sublocale category_with_finite_limits C
      using has_finite_limits by simp

  end

end


(*  Title:      ZF/Int_ZF.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1993  University of Cambridge
*)

section{*The Integers as Equivalence Classes Over Pairs of Natural Numbers*}

theory Int_ZF imports EquivClass ArithSimp begin

definition
  intrel :: i  where
    "intrel == {p \<in> (nat*nat)*(nat*nat).
                \<exists>x1 y1 x2 y2. p=<<x1,y1>,<x2,y2>> & x1#+y2 = x2#+y1}"

definition
  int :: i  where
    "int == (nat*nat)//intrel"

definition
  int_of :: "i=>i" --{*coercion from nat to int*}    ("$# _" [80] 80)  where
    "$# m == intrel `` {<natify(m), 0>}"

definition
  intify :: "i=>i" --{*coercion from ANYTHING to int*}  where
    "intify(m) == if m \<in> int then m else $#0"

definition
  raw_zminus :: "i=>i"  where
    "raw_zminus(z) == \<Union><x,y>\<in>z. intrel``{<y,x>}"

definition
  zminus :: "i=>i"                                 ("$- _" [80] 80)  where
    "$- z == raw_zminus (intify(z))"

definition
  znegative   ::      "i=>o"  where
    "znegative(z) == \<exists>x y. x<y & y\<in>nat & <x,y>\<in>z"

definition
  iszero      ::      "i=>o"  where
    "iszero(z) == z = $# 0"

definition
  raw_nat_of  :: "i=>i"  where
  "raw_nat_of(z) == natify (\<Union><x,y>\<in>z. x#-y)"

definition
  nat_of  :: "i=>i"  where
  "nat_of(z) == raw_nat_of (intify(z))"

definition
  zmagnitude  ::      "i=>i"  where
  --{*could be replaced by an absolute value function from int to int?*}
    "zmagnitude(z) ==
     THE m. m\<in>nat & ((~ znegative(z) & z = $# m) |
                       (znegative(z) & $- z = $# m))"

definition
  raw_zmult   ::      "[i,i]=>i"  where
    (*Cannot use UN<x1,y2> here or in zadd because of the form of congruent2.
      Perhaps a "curried" or even polymorphic congruent predicate would be
      better.*)
     "raw_zmult(z1,z2) ==
       \<Union>p1\<in>z1. \<Union>p2\<in>z2.  split(%x1 y1. split(%x2 y2.
                   intrel``{<x1#*x2 #+ y1#*y2, x1#*y2 #+ y1#*x2>}, p2), p1)"

definition
  zmult       ::      "[i,i]=>i"      (infixl "$*" 70)  where
     "z1 $* z2 == raw_zmult (intify(z1),intify(z2))"

definition
  raw_zadd    ::      "[i,i]=>i"  where
     "raw_zadd (z1, z2) ==
       \<Union>z1\<in>z1. \<Union>z2\<in>z2. let <x1,y1>=z1; <x2,y2>=z2
                           in intrel``{<x1#+x2, y1#+y2>}"

definition
  zadd        ::      "[i,i]=>i"      (infixl "$+" 65)  where
     "z1 $+ z2 == raw_zadd (intify(z1),intify(z2))"

definition
  zdiff        ::      "[i,i]=>i"      (infixl "$-" 65)  where
     "z1 $- z2 == z1 $+ zminus(z2)"

definition
  zless        ::      "[i,i]=>o"      (infixl "$<" 50)  where
     "z1 $< z2 == znegative(z1 $- z2)"

definition
  zle          ::      "[i,i]=>o"      (infixl "$<=" 50)  where
     "z1 $<= z2 == z1 $< z2 | intify(z1)=intify(z2)"

notation (xsymbols)
  zmult  (infixl "$\<times>" 70) and
  zle  (infixl "$\<le>" 50)  --{*less than or equals*}

notation (HTML output)
  zmult  (infixl "$\<times>" 70) and
  zle  (infixl "$\<le>" 50)

declare quotientE [elim!]

subsection{*Proving that @{term intrel} is an equivalence relation*}

(** Natural deduction for intrel **)

lemma intrel_iff [simp]:
    "<<x1,y1>,<x2,y2>>: intrel \<longleftrightarrow>
     x1\<in>nat & y1\<in>nat & x2\<in>nat & y2\<in>nat & x1#+y2 = x2#+y1"
by (simp add: intrel_def)

lemma intrelI [intro!]:
    "[| x1#+y2 = x2#+y1; x1\<in>nat; y1\<in>nat; x2\<in>nat; y2\<in>nat |]
     ==> <<x1,y1>,<x2,y2>>: intrel"
by (simp add: intrel_def)

lemma intrelE [elim!]:
  "[| p \<in> intrel;
      !!x1 y1 x2 y2. [| p = <<x1,y1>,<x2,y2>>;  x1#+y2 = x2#+y1;
                        x1\<in>nat; y1\<in>nat; x2\<in>nat; y2\<in>nat |] ==> Q |]
   ==> Q"
by (simp add: intrel_def, blast)

lemma int_trans_lemma:
     "[| x1 #+ y2 = x2 #+ y1; x2 #+ y3 = x3 #+ y2 |] ==> x1 #+ y3 = x3 #+ y1"
apply (rule sym)
apply (erule add_left_cancel)+
apply (simp_all (no_asm_simp))
done

lemma equiv_intrel: "equiv(nat*nat, intrel)"
apply (simp add: equiv_def refl_def sym_def trans_def)
apply (fast elim!: sym int_trans_lemma)
done

lemma image_intrel_int: "[| m\<in>nat; n\<in>nat |] ==> intrel `` {<m,n>} \<in> int"
by (simp add: int_def)

declare equiv_intrel [THEN eq_equiv_class_iff, simp]
declare conj_cong [cong]

lemmas eq_intrelD = eq_equiv_class [OF _ equiv_intrel]

(** int_of: the injection from nat to int **)

lemma int_of_type [simp,TC]: "$#m \<in> int"
by (simp add: int_def quotient_def int_of_def, auto)

lemma int_of_eq [iff]: "($# m = $# n) \<longleftrightarrow> natify(m)=natify(n)"
by (simp add: int_of_def)

lemma int_of_inject: "[| $#m = $#n;  m\<in>nat;  n\<in>nat |] ==> m=n"
by (drule int_of_eq [THEN iffD1], auto)

(** intify: coercion from anything to int **)

lemma intify_in_int [iff,TC]: "intify(x) \<in> int"
by (simp add: intify_def)

lemma intify_ident [simp]: "n \<in> int ==> intify(n) = n"
by (simp add: intify_def)

subsection{*Collapsing rules: to remove @{term intify}
            from arithmetic expressions*}

lemma intify_idem [simp]: "intify(intify(x)) = intify(x)"
by simp

lemma int_of_natify [simp]: "$# (natify(m)) = $# m"
by (simp add: int_of_def)

lemma zminus_intify [simp]: "$- (intify(m)) = $- m"
by (simp add: zminus_def)

(** Addition **)

lemma zadd_intify1 [simp]: "intify(x) $+ y = x $+ y"
by (simp add: zadd_def)

lemma zadd_intify2 [simp]: "x $+ intify(y) = x $+ y"
by (simp add: zadd_def)

(** Subtraction **)

lemma zdiff_intify1 [simp]:"intify(x) $- y = x $- y"
by (simp add: zdiff_def)

lemma zdiff_intify2 [simp]:"x $- intify(y) = x $- y"
by (simp add: zdiff_def)

(** Multiplication **)

lemma zmult_intify1 [simp]:"intify(x) $* y = x $* y"
by (simp add: zmult_def)

lemma zmult_intify2 [simp]:"x $* intify(y) = x $* y"
by (simp add: zmult_def)

(** Orderings **)

lemma zless_intify1 [simp]:"intify(x) $< y \<longleftrightarrow> x $< y"
by (simp add: zless_def)

lemma zless_intify2 [simp]:"x $< intify(y) \<longleftrightarrow> x $< y"
by (simp add: zless_def)

lemma zle_intify1 [simp]:"intify(x) $<= y \<longleftrightarrow> x $<= y"
by (simp add: zle_def)

lemma zle_intify2 [simp]:"x $<= intify(y) \<longleftrightarrow> x $<= y"
by (simp add: zle_def)

subsection{*@{term zminus}: unary negation on @{term int}*}

lemma zminus_congruent: "(%<x,y>. intrel``{<y,x>}) respects intrel"
by (auto simp add: congruent_def add_ac)

lemma raw_zminus_type: "z \<in> int ==> raw_zminus(z) \<in> int"
apply (simp add: int_def raw_zminus_def)
apply (typecheck add: UN_equiv_class_type [OF equiv_intrel zminus_congruent])
done

lemma zminus_type [TC,iff]: "$-z \<in> int"
by (simp add: zminus_def raw_zminus_type)

lemma raw_zminus_inject:
     "[| raw_zminus(z) = raw_zminus(w);  z \<in> int;  w \<in> int |] ==> z=w"
apply (simp add: int_def raw_zminus_def)
apply (erule UN_equiv_class_inject [OF equiv_intrel zminus_congruent], safe)
apply (auto dest: eq_intrelD simp add: add_ac)
done

lemma zminus_inject_intify [dest!]: "$-z = $-w ==> intify(z) = intify(w)"
apply (simp add: zminus_def)
apply (blast dest!: raw_zminus_inject)
done

lemma zminus_inject: "[| $-z = $-w;  z \<in> int;  w \<in> int |] ==> z=w"
by auto

lemma raw_zminus:
    "[| x\<in>nat;  y\<in>nat |] ==> raw_zminus(intrel``{<x,y>}) = intrel `` {<y,x>}"
apply (simp add: raw_zminus_def UN_equiv_class [OF equiv_intrel zminus_congruent])
done

lemma zminus:
    "[| x\<in>nat;  y\<in>nat |]
     ==> $- (intrel``{<x,y>}) = intrel `` {<y,x>}"
by (simp add: zminus_def raw_zminus image_intrel_int)

lemma raw_zminus_zminus: "z \<in> int ==> raw_zminus (raw_zminus(z)) = z"
by (auto simp add: int_def raw_zminus)

lemma zminus_zminus_intify [simp]: "$- ($- z) = intify(z)"
by (simp add: zminus_def raw_zminus_type raw_zminus_zminus)

lemma zminus_int0 [simp]: "$- ($#0) = $#0"
by (simp add: int_of_def zminus)

lemma zminus_zminus: "z \<in> int ==> $- ($- z) = z"
by simp

subsection{*@{term znegative}: the test for negative integers*}

lemma znegative: "[| x\<in>nat; y\<in>nat |] ==> znegative(intrel``{<x,y>}) \<longleftrightarrow> x<y"
apply (cases "x<y")
apply (auto simp add: znegative_def not_lt_iff_le)
apply (subgoal_tac "y #+ x2 < x #+ y2", force)
apply (rule add_le_lt_mono, auto)
done

(*No natural number is negative!*)
lemma not_znegative_int_of [iff]: "~ znegative($# n)"
by (simp add: znegative int_of_def)

lemma znegative_zminus_int_of [simp]: "znegative($- $# succ(n))"
by (simp add: znegative int_of_def zminus natify_succ)

lemma not_znegative_imp_zero: "~ znegative($- $# n) ==> natify(n)=0"
by (simp add: znegative int_of_def zminus Ord_0_lt_iff [THEN iff_sym])

subsection{*@{term nat_of}: Coercion of an Integer to a Natural Number*}

lemma nat_of_intify [simp]: "nat_of(intify(z)) = nat_of(z)"
by (simp add: nat_of_def)

lemma nat_of_congruent: "(\<lambda>x. (\<lambda>\<langle>x,y\<rangle>. x #- y)(x)) respects intrel"
by (auto simp add: congruent_def split add: nat_diff_split)

lemma raw_nat_of:
    "[| x\<in>nat;  y\<in>nat |] ==> raw_nat_of(intrel``{<x,y>}) = x#-y"
by (simp add: raw_nat_of_def UN_equiv_class [OF equiv_intrel nat_of_congruent])

lemma raw_nat_of_int_of: "raw_nat_of($# n) = natify(n)"
by (simp add: int_of_def raw_nat_of)

lemma nat_of_int_of [simp]: "nat_of($# n) = natify(n)"
by (simp add: raw_nat_of_int_of nat_of_def)

lemma raw_nat_of_type: "raw_nat_of(z) \<in> nat"
by (simp add: raw_nat_of_def)

lemma nat_of_type [iff,TC]: "nat_of(z) \<in> nat"
by (simp add: nat_of_def raw_nat_of_type)

subsection{*zmagnitude: magnitide of an integer, as a natural number*}

lemma zmagnitude_int_of [simp]: "zmagnitude($# n) = natify(n)"
by (auto simp add: zmagnitude_def int_of_eq)

lemma natify_int_of_eq: "natify(x)=n ==> $#x = $# n"
apply (drule sym)
apply (simp (no_asm_simp) add: int_of_eq)
done

lemma zmagnitude_zminus_int_of [simp]: "zmagnitude($- $# n) = natify(n)"
apply (simp add: zmagnitude_def)
apply (rule the_equality)
apply (auto dest!: not_znegative_imp_zero natify_int_of_eq
            iff del: int_of_eq, auto)
done

lemma zmagnitude_type [iff,TC]: "zmagnitude(z)\<in>nat"
apply (simp add: zmagnitude_def)
apply (rule theI2, auto)
done

lemma not_zneg_int_of:
     "[| z \<in> int; ~ znegative(z) |] ==> \<exists>n\<in>nat. z = $# n"
apply (auto simp add: int_def znegative int_of_def not_lt_iff_le)
apply (rename_tac x y)
apply (rule_tac x="x#-y" in bexI)
apply (auto simp add: add_diff_inverse2)
done

lemma not_zneg_mag [simp]:
     "[| z \<in> int; ~ znegative(z) |] ==> $# (zmagnitude(z)) = z"
by (drule not_zneg_int_of, auto)

lemma zneg_int_of:
     "[| znegative(z); z \<in> int |] ==> \<exists>n\<in>nat. z = $- ($# succ(n))"
by (auto simp add: int_def znegative zminus int_of_def dest!: less_imp_succ_add)

lemma zneg_mag [simp]:
     "[| znegative(z); z \<in> int |] ==> $# (zmagnitude(z)) = $- z"
by (drule zneg_int_of, auto)

lemma int_cases: "z \<in> int ==> \<exists>n\<in>nat. z = $# n | z = $- ($# succ(n))"
apply (case_tac "znegative (z) ")
prefer 2 apply (blast dest: not_zneg_mag sym)
apply (blast dest: zneg_int_of)
done

lemma not_zneg_raw_nat_of:
     "[| ~ znegative(z); z \<in> int |] ==> $# (raw_nat_of(z)) = z"
apply (drule not_zneg_int_of)
apply (auto simp add: raw_nat_of_type raw_nat_of_int_of)
done

lemma not_zneg_nat_of_intify:
     "~ znegative(intify(z)) ==> $# (nat_of(z)) = intify(z)"
by (simp (no_asm_simp) add: nat_of_def not_zneg_raw_nat_of)

lemma not_zneg_nat_of: "[| ~ znegative(z); z \<in> int |] ==> $# (nat_of(z)) = z"
apply (simp (no_asm_simp) add: not_zneg_nat_of_intify)
done

lemma zneg_nat_of [simp]: "znegative(intify(z)) ==> nat_of(z) = 0"
apply (subgoal_tac "intify(z) \<in> int")
apply (simp add: int_def)
apply (auto simp add: znegative nat_of_def raw_nat_of
            split add: nat_diff_split)
done

subsection{*@{term zadd}: addition on int*}

text{*Congruence Property for Addition*}
lemma zadd_congruent2:
    "(%z1 z2. let <x1,y1>=z1; <x2,y2>=z2
                            in intrel``{<x1#+x2, y1#+y2>})
     respects2 intrel"
apply (simp add: congruent2_def)
(*Proof via congruent2_commuteI seems longer*)
apply safe
apply (simp (no_asm_simp) add: add_assoc Let_def)
(*The rest should be trivial, but rearranging terms is hard
  add_ac does not help rewriting with the assumptions.*)
apply (rule_tac m1 = x1a in add_left_commute [THEN ssubst])
apply (rule_tac m1 = x2a in add_left_commute [THEN ssubst])
apply (simp (no_asm_simp) add: add_assoc [symmetric])
done

lemma raw_zadd_type: "[| z \<in> int;  w \<in> int |] ==> raw_zadd(z,w) \<in> int"
apply (simp add: int_def raw_zadd_def)
apply (rule UN_equiv_class_type2 [OF equiv_intrel zadd_congruent2], assumption+)
apply (simp add: Let_def)
done

lemma zadd_type [iff,TC]: "z $+ w \<in> int"
by (simp add: zadd_def raw_zadd_type)

lemma raw_zadd:
  "[| x1\<in>nat; y1\<in>nat;  x2\<in>nat; y2\<in>nat |]
   ==> raw_zadd (intrel``{<x1,y1>}, intrel``{<x2,y2>}) =
       intrel `` {<x1#+x2, y1#+y2>}"
apply (simp add: raw_zadd_def
             UN_equiv_class2 [OF equiv_intrel equiv_intrel zadd_congruent2])
apply (simp add: Let_def)
done

lemma zadd:
  "[| x1\<in>nat; y1\<in>nat;  x2\<in>nat; y2\<in>nat |]
   ==> (intrel``{<x1,y1>}) $+ (intrel``{<x2,y2>}) =
       intrel `` {<x1#+x2, y1#+y2>}"
by (simp add: zadd_def raw_zadd image_intrel_int)

lemma raw_zadd_int0: "z \<in> int ==> raw_zadd ($#0,z) = z"
by (auto simp add: int_def int_of_def raw_zadd)

lemma zadd_int0_intify [simp]: "$#0 $+ z = intify(z)"
by (simp add: zadd_def raw_zadd_int0)

lemma zadd_int0: "z \<in> int ==> $#0 $+ z = z"
by simp

lemma raw_zminus_zadd_distrib:
     "[| z \<in> int;  w \<in> int |] ==> $- raw_zadd(z,w) = raw_zadd($- z, $- w)"
by (auto simp add: zminus raw_zadd int_def)

lemma zminus_zadd_distrib [simp]: "$- (z $+ w) = $- z $+ $- w"
by (simp add: zadd_def raw_zminus_zadd_distrib)

lemma raw_zadd_commute:
     "[| z \<in> int;  w \<in> int |] ==> raw_zadd(z,w) = raw_zadd(w,z)"
by (auto simp add: raw_zadd add_ac int_def)

lemma zadd_commute: "z $+ w = w $+ z"
by (simp add: zadd_def raw_zadd_commute)

lemma raw_zadd_assoc:
    "[| z1: int;  z2: int;  z3: int |]
     ==> raw_zadd (raw_zadd(z1,z2),z3) = raw_zadd(z1,raw_zadd(z2,z3))"
by (auto simp add: int_def raw_zadd add_assoc)

lemma zadd_assoc: "(z1 $+ z2) $+ z3 = z1 $+ (z2 $+ z3)"
by (simp add: zadd_def raw_zadd_type raw_zadd_assoc)

(*For AC rewriting*)
lemma zadd_left_commute: "z1$+(z2$+z3) = z2$+(z1$+z3)"
apply (simp add: zadd_assoc [symmetric])
apply (simp add: zadd_commute)
done

(*Integer addition is an AC operator*)
lemmas zadd_ac = zadd_assoc zadd_commute zadd_left_commute

lemma int_of_add: "$# (m #+ n) = ($#m) $+ ($#n)"
by (simp add: int_of_def zadd)

lemma int_succ_int_1: "$# succ(m) = $# 1 $+ ($# m)"
by (simp add: int_of_add [symmetric] natify_succ)

lemma int_of_diff:
     "[| m\<in>nat;  n \<le> m |] ==> $# (m #- n) = ($#m) $- ($#n)"
apply (simp add: int_of_def zdiff_def)
apply (frule lt_nat_in_nat)
apply (simp_all add: zadd zminus add_diff_inverse2)
done

lemma raw_zadd_zminus_inverse: "z \<in> int ==> raw_zadd (z, $- z) = $#0"
by (auto simp add: int_def int_of_def zminus raw_zadd add_commute)

lemma zadd_zminus_inverse [simp]: "z $+ ($- z) = $#0"
apply (simp add: zadd_def)
apply (subst zminus_intify [symmetric])
apply (rule intify_in_int [THEN raw_zadd_zminus_inverse])
done

lemma zadd_zminus_inverse2 [simp]: "($- z) $+ z = $#0"
by (simp add: zadd_commute zadd_zminus_inverse)

lemma zadd_int0_right_intify [simp]: "z $+ $#0 = intify(z)"
by (rule trans [OF zadd_commute zadd_int0_intify])

lemma zadd_int0_right: "z \<in> int ==> z $+ $#0 = z"
by simp

subsection{*@{term zmult}: Integer Multiplication*}

text{*Congruence property for multiplication*}
lemma zmult_congruent2:
    "(%p1 p2. split(%x1 y1. split(%x2 y2.
                    intrel``{<x1#*x2 #+ y1#*y2, x1#*y2 #+ y1#*x2>}, p2), p1))
     respects2 intrel"
apply (rule equiv_intrel [THEN congruent2_commuteI], auto)
(*Proof that zmult is congruent in one argument*)
apply (rename_tac x y)
apply (frule_tac t = "%u. x#*u" in sym [THEN subst_context])
apply (drule_tac t = "%u. y#*u" in subst_context)
apply (erule add_left_cancel)+
apply (simp_all add: add_mult_distrib_left)
done

lemma raw_zmult_type: "[| z \<in> int;  w \<in> int |] ==> raw_zmult(z,w) \<in> int"
apply (simp add: int_def raw_zmult_def)
apply (rule UN_equiv_class_type2 [OF equiv_intrel zmult_congruent2], assumption+)
apply (simp add: Let_def)
done

lemma zmult_type [iff,TC]: "z $* w \<in> int"
by (simp add: zmult_def raw_zmult_type)

lemma raw_zmult:
     "[| x1\<in>nat; y1\<in>nat;  x2\<in>nat; y2\<in>nat |]
      ==> raw_zmult(intrel``{<x1,y1>}, intrel``{<x2,y2>}) =
          intrel `` {<x1#*x2 #+ y1#*y2, x1#*y2 #+ y1#*x2>}"
by (simp add: raw_zmult_def
           UN_equiv_class2 [OF equiv_intrel equiv_intrel zmult_congruent2])

lemma zmult:
     "[| x1\<in>nat; y1\<in>nat;  x2\<in>nat; y2\<in>nat |]
      ==> (intrel``{<x1,y1>}) $* (intrel``{<x2,y2>}) =
          intrel `` {<x1#*x2 #+ y1#*y2, x1#*y2 #+ y1#*x2>}"
by (simp add: zmult_def raw_zmult image_intrel_int)

lemma raw_zmult_int0: "z \<in> int ==> raw_zmult ($#0,z) = $#0"
by (auto simp add: int_def int_of_def raw_zmult)

lemma zmult_int0 [simp]: "$#0 $* z = $#0"
by (simp add: zmult_def raw_zmult_int0)

lemma raw_zmult_int1: "z \<in> int ==> raw_zmult ($#1,z) = z"
by (auto simp add: int_def int_of_def raw_zmult)

lemma zmult_int1_intify [simp]: "$#1 $* z = intify(z)"
by (simp add: zmult_def raw_zmult_int1)

lemma zmult_int1: "z \<in> int ==> $#1 $* z = z"
by simp

lemma raw_zmult_commute:
     "[| z \<in> int;  w \<in> int |] ==> raw_zmult(z,w) = raw_zmult(w,z)"
by (auto simp add: int_def raw_zmult add_ac mult_ac)

lemma zmult_commute: "z $* w = w $* z"
by (simp add: zmult_def raw_zmult_commute)

lemma raw_zmult_zminus:
     "[| z \<in> int;  w \<in> int |] ==> raw_zmult($- z, w) = $- raw_zmult(z, w)"
by (auto simp add: int_def zminus raw_zmult add_ac)

lemma zmult_zminus [simp]: "($- z) $* w = $- (z $* w)"
apply (simp add: zmult_def raw_zmult_zminus)
apply (subst zminus_intify [symmetric], rule raw_zmult_zminus, auto)
done

lemma zmult_zminus_right [simp]: "w $* ($- z) = $- (w $* z)"
by (simp add: zmult_commute [of w])

lemma raw_zmult_assoc:
    "[| z1: int;  z2: int;  z3: int |]
     ==> raw_zmult (raw_zmult(z1,z2),z3) = raw_zmult(z1,raw_zmult(z2,z3))"
by (auto simp add: int_def raw_zmult add_mult_distrib_left add_ac mult_ac)

lemma zmult_assoc: "(z1 $* z2) $* z3 = z1 $* (z2 $* z3)"
by (simp add: zmult_def raw_zmult_type raw_zmult_assoc)

(*For AC rewriting*)
lemma zmult_left_commute: "z1$*(z2$*z3) = z2$*(z1$*z3)"
apply (simp add: zmult_assoc [symmetric])
apply (simp add: zmult_commute)
done

(*Integer multiplication is an AC operator*)
lemmas zmult_ac = zmult_assoc zmult_commute zmult_left_commute

lemma raw_zadd_zmult_distrib:
    "[| z1: int;  z2: int;  w \<in> int |]
     ==> raw_zmult(raw_zadd(z1,z2), w) =
         raw_zadd (raw_zmult(z1,w), raw_zmult(z2,w))"
by (auto simp add: int_def raw_zadd raw_zmult add_mult_distrib_left add_ac mult_ac)

lemma zadd_zmult_distrib: "(z1 $+ z2) $* w = (z1 $* w) $+ (z2 $* w)"
by (simp add: zmult_def zadd_def raw_zadd_type raw_zmult_type
              raw_zadd_zmult_distrib)

lemma zadd_zmult_distrib2: "w $* (z1 $+ z2) = (w $* z1) $+ (w $* z2)"
by (simp add: zmult_commute [of w] zadd_zmult_distrib)

lemmas int_typechecks =
  int_of_type zminus_type zmagnitude_type zadd_type zmult_type

(*** Subtraction laws ***)

lemma zdiff_type [iff,TC]: "z $- w \<in> int"
by (simp add: zdiff_def)

lemma zminus_zdiff_eq [simp]: "$- (z $- y) = y $- z"
by (simp add: zdiff_def zadd_commute)

lemma zdiff_zmult_distrib: "(z1 $- z2) $* w = (z1 $* w) $- (z2 $* w)"
apply (simp add: zdiff_def)
apply (subst zadd_zmult_distrib)
apply (simp add: zmult_zminus)
done

lemma zdiff_zmult_distrib2: "w $* (z1 $- z2) = (w $* z1) $- (w $* z2)"
by (simp add: zmult_commute [of w] zdiff_zmult_distrib)

lemma zadd_zdiff_eq: "x $+ (y $- z) = (x $+ y) $- z"
by (simp add: zdiff_def zadd_ac)

lemma zdiff_zadd_eq: "(x $- y) $+ z = (x $+ z) $- y"
by (simp add: zdiff_def zadd_ac)

subsection{*The "Less Than" Relation*}

(*"Less than" is a linear ordering*)
lemma zless_linear_lemma:
     "[| z \<in> int; w \<in> int |] ==> z$<w | z=w | w$<z"
apply (simp add: int_def zless_def znegative_def zdiff_def, auto)
apply (simp add: zadd zminus image_iff Bex_def)
apply (rule_tac i = "xb#+ya" and j = "xc #+ y" in Ord_linear_lt)
apply (force dest!: spec simp add: add_ac)+
done

lemma zless_linear: "z$<w | intify(z)=intify(w) | w$<z"
apply (cut_tac z = " intify (z) " and w = " intify (w) " in zless_linear_lemma)
apply auto
done

lemma zless_not_refl [iff]: "~ (z$<z)"
by (auto simp add: zless_def znegative_def int_of_def zdiff_def)

lemma neq_iff_zless: "[| x \<in> int; y \<in> int |] ==> (x \<noteq> y) \<longleftrightarrow> (x $< y | y $< x)"
by (cut_tac z = x and w = y in zless_linear, auto)

lemma zless_imp_intify_neq: "w $< z ==> intify(w) \<noteq> intify(z)"
apply auto
apply (subgoal_tac "~ (intify (w) $< intify (z))")
apply (erule_tac [2] ssubst)
apply (simp (no_asm_use))
apply auto
done

(*This lemma allows direct proofs of other <-properties*)
lemma zless_imp_succ_zadd_lemma:
    "[| w $< z; w \<in> int; z \<in> int |] ==> (\<exists>n\<in>nat. z = w $+ $#(succ(n)))"
apply (simp add: zless_def znegative_def zdiff_def int_def)
apply (auto dest!: less_imp_succ_add simp add: zadd zminus int_of_def)
apply (rule_tac x = k in bexI)
apply (erule_tac i="succ (?v)" in add_left_cancel, auto)
done

lemma zless_imp_succ_zadd:
     "w $< z ==> (\<exists>n\<in>nat. w $+ $#(succ(n)) = intify(z))"
apply (subgoal_tac "intify (w) $< intify (z) ")
apply (drule_tac w = "intify (w) " in zless_imp_succ_zadd_lemma)
apply auto
done

lemma zless_succ_zadd_lemma:
    "w \<in> int ==> w $< w $+ $# succ(n)"
apply (simp add: zless_def znegative_def zdiff_def int_def)
apply (auto simp add: zadd zminus int_of_def image_iff)
apply (rule_tac x = 0 in exI, auto)
done

lemma zless_succ_zadd: "w $< w $+ $# succ(n)"
by (cut_tac intify_in_int [THEN zless_succ_zadd_lemma], auto)

lemma zless_iff_succ_zadd:
     "w $< z \<longleftrightarrow> (\<exists>n\<in>nat. w $+ $#(succ(n)) = intify(z))"
apply (rule iffI)
apply (erule zless_imp_succ_zadd, auto)
apply (rename_tac "n")
apply (cut_tac w = w and n = n in zless_succ_zadd, auto)
done

lemma zless_int_of [simp]: "[| m\<in>nat; n\<in>nat |] ==> ($#m $< $#n) \<longleftrightarrow> (m<n)"
apply (simp add: less_iff_succ_add zless_iff_succ_zadd int_of_add [symmetric])
apply (blast intro: sym)
done

lemma zless_trans_lemma:
    "[| x $< y; y $< z; x \<in> int; y \<in> int; z \<in> int |] ==> x $< z"
apply (simp add: zless_def znegative_def zdiff_def int_def)
apply (auto simp add: zadd zminus image_iff)
apply (rename_tac x1 x2 y1 y2)
apply (rule_tac x = "x1#+x2" in exI)
apply (rule_tac x = "y1#+y2" in exI)
apply (auto simp add: add_lt_mono)
apply (rule sym)
apply hypsubst_thin
apply (erule add_left_cancel)+
apply auto
done

lemma zless_trans [trans]: "[| x $< y; y $< z |] ==> x $< z"
apply (subgoal_tac "intify (x) $< intify (z) ")
apply (rule_tac [2] y = "intify (y) " in zless_trans_lemma)
apply auto
done

lemma zless_not_sym: "z $< w ==> ~ (w $< z)"
by (blast dest: zless_trans)

(* [| z $< w; ~ P ==> w $< z |] ==> P *)
lemmas zless_asym = zless_not_sym [THEN swap]

lemma zless_imp_zle: "z $< w ==> z $<= w"
by (simp add: zle_def)

lemma zle_linear: "z $<= w | w $<= z"
apply (simp add: zle_def)
apply (cut_tac zless_linear, blast)
done

subsection{*Less Than or Equals*}

lemma zle_refl: "z $<= z"
by (simp add: zle_def)

lemma zle_eq_refl: "x=y ==> x $<= y"
by (simp add: zle_refl)

lemma zle_anti_sym_intify: "[| x $<= y; y $<= x |] ==> intify(x) = intify(y)"
apply (simp add: zle_def, auto)
apply (blast dest: zless_trans)
done

lemma zle_anti_sym: "[| x $<= y; y $<= x; x \<in> int; y \<in> int |] ==> x=y"
by (drule zle_anti_sym_intify, auto)

lemma zle_trans_lemma:
     "[| x \<in> int; y \<in> int; z \<in> int; x $<= y; y $<= z |] ==> x $<= z"
apply (simp add: zle_def, auto)
apply (blast intro: zless_trans)
done

lemma zle_trans [trans]: "[| x $<= y; y $<= z |] ==> x $<= z"
apply (subgoal_tac "intify (x) $<= intify (z) ")
apply (rule_tac [2] y = "intify (y) " in zle_trans_lemma)
apply auto
done

lemma zle_zless_trans [trans]: "[| i $<= j; j $< k |] ==> i $< k"
apply (auto simp add: zle_def)
apply (blast intro: zless_trans)
apply (simp add: zless_def zdiff_def zadd_def)
done

lemma zless_zle_trans [trans]: "[| i $< j; j $<= k |] ==> i $< k"
apply (auto simp add: zle_def)
apply (blast intro: zless_trans)
apply (simp add: zless_def zdiff_def zminus_def)
done

lemma not_zless_iff_zle: "~ (z $< w) \<longleftrightarrow> (w $<= z)"
apply (cut_tac z = z and w = w in zless_linear)
apply (auto dest: zless_trans simp add: zle_def)
apply (auto dest!: zless_imp_intify_neq)
done

lemma not_zle_iff_zless: "~ (z $<= w) \<longleftrightarrow> (w $< z)"
by (simp add: not_zless_iff_zle [THEN iff_sym])

subsection{*More subtraction laws (for @{text zcompare_rls})*}

lemma zdiff_zdiff_eq: "(x $- y) $- z = x $- (y $+ z)"
by (simp add: zdiff_def zadd_ac)

lemma zdiff_zdiff_eq2: "x $- (y $- z) = (x $+ z) $- y"
by (simp add: zdiff_def zadd_ac)

lemma zdiff_zless_iff: "(x$-y $< z) \<longleftrightarrow> (x $< z $+ y)"
by (simp add: zless_def zdiff_def zadd_ac)

lemma zless_zdiff_iff: "(x $< z$-y) \<longleftrightarrow> (x $+ y $< z)"
by (simp add: zless_def zdiff_def zadd_ac)

lemma zdiff_eq_iff: "[| x \<in> int; z \<in> int |] ==> (x$-y = z) \<longleftrightarrow> (x = z $+ y)"
by (auto simp add: zdiff_def zadd_assoc)

lemma eq_zdiff_iff: "[| x \<in> int; z \<in> int |] ==> (x = z$-y) \<longleftrightarrow> (x $+ y = z)"
by (auto simp add: zdiff_def zadd_assoc)

lemma zdiff_zle_iff_lemma:
     "[| x \<in> int; z \<in> int |] ==> (x$-y $<= z) \<longleftrightarrow> (x $<= z $+ y)"
by (auto simp add: zle_def zdiff_eq_iff zdiff_zless_iff)

lemma zdiff_zle_iff: "(x$-y $<= z) \<longleftrightarrow> (x $<= z $+ y)"
by (cut_tac zdiff_zle_iff_lemma [OF intify_in_int intify_in_int], simp)

lemma zle_zdiff_iff_lemma:
     "[| x \<in> int; z \<in> int |] ==>(x $<= z$-y) \<longleftrightarrow> (x $+ y $<= z)"
apply (auto simp add: zle_def zdiff_eq_iff zless_zdiff_iff)
apply (auto simp add: zdiff_def zadd_assoc)
done

lemma zle_zdiff_iff: "(x $<= z$-y) \<longleftrightarrow> (x $+ y $<= z)"
by (cut_tac zle_zdiff_iff_lemma [ OF intify_in_int intify_in_int], simp)

text{*This list of rewrites simplifies (in)equalities by bringing subtractions
  to the top and then moving negative terms to the other side.
  Use with @{text zadd_ac}*}
lemmas zcompare_rls =
     zdiff_def [symmetric]
     zadd_zdiff_eq zdiff_zadd_eq zdiff_zdiff_eq zdiff_zdiff_eq2
     zdiff_zless_iff zless_zdiff_iff zdiff_zle_iff zle_zdiff_iff
     zdiff_eq_iff eq_zdiff_iff

subsection{*Monotonicity and Cancellation Results for Instantiation
     of the CancelNumerals Simprocs*}

lemma zadd_left_cancel:
     "[| w \<in> int; w': int |] ==> (z $+ w' = z $+ w) \<longleftrightarrow> (w' = w)"
apply safe
apply (drule_tac t = "%x. x $+ ($-z) " in subst_context)
apply (simp add: zadd_ac)
done

lemma zadd_left_cancel_intify [simp]:
     "(z $+ w' = z $+ w) \<longleftrightarrow> intify(w') = intify(w)"
apply (rule iff_trans)
apply (rule_tac [2] zadd_left_cancel, auto)
done

lemma zadd_right_cancel:
     "[| w \<in> int; w': int |] ==> (w' $+ z = w $+ z) \<longleftrightarrow> (w' = w)"
apply safe
apply (drule_tac t = "%x. x $+ ($-z) " in subst_context)
apply (simp add: zadd_ac)
done

lemma zadd_right_cancel_intify [simp]:
     "(w' $+ z = w $+ z) \<longleftrightarrow> intify(w') = intify(w)"
apply (rule iff_trans)
apply (rule_tac [2] zadd_right_cancel, auto)
done

lemma zadd_right_cancel_zless [simp]: "(w' $+ z $< w $+ z) \<longleftrightarrow> (w' $< w)"
by (simp add: zdiff_zless_iff [THEN iff_sym] zdiff_def zadd_assoc)

lemma zadd_left_cancel_zless [simp]: "(z $+ w' $< z $+ w) \<longleftrightarrow> (w' $< w)"
by (simp add: zadd_commute [of z] zadd_right_cancel_zless)

lemma zadd_right_cancel_zle [simp]: "(w' $+ z $<= w $+ z) \<longleftrightarrow> w' $<= w"
by (simp add: zle_def)

lemma zadd_left_cancel_zle [simp]: "(z $+ w' $<= z $+ w) \<longleftrightarrow>  w' $<= w"
by (simp add: zadd_commute [of z]  zadd_right_cancel_zle)

(*"v $<= w ==> v$+z $<= w$+z"*)
lemmas zadd_zless_mono1 = zadd_right_cancel_zless [THEN iffD2]

(*"v $<= w ==> z$+v $<= z$+w"*)
lemmas zadd_zless_mono2 = zadd_left_cancel_zless [THEN iffD2]

(*"v $<= w ==> v$+z $<= w$+z"*)
lemmas zadd_zle_mono1 = zadd_right_cancel_zle [THEN iffD2]

(*"v $<= w ==> z$+v $<= z$+w"*)
lemmas zadd_zle_mono2 = zadd_left_cancel_zle [THEN iffD2]

lemma zadd_zle_mono: "[| w' $<= w; z' $<= z |] ==> w' $+ z' $<= w $+ z"
by (erule zadd_zle_mono1 [THEN zle_trans], simp)

lemma zadd_zless_mono: "[| w' $< w; z' $<= z |] ==> w' $+ z' $< w $+ z"
by (erule zadd_zless_mono1 [THEN zless_zle_trans], simp)

subsection{*Comparison laws*}

lemma zminus_zless_zminus [simp]: "($- x $< $- y) \<longleftrightarrow> (y $< x)"
by (simp add: zless_def zdiff_def zadd_ac)

lemma zminus_zle_zminus [simp]: "($- x $<= $- y) \<longleftrightarrow> (y $<= x)"
by (simp add: not_zless_iff_zle [THEN iff_sym])

subsubsection{*More inequality lemmas*}

lemma equation_zminus: "[| x \<in> int;  y \<in> int |] ==> (x = $- y) \<longleftrightarrow> (y = $- x)"
by auto

lemma zminus_equation: "[| x \<in> int;  y \<in> int |] ==> ($- x = y) \<longleftrightarrow> ($- y = x)"
by auto

lemma equation_zminus_intify: "(intify(x) = $- y) \<longleftrightarrow> (intify(y) = $- x)"
apply (cut_tac x = "intify (x) " and y = "intify (y) " in equation_zminus)
apply auto
done

lemma zminus_equation_intify: "($- x = intify(y)) \<longleftrightarrow> ($- y = intify(x))"
apply (cut_tac x = "intify (x) " and y = "intify (y) " in zminus_equation)
apply auto
done

subsubsection{*The next several equations are permutative: watch out!*}

lemma zless_zminus: "(x $< $- y) \<longleftrightarrow> (y $< $- x)"
by (simp add: zless_def zdiff_def zadd_ac)

lemma zminus_zless: "($- x $< y) \<longleftrightarrow> ($- y $< x)"
by (simp add: zless_def zdiff_def zadd_ac)

lemma zle_zminus: "(x $<= $- y) \<longleftrightarrow> (y $<= $- x)"
by (simp add: not_zless_iff_zle [THEN iff_sym] zminus_zless)

lemma zminus_zle: "($- x $<= y) \<longleftrightarrow> ($- y $<= x)"
by (simp add: not_zless_iff_zle [THEN iff_sym] zless_zminus)

end


section \<open>Set Cover\<close>

theory Approx_SC_Hoare
imports
  "HOL-Hoare.Hoare_Logic"
  Complex_Main (* "HOL-Analysis.Harmonic_Numbers" *)
begin

text \<open>This is a formalization of the set cover algorithm and proof
in the book by Kleinberg and Tardos \cite{KleinbergT06}.\<close>

definition harm :: "nat \<Rightarrow> 'a :: real_normed_field" where
  "harm n = (\<Sum>k=1..n. inverse (of_nat k))"
(* For simplicity defined locally instead of importing HOL-Analysis.Harmonic_Numbers.
   Only the definition, no theorems are needed.
*)

locale Set_Cover = (* Set Cover *)
  fixes w :: "nat \<Rightarrow> real"
    and m :: nat
    and S :: "nat \<Rightarrow> 'a set"
  assumes S_finite: "\<forall>i \<in> {1..m}. finite (S i)"
      and w_nonneg: "\<forall>i. 0 \<le> w i"
begin

definition U :: "'a set" where
  "U = (\<Union>i \<in> {1..m}. S i)"

lemma S_subset: "\<forall>i \<in> {1..m}. S i \<subseteq> U"
  using U_def by blast

lemma U_finite: "finite U"
  unfolding U_def using S_finite by blast

lemma empty_cover: "m = 0 \<Longrightarrow> U = {}"
  using U_def by simp

definition sc :: "nat set \<Rightarrow> 'a set \<Rightarrow> bool" where
  "sc C X \<longleftrightarrow> C \<subseteq> {1..m} \<and> (\<Union>i \<in> C. S i) = X"

definition cost :: "'a set \<Rightarrow> nat \<Rightarrow> real" where
  "cost R i = w i / card (S i \<inter> R)"

lemma cost_nonneg: "0 \<le> cost R i"
  using w_nonneg by (simp add: cost_def)

text \<open>\<open>cost R i = 0\<close> if \<open>card (S i \<inter> R) = 0\<close>! Needs to be accounted for separately in \<open>min_arg\<close>.\<close>
fun min_arg :: "'a set \<Rightarrow> nat \<Rightarrow> nat" where
  "min_arg R 0 = 1"
| "min_arg R (Suc x) =
   (let j = min_arg R x
    in if S j \<inter> R = {} \<or> (S (Suc x) \<inter> R \<noteq> {} \<and> cost R (Suc x) < cost R j) then (Suc x) else j)"

lemma min_in_range: "k > 0 \<Longrightarrow> min_arg R k \<in> {1..k}"
  by (induction k) (force simp: Let_def)+

lemma min_empty: "S (min_arg R k) \<inter> R = {} \<Longrightarrow> \<forall>i \<in> {1..k}. S i \<inter> R = {}"
proof (induction k)
  case (Suc k)
  from Suc.prems have prem: "S (min_arg R k) \<inter> R = {}" by (auto simp: Let_def split: if_splits)
  with Suc.IH have IH: "\<forall>i \<in> {1..k}. S i \<inter> R = {}" .
  show ?case proof fix i assume "i \<in> {1..Suc k}" show "S i \<inter> R = {}"
    proof (cases \<open>i = Suc k\<close>)
      case True with Suc.prems prem show ?thesis by simp
    next
      case False with IH \<open>i \<in> {1..Suc k}\<close> show ?thesis by simp
    qed
  qed
qed simp

lemma min_correct: "\<lbrakk> i \<in> {1..k}; S i \<inter> R \<noteq> {} \<rbrakk> \<Longrightarrow> cost R (min_arg R k) \<le> cost R i"
proof (induction k)
  case (Suc k)
  show ?case proof (cases \<open>i = Suc k\<close>)
    case True with Suc.prems show ?thesis by (auto simp: Let_def)
  next
    case False with Suc.prems Suc.IH have IH: "cost R (min_arg R k) \<le> cost R i" by simp
    from Suc.prems False min_empty[of R k] have "S (min_arg R k) \<inter> R \<noteq> {}" by force
    with IH show ?thesis by (auto simp: Let_def)
  qed
qed simp

text \<open>Correctness holds quite trivially for both m = 0 and m > 0
      (assuming a set cover can be found at all, otherwise algorithm would not terminate).\<close>
lemma set_cover_correct:
"VARS (R :: 'a set) (C :: nat set) (i :: nat)
  {True}
  R := U; C := {};
  WHILE R \<noteq> {} INV {R \<subseteq> U \<and> sc C (U - R)} DO
  i := min_arg R m;
  R := R - S i;
  C := C \<union> {i}
  OD
  {sc C U}"
proof (vcg, goal_cases)
  case 2 show ?case proof (cases m)
    case 0
    from empty_cover[OF this] 2 show ?thesis by (auto simp: sc_def)
  next
    case Suc then have "m > 0" by simp
    from min_in_range[OF this] 2 show ?thesis using S_subset by (auto simp: sc_def)
  qed
qed (auto simp: sc_def)

definition c_exists :: "nat set \<Rightarrow> 'a set \<Rightarrow> bool" where
  "c_exists C R = (\<exists>c. sum w C = sum c (U - R) \<and> (\<forall>i. 0 \<le> c i)
                \<and> (\<forall>k \<in> {1..m}. sum c (S k \<inter> (U - R))
                   \<le> (\<Sum>j = card (S k \<inter> R) + 1..card (S k). inverse j) * w k))"

definition inv :: "nat set \<Rightarrow> 'a set \<Rightarrow> bool" where
  "inv C R \<longleftrightarrow> sc C (U - R) \<and> R \<subseteq> U \<and> c_exists C R"

lemma invI:
  assumes "sc C (U - R)" "R \<subseteq> U"
          "\<exists>c. sum w C = sum c (U - R) \<and> (\<forall>i. 0 \<le> c i)
        \<and> (\<forall>k \<in> {1..m}. sum c (S k \<inter> (U - R))
                      \<le> (\<Sum>j = card (S k \<inter> R) + 1..card (S k). inverse j) * w k)"
    shows "inv C R" using assms by (auto simp: inv_def c_exists_def)

lemma invD:
  assumes "inv C R"
  shows "sc C (U - R)" "R \<subseteq> U"
        "\<exists>c. sum w C = sum c (U - R) \<and> (\<forall>i. 0 \<le> c i)
      \<and> (\<forall>k \<in> {1..m}. sum c (S k \<inter> (U - R))
                    \<le> (\<Sum>j = card (S k \<inter> R) + 1..card (S k). inverse j) * w k)"
  using assms by (auto simp: inv_def c_exists_def)

lemma inv_init: "inv {} U"
proof (rule invI, goal_cases)
  case 3
  let ?c = "(\<lambda>_. 0) :: 'a \<Rightarrow> real"
  have "sum w {} = sum ?c (U - U)" by simp
  moreover {
    have "\<forall>k \<in> {1..m}. 0 \<le> (\<Sum>j = card (S k \<inter> U) + 1..card (S k). inverse j) * w k"
      by (simp add: sum_nonneg w_nonneg)
    then have "(\<forall>k\<in>{1..m}. sum ?c (S k \<inter> (U - U))
             \<le> (\<Sum>j = card (S k \<inter> U) + 1..card (S k). inverse j) * w k)" by simp
  }
  ultimately show ?case by blast
qed (simp_all add: sc_def)

lemma inv_step:
  assumes "inv C R" "R \<noteq> {}"
  defines [simp]: "i \<equiv> min_arg R m"
  shows "inv (C \<union> {i}) (R - (S i))"
proof (cases m)
  case 0
  from empty_cover[OF this] invD(2)[OF assms(1)] have "R = {}" by blast
  then show ?thesis using assms(2) by simp
next
  case Suc then have "0 < m" by simp
  note hyp = invD[OF assms(1)]
  show ?thesis proof (rule invI, goal_cases)
      \<comment> \<open>Correctness\<close>
    case 1 have "i \<in> {1..m}" using min_in_range[OF \<open>0 < m\<close>] by simp
    with hyp(1) S_subset show ?case by (auto simp: sc_def)
  next
    case 2 from hyp(2) show ?case by auto
  next
    case 3
      \<comment> \<open>Set Cover grows\<close>
    have "\<exists>i \<in> {1..m}. S i \<inter> R \<noteq> {}"
      using assms(2) U_def hyp(2) by blast
    then have "S i \<inter> R \<noteq> {}" using min_empty by auto
    then have "0 < card (S i \<inter> R)"
      using S_finite min_in_range[OF \<open>0 < m\<close>] by auto

      \<comment> \<open>Proving properties of cost function\<close>
    from hyp(3) obtain c where "sum w C = sum c (U - R)" "\<forall>i. 0 \<le> c i" and
      SUM: "\<forall>k\<in>{1..m}. sum c (S k \<inter> (U - R))
        \<le> (\<Sum>j = card (S k \<inter> R) + 1..card (S k). inverse j) * w k" by blast
    let ?c = "(\<lambda>x. if x \<in> S i \<inter> R then cost R i else c x)"

      \<comment> \<open>Proof of Lemma 11.9\<close>
    have "finite (U - R)" "finite (S i \<inter> R)" "(U - R) \<inter> (S i \<inter> R) = {}"
      using U_finite S_finite min_in_range[OF \<open>0 < m\<close>] by auto
    then have "sum ?c (U - R \<union> (S i \<inter> R)) = sum ?c (U - R) + sum ?c (S i \<inter> R)"
      by (rule sum.union_disjoint)
    moreover have U_split: "U - (R - S i) = U - R \<union> (S i \<inter> R)" using hyp(2) by blast
    moreover {
      have "sum ?c (S i \<inter> R) = card (S i \<inter> R) * cost R i" by simp
      also have "... = w i" unfolding cost_def using \<open>0 < card (S i \<inter> R)\<close> by simp
      finally have "sum ?c (S i \<inter> R) = w i" .
    }
    ultimately have "sum ?c (U - (R - S i)) = sum ?c (U - R) + w i" by simp
    moreover {
      have "C \<inter> {i} = {}" using hyp(1) \<open>S i \<inter> R \<noteq> {}\<close> by (auto simp: sc_def)
      from sum.union_disjoint[OF _ _ this] have "sum w (C \<union> {i}) = sum w C + w i"
        using hyp(1) by (auto simp: sc_def intro: finite_subset)
    }
    ultimately have 1: "sum w (C \<union> {i}) = sum ?c (U - (R - S i))" \<comment> \<open>Lemma 11.9\<close>
      using \<open>sum w C = sum c (U - R)\<close> by simp

    have 2: "\<forall>i. 0 \<le> ?c i" using \<open>\<forall>i. 0 \<le> c i\<close> cost_nonneg by simp

      \<comment> \<open>Proof of Lemma 11.10\<close>
    have 3: "\<forall>k\<in>{1..m}. sum ?c (S k \<inter> (U - (R - S i)))
          \<le> (\<Sum>j = card (S k \<inter> (R - S i)) + 1..card (S k). inverse j) * w k"
    proof
      fix k assume "k \<in> {1..m}"
      let ?rem = "S k \<inter> R" \<comment> \<open>Remaining elements to be covered\<close>
      let ?add = "S k \<inter> S i \<inter> R" \<comment> \<open>Elements that will be covered in this step\<close>
      let ?cov = "S k \<inter> (U - R)" \<comment> \<open>Covered elements\<close>

      \<comment> \<open>Transforming left and right sides\<close>
      have "sum ?c (S k \<inter> (U - (R - S i))) = sum ?c (S k \<inter> (U - R \<union> (S i \<inter> R)))"
        unfolding U_split ..
      also have "... = sum ?c (?cov \<union> ?add)"
        by (simp add: Int_Un_distrib Int_assoc)
      also have "... = sum ?c ?cov + sum ?c ?add"
        by (rule sum.union_disjoint) (insert S_finite \<open>k \<in> _\<close>, auto)
      finally have lhs:
        "sum ?c (S k \<inter> (U - (R - S i))) = sum ?c ?cov + sum ?c ?add" .
      have "S k \<inter> (R - S i) = ?rem - ?add" by blast
      then have "card (S k \<inter> (R - S i)) = card (?rem - ?add)" by simp
      also have "... = card ?rem - card ?add"
        using S_finite \<open>k \<in> _\<close> by (auto intro: card_Diff_subset)
      finally have rhs:
        "card (S k \<inter> (R - S i)) + 1 = card ?rem - card ?add + 1" by simp

      \<comment> \<open>The apparent complexity of the remaining proof is deceiving. Much of this is just about
          convincing Isabelle that these sum transformations are allowed.\<close>
      have "sum ?c ?add = card ?add * cost R i" by simp
      also have "... \<le> card ?add * cost R k"
        proof (cases "?rem = {}")
          case True
          then have "card ?add = 0" by (auto simp: card_eq_0_iff)
          then show ?thesis by simp
        next
          case False
          from min_correct[OF \<open>k \<in> _\<close> this] have "cost R i \<le> cost R k" by simp
          then show ?thesis by (simp add: mult_left_mono)
        qed
      also have "... = card ?add * inverse (card ?rem) * w k"
        by (simp add: cost_def divide_inverse_commute)
      also have "... = (\<Sum>j \<in> {card ?rem - card ?add + 1 .. card ?rem}. inverse (card ?rem)) * w k"
        proof -
          have "card ?add \<le> card ?rem"
            using S_finite \<open>k \<in> _\<close> by (blast intro: card_mono)
          then show ?thesis by (simp add: sum_distrib_left)
        qed
      also have "... \<le> (\<Sum>j \<in> {card ?rem - card ?add + 1 .. card ?rem}. inverse j) * w k"
        proof -
          have "\<forall>j \<in> {card ?rem - card ?add + 1 .. card ?rem}. inverse (card ?rem) \<le> inverse j"
            by force
          then have "(\<Sum>j \<in> {card ?rem - card ?add + 1 .. card ?rem}. inverse (card ?rem))
                   \<le> (\<Sum>j \<in> {card ?rem - card ?add + 1 .. card ?rem}. inverse j)"
            by (blast intro: sum_mono)
          with w_nonneg show ?thesis by (blast intro: mult_right_mono)
        qed
      finally have "sum ?c ?add
                 \<le> (\<Sum>j \<in> {card ?rem - card ?add + 1 .. card ?rem}. inverse j) * w k" .
      moreover from SUM have "sum ?c ?cov
                           \<le> (\<Sum>j \<in> {card ?rem + 1 .. card (S k)}. inverse j) * w k"
        using \<open>k \<in> {1..m}\<close> by simp
      ultimately have "sum ?c (S k \<inter> (U - (R - S i)))
                    \<le> ((\<Sum>j \<in> {card ?rem - card ?add + 1 .. card ?rem}. inverse j) +
                        (\<Sum>j \<in> {card ?rem + 1 .. card (S k)}. inverse j)) * w k"
        unfolding lhs by argo
      also have "... = (\<Sum>j \<in> {card ?rem - card ?add + 1 .. card (S k)}. inverse j) * w k"
        proof -
          have sum_split: "b \<in> {a .. c} \<Longrightarrow> sum f {a .. c} = sum f {a .. b} + sum f {Suc b .. c}"
            for f :: "nat \<Rightarrow> real" and a b c :: nat
          proof -
            assume "b \<in> {a .. c}"
            then have "{a .. b} \<union> {Suc b .. c} = {a .. c}" by force
            moreover have "{a .. b} \<inter> {Suc b .. c} = {}"
              using \<open>b \<in> {a .. c}\<close> by auto
            ultimately show ?thesis by (metis finite_atLeastAtMost sum.union_disjoint)
          qed

          have "(\<Sum>j \<in> {card ?rem - card ?add + 1 .. card (S k)}. inverse j)
              = (\<Sum>j \<in> {card ?rem - card ?add + 1 .. card ?rem}. inverse j)
              + (\<Sum>j \<in> {card ?rem + 1 .. card (S k)}. inverse j)"
            proof (cases \<open>?add = {}\<close>)
              case False
              then have "0 < card ?add" "0 < card ?rem"
                using S_finite \<open>k \<in> _\<close> by fastforce+
              then have "Suc (card ?rem - card ?add) \<le> card ?rem" by simp
              moreover have "card ?rem \<le> card (S k)"
                using S_finite \<open>k \<in> _\<close> by (simp add: card_mono)
              ultimately show ?thesis by (auto intro: sum_split)
            qed simp
          then show ?thesis by algebra
        qed
      finally show "sum ?c (S k \<inter> (U - (R - S i)))
                 \<le> (\<Sum>j \<in> {card (S k \<inter> (R - S i)) + 1 .. card (S k)}. inverse j) * w k"
        unfolding rhs .
    qed

    from 1 2 3 show ?case by blast
  qed
qed

lemma cover_sum:
  fixes c :: "'a \<Rightarrow> real"
  assumes "sc C V" "\<forall>i. 0 \<le> c i"
  shows "sum c V \<le> (\<Sum>i \<in> C. sum c (S i))"
proof -
  from assms(1) have "finite C" by (auto simp: sc_def finite_subset)
  then show ?thesis using assms(1)
  proof (induction C arbitrary: V rule: finite_induct)
    case (insert i C)
    have V_split: "(\<Union> (S ` insert i C)) = (\<Union> (S ` C)) \<union> S i" by auto
    have finite: "finite (\<Union> (S ` C))" "finite (S i)"
      using insert S_finite by (auto simp: sc_def)

    have "sum c (S i) - sum c (\<Union> (S ` C) \<inter> S i) \<le> sum c (S i)"
      using assms(2) by (simp add: sum_nonneg)
    then have "sum c (\<Union> (S ` insert i C)) \<le> sum c (\<Union> (S ` C)) + sum c (S i)"
      unfolding V_split using sum_Un[OF finite, of c] by linarith
    moreover have "(\<Sum>i\<in>insert i C. sum c (S i)) = (\<Sum>i \<in> C. sum c (S i)) + sum c (S i)"
      by (simp add: insert.hyps)
    ultimately show ?case using insert by (fastforce simp: sc_def)
  qed (simp add: sc_def)
qed

abbreviation H :: "nat \<Rightarrow> real" where "H \<equiv> harm"

definition d_star :: nat ("d\<^sup>*") where "d\<^sup>* \<equiv> Max (card ` (S ` {1..m}))"

lemma set_cover_bound:
  assumes "inv C {}" "sc C' U"
  shows "sum w C \<le> H d\<^sup>* * sum w C'"
proof -
  from invD(3)[OF assms(1)] obtain c where
    "sum w C = sum c U" "\<forall>i. 0 \<le> c i" and H_bound:
    "\<forall>k \<in> {1..m}. sum c (S k) \<le> H (card (S k)) * w k" \<comment> \<open>Lemma 11.10\<close>
    by (auto simp: harm_def Int_absorb2 S_subset)

  have "\<forall>k \<in> {1..m}. card (S k) \<le> d\<^sup>*" by (auto simp: d_star_def)
  then have "\<forall>k \<in> {1..m}. H (card (S k)) \<le> H d\<^sup>*" by (auto simp: harm_def intro!: sum_mono2)
  with H_bound have "\<forall>k \<in> {1..m}. sum c (S k) \<le> H d\<^sup>* * w k"
    by (metis atLeastAtMost_iff atLeastatMost_empty_iff empty_iff mult_right_mono w_nonneg)
  moreover have "C' \<subseteq> {1..m}" using assms(2) by (simp add: sc_def)
  ultimately have "\<forall>i \<in> C'. sum c (S i) \<le> H d\<^sup>* * w i" by blast
  then have "(\<Sum>i \<in> C'. sum c (S i)) \<le> H d\<^sup>* * sum w C'"
    by (auto simp: sum_distrib_left intro: sum_mono)

  have "sum w C = sum c U" by fact \<comment> \<open>Lemma 11.9\<close>
  also have "... \<le> (\<Sum>i \<in> C'. sum c (S i))" by (rule cover_sum[OF assms(2)]) fact
  also have "... \<le> H d\<^sup>* * sum w C'" by fact
  finally show ?thesis .
qed

theorem set_cover_approx:
"VARS (R :: 'a set) (C :: nat set) (i :: nat)
  {True}
  R := U; C := {};
  WHILE R \<noteq> {} INV {inv C R} DO
  i := min_arg R m;
  R := R - S i;
  C := C \<union> {i}
  OD
  {sc C U \<and> (\<forall>C'. sc C' U \<longrightarrow> sum w C \<le> H d\<^sup>* * sum w C')}"
proof (vcg, goal_cases)
  case 1 show ?case by (rule inv_init)
next
  case 2 thus ?case using inv_step ..
next
  case (3 R C i)
  then have "sc C U" unfolding inv_def by auto
  with 3 show ?case by (auto intro: set_cover_bound)
qed

end (* Set Cover *)

end (* Theory *)


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory Padding
imports "~~/src/HOL/Main"
begin

definition padup :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "padup align n \<equiv> (align - n mod align) mod align"

lemma padup_dvd:
  "0 < b \<Longrightarrow> (padup b n = 0) = (b dvd n)"
apply(clarsimp simp: padup_def dvd_eq_mod_eq_0)
apply(subst mod_if [where m="b - n mod b"])
apply clarsimp
apply(insert mod_less_divisor [of b n])
apply arith
done

lemma mod_triv_le:
  "0 < n \<Longrightarrow> m mod (n::nat) \<le> m"
apply(case_tac "m < n")
 apply simp
apply(subgoal_tac "m mod n < n")
 apply arith
apply(erule mod_less_divisor)
done

lemma dvd_padup_add:
  "0 < x \<Longrightarrow> x dvd y + padup x y"
apply(clarsimp simp: padup_def)
apply(subst mod_if [where m="x - y mod x"])
apply(clarsimp split: split_if_asm)
apply(rule conjI)
 apply clarsimp
 apply(subst ac_simps)
 apply(subst diff_add_assoc)
  apply(rule mod_triv_le)
  apply simp
 apply(rule dvd_add)
  apply simp
 apply(subst mod_div_equality')
 apply(subst diff_diff_right)
  apply(subst ac_simps)
  apply(subst mult_div_cancel)
  apply simp
 apply simp
apply(auto simp: dvd_eq_mod_eq_0)
done

end


(*  Title:      HOL/ex/List_to_Set_Comprehension_Examples.thy
    Author:     Lukas Bulwahn
    Copyright   2011 TU Muenchen
*)

section \<open>Examples for the list comprehension to set comprehension simproc\<close>

theory List_to_Set_Comprehension_Examples
imports Main
begin

text \<open>
Examples that show and test the simproc that rewrites list comprehensions
applied to List.set to set comprehensions.
\<close>

subsection \<open>Some own examples for set (case ..) simpproc\<close>

lemma "set [(x, xs). x # xs <- as] = {(x, xs). x # xs \<in> set as}"
by auto

lemma "set [(x, y, ys). x # y # ys <- as] = {(x, y, ys). x # y # ys \<in> set as}"
by auto

lemma "set [(x, y, z, zs). x # y # z # zs <- as] = {(x, y, z, zs). x # y # z # zs \<in> set as}"
by auto

lemma "set [(zs, x, z, y). x # (y, z) # zs <- as] = {(zs, x, z, y). x # (y, z) # zs \<in> set as}"
by auto

lemma "set [(x, y). x # y <- zs, x = x'] = {(x, y). x # y \<in> set zs & x = x'}"
by auto

subsection \<open>Existing examples from the List theory\<close>

lemma "set [(x,y,z). b] = {(x', y', z'). x = x' & y = y' & z = z' & b}"
by auto

lemma "set [(x,y,z). x\<leftarrow>xs] = {(x, y', z'). x \<in> set xs & y' = y & z = z'}"
by auto

lemma "set [e x y. x\<leftarrow>xs, y\<leftarrow>ys] = {z. \<exists> x y. z = e x y & x \<in> set xs & y \<in> set ys}"
by auto

lemma "set [(x,y,z). x<a, x>b] = {(x', y', z'). x' = x & y' = y & z = z' & x < a & x>b}"
by auto

lemma "set [(x,y,z). x\<leftarrow>xs, x>b] = {(x', y', z'). y = y' & z = z' & x' \<in> set xs & x' > b}"
by auto

lemma "set [(x,y,z). x<a, x\<leftarrow>xs] = {(x', y', z'). y = y' & z = z' & x' \<in> set xs & x < a}"
by auto

lemma "set [(x,y). Cons True x \<leftarrow> xs] = {(x, y'). y = y' & Cons True x \<in> set xs}"
by auto

lemma "set [(x,y,z). Cons x [] \<leftarrow> xs] = {(x, y', z'). y = y' & z = z' & Cons x [] \<in> set xs}"
by auto

lemma "set [(x,y,z). x<a, x>b, x=d] = {(x', y', z'). x = x' & y = y' & z = z' & x < a & x > b & x = d}"
by auto

lemma "set [(x,y,z). x<a, x>b, y\<leftarrow>ys] = {(x', y, z'). x = x' & y \<in> set ys & z = z' & x < a & x > b}"
by auto

lemma "set [(x,y,z). x<a, x\<leftarrow>xs,y>b] = {(x',y',z'). x' \<in> set xs & y = y' & z = z' & x < a & y > b}"
by auto

lemma "set [(x,y,z). x<a, x\<leftarrow>xs, y\<leftarrow>ys] = {(x', y', z'). z = z' & x < a & x' \<in> set xs & y' \<in> set ys}"
by auto

lemma "set [(x,y,z). x\<leftarrow>xs, x>b, y<a] = {(x', y', z'). y = y' & z = z' & x' \<in> set xs & x' > b & y < a}"
by auto

lemma "set [(x,y,z). x\<leftarrow>xs, x>b, y\<leftarrow>ys] = {(x', y', z'). z = z' & x' \<in> set xs & x' > b & y' \<in> set ys}"
by auto

lemma "set [(x,y,z). x\<leftarrow>xs, y\<leftarrow>ys,y>x] = {(x', y', z'). z = z' & x' \<in> set xs & y' \<in> set ys & y' > x'}"
by auto

lemma "set [(x,y,z). x\<leftarrow>xs, y\<leftarrow>ys,z\<leftarrow>zs] = {(x', y', z'). x' \<in> set xs & y' \<in> set ys & z' \<in> set zs}"
by auto

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_list_nub_nub
  imports "../../Test_Base"
begin

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

fun filter :: "('a => bool) => 'a list => 'a list" where
  "filter p (nil2) = nil2"
| "filter p (cons2 y xs) =
     (if p y then cons2 y (filter p xs) else filter p xs)"

(*fun did not finish the proof*)
function nubBy :: "('a => ('a => bool)) => 'a list => 'a list" where
  "nubBy x (nil2) = nil2"
| "nubBy x (cons2 z xs) =
     cons2 z (nubBy x (filter (% (y2 :: 'a) => (~ ((x z) y2))) xs))"
  by pat_completeness auto

theorem property0 :
  "((nubBy
       (% (x :: 'a) => % (y :: 'a) => (x = y))
       (nubBy (% (z :: 'a) => % (x2 :: 'a) => (z = x2)) xs)) =
      (nubBy (% (x3 :: 'a) => % (x4 :: 'a) => (x3 = x4)) xs))"
  oops

end