theory Extended_OAG
imports Main  "~~/src/HOL/Algebra/Ring"  "~~/src/HOL/Algebra/Valued_Fields/Ordered_Abelian_Group"
begin

record 'a  extended_ordered_monoid = "'a ordered_monoid" +
  infinity :: 'a ("\<infinity>\<index>")

(* constructor for build an EOM out of an OM*)

fun extended_mult :: "('a, 'm) ordered_monoid_scheme \<Rightarrow> 'a option \<Rightarrow> 'a option \<Rightarrow> 'a option"
  where
"extended_mult G   None      None   = None"|
"extended_mult G  (Some a)   None   = None"|
"extended_mult G   None    (Some a) = None"|
"extended_mult G  (Some a) (Some b) = Some (a \<otimes>\<^bsub>G\<^esub>b)"

fun extended_order :: "('a, 'm) ordered_monoid_scheme \<Rightarrow> 'a option \<Rightarrow> 'a option \<Rightarrow> bool"
  where
"extended_order G  None      None    = True"|
"extended_order G (Some a)   None    = True"|
"extended_order G  None     (Some a) = False"|
"extended_order G (Some a)  (Some b) = (a \<preceq>\<^bsub>G\<^esub> b)"

abbreviation
extended:: "('a, 'm) ordered_monoid_scheme \<Rightarrow> ('a option, 'm)  extended_ordered_monoid_scheme" where
"extended G \<equiv> \<lparr> carrier = (Some ` (carrier G)), mult = extended_mult G, one = Some (one G), le = extended_order G, infinity = None, \<dots> = (undefined :: 'm)\<rparr>   "

(*outlines the arithmetic of adding infinity to an ordered abelian group*)

abbreviation
vals:: "('a, 'm)  extended_ordered_monoid_scheme \<Rightarrow> 'a set"
where "vals G \<equiv> carrier G \<union> {\<infinity>\<^bsub>G\<^esub>}"

locale extended_ordered_abelian_group = "ordered_abelian_group" +
  assumes infinity_distinct: "\<infinity>\<^bsub>G\<^esub> \<notin> carrier G"
  assumes infinity_max1: " x \<in> carrier G \<Longrightarrow> le G x \<infinity>\<^bsub>G\<^esub>"
  assumes infinity_max2: " x \<in> carrier G \<Longrightarrow> \<not> le G \<infinity>\<^bsub>G\<^esub> x"
  assumes infinity_infinity: "le G \<infinity>\<^bsub>G\<^esub> \<infinity>\<^bsub>G\<^esub>"
  assumes infinity_plus_right: "x \<in> carrier G \<Longrightarrow> (x \<otimes>\<^bsub>G\<^esub> \<infinity>\<^bsub>G\<^esub>) =  \<infinity>\<^bsub>G\<^esub>"
  assumes infinity_plus_left: "x \<in> carrier G \<Longrightarrow> ( \<infinity>\<^bsub>G\<^esub> \<otimes>\<^bsub>G\<^esub> x) =  \<infinity>\<^bsub>G\<^esub>"
  assumes infinity_plus_infinity: "( \<infinity>\<^bsub>G\<^esub> \<otimes>\<^bsub>G\<^esub> \<infinity>\<^bsub>G\<^esub> ) =  \<infinity>\<^bsub>G\<^esub>"

lemma (in ordered_abelian_group) extended_is_eoag:
"extended_ordered_abelian_group (extended G)"
proof
  show "\<And>x y. x \<in> carrier (extended G)   \<Longrightarrow> y \<in> carrier (extended G) \<Longrightarrow> x \<otimes>\<^bsub>extended G\<^esub> y \<in> carrier (extended G)"
    using ab comm_groupE(1) by fastforce
  show "\<And>x y z.
       x \<in> carrier (extended G) \<Longrightarrow>
       y \<in> carrier (extended G) \<Longrightarrow>
       z \<in> carrier (extended G) \<Longrightarrow>
       x \<otimes>\<^bsub>extended G\<^esub> y \<otimes>\<^bsub>extended G\<^esub> z = x \<otimes>\<^bsub>extended G\<^esub> (y \<otimes>\<^bsub>extended G\<^esub> z)"
    using ab comm_groupE(3) by fastforce
  show "\<one>\<^bsub>extended G\<^esub> \<in> carrier (extended G)"
    by (simp add: one_in)
  show "\<And>x. x \<in> carrier (extended G) \<Longrightarrow> \<one>\<^bsub>extended G\<^esub> \<otimes>\<^bsub>extended G\<^esub> x = x"
    using a_monoid by auto
  show "\<And>x. x \<in> carrier (extended G) \<Longrightarrow> x \<otimes>\<^bsub>extended G\<^esub> \<one>\<^bsub>extended G\<^esub> = x"
    using a_monoid by auto
  show "\<And>x. x \<in> carrier (underlying_order (extended G)) \<Longrightarrow> x .=\<^bsub>underlying_order (extended G)\<^esub> x"
    by simp
  show " \<And>x y. x .=\<^bsub>underlying_order (extended G)\<^esub> y \<Longrightarrow>
           x \<in> carrier (underlying_order (extended G)) \<Longrightarrow>
           y \<in> carrier (underlying_order (extended G)) \<Longrightarrow>
          y .=\<^bsub>underlying_order (extended G)\<^esub> x"
    by simp
  show "\<And>x y z.
       x .=\<^bsub>underlying_order (extended G)\<^esub> y \<Longrightarrow>
       y .=\<^bsub>underlying_order (extended G)\<^esub> z \<Longrightarrow>
       x \<in> carrier (underlying_order (extended G)) \<Longrightarrow>
       y \<in> carrier (underlying_order (extended G)) \<Longrightarrow>
        z \<in> carrier (underlying_order (extended G)) \<Longrightarrow>
      x .=\<^bsub>underlying_order (extended G)\<^esub> z"
    by simp
  show "\<And> x. x \<in> carrier (underlying_order (extended G)) \<Longrightarrow> x \<sqsubseteq>\<^bsub>underlying_order (extended G)\<^esub> x"
    using an_order has_order.an_order total_order.total_order_total by fastforce
  show "\<And>x y. x \<sqsubseteq>\<^bsub>underlying_order (extended G)\<^esub> y \<Longrightarrow>
           y \<sqsubseteq>\<^bsub>underlying_order (extended G)\<^esub> x \<Longrightarrow>
           x \<in> carrier (underlying_order (extended G)) \<Longrightarrow>
           y \<in> carrier (underlying_order (extended G)) \<Longrightarrow>
           x .=\<^bsub>underlying_order (extended G)\<^esub> y"
    using an_order has_order.an_order
      partial_order.le_antisym total_order.axioms(1) by fastforce
  show " \<And>x y z.
     x \<sqsubseteq>\<^bsub>underlying_order (extended G)\<^esub> y \<Longrightarrow>
     y \<sqsubseteq>\<^bsub>underlying_order (extended G)\<^esub> z \<Longrightarrow>
     x \<in> carrier (underlying_order (extended G)) \<Longrightarrow>
     y \<in> carrier (underlying_order (extended G)) \<Longrightarrow>
     z \<in> carrier (underlying_order (extended G)) \<Longrightarrow>
     x \<sqsubseteq>\<^bsub>underlying_order (extended G)\<^esub> z"
  proof-
    fix x y z
    assume 0: "x \<sqsubseteq>\<^bsub>underlying_order (extended G)\<^esub> y"
    assume 1: "y \<sqsubseteq>\<^bsub>underlying_order (extended G)\<^esub> z"
    assume 2: "x \<in> carrier (underlying_order (extended G))"
    assume 3: "y \<in> carrier (underlying_order (extended G))"
    assume 4: "z \<in> carrier (underlying_order (extended G))"
    show "x \<sqsubseteq>\<^bsub>underlying_order (extended G)\<^esub> z"
    proof-
      obtain a where "x = Some a"
        using "2" by auto
      obtain b where "y = Some b"
        using "3" by auto
      obtain c where "z = Some c"
        using "4" by auto
      have 5: "a \<sqsubseteq>\<^bsub>underlying_order (G)\<^esub>b"
        using "0" \<open>x = Some a\<close> \<open>y = Some b\<close> by auto
      have 6: "b \<sqsubseteq>\<^bsub>underlying_order (G)\<^esub>c"
        using "1" \<open>y = Some b\<close> \<open>z = Some c\<close> by auto
      have 7: "a \<sqsubseteq>\<^bsub>underlying_order (G)\<^esub>c" using 5 6 an_order
        by (smt "2" "3" "4" \<open>x = Some a\<close> \<open>y = Some b\<close> \<open>z = Some c\<close> has_order.an_order
            image_iff option.sel partial_object.select_convs(1) partial_order_def
            total_order.axioms(1) weak_partial_order.le_trans)
      then show ?thesis
        by (simp add: \<open>x = Some a\<close> \<open>z = Some c\<close>)
    qed
  qed
  show "\<And>x y z w.
       x .=\<^bsub>underlying_order (extended G)\<^esub> y \<Longrightarrow>
       z .=\<^bsub>underlying_order (extended G)\<^esub> w \<Longrightarrow>
       x \<in> carrier (underlying_order (extended G)) \<Longrightarrow>
       y \<in> carrier (underlying_order (extended G)) \<Longrightarrow>
       z \<in> carrier (underlying_order (extended G)) \<Longrightarrow>
       w \<in> carrier (underlying_order (extended G)) \<Longrightarrow>
      (x \<sqsubseteq>\<^bsub>underlying_order (extended G)\<^esub> z) = (y \<sqsubseteq>\<^bsub>underlying_order (extended G)\<^esub> w)"
    by simp
  show "(.=\<^bsub>underlying_order (extended G)\<^esub>) = (=)" by simp
  show " \<And>x y. x \<in> carrier (underlying_order (extended G)) \<Longrightarrow>
           y \<in> carrier (underlying_order (extended G)) \<Longrightarrow>
          x \<sqsubseteq>\<^bsub>underlying_order (extended G)\<^esub> y \<or> y \<sqsubseteq>\<^bsub>underlying_order (extended G)\<^esub> x"
    by (smt None_notin_image_Some an_order extended_order.elims(3)
        gorder.select_convs(1) has_order.an_order image_iff option.inject
        ordered_monoid.simps(1) partial_object.select_convs(1) total_order.total_order_total)
  have "le_resp_mult G"
    using ordered_monoid_axioms ordered_monoid_def by auto
  then show " \<And>a b c.
       a \<in> carrier (extended G) \<Longrightarrow>
       b \<in> carrier (extended G) \<Longrightarrow>
       a \<preceq>\<^bsub>extended G\<^esub> b \<Longrightarrow>
       c \<in> carrier (extended G) \<Longrightarrow>
       a \<otimes>\<^bsub>extended G\<^esub> c \<preceq>\<^bsub>extended G\<^esub> b \<otimes>\<^bsub>extended G\<^esub> c"
    using None_notin_image_Some le_resp_mult_def by fastforce
  show "\<And>x y. x \<in> carrier (extended G) \<Longrightarrow>
        y \<in> carrier (extended G) \<Longrightarrow>
        x \<otimes>\<^bsub>extended G\<^esub> y = y \<otimes>\<^bsub>extended G\<^esub> x"
    using ab comm_groupE(4) by fastforce
  show "carrier (extended G) \<subseteq> Units (extended G)"
    proof fix x assume "x \<in> carrier (extended G)"
      obtain a where "x = Some a"
        using \<open>x \<in> carrier (extended G)\<close> by auto
      obtain b where "b = inv a"
        by simp
      have "Some b \<otimes>\<^bsub>extended G\<^esub> x = \<one>\<^bsub>extended G\<^esub>"
        using \<open>b = inv a\<close> \<open>x = Some a\<close> \<open>x \<in> carrier (extended G)\<close>
          ab comm_group.axioms(2) group.l_inv by fastforce
      then show "x \<in> Units (extended G)" using Units_def
        by (smt \<open>\<And>y x. \<lbrakk>x \<in> carrier (extended G); y \<in> carrier (extended G)\<rbrakk>
              \<Longrightarrow> x \<otimes>\<^bsub>extended G\<^esub> y = y \<otimes>\<^bsub>extended G\<^esub> x\<close> \<open>b = inv a\<close>
            \<open>x = Some a\<close> \<open>x \<in> carrier (extended G)\<close> ab comm_group.axioms(2)
            group.inv_closed in_these_eq mem_Collect_eq partial_object.select_convs(1)
            these_image_Some_eq)
    qed
  show "\<infinity>\<^bsub>extended G\<^esub> \<notin> carrier (extended G)"
    by simp
  show "\<And>x. x \<in> carrier (extended G) \<Longrightarrow> x \<preceq>\<^bsub>extended G\<^esub> \<infinity>\<^bsub>extended G\<^esub>"
    by auto
  show "\<And>x. x \<in> carrier (extended G) \<Longrightarrow> \<not> \<infinity>\<^bsub>extended G\<^esub> \<preceq>\<^bsub>extended G\<^esub> x"
    by auto
  show "\<infinity>\<^bsub>extended G\<^esub> \<preceq>\<^bsub>extended G\<^esub> \<infinity>\<^bsub>extended G\<^esub>"
    by simp
  show "\<And>x. x \<in> carrier (extended G) \<Longrightarrow> x \<otimes>\<^bsub>extended G\<^esub> \<infinity>\<^bsub>extended G\<^esub> = \<infinity>\<^bsub>extended G\<^esub>"
    by auto
  show "\<And>x. x \<in> carrier (extended G) \<Longrightarrow> \<infinity>\<^bsub>extended G\<^esub> \<otimes>\<^bsub>extended G\<^esub> x = \<infinity>\<^bsub>extended G\<^esub>"
    by auto
  show "\<infinity>\<^bsub>extended G\<^esub> \<otimes>\<^bsub>extended G\<^esub> \<infinity>\<^bsub>extended G\<^esub> = \<infinity>\<^bsub>extended G\<^esub>"
    by simp
