section \<open>Edmonds-Karp Algorithm\<close>

theory EdmondsKarp_Termination_Abstract imports
  Flow_Networks.Ford_Fulkerson
begin

lemma mlex_fst_decrI:
  fixes a a' b b' N :: nat
  assumes "a<a'"
  assumes "b<N" "b'<N"
  shows "a*N + b < a'*N + b'"
proof -
  have "a*N + b + 1 \<le> a*N + N" using \<open>b<N\<close> by linarith
  also have "\<dots> \<le> a'*N" using \<open>a<a'\<close>
    by (metis Suc_leI ab_semigroup_add_class.add.commute
      ab_semigroup_mult_class.mult.commute mult_Suc_right mult_le_mono2)
  also have "\<dots> \<le> a'*N + b'" by auto
  finally show ?thesis by auto
qed

lemma (in NFlow) augmenting_path_imp_shortest:
  "isAugmentingPath p \<Longrightarrow> \<exists>p. Graph.isShortestPath cf s p t"
  using Graph.obtain_shortest_path unfolding isAugmentingPath_def
  by (fastforce simp: Graph.isSimplePath_def Graph.connected_def)

lemma (in NFlow) shortest_is_augmenting:
  "Graph.isShortestPath cf s p t \<Longrightarrow> isAugmentingPath p"
  unfolding isAugmentingPath_def using Graph.shortestPath_is_simple
  by (fastforce)

subsection \<open>Complexity and Termination Analysis\<close>
text \<open>
  In this section, we show that the loop iterations of the Edmonds-Karp algorithm
  are bounded by $O(VE)$.

  The basic idea of the proof is, that a path that
  takes an edge reverse to an edge on some shortest path
  cannot be a shortest path itself.

  As augmentation flips at least one edge, this yields a termination argument:
    After augmentation, either the minimum distance between source and target
    increases, or it remains the same, but the number of edges that lay on a
    shortest path decreases. As the minimum distance is bounded by $V$,
    we get termination within $O(VE)$ loop iterations.
\<close>

context Graph begin

text \<open>
  The basic idea is expressed in the following lemma, which, however,
  is not general enough to be applied for the correctness proof, where
  we flip more than one edge simultaneously.
  \<close>
lemma isShortestPath_flip_edge:
  assumes "isShortestPath s p t" "(u,v)\<in>set p"
  assumes "isPath s p' t" "(v,u)\<in>set p'"
  shows "length p' \<ge> length p + 2"
  using assms