qed

lemma (in extended_ordered_abelian_group) add_infinityR:
  assumes "x \<in> carrier G \<or> x = \<infinity>\<^bsub>G\<^esub>"
  shows " (x \<otimes>\<^bsub>G\<^esub> \<infinity>\<^bsub>G\<^esub>) =  \<infinity>\<^bsub>G\<^esub>"
proof (cases  "x = \<infinity>\<^bsub>G\<^esub>")
  case True
  then show " (x \<otimes>\<^bsub>G\<^esub> \<infinity>\<^bsub>G\<^esub>) =  \<infinity>\<^bsub>G\<^esub>" using infinity_plus_infinity by auto
next
  case False
  then show " (x \<otimes>\<^bsub>G\<^esub> \<infinity>\<^bsub>G\<^esub>) =  \<infinity>\<^bsub>G\<^esub>" using infinity_plus_right using assms by blast
qed

lemma (in extended_ordered_abelian_group) add_infinityL:
  assumes "x \<in> carrier G \<or> x = \<infinity>\<^bsub>G\<^esub>"
  shows " ( \<infinity>\<^bsub>G\<^esub> \<otimes>\<^bsub>G\<^esub> x) =  \<infinity>\<^bsub>G\<^esub>"
proof (cases  "x = \<infinity>\<^bsub>G\<^esub>")
  case True
  then show "  \<infinity>\<^bsub>G\<^esub> \<otimes>\<^bsub>G\<^esub> x =  \<infinity>\<^bsub>G\<^esub>" using infinity_plus_infinity by auto
  next
  case False
  then show " \<infinity>\<^bsub>G\<^esub> \<otimes>\<^bsub>G\<^esub> x =  \<infinity>\<^bsub>G\<^esub>" using infinity_plus_left using assms by blast
  qed

lemma (in extended_ordered_abelian_group) add_infinityOR:
  assumes "x \<in> vals G"
  assumes "y \<in> vals G"
  assumes "x = \<infinity> \<or> y = \<infinity>"
  shows " (x \<otimes>\<^bsub>G\<^esub> y) =  \<infinity>\<^bsub>G\<^esub>"
  using add_infinityL add_infinityR assms(1) assms(2) assms(3) by blast

(* The minimum function. Maybe makes more sense to add this elsewhere? We'll see.*)

abbreviation Min :: "[ ('a, 'm) extended_ordered_monoid_scheme, 'a, 'a] \<Rightarrow> 'a " ("Min\<index>")
  where "Min\<^bsub>G\<^esub>  x y \<equiv> (if (le G x y) then x else y)"

lemma (in extended_ordered_abelian_group) no_idempotents:
  assumes "x \<in> vals G"
  assumes "x \<otimes> x = \<one>"
  shows "x = \<one>"
  using add_infinityOR assms(1) assms(2) no_idempotents1 by auto

(*forgetful functor to get the underlying order of an extended ordered monoid*)
abbreviation
  e_underlying_order :: "('a, 'm) extended_ordered_monoid_scheme \<Rightarrow> ('a, 'm) gorder_scheme" ("Order\<index>")
  where "e_underlying_order G \<equiv> \<lparr>carrier = carrier G \<union> {\<infinity>\<^bsub>G\<^esub>}, eq = (=), gorder.le = le G
, \<dots> = (undefined:: 'm) \<rparr>"

lemma  (in extended_ordered_abelian_group) e_is_equals:
"eq (e_underlying_order G) = (=)" by auto

lemma (in extended_ordered_abelian_group) EOAG_is_equivalence:
  "equivalence (e_underlying_order G)"
  using e_is_equals  by (simp add: equivalence_def)

lemma (in extended_ordered_abelian_group) EOAG_is_pOrdered0:
  "weak_partial_order Order\<^bsub>G\<^esub>"
proof
  show "\<And>x. x \<in> carrier Order\<^bsub>G\<^esub>  \<Longrightarrow> x \<sqsubseteq>\<^bsub>Order\<^bsub>G\<^esub> \<^esub> x"
    using an_order has_order.an_order infinity_infinity
      total_order.total_order_total by fastforce
  show "\<And>x y. x \<sqsubseteq>\<^bsub>Order\<^bsub>G\<^esub> \<^esub> y \<Longrightarrow>
           y \<sqsubseteq>\<^bsub>Order\<^bsub>G\<^esub>\<^esub> x \<Longrightarrow>
           x \<in> carrier Order\<^bsub>G\<^esub> \<Longrightarrow>
           y \<in> carrier Order\<^bsub>G\<^esub> \<Longrightarrow> x .=\<^bsub>Order\<^bsub>G\<^esub>\<^esub> y"
  proof-
    fix x y
    assume 0:"x \<sqsubseteq>\<^bsub>Order\<^bsub>G\<^esub> \<^esub> y"
    assume 1:"y \<sqsubseteq>\<^bsub>Order\<^bsub>G\<^esub>\<^esub> x"
    assume 2:"x \<in> carrier Order\<^bsub>G\<^esub>"
    assume 3:"y \<in> carrier Order\<^bsub>G\<^esub>"
    then show "x .=\<^bsub>Order\<^bsub>G\<^esub>\<^esub> y"
    proof(cases "x = infinity G")
      case True
      then show ?thesis
        using "0" "3" infinity_max2 by auto
      next
        case False
        then have "y \<noteq> infinity G"
          using "1" "2" infinity_max2 by auto
        then have "x \<in>carrier G" and "y \<in> carrier G"
          using "2" False apply auto[1] using "3" \<open>y \<noteq> \<infinity>\<close> by auto
        then have "x = y"
          using an_order has_order.an_order total_order.total_order_total
            e_is_equals  "0" "1" partial_order.le_antisym total_order.axioms(1) by fastforce
        then show ?thesis using e_is_equals  by simp
      qed
    qed
  show "\<And>x y z.
       x \<sqsubseteq>\<^bsub>Order\<^bsub>G\<^esub> \<^esub> y \<Longrightarrow>
       y \<sqsubseteq>\<^bsub>Order\<^bsub>G\<^esub> \<^esub> z \<Longrightarrow>
       x \<in> carrier Order\<^bsub>G\<^esub> \<Longrightarrow>
       y \<in> carrier Order\<^bsub>G\<^esub> \<Longrightarrow>
       z \<in> carrier Order\<^bsub>G\<^esub> \<Longrightarrow> x \<sqsubseteq>\<^bsub>Order\<^bsub>G\<^esub> \<^esub> z"
    by (smt Un_insert_right an_order gorder.simps(1) has_order.an_order
        infinity_max1 infinity_max2 insert_iff partial_object.select_convs(1)
        partial_order_def sup_bot.comm_neutral total_order.axioms(1)
        weak_partial_order.le_trans)
  show "\<And>x y z w.
       x .=\<^bsub>Order\<^bsub>G\<^esub>\<^esub> y \<Longrightarrow>
       z .=\<^bsub>Order\<^bsub>G\<^esub>\<^esub> w \<Longrightarrow>
       x \<in> carrier Order\<^bsub>G\<^esub> \<Longrightarrow>
       y \<in> carrier Order\<^bsub>G\<^esub> \<Longrightarrow>
       z \<in> carrier Order\<^bsub>G\<^esub> \<Longrightarrow>
       w \<in> carrier Order\<^bsub>G\<^esub> \<Longrightarrow>
       (x \<sqsubseteq>\<^bsub>Order\<^bsub>G\<^esub>\<^esub> z) = (y \<sqsubseteq>\<^bsub>Order\<^bsub>G\<^esub>\<^esub> w)"
    by simp
  show "\<And>x. x \<in> carrier Order\<^bsub>G\<^esub>  \<Longrightarrow> x .=\<^bsub>Order \<^bsub>G\<^esub> \<^esub> x"
    by simp
  show "\<And>x y. x .=\<^bsub>Order\<^bsub>G\<^esub> \<^esub> y \<Longrightarrow>
           x \<in> carrier Order\<^bsub>G\<^esub>  \<Longrightarrow>
           y \<in> carrier Order\<^bsub>G\<^esub>  \<Longrightarrow> y .=\<^bsub>Order\<^bsub>G\<^esub> \<^esub> x"
    by simp
  show "\<And>x y z.
       x .=\<^bsub>Order\<^bsub>G\<^esub>\<^esub> y \<Longrightarrow>
       y .=\<^bsub>Order\<^bsub>G\<^esub>\<^esub> z \<Longrightarrow>
       x \<in> carrier Order\<^bsub>G\<^esub> \<Longrightarrow>
       y \<in> carrier Order\<^bsub>G\<^esub> \<Longrightarrow>
       z \<in> carrier Order\<^bsub>G\<^esub> \<Longrightarrow> x .=\<^bsub>Order\<^bsub>G\<^esub>\<^esub> z"
    by simp
qed

lemma (in extended_ordered_abelian_group) EOAG_is_pOrdered:
  "partial_order (e_underlying_order G)"
  using EOAG_is_pOrdered0  e_is_equals partial_order.intro partial_order_axioms.intro by blast

lemma (in extended_ordered_abelian_group) EOAG_is_ordered0:
 " \<lbrakk>x \<in> carrier (e_underlying_order G); y \<in> carrier (e_underlying_order G)\<rbrakk>
           \<Longrightarrow> x \<sqsubseteq>\<^bsub>e_underlying_order G\<^esub> y \<or> y \<sqsubseteq>\<^bsub>e_underlying_order G\<^esub> x"
  using  EOAG_is_pOrdered
  by (metis EOAG_is_equivalence EOAG_is_pOrdered0
      Un_insert_right an_order equivalence.refl
      gorder.select_convs(1) has_order.an_order
      infinity_max1 insertE partial_object.select_convs(1)
      sup_bot.right_neutral total_order.total_order_total
      weak_partial_order.weak_refl)

lemma (in extended_ordered_abelian_group) EOAG_is_ordered:
  "total_order (e_underlying_order G)"
using EOAG_is_ordered0 EOAG_is_pOrdered partial_order.total_orderI by blast

lemma (in extended_ordered_abelian_group) refl:
  assumes "x \<in> carrier G \<union> {\<infinity>}"
  shows "x \<preceq>\<^bsub>G\<^esub> x"
  using assms EOAG_is_ordered0 by auto

lemma (in extended_ordered_abelian_group) trans:
  assumes "x \<in> carrier G \<union> {\<infinity>}"
  assumes "y \<in> carrier G \<union> {\<infinity>}"
  assumes "z \<in> carrier G \<union> {\<infinity>}"
  assumes "x \<preceq>\<^bsub>G\<^esub> y"
  assumes "y \<preceq>\<^bsub>G\<^esub> z"
shows "x \<preceq>\<^bsub>G\<^esub> z"
  using assms(1) assms(2) assms(3) assms(4) assms(5)
      extended_ordered_abelian_group.EOAG_is_pOrdered
      extended_ordered_abelian_group_axioms
      gorder.select_convs(1) partial_object.select_convs(1)
      partial_order_def weak_partial_order.le_trans
       by smt

lemma (in extended_ordered_abelian_group) anti_symm:
  assumes "x \<in> carrier G \<union> {\<infinity>}"
  assumes "y \<in> carrier G \<union> {\<infinity>}"
  assumes "x \<preceq>\<^bsub>G\<^esub> y"
  assumes "y \<preceq>\<^bsub>G\<^esub> x"
  shows "x = y"
 using assms(1) assms(2) assms(3)
    assms(4) extended_ordered_abelian_group.EOAG_is_pOrdered
    extended_ordered_abelian_group_axioms
    partial_order.le_antisym by fastforce

lemma (in extended_ordered_abelian_group) E_le_resp_mult:
assumes   "a \<in> carrier G \<union> {\<infinity>}"
assumes "b \<in> carrier G \<union> {\<infinity>}"
assumes "le G a b"
assumes "c \<in> carrier G\<union> {\<infinity>}"
shows   "((le G)(a\<otimes>\<^bsub>G\<^esub>c) (b\<otimes>\<^bsub>G\<^esub>c))"
proof (cases "a = \<infinity> \<or> b = \<infinity>")
  case True
  then show "((le G)(a\<otimes>\<^bsub>G\<^esub>c) (b\<otimes>\<^bsub>G\<^esub>c))"
  proof (cases "a = \<infinity>")
    case True
    then have "b = \<infinity>"
    using assms(2) assms(3) infinity_max2 by auto
    then show "((le G)(a\<otimes>\<^bsub>G\<^esub>c) (b\<otimes>\<^bsub>G\<^esub>c))"
    using True assms(3) assms(4) infinity_plus_infinity infinity_plus_left by auto
  next
    case False
    then have "b = \<infinity>"
    using True by auto
    from this show "((le G)(a\<otimes>\<^bsub>G\<^esub>c) (b\<otimes>\<^bsub>G\<^esub>c))"
      using a_monoid assms(1) assms(4) infinity_infinity
        infinity_max1 infinity_plus_infinity infinity_plus_left
        infinity_plus_right monoid.m_closed by force
  qed
next
  case False
  then show "((le G)(a\<otimes>\<^bsub>G\<^esub>c) (b\<otimes>\<^bsub>G\<^esub>c))"
    using assms(1) assms(2) assms(3) assms(4)
      infinity_infinity infinity_plus_right ordered_monoid_axioms
      ab comm_groupE(4) le_resp_mult1 by fastforce

qed

lemma (in extended_ordered_abelian_group) mult_closed:
assumes   "a \<in> carrier G \<union> {\<infinity>}"
assumes "b \<in> carrier G \<union> {\<infinity>}"
shows "a \<otimes>\<^bsub>G\<^esub> b \<in> carrier G \<union> {\<infinity>\<^bsub>G\<^esub>}"
proof
  assume "a \<otimes> b \<notin> {\<infinity>}"
  show "a \<otimes> b \<in> carrier G "
    using \<open>a \<otimes> b \<notin> {\<infinity>}\<close> a_monoid assms(1) assms(2) infinity_plus_infinity
      infinity_plus_left infinity_plus_right monoid.m_closed by force
qed

lemma (in extended_ordered_abelian_group) E_le_resp_mult2:
assumes "a \<in> carrier G \<union> {\<infinity>}"
assumes "b \<in> carrier G \<union> {\<infinity>}"
assumes "c \<in> carrier G \<union> {\<infinity>}"
assumes "d \<in> carrier G \<union> {\<infinity>}"
assumes "le G a b"
assumes "le G c d"
shows  "((le G)(a\<otimes>\<^bsub>G\<^esub>c) (b\<otimes>\<^bsub>G\<^esub>d))"
proof-
  from E_le_resp_mult have 1: "((le G)(a\<otimes>\<^bsub>G\<^esub>c) (b\<otimes>\<^bsub>G\<^esub>c))"
  using assms(1) assms(2) assms(3) assms(5) by blast
  from E_le_resp_mult have 2: "((le G)(b\<otimes>\<^bsub>G\<^esub>c) (b\<otimes>\<^bsub>G\<^esub>d))"
  by (metis (no_types, lifting) Un_insert_right assms(2) assms(3) assms(4) assms(6) extended_ordered_abelian_group.infinity_max2 extended_ordered_abelian_group_axioms infinity_max1 infinity_plus_left infinity_plus_right insertE le_resp_mult1 sup_bot.right_neutral)
  from 1 and 2 show "((le G)(a\<otimes>\<^bsub>G\<^esub>c) (b\<otimes>\<^bsub>G\<^esub>d))"
  by (metis (no_types, lifting) assms(1) assms(2) assms(3) assms(4) extended_ordered_abelian_group.EOAG_is_pOrdered extended_ordered_abelian_group_axioms gorder.simps(1) mult_closed partial_object.select_convs(1) partial_order_def weak_partial_order.le_trans)
qed

lemma (in extended_ordered_abelian_group) chain:
assumes "a \<in> carrier G \<union> {\<infinity>}"
assumes "b \<in> carrier G \<union> {\<infinity>}"
assumes "c \<in> carrier G \<union> {\<infinity>}"
assumes "le G a b"
assumes "le G b c"
assumes "a \<noteq> b"
shows "a \<noteq> c"
proof
  assume "a = c"
  then have "a = b"
  using assms(1) assms(2) assms(4) assms(5) extended_ordered_abelian_group.EOAG_is_pOrdered extended_ordered_abelian_group_axioms partial_order.le_antisym by fastforce
  from this and assms(6) show False by auto
qed
end


theory bin_times_assoc
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Bin = One | ZeroAnd "Bin" | OneAnd "Bin"

fun s :: "Bin => Bin" where
"s (One) = ZeroAnd One"
| "s (ZeroAnd xs) = OneAnd xs"
| "s (OneAnd ys) = ZeroAnd (s ys)"

fun plus :: "Bin => Bin => Bin" where
"plus (One) y = s y"
| "plus (ZeroAnd z) (One) = s (ZeroAnd z)"
| "plus (ZeroAnd z) (ZeroAnd ys) = ZeroAnd (plus z ys)"
| "plus (ZeroAnd z) (OneAnd xs) = OneAnd (plus z xs)"
| "plus (OneAnd x2) (One) = s (OneAnd x2)"
| "plus (OneAnd x2) (ZeroAnd zs) = OneAnd (plus x2 zs)"
| "plus (OneAnd x2) (OneAnd ys2) = ZeroAnd (s (plus x2 ys2))"

fun times :: "Bin => Bin => Bin" where
"times (One) y = y"
| "times (ZeroAnd xs) y = ZeroAnd (times xs y)"
| "times (OneAnd ys) y = plus (ZeroAnd (times ys y)) y"

(*hipster s plus times *)

theorem x0 :
  "!! (x :: Bin) (y :: Bin) (z :: Bin) .
     (times x (times y z)) = (times (times x y) z)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

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.*)
  theory TIP_nat_acc_plus_assoc
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun accplus :: "Nat => Nat => Nat" where
"accplus (Z) y = y"
| "accplus (S z) y = accplus z (S y)"

theorem property0 :
  "((accplus x (accplus y z)) = (accplus (accplus x y) z))"
  oops

end


theory Desargues_3D
  imports Main Higher_Projective_Space_Rank_Axioms Matroid_Rank_Properties
begin

(* Author: Anthony Bordg, University of Cambridge, apdb3@cam.ac.uk .*)

text \<open>
Contents:
\<^item> We prove Desargues's theorem: if two triangles ABC and A'B'C' are perspective from a point P (ie.
the lines AA', BB' and CC' are concurrent in P), then they are perspective from a line (ie. the points
\<alpha> = BC \<inter> B'C', \<beta> = AC \<inter> A'C' and \<gamma> = AB \<inter> A'B' are collinear).
In this file we restrict ourself to the case where the two triangles ABC and A'B'C' are not coplanar.
\<close>

section \<open>Desargues's Theorem: The Non-coplanar Case\<close>

definition desargues_config_3D ::
  "[Points, Points, Points, Points, Points, Points, Points, Points, Points, Points] => bool"
  where "desargues_config_3D A B C A' B' C' P \<alpha> \<beta> \<gamma> \<equiv> rk {A, B, C} = 3 \<and> rk {A', B', C'} = 3 \<and>
rk {A, A', P} = 2 \<and> rk {B, B', P} = 2 \<and> rk {C, C', P} = 2 \<and> rk {A, B, C, A', B', C'} \<ge> 4 \<and>
rk {B, C, \<alpha>} = 2 \<and> rk {B', C', \<alpha>} = 2 \<and> rk {A, C, \<beta>} = 2 \<and> rk {A', C', \<beta>} = 2 \<and> rk {A, B, \<gamma>} = 2 \<and>
rk {A', B', \<gamma>} = 2"

lemma coplanar_4 :
  assumes "rk {A, B, C} = 3" and "rk {B, C, \<alpha>} = 2"
  shows "rk {A, B, C, \<alpha>} = 3"
proof-
  have f1:"rk {A, B, C, \<alpha>} \<ge> 3"
    using matroid_ax_2
    by (metis assms(1) empty_subsetI insert_mono)
  have "rk {A, B, C, \<alpha>} + rk {B, C} \<le> rk {A, B, C} + rk {B, C, \<alpha>}"
    using matroid_ax_3_alt
    by (metis Un_insert_right add_One_commute add_mono assms(1) assms(2) matroid_ax_2_alt
        nat_1_add_1 numeral_plus_one rk_singleton semiring_norm(3) sup_bot.right_neutral)
  then have f2:"rk {A, B, C, \<alpha>} \<le> 3"
    by (metis Un_insert_right add_One_commute assms(2) matroid_ax_2_alt numeral_plus_one
        semiring_norm(3) sup_bot.right_neutral)
  from f1 and f2 show "rk {A, B, C, \<alpha>} = 3"
    by auto
qed

lemma desargues_config_3D_coplanar_4 :
  assumes "desargues_config_3D A B C A' B' C' P \<alpha> \<beta> \<gamma>"
  shows "rk {A, B, C, \<alpha>} = 3" and "rk {A', B', C', \<alpha>} = 3"
proof-
  show "rk {A, B, C, \<alpha>} = 3"
    using assms desargues_config_3D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] coplanar_4
    by blast
  show "rk {A', B', C', \<alpha>} = 3"
    using assms desargues_config_3D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] coplanar_4
    by blast