proof -
  from \<open>isShortestPath s p t\<close> have
    MIN: "min_dist s t = length p" and
      P: "isPath s p t" and
     DV: "distinct (pathVertices s p)"
    by (auto simp: isShortestPath_alt isSimplePath_def)

  from \<open>(u,v)\<in>set p\<close> obtain p1 p2 where [simp]: "p=p1@(u,v)#p2"
    by (auto simp: in_set_conv_decomp)

  from P DV have [simp]: "u\<noteq>v"
    by (cases p2) (auto simp add: isPath_append pathVertices_append)

  from P have DISTS: "dist s (length p1) u" "dist u 1 v" "dist v (length p2) t"
    by (auto simp: isPath_append dist_def intro: exI[where x="[(u,v)]"])

  from MIN have MIN': "min_dist s t = length p1 + 1 + length p2" by auto

  from min_dist_split[OF dist_trans[OF DISTS(1,2)] DISTS(3) MIN'] have
    MDSV: "min_dist s v = length p1 + 1" by simp

  from min_dist_split[OF DISTS(1) dist_trans[OF DISTS(2,3)]] MIN' have
    MDUT: "min_dist u t = 1 + length p2" by simp

  from \<open>(v,u)\<in>set p'\<close> obtain p1' p2' where [simp]: "p'=p1'@(v,u)#p2'"
    by (auto simp: in_set_conv_decomp)

  from \<open>isPath s p' t\<close> have
    DISTS': "dist s (length p1') v" "dist u (length p2') t"
    by (auto simp: isPath_append dist_def)

  from DISTS'[THEN min_dist_minD, unfolded MDSV MDUT] show
    "length p + 2 \<le> length p'" by auto
qed

text \<open>
  To be used for the analysis of augmentation, we have to generalize the
  lemma to simultaneous flipping of edges:
  \<close>

  (* TODO: The proof still contains some redundancy: A first flipped edge
    is searched in both, the induction, and the initialization *)
  {
    fix u v p1 p2'
    assume "(u,v)\<in>edges"
       and "isPath s p1 v" and "g'.isPath u p2' t"
    hence "min_dist s t < length p1 + length p2'"
    proof (induction p2' arbitrary: u v p1 rule: length_induct)
      case (1 p2')
      note IH = "1.IH"[rule_format]
      note P1 = \<open>isPath s p1 v\<close>
      note P2' = \<open>g'.isPath u p2' t\<close>

      have "length p1 > min_dist s u"
      proof -
        from P1 have "length p1 \<ge> min_dist s v"
          using min_dist_minD by (auto simp: dist_def)
        moreover from \<open>(u,v)\<in>edges\<close> EDGES_SS
        have "min_dist s v = Suc (min_dist s u)"
          using isShortestPath_level_edge[OF SP] by auto
        ultimately show ?thesis by auto
      qed

      from isShortestPath_level_edge[OF SP] \<open>(u,v)\<in>edges\<close> EDGES_SS
      have
            "min_dist s t = min_dist s u + min_dist u t"
        and "connected s u"
      by auto

      show ?case
      proof (cases "prod.swap`edges \<inter> set p2' = {}")
        \<comment> \<open>We proceed by a case distinction whether the suffix path contains swapped edges\<close>
        case True
        with g'.transfer_path[OF _ P2', of c] \<open>g'.E \<subseteq> E \<union> prod.swap ` edges\<close>
        have "isPath u p2' t" by auto
        hence "length p2' \<ge> min_dist u t" using min_dist_minD
          by (auto simp: dist_def)
        moreover note \<open>length p1 > min_dist s u\<close>
        moreover note \<open>min_dist s t = min_dist s u + min_dist u t\<close>
        ultimately show ?thesis by auto
      next
        case False
        \<comment> \<open>Obtain first swapped edge on suffix path\<close>
        obtain p21' e' p22' where [simp]: "p2'=p21'@e'#p22'" and
           E_IN_EDGES: "e'\<in>prod.swap`edges" and
          P1_NO_EDGES: "prod.swap`edges \<inter> set p21' = {}"
          apply (rule split_list_first_propE[of p2' "\<lambda>e. e\<in>prod.swap`edges"])
          using \<open>prod.swap ` edges \<inter> set p2' \<noteq> {}\<close> by fastforce+
        obtain u' v' where [simp]: "e'=(v',u')" by (cases e')

        \<comment> \<open>Split the suffix path accordingly\<close>
        from P2' have P21': "g'.isPath u p21' v'" and P22': "g'.isPath u' p22' t"
          by (auto simp: g'.isPath_append)
        \<comment> \<open>As we chose the first edge, the prefix of the suffix path is also a path in the original graph\<close>
        from
          g'.transfer_path[OF _ P21', of c]
          \<open>g'.E \<subseteq> E \<union> prod.swap ` edges\<close>
          P1_NO_EDGES
        have P21: "isPath u p21' v'" by auto
        from min_dist_is_dist[OF \<open>connected s u\<close>]
        obtain psu where
              PSU: "isPath s psu u" and
          LEN_PSU: "length psu = min_dist s u"
          by (auto simp: dist_def)
        from PSU P21 have P1n: "isPath s (psu@p21') v'"
          by (auto simp: isPath_append)
        from IH[OF _ _ P1n P22'] E_IN_EDGES have
          "min_dist s t < length psu + length p21' + length p22'"
          by auto
        moreover note \<open>length p1 > min_dist s u\<close>
        ultimately show ?thesis by (auto simp: LEN_PSU)
      qed
    qed
  } note aux=this

  (* TODO: This step is analogous to what we do in the False-case of the induction.
    Can we somehow remove the redundancy? *)
  \<comment> \<open>Obtain first swapped edge on path\<close>
  obtain p1' e p2' where [simp]: "p'=p1'@e#p2'" and
    E_IN_EDGES: "e\<in>prod.swap`edges" and
    P1_NO_EDGES: "prod.swap`edges \<inter> set p1' = {}"
    apply (rule split_list_first_propE[of p' "\<lambda>e. e\<in>prod.swap`edges"])
    using \<open>prod.swap ` edges \<inter> set p' \<noteq> {}\<close> by fastforce+
  obtain u v where [simp]: "e=(v,u)" by (cases e)

  \<comment> \<open>Split the new path accordingly\<close>
  from \<open>g'.isPath s p' t\<close> have
    P1': "g'.isPath s p1' v" and
    P2': "g'.isPath u p2' t"
    by (auto simp: g'.isPath_append)
  \<comment> \<open>As we chose the first edge, the prefix of the path is also a path in the original graph\<close>
  from
    g'.transfer_path[OF _ P1', of c]
    \<open>g'.E \<subseteq> E \<union> prod.swap ` edges\<close>
    P1_NO_EDGES
  have P1: "isPath s p1' v" by auto

  from aux[OF _ P1 P2'] E_IN_EDGES
  have "min_dist s t < length p1' + length p2'"
    by auto
  thus ?thesis using SP
    by (auto simp: isShortestPath_min_dist_def)
qed

end \<comment> \<open>Graph\<close>

text \<open>We outsource the more specific lemmas to their own locale,
  to prevent name space pollution\<close>
locale ek_analysis_defs = Graph +
  fixes s t :: node

locale ek_analysis = ek_analysis_defs + Finite_Graph
begin

definition (in ek_analysis_defs)
  "spEdges \<equiv> {e. \<exists>p. e\<in>set p \<and> isShortestPath s p t}"

lemma spEdges_ss_E: "spEdges \<subseteq> E"
  using isPath_edgeset unfolding spEdges_def isShortestPath_def by auto

lemma finite_spEdges[simp, intro]: "finite (spEdges)"
  using finite_subset[OF spEdges_ss_E]
  by blast

definition (in ek_analysis_defs) "uE \<equiv> E \<union> E\<inverse>"

lemma finite_uE[simp,intro]: "finite uE"
  by (auto simp: uE_def)

lemma E_ss_uE: "E\<subseteq>uE"
  by (auto simp: uE_def)

lemma card_spEdges_le:
  shows "card spEdges \<le> card uE"
  apply (rule card_mono)
  apply (auto simp: order_trans[OF spEdges_ss_E E_ss_uE])
  done

lemma card_spEdges_less:
  shows "card spEdges < card uE + 1"
  using card_spEdges_le
  by auto

definition (in ek_analysis_defs) "ekMeasure \<equiv>
  if (connected s t) then
    (card V - min_dist s t) * (card uE + 1) + (card (spEdges))
  else 0"

  interpret g': ek_analysis c' s t
    apply intro_locales
    apply (rule g'.Finite_Graph_EI)
    using finite_subset[OF Ebounds(2)] finite_subset[OF SP_EDGES]
    by auto

  from SP_EDGES SP have "edges \<subseteq> E"
    by (auto simp: spEdges_def isShortestPath_def dest: isPath_edgeset)
  with Ebounds have Veq[simp]: "Graph.V c' = V"
    by (force simp: Graph.V_def)

  from Ebounds \<open>edges \<subseteq> E\<close> have uE_eq[simp]: "g'.uE = uE"
    by (force simp: ek_analysis_defs.uE_def)

  from SP have LENP: "length p = min_dist s t"
    by (auto simp: isShortestPath_min_dist_def)

  from SP have CONN: "connected s t"
    by (auto simp: isShortestPath_def connected_def)

  {
    assume NCONN2: "\<not>g'.connected s t"
    hence "s\<noteq>t" by auto
    with CONN NCONN2 have "g'.ekMeasure < ekMeasure"
      unfolding g'.ekMeasure_def ekMeasure_def
      using min_dist_less_V[OF SV]
      by auto
  } moreover {
    assume SHORTER: "g'.min_dist s t < min_dist s t"
    assume CONN2: "g'.connected s t"

    \<comment> \<open>Obtain a shorter path in $g'$\<close>
    from g'.min_dist_is_dist[OF CONN2] obtain p' where
      P': "g'.isPath s p' t" and LENP': "length p' = g'.min_dist s t"
      by (auto simp: g'.dist_def)

    { \<comment> \<open>Case: It does not use @{term "prod.swap`edges"}.
        Then it is also a path in $g$, which is shorter than
        the shortest path in $g$, yielding a contradiction.\<close>
      assume "prod.swap`edges \<inter> set p' = {}"
      with g'.transfer_path[OF _ P', of c] Ebounds have "dist s (length p') t"
        by (auto simp: dist_def)
      from LENP' SHORTER min_dist_minD[OF this] have False by auto
    } moreover {
      \<comment> \<open>So assume the path uses the edge @{term "prod.swap e"}.\<close>
      assume "prod.swap`edges \<inter> set p' \<noteq> {}"
      \<comment> \<open>Due to auxiliary lemma, those path must be longer\<close>
      from isShortestPath_flip_edges[OF _ _ SP SP_EDGES P' this] Ebounds
      have "length p' > length p" by auto
      with SHORTER LENP LENP' have False by auto
    } ultimately have False by auto
  } moreover {
    assume LONGER: "g'.min_dist s t > min_dist s t"
    assume CONN2: "g'.connected s t"
    have "g'.ekMeasure < ekMeasure"
      unfolding g'.ekMeasure_def ekMeasure_def
      apply (simp only: Veq uE_eq CONN CONN2 if_True)
      apply (rule mlex_fst_decrI)
      using card_spEdges_less g'.card_spEdges_less
        and g'.min_dist_less_V[OF _ CONN2] SV
        and LONGER
      apply auto

      done
  } moreover {
    assume EQ: "g'.min_dist s t = min_dist s t"
    assume CONN2: "g'.connected s t"

    {
      fix p'
      assume P': "g'.isShortestPath s p' t"
      have "prod.swap`edges \<inter> set p' = {}"
      proof (rule ccontr)
        assume EIP': "prod.swap`edges \<inter> set p' \<noteq> {}"
        from P' have
             P': "g'.isPath s p' t" and
          LENP': "length p' = g'.min_dist s t"
          by (auto simp: g'.isShortestPath_min_dist_def)
        from isShortestPath_flip_edges[OF _ _ SP SP_EDGES P' EIP'] Ebounds
        have "length p + 2 \<le> length p'" by auto
        with LENP LENP' EQ show False by auto
      qed
      with g'.transfer_path[of p' c s t] P' Ebounds have "isShortestPath s p' t"
        by (auto simp: Graph.isShortestPath_min_dist_def EQ)
    } hence SS: "g'.spEdges \<subseteq> spEdges" by (auto simp: g'.spEdges_def spEdges_def)

    {
      assume "edges - Graph.E c' \<noteq> {}"
      with g'.spEdges_ss_E SS SP SP_EDGES have "g'.spEdges \<subset> spEdges"
        unfolding g'.spEdges_def spEdges_def by fastforce
      hence "g'.ekMeasure < ekMeasure"
        unfolding g'.ekMeasure_def ekMeasure_def
        apply (simp only: Veq uE_eq EQ CONN CONN2 if_True)
        apply (rule add_strict_left_mono)
        apply (rule psubset_card_mono)
        apply simp
        by simp
    } note G1 = this

    have G2: "g'.ekMeasure \<le> ekMeasure"
      unfolding g'.ekMeasure_def ekMeasure_def
      apply (simp only: Veq uE_eq CONN CONN2 if_True)
      apply (rule add_mono[OF mult_right_mono])
      apply (simp add: EQ)
      apply simp
      apply (rule card_mono)
      apply simp
      by fact
    note G1 G2
  } ultimately show
    "g'.ekMeasure \<le> ekMeasure"
    "edges - Graph.E c' \<noteq> {} \<Longrightarrow> g'.ekMeasure < ekMeasure"
    using less_linear[of "g'.min_dist s t" "min_dist s t"]
    apply -
    apply (fastforce)+
    done

qed

end \<comment> \<open>Analysis locale\<close>

text \<open>As a first step to the analysis setup, we characterize
  the effect of augmentation on the residual graph
  \<close>
context Graph
begin

definition "augment_cf edges cap \<equiv> \<lambda>e.
  if e\<in>edges then c e - cap
  else if prod.swap e\<in>edges then c e + cap
  else c e"

lemma augment_cf_empty[simp]: "augment_cf {} cap = c"
  by (auto simp: augment_cf_def)

lemma augment_cf_ss_V: "\<lbrakk>edges \<subseteq> E\<rbrakk> \<Longrightarrow> Graph.V (augment_cf edges cap) \<subseteq> V"
  unfolding Graph.E_def Graph.V_def
  by (auto simp add: augment_cf_def) []

lemma augment_saturate:
  fixes edges e
  defines "c' \<equiv> augment_cf edges (c e)"
  assumes EIE: "e\<in>edges"
  shows "e\<notin>Graph.E c'"
  using EIE unfolding c'_def augment_cf_def
  by (auto simp: Graph.E_def)

lemma augment_cf_split:
  assumes "edges1 \<inter> edges2 = {}" "edges1\<inverse> \<inter> edges2 = {}"
  shows "Graph.augment_cf c (edges1 \<union> edges2) cap
    = Graph.augment_cf (Graph.augment_cf c edges1 cap) edges2 cap"
  using assms
  by (fastforce simp: Graph.augment_cf_def intro!: ext)

end \<comment> \<open>Graph\<close>

context NFlow begin

lemma augmenting_edge_no_swap: "isAugmentingPath p \<Longrightarrow> set p \<inter> (set p)\<inverse> = {}"
  using cf.isSPath_nt_parallel_pf
  by (auto simp: isAugmentingPath_def)

lemma aug_flows_finite[simp, intro!]:
  "finite {cf e |e. e \<in> set p}"
  apply (rule finite_subset[where B="cf`set p"])
  by auto

lemma aug_flows_finite'[simp, intro!]:
  "finite {cf (u,v) |u v. (u,v) \<in> set p}"
  apply (rule finite_subset[where B="cf`set p"])
  by auto

lemma augment_alt:
  assumes AUG: "isAugmentingPath p"
  defines "f' \<equiv> augment (augmentingFlow p)"
  defines "cf' \<equiv> residualGraph c f'"
  shows "cf' = Graph.augment_cf cf (set p) (resCap p)"
proof -
  {
    fix u v
    assume "(u,v)\<in>set p"
    hence "resCap p \<le> cf (u,v)"
      unfolding resCap_def by (auto intro: Min_le)
  } note bn_smallerI = this

  {
    fix u v
    assume "(u,v)\<in>set p"
    hence "(u,v)\<in>cf.E" using AUG cf.isPath_edgeset
      by (auto simp: isAugmentingPath_def cf.isSimplePath_def)
    hence "(u,v)\<in>E \<or> (v,u)\<in>E" using cfE_ss_invE by (auto)
  } note edge_or_swap = this

  show ?thesis
    apply (rule ext)
    unfolding cf.augment_cf_def
    using augmenting_edge_no_swap[OF AUG]
    apply (auto
      simp: augment_def augmentingFlow_def cf'_def f'_def residualGraph_def
      split: prod.splits
      dest: edge_or_swap
      )
    done
qed

lemma augmenting_path_contains_resCap:
  assumes "isAugmentingPath p"
  obtains e where "e\<in>set p" "cf e = resCap p"
proof -
  from assms have "p\<noteq>[]" by (auto simp: isAugmentingPath_def s_not_t)
  hence "{cf e | e. e \<in> set p} \<noteq> {}" by (cases p) auto
  with Min_in[OF aug_flows_finite this, folded resCap_def]
    obtain e where "e\<in>set p" "cf e = resCap p" by auto
  thus ?thesis by (blast intro: that)
qed

text \<open>Finally, we show the main theorem used for termination and complexity
  analysis: Augmentation with a shortest path decreases the measure function.\<close>
theorem shortest_path_decr_ek_measure:
  fixes p
  assumes SP: "Graph.isShortestPath cf s p t"
  defines "f' \<equiv> augment (augmentingFlow p)"
  defines "cf' \<equiv> residualGraph c f'"
  shows "ek_analysis_defs.ekMeasure cf' s t < ek_analysis_defs.ekMeasure cf s t"
proof -
  interpret cf: ek_analysis cf by unfold_locales
  interpret cf': ek_analysis_defs cf' .

  from SP have AUG: "isAugmentingPath p"
    unfolding isAugmentingPath_def cf.isShortestPath_alt by simp

  note BNGZ = resCap_gzero[OF AUG]

  have cf'_alt: "cf' = cf.augment_cf (set p) (resCap p)"
    using augment_alt[OF AUG] unfolding cf'_def f'_def by simp

  obtain e where
    EIP: "e\<in>set p" and EBN: "cf e = resCap p"
    by (rule augmenting_path_contains_resCap[OF AUG]) auto

  have ENIE': "e\<notin>cf'.E"
    using cf.augment_saturate[OF EIP] EBN by (simp add: cf'_alt)

  { fix e
    have "cf e + resCap p \<noteq> 0" using resE_nonNegative[of e] BNGZ by auto
  } note [simp] = this

  { fix e
    assume "e\<in>set p"
    hence "e \<in> cf.E"
      using cf.shortestPath_is_path[OF SP] cf.isPath_edgeset by blast
    hence "cf e > 0 \<and> cf e \<noteq> 0" using resE_positive[of e] by auto
  } note [simp] = this

  show ?thesis
    apply (rule cf.measure_decr(2))
    apply (simp_all add: s_node)
    apply (rule SP)
    apply (rule order_refl)

    apply (rule conjI)
      apply (unfold Graph.E_def) []
      apply (auto simp: cf'_alt cf.augment_cf_def) []

      using augmenting_edge_no_swap[OF AUG]
      apply (fastforce
        simp: cf'_alt cf.augment_cf_def Graph.E_def
        simp del: cf.zero_cap_simp) []

    apply (unfold Graph.E_def) []
    apply (auto simp: cf'_alt cf.augment_cf_def) []
    using EIP ENIE' apply auto []
    done
qed

end \<comment> \<open>Network with flow\<close>

end


(* Author: Rene Thiemann, License: LGPL *)

section \<open>Examples\<close>
theory Partial_Function_MR_Examples
imports
  Partial_Function_MR
  "HOL-Library.Monad_Syntax"
  HOL.Rat
begin

subsection \<open>Collatz function\<close>
text \<open>In the following, we define the Collatz function,
which is artificially encoded via mutually recursive functions.
As second argument we store the intermediate values.
It is currently unknown whether this function is terminating for all inputs or not.\<close>

partial_function_mr (tailrec) collatz and even_case and odd_case where
  "collatz (x :: int) xs =
    (if (x \<le> 1) then rev (x # xs) else
    (if (x mod 2 = 0) then even_case x (x # xs)
     else odd_case x xs))"
| "even_case x xs = collatz (x div 2) xs"
| [simp]: "odd_case x xs = collatz (3 * x + 1) (x # xs)"

text \<open>The equations are registered as code-equations.\<close>
lemma "length (collatz 327 []) = 144" by eval

text \<open>The equations are accessible via .simps, but are not put in the standard simpset.\<close>
lemma "collatz 5 [] = [5,16,8,4,2,1]" by (simp add: collatz.simps even_case.simps)

subsection \<open>Evaluating expressions\<close>
text \<open>Note that we also provide a least fixpoint operator.
  Hence, the evaluation function will clearly be partial.
  The example also illustrates the usage
  of polymorphism and of different return types.\<close>

text \<open>In the following datatype, \isa{Mu b f a} encodes the least $n$ such that $b(f^n(a))$.\<close>
datatype 'a bexp =
  BConst bool
| Less "'a aexp" "'a aexp"
| Eq "'a aexp" "'a aexp"
| And "'a bexp" "'a bexp"
and 'a aexp =
  Plus "'a aexp" "'a aexp"
| Div "'a aexp" "'a aexp"
| IfThenElse "'a bexp" "'a aexp" "'a aexp"
| AConst 'a
| Mu "'a \<Rightarrow> 'a bexp" "'a \<Rightarrow> 'a aexp" "'a aexp"

partial_function_mr (option)
  b_eval and a_eval and mu_eval where
  "b_eval bexp = (case bexp of
     BConst b \<Rightarrow> Some b
   | Less a1 a2 \<Rightarrow> do {
        x1 \<leftarrow> a_eval a1;
        x2 \<leftarrow> a_eval a2;
        Some (x1 < x2)
     }
   | Eq a1 a2 \<Rightarrow> do {
        x1 \<leftarrow> a_eval a1;
        x2 \<leftarrow> a_eval a2;
        Some (x1 = x2)
     }
   | And be1 be2 \<Rightarrow> do {
        b1 \<leftarrow> b_eval be1;
        b2 \<leftarrow> b_eval be2;
        Some (b1 \<and> b2)
     }
  )"
| "a_eval aexp = (case aexp of
     AConst x \<Rightarrow> Some x
   | Plus a1 a2 \<Rightarrow> do {
        x1 \<leftarrow> a_eval a1;
        x2 \<leftarrow> a_eval a2;
        Some (x1 + x2)
     }
   | Div a1 a2 \<Rightarrow> do {
        x1 \<leftarrow> a_eval a1;
        x2 \<leftarrow> a_eval a2;
        if (x2 = 0) then None else Some (x1 / x2)
     }
   | IfThenElse bexp a1 a2 \<Rightarrow> do {
        b \<leftarrow> b_eval bexp;
        (if b then a_eval a1 else a_eval a2)
     }
   | Mu b f a \<Rightarrow> do {
        mu_eval b f a 0
     }
  )"
| "mu_eval b f a n = do {
      x \<leftarrow> a_eval a;
      check \<leftarrow> b_eval (b x);
      (if check then Some (of_nat n) else
       mu_eval b f (f x) (Suc n))
   }"

definition
  "five_minus_two = a_eval (Mu (\<lambda> x. Eq (AConst 5) (AConst x)) (\<lambda> x. Plus (AConst x) (AConst 1)) (AConst (2 :: rat)))"

value five_minus_two

subsection \<open>An example with contexts\<close>

text \<open>Mutual recursive partial functions also work within contexts.\<close>

context
  fixes y :: int
begin
partial_function_mr (tailrec) foo and bar where
  "foo x = (if x = y then foo (x - 1) else (bar x (y - 1)))"
| "bar x z = foo (x + (1 :: int) + y)"
end

end


(*  Title:      HOL/HOLCF/Adm.thy
    Author:     Franz Regensburger and Brian Huffman
*)

section {* Admissibility and compactness *}

theory Adm
imports Cont
begin

default_sort cpo

subsection {* Definitions *}

definition
  adm :: "('a::cpo \<Rightarrow> bool) \<Rightarrow> bool" where
  "adm P = (\<forall>Y. chain Y \<longrightarrow> (\<forall>i. P (Y i)) \<longrightarrow> P (\<Squnion>i. Y i))"

lemma admI:
   "(\<And>Y. \<lbrakk>chain Y; \<forall>i. P (Y i)\<rbrakk> \<Longrightarrow> P (\<Squnion>i. Y i)) \<Longrightarrow> adm P"
unfolding adm_def by fast

lemma admD: "\<lbrakk>adm P; chain Y; \<And>i. P (Y i)\<rbrakk> \<Longrightarrow> P (\<Squnion>i. Y i)"
unfolding adm_def by fast

lemma admD2: "\<lbrakk>adm (\<lambda>x. \<not> P x); chain Y; P (\<Squnion>i. Y i)\<rbrakk> \<Longrightarrow> \<exists>i. P (Y i)"
unfolding adm_def by fast

lemma triv_admI: "\<forall>x. P x \<Longrightarrow> adm P"
by (rule admI, erule spec)

subsection {* Admissibility on chain-finite types *}

text {* For chain-finite (easy) types every formula is admissible. *}

lemma adm_chfin [simp]: "adm (P::'a::chfin \<Rightarrow> bool)"
by (rule admI, frule chfin, auto simp add: maxinch_is_thelub)

subsection {* Admissibility of special formulae and propagation *}

lemma adm_const [simp]: "adm (\<lambda>x. t)"
by (rule admI, simp)

lemma adm_conj [simp]:
  "\<lbrakk>adm (\<lambda>x. P x); adm (\<lambda>x. Q x)\<rbrakk> \<Longrightarrow> adm (\<lambda>x. P x \<and> Q x)"
by (fast intro: admI elim: admD)

lemma adm_all [simp]:
  "(\<And>y. adm (\<lambda>x. P x y)) \<Longrightarrow> adm (\<lambda>x. \<forall>y. P x y)"
by (fast intro: admI elim: admD)

lemma adm_ball [simp]:
  "(\<And>y. y \<in> A \<Longrightarrow> adm (\<lambda>x. P x y)) \<Longrightarrow> adm (\<lambda>x. \<forall>y\<in>A. P x y)"
by (fast intro: admI elim: admD)

text {* Admissibility for disjunction is hard to prove. It requires 2 lemmas. *}

lemma adm_disj_lemma1:
  assumes adm: "adm P"
  assumes chain: "chain Y"
  assumes P: "\<forall>i. \<exists>j\<ge>i. P (Y j)"
  shows "P (\<Squnion>i. Y i)"
proof -
  def f \<equiv> "\<lambda>i. LEAST j. i \<le> j \<and> P (Y j)"
  have chain': "chain (\<lambda>i. Y (f i))"
    unfolding f_def
    apply (rule chainI)
    apply (rule chain_mono [OF chain])
    apply (rule Least_le)
    apply (rule LeastI2_ex)
    apply (simp_all add: P)
    done
  have f1: "\<And>i. i \<le> f i" and f2: "\<And>i. P (Y (f i))"
    using LeastI_ex [OF P [rule_format]] by (simp_all add: f_def)
  have lub_eq: "(\<Squnion>i. Y i) = (\<Squnion>i. Y (f i))"
    apply (rule below_antisym)
    apply (rule lub_mono [OF chain chain'])
    apply (rule chain_mono [OF chain f1])
    apply (rule lub_range_mono [OF _ chain chain'])
    apply clarsimp
    done
  show "P (\<Squnion>i. Y i)"
    unfolding lub_eq using adm chain' f2 by (rule admD)
qed

lemma adm_disj_lemma2:
  "\<forall>n::nat. P n \<or> Q n \<Longrightarrow> (\<forall>i. \<exists>j\<ge>i. P j) \<or> (\<forall>i. \<exists>j\<ge>i. Q j)"
apply (erule contrapos_pp)
apply (clarsimp, rename_tac a b)
apply (rule_tac x="max a b" in exI)
apply simp
done

lemma adm_disj [simp]:
  "\<lbrakk>adm (\<lambda>x. P x); adm (\<lambda>x. Q x)\<rbrakk> \<Longrightarrow> adm (\<lambda>x. P x \<or> Q x)"
apply (rule admI)
apply (erule adm_disj_lemma2 [THEN disjE])
apply (erule (2) adm_disj_lemma1 [THEN disjI1])
apply (erule (2) adm_disj_lemma1 [THEN disjI2])
done

lemma adm_imp [simp]:
  "\<lbrakk>adm (\<lambda>x. \<not> P x); adm (\<lambda>x. Q x)\<rbrakk> \<Longrightarrow> adm (\<lambda>x. P x \<longrightarrow> Q x)"
by (subst imp_conv_disj, rule adm_disj)

lemma adm_iff [simp]:
  "\<lbrakk>adm (\<lambda>x. P x \<longrightarrow> Q x); adm (\<lambda>x. Q x \<longrightarrow> P x)\<rbrakk>
    \<Longrightarrow> adm (\<lambda>x. P x = Q x)"
by (subst iff_conv_conj_imp, rule adm_conj)

text {* admissibility and continuity *}

lemma adm_below [simp]:
  "\<lbrakk>cont (\<lambda>x. u x); cont (\<lambda>x. v x)\<rbrakk> \<Longrightarrow> adm (\<lambda>x. u x \<sqsubseteq> v x)"
by (simp add: adm_def cont2contlubE lub_mono ch2ch_cont)

lemma adm_eq [simp]:
  "\<lbrakk>cont (\<lambda>x. u x); cont (\<lambda>x. v x)\<rbrakk> \<Longrightarrow> adm (\<lambda>x. u x = v x)"
by (simp add: po_eq_conv)

lemma adm_subst: "\<lbrakk>cont (\<lambda>x. t x); adm P\<rbrakk> \<Longrightarrow> adm (\<lambda>x. P (t x))"
by (simp add: adm_def cont2contlubE ch2ch_cont)

lemma adm_not_below [simp]: "cont (\<lambda>x. t x) \<Longrightarrow> adm (\<lambda>x. t x \<notsqsubseteq> u)"
by (rule admI, simp add: cont2contlubE ch2ch_cont lub_below_iff)

subsection {* Compactness *}

definition
  compact :: "'a::cpo \<Rightarrow> bool" where
  "compact k = adm (\<lambda>x. k \<notsqsubseteq> x)"

lemma compactI: "adm (\<lambda>x. k \<notsqsubseteq> x) \<Longrightarrow> compact k"
unfolding compact_def .

lemma compactD: "compact k \<Longrightarrow> adm (\<lambda>x. k \<notsqsubseteq> x)"
unfolding compact_def .

lemma compactI2:
  "(\<And>Y. \<lbrakk>chain Y; x \<sqsubseteq> (\<Squnion>i. Y i)\<rbrakk> \<Longrightarrow> \<exists>i. x \<sqsubseteq> Y i) \<Longrightarrow> compact x"
unfolding compact_def adm_def by fast

lemma compactD2:
  "\<lbrakk>compact x; chain Y; x \<sqsubseteq> (\<Squnion>i. Y i)\<rbrakk> \<Longrightarrow> \<exists>i. x \<sqsubseteq> Y i"
unfolding compact_def adm_def by fast

lemma compact_below_lub_iff:
  "\<lbrakk>compact x; chain Y\<rbrakk> \<Longrightarrow> x \<sqsubseteq> (\<Squnion>i. Y i) \<longleftrightarrow> (\<exists>i. x \<sqsubseteq> Y i)"
by (fast intro: compactD2 elim: below_lub)

lemma compact_chfin [simp]: "compact (x::'a::chfin)"
by (rule compactI [OF adm_chfin])

lemma compact_imp_max_in_chain:
  "\<lbrakk>chain Y; compact (\<Squnion>i. Y i)\<rbrakk> \<Longrightarrow> \<exists>i. max_in_chain i Y"
apply (drule (1) compactD2, simp)
apply (erule exE, rule_tac x=i in exI)
apply (rule max_in_chainI)
apply (rule below_antisym)
apply (erule (1) chain_mono)
apply (erule (1) below_trans [OF is_ub_thelub])
done

text {* admissibility and compactness *}

lemma adm_compact_not_below [simp]:
  "\<lbrakk>compact k; cont (\<lambda>x. t x)\<rbrakk> \<Longrightarrow> adm (\<lambda>x. k \<notsqsubseteq> t x)"
unfolding compact_def by (rule adm_subst)

lemma adm_neq_compact [simp]:
  "\<lbrakk>compact k; cont (\<lambda>x. t x)\<rbrakk> \<Longrightarrow> adm (\<lambda>x. t x \<noteq> k)"
by (simp add: po_eq_conv)

lemma adm_compact_neq [simp]:
  "\<lbrakk>compact k; cont (\<lambda>x. t x)\<rbrakk> \<Longrightarrow> adm (\<lambda>x. k \<noteq> t x)"
by (simp add: po_eq_conv)

lemma compact_bottom [simp, intro]: "compact \<bottom>"
by (rule compactI, simp)

text {* Any upward-closed predicate is admissible. *}

lemma adm_upward:
  assumes P: "\<And>x y. \<lbrakk>P x; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> P y"
  shows "adm P"
by (rule admI, drule spec, erule P, erule is_ub_thelub)

lemmas adm_lemmas =
  adm_const adm_conj adm_all adm_ball adm_disj adm_imp adm_iff
  adm_below adm_eq adm_not_below
  adm_compact_not_below adm_compact_neq adm_neq_compact

end


theory ex08
imports
  Complex_Main
  "HOL-Data_Structures.Tree23_Set"
begin

term Tree23_Set.ins

fun join :: "'a tree23 \<Rightarrow> 'a tree23 \<Rightarrow> 'a upI" where
  "join Leaf Leaf = TI Leaf"
| "join (Node2 l1 a r1) (Node2 l2 b r2) =
    (case join r1 l2 of TI t \<Rightarrow> TI (Node3 l1 a t b r2)
                      | OF t1 c t2 \<Rightarrow> OF (Node2 l1 a t1) c (Node2 t2 b r2))"
| "join (Node2 l1 a r1) (Node3 l2 b m2 c r2) =
    (case join r1 l2 of TI t \<Rightarrow> OF (Node2 l1 a t) b (Node2 m2 c r2)
                      | OF t1 d t2 \<Rightarrow> OF (Node2 l1 a t1) d (Node3 t2 b m2 c r2))"
| "join (Node3 l1 a m1 b r1) (Node2 l2 c r2) =
    (case join r1 l2 of TI t \<Rightarrow> OF (Node2 l1 a m1) b (Node2 t c r2)
                      | OF t1 d t2 \<Rightarrow> OF (Node3 l1 a m1 b t1) d (Node2 t2 c r2))"
| "join (Node3 l1 a m1 b r1) (Node3 l2 c m2 d r2) =
    (case join r1 l2 of TI t \<Rightarrow> OF (Node3 l1 a m1 b t) c (Node2 m2 d r2)
                      | OF t1 e t2 \<Rightarrow> OF (Node3 l1 a m1 b t1) e (Node3 t2 c m2 d r2))"

lemma join_inorder:
fixes t1 t2 :: "'a tree23"
assumes "height t1 = height t2"
assumes "complete t1" "complete t2"
shows "inorder (treeI (join t1 t2 )) = (inorder t1 @ inorder t2)"
  using assms
  apply(induction t1 t2 rule: join.induct)
          apply (auto split: upI.splits)
  done

lemma join_complete:
fixes t1 t2 :: "'a tree23"
assumes "height t1 = height t2"
assumes "complete t1" "complete t2"
shows "complete (treeI (join t1 t2 )) \<and> height (join t1 t2 ) = height t2"
  using assms
  apply(induction t1 t2 rule: join.induct)
          apply (auto split: upI.splits)
  done

find_theorems "size" "complete"
find_theorems "_ ^ _" "log"

lemma height_bound_upper: "complete t \<Longrightarrow> height t \<le> log 2 (size t + 1 )"
  using ht_sz_if_complete  le_log2_of_power
  by blast

lemma height_bound_lower_aux: "complete t \<Longrightarrow> size t + 1 \<le> 3 ^ height t"
  apply(induction t)
    apply auto
  done

find_theorems "log" "log _ _ \<le> _"

lemma height_bound_lower:
  assumes "complete t"
  shows "log 3 (size t + 1 ) \<le> height t"
proof-
  have "real (size t + 1) \<le> 3 ^ height t"
    using height_bound_lower_aux[OF assms]
    using of_nat_mono
    by fastforce
  hence "log 3 (size t + 1) \<le> log 3 (3 ^ height t)"
    using log_le_cancel_iff[where a = 3 and x = "(size t + 1)" and y = "3 ^ height t", symmetric]
    by auto
  moreover have "log 3 (3 ^ height t) = height t"
    using log_pow_cancel
    by force
  ultimately show ?thesis
    by auto
qed


(*
  Authors: Asta Halkjær From, Agnes Moesgård Eschen & Jørgen Villadsen, DTU Compute
*)

theory LT3 imports System_L1 begin

text \<open>System from Jan Lukasiewicz and Alfred Tarski (1930): Untersuchungen über den Aussagenkalkül\<close>

text \<open>Inspired by Shotaro Tanaka (1965): On Axiom Systems of Propositional Calculi. XIII\<close>

inductive LT (\<open>\<tturnstile>\<close>) where
  LT_MP: \<open>\<tturnstile> q\<close> if \<open>\<tturnstile> p\<close> and \<open>\<tturnstile> (p \<rightarrow> q)\<close> |
  LT_15: \<open>\<tturnstile> (((p \<rightarrow> q) \<rightarrow> r) \<rightarrow> (q \<rightarrow> r))\<close> |
  LT_4: \<open>\<tturnstile> ((\<sim> r \<rightarrow> (s \<rightarrow> \<sim> t)) \<rightarrow> ((r \<rightarrow> (s \<rightarrow> u)) \<rightarrow> ((t \<rightarrow> s) \<rightarrow> (t \<rightarrow> u))))\<close>

lemma LT_11: \<open>\<tturnstile> ((p \<rightarrow> q) \<rightarrow> ((q \<rightarrow> r) \<rightarrow> (p \<rightarrow> r)))\<close>
  using LT_4 LT_15 LT_MP by metis

lemma LT_20: \<open>\<tturnstile> ((\<sim> p \<rightarrow> p) \<rightarrow> p)\<close>
  using LT_4 LT_15 LT_MP by metis

lemma LT_21: \<open>\<tturnstile> (p \<rightarrow> (\<sim> p \<rightarrow> q))\<close>
  using LT_4 LT_15 LT_MP by metis

lemma LT_1: \<open>\<tturnstile> (((p \<rightarrow> (q \<rightarrow> p))
              \<rightarrow> ((((\<sim> r) \<rightarrow> (s \<rightarrow> (\<sim> t))) \<rightarrow> ((r \<rightarrow> (s \<rightarrow> u)) \<rightarrow> ((t \<rightarrow> s) \<rightarrow> (t \<rightarrow> u)))) \<rightarrow> (v)))
             \<rightarrow> (w \<rightarrow> v))\<close>
  using LT_4 LT_15 LT_11 LT_20 LT_MP by metis (* A little faster without LT_21 *)

theorem LT_iff_L1: \<open>\<tturnstile> p \<longleftrightarrow> \<turnstile> p\<close>
proof
  have L1_LT_15: \<open>\<turnstile> (((p \<rightarrow> q) \<rightarrow> r) \<rightarrow> (q \<rightarrow> r))\<close> for p q r
    using L1_completeness by simp
  have L1_LT_4: \<open>\<turnstile> ((\<sim> r \<rightarrow> (s \<rightarrow> \<sim> t)) \<rightarrow> ((r \<rightarrow> (s \<rightarrow> u)) \<rightarrow> ((t \<rightarrow> s) \<rightarrow> (t \<rightarrow> u))))\<close> for r s t u
    using L1_completeness by simp
  show \<open>\<turnstile> p\<close> if \<open>\<tturnstile> p\<close>
    using that by (induct) (metis MP, metis L1_LT_15, metis L1_LT_4)
  show \<open>\<tturnstile> p\<close> if \<open>\<turnstile> p\<close>
    using that by (induct) (metis LT_MP, metis LT_11, metis LT_20, metis LT_21)
qed

theorem LT_soundness: \<open>\<tturnstile> p \<Longrightarrow> I \<Turnstile> p\<close>
  by (induct rule: LT.induct) auto

theorem LT_completeness: \<open>\<forall>I. (I \<Turnstile> p) \<Longrightarrow> \<tturnstile> p\<close>
  using LT_iff_L1 by (simp add: L1_completeness)

section \<open>Soundness and Completeness\<close>

theorem main: \<open>valid p = \<tturnstile> p\<close>
  unfolding valid_def using LT_soundness LT_completeness by blast

lemmas LT = LT.intros main

(* L2 *)

lemma \<open>\<tturnstile> (((p \<rightarrow> q) \<rightarrow> r) \<rightarrow> ((\<sim> p) \<rightarrow> r))\<close>
  using LT_4 LT_15 LT_MP oops (* by metis MINUTES *)

lemma \<open>\<tturnstile> (((p \<rightarrow> q) \<rightarrow> r) \<rightarrow> (q \<rightarrow> r))\<close>
  using LT_4 LT_15 LT_MP oops (* by metis = LT_15 *)

lemma \<open>\<tturnstile> (((\<sim> p) \<rightarrow> r) \<rightarrow> ((q \<rightarrow> r) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> r)))\<close>
  using LT_4 LT_15 LT_MP oops (* by metis NO LUCK *)

(* L3 *)

lemma LT_3: \<open>\<tturnstile> (p \<rightarrow> (q \<rightarrow> p))\<close>
  using LT_4 LT_15 LT_MP by metis

lemma LT_5: \<open>\<tturnstile> ((p \<rightarrow> (q \<rightarrow> r)) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> (p \<rightarrow> r)))\<close>
  using LT_4 LT_15 LT_MP by metis

lemma LT_19: \<open>\<tturnstile> ((\<sim> p \<rightarrow> \<sim> q) \<rightarrow> (q \<rightarrow> p))\<close>
  using LT_4 LT_15 LT_MP by metis

end


section \<open> Astronomical Constants \<close>

theory SI_Astronomical
  imports SI "HOL-Decision_Procs.Approximation"
begin

text \<open> We create a number of astronomical constants and prove relationships between some of them.
  For this, we use the approximation method that can compute bounds on transcendental functions. \<close>

definition julian_year :: "'a::field[T]" where
[si_eq]: "julian_year = 365.25 *\<^sub>Q day"

definition light_year :: "'a::field_char_0[L]" where
"light_year = QCOERCE[L] (\<^bold>c \<^bold>\<cdot> julian_year)"

text \<open> We need to apply a coercion in the definition of light year to convert the dimension type
  from \<^typ>\<open>L \<cdot> T\<^sup>-\<^sup>1 \<cdot> T\<close> to \<^typ>\<open>L\<close>. The correctness of this coercion is confirmed by the following
  equivalence theorem. \<close>

lemma light_year: "light_year \<cong>\<^sub>Q \<^bold>c \<^bold>\<cdot> julian_year"
  unfolding light_year_def by (si_calc)

lemma light_year_eq [si_eq]: "\<lbrakk>light_year\<rbrakk>\<^sub>Q = \<lbrakk>\<^bold>c \<^bold>\<cdot> julian_year\<rbrakk>\<^sub>Q"
  using light_year quant_equiv_iff by blast

text \<open> HOL can characterise \<^const>\<open>pi\<close> exactly and so we also give an exact value for the parsec. \<close>

definition parsec :: "real[L]" where
[si_eq]: "parsec = 648000 / pi *\<^sub>Q astronomical_unit"

text \<open> We calculate some conservative bounds on the parsec: it is somewhere between 3.26 and 3.27
  light-years. \<close>

lemma parsec_lb: "3.26 *\<^sub>Q light_year < parsec"
  by (si_simp, approximation 12)

lemma parsec_ub: "parsec < 3.27 *\<^sub>Q light_year"
  by (si_simp, approximation 12)

text\<open> The full beauty of the approach is perhaps revealed here, with the
      type of a classical three-dimensional gravitation field:\<close>

type_synonym gravitation_field = "real\<^sup>3[L] \<Rightarrow> (real\<^sup>3[L \<cdot> T\<^sup>-\<^sup>2])"

end


(*  Title:      HOL/ex/BigO.thy
    Authors:    Jeremy Avigad and Kevin Donnelly; proofs tidied by LCP
*)

section \<open>Big O notation\<close>

theory BigO
  imports
    Complex_Main
    "HOL-Library.Function_Algebras"
    "HOL-Library.Set_Algebras"
begin

text \<open>
  This library is designed to support asymptotic ``big O'' calculations,
  i.e.~reasoning with expressions of the form \<open>f = O(g)\<close> and \<open>f = g + O(h)\<close>.
  An earlier version of this library is described in detail in \<^cite>\<open>"Avigad-Donnelly"\<close>.

  The main changes in this version are as follows:

    \<^item> We have eliminated the \<open>O\<close> operator on sets. (Most uses of this seem
      to be inessential.)
    \<^item> We no longer use \<open>+\<close> as output syntax for \<open>+o\<close>
    \<^item> Lemmas involving \<open>sumr\<close> have been replaced by more general lemmas
      involving `\<open>sum\<close>.
    \<^item> The library has been expanded, with e.g.~support for expressions of
      the form \<open>f < g + O(h)\<close>.

  Note also since the Big O library includes rules that demonstrate set
  inclusion, to use the automated reasoners effectively with the library one
  should redeclare the theorem \<open>subsetI\<close> as an intro rule, rather than as an
  \<open>intro!\<close> rule, for example, using \<^theory_text>\<open>declare subsetI [del, intro]\<close>.
\<close>

subsection \<open>Definitions\<close>

definition bigo :: "('a \<Rightarrow> 'b::linordered_idom) \<Rightarrow> ('a \<Rightarrow> 'b) set"  ("(1O'(_'))")
  where "O(f:: 'a \<Rightarrow> 'b) = {h. \<exists>c. \<forall>x. \<bar>h x\<bar> \<le> c * \<bar>f x\<bar>}"

lemma bigo_pos_const:
  "(\<exists>c::'a::linordered_idom. \<forall>x. \<bar>h x\<bar> \<le> c * \<bar>f x\<bar>) \<longleftrightarrow>
    (\<exists>c. 0 < c \<and> (\<forall>x. \<bar>h x\<bar> \<le> c * \<bar>f x\<bar>))"
  by (metis (no_types, opaque_lifting) abs_ge_zero abs_not_less_zero abs_of_nonneg dual_order.trans
        mult_1 zero_less_abs_iff zero_less_mult_iff zero_less_one)

lemma bigo_alt_def: "O(f) = {h. \<exists>c. 0 < c \<and> (\<forall>x. \<bar>h x\<bar> \<le> c * \<bar>f x\<bar>)}"
  by (auto simp add: bigo_def bigo_pos_const)

lemma bigo_elt_subset [intro]: "f \<in> O(g) \<Longrightarrow> O(f) \<le> O(g)"
  apply (auto simp add: bigo_alt_def)
  by (metis (no_types, opaque_lifting) mult.assoc mult_le_cancel_iff2 order.trans
      zero_less_mult_iff)

lemma bigo_refl [intro]: "f \<in> O(f)"
  using bigo_def comm_monoid_mult_class.mult_1 dual_order.eq_iff by blast

lemma bigo_zero: "0 \<in> O(g)"
  using bigo_def mult_le_cancel_left1 by fastforce

lemma bigo_zero2: "O(\<lambda>x. 0) = {\<lambda>x. 0}"
  by (auto simp add: bigo_def)

lemma bigo_plus_self_subset [intro]: "O(f) + O(f) \<subseteq> O(f)"
  apply (auto simp add: bigo_alt_def set_plus_def)
  apply (rule_tac x = "c + ca" in exI)
  by (smt (verit, best) abs_triangle_ineq add_mono add_pos_pos comm_semiring_class.distrib dual_order.trans)

lemma bigo_plus_idemp [simp]: "O(f) + O(f) = O(f)"
  by (simp add: antisym bigo_plus_self_subset bigo_zero set_zero_plus2)

lemma bigo_plus_subset [intro]: "O(f + g) \<subseteq> O(f) + O(g)"
  apply (rule subsetI)
  apply (auto simp add: bigo_def bigo_pos_const func_plus set_plus_def)
  apply (subst bigo_pos_const [symmetric])+
  apply (rule_tac x = "\<lambda>n. if \<bar>g n\<bar> \<le> \<bar>f n\<bar> then x n else 0" in exI)
  apply (rule conjI)
   apply (rule_tac x = "c + c" in exI)
   apply (clarsimp)
  apply (smt (verit, ccfv_threshold) mult.commute abs_triangle_ineq add_le_cancel_left dual_order.trans mult.left_commute mult_2 mult_le_cancel_iff2)
  apply (simp add: order_less_le)
  apply (rule_tac x = "\<lambda>n. if \<bar>f n\<bar> < \<bar>g n\<bar> then x n else 0" in exI)
  apply (rule conjI)
   apply (rule_tac x = "c + c" in exI)
   apply auto
  apply (subgoal_tac "c * \<bar>f xa + g xa\<bar> \<le> (c + c) * \<bar>g xa\<bar>")
   apply (metis mult_2 order.trans)
  apply simp
  done

lemma bigo_plus_subset2 [intro]: "A \<subseteq> O(f) \<Longrightarrow> B \<subseteq> O(f) \<Longrightarrow> A + B \<subseteq> O(f)"
  using bigo_plus_idemp set_plus_mono2 by blast

lemma bigo_plus_eq: "\<forall>x. 0 \<le> f x \<Longrightarrow> \<forall>x. 0 \<le> g x \<Longrightarrow> O(f + g) = O(f) + O(g)"
  apply (rule equalityI)
   apply (rule bigo_plus_subset)
  apply (simp add: bigo_alt_def set_plus_def func_plus)
  apply clarify
  apply (rule_tac x = "max c ca" in exI)
  by (smt (verit, del_insts) add.commute abs_triangle_ineq add_mono_thms_linordered_field(3) distrib_left less_max_iff_disj linorder_not_less max.orderE max_mult_distrib_right order_le_less)

lemma bigo_bounded_alt: "\<forall>x. 0 \<le> f x \<Longrightarrow> \<forall>x. f x \<le> c * g x \<Longrightarrow> f \<in> O(g)"
  by (simp add: bigo_def) (metis abs_mult abs_of_nonneg order_trans)

lemma bigo_bounded: "\<forall>x. 0 \<le> f x \<Longrightarrow> \<forall>x. f x \<le> g x \<Longrightarrow> f \<in> O(g)"
  by (metis bigo_bounded_alt mult_1)

lemma bigo_bounded2: "\<forall>x. lb x \<le> f x \<Longrightarrow> \<forall>x. f x \<le> lb x + g x \<Longrightarrow> f \<in> lb +o O(g)"
  by (simp add: add.commute bigo_bounded diff_le_eq set_minus_imp_plus)

lemma bigo_abs: "(\<lambda>x. \<bar>f x\<bar>) =o O(f)"
  by (smt (verit, del_insts) abs_abs bigo_def bigo_refl mem_Collect_eq)

lemma bigo_abs2: "f =o O(\<lambda>x. \<bar>f x\<bar>)"
  by (smt (verit, del_insts) abs_abs bigo_def bigo_refl mem_Collect_eq)

lemma bigo_abs3: "O(f) = O(\<lambda>x. \<bar>f x\<bar>)"
  using bigo_abs bigo_abs2 bigo_elt_subset by blast

lemma bigo_abs4: assumes "f =o g +o O(h)" shows "(\<lambda>x. \<bar>f x\<bar>) =o (\<lambda>x. \<bar>g x\<bar>) +o O(h)"
proof -
  { assume *: "f - g \<in> O(h)"
    have "(\<lambda>x. \<bar>f x\<bar> - \<bar>g x\<bar>) =o O(\<lambda>x. \<bar>\<bar>f x\<bar> - \<bar>g x\<bar>\<bar>)"
      by (rule bigo_abs2)
    also have "\<dots> \<subseteq> O(\<lambda>x. \<bar>f x - g x\<bar>)"
      by (simp add: abs_triangle_ineq3 bigo_bounded bigo_elt_subset)
    also have "\<dots> \<subseteq> O(f - g)"
      using bigo_abs3 by fastforce
    also from * have "\<dots> \<subseteq> O(h)"
      by (rule bigo_elt_subset)
    finally have "(\<lambda>x. \<bar>f x\<bar> - \<bar>g x\<bar>) \<in> O(h)" . }
  then show ?thesis
    by (smt (verit) assms bigo_alt_def fun_diff_def mem_Collect_eq set_minus_imp_plus set_plus_imp_minus)
qed

lemma bigo_abs5: "f =o O(g) \<Longrightarrow> (\<lambda>x. \<bar>f x\<bar>) =o O(g)"
  by (auto simp: bigo_def)

lemma bigo_elt_subset2 [intro]:
  assumes *: "f \<in> g +o O(h)"
  shows "O(f) \<subseteq> O(g) + O(h)"
proof -
  note *
  also have "g +o O(h) \<subseteq> O(g) + O(h)"
    by (auto del: subsetI)
  also have "\<dots> = O(\<lambda>x. \<bar>g x\<bar>) + O(\<lambda>x. \<bar>h x\<bar>)"
    by (subst bigo_abs3 [symmetric])+ (rule refl)
  also have "\<dots> = O((\<lambda>x. \<bar>g x\<bar>) + (\<lambda>x. \<bar>h x\<bar>))"
    by (rule bigo_plus_eq [symmetric]) auto
  finally have "f \<in> \<dots>" .
  then have "O(f) \<subseteq> \<dots>"
    by (elim bigo_elt_subset)
  also have "\<dots> = O(\<lambda>x. \<bar>g x\<bar>) + O(\<lambda>x. \<bar>h x\<bar>)"
    by (rule bigo_plus_eq, auto)
  finally show ?thesis
    by (simp flip: bigo_abs3)
qed

lemma bigo_mult [intro]: "O(f)*O(g) \<subseteq> O(f * g)"
  apply (rule subsetI)
  apply (subst bigo_def)
  apply (clarsimp simp add: bigo_alt_def set_times_def func_times)
  apply (rule_tac x = "c * ca" in exI)
  by (smt (verit, ccfv_threshold) mult.commute mult.assoc abs_ge_zero abs_mult dual_order.trans mult_mono)

lemma bigo_mult2 [intro]: "f *o O(g) \<subseteq> O(f * g)"
  by (metis bigo_mult bigo_refl dual_order.trans mult.commute set_times_mono4)

lemma bigo_mult3: "f \<in> O(h) \<Longrightarrow> g \<in> O(j) \<Longrightarrow> f * g \<in> O(h * j)"
  using bigo_mult mult.commute mult.commute set_times_intro subsetD by blast

lemma bigo_mult4 [intro]: "f \<in> k +o O(h) \<Longrightarrow> g * f \<in> (g * k) +o O(g * h)"
  by (metis bigo_mult3 bigo_refl left_diff_distrib' mult.commute set_minus_imp_plus set_plus_imp_minus)

lemma bigo_mult5:
  fixes f :: "'a \<Rightarrow> 'b::linordered_field"
  assumes "\<forall>x. f x \<noteq> 0"
  shows "O(f * g) \<subseteq> f *o O(g)"
proof
  fix h
  assume "h \<in> O(f * g)"
  then have "(\<lambda>x. 1 / (f x)) * h \<in> (\<lambda>x. 1 / f x) *o O(f * g)"
    by auto
  also have "\<dots> \<subseteq> O((\<lambda>x. 1 / f x) * (f * g))"
    by (rule bigo_mult2)
  also have "(\<lambda>x. 1 / f x) * (f * g) = g"
    using assms by auto
  finally have "(\<lambda>x. (1::'b) / f x) * h \<in> O(g)" .
  then have "f * ((\<lambda>x. (1::'b) / f x) * h) \<in> f *o O(g)"
    by auto
  also have "f * ((\<lambda>x. (1::'b) / f x) * h) = h"
  by (simp add: assms times_fun_def)
  finally show "h \<in> f *o O(g)" .
qed

lemma bigo_mult6: "\<forall>x. f x \<noteq> 0 \<Longrightarrow> O(f * g) = f *o O(g)"
  for f :: "'a \<Rightarrow> 'b::linordered_field"
  by (simp add: bigo_mult2 bigo_mult5 subset_antisym)

lemma bigo_mult7: "\<forall>x. f x \<noteq> 0 \<Longrightarrow> O(f * g) \<subseteq> O(f) * O(g)"
  for f :: "'a \<Rightarrow> 'b::linordered_field"
  by (metis bigo_mult6 bigo_refl mult.commute set_times_mono4)

lemma bigo_mult8: "\<forall>x. f x \<noteq> 0 \<Longrightarrow> O(f * g) = O(f) * O(g)"
  for f :: "'a \<Rightarrow> 'b::linordered_field"
  by (simp add: bigo_mult bigo_mult7 subset_antisym)

lemma bigo_minus [intro]: "f \<in> O(g) \<Longrightarrow> - f \<in> O(g)"
  by (auto simp add: bigo_def fun_Compl_def)

lemma bigo_minus2:
  assumes "f \<in> g +o O(h)" shows "- f \<in> -g +o O(h)"
proof -
   have "- f + g \<in> O(h)"
    by (metis assms bigo_minus minus_diff_eq set_plus_imp_minus uminus_add_conv_diff)
  then show ?thesis
    by (simp add: set_minus_imp_plus)
qed

lemma bigo_minus3: "O(- f) = O(f)"
  by (auto simp add: bigo_def fun_Compl_def)

lemma bigo_plus_absorb_lemma1:
  assumes *: "f \<in> O(g)"
  shows "f +o O(g) \<subseteq> O(g)"
  using assms bigo_plus_idemp set_plus_mono4 by blast

lemma bigo_plus_absorb_lemma2:
  assumes *: "f \<in> O(g)"
  shows "O(g) \<subseteq> f +o O(g)"
proof -
  from * have "- f \<in> O(g)"
    by auto
  then have "- f +o O(g) \<subseteq> O(g)"
    by (elim bigo_plus_absorb_lemma1)
  then have "f +o (- f +o O(g)) \<subseteq> f +o O(g)"
    by auto
  also have "f +o (- f +o O(g)) = O(g)"
    by (simp add: set_plus_rearranges)
  finally show ?thesis .
qed

lemma bigo_plus_absorb [simp]: "f \<in> O(g) \<Longrightarrow> f +o O(g) = O(g)"
  by (simp add: bigo_plus_absorb_lemma1 bigo_plus_absorb_lemma2 subset_antisym)

lemma bigo_plus_absorb2 [intro]: "f \<in> O(g) \<Longrightarrow> A \<subseteq> O(g) \<Longrightarrow> f +o A \<subseteq> O(g)"
  using bigo_plus_absorb set_plus_mono by blast

lemma bigo_add_commute_imp: "f \<in> g +o O(h) \<Longrightarrow> g \<in> f +o O(h)"
  by (metis bigo_minus minus_diff_eq set_minus_imp_plus set_plus_imp_minus)

lemma bigo_add_commute: "f \<in> g +o O(h) \<longleftrightarrow> g \<in> f +o O(h)"
  using bigo_add_commute_imp by blast

lemma bigo_const1: "(\<lambda>x. c) \<in> O(\<lambda>x. 1)"
  by (auto simp add: bigo_def ac_simps)

lemma bigo_const2 [intro]: "O(\<lambda>x. c) \<subseteq> O(\<lambda>x. 1)"
  by (metis bigo_elt_subset bigo_const1)

lemma bigo_const3: "c \<noteq> 0 \<Longrightarrow> (\<lambda>x. 1) \<in> O(\<lambda>x. c)"
  for c :: "'a::linordered_field"
  by (metis bigo_bounded_alt le_numeral_extra(4) nonzero_divide_eq_eq zero_less_one_class.zero_le_one)

lemma bigo_const4: "c \<noteq> 0 \<Longrightarrow> O(\<lambda>x. 1) \<subseteq> O(\<lambda>x. c)"
  for c :: "'a::linordered_field"
  by (metis bigo_elt_subset bigo_const3)

lemma bigo_const [simp]: "c \<noteq> 0 \<Longrightarrow> O(\<lambda>x. c) = O(\<lambda>x. 1)"
  for c :: "'a::linordered_field"
  by (metis equalityI bigo_const2 bigo_const4)

lemma bigo_const_mult1: "(\<lambda>x. c * f x) \<in> O(f)"
  by (smt (z3) abs_mult bigo_def bigo_refl mem_Collect_eq mult.left_commute mult_commute_abs)

lemma bigo_const_mult2: "O(\<lambda>x. c * f x) \<subseteq> O(f)"
  by (metis bigo_elt_subset bigo_const_mult1)

lemma bigo_const_mult3: "c \<noteq> 0 \<Longrightarrow> f \<in> O(\<lambda>x. c * f x)"
  for c :: "'a::linordered_field"
  by (simp add: bigo_def) (metis abs_mult field_class.field_divide_inverse mult.commute nonzero_divide_eq_eq order_refl)

lemma bigo_const_mult4: "c \<noteq> 0 \<Longrightarrow> O(f) \<subseteq> O(\<lambda>x. c * f x)"
  for c :: "'a::linordered_field"
  by (simp add: bigo_const_mult3 bigo_elt_subset)

lemma bigo_const_mult [simp]: "c \<noteq> 0 \<Longrightarrow> O(\<lambda>x. c * f x) = O(f)"
  for c :: "'a::linordered_field"
  by (simp add: bigo_const_mult2 bigo_const_mult4 subset_antisym)

lemma bigo_const_mult5 [simp]: "(\<lambda>x. c) *o O(f) = O(f)" if "c \<noteq> 0"
  for c :: "'a::linordered_field"
proof
  show "O(f) \<subseteq> (\<lambda>x. c) *o O(f)"
    using that
    apply (clarsimp simp add: bigo_def elt_set_times_def func_times)
    apply (rule_tac x = "\<lambda>y. inverse c * x y" in exI)
    apply (simp add: mult.assoc [symmetric] abs_mult)
    apply (rule_tac x = "\<bar>inverse c\<bar> * ca" in exI)
    apply auto
    done
  have "O(\<lambda>x. c * f x) \<subseteq> O(f)"
    by (simp add: bigo_const_mult2)
  then show "(\<lambda>x. c) *o O(f) \<subseteq> O(f)"
    using order_trans[OF bigo_mult2] by (force simp add: times_fun_def)
qed

lemma bigo_const_mult6 [intro]: "(\<lambda>x. c) *o O(f) \<subseteq> O(f)"
  apply (auto intro!: simp add: bigo_def elt_set_times_def func_times)
  apply (rule_tac x = "ca * \<bar>c\<bar>" in exI)
  by (smt (verit, ccfv_SIG) ab_semigroup_mult_class.mult_ac(1) abs_abs abs_le_self_iff abs_mult le_cases3 mult.commute mult_left_mono)

lemma bigo_const_mult7 [intro]:
  assumes *: "f =o O(g)"
  shows "(\<lambda>x. c * f x) =o O(g)"
proof -
  from * have "(\<lambda>x. c) * f =o (\<lambda>x. c) *o O(g)"
    by auto
  also have "(\<lambda>x. c) * f = (\<lambda>x. c * f x)"
    by (simp add: func_times)
  also have "(\<lambda>x. c) *o O(g) \<subseteq> O(g)"
    by (auto del: subsetI)
  finally show ?thesis .
qed

lemma bigo_compose1: "f =o O(g) \<Longrightarrow> (\<lambda>x. f (k x)) =o O(\<lambda>x. g (k x))"
  by (auto simp: bigo_def)

lemma bigo_compose2: "f =o g +o O(h) \<Longrightarrow> (\<lambda>x. f (k x)) =o (\<lambda>x. g (k x)) +o O(\<lambda>x. h(k x))"
  by (smt (verit, best) set_minus_plus bigo_def fun_diff_def mem_Collect_eq)

subsection \<open>Sum\<close>

lemma bigo_sum_main:
  assumes "\<forall>x. \<forall>y \<in> A x. 0 \<le> h x y" and "\<forall>x. \<forall>y \<in> A x. \<bar>f x y\<bar> \<le> c * h x y"
  shows "(\<lambda>x. \<Sum>y \<in> A x. f x y) =o O(\<lambda>x. \<Sum>y \<in> A x. h x y)"
proof -
  have "(\<Sum>i\<in>A x. \<bar>f x i\<bar>) \<le> \<bar>c\<bar> * sum (h x) (A x)" for x
    by (smt (verit, ccfv_threshold) assms abs_mult_pos abs_of_nonneg abs_of_nonpos dual_order.trans le_cases3 neg_0_le_iff_le sum_distrib_left sum_mono)
  then show ?thesis
    using assms by (fastforce simp add: bigo_def sum_nonneg intro: order_trans [OF sum_abs])
qed

lemma bigo_sum1: "\<forall>x y. 0 \<le> h x y \<Longrightarrow>
    \<exists>c. \<forall>x y. \<bar>f x y\<bar> \<le> c * h x y \<Longrightarrow>
      (\<lambda>x. \<Sum>y \<in> A x. f x y) =o O(\<lambda>x. \<Sum>y \<in> A x. h x y)"
  by (metis (no_types) bigo_sum_main)

lemma bigo_sum2: "\<forall>y. 0 \<le> h y \<Longrightarrow>
    \<exists>c. \<forall>y. \<bar>f y\<bar> \<le> c * (h y) \<Longrightarrow>
      (\<lambda>x. \<Sum>y \<in> A x. f y) =o O(\<lambda>x. \<Sum>y \<in> A x. h y)"
  by (rule bigo_sum1) auto

lemma bigo_sum3: "f =o O(h) \<Longrightarrow>
    (\<lambda>x. \<Sum>y \<in> A x. l x y * f (k x y)) =o O(\<lambda>x. \<Sum>y \<in> A x. \<bar>l x y * h (k x y)\<bar>)"
  apply (rule bigo_sum1)
  using abs_ge_zero apply blast
  apply (clarsimp simp: bigo_def)
  by (smt (verit, ccfv_threshold) abs_mult abs_not_less_zero mult.left_commute mult_le_cancel_left)

lemma bigo_sum4: "f =o g +o O(h) \<Longrightarrow>
    (\<lambda>x. \<Sum>y \<in> A x. l x y * f (k x y)) =o
      (\<lambda>x. \<Sum>y \<in> A x. l x y * g (k x y)) +o
        O(\<lambda>x. \<Sum>y \<in> A x. \<bar>l x y * h (k x y)\<bar>)"
  using bigo_sum3 [of "f-g" h l k A]
  apply (simp add: algebra_simps sum_subtractf)
  by (smt (verit) bigo_alt_def minus_apply set_minus_imp_plus set_plus_imp_minus mem_Collect_eq)

lemma bigo_sum5: "f =o O(h) \<Longrightarrow> \<forall>x y. 0 \<le> l x y \<Longrightarrow>
    \<forall>x. 0 \<le> h x \<Longrightarrow>
      (\<lambda>x. \<Sum>y \<in> A x. l x y * f (k x y)) =o
        O(\<lambda>x. \<Sum>y \<in> A x. l x y * h (k x y))"
  using bigo_sum3 [of f h l k A] by simp

lemma bigo_sum6: "f =o g +o O(h) \<Longrightarrow> \<forall>x y. 0 \<le> l x y \<Longrightarrow>
    \<forall>x. 0 \<le> h x \<Longrightarrow>
      (\<lambda>x. \<Sum>y \<in> A x. l x y * f (k x y)) =o
        (\<lambda>x. \<Sum>y \<in> A x. l x y * g (k x y)) +o
          O(\<lambda>x. \<Sum>y \<in> A x. l x y * h (k x y))"
  using bigo_sum5 [of "f-g" h l k A]
  apply (simp add: algebra_simps sum_subtractf)
  by (smt (verit, del_insts) bigo_alt_def set_minus_imp_plus minus_apply set_plus_imp_minus mem_Collect_eq)

subsection \<open>Misc useful stuff\<close>

lemma bigo_useful_add: "f =o O(h) \<Longrightarrow> g =o O(h) \<Longrightarrow> f + g =o O(h)"
  using bigo_plus_idemp set_plus_intro by blast

lemma bigo_useful_const_mult: "c \<noteq> 0 \<Longrightarrow> (\<lambda>x. c) * f =o O(h) \<Longrightarrow> f =o O(h)"
  for c :: "'a::linordered_field"
  using bigo_elt_subset bigo_mult6 by fastforce

lemma bigo_fix: "(\<lambda>x::nat. f (x + 1)) =o O(\<lambda>x. h (x + 1)) \<Longrightarrow> f 0 = 0 \<Longrightarrow> f =o O(h)"
  by (simp add: bigo_alt_def) (metis abs_eq_0_iff abs_ge_zero abs_mult abs_of_pos not0_implies_Suc)

lemma bigo_fix2:
  "(\<lambda>x. f ((x::nat) + 1)) =o (\<lambda>x. g(x + 1)) +o O(\<lambda>x. h(x + 1)) \<Longrightarrow>
       f 0 = g 0 \<Longrightarrow> f =o g +o O(h)"
  apply (rule set_minus_imp_plus [OF bigo_fix])
   apply (smt (verit, del_insts) bigo_alt_def fun_diff_def set_plus_imp_minus mem_Collect_eq)
  apply simp
  done

subsection \<open>Less than or equal to\<close>

definition lesso :: "('a \<Rightarrow> 'b::linordered_idom) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"  (infixl "<o" 70)
  where "f <o g = (\<lambda>x. max (f x - g x) 0)"

lemma bigo_lesseq1: "f =o O(h) \<Longrightarrow> \<forall>x. \<bar>g x\<bar> \<le> \<bar>f x\<bar> \<Longrightarrow> g =o O(h)"
  by (smt (verit, del_insts) bigo_def mem_Collect_eq order_trans)

lemma bigo_lesseq2: "f =o O(h) \<Longrightarrow> \<forall>x. \<bar>g x\<bar> \<le> f x \<Longrightarrow> g =o O(h)"
  by (metis (mono_tags, lifting) abs_ge_zero abs_of_nonneg bigo_lesseq1 dual_order.trans)

lemma bigo_lesseq3: "f =o O(h) \<Longrightarrow> \<forall>x. 0 \<le> g x \<Longrightarrow> \<forall>x. g x \<le> f x \<Longrightarrow> g =o O(h)"
  by (meson bigo_bounded bigo_elt_subset subsetD)

lemma bigo_lesseq4: "f =o O(h) \<Longrightarrow> \<forall>x. 0 \<le> g x \<Longrightarrow> \<forall>x. g x \<le> \<bar>f x\<bar> \<Longrightarrow> g =o O(h)"
  by (metis abs_of_nonneg bigo_lesseq1)

lemma bigo_lesso1: "\<forall>x. f x \<le> g x \<Longrightarrow> f <o g =o O(h)"
  by (smt (verit, del_insts) abs_ge_zero add_0 bigo_abs3 bigo_bounded diff_le_eq lesso_def max_def order_refl)

lemma bigo_lesso2: "f =o g +o O(h) \<Longrightarrow> \<forall>x. 0 \<le> k x \<Longrightarrow> \<forall>x. k x \<le> f x \<Longrightarrow> k <o g =o O(h)"
  unfolding lesso_def
  apply (rule bigo_lesseq4 [of "f-g"])
    apply (erule set_plus_imp_minus)
  using max.cobounded2 apply blast
  by (smt (verit) abs_ge_zero abs_of_nonneg diff_ge_0_iff_ge diff_mono diff_self fun_diff_def order_refl max.coboundedI2 max_def)

lemma bigo_lesso3: "f =o g +o O(h) \<Longrightarrow> \<forall>x. 0 \<le> k x \<Longrightarrow> \<forall>x. g x \<le> k x \<Longrightarrow> f <o k =o O(h)"
  unfolding lesso_def
  apply (rule bigo_lesseq4 [of "f-g"])
    apply (erule set_plus_imp_minus)
  using max.cobounded2 apply blast
  by (smt (verit) abs_eq_iff abs_ge_zero abs_if abs_minus_le_zero diff_left_mono fun_diff_def le_max_iff_disj order.trans order_eq_refl)

lemma bigo_lesso4:
  fixes k :: "'a \<Rightarrow> 'b::linordered_field"
  assumes f: "f <o g =o O(k)" and g: "g =o h +o O(k)"
  shows "f <o h =o O(k)"
proof -
  have "g - h \<in> O(k)"
    by (simp add: g set_plus_imp_minus)
  then have "(\<lambda>x. \<bar>g x - h x\<bar>) \<in> O(k)"
    using bigo_abs5 by force
  then have \<section>: "(\<lambda>x. max (f x - g x) 0) + (\<lambda>x. \<bar>g x - h x\<bar>) \<in> O(k)"
    by (metis (mono_tags, lifting) bigo_lesseq1 bigo_useful_add dual_order.eq_iff f lesso_def)
  have "\<bar>max (f x - h x) 0\<bar> \<le> ((\<lambda>x. max (f x - g x) 0) + (\<lambda>x. \<bar>g x - h x\<bar>)) x" for x
    by (auto simp add: func_plus fun_diff_def algebra_simps split: split_max abs_split)
  then show ?thesis
    by (smt (verit, ccfv_SIG) \<section> bigo_lesseq2 lesso_def)
qed

lemma bigo_lesso5:
  assumes "f <o g =o O(h)" shows "\<exists>C. \<forall>x. f x \<le> g x + C * \<bar>h x\<bar>"
proof -
  obtain c where "0 < c" and c: "\<And>x. f x - g x \<le> c * \<bar>h x\<bar>"
    using assms by (auto simp: lesso_def bigo_alt_def)
  have "\<bar>max (f x - g x) 0\<bar> = max (f x - g x) 0" for x
    by (auto simp add: algebra_simps)
  then show ?thesis
    by (metis c add.commute diff_le_eq)
qed

lemma lesso_add: "f <o g =o O(h) \<Longrightarrow> k <o l =o O(h) \<Longrightarrow> (f + k) <o (g + l) =o O(h)"
  unfolding lesso_def
  using bigo_useful_add by (fastforce split: split_max intro: bigo_lesseq3)

lemma bigo_LIMSEQ1: "f \<longlonglongrightarrow> 0" if f: "f =o O(g)" and g: "g \<longlonglongrightarrow> 0"
  for f g :: "nat \<Rightarrow> real"
proof -
  { fix r::real
    assume "0 < r"
    obtain c::real where "0 < c"  and rc: "\<And>x. \<bar>f x\<bar> \<le> c * \<bar>g x\<bar>"
      using f by (auto simp: LIMSEQ_iff bigo_alt_def)
    with g \<open>0 < r\<close> obtain no where "\<forall>n\<ge>no. \<bar>g n\<bar> < r/c"
      by (fastforce simp: LIMSEQ_iff)
    then have "\<exists>no. \<forall>n\<ge>no. \<bar>f n\<bar> < r"
      by (metis \<open>0 < c\<close> mult.commute order_le_less_trans pos_less_divide_eq rc) }
  then show ?thesis
    by (auto simp: LIMSEQ_iff)
qed

lemma bigo_LIMSEQ2:
  fixes f g :: "nat \<Rightarrow> real"
  assumes "f =o g +o O(h)" "h \<longlonglongrightarrow> 0" and f: "f \<longlonglongrightarrow> a"
  shows  "g \<longlonglongrightarrow> a"
proof -
  have "f - g \<longlonglongrightarrow> 0"
    using assms bigo_LIMSEQ1 set_plus_imp_minus by blast
  then have "(\<lambda>n. f n - g n) \<longlonglongrightarrow> 0"
    by (simp add: fun_diff_def)
  then show ?thesis
    using Lim_transform_eq f by blast
qed

end


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

section\<open>Arithmetic with simplification\<close>

theory ArithSimp
imports Arith
begin

ML_file "~~/src/Provers/Arith/cancel_numerals.ML"
ML_file "~~/src/Provers/Arith/combine_numerals.ML"
ML_file "arith_data.ML"

subsection\<open>Difference\<close>

lemma diff_self_eq_0 [simp]: "m #- m = 0"
apply (subgoal_tac "natify (m) #- natify (m) = 0")
apply (rule_tac [2] natify_in_nat [THEN nat_induct], auto)
done

(**Addition is the inverse of subtraction**)

(*We need m:nat even if we replace the RHS by natify(m), for consider e.g.
  n=2, m=omega; then n + (m-n) = 2 + (0-2) = 2 \<noteq> 0 = natify(m).*)
lemma add_diff_inverse: "[| n \<le> m;  m:nat |] ==> n #+ (m#-n) = m"
apply (frule lt_nat_in_nat, erule nat_succI)
apply (erule rev_mp)
apply (rule_tac m = m and n = n in diff_induct, auto)
done

lemma add_diff_inverse2: "[| n \<le> m;  m:nat |] ==> (m#-n) #+ n = m"
apply (frule lt_nat_in_nat, erule nat_succI)
apply (simp (no_asm_simp) add: add_commute add_diff_inverse)
done

(*Proof is IDENTICAL to that of add_diff_inverse*)
lemma diff_succ: "[| n \<le> m;  m:nat |] ==> succ(m) #- n = succ(m#-n)"
apply (frule lt_nat_in_nat, erule nat_succI)
apply (erule rev_mp)
apply (rule_tac m = m and n = n in diff_induct)
apply (simp_all (no_asm_simp))
done

lemma zero_less_diff [simp]:
     "[| m: nat; n: nat |] ==> 0 < (n #- m)   \<longleftrightarrow>   m<n"
apply (rule_tac m = m and n = n in diff_induct)
apply (simp_all (no_asm_simp))
done

(** Difference distributes over multiplication **)

lemma diff_mult_distrib: "(m #- n) #* k = (m #* k) #- (n #* k)"
apply (subgoal_tac " (natify (m) #- natify (n)) #* natify (k) = (natify (m) #* natify (k)) #- (natify (n) #* natify (k))")
apply (rule_tac [2] m = "natify (m) " and n = "natify (n) " in diff_induct)
apply (simp_all add: diff_cancel)
done

lemma diff_mult_distrib2: "k #* (m #- n) = (k #* m) #- (k #* n)"
apply (simp (no_asm) add: mult_commute [of k] diff_mult_distrib)
done

subsection\<open>Remainder\<close>

(*We need m:nat even with natify*)
lemma div_termination: "[| 0<n;  n \<le> m;  m:nat |] ==> m #- n < m"
apply (frule lt_nat_in_nat, erule nat_succI)
apply (erule rev_mp)
apply (erule rev_mp)
apply (rule_tac m = m and n = n in diff_induct)
apply (simp_all (no_asm_simp) add: diff_le_self)
done

(*for mod and div*)
lemmas div_rls =
    nat_typechecks Ord_transrec_type apply_funtype
    div_termination [THEN ltD]
    nat_into_Ord not_lt_iff_le [THEN iffD1]

lemma raw_mod_type: "[| m:nat;  n:nat |] ==> raw_mod (m, n) \<in> nat"
apply (unfold raw_mod_def)
apply (rule Ord_transrec_type)
apply (auto simp add: nat_into_Ord [THEN Ord_0_lt_iff])
apply (blast intro: div_rls)
done

lemma mod_type [TC,iff]: "m mod n \<in> nat"
apply (unfold mod_def)
apply (simp (no_asm) add: mod_def raw_mod_type)
done

(** Aribtrary definitions for division by zero.  Useful to simplify
    certain equations **)

lemma DIVISION_BY_ZERO_DIV: "a div 0 = 0"
apply (unfold div_def)
apply (rule raw_div_def [THEN def_transrec, THEN trans])
apply (simp (no_asm_simp))
done  (*NOT for adding to default simpset*)

lemma DIVISION_BY_ZERO_MOD: "a mod 0 = natify(a)"
apply (unfold mod_def)
apply (rule raw_mod_def [THEN def_transrec, THEN trans])
apply (simp (no_asm_simp))
done  (*NOT for adding to default simpset*)

lemma raw_mod_less: "m<n ==> raw_mod (m,n) = m"
apply (rule raw_mod_def [THEN def_transrec, THEN trans])
apply (simp (no_asm_simp) add: div_termination [THEN ltD])
done

lemma mod_less [simp]: "[| m<n; n \<in> nat |] ==> m mod n = m"
apply (frule lt_nat_in_nat, assumption)
apply (simp (no_asm_simp) add: mod_def raw_mod_less)
done

lemma raw_mod_geq:
     "[| 0<n; n \<le> m;  m:nat |] ==> raw_mod (m, n) = raw_mod (m#-n, n)"
apply (frule lt_nat_in_nat, erule nat_succI)
apply (rule raw_mod_def [THEN def_transrec, THEN trans])
apply (simp (no_asm_simp) add: div_termination [THEN ltD] not_lt_iff_le [THEN iffD2], blast)
done

lemma mod_geq: "[| n \<le> m;  m:nat |] ==> m mod n = (m#-n) mod n"
apply (frule lt_nat_in_nat, erule nat_succI)
apply (case_tac "n=0")
 apply (simp add: DIVISION_BY_ZERO_MOD)
apply (simp add: mod_def raw_mod_geq nat_into_Ord [THEN Ord_0_lt_iff])
done

subsection\<open>Division\<close>

lemma raw_div_type: "[| m:nat;  n:nat |] ==> raw_div (m, n) \<in> nat"
apply (unfold raw_div_def)
apply (rule Ord_transrec_type)
apply (auto simp add: nat_into_Ord [THEN Ord_0_lt_iff])
apply (blast intro: div_rls)
done

lemma div_type [TC,iff]: "m div n \<in> nat"
apply (unfold div_def)
apply (simp (no_asm) add: div_def raw_div_type)
done

lemma raw_div_less: "m<n ==> raw_div (m,n) = 0"
apply (rule raw_div_def [THEN def_transrec, THEN trans])
apply (simp (no_asm_simp) add: div_termination [THEN ltD])
done

lemma div_less [simp]: "[| m<n; n \<in> nat |] ==> m div n = 0"
apply (frule lt_nat_in_nat, assumption)
apply (simp (no_asm_simp) add: div_def raw_div_less)
done

lemma raw_div_geq: "[| 0<n;  n \<le> m;  m:nat |] ==> raw_div(m,n) = succ(raw_div(m#-n, n))"
apply (subgoal_tac "n \<noteq> 0")
prefer 2 apply blast
apply (frule lt_nat_in_nat, erule nat_succI)
apply (rule raw_div_def [THEN def_transrec, THEN trans])
apply (simp (no_asm_simp) add: div_termination [THEN ltD] not_lt_iff_le [THEN iffD2] )
done

lemma div_geq [simp]:
     "[| 0<n;  n \<le> m;  m:nat |] ==> m div n = succ ((m#-n) div n)"
apply (frule lt_nat_in_nat, erule nat_succI)
apply (simp (no_asm_simp) add: div_def raw_div_geq)
done

declare div_less [simp] div_geq [simp]

(*A key result*)
lemma mod_div_lemma: "[| m: nat;  n: nat |] ==> (m div n)#*n #+ m mod n = m"
apply (case_tac "n=0")
 apply (simp add: DIVISION_BY_ZERO_MOD)
apply (simp add: nat_into_Ord [THEN Ord_0_lt_iff])
apply (erule complete_induct)
apply (case_tac "x<n")
txt\<open>case x<n\<close>
apply (simp (no_asm_simp))
txt\<open>case @{term"n \<le> x"}\<close>
apply (simp add: not_lt_iff_le add_assoc mod_geq div_termination [THEN ltD] add_diff_inverse)
done

lemma mod_div_equality_natify: "(m div n)#*n #+ m mod n = natify(m)"
apply (subgoal_tac " (natify (m) div natify (n))#*natify (n) #+ natify (m) mod natify (n) = natify (m) ")
apply force
apply (subst mod_div_lemma, auto)
done

lemma mod_div_equality: "m: nat ==> (m div n)#*n #+ m mod n = m"
apply (simp (no_asm_simp) add: mod_div_equality_natify)
done

subsection\<open>Further Facts about Remainder\<close>

text\<open>(mainly for mutilated chess board)\<close>

lemma mod_succ_lemma:
     "[| 0<n;  m:nat;  n:nat |]
      ==> succ(m) mod n = (if succ(m mod n) = n then 0 else succ(m mod n))"
apply (erule complete_induct)
apply (case_tac "succ (x) <n")
txt\<open>case succ(x) < n\<close>
 apply (simp (no_asm_simp) add: nat_le_refl [THEN lt_trans] succ_neq_self)
 apply (simp add: ltD [THEN mem_imp_not_eq])
txt\<open>case @{term"n \<le> succ(x)"}\<close>
apply (simp add: mod_geq not_lt_iff_le)
apply (erule leE)
 apply (simp (no_asm_simp) add: mod_geq div_termination [THEN ltD] diff_succ)
txt\<open>equality case\<close>
apply (simp add: diff_self_eq_0)
done

lemma mod_succ:
  "n:nat ==> succ(m) mod n = (if succ(m mod n) = n then 0 else succ(m mod n))"
apply (case_tac "n=0")
 apply (simp (no_asm_simp) add: natify_succ DIVISION_BY_ZERO_MOD)
apply (subgoal_tac "natify (succ (m)) mod n = (if succ (natify (m) mod n) = n then 0 else succ (natify (m) mod n))")
 prefer 2
 apply (subst natify_succ)
 apply (rule mod_succ_lemma)
  apply (auto simp del: natify_succ simp add: nat_into_Ord [THEN Ord_0_lt_iff])
done

lemma mod_less_divisor: "[| 0<n;  n:nat |] ==> m mod n < n"
apply (subgoal_tac "natify (m) mod n < n")
apply (rule_tac [2] i = "natify (m) " in complete_induct)
apply (case_tac [3] "x<n", auto)
txt\<open>case @{term"n \<le> x"}\<close>
apply (simp add: mod_geq not_lt_iff_le div_termination [THEN ltD])
done

lemma mod_1_eq [simp]: "m mod 1 = 0"
by (cut_tac n = 1 in mod_less_divisor, auto)

lemma mod2_cases: "b<2 ==> k mod 2 = b | k mod 2 = (if b=1 then 0 else 1)"
apply (subgoal_tac "k mod 2: 2")
 prefer 2 apply (simp add: mod_less_divisor [THEN ltD])
apply (drule ltD, auto)
done

lemma mod2_succ_succ [simp]: "succ(succ(m)) mod 2 = m mod 2"
apply (subgoal_tac "m mod 2: 2")
 prefer 2 apply (simp add: mod_less_divisor [THEN ltD])
apply (auto simp add: mod_succ)
done

lemma mod2_add_more [simp]: "(m#+m#+n) mod 2 = n mod 2"
apply (subgoal_tac " (natify (m) #+natify (m) #+n) mod 2 = n mod 2")
apply (rule_tac [2] n = "natify (m) " in nat_induct)
apply auto
done

lemma mod2_add_self [simp]: "(m#+m) mod 2 = 0"
by (cut_tac n = 0 in mod2_add_more, auto)

subsection\<open>Additional theorems about \<open>\<le>\<close>\<close>

lemma add_le_self: "m:nat ==> m \<le> (m #+ n)"
apply (simp (no_asm_simp))
done

lemma add_le_self2: "m:nat ==> m \<le> (n #+ m)"
apply (simp (no_asm_simp))
done

(*** Monotonicity of Multiplication ***)

lemma mult_le_mono1: "[| i \<le> j; j:nat |] ==> (i#*k) \<le> (j#*k)"
apply (subgoal_tac "natify (i) #*natify (k) \<le> j#*natify (k) ")
apply (frule_tac [2] lt_nat_in_nat)
apply (rule_tac [3] n = "natify (k) " in nat_induct)
apply (simp_all add: add_le_mono)
done

(* @{text"\<le>"} monotonicity, BOTH arguments*)
lemma mult_le_mono: "[| i \<le> j; k \<le> l; j:nat; l:nat |] ==> i#*k \<le> j#*l"
apply (rule mult_le_mono1 [THEN le_trans], assumption+)
apply (subst mult_commute, subst mult_commute, rule mult_le_mono1, assumption+)
done

(*strict, in 1st argument; proof is by induction on k>0.
  I can't see how to relax the typing conditions.*)
lemma mult_lt_mono2: "[| i<j; 0<k; j:nat; k:nat |] ==> k#*i < k#*j"
apply (erule zero_lt_natE)
apply (frule_tac [2] lt_nat_in_nat)
apply (simp_all (no_asm_simp))
apply (induct_tac "x")
apply (simp_all (no_asm_simp) add: add_lt_mono)
done

lemma mult_lt_mono1: "[| i<j; 0<k; j:nat; k:nat |] ==> i#*k < j#*k"
apply (simp (no_asm_simp) add: mult_lt_mono2 mult_commute [of _ k])
done

lemma add_eq_0_iff [iff]: "m#+n = 0 \<longleftrightarrow> natify(m)=0 & natify(n)=0"
apply (subgoal_tac "natify (m) #+ natify (n) = 0 \<longleftrightarrow> natify (m) =0 & natify (n) =0")
apply (rule_tac [2] n = "natify (m) " in natE)
 apply (rule_tac [4] n = "natify (n) " in natE)
apply auto
done

lemma zero_lt_mult_iff [iff]: "0 < m#*n \<longleftrightarrow> 0 < natify(m) & 0 < natify(n)"
apply (subgoal_tac "0 < natify (m) #*natify (n) \<longleftrightarrow> 0 < natify (m) & 0 < natify (n) ")
apply (rule_tac [2] n = "natify (m) " in natE)
 apply (rule_tac [4] n = "natify (n) " in natE)
  apply (rule_tac [3] n = "natify (n) " in natE)
apply auto
done

lemma mult_eq_1_iff [iff]: "m#*n = 1 \<longleftrightarrow> natify(m)=1 & natify(n)=1"
apply (subgoal_tac "natify (m) #* natify (n) = 1 \<longleftrightarrow> natify (m) =1 & natify (n) =1")
apply (rule_tac [2] n = "natify (m) " in natE)
 apply (rule_tac [4] n = "natify (n) " in natE)
apply auto
done

lemma mult_is_zero: "[|m: nat; n: nat|] ==> (m #* n = 0) \<longleftrightarrow> (m = 0 | n = 0)"
apply auto
apply (erule natE)
apply (erule_tac [2] natE, auto)
done

lemma mult_is_zero_natify [iff]:
     "(m #* n = 0) \<longleftrightarrow> (natify(m) = 0 | natify(n) = 0)"
apply (cut_tac m = "natify (m) " and n = "natify (n) " in mult_is_zero)
apply auto
done

subsection\<open>Cancellation Laws for Common Factors in Comparisons\<close>

lemma mult_less_cancel_lemma:
     "[| k: nat; m: nat; n: nat |] ==> (m#*k < n#*k) \<longleftrightarrow> (0<k & m<n)"
apply (safe intro!: mult_lt_mono1)
apply (erule natE, auto)
apply (rule not_le_iff_lt [THEN iffD1])
apply (drule_tac [3] not_le_iff_lt [THEN [2] rev_iffD2])
prefer 5 apply (blast intro: mult_le_mono1, auto)
done

lemma mult_less_cancel2 [simp]:
     "(m#*k < n#*k) \<longleftrightarrow> (0 < natify(k) & natify(m) < natify(n))"
apply (rule iff_trans)
apply (rule_tac [2] mult_less_cancel_lemma, auto)
done

lemma mult_less_cancel1 [simp]:
     "(k#*m < k#*n) \<longleftrightarrow> (0 < natify(k) & natify(m) < natify(n))"
apply (simp (no_asm) add: mult_less_cancel2 mult_commute [of k])
done

lemma mult_le_cancel2 [simp]: "(m#*k \<le> n#*k) \<longleftrightarrow> (0 < natify(k) \<longrightarrow> natify(m) \<le> natify(n))"
apply (simp (no_asm_simp) add: not_lt_iff_le [THEN iff_sym])
apply auto
done

lemma mult_le_cancel1 [simp]: "(k#*m \<le> k#*n) \<longleftrightarrow> (0 < natify(k) \<longrightarrow> natify(m) \<le> natify(n))"
apply (simp (no_asm_simp) add: not_lt_iff_le [THEN iff_sym])
apply auto
done

lemma mult_le_cancel_le1: "k \<in> nat ==> k #* m \<le> k \<longleftrightarrow> (0 < k \<longrightarrow> natify(m) \<le> 1)"
by (cut_tac k = k and m = m and n = 1 in mult_le_cancel1, auto)

lemma Ord_eq_iff_le: "[| Ord(m); Ord(n) |] ==> m=n \<longleftrightarrow> (m \<le> n & n \<le> m)"
by (blast intro: le_anti_sym)

lemma mult_cancel2_lemma:
     "[| k: nat; m: nat; n: nat |] ==> (m#*k = n#*k) \<longleftrightarrow> (m=n | k=0)"
apply (simp (no_asm_simp) add: Ord_eq_iff_le [of "m#*k"] Ord_eq_iff_le [of m])
apply (auto simp add: Ord_0_lt_iff)
done

lemma mult_cancel2 [simp]:
     "(m#*k = n#*k) \<longleftrightarrow> (natify(m) = natify(n) | natify(k) = 0)"
apply (rule iff_trans)
apply (rule_tac [2] mult_cancel2_lemma, auto)
done

lemma mult_cancel1 [simp]:
     "(k#*m = k#*n) \<longleftrightarrow> (natify(m) = natify(n) | natify(k) = 0)"
apply (simp (no_asm) add: mult_cancel2 mult_commute [of k])
done

(** Cancellation law for division **)

lemma div_cancel_raw:
     "[| 0<n; 0<k; k:nat; m:nat; n:nat |] ==> (k#*m) div (k#*n) = m div n"
apply (erule_tac i = m in complete_induct)
apply (case_tac "x<n")
 apply (simp add: div_less zero_lt_mult_iff mult_lt_mono2)
apply (simp add: not_lt_iff_le zero_lt_mult_iff le_refl [THEN mult_le_mono]
          div_geq diff_mult_distrib2 [symmetric] div_termination [THEN ltD])
done

lemma div_cancel:
     "[| 0 < natify(n);  0 < natify(k) |] ==> (k#*m) div (k#*n) = m div n"
apply (cut_tac k = "natify (k) " and m = "natify (m)" and n = "natify (n)"
       in div_cancel_raw)
apply auto
done

subsection\<open>More Lemmas about Remainder\<close>

lemma mult_mod_distrib_raw:
     "[| k:nat; m:nat; n:nat |] ==> (k#*m) mod (k#*n) = k #* (m mod n)"
apply (case_tac "k=0")
 apply (simp add: DIVISION_BY_ZERO_MOD)
apply (case_tac "n=0")
 apply (simp add: DIVISION_BY_ZERO_MOD)
apply (simp add: nat_into_Ord [THEN Ord_0_lt_iff])
apply (erule_tac i = m in complete_induct)
apply (case_tac "x<n")
 apply (simp (no_asm_simp) add: mod_less zero_lt_mult_iff mult_lt_mono2)
apply (simp add: not_lt_iff_le zero_lt_mult_iff le_refl [THEN mult_le_mono]
         mod_geq diff_mult_distrib2 [symmetric] div_termination [THEN ltD])
done

lemma mod_mult_distrib2: "k #* (m mod n) = (k#*m) mod (k#*n)"
apply (cut_tac k = "natify (k) " and m = "natify (m)" and n = "natify (n)"
       in mult_mod_distrib_raw)
apply auto
done

lemma mult_mod_distrib: "(m mod n) #* k = (m#*k) mod (n#*k)"
apply (simp (no_asm) add: mult_commute mod_mult_distrib2)
done

lemma mod_add_self2_raw: "n \<in> nat ==> (m #+ n) mod n = m mod n"
apply (subgoal_tac " (n #+ m) mod n = (n #+ m #- n) mod n")
apply (simp add: add_commute)
apply (subst mod_geq [symmetric], auto)
done

lemma mod_add_self2 [simp]: "(m #+ n) mod n = m mod n"
apply (cut_tac n = "natify (n) " in mod_add_self2_raw)
apply auto
done

lemma mod_add_self1 [simp]: "(n#+m) mod n = m mod n"
apply (simp (no_asm_simp) add: add_commute mod_add_self2)
done

lemma mod_mult_self1_raw: "k \<in> nat ==> (m #+ k#*n) mod n = m mod n"
apply (erule nat_induct)
apply (simp_all (no_asm_simp) add: add_left_commute [of _ n])
done

lemma mod_mult_self1 [simp]: "(m #+ k#*n) mod n = m mod n"
apply (cut_tac k = "natify (k) " in mod_mult_self1_raw)
apply auto
done

lemma mod_mult_self2 [simp]: "(m #+ n#*k) mod n = m mod n"
apply (simp (no_asm) add: mult_commute mod_mult_self1)
done

(*Lemma for gcd*)
lemma mult_eq_self_implies_10: "m = m#*n ==> natify(n)=1 | m=0"
apply (subgoal_tac "m: nat")
 prefer 2
 apply (erule ssubst)
 apply simp
apply (rule disjCI)
apply (drule sym)
apply (rule Ord_linear_lt [of "natify(n)" 1])
apply simp_all
 apply (subgoal_tac "m #* n = 0", simp)
 apply (subst mult_natify2 [symmetric])
 apply (simp del: mult_natify2)
apply (drule nat_into_Ord [THEN Ord_0_lt, THEN [2] mult_lt_mono2], auto)
done

lemma less_imp_succ_add [rule_format]:
     "[| m<n; n: nat |] ==> \<exists>k\<in>nat. n = succ(m#+k)"
apply (frule lt_nat_in_nat, assumption)
apply (erule rev_mp)
apply (induct_tac "n")
apply (simp_all (no_asm) add: le_iff)
apply (blast elim!: leE intro!: add_0_right [symmetric] add_succ_right [symmetric])
done

lemma less_iff_succ_add:
     "[| m: nat; n: nat |] ==> (m<n) \<longleftrightarrow> (\<exists>k\<in>nat. n = succ(m#+k))"
by (auto intro: less_imp_succ_add)

lemma add_lt_elim2:
     "\<lbrakk>a #+ d = b #+ c; a < b; b \<in> nat; c \<in> nat; d \<in> nat\<rbrakk> \<Longrightarrow> c < d"
by (drule less_imp_succ_add, auto)

lemma add_le_elim2:
     "\<lbrakk>a #+ d = b #+ c; a \<le> b; b \<in> nat; c \<in> nat; d \<in> nat\<rbrakk> \<Longrightarrow> c \<le> d"
by (drule less_imp_succ_add, auto)

subsubsection\<open>More Lemmas About Difference\<close>

lemma diff_is_0_lemma:
     "[| m: nat; n: nat |] ==> m #- n = 0 \<longleftrightarrow> m \<le> n"
apply (rule_tac m = m and n = n in diff_induct, simp_all)
done

lemma diff_is_0_iff: "m #- n = 0 \<longleftrightarrow> natify(m) \<le> natify(n)"
by (simp add: diff_is_0_lemma [symmetric])

lemma nat_lt_imp_diff_eq_0:
     "[| a:nat; b:nat; a<b |] ==> a #- b = 0"
by (simp add: diff_is_0_iff le_iff)

lemma raw_nat_diff_split:
     "[| a:nat; b:nat |] ==>
      (P(a #- b)) \<longleftrightarrow> ((a < b \<longrightarrow>P(0)) & (\<forall>d\<in>nat. a = b #+ d \<longrightarrow> P(d)))"
apply (case_tac "a < b")
 apply (force simp add: nat_lt_imp_diff_eq_0)
apply (rule iffI, force, simp)
apply (drule_tac x="a#-b" in bspec)
apply (simp_all add: Ordinal.not_lt_iff_le add_diff_inverse)
done

lemma nat_diff_split:
   "(P(a #- b)) \<longleftrightarrow>
    (natify(a) < natify(b) \<longrightarrow>P(0)) & (\<forall>d\<in>nat. natify(a) = b #+ d \<longrightarrow> P(d))"
apply (cut_tac P=P and a="natify(a)" and b="natify(b)" in raw_nat_diff_split)
apply simp_all
done

text\<open>Difference and less-than\<close>

lemma diff_lt_imp_lt: "[|(k#-i) < (k#-j); i\<in>nat; j\<in>nat; k\<in>nat|] ==> j<i"
apply (erule rev_mp)
apply (simp split: nat_diff_split, auto)
 apply (blast intro: add_le_self lt_trans1)
apply (rule not_le_iff_lt [THEN iffD1], auto)
apply (subgoal_tac "i #+ da < j #+ d", force)
apply (blast intro: add_le_lt_mono)
done

lemma lt_imp_diff_lt: "[|j<i; i\<le>k; k\<in>nat|] ==> (k#-i) < (k#-j)"
apply (frule le_in_nat, assumption)
apply (frule lt_nat_in_nat, assumption)
apply (simp split: nat_diff_split, auto)
  apply (blast intro: lt_asym lt_trans2)
 apply (blast intro: lt_irrefl lt_trans2)
apply (rule not_le_iff_lt [THEN iffD1], auto)
apply (subgoal_tac "j #+ d < i #+ da", force)
apply (blast intro: add_lt_le_mono)
done

lemma diff_lt_iff_lt: "[|i\<le>k; j\<in>nat; k\<in>nat|] ==> (k#-i) < (k#-j) \<longleftrightarrow> j<i"
apply (frule le_in_nat, assumption)
apply (blast intro: lt_imp_diff_lt diff_lt_imp_lt)
done

end


header {*  Marking Using a Set  *}

theory SetMark
imports Graph "../DataRefinementIBP/DataRefinement"
begin

text{*
We construct in this theory a diagram which computes all reachable nodes
from a given root node in a graph. The graph is defined in the theory
Graph and is given by a relation $next$ on the nodes of the graph.

The diagram has only three ordered situation
($\mathit{init} > \mathit{loop} > \mathit{final}$). The termination
variant is a pair of a situation and a natural number with the lexicographic
ordering. The idea of this ordering is that we can go from a bigger situation
to a smaller one, however if we stay in the same situation the second
component of the variant must decrease.

The idea of the algorithm is that it starts with a set $X$ containing the
root element and the root is marked. As long as $X$ is not empty, if $x\in X$
and $y$ is an unmarked sucessor of $x$ we add $y$ to $X$. If $x\in X$ has
no unmarked sucessors it is removed from $X$.
The algorithm terminates when $X$ is empty.
*}

datatype I = init | loop | final

declare I.split [split]

instantiation I :: well_founded_transitive
begin

definition
  less_I_def: "i < j \<equiv>  (j = init \<and> (i = loop \<or> i = final)) \<or> (j = loop \<and> i = final)"

definition
  less_eq_I_def:  "(i::I) \<le> (j::I) \<equiv> i = j \<or> i < j"

instance proof
fix x y z :: I
  assume "x < y" and "y < z" then  show  "x < z"
    apply (simp add: less_I_def)
    by auto
  next
fix x y :: I
  show  "x \<le> y <-> x = y \<or> x < y"
    by (simp add: less_eq_I_def)
  next
fix P fix a::I
  show " (\<forall> x. (\<forall> y. y < x \<longrightarrow> P y) \<longrightarrow> P x) \<Longrightarrow> P a"
    apply (case_tac "P final")
    apply (case_tac "P loop")
    apply (simp_all add: less_I_def)
    by blast
next
qed (simp)

end

text{*
The set $\mathit{path}\ S \ \mathit{mrk}$ contains all reachable nodes from S along paths with
unmarked nodes.
*}

lemma trascl_less: "x \<noteq> y \<Longrightarrow> (a, x) \<in> R\<^sup>* \<Longrightarrow>
    ((a,x) \<in> (R \<inter> (-{y})\<times>(-{y}))\<^sup>* \<or>  (y,x) \<in> R O (R \<inter> (-{y})\<times>(-{y}))\<^sup>* )"
  apply (drule_tac
    b = x and a = a and r = R and
    P = "\<lambda> x. (x \<noteq> y \<longrightarrow>((a,x) \<in> (R \<inter> (-{y})\<times>(-{y}))\<^sup>* \<or> (y,x) \<in> R O (R \<inter> (-{y})\<times>(-{y}))\<^sup>* ))"
    in rtrancl_induct)
  apply (auto simp: Compl_insert)
  apply (case_tac "ya = y")
  apply auto
  apply (rule_tac x = a and y = ya and z = z and r = "R \<inter> ((UNIV - {y}) \<times> (UNIV - {y}))" in rtrancl_trans)
  apply auto
  apply (case_tac "za = y")
  apply auto
  apply (drule_tac x = ya and y = za and z = z and r = "(R \<inter> (UNIV - {y}) \<times> (UNIV - {y}))" in rtrancl_trans)
  by auto

lemma (in graph) add_set [simp]: "x \<noteq> y \<Longrightarrow> x \<in> path S mrk \<Longrightarrow> x \<in> path (insert y S) (insert y mrk)"
  apply (simp add: path_def)
  apply clarify
  apply (drule_tac x = x and y = y and a = ya and R = "next \<inter> (- mrk) \<times> (- mrk)" in trascl_less)
  apply simp_all
  apply (case_tac "(ya, x) \<in> (next \<inter> (- mrk) \<times> - mrk \<inter> (- {y}) \<times> - {y})\<^sup>*")
  apply (rule_tac x = xa in exI)
  apply simp_all
  apply (simp add: relcomp_unfold)
  apply (rule_tac x = ya in exI)
  apply simp
  apply (case_tac "(next \<inter> (- mrk) \<times> - mrk \<inter> (- {y}) \<times> - {y}) = (next \<inter> (- insert y mrk) \<times> - insert y mrk)")
  apply simp_all
  apply safe
  apply simp_all
  apply (rule_tac x = y in exI)
  apply simp
  apply (simp add: relcomp_unfold)
  apply (rule_tac x = yaa in exI)
  apply simp
  apply (case_tac "(next \<inter> (- mrk) \<times> - mrk \<inter> (- {y}) \<times> - {y}) = (next \<inter> (- insert y mrk) \<times> - insert y mrk)")
  apply simp_all
  by auto

lemma (in graph) add_set2: "x \<in> path S mrk \<Longrightarrow> x \<notin> path (insert y S) (insert y mrk) \<Longrightarrow> x = y"
  apply (case_tac "x \<noteq> y")
  apply (frule add_set)
  by simp_all

lemma (in graph) del_stack [simp]: "(\<forall> y . (t, y) \<in> next \<longrightarrow> y \<in> mrk) \<Longrightarrow> x \<notin>  mrk \<Longrightarrow> x \<in> path S mrk \<Longrightarrow> x \<in> path (S - {t}) mrk"
  apply (simp add: path_def)
  apply clarify
  apply (rule_tac x = xa in exI)
  apply (case_tac "x = y")
  apply auto
  apply (drule_tac a = y and b = x and R = "(next \<inter> (- mrk) \<times> - mrk)" in rtranclD)
  apply safe
  apply (drule_tac x = y and y = x in tranclD)
  by auto

lemma (in graph) init_set [simp]: "x \<in> reach root \<Longrightarrow> x \<noteq> root \<Longrightarrow> x \<in> path {root} {root}"
  apply (simp add: reach_def path_def)
  apply (case_tac "root \<noteq> x")
  apply (drule_tac a = root and x = x and y = root and R = "next" in trascl_less)
  apply (simp_all add: Compl_insert)
  apply safe
  apply (drule_tac a = root and b = x and R = "(next \<inter> (UNIV - {root}) \<times> (UNIV - {root}))" in rtranclD)
  apply safe
  apply (drule_tac x = root and y = x in tranclD)
  by auto

lemma (in graph)  init_set2: "x \<in> reach root \<Longrightarrow> x \<notin> path {root} {root} \<Longrightarrow> x = root"
  apply (case_tac "root \<noteq> x")
  apply (drule init_set)
  by simp_all

subsection {* Transitions *}

definition (in graph)
  "Q1_a \<equiv> [: X, mrk \<leadsto> X', mrk'. (root::'node) = nil \<and> X' = {} \<and> mrk' = mrk :]"

definition (in graph)
  "Q2_a \<equiv> [: X, mrk \<leadsto> X', mrk' .
       (root::'node) \<noteq> nil \<and> X' = {root::'node} \<and> mrk' = {root::'node} :]"

definition (in graph)
  "Q3_a \<equiv> [: X, mrk \<leadsto> X', mrk' .
        (\<exists> x \<in> X . \<exists> y . (x, y) \<in> next \<and> y \<notin> mrk \<and> X' = X \<union> {y} \<and> mrk' = mrk \<union> {y}):]"

definition (in graph)
  "Q4_a \<equiv> [: X, mrk \<leadsto> X', mrk' .
        (\<exists> x \<in> X . (\<forall> y . (x, y) \<in> next \<longrightarrow> y \<in> mrk) \<and> X' = X - {x} \<and> mrk' = mrk):]"

definition (in graph)
  "Q5_a \<equiv> [: X, mrk \<leadsto> X', mrk' . X = {} \<and> mrk = mrk' :]"

subsection {* Invariants *}

definition (in graph)
  "Loop \<equiv> { (X, mrk) .
      finite (-mrk) \<and> finite X \<and> X \<subseteq> mrk \<and>
      mrk \<subseteq> reach root \<and> reach root \<inter> -mrk \<subseteq> path X mrk}"

definition
  "trm \<equiv> \<lambda> (X, mrk) . 2 * card (-mrk) + card X"

definition
  "term_eq t w = {s . t s = w}"

definition
  "term_less t w = {s . t s < w}"

lemma union_term_eq [simp]:  "(\<Union> w . term_eq t w) = UNIV"
  apply (simp add: term_eq_def)
  by auto

lemma union_less_term_eq [simp]: "(\<Union>v\<in>{v. v < w}. term_eq t v) = term_less t w"
  apply (simp add: term_eq_def term_less_def)
  by auto

definition (in graph)
  "Init \<equiv> { (X::('node set), mrk::('node set)) . finite (-mrk) \<and> mrk = {}}"

definition (in graph)
  "Final \<equiv> { (X::('node set), mrk::('node set)) . mrk = reach root}"

definition (in graph)
  "SetMarkInv i = (case i of
      I.init  \<Rightarrow> Init |
      I.loop  \<Rightarrow> Loop |
      I.final \<Rightarrow> Final)"

definition (in graph)
  "SetMarkInvFinal i = (case i of
      I.final  \<Rightarrow> Final |
      _  \<Rightarrow> {})"

definition  (in graph) [simp]:
  "SetMarkInvTerm w i = (case i of
      I.init  \<Rightarrow> Init |
      I.loop  \<Rightarrow> Loop \<inter> {s . trm s = w} |
      I.final \<Rightarrow> Final)"

subsection {* Diagram *}

definition (in graph)
  "SetMark \<equiv> \<lambda> (i, j) . (case (i, j) of
      (I.init, I.loop)  \<Rightarrow> Q1_a \<sqinter> Q2_a |
      (I.loop, I.loop)  \<Rightarrow> Q3_a \<sqinter> Q4_a |
      (I.loop, I.final) \<Rightarrow> Q5_a |
       _ \<Rightarrow> top)"

lemma (in graph)  SetMark_dmono [simp]:
  "dmono SetMark"
  apply (unfold dmono_def SetMark_def Q1_a_def Q2_a_def Q3_a_def Q4_a_def Q5_a_def)
  by simp

subsection {* Correctness of the transitions *}

lemma  (in graph) init_loop_1_a[simp]: "\<Turnstile> Init {| Q1_a |} Loop"
  apply (unfold hoare_demonic Init_def Q1_a_def Loop_def)
  by auto

lemma  (in graph) init_loop_2_a[simp]: "\<Turnstile> Init {| Q2_a |} Loop"
  apply (simp add: hoare_demonic Init_def Q2_a_def Loop_def)
  apply auto
  apply (simp_all add: reach_def)
  apply (rule init_set2)
  by (simp_all add: reach_def)

lemma  (in graph) loop_loop_1_a [simp]: "\<Turnstile> (Loop \<inter>  {s . trm s = w}) {| Q3_a |} (Loop \<inter> {s. trm s < w})"
  apply (simp add: hoare_demonic Q3_a_def Loop_def trm_def)
  apply safe
  apply (simp_all)
  apply (simp_all add: reach_def subset_eq)
  apply safe
  apply (simp_all add: Compl_insert)
  apply (rule rtrancl_into_rtrancl)
  apply (simp_all add: Int_def)
  apply (rule add_set2)
  apply simp_all
  apply (case_tac "card (-b) > 0")
  by auto

 lemma  (in graph) loop_loop_2_a[simp]: "\<Turnstile> (Loop \<inter>  {s . trm s = w}) {| Q4_a |} (Loop \<inter> {s. trm s < w})"
  apply (simp add: hoare_demonic Q4_a_def Loop_def trm_def)
  apply auto
  apply (case_tac "card a > 0")
  by auto

 lemma  (in graph) loop_final_a [simp]: "\<Turnstile> (Loop \<inter> {s . trm s = w}) {| Q5_a |} Final"
  apply (simp add: hoare_demonic Q5_a_def Loop_def Final_def subset_eq Int_def path_def)
  by auto

lemma union_term_w[simp]:  "(\<Union>w. {s. t s = w}) = UNIV"
  by auto

lemma union_less_term_w[simp]: "(\<Union>v\<in>{v. v < w}. {s. t s = v}) = {s . t s < w}"
  by auto

lemma sup_union[simp]: "Sup (range A) i =  (\<Union> w . A w i)"
  by (simp_all add: Sup_fun_def)

lemma forall_simp [simp]: "(!a b. \<forall> x\<in> A . (a = (t x)) \<longrightarrow> (h x) \<or> b \<noteq> u x) = (\<forall> x\<in> A . h x)"
  apply safe
  by auto

lemma forall_simp2 [simp]: "(!a b. \<forall> x\<in> A . !y . (a  = t x y) \<longrightarrow> (h x y) \<longrightarrow> (g x y) \<or> b \<noteq> u x y) = (\<forall> x\<in> A . ! y . h x y \<longrightarrow> g x y )"
  apply safe
  by auto

subsection {* Diagram correctness *}

text{*
The termination ordering for the $\mathit{SetMark}$ diagram is the lexicographic
ordering on pairs $(i,\, n)$ where $i\in I$ and $n\in \mathit{nat}$.
*}

interpretation  DiagramTermination "\<lambda> (n::nat) (i :: I) . (i, n)"
  done

theorem (in graph) SetMark_correct:
  "\<Turnstile> SetMarkInv {|pt SetMark|} SetMarkInvFinal"
proof (rule_tac X = "SetMarkInvTerm" in hoare_diagram3)
  show "dmono SetMark" by simp
  show "\<forall>u i j. \<Turnstile> SetMarkInvTerm u i{| SetMark (i, j) |}
    DiagramTermination.SUP_L_P (\<lambda>n i. (i, n)) SetMarkInvTerm (i, u) j"
    by (auto simp add: SUP_L_P_def  less_pair_def less_I_def hoare_choice SetMark_def)
  show "SetMarkInv \<le> Sup (range SetMarkInvTerm)"
    apply (simp add: le_fun_def, safe)
    apply (simp_all add: SetMarkInv_def)
    apply (case_tac x)
    apply auto
    done
  show "Sup (range SetMarkInvTerm) \<sqinter> - grd (step SetMark) \<le> SetMarkInvFinal"
    apply (simp add: le_fun_def inf_fun_def SetMarkInvFinal_def)
    apply safe
    apply simp_all
    apply (drule_tac x="I.loop" in spec)
    apply (simp add: SetMark_def)
    apply (simp add: Q1_a_def Q2_a_def)
    apply auto[1]
    apply (frule_tac x="I.loop" in spec)
    apply (drule_tac x="I.final" in spec)
    apply (simp add: SetMark_def)
    apply (simp add: Q3_a_def Q4_a_def Q5_a_def)
    apply (auto)
    done
qed

theorem (in graph) SetMark_correct1 [simp]:
  "Hoare_dgr SetMarkInv SetMark (SetMarkInv \<sqinter> (- grd (step SetMark)))"
  apply (simp add: Hoare_dgr_def)
  apply (rule_tac x = SetMarkInvTerm in exI)
  apply (subgoal_tac "SetMarkInv = \<Squnion>range SetMarkInvTerm")
  apply simp
  apply safe
  apply (simp_all add: SetMark_def SUP_L_P_def
       less_pair_def less_I_def hoare_choice  uminus_apply)
  apply (simp_all add: fun_eq_iff)
  apply safe
  apply (unfold SetMarkInv_def)
  by auto

theorem (in graph) stack_not_nil [simp]:
  "(mrk, S) \<in> Loop \<Longrightarrow> x \<in> S \<Longrightarrow> x \<noteq> nil"
  apply (simp add: Loop_def reach_def)
  by auto

end


(* Author: Alexander Bentkamp, Universität des Saarlandes
*)
section \<open>Missing Lemmas of List\<close>

theory DL_Missing_List
imports Main
begin

lemma nth_map_zip:
assumes "i < length xs"
assumes "i < length ys"
shows "map f (zip xs ys) ! i = f (xs ! i, ys ! i)"
 using nth_zip nth_map length_zip by (simp add: assms(1) assms(2))

lemma nth_map_zip2:
assumes "i < length (map f (zip xs ys))"
shows "map f (zip xs ys) ! i = f (xs ! i, ys ! i)"
 using nth_zip nth_map length_zip assms by simp

fun find_first where
"find_first a [] = undefined" |
"find_first a (x # xs) = (if x = a then 0 else Suc (find_first a xs))"

lemma find_first_le:
assumes "a \<in> set xs"
shows "find_first a xs < length xs"
using assms proof (induction xs)
  case (Cons x xs)
  then show ?case
    using find_first.simps(2) nth_Cons_0 nth_Cons_Suc set_ConsD by auto
qed auto

lemma nth_find_first:
assumes "a \<in> set xs"
shows "xs ! (find_first a xs) = a"
using assms proof (induction xs)
  case (Cons x xs)
  then show ?case
    using find_first.simps(2) nth_Cons_0 nth_Cons_Suc set_ConsD by auto
qed auto

lemma find_first_unique:
assumes "distinct xs"
and "i < length xs"
shows "find_first (xs ! i) xs = i"
using assms proof (induction xs arbitrary:i)
  case (Cons x xs i)
  then show ?case by (cases i; auto)
qed auto

end