qed

lemma coplanar_4_bis :
  assumes "rk {A, B, C} = 3" and "rk {A, C, \<beta>} = 2"
  shows "rk {A, B, C, \<beta>} = 3"
  by (smt assms(1) assms(2) coplanar_4 insert_commute)

lemma desargues_config_3D_coplanar_4_bis :
  assumes "desargues_config_3D A B C A' B' C' P \<alpha> \<beta> \<gamma>"
  shows "rk {A, B, C, \<beta>} = 3" and "rk {A', B', C', \<beta>} = 3"
proof-
  show "rk {A, B, C, \<beta>} = 3"
    using assms desargues_config_3D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] coplanar_4_bis
    by auto
  show "rk {A', B', C', \<beta>} = 3"
    using assms desargues_config_3D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] coplanar_4_bis
    by auto
qed

lemma coplanar_4_ter :
  assumes "rk {A, B, C} = 3" and "rk {A, B, \<gamma>} = 2"
  shows "rk {A, B, C, \<gamma>} = 3"
  by (smt assms(1) assms(2) coplanar_4 insert_commute)

lemma desargues_config_3D_coplanar_4_ter :
  assumes "desargues_config_3D A B C A' B' C' P \<alpha> \<beta> \<gamma>"
  shows "rk {A, B, C, \<gamma>} = 3" and "rk {A', B', C', \<gamma>} = 3"
proof-
  show "rk {A, B, C, \<gamma>} = 3"
    using assms desargues_config_3D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] coplanar_4_ter
    by auto
  show "rk {A', B', C', \<gamma>} = 3"
    using assms desargues_config_3D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] coplanar_4_ter
    by auto
qed

lemma coplanar_5 :
  assumes "rk {A, B, C} = 3" and "rk {B, C, \<alpha>} = 2" and "rk {A, C, \<beta>} = 2"
  shows "rk {A, B, C, \<alpha>, \<beta>} = 3"
proof-
  have f1:"rk {A, B, C, \<alpha>} = 3"
    using coplanar_4
    by (smt One_nat_def Un_assoc Un_commute add.commute add_Suc_right assms(1) assms(2) insert_is_Un
        le_antisym matroid_ax_2_alt numeral_2_eq_2 numeral_3_eq_3 one_add_one)
  have f2:"rk {A, B, C, \<beta>} = 3"
    using coplanar_4_bis
    by (smt One_nat_def Un_assoc Un_commute add.commute add_Suc_right assms(1) assms(3) insert_is_Un
        le_antisym matroid_ax_2_alt numeral_2_eq_2 numeral_3_eq_3 one_add_one)
  from f1 and f2 show "rk {A, B, C, \<alpha>, \<beta>} = 3"
    using matroid_ax_3_alt'
    by (metis Un_assoc assms(1) insert_is_Un)
qed

lemma desargues_config_3D_coplanar_5 :
  assumes "desargues_config_3D A B C A' B' C' P \<alpha> \<beta> \<gamma>"
  shows "rk {A, B, C, \<alpha>, \<beta>} = 3" and "rk {A', B', C', \<alpha>, \<beta>} = 3"
proof-
  show "rk {A, B, C, \<alpha>, \<beta>} = 3"
    using assms desargues_config_3D_def coplanar_5
    by auto
  show "rk {A', B', C', \<alpha>, \<beta>} = 3"
    using assms desargues_config_3D_def coplanar_5
    by auto
qed

lemma coplanar_5_bis :
  assumes "rk {A, B, C} = 3" and "rk {B, C, \<alpha>} = 2" and "rk {A, B, \<gamma>} = 2"
  shows "rk {A, B, C, \<alpha>, \<gamma>} = 3"
  by (smt assms coplanar_5 insert_commute)

lemma desargues_config_3D_coplanar_5_bis :
  assumes "desargues_config_3D A B C A' B' C' P \<alpha> \<beta> \<gamma>"
  shows "rk {A, B, C, \<alpha>, \<gamma>} = 3" and "rk {A', B', C', \<alpha>, \<gamma>} = 3"
proof-
  show "rk {A, B, C, \<alpha>, \<gamma>} = 3"
    using assms desargues_config_3D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] coplanar_5_bis
    by auto
  show "rk {A', B', C', \<alpha>, \<gamma>} = 3"
    using assms desargues_config_3D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] coplanar_5_bis
    by auto
qed

lemma coplanar_6 :
  assumes "rk {A, B, C} = 3" and "rk {B, C, \<alpha>} = 2" and "rk {A, B, \<gamma>} = 2" and "rk {A, C, \<beta>} = 2"
  shows "rk {A, B, C, \<alpha>, \<beta>, \<gamma>} = 3"
proof-
  have f1:"rk {A, B, C, \<alpha>, \<gamma>} = 3"
    using coplanar_5_bis assms(1) assms(2) assms(3)
    by auto
  have f2:"rk {A, B, C, \<alpha>, \<beta>} = 3"
    using coplanar_5 assms(1) assms(2) assms(4)
    by auto
  have f3:"rk {A, B, C, \<alpha>} = 3"
    using coplanar_4 assms(1) assms(2)
    by auto
  from f1 and f2 and f3 show "rk {A, B, C, \<alpha>, \<beta>, \<gamma>} = 3"
    using matroid_ax_3_alt'[of "{A, B, C, \<alpha>}" "\<beta>" "\<gamma>"]
    by (metis Un_insert_left sup_bot.left_neutral)
qed

lemma desargues_config_3D_coplanar_6 :
  assumes "desargues_config_3D A B C A' B' C' P \<alpha> \<beta> \<gamma>"
  shows "rk {A, B, C, \<alpha>, \<beta>, \<gamma>} = 3" and "rk {A', B', C', \<alpha>, \<beta>, \<gamma>} = 3"
proof-
  show "rk {A, B, C, \<alpha>, \<beta>, \<gamma>} = 3"
    using assms desargues_config_3D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] coplanar_6
    by auto
  show "rk {A', B', C', \<alpha>, \<beta>, \<gamma>} = 3"
    using assms desargues_config_3D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] coplanar_6
    by auto
qed

lemma desargues_config_3D_non_coplanar :
  assumes "desargues_config_3D A B C A' B' C' P \<alpha> \<beta> \<gamma>"
  shows "rk {A, B, C, A', B', C', \<alpha>, \<beta>, \<gamma>} \<ge> 4"
proof-
  have "rk {A, B, C, A', B', C'} \<le> rk {A, B, C, A', B', C', \<alpha>, \<beta>, \<gamma>}"
    using matroid_ax_2
    by auto
  thus "4 \<le> rk {A, B, C, A', B', C', \<alpha>, \<beta>, \<gamma>}"
    using matroid_ax_2 assms desargues_config_3D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
    by linarith
qed

theorem desargues_3D :
  assumes "desargues_config_3D A B C A' B' C' P \<alpha> \<beta> \<gamma>"
  shows "rk {\<alpha>, \<beta>, \<gamma>} \<le> 2"
proof-
  have "rk {A, B, C, A', B', C', \<alpha>, \<beta>, \<gamma>} + rk {\<alpha>, \<beta>, \<gamma>} \<le> rk {A, B, C, \<alpha>, \<beta>, \<gamma>} + rk {A', B', C', \<alpha>, \<beta>, \<gamma>}"
    using matroid_ax_3_alt[of "{\<alpha>, \<beta>, \<gamma>}" "{A, B, C, \<alpha>, \<beta>, \<gamma>}" "{A', B', C', \<alpha>, \<beta>, \<gamma>}"]
    by (simp add: insert_commute)
  then have "rk {\<alpha>, \<beta>, \<gamma>} \<le> rk {A, B, C, \<alpha>, \<beta>, \<gamma>} + rk {A', B', C', \<alpha>, \<beta>, \<gamma>} - rk {A, B, C, A', B', C', \<alpha>, \<beta>, \<gamma>}"
    by linarith
  thus "rk {\<alpha>, \<beta>, \<gamma>} \<le> 2"
    using assms desargues_config_3D_coplanar_6 desargues_config_3D_non_coplanar
    by fastforce
qed

end


section \<open>Treewidth of Trees\<close>

theory TreewidthTree
imports TreeDecomposition begin

text \<open>The treewidth of a tree is 1 if the tree has at least one edge, otherwise it is 0.

  For simplicity and without loss of generality, we assume that the vertex set of the tree is a
  subset of the natural numbers because this is what we use in the definition of
  @{const Graph.treewidth}.

  While it would be nice to lift this restriction, removing it would entail defining isomorphisms
  between graphs in order to map the tree decomposition to a tree decomposition over the natural
  numbers.  This is outside the scope of this theory and probably not terribly interesting by
  itself.\<close>
theorem treewidth_tree:
  fixes G :: "nat Graph" (structure)
  assumes "Tree G"
  shows "Graph.treewidth G \<le> 1"
proof-
  interpret Tree G using assms .
  {
    assume "V \<noteq> {}"
    then obtain root where root: "root \<in> V" by blast
    then interpret RootedTree G root by unfold_locales
    define bag where "bag v = (if v = root then {v} else {v, parent v})" for v
    have v_in_bag: "\<And>v. v \<in> bag v" unfolding bag_def by simp
    have bag_in_V: "\<And>v. v \<in> V \<Longrightarrow> bag v \<subseteq> V" unfolding bag_def
      using parent_in_V empty_subsetI insert_subset by auto
    have "TreeDecomposition G G bag" proof
      show "\<Union>{bag t | t. t \<in> V} = V" using bag_in_V v_in_bag by blast
    next
      fix v w assume "v\<rightarrow>w"
      moreover have "\<And>v' w'. \<lbrakk> v'\<rightarrow>w'; v' \<noteq> root \<rbrakk> \<Longrightarrow> w' \<in> bag v' \<or> v' \<in> bag w'" unfolding bag_def
        by (metis insertI2 parent_edge_cases parent_edge_root singletonI)
      ultimately have "v \<in> bag w \<or> w \<in> bag v" using no_loops undirected by blast
      thus "\<exists>t\<in>V. v \<in> bag t \<and> w \<in> bag t" using \<open>v\<rightarrow>w\<close> edges_are_in_V v_in_bag by blast
    next
      fix s u t assume s: "s \<in> V" and u: "u \<in> V" and t: "t \<in> set (s\<leadsto>u)"
      have "t \<in> V" using t by (meson s subsetCE u unique_connecting_path_properties(1) walk_in_V)
      hence "s = u \<Longrightarrow> t = s" using left_tree_initial' s t by blast
      moreover have "s\<rightarrow>u \<Longrightarrow> t = s \<or> t = u" using s t u \<open>t \<in> V\<close>
        by (metis insertE left_treeI left_tree_initial' list.exhaust_sel list.simps(15)
            undirected unique_connecting_path_properties(2,3) unique_connecting_path_set(2)
            unique_connecting_path_tl)
      moreover {
        assume *: "s \<noteq> u" "\<not>s\<rightarrow>u"
        have "s = root \<Longrightarrow> bag s \<inter> bag u = {}" unfolding bag_def
          using *(1,2) parent_edge u undirected by fastforce
        moreover have "u = root \<Longrightarrow> bag s \<inter> bag u = {}" unfolding bag_def
          using *(1,2) parent_edge s by fastforce
        moreover have "\<lbrakk> s \<noteq> root; u \<noteq> root; parent s \<noteq> parent u \<rbrakk> \<Longrightarrow> bag s \<inter> bag u = {}"
          unfolding bag_def using *(2) parent_edge s u undirected by fastforce
        moreover {
          assume **: "s \<noteq> root" "u \<noteq> root" "parent s = parent u" "t \<noteq> s" "t \<noteq> u"
          have "bag s \<inter> bag u = { parent s }" unfolding bag_def using *(1) **(1-3)
            Int_insert_left inf.orderE insertE insert_absorb subset_insertI by auto
          moreover have "t = parent s"
            using sibling_path[OF s **(1) u **(2) *(1) **(3)] t **(4,5) by auto
          ultimately have "bag s \<inter> bag u \<subseteq> bag t" by (simp add: v_in_bag)
        }
        ultimately have "bag s \<inter> bag u \<subseteq> bag t" by blast
      }
      ultimately show "bag s \<inter> bag u \<subseteq> bag t" by blast
    qed
    then interpret TreeDecomposition G G bag .
    {
      fix v
      have "card { v, parent v } \<le> 2"
        by (metis card.insert card_empty finite.emptyI finite_insert insert_absorb insert_not_empty
            lessI less_or_eq_imp_le numerals(2))
      hence "card (bag v) \<le> 2" unfolding bag_def by simp
    }
    hence "max_bag_card \<le> 2" using \<open>V \<noteq> {}\<close> max_bag_card_in_bag_cards by auto
    hence "width \<le> 1" unfolding width_def by (simp add: \<open>V \<noteq> {}\<close>)
    hence "\<exists>bag. TreeDecomposition G G bag \<and> TreeDecomposition.width G bag \<le> 1"
      using TreeDecomposition_axioms by blast
  }
  thus ?thesis by (metis TreeDecomposition.width_V_empty le_0_eq linear
    treewidth_cards_treewidth treewidth_upper_bound_ex)
qed

text \<open>If the tree is non-trivial, that is, if it contains more than one vertex, then its
  treewidth is exactly 1.\<close>
corollary treewidth_tree_exact:
  fixes G :: "nat Graph" (structure)
  assumes "Tree G" "card V\<^bsub>G\<^esub> > 1"
  shows "Graph.treewidth G = 1"
  using assms Graph.treewidth_lower_bound_1 Tree.tree_has_edge Tree_def treewidth_tree
  by fastforce

end


(*  Title:      ZF/WF.thy
    Author:     Tobias Nipkow and Lawrence C Paulson
    Copyright   1994  University of Cambridge

Derived first for transitive relations, and finally for arbitrary WF relations
via wf_trancl and trans_trancl.

It is difficult to derive this general case directly, using r^+ instead of
r.  In is_recfun, the two occurrences of the relation must have the same
form.  Inserting r^+ in the_recfun or wftrec yields a recursion rule with
r^+ -`` {a} instead of r-``{a}.  This recursion rule is stronger in
principle, but harder to use, especially to prove wfrec_eclose_eq in
epsilon.ML.  Expanding out the definition of wftrec in wfrec would yield
a mess.
*)

section\<open>Well-Founded Recursion\<close>

theory WF imports Trancl begin

definition
  wf           :: "i\<Rightarrow>o"  where
    (*r is a well-founded relation*)
    "wf(r) \<equiv> \<forall>Z. Z=0 | (\<exists>x\<in>Z. \<forall>y. \<langle>y,x\<rangle>:r \<longrightarrow> \<not> y \<in> Z)"

definition
  wf_on        :: "[i,i]\<Rightarrow>o"                      (\<open>wf[_]'(_')\<close>)  where
    (*r is well-founded on A*)
    "wf_on(A,r) \<equiv> wf(r \<inter> A*A)"

definition
  is_recfun    :: "[i, i, [i,i]\<Rightarrow>i, i] \<Rightarrow>o"  where
    "is_recfun(r,a,H,f) \<equiv> (f = (\<lambda>x\<in>r-``{a}. H(x, restrict(f, r-``{x}))))"

definition
  the_recfun   :: "[i, i, [i,i]\<Rightarrow>i] \<Rightarrow>i"  where
    "the_recfun(r,a,H) \<equiv> (THE f. is_recfun(r,a,H,f))"

definition
  wftrec :: "[i, i, [i,i]\<Rightarrow>i] \<Rightarrow>i"  where
    "wftrec(r,a,H) \<equiv> H(a, the_recfun(r,a,H))"

definition
  wfrec :: "[i, i, [i,i]\<Rightarrow>i] \<Rightarrow>i"  where
    (*public version.  Does not require r to be transitive*)
    "wfrec(r,a,H) \<equiv> wftrec(r^+, a, \<lambda>x f. H(x, restrict(f,r-``{x})))"

definition
  wfrec_on     :: "[i, i, i, [i,i]\<Rightarrow>i] \<Rightarrow>i"       (\<open>wfrec[_]'(_,_,_')\<close>)  where
    "wfrec[A](r,a,H) \<equiv> wfrec(r \<inter> A*A, a, H)"

subsection\<open>Well-Founded Relations\<close>

subsubsection\<open>Equivalences between \<^term>\<open>wf\<close> and \<^term>\<open>wf_on\<close>\<close>

lemma wf_imp_wf_on: "wf(r) \<Longrightarrow> wf[A](r)"
by (unfold wf_def wf_on_def, force)

lemma wf_on_imp_wf: "\<lbrakk>wf[A](r); r \<subseteq> A*A\<rbrakk> \<Longrightarrow> wf(r)"
by (simp add: wf_on_def subset_Int_iff)

lemma wf_on_field_imp_wf: "wf[field(r)](r) \<Longrightarrow> wf(r)"
by (unfold wf_def wf_on_def, fast)

lemma wf_iff_wf_on_field: "wf(r) \<longleftrightarrow> wf[field(r)](r)"
by (blast intro: wf_imp_wf_on wf_on_field_imp_wf)

lemma wf_on_subset_A: "\<lbrakk>wf[A](r);  B<=A\<rbrakk> \<Longrightarrow> wf[B](r)"
by (unfold wf_on_def wf_def, fast)

lemma wf_on_subset_r: "\<lbrakk>wf[A](r); s<=r\<rbrakk> \<Longrightarrow> wf[A](s)"
by (unfold wf_on_def wf_def, fast)

lemma wf_subset: "\<lbrakk>wf(s); r<=s\<rbrakk> \<Longrightarrow> wf(r)"
by (simp add: wf_def, fast)

subsubsection\<open>Introduction Rules for \<^term>\<open>wf_on\<close>\<close>

text\<open>If every non-empty subset of \<^term>\<open>A\<close> has an \<^term>\<open>r\<close>-minimal element
   then we have \<^term>\<open>wf[A](r)\<close>.\<close>
lemma wf_onI:
 assumes prem: "\<And>Z u. \<lbrakk>Z<=A;  u \<in> Z;  \<forall>x\<in>Z. \<exists>y\<in>Z. \<langle>y,x\<rangle>:r\<rbrakk> \<Longrightarrow> False"
 shows         "wf[A](r)"
  unfolding wf_on_def wf_def
apply (rule equals0I [THEN disjCI, THEN allI])
apply (rule_tac Z = Z in prem, blast+)
done

text\<open>If \<^term>\<open>r\<close> allows well-founded induction over \<^term>\<open>A\<close>
   then we have \<^term>\<open>wf[A](r)\<close>.   Premise is equivalent to
  \<^prop>\<open>\<And>B. \<forall>x\<in>A. (\<forall>y. \<langle>y,x\<rangle>: r \<longrightarrow> y \<in> B) \<longrightarrow> x \<in> B \<Longrightarrow> A<=B\<close>\<close>
lemma wf_onI2:
 assumes prem: "\<And>y B. \<lbrakk>\<forall>x\<in>A. (\<forall>y\<in>A. \<langle>y,x\<rangle>:r \<longrightarrow> y \<in> B) \<longrightarrow> x \<in> B;   y \<in> A\<rbrakk>
                       \<Longrightarrow> y \<in> B"
 shows         "wf[A](r)"
apply (rule wf_onI)
apply (rule_tac c=u in prem [THEN DiffE])
  prefer 3 apply blast
 apply fast+
done

subsubsection\<open>Well-founded Induction\<close>

text\<open>Consider the least \<^term>\<open>z\<close> in \<^term>\<open>domain(r)\<close> such that
  \<^term>\<open>P(z)\<close> does not hold...\<close>
lemma wf_induct_raw:
    "\<lbrakk>wf(r);
        \<And>x.\<lbrakk>\<forall>y. \<langle>y,x\<rangle>: r \<longrightarrow> P(y)\<rbrakk> \<Longrightarrow> P(x)\<rbrakk>
     \<Longrightarrow> P(a)"
  unfolding wf_def
apply (erule_tac x = "{z \<in> domain(r). \<not> P(z)}" in allE)
apply blast
done

lemmas wf_induct = wf_induct_raw [rule_format, consumes 1, case_names step, induct set: wf]

text\<open>The form of this rule is designed to match \<open>wfI\<close>\<close>
lemma wf_induct2:
    "\<lbrakk>wf(r);  a \<in> A;  field(r)<=A;
        \<And>x.\<lbrakk>x \<in> A;  \<forall>y. \<langle>y,x\<rangle>: r \<longrightarrow> P(y)\<rbrakk> \<Longrightarrow> P(x)\<rbrakk>
     \<Longrightarrow>  P(a)"
apply (erule_tac P="a \<in> A" in rev_mp)
apply (erule_tac a=a in wf_induct, blast)
done

lemma field_Int_square: "field(r \<inter> A*A) \<subseteq> A"
by blast

lemma wf_on_induct_raw [consumes 2, induct set: wf_on]:
    "\<lbrakk>wf[A](r);  a \<in> A;
        \<And>x.\<lbrakk>x \<in> A;  \<forall>y\<in>A. \<langle>y,x\<rangle>: r \<longrightarrow> P(y)\<rbrakk> \<Longrightarrow> P(x)
\<rbrakk>  \<Longrightarrow>  P(a)"
  unfolding wf_on_def
apply (erule wf_induct2, assumption)
apply (rule field_Int_square, blast)
done

lemma wf_on_induct [consumes 2, case_names step, induct set: wf_on]:
  "wf[A](r) \<Longrightarrow> a \<in> A \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> (\<And>y. y \<in> A \<Longrightarrow> \<langle>y, x\<rangle> \<in> r \<Longrightarrow> P(y)) \<Longrightarrow> P(x)) \<Longrightarrow> P(a)"
  using wf_on_induct_raw [of A r a P] by simp

text\<open>If \<^term>\<open>r\<close> allows well-founded induction
   then we have \<^term>\<open>wf(r)\<close>.\<close>
lemma wfI:
    "\<lbrakk>field(r)<=A;
        \<And>y B. \<lbrakk>\<forall>x\<in>A. (\<forall>y\<in>A. \<langle>y,x\<rangle>:r \<longrightarrow> y \<in> B) \<longrightarrow> x \<in> B;  y \<in> A\<rbrakk>
               \<Longrightarrow> y \<in> B\<rbrakk>
     \<Longrightarrow>  wf(r)"
apply (rule wf_on_subset_A [THEN wf_on_field_imp_wf])
apply (rule wf_onI2)
 prefer 2 apply blast
apply blast
done

subsection\<open>Basic Properties of Well-Founded Relations\<close>

lemma wf_not_refl: "wf(r) \<Longrightarrow> \<langle>a,a\<rangle> \<notin> r"
by (erule_tac a=a in wf_induct, blast)

lemma wf_not_sym [rule_format]: "wf(r) \<Longrightarrow> \<forall>x. \<langle>a,x\<rangle>:r \<longrightarrow> \<langle>x,a\<rangle> \<notin> r"
by (erule_tac a=a in wf_induct, blast)

(* @{term"\<lbrakk>wf(r);  \<langle>a,x\<rangle> \<in> r;  \<not>P \<Longrightarrow> \<langle>x,a\<rangle> \<in> r\<rbrakk> \<Longrightarrow> P"} *)
lemmas wf_asym = wf_not_sym [THEN swap]

lemma wf_on_not_refl: "\<lbrakk>wf[A](r); a \<in> A\<rbrakk> \<Longrightarrow> \<langle>a,a\<rangle> \<notin> r"
by (erule_tac a=a in wf_on_induct, assumption, blast)

lemma wf_on_not_sym:
     "\<lbrakk>wf[A](r);  a \<in> A\<rbrakk> \<Longrightarrow> (\<And>b. b\<in>A \<Longrightarrow> \<langle>a,b\<rangle>:r \<Longrightarrow> \<langle>b,a\<rangle>\<notin>r)"
apply (atomize (full), intro impI)
apply (erule_tac a=a in wf_on_induct, assumption, blast)
done

lemma wf_on_asym:
     "\<lbrakk>wf[A](r);  \<not>Z \<Longrightarrow> \<langle>a,b\<rangle> \<in> r;
         \<langle>b,a\<rangle> \<notin> r \<Longrightarrow> Z; \<not>Z \<Longrightarrow> a \<in> A; \<not>Z \<Longrightarrow> b \<in> A\<rbrakk> \<Longrightarrow> Z"
by (blast dest: wf_on_not_sym)

(*Needed to prove well_ordI.  Could also reason that wf[A](r) means
  wf(r \<inter> A*A);  thus wf( (r \<inter> A*A)^+ ) and use wf_not_refl *)
lemma wf_on_chain3:
     "\<lbrakk>wf[A](r); \<langle>a,b\<rangle>:r; \<langle>b,c\<rangle>:r; \<langle>c,a\<rangle>:r; a \<in> A; b \<in> A; c \<in> A\<rbrakk> \<Longrightarrow> P"
apply (subgoal_tac "\<forall>y\<in>A. \<forall>z\<in>A. \<langle>a,y\<rangle>:r \<longrightarrow> \<langle>y,z\<rangle>:r \<longrightarrow> \<langle>z,a\<rangle>:r \<longrightarrow> P",
       blast)
apply (erule_tac a=a in wf_on_induct, assumption, blast)
done

text\<open>transitive closure of a WF relation is WF provided
  \<^term>\<open>A\<close> is downward closed\<close>
lemma wf_on_trancl:
    "\<lbrakk>wf[A](r);  r-``A \<subseteq> A\<rbrakk> \<Longrightarrow> wf[A](r^+)"
apply (rule wf_onI2)
apply (frule bspec [THEN mp], assumption+)
apply (erule_tac a = y in wf_on_induct, assumption)
apply (blast elim: tranclE, blast)
done

lemma wf_trancl: "wf(r) \<Longrightarrow> wf(r^+)"
apply (simp add: wf_iff_wf_on_field)
apply (rule wf_on_subset_A)
 apply (erule wf_on_trancl)
 apply blast
apply (rule trancl_type [THEN field_rel_subset])
done

text\<open>\<^term>\<open>r-``{a}\<close> is the set of everything under \<^term>\<open>a\<close> in \<^term>\<open>r\<close>\<close>

lemmas underI = vimage_singleton_iff [THEN iffD2]
lemmas underD = vimage_singleton_iff [THEN iffD1]

subsection\<open>The Predicate \<^term>\<open>is_recfun\<close>\<close>

lemma is_recfun_type: "is_recfun(r,a,H,f) \<Longrightarrow> f \<in> r-``{a} -> range(f)"
  unfolding is_recfun_def
apply (erule ssubst)
apply (rule lamI [THEN rangeI, THEN lam_type], assumption)
done

lemmas is_recfun_imp_function = is_recfun_type [THEN fun_is_function]

lemma apply_recfun:
    "\<lbrakk>is_recfun(r,a,H,f); \<langle>x,a\<rangle>:r\<rbrakk> \<Longrightarrow> f`x = H(x, restrict(f,r-``{x}))"
  unfolding is_recfun_def
  txt\<open>replace f only on the left-hand side\<close>
apply (erule_tac P = "\<lambda>x. t(x) = u" for t u in ssubst)
apply (simp add: underI)
done

lemma is_recfun_equal [rule_format]:
     "\<lbrakk>wf(r);  trans(r);  is_recfun(r,a,H,f);  is_recfun(r,b,H,g)\<rbrakk>
      \<Longrightarrow> \<langle>x,a\<rangle>:r \<longrightarrow> \<langle>x,b\<rangle>:r \<longrightarrow> f`x=g`x"
apply (frule_tac f = f in is_recfun_type)
apply (frule_tac f = g in is_recfun_type)
apply (simp add: is_recfun_def)
apply (erule_tac a=x in wf_induct)
apply (intro impI)
apply (elim ssubst)
apply (simp (no_asm_simp) add: vimage_singleton_iff restrict_def)
apply (rule_tac t = "\<lambda>z. H (x, z)" for x in subst_context)
apply (subgoal_tac "\<forall>y\<in>r-``{x}. \<forall>z. \<langle>y,z\<rangle>:f \<longleftrightarrow> \<langle>y,z\<rangle>:g")
 apply (blast dest: transD)
apply (simp add: apply_iff)
apply (blast dest: transD intro: sym)
done

lemma is_recfun_cut:
     "\<lbrakk>wf(r);  trans(r);
         is_recfun(r,a,H,f);  is_recfun(r,b,H,g);  \<langle>b,a\<rangle>:r\<rbrakk>
      \<Longrightarrow> restrict(f, r-``{b}) = g"
apply (frule_tac f = f in is_recfun_type)
apply (rule fun_extension)
  apply (blast dest: transD intro: restrict_type2)
 apply (erule is_recfun_type, simp)
apply (blast dest: transD intro: is_recfun_equal)
done

subsection\<open>Recursion: Main Existence Lemma\<close>

lemma is_recfun_functional:
     "\<lbrakk>wf(r); trans(r); is_recfun(r,a,H,f); is_recfun(r,a,H,g)\<rbrakk>  \<Longrightarrow>  f=g"
by (blast intro: fun_extension is_recfun_type is_recfun_equal)

lemma the_recfun_eq:
    "\<lbrakk>is_recfun(r,a,H,f);  wf(r);  trans(r)\<rbrakk> \<Longrightarrow> the_recfun(r,a,H) = f"
  unfolding the_recfun_def
apply (blast intro: is_recfun_functional)
done

(*If some f satisfies is_recfun(r,a,H,-) then so does the_recfun(r,a,H) *)
lemma is_the_recfun:
    "\<lbrakk>is_recfun(r,a,H,f);  wf(r);  trans(r)\<rbrakk>
     \<Longrightarrow> is_recfun(r, a, H, the_recfun(r,a,H))"
by (simp add: the_recfun_eq)

lemma unfold_the_recfun:
     "\<lbrakk>wf(r);  trans(r)\<rbrakk> \<Longrightarrow> is_recfun(r, a, H, the_recfun(r,a,H))"
apply (rule_tac a=a in wf_induct, assumption)
apply (rename_tac a1)
apply (rule_tac f = "\<lambda>y\<in>r-``{a1}. wftrec (r,y,H)" in is_the_recfun)
  apply typecheck
  unfolding is_recfun_def wftrec_def
  \<comment> \<open>Applying the substitution: must keep the quantified assumption!\<close>
apply (rule lam_cong [OF refl])
apply (drule underD)
apply (fold is_recfun_def)
apply (rule_tac t = "\<lambda>z. H(x, z)" for x in subst_context)
apply (rule fun_extension)
  apply (blast intro: is_recfun_type)
 apply (rule lam_type [THEN restrict_type2])
  apply blast
 apply (blast dest: transD)
apply atomize
apply (frule spec [THEN mp], assumption)
apply (subgoal_tac "\<langle>xa,a1\<rangle> \<in> r")
 apply (drule_tac x1 = xa in spec [THEN mp], assumption)
apply (simp add: vimage_singleton_iff
                 apply_recfun is_recfun_cut)
apply (blast dest: transD)
done

subsection\<open>Unfolding \<^term>\<open>wftrec(r,a,H)\<close>\<close>

lemma the_recfun_cut:
     "\<lbrakk>wf(r);  trans(r);  \<langle>b,a\<rangle>:r\<rbrakk>
      \<Longrightarrow> restrict(the_recfun(r,a,H), r-``{b}) = the_recfun(r,b,H)"
by (blast intro: is_recfun_cut unfold_the_recfun)

(*NOT SUITABLE FOR REWRITING: it is recursive!*)
lemma wftrec:
    "\<lbrakk>wf(r);  trans(r)\<rbrakk> \<Longrightarrow>
          wftrec(r,a,H) = H(a, \<lambda>x\<in>r-``{a}. wftrec(r,x,H))"
  unfolding wftrec_def
apply (subst unfold_the_recfun [unfolded is_recfun_def])
apply (simp_all add: vimage_singleton_iff [THEN iff_sym] the_recfun_cut)
done

subsubsection\<open>Removal of the Premise \<^term>\<open>trans(r)\<close>\<close>

(*NOT SUITABLE FOR REWRITING: it is recursive!*)
lemma wfrec:
    "wf(r) \<Longrightarrow> wfrec(r,a,H) = H(a, \<lambda>x\<in>r-``{a}. wfrec(r,x,H))"
  unfolding wfrec_def
apply (erule wf_trancl [THEN wftrec, THEN ssubst])
 apply (rule trans_trancl)
apply (rule vimage_pair_mono [THEN restrict_lam_eq, THEN subst_context])
 apply (erule r_into_trancl)
apply (rule subset_refl)
done

(*This form avoids giant explosions in proofs.  NOTE USE OF \<equiv> *)
lemma def_wfrec:
    "\<lbrakk>\<And>x. h(x)\<equiv>wfrec(r,x,H);  wf(r)\<rbrakk> \<Longrightarrow>
     h(a) = H(a, \<lambda>x\<in>r-``{a}. h(x))"
apply simp
apply (elim wfrec)
done

lemma wfrec_type:
    "\<lbrakk>wf(r);  a \<in> A;  field(r)<=A;
        \<And>x u. \<lbrakk>x \<in> A;  u \<in> Pi(r-``{x}, B)\<rbrakk> \<Longrightarrow> H(x,u) \<in> B(x)
\<rbrakk> \<Longrightarrow> wfrec(r,a,H) \<in> B(a)"
apply (rule_tac a = a in wf_induct2, assumption+)
apply (subst wfrec, assumption)
apply (simp add: lam_type underD)
done

lemma wfrec_on:
 "\<lbrakk>wf[A](r);  a \<in> A\<rbrakk> \<Longrightarrow>
         wfrec[A](r,a,H) = H(a, \<lambda>x\<in>(r-``{a}) \<inter> A. wfrec[A](r,x,H))"
  unfolding wf_on_def wfrec_on_def
apply (erule wfrec [THEN trans])
apply (simp add: vimage_Int_square)
done

text\<open>Minimal-element characterization of well-foundedness\<close>
lemma wf_eq_minimal: "wf(r) \<longleftrightarrow> (\<forall>Q x. x \<in> Q \<longrightarrow> (\<exists>z\<in>Q. \<forall>y. \<langle>y,z\<rangle>:r \<longrightarrow> y\<notin>Q))"
  unfolding wf_def by blast

end


(*
 * Copyright Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section \<open>Lemmas on division\<close>

theory More_Divides
  imports
    "HOL-Library.Word"
begin

declare div_eq_dividend_iff [simp]

lemma int_div_same_is_1 [simp]:
  \<open>a div b = a \<longleftrightarrow> b = 1\<close> if \<open>0 < a\<close> for a b :: int
  using that by (metis div_by_1 abs_ge_zero abs_of_pos int_div_less_self neq_iff
            nonneg1_imp_zdiv_pos_iff zabs_less_one_iff)

lemma int_div_minus_is_minus1 [simp]:
  \<open>a div b = - a \<longleftrightarrow> b = - 1\<close> if \<open>0 > a\<close> for a b :: int
  using that by (metis div_minus_right equation_minus_iff int_div_same_is_1 neg_0_less_iff_less)

lemma nat_div_eq_Suc_0_iff: "n div m = Suc 0 \<longleftrightarrow> m \<le> n \<and> n < 2 * m"
  apply auto
  using div_greater_zero_iff apply fastforce
   apply (metis One_nat_def div_greater_zero_iff dividend_less_div_times mult.right_neutral mult_Suc mult_numeral_1 numeral_2_eq_2 zero_less_numeral)
  apply (simp add: div_nat_eqI)
  done

lemma diff_mod_le:
  \<open>a - a mod b \<le> d - b\<close> if \<open>a < d\<close> \<open>b dvd d\<close> for a b d :: nat
  using that
  apply(subst minus_mod_eq_mult_div)
  apply(clarsimp simp: dvd_def)
  apply(cases \<open>b = 0\<close>)
   apply simp
  apply(subgoal_tac "a div b \<le> k - 1")
   prefer 2
   apply(subgoal_tac "a div b < k")
    apply(simp add: less_Suc_eq_le [symmetric])
   apply(subgoal_tac "b * (a div b) < b * ((b * k) div b)")
    apply clarsimp
   apply(subst div_mult_self1_is_m)
    apply arith
   apply(rule le_less_trans)
    apply simp
    apply(subst mult.commute)
    apply(rule div_times_less_eq_dividend)
   apply assumption
  apply clarsimp
  apply(subgoal_tac "b * (a div b) \<le> b * (k - 1)")
   apply(erule le_trans)
   apply(simp add: diff_mult_distrib2)
  apply simp
  done

lemma one_mod_exp_eq_one [simp]:
  "1 mod (2 * 2 ^ n) = (1::int)"
  using power_gt1 [of 2 n] by (auto intro: mod_pos_pos_trivial)

lemma int_mod_lem: "0 < n \<Longrightarrow> 0 \<le> b \<and> b < n \<longleftrightarrow> b mod n = b"
  for b n :: int
  apply safe
    apply (erule (1) mod_pos_pos_trivial)
   apply (erule_tac [!] subst)
   apply auto
  done

lemma int_mod_ge': "b < 0 \<Longrightarrow> 0 < n \<Longrightarrow> b + n \<le> b mod n"
  for b n :: int
  by (metis add_less_same_cancel2 int_mod_ge mod_add_self2)

lemma int_mod_le': "0 \<le> b - n \<Longrightarrow> b mod n \<le> b - n"
  for b n :: int
  by (metis minus_mod_self2 zmod_le_nonneg_dividend)

lemma emep1: "even n \<Longrightarrow> even d \<Longrightarrow> 0 \<le> d \<Longrightarrow> (n + 1) mod d = (n mod d) + 1"
  for n d :: int
  by (auto simp add: pos_zmod_mult_2 add.commute dvd_def)

lemma m1mod2k: "- 1 mod 2 ^ n = (2 ^ n - 1 :: int)"
  by (rule zmod_minus1) simp

lemma sb_inc_lem: "a + 2^k < 0 \<Longrightarrow> a + 2^k + 2^(Suc k) \<le> (a + 2^k) mod 2^(Suc k)"
  for a :: int
  using int_mod_ge' [where n = "2 ^ (Suc k)" and b = "a + 2 ^ k"]
  by simp

lemma sb_inc_lem': "a < - (2^k) \<Longrightarrow> a + 2^k + 2^(Suc k) \<le> (a + 2^k) mod 2^(Suc k)"
  for a :: int
  by (rule sb_inc_lem) simp

lemma sb_dec_lem: "0 \<le> - (2 ^ k) + a \<Longrightarrow> (a + 2 ^ k) mod (2 * 2 ^ k) \<le> - (2 ^ k) + a"
  for a :: int
  using int_mod_le'[where n = "2 ^ (Suc k)" and b = "a + 2 ^ k"] by simp

lemma sb_dec_lem': "2 ^ k \<le> a \<Longrightarrow> (a + 2 ^ k) mod (2 * 2 ^ k) \<le> - (2 ^ k) + a"
  for a :: int
  by (rule sb_dec_lem) simp

lemma mod_2_neq_1_eq_eq_0: "k mod 2 \<noteq> 1 \<longleftrightarrow> k mod 2 = 0"
  for k :: int
  by (fact not_mod_2_eq_1_eq_0)

lemma z1pmod2: "(2 * b + 1) mod 2 = (1::int)"
  for b :: int
  by arith

lemma p1mod22k': "(1 + 2 * b) mod (2 * 2 ^ n) = 1 + 2 * (b mod 2 ^ n)"
  for b :: int
  by (rule pos_zmod_mult_2) simp

lemma p1mod22k: "(2 * b + 1) mod (2 * 2 ^ n) = 2 * (b mod 2 ^ n) + 1"
  for b :: int
  by (simp add: p1mod22k' add.commute)

lemma pos_mod_sign2:
  \<open>0 \<le> a mod 2\<close> for a :: int
  by simp

lemma pos_mod_bound2:
  \<open>a mod 2 < 2\<close> for a :: int
  by simp

lemma nmod2: "n mod 2 = 0 \<or> n mod 2 = 1"
  for n :: int
  by arith

lemma eme1p:
  "even n \<Longrightarrow> even d \<Longrightarrow> 0 \<le> d \<Longrightarrow> (1 + n) mod d = 1 + n mod d" for n d :: int
  using emep1 [of n d] by (simp add: ac_simps)

lemma m1mod22k:
  \<open>- 1 mod (2 * 2 ^ n) = 2 * 2 ^ n - (1::int)\<close>
  by (simp add: zmod_minus1)

lemma z1pdiv2: "(2 * b + 1) div 2 = b"
  for b :: int
  by arith

lemma zdiv_le_dividend:
  \<open>0 \<le> a \<Longrightarrow> 0 < b \<Longrightarrow> a div b \<le> a\<close> for a b :: int
  by (metis div_by_1 int_one_le_iff_zero_less zdiv_mono2 zero_less_one)

lemma axxmod2: "(1 + x + x) mod 2 = 1 \<and> (0 + x + x) mod 2 = 0"
  for x :: int
  by arith

lemma axxdiv2: "(1 + x + x) div 2 = x \<and> (0 + x + x) div 2 = x"
  for x :: int
  by arith

lemmas rdmods =
  mod_minus_eq [symmetric]
  mod_diff_left_eq [symmetric]
  mod_diff_right_eq [symmetric]
  mod_add_left_eq [symmetric]
  mod_add_right_eq [symmetric]
  mod_mult_right_eq [symmetric]
  mod_mult_left_eq [symmetric]

lemma mod_plus_right: "(a + x) mod m = (b + x) mod m \<longleftrightarrow> a mod m = b mod m"
  for a b m x :: nat
  by (induct x) (simp_all add: mod_Suc, arith)

lemma nat_minus_mod: "(n - n mod m) mod m = 0"
  for m n :: nat
  by (induct n) (simp_all add: mod_Suc)

lemmas nat_minus_mod_plus_right =
  trans [OF nat_minus_mod mod_0 [symmetric],
    THEN mod_plus_right [THEN iffD2], simplified]

lemmas push_mods' = mod_add_eq
  mod_mult_eq mod_diff_eq
  mod_minus_eq

lemmas push_mods = push_mods' [THEN eq_reflection]
lemmas pull_mods = push_mods [symmetric] rdmods [THEN eq_reflection]

lemma nat_mod_eq: "b < n \<Longrightarrow> a mod n = b mod n \<Longrightarrow> a mod n = b"
  for a b n :: nat
  by (induct a) auto

lemmas nat_mod_eq' = refl [THEN [2] nat_mod_eq]

lemma nat_mod_lem: "0 < n \<Longrightarrow> b < n \<longleftrightarrow> b mod n = b"
  for b n :: nat
  apply safe
   apply (erule nat_mod_eq')
  apply (erule subst)
  apply (erule mod_less_divisor)
  done

lemma mod_nat_add: "x < z \<Longrightarrow> y < z \<Longrightarrow> (x + y) mod z = (if x + y < z then x + y else x + y - z)"
  for x y z :: nat
  apply (rule nat_mod_eq)
   apply auto
  apply (rule trans)
   apply (rule le_mod_geq)
   apply simp
  apply (rule nat_mod_eq')
  apply arith
  done

lemma mod_nat_sub: "x < z \<Longrightarrow> (x - y) mod z = x - y"
  for x y :: nat
  by (rule nat_mod_eq') arith

lemma int_mod_eq: "0 \<le> b \<Longrightarrow> b < n \<Longrightarrow> a mod n = b mod n \<Longrightarrow> a mod n = b"
  for a b n :: int
  by (metis mod_pos_pos_trivial)

lemma zmde:
  \<open>b * (a div b) = a - a mod b\<close> for a b :: \<open>'a::{group_add,semiring_modulo}\<close>
  using mult_div_mod_eq [of b a] by (simp add: eq_diff_eq)

(* already have this for naturals, div_mult_self1/2, but not for ints *)
lemma zdiv_mult_self: "m \<noteq> 0 \<Longrightarrow> (a + m * n) div m = a div m + n"
  for a m n :: int
  by simp

lemma mod_power_lem: "a > 1 \<Longrightarrow> a ^ n mod a ^ m = (if m \<le> n then 0 else a ^ n)"
  for a :: int
  by (simp add: mod_eq_0_iff_dvd le_imp_power_dvd)

lemma nonneg_mod_div: "0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> 0 \<le> (a mod b) \<and> 0 \<le> a div b"
  for a b :: int
  by (cases "b = 0") (auto intro: pos_imp_zdiv_nonneg_iff [THEN iffD2])

lemma mod_exp_less_eq_exp:
  \<open>a mod 2 ^ n < 2 ^ n\<close> for a :: int
  by (rule pos_mod_bound) simp

lemma div_mult_le:
  \<open>a div b * b \<le> a\<close> for a b :: nat
  by (fact div_times_less_eq_dividend)

lemma power_sub:
  fixes a :: nat
  assumes lt: "n \<le> m"
  and     av: "0 < a"
  shows "a ^ (m - n) = a ^ m div a ^ n"
proof (subst nat_mult_eq_cancel1 [symmetric])
  show "(0::nat) < a ^ n" using av by simp
next
  from lt obtain q where mv: "n + q = m"
    by (auto simp: le_iff_add)

  have "a ^ n * (a ^ m div a ^ n) = a ^ m"
  proof (subst mult.commute)
    have "a ^ m = (a ^ m div a ^ n) * a ^ n + a ^ m mod a ^ n"
      by (rule  div_mult_mod_eq [symmetric])

    moreover have "a ^ m mod a ^ n = 0"
      by (subst mod_eq_0_iff_dvd, subst dvd_def, rule exI [where x = "a ^ q"],
      (subst power_add [symmetric] mv)+, rule refl)

    ultimately show "(a ^ m div a ^ n) * a ^ n = a ^ m" by simp
  qed

  then show "a ^ n * a ^ (m - n) = a ^ n * (a ^ m div a ^ n)" using lt
    by (simp add: power_add [symmetric])
qed

lemma mod_lemma: "[| (0::nat) < c; r < b |] ==> b * (q mod c) + r < b * c"
  apply (cut_tac m = q and n = c in mod_less_divisor)
  apply (drule_tac [2] m = "q mod c" in less_imp_Suc_add, auto)
  apply (erule_tac P = "%x. lhs < rhs x" for lhs rhs in ssubst)
  apply (simp add: add_mult_distrib2)
  done

lemma less_two_pow_divD:
  "\<lbrakk> (x :: nat) < 2 ^ n div 2 ^ m \<rbrakk>
    \<Longrightarrow> n \<ge> m \<and> (x < 2 ^ (n - m))"
  apply (rule context_conjI)
   apply (rule ccontr)
   apply (simp add: power_strict_increasing)
  apply (simp add: power_sub)
  done

lemma less_two_pow_divI:
  "\<lbrakk> (x :: nat) < 2 ^ (n - m); m \<le> n \<rbrakk> \<Longrightarrow> x < 2 ^ n div 2 ^ m"
  by (simp add: power_sub)

lemmas m2pths = pos_mod_sign mod_exp_less_eq_exp

lemmas int_mod_eq' = mod_pos_pos_trivial (* FIXME delete *)

lemmas int_mod_le = zmod_le_nonneg_dividend (* FIXME: delete *)

lemma power_mod_div:
  fixes x :: "nat"
  shows "x mod 2 ^ n div 2 ^ m = x div 2 ^ m mod 2 ^ (n - m)" (is "?LHS = ?RHS")
proof (cases "n \<le> m")
  case True
  then have "?LHS = 0"
    apply -
    apply (rule div_less)
    apply (rule order_less_le_trans [OF mod_less_divisor]; simp)
    done
  also have "\<dots> = ?RHS" using True
    by simp
  finally show ?thesis .
next
  case False
  then have lt: "m < n" by simp
  then obtain q where nv: "n = m + q" and "0 < q"
    by (auto dest: less_imp_Suc_add)

  then have "x mod 2 ^ n = 2 ^ m * (x div 2 ^ m mod 2 ^ q) + x mod 2 ^ m"
    by (simp add: power_add mod_mult2_eq)

  then have "?LHS = x div 2 ^ m mod 2 ^ q"
    by (simp add: div_add1_eq)

  also have "\<dots> = ?RHS" using nv
    by simp

  finally show ?thesis .
qed

lemma mod_mod_power:
  fixes k :: nat
  shows "k mod 2 ^ m mod 2 ^ n = k mod 2 ^ (min m n)"
proof (cases "m \<le> n")
  case True

  then have "k mod 2 ^ m mod 2 ^ n = k mod 2 ^ m"
    apply -
    apply (subst mod_less [where n = "2 ^ n"])
    apply (rule order_less_le_trans [OF mod_less_divisor])
    apply simp+
    done
  also have "\<dots> = k mod  2 ^ (min m n)" using True by simp
  finally show ?thesis .
next
  case False
  then have "n < m" by simp
  then obtain d where md: "m = n + d"
    by (auto dest: less_imp_add_positive)
  then have "k mod 2 ^ m = 2 ^ n * (k div 2 ^ n mod 2 ^ d) + k mod 2 ^ n"
    by (simp add: mod_mult2_eq power_add)
  then have "k mod 2 ^ m mod 2 ^ n = k mod 2 ^ n"
    by (simp add: mod_add_left_eq)
  then show ?thesis using False
    by simp
qed

lemma mod_div_equality_div_eq:
  "a div b * b = (a - (a mod b) :: int)"
  by (simp add: field_simps)

lemma zmod_helper:
  "n mod m = k \<Longrightarrow> ((n :: int) + a) mod m = (k + a) mod m"
  by (metis add.commute mod_add_right_eq)

lemma int_div_sub_1:
  "\<lbrakk> m \<ge> 1 \<rbrakk> \<Longrightarrow> (n - (1 :: int)) div m = (if m dvd n then (n div m) - 1 else n div m)"
  apply (subgoal_tac "m = 0 \<or> (n - (1 :: int)) div m = (if m dvd n then (n div m) - 1 else n div m)")
   apply fastforce
  apply (subst mult_cancel_right[symmetric])
  apply (simp only: left_diff_distrib split: if_split)
  apply (simp only: mod_div_equality_div_eq)
  apply (clarsimp simp: field_simps)
  apply (clarsimp simp: dvd_eq_mod_eq_0)
  apply (cases "m = 1")
   apply simp
  apply (subst mod_diff_eq[symmetric], simp add: zmod_minus1)
  apply clarsimp
  apply (subst diff_add_cancel[where b=1, symmetric])
  apply (subst mod_add_eq[symmetric])
  apply (simp add: field_simps)
  apply (rule mod_pos_pos_trivial)
   apply (subst add_0_right[where a=0, symmetric])
   apply (rule add_mono)
    apply simp
   apply simp
  apply (cases "(n - 1) mod m = m - 1")
   apply (drule zmod_helper[where a=1])
   apply simp
  apply (subgoal_tac "1 + (n - 1) mod m \<le> m")
   apply simp
  apply (subst field_simps, rule zless_imp_add1_zle)
  apply simp
  done

lemma power_minus_is_div:
  "b \<le> a \<Longrightarrow> (2 :: nat) ^ (a - b) = 2 ^ a div 2 ^ b"
  apply (induct a arbitrary: b)
   apply simp
  apply (erule le_SucE)
   apply (clarsimp simp:Suc_diff_le le_iff_add power_add)
  apply simp
  done

lemma two_pow_div_gt_le:
  "v < 2 ^ n div (2 ^ m :: nat) \<Longrightarrow> m \<le> n"
  by (clarsimp dest!: less_two_pow_divD)

lemma td_gal_lt:
  \<open>0 < c \<Longrightarrow> a < b * c \<longleftrightarrow> a div c < b\<close>
  for a b c :: nat
  by (simp add: div_less_iff_less_mult)

lemma td_gal:
  \<open>0 < c \<Longrightarrow> b * c \<le> a  \<longleftrightarrow> b \<le> a div c\<close>
  for a b c :: nat
  by (simp add: less_eq_div_iff_mult_less_eq)

end