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

section{*Disjoint Sums*}

theory Sum imports Bool equalities begin

text{*And the "Part" primitive for simultaneous recursive type definitions*}

definition sum :: "[i,i]=>i" (infixr "+" 65) where
     "A+B == {0}*A \<union> {1}*B"

definition Inl :: "i=>i" where
     "Inl(a) == <0,a>"

definition Inr :: "i=>i" where
     "Inr(b) == <1,b>"

definition "case" :: "[i=>i, i=>i, i]=>i" where
     "case(c,d) == (%<y,z>. cond(y, d(z), c(z)))"

  (*operator for selecting out the various summands*)
definition Part :: "[i,i=>i] => i" where
     "Part(A,h) == {x \<in> A. \<exists>z. x = h(z)}"

subsection{*Rules for the @{term Part} Primitive*}

lemma Part_iff:
    "a \<in> Part(A,h) \<longleftrightarrow> a \<in> A & (\<exists>y. a=h(y))"
apply (unfold Part_def)
apply (rule separation)
done

lemma Part_eqI [intro]:
    "[| a \<in> A;  a=h(b) |] ==> a \<in> Part(A,h)"
by (unfold Part_def, blast)

lemmas PartI = refl [THEN [2] Part_eqI]

lemma PartE [elim!]:
    "[| a \<in> Part(A,h);  !!z. [| a \<in> A;  a=h(z) |] ==> P
     |] ==> P"
apply (unfold Part_def, blast)
done

lemma Part_subset: "Part(A,h) \<subseteq> A"
apply (unfold Part_def)
apply (rule Collect_subset)
done

subsection{*Rules for Disjoint Sums*}

lemmas sum_defs = sum_def Inl_def Inr_def case_def

lemma Sigma_bool: "Sigma(bool,C) = C(0) + C(1)"
by (unfold bool_def sum_def, blast)

(** Introduction rules for the injections **)

lemma InlI [intro!,simp,TC]: "a \<in> A ==> Inl(a) \<in> A+B"
by (unfold sum_defs, blast)

lemma InrI [intro!,simp,TC]: "b \<in> B ==> Inr(b) \<in> A+B"
by (unfold sum_defs, blast)

(** Elimination rules **)

lemma sumE [elim!]:
    "[| u \<in> A+B;
        !!x. [| x \<in> A;  u=Inl(x) |] ==> P;
        !!y. [| y \<in> B;  u=Inr(y) |] ==> P
     |] ==> P"
by (unfold sum_defs, blast)

(** Injection and freeness equivalences, for rewriting **)

lemma Inl_iff [iff]: "Inl(a)=Inl(b) \<longleftrightarrow> a=b"
by (simp add: sum_defs)

lemma Inr_iff [iff]: "Inr(a)=Inr(b) \<longleftrightarrow> a=b"
by (simp add: sum_defs)

lemma Inl_Inr_iff [simp]: "Inl(a)=Inr(b) \<longleftrightarrow> False"
by (simp add: sum_defs)

lemma Inr_Inl_iff [simp]: "Inr(b)=Inl(a) \<longleftrightarrow> False"
by (simp add: sum_defs)

lemma sum_empty [simp]: "0+0 = 0"
by (simp add: sum_defs)

(*Injection and freeness rules*)

lemmas Inl_inject = Inl_iff [THEN iffD1]
lemmas Inr_inject = Inr_iff [THEN iffD1]
lemmas Inl_neq_Inr = Inl_Inr_iff [THEN iffD1, THEN FalseE, elim!]
lemmas Inr_neq_Inl = Inr_Inl_iff [THEN iffD1, THEN FalseE, elim!]

lemma InlD: "Inl(a): A+B ==> a \<in> A"
by blast

lemma InrD: "Inr(b): A+B ==> b \<in> B"
by blast

lemma sum_iff: "u \<in> A+B \<longleftrightarrow> (\<exists>x. x \<in> A & u=Inl(x)) | (\<exists>y. y \<in> B & u=Inr(y))"
by blast

lemma Inl_in_sum_iff [simp]: "(Inl(x) \<in> A+B) \<longleftrightarrow> (x \<in> A)"
by auto

lemma Inr_in_sum_iff [simp]: "(Inr(y) \<in> A+B) \<longleftrightarrow> (y \<in> B)"
by auto

lemma sum_subset_iff: "A+B \<subseteq> C+D \<longleftrightarrow> A<=C & B<=D"
by blast

lemma sum_equal_iff: "A+B = C+D \<longleftrightarrow> A=C & B=D"
by (simp add: extension sum_subset_iff, blast)

lemma sum_eq_2_times: "A+A = 2*A"
by (simp add: sum_def, blast)

subsection{*The Eliminator: @{term case}*}

lemma case_Inl [simp]: "case(c, d, Inl(a)) = c(a)"
by (simp add: sum_defs)

lemma case_Inr [simp]: "case(c, d, Inr(b)) = d(b)"
by (simp add: sum_defs)

lemma case_type [TC]:
    "[| u \<in> A+B;
        !!x. x \<in> A ==> c(x): C(Inl(x));
        !!y. y \<in> B ==> d(y): C(Inr(y))
     |] ==> case(c,d,u) \<in> C(u)"
by auto

lemma expand_case: "u \<in> A+B ==>
        R(case(c,d,u)) \<longleftrightarrow>
        ((\<forall>x\<in>A. u = Inl(x) \<longrightarrow> R(c(x))) &
        (\<forall>y\<in>B. u = Inr(y) \<longrightarrow> R(d(y))))"
by auto

lemma case_cong:
  "[| z \<in> A+B;
      !!x. x \<in> A ==> c(x)=c'(x);
      !!y. y \<in> B ==> d(y)=d'(y)
   |] ==> case(c,d,z) = case(c',d',z)"
by auto

lemma case_case: "z \<in> A+B ==>
        case(c, d, case(%x. Inl(c'(x)), %y. Inr(d'(y)), z)) =
        case(%x. c(c'(x)), %y. d(d'(y)), z)"
by auto

subsection{*More Rules for @{term "Part(A,h)"}*}

lemma Part_mono: "A<=B ==> Part(A,h)<=Part(B,h)"
by blast

lemma Part_Collect: "Part(Collect(A,P), h) = Collect(Part(A,h), P)"
by blast

lemmas Part_CollectE =
     Part_Collect [THEN equalityD1, THEN subsetD, THEN CollectE]

lemma Part_Inl: "Part(A+B,Inl) = {Inl(x). x \<in> A}"
by blast

lemma Part_Inr: "Part(A+B,Inr) = {Inr(y). y \<in> B}"
by blast

lemma PartD1: "a \<in> Part(A,h) ==> a \<in> A"
by (simp add: Part_def)

lemma Part_id: "Part(A,%x. x) = A"
by blast

lemma Part_Inr2: "Part(A+B, %x. Inr(h(x))) = {Inr(y). y \<in> Part(B,h)}"
by blast

lemma Part_sum_equality: "C \<subseteq> A+B ==> Part(C,Inl) \<union> Part(C,Inr) = C"
by blast

end


(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Real Roots\<close>

text \<open>This theory contains an algorithm to determine the set of real roots of a
  rational polynomial. For polynomials with real coefficients, we refer to
  the AFP entry "Factor-Algebraic-Polynomial".\<close>

theory Real_Roots
  imports
    Cauchy_Root_Bound
    Real_Algebraic_Numbers
begin

hide_const (open) UnivPoly.coeff
hide_const (open) Module.smult

partial_function (tailrec) roots_of_2_main ::
  "int poly \<Rightarrow> root_info \<Rightarrow> (rat \<Rightarrow> rat \<Rightarrow> nat) \<Rightarrow> (rat \<times> rat)list \<Rightarrow> real_alg_2 list \<Rightarrow> real_alg_2 list" where
  [code]: "roots_of_2_main p ri cr lrs rais = (case lrs of Nil \<Rightarrow> rais
  | (l,r) # lrs \<Rightarrow> let c = cr l r in
    if c = 0 then roots_of_2_main p ri cr lrs rais
    else if c = 1 then roots_of_2_main p ri cr lrs (real_alg_2'' ri p l r # rais)
    else let m = (l + r) / 2 in roots_of_2_main p ri cr ((m,r) # (l,m) # lrs) rais)"

definition roots_of_2_irr :: "int poly \<Rightarrow> real_alg_2 list" where
  "roots_of_2_irr p = (if degree p = 1
    then [Rational (Rat.Fract (- coeff p 0) (coeff p 1)) ] else
    let ri = root_info p;
        cr = root_info.l_r ri;
        B = root_bound p
      in (roots_of_2_main p ri cr [(-B,B)] []))"

fun pairwise_disjoint :: "'a set list \<Rightarrow> bool" where
  "pairwise_disjoint [] = True"
| "pairwise_disjoint (x # xs) = ((x \<inter> (\<Union> y \<in> set xs. y) = {}) \<and> pairwise_disjoint xs)"

lemma roots_of_2_irr: assumes pc: "poly_cond p" and deg: "degree p > 0"
  shows "real_of_2 ` set (roots_of_2_irr p) = {x. ipoly p x = 0}" (is ?one)
    "Ball (set (roots_of_2_irr p)) invariant_2" (is ?two)
    "distinct (map real_of_2 (roots_of_2_irr p))" (is ?three)
proof -
  note d = roots_of_2_irr_def
  from poly_condD[OF pc] have mon: "lead_coeff p > 0" and irr: "irreducible p" by auto
  let ?norm = "real_alg_2'"
  have "?one \<and> ?two \<and> ?three"
  proof (cases "degree p = 1")
    case True
    define c where "c = coeff p 0"
    define d where "d = coeff p 1"
    from True have rr: "roots_of_2_irr p = [Rational (Rat.Fract (- c) (d))]" unfolding d d_def c_def by auto
    from degree1_coeffs[OF True] have p: "p = [:c,d:]" and d: "d \<noteq> 0" unfolding c_def d_def by auto
    have *: "real_of_int c + x * real_of_int d = 0 \<Longrightarrow> x = - (real_of_int c / real_of_int d)" for x
      using d by (simp add: field_simps)
    show ?thesis unfolding rr using d * unfolding p using of_rat_1[of "Rat.Fract (- c) (d)"]
      by (auto simp: Fract_of_int_quotient hom_distribs)
  next
    case False
    let ?r = real_of_rat
    let ?rp = "map_poly ?r"
    let ?rr = "set (roots_of_2_irr p)"
    define ri where "ri = root_info p"
    define cr where "cr = root_info.l_r ri"
    define bnds where "bnds = [(-root_bound p, root_bound p)]"
    define empty where "empty = (Nil :: real_alg_2 list)"
    have empty: "Ball (set empty) invariant_2 \<and> distinct (map real_of_2 empty)" unfolding empty_def by auto
    from mon have p: "p \<noteq> 0" by auto
    from root_info[OF irr deg] have ri: "root_info_cond ri p" unfolding ri_def .
    from False
    have rr: "roots_of_2_irr p = roots_of_2_main p ri cr bnds empty"
      unfolding d ri_def cr_def Let_def bnds_def empty_def by auto
    note root_bound = root_bound[OF refl deg]
    from root_bound(2)
    have bnds: "\<And> l r. (l,r) \<in> set bnds \<Longrightarrow> l \<le> r" unfolding bnds_def by auto
    have "ipoly p x = 0 \<Longrightarrow> ?r (- root_bound p) \<le> x \<and> x \<le> ?r (root_bound p)" for x
      using root_bound(1)[of x] by (auto simp: hom_distribs)
    hence rts: "{x. ipoly p x = 0}
      = real_of_2 ` set empty \<union> {x. \<exists> l r. root_cond (p,l,r) x \<and> (l,r) \<in> set bnds}"
      unfolding empty_def bnds_def by (force simp: root_cond_def)
    define rts where "rts lr = Collect (root_cond (p,lr))" for lr
    have disj: "pairwise_disjoint (real_of_2 ` set empty # map rts bnds)"
      unfolding empty_def bnds_def by auto
    from deg False have deg1: "degree p > 1" by auto
    define delta where "delta = ipoly_root_delta p"
    note delta = ipoly_root_delta[OF p, folded delta_def]
    define rel' where "rel' = ({(x, y). 0 \<le> y \<and> delta_gt delta x y})^-1"
    define mm where "mm = (\<lambda>bnds. mset (map (\<lambda> (l,r). ?r r - ?r l) bnds))"
    define rel where "rel = inv_image (mult1 rel') mm"
    have wf: "wf rel" unfolding rel_def rel'_def
      by (rule wf_inv_image[OF wf_mult1[OF SN_imp_wf[OF delta_gt_SN[OF delta(1)]]]])
    let ?main = "roots_of_2_main p ri cr"
    have "real_of_2 ` set (?main bnds empty) =
      real_of_2 ` set empty \<union>
      {x. \<exists>l r. root_cond (p, l, r) x \<and> (l, r) \<in> set bnds} \<and>
      Ball (set (?main bnds empty)) invariant_2 \<and> distinct (map real_of_2 (?main bnds empty))" (is "?one' \<and> ?two' \<and> ?three'")
      using empty bnds disj
    proof (induct bnds arbitrary: empty rule: wf_induct[OF wf])
      case (1 lrss rais)
      note rais = 1(2)[rule_format]
      note lrs = 1(3)
      note disj = 1(4)
      note IH = 1(1)[rule_format]
      note simp = roots_of_2_main.simps[of p ri cr lrss rais]
      show ?case
      proof (cases lrss)
        case Nil
        with rais show ?thesis unfolding simp by auto
      next
        case (Cons lr lrs)
        obtain l r where lr': "lr = (l,r)" by force
        {
          fix lr'
          assume lt: "\<And> l' r'. (l',r') \<in> set lr' \<Longrightarrow>
            l' \<le> r' \<and> delta_gt delta (?r r - ?r l) (?r r' - ?r l')"
          have l: "mm (lr' @ lrs) = mm lrs + mm lr'" unfolding mm_def by (auto simp: ac_simps)
          have r: "mm lrss = mm lrs + {# ?r r - ?r l #}" unfolding Cons lr' rel_def mm_def
            by auto
          have "(mm (lr' @ lrs), mm lrss) \<in> mult1 rel'" unfolding l r mult1_def
          proof (rule, unfold split, intro exI conjI, unfold add_mset_add_single[symmetric], rule refl, rule refl, intro allI impI)
            fix d
            assume "d \<in># mm lr'"
            then obtain l' r' where d: "d = ?r r' - ?r l'" and lr': "(l',r') \<in> set lr'"
              unfolding mm_def in_multiset_in_set by auto
            from lt[OF lr']
            show "(d, ?r r - ?r l) \<in> rel'"  unfolding d rel'_def
              by (auto simp: of_rat_less_eq)
          qed
          hence "(lr' @ lrs, lrss) \<in> rel" unfolding rel_def by auto
        } note rel = this
        from rel[of Nil] have easy_rel: "(lrs,lrss) \<in> rel" by auto
        define c where "c = cr l r"
        from simp Cons lr' have simp: "?main lrss rais =
          (if c = 0 then ?main lrs rais else if c = 1 then
             ?main lrs (real_alg_2' ri p l r # rais)
               else let m = (l + r) / 2 in ?main ((m, r) # (l, m) # lrs) rais)"
          unfolding c_def simp Cons lr' using real_alg_2''[OF False] by auto
        note lrs = lrs[unfolded Cons lr']
        from lrs have lr: "l \<le> r" by auto
        from root_info_condD(1)[OF ri lr, folded cr_def]
        have c: "c = card {x. root_cond (p,l,r) x}" unfolding c_def by auto
        let ?rt = "\<lambda> lrs. {x. \<exists>l r. root_cond (p, l, r) x \<and> (l, r) \<in> set lrs}"
        have rts: "?rt lrss = ?rt lrs \<union> {x. root_cond (p,l,r) x}" (is "?rt1 = ?rt2 \<union> ?rt3")
          unfolding Cons lr' by auto
        show ?thesis
        proof (cases "c = 0")
          case True
          with simp have simp: "?main lrss rais = ?main lrs rais" by simp
          from disj have disj: "pairwise_disjoint (real_of_2 ` set rais # map rts lrs)"
            unfolding Cons by auto
          from finite_ipoly_roots[OF p] True[unfolded c] have empty: "?rt3 = {}"
            unfolding root_cond_def[abs_def] split by simp
          with rts have rts: "?rt1 = ?rt2" by auto
          show ?thesis unfolding simp rts
            by (rule IH[OF easy_rel rais lrs disj], auto)
        next
          case False
          show ?thesis
          proof (cases "c = 1")
            case True
            let ?rai = "real_alg_2' ri p l r"
            from True simp have simp: "?main lrss rais = ?main lrs (?rai # rais)" by auto
            from card_1_Collect_ex1[OF c[symmetric, unfolded True]]
            have ur: "unique_root (p,l,r)"  .
            from real_alg_2'[OF ur pc ri]
            have rai: "invariant_2 ?rai" "real_of_2 ?rai = the_unique_root (p, l, r)" by auto
            with rais have rais: "\<And> x. x \<in> set (?rai # rais) \<Longrightarrow> invariant_2 x"
              and dist: "distinct (map real_of_2 rais)" by auto
            have rt3: "?rt3 = {real_of_2 ?rai}"
              using ur rai by (auto intro: the_unique_root_eqI theI')
            have "real_of_2 ` set (roots_of_2_main p ri cr lrs (?rai # rais)) =
              real_of_2 ` set (?rai # rais) \<union> ?rt2 \<and>
              Ball (set (roots_of_2_main p ri cr lrs (?rai # rais))) invariant_2 \<and>
              distinct (map real_of_2 (roots_of_2_main p ri cr lrs (?rai # rais)))"
              (is "?one \<and> ?two \<and> ?three")
            proof (rule IH[OF easy_rel, of "?rai # rais", OF conjI lrs])
              show "Ball (set (real_alg_2' ri p l r # rais)) invariant_2" using rais by auto
              have "real_of_2 (real_alg_2' ri p l r) \<notin> set (map real_of_2 rais)"
                using disj rt3 unfolding Cons lr' rts_def by auto
              thus "distinct (map real_of_2 (real_alg_2' ri p l r # rais))" using dist by auto
              show "pairwise_disjoint (real_of_2 ` set (real_alg_2' ri p l r # rais) # map rts lrs)"
                using disj rt3 unfolding Cons lr' rts_def by auto
            qed auto
            hence ?one ?two ?three by blast+
            show ?thesis unfolding simp rts rt3
              by (rule conjI[OF _ conjI[OF \<open>?two\<close> \<open>?three\<close>]], unfold \<open>?one\<close>, auto)
          next
            case False
            let ?m = "(l+r)/2"
            let ?lrs = "[(?m,r),(l,?m)] @ lrs"
            from False \<open>c \<noteq> 0\<close> have simp: "?main lrss rais = ?main ?lrs rais"
              unfolding simp by (auto simp: Let_def)
            from False \<open>c \<noteq> 0\<close> have "c \<ge> 2" by auto
            from delta(2)[OF this[unfolded c]] have delta: "delta \<le> ?r (r - l) / 4" by auto
            have lrs: "\<And> l r. (l,r) \<in> set ?lrs \<Longrightarrow> l \<le> r"
              using lr lrs by (fastforce simp: field_simps)
            have "?r ?m \<in> \<rat>" unfolding Rats_def by blast
            with poly_cond_degree_gt_1[OF pc deg1, of "?r ?m"]
            have disj1: "?r ?m \<notin> rts lr" for lr unfolding rts_def root_cond_def by auto
            have disj2: "rts (?m, r) \<inter> rts (l, ?m) = {}" using disj1[of "(l,?m)"] disj1[of "(?m,r)"]
              unfolding rts_def root_cond_def by auto
            have disj3: "(rts (l,?m) \<union> rts (?m,r)) = rts (l,r)"
              unfolding rts_def root_cond_def by (auto simp: hom_distribs)
            have disj4: "real_of_2 ` set rais \<inter> rts (l,r) = {}" using disj unfolding Cons lr' by auto
            have disj: "pairwise_disjoint (real_of_2 ` set rais # map rts ([(?m, r), (l, ?m)] @ lrs))"
              using disj disj2 disj3 disj4 by (auto simp: Cons lr')
            have "(?lrs,lrss) \<in> rel"
            proof (rule rel, intro conjI)
              fix l' r'
              assume mem: "(l', r') \<in> set [(?m,r),(l,?m)]"
              from mem lr show "l' \<le> r'" by auto
              from mem have diff: "?r r' - ?r l' = (?r r - ?r l) / 2" by auto
               (metis eq_diff_eq minus_diff_eq mult_2_right of_rat_add of_rat_diff,
                metis of_rat_add of_rat_mult of_rat_numeral_eq)
              show "delta_gt delta (?r r - ?r l) (?r r' - ?r l')" unfolding diff
                delta_gt_def by (rule order.trans[OF delta], insert lr,
                auto simp: field_simps of_rat_diff of_rat_less_eq)
            qed
            note IH = IH[OF this, of rais, OF rais lrs disj]
            have "real_of_2 ` set (?main ?lrs rais) =
              real_of_2 ` set rais \<union> ?rt ?lrs \<and>
              Ball (set (?main ?lrs rais)) invariant_2 \<and> distinct (map real_of_2 (?main ?lrs rais))"
              (is "?one \<and> ?two")
              by (rule IH)
            hence ?one ?two by blast+
            have cong: "\<And> a b c. b = c \<Longrightarrow> a \<union> b = a \<union> c" by auto
            have id: "?rt ?lrs = ?rt lrs \<union> ?rt [(?m,r),(l,?m)]" by auto
            show ?thesis unfolding rts simp \<open>?one\<close> id
            proof (rule conjI[OF cong[OF cong] conjI])
              have "\<And> x. root_cond (p,l,r) x = (root_cond (p,l,?m) x \<or> root_cond (p,?m,r) x)"
                unfolding root_cond_def by (auto simp:hom_distribs)
              hence id: "Collect (root_cond (p,l,r)) = {x. (root_cond (p,l,?m) x \<or> root_cond (p,?m,r) x)}"
                by auto
              show "?rt [(?m,r),(l,?m)] = Collect (root_cond (p,l,r))" unfolding id list.simps by blast
              show "\<forall> a \<in> set (?main ?lrs rais). invariant_2 a" using \<open>?two\<close> by auto
              show "distinct (map real_of_2 (?main ?lrs rais))" using \<open>?two\<close> by auto
            qed
          qed
        qed
      qed
    qed
    hence idd: "?one'" and cond: ?two' ?three' by blast+
    define res where "res = roots_of_2_main p ri cr bnds empty"
    have e: "set empty = {}" unfolding empty_def by auto
    from idd[folded res_def] e have idd: "real_of_2 ` set res = {} \<union> {x. \<exists>l r. root_cond (p, l, r) x \<and> (l, r) \<in> set bnds}"
      by auto
    show ?thesis
      unfolding rr unfolding rts id e norm_def using cond
      unfolding res_def[symmetric] image_empty e idd[symmetric] by auto
  qed
  thus ?one ?two ?three by blast+
qed

definition roots_of_2 :: "int poly \<Rightarrow> real_alg_2 list" where
  "roots_of_2 p = concat (map roots_of_2_irr
     (factors_of_int_poly p))"

lemma roots_of_2:
  shows "p \<noteq> 0 \<Longrightarrow> real_of_2 ` set (roots_of_2 p) = {x. ipoly p x = 0}"
    "Ball (set (roots_of_2 p)) invariant_2"
    "distinct (map real_of_2 (roots_of_2 p))"
proof -
  let ?rr = "roots_of_2 p"
  note d = roots_of_2_def
  note frp1 = factors_of_int_poly
  {
    fix q r
    assume "q \<in> set ?rr"
    then obtain s where
      s: "s \<in> set (factors_of_int_poly p)" and
      q: "q \<in> set (roots_of_2_irr s)"
      unfolding d by auto
    from frp1(1)[OF refl s] have "poly_cond s" "degree s > 0" by (auto simp: poly_cond_def)
    from roots_of_2_irr[OF this] q
    have "invariant_2 q" by auto
  }
  thus "Ball (set ?rr) invariant_2" by auto
  {
    assume p: "p \<noteq> 0"
    have "real_of_2 ` set ?rr = (\<Union> ((\<lambda> p. real_of_2 ` set (roots_of_2_irr p)) `
      (set (factors_of_int_poly p))))"
      (is "_ = ?rrr")
      unfolding d set_concat set_map by auto
    also have "\<dots> = {x. ipoly p x = 0}"
    proof -
      {
        fix x
        assume "x \<in> ?rrr"
        then obtain q s where
          s: "s \<in> set (factors_of_int_poly p)" and
          q: "q \<in> set (roots_of_2_irr s)" and
          x: "x = real_of_2 q" by auto
        from frp1(1)[OF refl s] have s0: "s \<noteq> 0" and pt: "poly_cond s" "degree s > 0"
          by (auto simp: poly_cond_def)
        from roots_of_2_irr[OF pt] q have rt: "ipoly s x = 0" unfolding x by auto
        from frp1(2)[OF refl p, of x] rt s have rt: "ipoly p x = 0" by auto
      }
      moreover
      {
        fix x :: real
        assume rt: "ipoly p x = 0"
        from rt frp1(2)[OF refl p, of x] obtain s where s: "s \<in> set (factors_of_int_poly p)"
          and rt: "ipoly s x = 0" by auto
        from frp1(1)[OF refl s] have s0: "s \<noteq> 0" and ty: "poly_cond s" "degree s > 0"
          by (auto simp: poly_cond_def)
        from roots_of_2_irr(1)[OF ty] rt obtain q where
          q: "q \<in> set (roots_of_2_irr s)" and
          x: "x = real_of_2 q" by blast
        have "x \<in> ?rrr" unfolding x using q s by auto
      }
      ultimately show ?thesis by auto
    qed
    finally show "real_of_2 ` set ?rr = {x. ipoly p x = 0}" by auto
  }
  show "distinct (map real_of_2 (roots_of_2 p))"
  proof (cases "p = 0")
    case True
    from factors_of_int_poly_const[of 0] True show ?thesis unfolding roots_of_2_def by auto
  next
    case p: False
    note frp1 = frp1[OF refl]
    let ?fp = "factors_of_int_poly p"
    let ?cc = "concat (map roots_of_2_irr ?fp)"
    show ?thesis unfolding roots_of_2_def distinct_conv_nth length_map
    proof (intro allI impI notI)
      fix i j
      assume ij: "i < length ?cc" "j < length ?cc" "i \<noteq> j" and id: "map real_of_2 ?cc ! i = map real_of_2 ?cc ! j"
      from ij id have id: "real_of_2 (?cc ! i) = real_of_2 (?cc ! j)" by auto
      from nth_concat_diff[OF ij, unfolded length_map] obtain j1 k1 j2 k2 where
        *: "(j1,k1) \<noteq> (j2,k2)"
        "j1 < length ?fp" "j2 < length ?fp" and
        "k1 < length (map roots_of_2_irr ?fp ! j1)"
        "k2 < length (map roots_of_2_irr ?fp ! j2)"
        "?cc ! i = map roots_of_2_irr ?fp ! j1 ! k1"
        "?cc ! j = map roots_of_2_irr ?fp ! j2 ! k2" by blast
      hence **: "k1 < length (roots_of_2_irr (?fp ! j1))"
        "k2 < length (roots_of_2_irr (?fp ! j2))"
        "?cc ! i = roots_of_2_irr (?fp ! j1) ! k1"
        "?cc ! j = roots_of_2_irr (?fp ! j2) ! k2"
        by auto
      from * have mem: "?fp ! j1 \<in> set ?fp" "?fp ! j2 \<in> set ?fp" by auto
      from frp1(1)[OF mem(1)] frp1(1)[OF mem(2)]
      have pc1: "poly_cond (?fp ! j1)" "degree (?fp ! j1) > 0" and pc10: "?fp ! j1 \<noteq> 0"
        and pc2: "poly_cond (?fp ! j2)" "degree (?fp ! j2) > 0"
        by (auto simp: poly_cond_def)
      show False
      proof (cases "j1 = j2")
        case True
        with * have neq: "k1 \<noteq> k2" by auto
        from **[unfolded True] id *
        have "map real_of_2 (roots_of_2_irr (?fp ! j2)) ! k1 = real_of_2 (?cc ! j)"
          "map real_of_2 (roots_of_2_irr (?fp ! j2)) ! k1 = real_of_2 (?cc ! j)"
          by auto
        hence "\<not> distinct (map real_of_2 (roots_of_2_irr (?fp ! j2)))"
          unfolding distinct_conv_nth using * ** True by auto
        with roots_of_2_irr(3)[OF pc2] show False by auto
      next
        case neq: False
        with frp1(4)[of p] * have neq: "?fp ! j1 \<noteq> ?fp ! j2" unfolding distinct_conv_nth by auto
        let ?x = "real_of_2 (?cc ! i)"
        define x where "x = ?x"
        from ** have "x \<in> real_of_2 ` set (roots_of_2_irr (?fp ! j1))" unfolding x_def by auto
        with roots_of_2_irr(1)[OF pc1] have x1: "ipoly (?fp ! j1) x = 0" by auto
        from ** id have "x \<in> real_of_2 ` set (roots_of_2_irr (?fp ! j2))" unfolding x_def
          by (metis image_eqI nth_mem)
        with roots_of_2_irr(1)[OF pc2] have x2: "ipoly (?fp ! j2) x = 0" by auto
        have "ipoly p x = 0" using x1 mem unfolding roots_of_2_def by (metis frp1(2) p)
        from frp1(3)[OF p this] x1 x2 neq mem show False by blast
      qed
    qed
  qed
qed

lift_definition (code_dt) roots_of_3 :: "int poly \<Rightarrow> real_alg_3 list" is roots_of_2
  by (insert roots_of_2, auto simp: list_all_iff)

lemma roots_of_3:
  shows "p \<noteq> 0 \<Longrightarrow> real_of_3 ` set (roots_of_3 p) = {x. ipoly p x = 0}"
    "distinct (map real_of_3 (roots_of_3 p))"
proof -
  show "p \<noteq> 0 \<Longrightarrow> real_of_3 ` set (roots_of_3 p) = {x. ipoly p x = 0}"
    by (transfer; intro roots_of_2, auto)
  show "distinct (map real_of_3 (roots_of_3 p))"
    by (transfer; insert roots_of_2, auto)
qed

lift_definition roots_of_real_alg :: "int poly \<Rightarrow> real_alg list" is roots_of_3 .

lemma roots_of_real_alg:
  "p \<noteq> 0 \<Longrightarrow> real_of ` set (roots_of_real_alg p) = {x. ipoly p x = 0}"
  "distinct (map real_of (roots_of_real_alg p))"
proof -
  show "p \<noteq> 0 \<Longrightarrow> real_of ` set (roots_of_real_alg p) = {x. ipoly p x = 0}"
    by (transfer', insert roots_of_3, auto)
  show "distinct (map real_of (roots_of_real_alg p))"
    by (transfer, insert roots_of_3(2), auto)
qed

definition real_roots_of_int_poly :: "int poly \<Rightarrow> real list" where
  "real_roots_of_int_poly p = map real_of (roots_of_real_alg p)"

definition real_roots_of_rat_poly :: "rat poly \<Rightarrow> real list" where
  "real_roots_of_rat_poly p = map real_of (roots_of_real_alg (snd (rat_to_int_poly p)))"

abbreviation rpoly :: "rat poly \<Rightarrow> 'a :: field_char_0 \<Rightarrow> 'a"
where "rpoly f \<equiv> poly (map_poly of_rat f)"

lemma real_roots_of_int_poly: "p \<noteq> 0 \<Longrightarrow> set (real_roots_of_int_poly p) = {x. ipoly p x = 0}"
  "distinct (real_roots_of_int_poly p)"
  unfolding real_roots_of_int_poly_def using roots_of_real_alg[of p] by auto

lemma real_roots_of_rat_poly: "p \<noteq> 0 \<Longrightarrow> set (real_roots_of_rat_poly p) = {x. rpoly p x = 0}"
  "distinct (real_roots_of_rat_poly p)"
proof -
  obtain c q where cq: "rat_to_int_poly p = (c,q)" by force
  from rat_to_int_poly[OF this]
  have pq: "p = smult (inverse (of_int c)) (of_int_poly q)"
    and c: "c \<noteq> 0" by auto
  have id: "{x. rpoly p x = (0 :: real)} = {x. ipoly q x = 0}"
    unfolding pq by (simp add: c of_rat_of_int_poly hom_distribs)
  show "distinct (real_roots_of_rat_poly p)" unfolding real_roots_of_rat_poly_def cq snd_conv
    using roots_of_real_alg(2)[of q] .
  assume "p \<noteq> 0"
  with pq c have q: "q \<noteq> 0" by auto
  show "set (real_roots_of_rat_poly p) = {x. rpoly p x = 0}" unfolding id
    unfolding real_roots_of_rat_poly_def cq snd_conv using roots_of_real_alg(1)[OF q]
    by auto
qed

end


(* Title: thys/TuringDecidable.thy
   Author: Franz Regensburger (FABR) 02/2022
 *)

section \<open>Turing Decidability\<close>

theory TuringDecidable
  imports
    OneStrokeTM
    Turing_HaltingConditions
begin

(* -------------------------------------------------------------------------- *)

(*
declare adjust.simps[simp del]

declare seq_tm.simps [simp del]
declare shift.simps[simp del]
declare composable_tm.simps[simp del]
declare step.simps[simp del]
declare steps.simps[simp del]
*)

subsection \<open>Turing Decidable Sets and Relations of natural numbers\<close>

text \<open>We use lists of natural numbers in order to model tuples of
 arity @{term k} of natural numbers,
 where @{term "0 \<le> (k::nat)"}.
\<close>

(*
 For a relation R of @\<lbrace>term k\<rbrace>-ary tuples use a set nls of nat lists,
 where each of its elements nl (which is a nat list) has length k.

     (n1, ... , nk) \<in> R \<longleftrightarrow> [<[n1, ... , nk]>] \<in> nls .

 For a plain set of natural numbers S simply use a set of singleton nat lists nls
 where

      n \<in> S \<longleftrightarrow> [<n>] \<in> nls.
*)

text \<open>Now, we define the notion of {\em Turing Decidable Sets and Relations}.
In our definition, we directly relate decidability of sets and relations to Turing machines
and do not adhere to the formal concept of a characteristic function.

However, the notion of a characteristic function is introduced in the theory about Turing
computable functions.
\<close>

definition turing_decidable :: "(nat list) set \<Rightarrow> bool"
  where
    "turing_decidable nls \<equiv> (\<exists>D. (\<forall>nl.
         (nl \<in> nls \<longrightarrow> \<lbrace>(\<lambda>tap. tap = ([], <nl>))\<rbrace> D \<lbrace>(\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <1::nat> @ Bk\<up> l))\<rbrace>)
       \<and> (nl \<notin> nls \<longrightarrow> \<lbrace>(\<lambda>tap. tap = ([], <nl>))\<rbrace> D \<lbrace>(\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <0::nat> @ Bk\<up> l))\<rbrace>)
     ))"

(* This is for documentation and explanation: turing_decidable_unfolded_into_TMC_yields_conditions *)

lemma turing_decidable_unfolded_into_TMC_yields_conditions:
"turing_decidable nls \<equiv> (\<exists>D. (\<forall>nl.
         (nl \<in> nls \<longrightarrow> TMC_yields_num_res D nl (1::nat) )
       \<and> (nl \<notin> nls \<longrightarrow> TMC_yields_num_res D nl (0::nat) )
     ))"
  unfolding TMC_yields_num_res_unfolded_into_Hoare_halt
  by (simp add: turing_decidable_def)

(* --------------------------------------------------------------------------------------------- *)

subsection \<open>Examples for decidable sets of natural numbers\<close>

text \<open>Using the machine OneStrokeTM as a decider
we are able to proof the decidability of the empty set.
Moreover, in the theory about Halting Problems, we will show that there are undecidable sets as well.
Thus, the notion of Turing Decidability is not a trivial concept.
\<close>

lemma turing_decidable_empty_set_iff:
  "turing_decidable {} = (\<exists>D. \<forall>(nl:: nat list).
        \<lbrace>(\<lambda>tap. tap = ([], <nl>))\<rbrace> D \<lbrace>(\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up>l))\<rbrace>)"
  unfolding turing_decidable_def
  by (simp add: tape_of_nat_def)

theorem turing_decidable_empty_set: "turing_decidable {}"
  by (rule turing_decidable_empty_set_iff[THEN iffD2])
     (blast intro: tm_onestroke_total_correctness)

(* For demo in classes *)
(*
lemma tm_onestroke_total_correctness':
  "\<forall>nl. TMC_yields_num_res tm_onestroke nl (0::nat)"
  unfolding TMC_yields_num_res_unfolded_into_Hoare_halt
  using tm_onestroke_total_correctness by (simp add: tape_of_nat_def)

theorem turing_decidable_empty_set':
  "(\<forall>nl.
             (nl \<in> {} \<longrightarrow> TMC_yields_num_res tm_onestroke nl (1::nat) )
           \<and> (nl \<notin> {} \<longrightarrow> TMC_yields_num_res tm_onestroke nl (0::nat) )
         )"
  unfolding TMC_yields_num_res_unfolded_into_Hoare_halt
proof -
  show "\<forall>nl. (nl \<in> {} \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl::nat list>)\<rbrace> tm_onestroke \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <1::nat> @ Bk \<up> l)\<rbrace>) \<and>
               (nl \<notin> {} \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl::nat list>)\<rbrace> tm_onestroke \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <0::nat> @ Bk \<up> l)\<rbrace>)"
  proof
    fix nl:: "nat list"
    show "(nl \<in> {} \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> tm_onestroke \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <1::nat> @ Bk \<up> l)\<rbrace>) \<and>
          (nl \<notin> {} \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> tm_onestroke \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <0::nat> @ Bk \<up> l)\<rbrace>)"
    proof
      show "nl \<in> {} \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> tm_onestroke \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <1::nat> @ Bk \<up> l)\<rbrace>"
      proof
        assume "nl \<in> {}" (* nothing can ever be an element of the empty set {}, thus contradiction *)
        then have False by auto
        then show "\<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> tm_onestroke \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <1::nat> @ Bk \<up> l)\<rbrace>" by auto
      qed
    next
      show "nl \<notin> {} \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> tm_onestroke \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <0::nat> @ Bk \<up> l)\<rbrace>"
      proof
        assume "nl \<notin> {}"
        have "\<forall>nl.\<lbrace>\<lambda>tap. tap = ([], <nl::nat list>)\<rbrace> tm_onestroke \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <0::nat> @ Bk \<up> l)\<rbrace>"
          using TMC_yields_num_res_unfolded_into_Hoare_halt tm_onestroke_total_correctness' by blast
        then show "\<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> tm_onestroke \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <0::nat> @ Bk \<up> l)\<rbrace>" by auto
      qed
    qed
  qed
qed

corollary "turing_decidable {}"
  unfolding turing_decidable_unfolded_into_TMC_yields_conditions
  using turing_decidable_empty_set' by auto
*)

(* ---------------------------------------------------- *)
(* ENHANCE: add a means for turing_semi_decidable       *)
(* ---------------------------------------------------- *)

(* ---------------------------------------------------- *)
(* ENHANCE: add a means for dove-tailing                *)
(* ---------------------------------------------------- *)

(* ---------------------------------------------------- *)
(* ENHANCE: prove advanced theorems about decidability  *)
(* ---------------------------------------------------- *)
(* - Step counter theorem ;aka (s,m,n) theorem          *)
(* - Rice's theorem for Turing Machines                 *)
(* ---------------------------------------------------- *)

end


(*  Title:      SetIntervalCut.thy
    Date:       Oct 2006
    Author:     David Trachtenherz
*)

(* header {* Cutting @{term linorder} and @{term nat} sets *} *)
header {* Cutting linearly ordered and natural sets *}

theory SetIntervalCut
imports SetInterval2
begin

subsection {* Set restriction *}

text {*
  A set to set function @{text f} is a @{text "set restriction"},
  if there exists a predicate @{text P},
  so that for every set @{text s} the function result @{text "f s"}
  contains all its elements fulfilling @{text P} *}
definition
  set_restriction :: "('a set \<Rightarrow> 'a set) \<Rightarrow> bool"
where
  "set_restriction f \<equiv> \<exists>P. \<forall>A. f A = {x \<in> A. P x}"

lemma set_restrictionD: "set_restriction f \<Longrightarrow> \<exists>P. \<forall>A. f A = {x \<in> A. P x}"
unfolding set_restriction_def by blast
lemma set_restrictionD_spec: "set_restriction f \<Longrightarrow> \<exists>P. f A = {x \<in> A. P x}"
unfolding set_restriction_def by blast
lemma set_restrictionI: "f = (\<lambda>A. {x \<in> A. P x}) \<Longrightarrow> set_restriction f"
unfolding set_restriction_def by blast

lemma set_restriction_comp: "
  \<lbrakk> set_restriction f; set_restriction g \<rbrakk> \<Longrightarrow> set_restriction (f \<circ> g)"
apply (unfold set_restriction_def)
apply (elim exE, rename_tac P1 P2)
apply (rule_tac x="\<lambda>x. P1 x \<and> P2 x" in exI)
apply fastforce
done
lemma set_restriction_commute: "
  \<lbrakk> set_restriction f; set_restriction g \<rbrakk> \<Longrightarrow> f (g I) = g (f I)"
unfolding set_restriction_def by fastforce

text {* Constructs a set restriction function with the given restriction predicate *}
definition
  set_restriction_fun :: "('a \<Rightarrow> bool) \<Rightarrow> ('a set \<Rightarrow> 'a set)"
where
  "set_restriction_fun P \<equiv> \<lambda>A. {x \<in> A. P x}"

lemma set_restriction_fun_is_set_restriction: "
  set_restriction (set_restriction_fun P)"
unfolding set_restriction_def set_restriction_fun_def by blast

lemma set_restriction_Int_conv:
  "set_restriction f = (\<exists>B. \<forall>A. f A = A \<inter> B)"
apply (unfold set_restriction_def)
apply (rule iffI)
apply (erule exE, rule_tac x="Collect P" in exI, blast)
apply (erule exE, rule_tac x="\<lambda>x. x \<in> B" in exI, blast)
done

lemma set_restriction_Un: "
  set_restriction f \<Longrightarrow> f (A \<union> B) = f A \<union> f B"
unfolding set_restriction_def by fastforce
lemma set_restriction_Int: "
  set_restriction f \<Longrightarrow> f (A \<inter> B) = f A \<inter> f B"
unfolding set_restriction_def by fastforce
lemma set_restriction_Diff: "
  set_restriction f \<Longrightarrow> f (A - B) = f A - f B"
unfolding set_restriction_def by fastforce
lemma set_restriction_mono: "
  \<lbrakk> set_restriction f; A \<subseteq> B \<rbrakk> \<Longrightarrow> f A \<subseteq> f B"
unfolding set_restriction_def by fastforce
lemma set_restriction_absorb: "
  set_restriction f \<Longrightarrow> f (f A) = f A"
unfolding set_restriction_def by fastforce
lemma set_restriction_empty: "
  set_restriction f \<Longrightarrow> f {} = {}"
unfolding set_restriction_def by blast
lemma set_restriction_non_empty_imp: "
  \<lbrakk> set_restriction f; f A \<noteq> {} \<rbrakk> \<Longrightarrow> A \<noteq> {}"
unfolding set_restriction_def by blast
lemma set_restriction_subset: "
  set_restriction f \<Longrightarrow> f A \<subseteq> A"
unfolding set_restriction_def by blast
lemma set_restriction_finite: "
  \<lbrakk> set_restriction f; finite A \<rbrakk> \<Longrightarrow> finite (f A)"
unfolding set_restriction_def by fastforce
lemma set_restriction_card: "
  \<lbrakk> set_restriction f; finite A \<rbrakk> \<Longrightarrow>
  card (f A) = card A - card {a \<in> A. f {a} = {}}"
apply (unfold set_restriction_def)
thm card_Diff_subset[symmetric]
apply (subgoal_tac "{a \<in> A. f {a} = {}} \<subseteq> A")
 prefer 2
 apply blast
apply (frule finite_subset, simp)
thm card_Diff_subset[symmetric]
apply (simp only: card_Diff_subset[symmetric])
apply (rule arg_cong[where f=card])
apply fastforce
done
lemma set_restriction_card_le: "
  \<lbrakk> set_restriction f; finite A \<rbrakk> \<Longrightarrow> card (f A) \<le> card A"
by (simp add: set_restriction_card)

lemma set_restriction_not_in_imp: "
  \<lbrakk> set_restriction f; x \<notin> A \<rbrakk> \<Longrightarrow> x \<notin> f A"
unfolding set_restriction_def by blast
lemma set_restriction_in_imp: "
  \<lbrakk> set_restriction f; x \<in> f A \<rbrakk> \<Longrightarrow> x \<in> A"
unfolding set_restriction_def by blast

lemma set_restriction_fun_singleton: "
  set_restriction_fun P {a} = (if P a then {a} else {})"
unfolding set_restriction_fun_def by force
lemma set_restriction_fun_all_conv: "
  ((set_restriction_fun P) A = A) = (\<forall>x\<in>A. P x)"
unfolding set_restriction_fun_def by blast
lemma set_restriction_fun_empty_conv: "
  ((set_restriction_fun P) A = {}) = (\<forall>x\<in>A. \<not> P x)"
unfolding set_restriction_fun_def by blast

subsection {* Cut operators for sets/intervals *}

subsubsection {* Definitions and basic lemmata for cut operators *}

definition
  cut_le :: "'a::linorder set \<Rightarrow> 'a \<Rightarrow> 'a set"           ( infixl "\<down>\<le>" 100 )
where
  "I \<down>\<le> t \<equiv> { x\<in>I. x \<le> t }"
definition
  cut_less :: "'a::linorder set \<Rightarrow> 'a \<Rightarrow> 'a set"         ( infixl "\<down><" 100 )
where
  "I \<down>< t \<equiv> { x\<in>I. x < t }"

definition
  cut_ge :: "'a::linorder set \<Rightarrow> 'a \<Rightarrow> 'a set"           ( infixl "\<down>\<ge>" 100 )
where
  "I \<down>\<ge> t \<equiv> { x\<in>I. t \<le> x }"
definition
  cut_greater :: "'a::linorder set \<Rightarrow> 'a \<Rightarrow> 'a set"      ( infixl "\<down>>" 100 )
where
  "I \<down>> t \<equiv> { x\<in>I. t < x }"

lemmas i_cut_defs =
  cut_le_def cut_less_def
  cut_ge_def cut_greater_def
thm i_cut_defs

lemma cut_le_mem_iff: "x \<in> I \<down>\<le> t = (x \<in> I \<and> x \<le> t)"
by (unfold cut_le_def, blast)
lemma cut_less_mem_iff: "x \<in> I \<down>< t = (x \<in> I \<and> x < t)"
by (unfold cut_less_def, blast)
lemma cut_ge_mem_iff: "x \<in> I \<down>\<ge> t = (x \<in> I \<and> t \<le> x)"
by (unfold cut_ge_def, blast)
lemma cut_greater_mem_iff: "x \<in> I \<down>> t = (x \<in> I \<and> t < x)"
by (unfold cut_greater_def, blast)

lemmas i_cut_mem_iff =
  cut_le_mem_iff cut_less_mem_iff
  cut_ge_mem_iff cut_greater_mem_iff
thm i_cut_mem_iff

lemma
  cut_leI [intro!]:      "x \<in> I \<Longrightarrow> x \<le> t \<Longrightarrow> x \<in> I \<down>\<le> t" and
  cut_lessI [intro!]:    "x \<in> I \<Longrightarrow> x < t \<Longrightarrow> x \<in> I \<down>< t" and
  cut_geI [intro!]:      "x \<in> I \<Longrightarrow> x \<ge> t \<Longrightarrow> x \<in> I \<down>\<ge> t" and
  cut_greaterI [intro!]: "x \<in> I \<Longrightarrow> x > t \<Longrightarrow> x \<in> I \<down>> t"
by (simp_all add: i_cut_mem_iff)

lemma
  cut_leE [elim!]:      "x \<in> I \<down>\<le> t \<Longrightarrow> (x \<in> I \<Longrightarrow> x \<le> t \<Longrightarrow> P) \<Longrightarrow> P" and
  cut_lessE [elim!]:    "x \<in> I \<down>< t \<Longrightarrow> (x \<in> I \<Longrightarrow> x < t \<Longrightarrow> P) \<Longrightarrow> P" and
  cut_geE [elim!]:      "x \<in> I \<down>\<ge> t \<Longrightarrow> (x \<in> I \<Longrightarrow> x \<ge> t \<Longrightarrow> P) \<Longrightarrow> P" and
  cut_greaterE [elim!]: "x \<in> I \<down>> t \<Longrightarrow> (x \<in> I \<Longrightarrow> x > t \<Longrightarrow> P) \<Longrightarrow> P"
by (simp_all add: i_cut_mem_iff)

lemma
  cut_less_bound:    "n \<in> I \<down>< t \<Longrightarrow> n < t" and
  cut_le_bound:      "n \<in> I \<down>\<le> t \<Longrightarrow> n \<le> t" and
  cut_greater_bound: "n \<in> i \<down>> t \<Longrightarrow> t < n" and
  cut_ge_bound:      "n \<in> i \<down>\<ge> t \<Longrightarrow> t \<le> n"
unfolding i_cut_defs by simp_all
lemmas i_cut_bound =
  cut_less_bound cut_le_bound
  cut_greater_bound cut_ge_bound

lemma
  cut_le_Int_conv: "I \<down>\<le> t = I \<inter> {..t}" and
  cut_less_Int_conv: "I \<down>< t = I \<inter> {..<t}" and
  cut_ge_Int_conv: "I \<down>\<ge> t = I \<inter> {t..}" and
  cut_greater_Int_conv: "I \<down>> t = I \<inter> {t<..}"
unfolding i_cut_defs by blast+

lemmas i_cut_Int_conv =
  cut_le_Int_conv cut_less_Int_conv
  cut_ge_Int_conv cut_greater_Int_conv
thm i_cut_Int_conv

lemma
  cut_le_Diff_conv: "I \<down>\<le> t = I - {t<..}" and
  cut_less_Diff_conv: "I \<down>< t = I - {t..}" and
  cut_ge_Diff_conv: "I \<down>\<ge> t = I - {..<t}" and
  cut_greater_Diff_conv: "I \<down>> t = I - {..t}"
by (fastforce simp: i_cut_defs)+
lemmas i_cut_Diff_conv =
  cut_le_Diff_conv cut_less_Diff_conv
  cut_ge_Diff_conv cut_greater_Diff_conv
thm i_cut_Diff_conv

subsubsection {* Basic results for cut operators *}

lemma
  cut_less_eq_set_restriction_fun':    "(\<lambda>I. I \<down>< t) = set_restriction_fun (\<lambda>x. x < t)" and
  cut_le_eq_set_restriction_fun':      "(\<lambda>I. I \<down>\<le> t) = set_restriction_fun (\<lambda>x. x \<le> t)" and
  cut_greater_eq_set_restriction_fun': "(\<lambda>I. I \<down>> t) = set_restriction_fun (\<lambda>x. x > t)" and
  cut_ge_eq_set_restriction_fun':      "(\<lambda>I. I \<down>\<ge> t) = set_restriction_fun (\<lambda>x. x \<ge> t)"
unfolding set_restriction_fun_def i_cut_defs by blast+
lemmas i_cut_eq_set_restriction_fun' =
  cut_less_eq_set_restriction_fun' cut_le_eq_set_restriction_fun'
  cut_greater_eq_set_restriction_fun' cut_ge_eq_set_restriction_fun'

lemma
  cut_less_eq_set_restriction_fun:    "I \<down>< t = set_restriction_fun (\<lambda>x. x < t) I" and
  cut_le_eq_set_restriction_fun:      "I \<down>\<le> t = set_restriction_fun (\<lambda>x. x \<le> t) I" and
  cut_greater_eq_set_restriction_fun: "I \<down>> t = set_restriction_fun (\<lambda>x. x > t) I" and
  cut_ge_eq_set_restriction_fun:      "I \<down>\<ge> t = set_restriction_fun (\<lambda>x. x \<ge> t) I"
by (simp_all only: i_cut_eq_set_restriction_fun'[symmetric])
lemmas i_cut_eq_set_restriction_fun =
  cut_less_eq_set_restriction_fun cut_le_eq_set_restriction_fun
  cut_greater_eq_set_restriction_fun cut_ge_eq_set_restriction_fun

lemma i_cut_set_restriction_disj: "
  \<lbrakk> cut_op = op \<down>< \<or> cut_op = op \<down>\<le> \<or>
    cut_op = op \<down>> \<or> cut_op = op \<down>\<ge>;
    f = (\<lambda>I. cut_op I t)  \<rbrakk> \<Longrightarrow> set_restriction f"
apply safe
apply (simp_all only: i_cut_eq_set_restriction_fun set_restriction_fun_is_set_restriction)
done
thm set_restriction_def
corollary
  i_cut_less_set_restriction:    "set_restriction (\<lambda>I. I \<down>< t)" and
  i_cut_le_set_restriction:      "set_restriction (\<lambda>I. I \<down>\<le> t)" and
  i_cut_greater_set_restriction: "set_restriction (\<lambda>I. I \<down>> t)" and
  i_cut_ge_set_restriction:      "set_restriction (\<lambda>I. I \<down>\<ge> t)"
by (simp_all only: i_cut_eq_set_restriction_fun set_restriction_fun_is_set_restriction)
lemmas i_cut_set_restriction =
  i_cut_le_set_restriction i_cut_less_set_restriction
  i_cut_ge_set_restriction i_cut_greater_set_restriction
lemma i_cut_commute_disj: "\<lbrakk>
  cut_op1 = op \<down>< \<or> cut_op1 = op \<down>\<le> \<or>
  cut_op1 = op \<down>> \<or> cut_op1 = op \<down>\<ge>;
  cut_op2 = op \<down>< \<or> cut_op2 = op \<down>\<le> \<or>
  cut_op2 = op \<down>> \<or> cut_op2 = op \<down>\<ge> \<rbrakk> \<Longrightarrow>
  cut_op2 (cut_op1 I t1) t2 = cut_op1 (cut_op2 I t2) t1"
thm
  set_restriction_commute[of "\<lambda>I. cut_op1 I t"]
  i_cut_set_restriction_disj
apply (rule set_restriction_commute)
apply (simp_all only: i_cut_set_restriction_disj)
done
thm i_cut_commute_disj
thm i_cut_commute_disj[of "op \<down><" "op \<down><", simplified]
thm i_cut_commute_disj[of "op \<down><" "op \<down>>", simplified]
thm i_cut_commute_disj[of "op \<down>\<le>" "op \<down>>", simplified]
thm i_cut_commute_disj[of "op \<down>\<ge>" "op \<down>>", simplified]

lemma
  cut_less_empty:    "{} \<down>< t = {}" and
  cut_le_empty:      "{} \<down>\<le> t = {}" and
  cut_greater_empty: "{} \<down>> t = {}" and
  cut_ge_empty:      "{} \<down>\<ge> t = {}"
by blast+
lemmas i_cut_empty =
  cut_less_empty cut_le_empty
  cut_greater_empty cut_ge_empty
thm i_cut_empty

lemma
  cut_less_not_empty_imp:    "I \<down>< t \<noteq> {} \<Longrightarrow> I \<noteq> {}" and
  cut_le_not_empty_imp:      "I \<down>\<le> t \<noteq> {} \<Longrightarrow> I \<noteq> {}" and
  cut_greater_not_empty_imp: "I \<down>> t \<noteq> {} \<Longrightarrow> I \<noteq> {}" and
  cut_ge_not_empty_imp:      "I \<down>\<ge> t \<noteq> {} \<Longrightarrow> I \<noteq> {}"
by blast+

lemma
  cut_less_singleton:    "{a} \<down>< t = (if a < t then {a} else {})" and
  cut_le_singleton:      "{a} \<down>\<le> t = (if a \<le> t then {a} else {})" and
  cut_greater_singleton: "{a} \<down>> t = (if a > t then {a} else {})" and
  cut_ge_singleton:      "{a} \<down>\<ge> t = (if a \<ge> t then {a} else {})"
by (rule i_cut_eq_set_restriction_fun[THEN ssubst], simp only: set_restriction_fun_singleton)+
lemmas i_cut_singleton =
  cut_le_singleton cut_less_singleton
  cut_ge_singleton cut_greater_singleton

lemma
  cut_less_subset:    "I \<down>< t \<subseteq> I" and
  cut_le_subset:      "I \<down>\<le> t \<subseteq> I" and
  cut_greater_subset: "I \<down>> t \<subseteq> I" and
  cut_ge_subset:      "I \<down>\<ge> t \<subseteq> I"
thm i_cut_set_restriction[THEN set_restriction_subset]
by (simp_all only: i_cut_set_restriction[THEN set_restriction_subset])
lemmas i_cut_subset =
  cut_less_subset cut_le_subset
  cut_greater_subset cut_ge_subset
thm i_cut_subset

thm set_restriction_Un
lemma i_cut_Un_disj: "
  \<lbrakk> cut_op = op \<down>< \<or> cut_op = op \<down>\<le> \<or>
    cut_op = op \<down>> \<or> cut_op = op \<down>\<ge> \<rbrakk>
  \<Longrightarrow> cut_op (A \<union> B) t = cut_op A t \<union> cut_op B t"
thm i_cut_set_restriction_disj[of cut_op "\<lambda>I. cut_op I t" t]
apply (drule i_cut_set_restriction_disj[where f="\<lambda>I. cut_op I t"], simp)
thm set_restriction_Un
by (rule set_restriction_Un)

corollary
  cut_less_Un:    "(A \<union> B) \<down>< t = A \<down>< t \<union> B \<down>< t" and
  cut_le_Un:      "(A \<union> B) \<down>\<le> t = A \<down>\<le> t \<union> B \<down>\<le> t" and
  cut_greater_Un: "(A \<union> B) \<down>> t = A \<down>> t \<union> B \<down>> t" and
  cut_ge_Un:      "(A \<union> B) \<down>\<ge> t = A \<down>\<ge> t \<union> B \<down>\<ge> t"
by (rule i_cut_Un_disj, blast)+
lemmas i_cut_Un =
  cut_less_Un cut_le_Un
  cut_greater_Un cut_ge_Un

lemma i_cut_Int_disj: "
  \<lbrakk> cut_op = op \<down>< \<or> cut_op = op \<down>\<le> \<or>
    cut_op = op \<down>> \<or> cut_op = op \<down>\<ge> \<rbrakk>
  \<Longrightarrow> cut_op (A \<inter> B) t = cut_op A t \<inter> cut_op B t"
apply (drule i_cut_set_restriction_disj[where f="\<lambda>I. cut_op I t"], simp)
by (rule set_restriction_Int)

lemma
  cut_less_Int:    "(A \<inter> B) \<down>< t = A \<down>< t \<inter> B \<down>< t" and
  cut_le_Int:      "(A \<inter> B) \<down>\<le> t = A \<down>\<le> t \<inter> B \<down>\<le> t" and
  cut_greater_Int: "(A \<inter> B) \<down>> t = A \<down>> t \<inter> B \<down>> t" and
  cut_ge_Int:      "(A \<inter> B) \<down>\<ge> t = A \<down>\<ge> t \<inter> B \<down>\<ge> t"
by blast+
lemmas i_cut_Int =
  cut_less_Int cut_le_Int
  cut_greater_Int cut_ge_Int

lemma
  cut_less_Int_left:    "(A \<inter> B) \<down>< t = A \<down>< t \<inter> B" and
  cut_le_Int_left:      "(A \<inter> B) \<down>\<le> t = A \<down>\<le> t \<inter> B" and
  cut_greater_Int_left: "(A \<inter> B) \<down>> t = A \<down>> t \<inter> B" and
  cut_ge_Int_left:      "(A \<inter> B) \<down>\<ge> t = A \<down>\<ge> t \<inter> B"
by blast+
lemmas i_cut_Int_left =
  cut_less_Int_left cut_le_Int_left
  cut_greater_Int_left cut_ge_Int_left

lemma
  cut_less_Int_right:    "(A \<inter> B) \<down>< t = A \<inter> B \<down>< t" and
  cut_le_Int_right:      "(A \<inter> B) \<down>\<le> t = A \<inter> B \<down>\<le> t" and
  cut_greater_Int_right: "(A \<inter> B) \<down>> t = A \<inter> B \<down>> t" and
  cut_ge_Int_right:      "(A \<inter> B) \<down>\<ge> t = A \<inter> B \<down>\<ge> t"
by blast+
lemmas i_cut_Int_right =
  cut_less_Int_right cut_le_Int_right
  cut_greater_Int_right cut_ge_Int_right

lemma i_cut_Diff_disj: "
  \<lbrakk> cut_op = op \<down>< \<or> cut_op = op \<down>\<le> \<or>
    cut_op = op \<down>> \<or> cut_op = op \<down>\<ge> \<rbrakk>
  \<Longrightarrow> cut_op (A - B) t = cut_op A t - cut_op B t"
apply (drule i_cut_set_restriction_disj[where f="\<lambda>I. cut_op I t"], simp)
by (rule set_restriction_Diff)
corollary
  cut_less_Diff:    "(A - B) \<down>< t = A \<down>< t - B \<down>< t" and
  cut_le_Diff:      "(A - B) \<down>\<le> t = A \<down>\<le> t - B \<down>\<le> t" and
  cut_greater_Diff: "(A - B) \<down>> t = A \<down>> t - B \<down>> t" and
  cut_ge_Diff:      "(A - B) \<down>\<ge> t = A \<down>\<ge> t - B \<down>\<ge> t"
by (rule i_cut_Diff_disj, blast)+
lemmas i_cut_Diff =
  cut_less_Diff cut_le_Diff
  cut_greater_Diff cut_ge_Diff

thm set_restriction_mono
lemma i_cut_subset_mono_disj: "
  \<lbrakk> cut_op = op \<down>< \<or> cut_op = op \<down>\<le> \<or>
    cut_op = op \<down>> \<or> cut_op = op \<down>\<ge>; A \<subseteq> B \<rbrakk>
  \<Longrightarrow> cut_op A t \<subseteq> cut_op B t"
apply (drule i_cut_set_restriction_disj[where f="\<lambda>I. cut_op I t"], simp)
thm set_restriction_mono[where f="\<lambda>I. cut_op I t"]
by (rule set_restriction_mono[where f="\<lambda>I. cut_op I t"])
corollary
  cut_less_subset_mono:    "A \<subseteq> B \<Longrightarrow> A \<down>< t \<subseteq> B \<down>< t" and
  cut_le_subset_mono:      "A \<subseteq> B \<Longrightarrow> A \<down>\<le> t \<subseteq> B \<down>\<le> t" and
  cut_greater_subset_mono: "A \<subseteq> B \<Longrightarrow> A \<down>> t \<subseteq> B \<down>> t" and
  cut_ge_subset_mono:      "A \<subseteq> B \<Longrightarrow> A \<down>\<ge> t \<subseteq> B \<down>\<ge> t"
by (rule i_cut_subset_mono_disj[of _ A], simp+)+
lemmas i_cut_subset_mono =
  cut_less_subset_mono cut_le_subset_mono
  cut_greater_subset_mono cut_ge_subset_mono

lemma
  cut_less_mono:    "t \<le> t' \<Longrightarrow> I \<down>< t \<subseteq> I \<down>< t'" and
  cut_greater_mono: "t' \<le> t \<Longrightarrow> I \<down>> t \<subseteq> I \<down>> t'" and
  cut_le_mono:      "t \<le> t' \<Longrightarrow> I \<down>\<le> t \<subseteq> I \<down>\<le> t'" and
  cut_ge_mono:      "t' \<le> t \<Longrightarrow> I \<down>\<ge> t \<subseteq> I \<down>\<ge> t'"
by (unfold i_cut_defs, safe, simp_all)
lemmas i_cut_mono =
  cut_le_mono cut_less_mono
  cut_ge_mono cut_greater_mono

lemma
  cut_cut_le: "i \<down>\<le> a \<down>\<le> b = i \<down>\<le> min a b" and
  cut_cut_less: "i \<down>< a \<down>< b = i \<down>< min a b" and
  cut_cut_ge: "i \<down>\<ge> a \<down>\<ge> b = i \<down>\<ge> max a b" and
  cut_cut_greater: "i \<down>> a \<down>> b = i \<down>> max a b"
unfolding i_cut_defs by simp_all
lemmas i_cut_cut =
  cut_cut_le cut_cut_less
  cut_cut_ge cut_cut_greater

lemma i_cut_absorb_disj: "
  \<lbrakk> cut_op = op \<down>< \<or> cut_op = op \<down>\<le> \<or>
    cut_op = op \<down>> \<or> cut_op = op \<down>\<ge> \<rbrakk>
  \<Longrightarrow> cut_op (cut_op I t) t = cut_op I t"
thm i_cut_set_restriction_disj[where f="\<lambda>I. cut_op I t"]
apply (drule i_cut_set_restriction_disj[where f="\<lambda>I. cut_op I t"], blast)
thm set_restriction_absorb
apply (blast dest: set_restriction_absorb)
done
corollary
  cut_le_absorb:      "I \<down>\<le> t \<down>\<le> t = I \<down>\<le> t" and
  cut_less_absorb:    "I \<down>< t \<down>< t = I \<down>< t" and
  cut_ge_absorb:      "I \<down>\<ge> t \<down>\<ge> t = I \<down>\<ge> t" and
  cut_greater_absorb: "I \<down>> t \<down>> t = I \<down>> t"
thm i_cut_absorb_disj
by (rule i_cut_absorb_disj, blast)+
lemmas i_cut_absorb =
  cut_le_absorb cut_less_absorb
  cut_ge_absorb cut_greater_absorb

lemma
  cut_less_0_empty: "I \<down>< (0::nat) = {}" and
  cut_ge_0_all:     "I \<down>\<ge> (0::nat) = I"
unfolding i_cut_defs by blast+

lemma
  cut_le_all_iff:      "(I \<down>\<le> t = I) = (\<forall>x\<in>I. x \<le> t)" and
  cut_less_all_iff:    "(I \<down>< t = I) = (\<forall>x\<in>I. x < t)" and
  cut_ge_all_iff:      "(I \<down>\<ge> t = I) = (\<forall>x\<in>I. x \<ge> t)" and
  cut_greater_all_iff: "(I \<down>> t = I) = (\<forall>x\<in>I. x > t)"
by blast+
lemmas i_cut_all_iff =
  cut_le_all_iff cut_less_all_iff
  cut_ge_all_iff cut_greater_all_iff

lemma
  cut_le_empty_iff:      "(I \<down>\<le> t = {}) = (\<forall>x\<in>I. t < x)" and
  cut_less_empty_iff:    "(I \<down>< t = {}) = (\<forall>x\<in>I. t \<le> x)" and
  cut_ge_empty_iff:      "(I \<down>\<ge> t = {}) = (\<forall>x\<in>I. x < t)" and
  cut_greater_empty_iff: "(I \<down>> t = {}) = (\<forall>x\<in>I. x \<le> t)"
unfolding i_cut_defs by fastforce+
lemmas i_cut_empty_iff =
  cut_le_empty_iff cut_less_empty_iff
  cut_ge_empty_iff cut_greater_empty_iff

lemma
  cut_le_not_empty_iff:      "(I \<down>\<le> t \<noteq> {}) = (\<exists>x\<in>I. x \<le> t)" and
  cut_less_not_empty_iff:    "(I \<down>< t \<noteq> {}) = (\<exists>x\<in>I. x < t)" and
  cut_ge_not_empty_iff:      "(I \<down>\<ge> t \<noteq> {}) = (\<exists>x\<in>I. t \<le> x)" and
  cut_greater_not_empty_iff: "(I \<down>> t \<noteq> {}) = (\<exists>x\<in>I. t < x)"
unfolding i_cut_defs by blast+

lemmas i_cut_not_empty_iff =
  cut_le_not_empty_iff cut_less_not_empty_iff
  cut_ge_not_empty_iff cut_greater_not_empty_iff
thm i_cut_not_empty_iff

lemma nat_cut_ge_infinite_not_empty: "infinite I \<Longrightarrow> I \<down>\<ge> (t::nat) \<noteq> {}"
by (drule infinite_nat_iff_unbounded_le[THEN iffD1], blast)
lemma nat_cut_greater_infinite_not_empty: "infinite I \<Longrightarrow> I \<down>> (t::nat) \<noteq> {}"
by (drule infinite_nat_iff_unbounded[THEN iffD1], blast)

thm set_restriction_not_in_imp
corollary
  cut_le_not_in_imp:      "x \<notin> I \<Longrightarrow> x \<notin> I \<down>\<le> t" and
  cut_less_not_in_imp:    "x \<notin> I \<Longrightarrow> x \<notin> I \<down>< t" and
  cut_ge_not_in_imp:      "x \<notin> I \<Longrightarrow> x \<notin> I \<down>\<ge> t" and
  cut_greater_not_in_imp: "x \<notin> I \<Longrightarrow> x \<notin> I \<down>> t"
thm i_cut_set_restriction[THEN set_restriction_not_in_imp]
by (rule i_cut_set_restriction[THEN set_restriction_not_in_imp], assumption)+
lemmas i_cut_not_in_imp =
  cut_le_not_in_imp cut_less_not_in_imp
  cut_ge_not_in_imp cut_greater_not_in_imp

thm set_restriction_in_imp
corollary
  cut_le_in_imp:      "x \<in> I \<down>\<le> t \<Longrightarrow> x \<in> I" and
  cut_less_in_imp:    "x \<in> I \<down>< t \<Longrightarrow> x \<in> I" and
  cut_ge_in_imp:      "x \<in> I \<down>\<ge> t \<Longrightarrow> x \<in> I" and
  cut_greater_in_imp: "x \<in> I \<down>> t \<Longrightarrow> x \<in> I"
thm i_cut_set_restriction[THEN set_restriction_in_imp]
by (rule i_cut_set_restriction[THEN set_restriction_in_imp], assumption)+
lemmas i_cut_in_imp =
  cut_le_in_imp cut_less_in_imp
  cut_ge_in_imp cut_greater_in_imp

lemma Collect_minI_cut: "\<lbrakk> k \<in> I; P (k::('a::wellorder)) \<rbrakk> \<Longrightarrow> \<exists>x\<in>I. P x \<and> (\<forall>y\<in>(I \<down>< x). \<not> P y)"
by (drule Collect_minI, assumption, blast)
corollary Collect_minI_ex_cut: "\<exists>k\<in>I. P (k::('a::wellorder)) \<Longrightarrow> \<exists>x\<in>I. P x \<and> (\<forall>y\<in>(I \<down>< x). \<not> P y)"
by (drule Collect_minI_ex, blast)
corollary Collect_minI_ex2_cut: "{k\<in>I. P (k::('a::wellorder))} \<noteq> {} \<Longrightarrow> \<exists>x\<in>I. P x \<and> (\<forall>y\<in>(I \<down>< x). \<not> P y)"
by (drule Collect_minI_ex2, blast)

lemma cut_le_cut_greater_ident: "t2 \<le> t1 \<Longrightarrow> I \<down>\<le> t1 \<union> I \<down>> t2 = I"
by fastforce
lemma cut_less_cut_ge_ident: "t2 \<le> t1 \<Longrightarrow> I \<down>< t1 \<union> I \<down>\<ge> t2 = I"
by fastforce
lemma cut_le_cut_ge_ident: "t2 \<le> t1 \<Longrightarrow> I \<down>\<le> t1 \<union> I \<down>\<ge> t2 = I"
by fastforce

lemma cut_less_cut_greater_ident: "
  \<lbrakk> t2 \<le> t1; I \<inter> {t1..t2} = {} \<rbrakk> \<Longrightarrow> I \<down>< t1 \<union> I \<down>> t2 = I"
by fastforce
corollary cut_less_cut_greater_ident': "
  t \<notin> I \<Longrightarrow> I \<down>< t \<union> I \<down>> t = I"
by (simp add: cut_less_cut_greater_ident)

lemma insert_eq_cut_less_cut_greater: "insert n I = I \<down>< n \<union> {n} \<union> I \<down>> n"
by fastforce

subsubsection {* Relations between cut operators *}

lemma insert_Int_conv_if: "A \<inter> (insert x B) = (
  if x \<in> A then insert x (A \<inter> B) else A \<inter> B)"
by simp

lemma cut_le_less_conv_if: "I \<down>\<le> t = (
  if t \<in> I then insert t (I \<down>< t) else (I \<down>< t))"
by (simp add: i_cut_Int_conv lessThan_insert[symmetric] insert_Int_conv_if)

lemma cut_le_less_conv: "I \<down>\<le> t = ({t} \<inter> I) \<union> (I \<down>< t)"
by fastforce

lemma cut_less_le_conv: "I \<down>< t = (I \<down>\<le> t) - {t}"
by fastforce
lemma cut_less_le_conv_if: "I \<down>< t = (
  if t \<in> I then (I \<down>\<le> t) - {t} else (I \<down>\<le> t))"
by (simp only: cut_less_le_conv, force)

lemma cut_ge_greater_conv_if: "I \<down>\<ge> t = (
  if t \<in> I then insert t (I \<down>> t) else (I \<down>> t))"
by (simp add: i_cut_Int_conv greaterThan_insert[symmetric] insert_Int_conv_if)
lemma cut_ge_greater_conv: "I \<down>\<ge> t = ({t} \<inter> I) \<union> (I \<down>> t)"
apply (simp only: cut_ge_greater_conv_if)
apply (case_tac "t \<in> I")
apply simp_all
done
lemma cut_greater_ge_conv: "I \<down>> t = (I \<down>\<ge> t) - {t}"
by fastforce
lemma cut_greater_ge_conv_if: "I \<down>> t = (
  if t \<in> I then (I \<down>\<ge> t) - {t} else (I \<down>\<ge> t))"
by (simp only: cut_greater_ge_conv, force)

lemma nat_cut_le_less_conv: "I \<down>\<le> t = I \<down>< Suc t"
by fastforce
lemma nat_cut_less_le_conv: "0 < t \<Longrightarrow> I \<down>< t = I \<down>\<le> (t - Suc 0)"
by fastforce
lemma nat_cut_ge_greater_conv: "I \<down>\<ge> Suc t = I \<down>> t"
by fastforce
lemma nat_cut_greater_ge_conv: "0 < t \<Longrightarrow> I \<down>> (t - Suc 0) = I \<down>\<ge> t"
by fastforce

subsubsection {* Function images with cut operators *}

lemma cut_less_image: "
  \<lbrakk> strict_mono_on f A; I \<subseteq> A; n \<in> A \<rbrakk> \<Longrightarrow>
  (f ` I) \<down>< f n = f ` (I \<down>< n)"
apply (rule set_eqI)
apply (simp add: image_iff Bex_def cut_less_mem_iff)
apply (unfold strict_mono_on_def)
apply (rule iffI)
 apply (metis not_less_iff_gr_or_eq set_rev_mp)
apply blast
done

lemma cut_le_image: "
  \<lbrakk> strict_mono_on f A; I \<subseteq> A; n \<in> A \<rbrakk> \<Longrightarrow>
  (f ` I) \<down>\<le> f n = f ` (I \<down>\<le> n)"
apply (frule strict_mono_on_imp_inj_on)
thm cut_le_less_conv_if
apply (clarsimp simp: cut_le_less_conv_if cut_less_image inj_on_def)
apply blast
done

lemma cut_greater_image: "
  \<lbrakk> strict_mono_on f A; I \<subseteq> A; n \<in> A \<rbrakk> \<Longrightarrow>
  (f ` I) \<down>> f n = f ` (I \<down>> n)"
apply (rule set_eqI)
apply (simp add: image_iff Bex_def cut_greater_mem_iff)
apply (unfold strict_mono_on_def)
apply (rule iffI)
 apply (metis not_less_iff_gr_or_eq set_rev_mp)
apply blast
done

lemma cut_ge_image: "
  \<lbrakk> strict_mono_on f A; I \<subseteq> A; n \<in> A \<rbrakk> \<Longrightarrow>
  (f ` I) \<down>\<ge> f n = f ` (I \<down>\<ge> n)"
apply (frule strict_mono_on_imp_inj_on)
thm cut_ge_greater_conv_if
apply (clarsimp simp: cut_ge_greater_conv_if cut_greater_image inj_on_def)
apply blast
done

lemmas i_cut_image =
  cut_le_image cut_less_image
  cut_ge_image cut_greater_image
thm i_cut_image
thm i_cut_image[OF _ subset_refl]

subsubsection {* Finiteness and cardinality with cut operators *}

thm set_restriction_finite
lemma
  cut_le_finite:      "finite I \<Longrightarrow> finite (I \<down>\<le> t)" and
  cut_less_finite:    "finite I \<Longrightarrow> finite (I \<down>< t)" and
  cut_ge_finite:      "finite I \<Longrightarrow> finite (I \<down>\<ge> t)" and
  cut_greater_finite: "finite I \<Longrightarrow> finite (I \<down>> t)"
thm finite_subset
by (rule finite_subset[of _ I], rule i_cut_subset, assumption+)+

lemma nat_cut_le_finite: "finite (I \<down>\<le> (t::nat))"
by (fastforce simp: finite_nat_iff_bounded_le2 cut_le_def)
lemma nat_cut_less_finite: "finite (I \<down>< (t::nat))"
by (fastforce simp: finite_nat_iff_bounded2 cut_less_def)
lemma nat_cut_ge_finite_iff: "finite (I \<down>\<ge> (t::nat)) = finite I"
apply (rule iffI)
 thm cut_less_cut_ge_ident[OF order_refl]
 apply (subst cut_less_cut_ge_ident[of t, OF order_refl, symmetric])
 apply (simp add: nat_cut_less_finite)
apply (simp add: cut_ge_finite)
done
lemma nat_cut_greater_finite_iff: "finite (I \<down>> (t::nat)) = finite I"
thm cut_ge_greater_conv
by (simp only: nat_cut_ge_greater_conv[symmetric] nat_cut_ge_finite_iff)

lemma
  cut_le_card:      "finite I \<Longrightarrow> card (I \<down>\<le> t) \<le> card I" and
  cut_less_card:    "finite I \<Longrightarrow> card (I \<down>< t) \<le> card I" and
  cut_ge_card:      "finite I \<Longrightarrow> card (I \<down>\<ge> t) \<le> card I" and
  cut_greater_card: "finite I \<Longrightarrow> card (I \<down>> t) \<le> card I"
by (rule card_mono, assumption, rule i_cut_subset)+

lemma nat_cut_greater_card: "card (I \<down>> (t::nat)) \<le> card I"
apply (case_tac "finite I")
 apply (simp add: cut_greater_card)
thm nat_cut_greater_finite_iff
apply (simp add: nat_cut_greater_finite_iff)
done
lemma nat_cut_ge_card: "card (I \<down>\<ge> (t::nat)) \<le> card I"
apply (case_tac "finite I")
 apply (simp add: cut_ge_card)
thm nat_cut_ge_finite_iff
apply (simp add: nat_cut_ge_finite_iff)
done

subsubsection {* Cutting a set at  @{text Min} or @{text Max} element *}

lemma cut_greater_Min_eq_Diff: "I \<down>> (iMin I) = I - {iMin I}"
by blast
lemma cut_less_Max_eq_Diff: "finite I \<Longrightarrow> I \<down>< (Max I) = I - {Max I}"
by blast

lemma cut_le_Min_empty: "t < iMin I \<Longrightarrow> I \<down>\<le> t = {}"
by (fastforce simp: i_cut_defs)
lemma cut_less_Min_empty: "t \<le> iMin I \<Longrightarrow> I \<down>< t = {}"
by (fastforce simp: i_cut_defs)

lemma cut_le_Min_not_empty: "\<lbrakk> I \<noteq> {}; iMin I \<le> t \<rbrakk> \<Longrightarrow> I \<down>\<le> t \<noteq> {}"
apply (simp add: i_cut_defs)
apply (rule_tac x="iMin I" in exI)
thm iMinI_ex2
apply (simp add: iMinI_ex2)
done
lemma cut_less_Min_not_empty: "\<lbrakk> I \<noteq> {}; iMin I < t \<rbrakk> \<Longrightarrow> I \<down>< t \<noteq> {}"
apply (simp add: i_cut_defs)
apply (rule_tac x="iMin I" in exI)
apply (simp add: iMinI_ex2)
done

lemma cut_ge_Min_all: "t \<le> iMin I \<Longrightarrow> I \<down>\<ge> t = I"
apply (simp add: i_cut_defs)
apply safe
thm iMin_le
apply (drule iMin_le, simp)
done

lemma cut_greater_Min_all: "t < iMin I \<Longrightarrow> I \<down>> t = I"
apply (simp add: i_cut_defs)
apply safe
thm iMin_le
apply (drule iMin_le, simp)
done

lemmas i_cut_min_empty =
  cut_le_Min_empty
  cut_less_Min_empty
  cut_le_Min_not_empty
  cut_less_Min_not_empty
lemmas i_cut_min_all =
  cut_ge_Min_all
  cut_greater_Min_all

thm
  i_cut_min_empty
  i_cut_min_all

lemma cut_ge_Max_empty: "finite I \<Longrightarrow> Max I < t \<Longrightarrow> I \<down>\<ge> t = {}"
by (fastforce simp: i_cut_defs)

lemma cut_greater_Max_empty: "finite I \<Longrightarrow> Max I \<le> t \<Longrightarrow> I \<down>> t = {}"
by (fastforce simp: i_cut_defs)

lemma cut_ge_Max_not_empty: "\<lbrakk> I \<noteq> {}; finite I; t \<le> Max I \<rbrakk> \<Longrightarrow> I \<down>\<ge> t \<noteq> {}"
apply (simp add: i_cut_defs)
apply (rule_tac x="Max I" in exI)
thm MaxI_ex2
apply (simp add: MaxI_ex2)
done

lemma cut_greater_Max_not_empty: "\<lbrakk> I \<noteq> {}; finite I; t < Max I \<rbrakk> \<Longrightarrow> I \<down>> t \<noteq> {}"
apply (simp add: i_cut_defs)
apply (rule_tac x="Max I" in exI)
apply (simp add: MaxI_ex2)
done

lemma cut_le_Max_all: "finite I \<Longrightarrow> Max I \<le> t \<Longrightarrow> I \<down>\<le> t = I"
by (fastforce simp: i_cut_defs)

lemma cut_less_Max_all: "finite I \<Longrightarrow> Max I < t \<Longrightarrow> I \<down>< t = I"
by (fastforce simp: i_cut_defs)

lemmas i_cut_max_empty =
  cut_ge_Max_empty
  cut_greater_Max_empty
  cut_ge_Max_not_empty
  cut_greater_Max_not_empty
lemmas i_cut_max_all =
  cut_le_Max_all
  cut_less_Max_all

thm
  i_cut_max_empty
  i_cut_max_all

lemma cut_less_Max_less: "
  \<lbrakk> finite (I \<down>< t); I \<down>< t \<noteq> {} \<rbrakk> \<Longrightarrow> Max (I \<down>< t) < t"
by (rule cut_less_bound[OF Max_in])
lemma cut_le_Max_le: "
  \<lbrakk> finite (I \<down>\<le> t); I \<down>\<le> t \<noteq> {} \<rbrakk> \<Longrightarrow> Max (I \<down>\<le> t) \<le> t"
by (rule cut_le_bound[OF Max_in])
lemma nat_cut_less_Max_less: "
  I \<down>< t \<noteq> {} \<Longrightarrow> Max (I \<down>< t) < (t::nat)"
by (rule cut_less_bound[OF Max_in[OF nat_cut_less_finite]])
lemma nat_cut_le_Max_le: "
  I \<down>\<le> t \<noteq> {} \<Longrightarrow> Max (I \<down>\<le> t) \<le> (t::nat)"
by (rule cut_le_bound[OF Max_in[OF nat_cut_le_finite]])
lemma cut_greater_Min_greater: "
  I \<down>> t \<noteq> {} \<Longrightarrow> iMin (I \<down>> t) > t"
by (rule cut_greater_bound[OF iMinI_ex2])
lemma cut_ge_Min_greater: "
  I \<down>\<ge> t \<noteq> {} \<Longrightarrow> iMin (I \<down>\<ge> t) \<ge> t"
by (rule cut_ge_bound[OF iMinI_ex2])

lemma cut_less_Min_eq: "I \<down>< t \<noteq> {} \<Longrightarrow> iMin (I \<down>< t) = iMin I"
apply (drule cut_less_not_empty_iff[THEN iffD1])
apply (rule iMin_equality)
 apply (fastforce intro: iMinI)
apply blast
done

lemma cut_le_Min_eq: "I \<down>\<le> t \<noteq> {} \<Longrightarrow> iMin (I \<down>\<le> t) = iMin I"
apply (drule cut_le_not_empty_iff[THEN iffD1])
apply (rule iMin_equality)
 apply (fastforce intro: iMinI)
apply blast
done

lemma cut_ge_Max_eq: "\<lbrakk> finite I; I \<down>\<ge> t \<noteq> {} \<rbrakk> \<Longrightarrow> Max (I \<down>\<ge> t) = Max I"
apply (drule cut_ge_not_empty_iff[THEN iffD1])
apply (rule Max_equality)
  apply (fastforce intro: MaxI)
 apply (simp add: cut_ge_finite)
apply fastforce
done

lemma cut_greater_Max_eq: "\<lbrakk> finite I; I \<down>> t \<noteq> {} \<rbrakk> \<Longrightarrow> Max (I \<down>> t) = Max I"
apply (drule cut_greater_not_empty_iff[THEN iffD1])
apply (rule Max_equality)
  apply (fastforce intro: MaxI)
 apply (simp add: cut_greater_finite)
apply fastforce
done

subsubsection {* Cut operators with intervals from SetInterval *}

lemma
  UNIV_cut_le:      "UNIV \<down>\<le> t = {..t}" and
  UNIV_cut_less:    "UNIV \<down>< t = {..<t}" and
  UNIV_cut_ge:      "UNIV \<down>\<ge> t = {t..}" and
  UNIV_cut_greater: "UNIV \<down>> t = {t<..}"
by blast+

lemma
  lessThan_cut_le:      "{..<n} \<down>\<le> t = (if n \<le> t then {..<n} else {..t})" and
  lessThan_cut_less:    "{..<n} \<down>< t = (if n \<le> t then {..<n} else {..<t})" and
  lessThan_cut_ge:      "{..<n} \<down>\<ge> t = {t..<n}" and
  lessThan_cut_greater: "{..<n} \<down>> t = {t<..<n}" and
  atMost_cut_le:      "{..n} \<down>\<le> t = (if n \<le> t then {..n} else {..t})" and
  atMost_cut_less:    "{..n} \<down>< t = (if n < t then {..n} else {..<t})" and
  atMost_cut_ge:      "{..n} \<down>\<ge> t = {t..n}" and
  atMost_cut_greager: "{..n} \<down>> t = {t<..n}" and
  greaterThan_cut_le:      "{n<..} \<down>\<le> t = {n<..t}" and
  greaterThan_cut_less:    "{n<..} \<down>< t = {n<..<t}" and
  greaterThan_cut_ge:      "{n<..} \<down>\<ge> t = (if t \<le> n then {n<..} else {t..})" and
  greaterThan_cut_greater: "{n<..} \<down>> t = (if t \<le> n then {n<..} else {t<..})" and
  atLeast_cut_le:      "{n..} \<down>\<le> t = {n..t}" and
  atLeast_cut_less:    "{n..} \<down>< t = {n..<t}" and
  atLeast_cut_ge:      "{n..} \<down>\<ge> t = (if t \<le> n then {n..} else {t..})" and
  atLeast_cut_greater: "{n..} \<down>\<ge> t = (if t \<le> n then {n..} else {t..})"
apply (simp_all add: set_eq_iff i_cut_mem_iff linorder_not_le linorder_not_less)
apply fastforce+
done

lemma
  greaterThanLessThan_cut_le:      "{m<..<n} \<down>\<le> t = (if n \<le> t then {m<..<n} else {m<..t})" and
  greaterThanLessThan_cut_less:    "{m<..<n} \<down>< t = (if n \<le> t then {m<..<n} else {m<..<t})" and
  greaterThanLessThan_cut_ge:      "{m<..<n} \<down>\<ge> t = (if t \<le> m then {m<..<n} else {t..<n})" and
  greaterThanLessThan_cut_greater: "{m<..<n} \<down>> t = (if t \<le> m then {m<..<n} else {t<..<n})" and
  atLeastLessThan_cut_le:      "{m..<n} \<down>\<le> t = (if n \<le> t then {m..<n} else {m..t})" and
  atLeastLessThan_cut_less:    "{m..<n} \<down>< t = (if n \<le> t then {m..<n} else {m..<t})" and
  atLeastLessThan_cut_ge:      "{m..<n} \<down>\<ge> t = (if t \<le> m then {m..<n} else {t..<n})" and
  atLeastLessThan_cut_greater: "{m..<n} \<down>> t = (if t < m then {m..<n} else {t<..<n})" and
  greaterThanAtMost_cut_le:      "{m<..n} \<down>\<le> t = (if n \<le> t then {m<..n} else {m<..t})" and
  greaterThanAtMost_cut_less:    "{m<..n} \<down>< t = (if n < t then {m<..n} else {m<..<t})" and
  greaterThanAtMost_cut_ge:      "{m<..n} \<down>\<ge> t = (if t \<le> m then {m<..n} else {t..n})" and
  greaterThanAtMost_cut_greater: "{m<..n} \<down>> t = (if t \<le> m then {m<..n} else {t<..n})" and
  atLeastAtMost_cut_le:      "{m..n} \<down>\<le> t = (if n \<le> t then {m..n} else {m..t})" and
  atLeastAtMost_cut_less:    "{m..n} \<down>< t = (if n < t then {m..n} else {m..<t})" and
  atLeastAtMost_cut_ge:      "{m..n} \<down>\<ge> t = (if t \<le> m then {m..n} else {t..n})" and
  atLeastAtMost_cut_greater: "{m..n} \<down>> t = (if t < m then {m..n} else {t<..n})"
apply (simp_all add: set_eq_iff i_cut_mem_iff split_if linorder_not_le linorder_not_less)
apply fastforce+
done

subsubsection {* Mirroring finite natural sets between their @{term Min} and @{term Max} element *}

text {* Mirroring a number at the middle of the interval {min l r..max l r} *}
text_raw {* \bigskip *}

text {* Mirroring a single element n between the interval boundaries l and r *}
definition
  nat_mirror :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
where
  "nat_mirror n l r \<equiv> l + r - n"

lemma nat_mirror_commute: "nat_mirror n l r = nat_mirror n r l"
unfolding nat_mirror_def by simp

lemma nat_mirror_inj_on: "inj_on (\<lambda>x. nat_mirror x l r) {..l + r}"
unfolding inj_on_def nat_mirror_def by fastforce

lemma nat_mirror_nat_mirror_ident: "
  n \<le> l + r \<Longrightarrow> nat_mirror (nat_mirror n l r) l r = n"
unfolding nat_mirror_def by simp

lemma nat_mirror_add: "
  nat_mirror (n + k) l r = (nat_mirror n l r) - k"
unfolding nat_mirror_def by simp
lemma nat_mirror_diff: "
  \<lbrakk> k \<le> n; n \<le> l + r \<rbrakk> \<Longrightarrow>
  nat_mirror (n - k) l r = (nat_mirror n l r) + k"
unfolding nat_mirror_def by simp

lemma nat_mirror_le: "a \<le> b \<Longrightarrow> nat_mirror b l r \<le> nat_mirror a l r"
unfolding nat_mirror_def by simp
lemma nat_mirror_le_conv: "
  a \<le> l + r \<Longrightarrow> (nat_mirror b l r \<le> nat_mirror a l r) = (a \<le> b)"
unfolding nat_mirror_def by fastforce

lemma nat_mirror_less: "
  \<lbrakk> a < b; a < l + r \<rbrakk> \<Longrightarrow>
  nat_mirror b l r < nat_mirror a l r"
unfolding nat_mirror_def by simp
lemma nat_mirror_less_imp_less: "
  nat_mirror b l r < nat_mirror a l r \<Longrightarrow> a < b"
unfolding nat_mirror_def by simp
lemma nat_mirror_less_conv: "
  a < l + r \<Longrightarrow> (nat_mirror b l r < nat_mirror a l r) = (a < b)"
unfolding nat_mirror_def by fastforce

lemma nat_mirror_eq_conv: "
  \<lbrakk> a \<le> l + r; b \<le> l + r \<rbrakk> \<Longrightarrow>
  (nat_mirror a l r = nat_mirror b l r) = (a = b)"
unfolding nat_mirror_def by fastforce

text {* Mirroring a single element n between the interval boundaries of I *}
definition
  mirror_elem :: "nat \<Rightarrow> nat set \<Rightarrow> nat"
where
  "mirror_elem n I \<equiv> nat_mirror n (iMin I) (Max I)"

lemma mirror_elem_inj_on: "finite I \<Longrightarrow> inj_on (\<lambda>x. mirror_elem x I) I"
unfolding mirror_elem_def
by (metis Max_le_imp_subset_atMost nat_mirror_inj_on not_add_less2 not_leE subset_inj_on)

lemma mirror_elem_add: "
  finite I \<Longrightarrow> mirror_elem (n + k) I = mirror_elem n I - k"
unfolding mirror_elem_def by (rule nat_mirror_add)
lemma mirror_elem_diff: "
  \<lbrakk> finite I; k \<le> n; n \<in> I \<rbrakk> \<Longrightarrow> mirror_elem (n - k) I = mirror_elem n I + k"
apply (unfold mirror_elem_def)
apply (rule nat_mirror_diff, assumption)
apply (simp add: trans_le_add2)
done
lemma mirror_elem_Min: "
  \<lbrakk> finite I; I \<noteq> {} \<rbrakk> \<Longrightarrow> mirror_elem (iMin I) I = Max I"
unfolding mirror_elem_def nat_mirror_def by simp
lemma mirror_elem_Max: "
  \<lbrakk> finite I; I \<noteq> {} \<rbrakk> \<Longrightarrow> mirror_elem (Max I) I = iMin I"
unfolding mirror_elem_def nat_mirror_def by simp

lemma mirror_elem_mirror_elem_ident: "
  \<lbrakk> finite I; n \<le> iMin I + Max I \<rbrakk> \<Longrightarrow> mirror_elem (mirror_elem n I) I = n"
unfolding mirror_elem_def nat_mirror_def by simp

thm nat_mirror_le_conv
lemma mirror_elem_le_conv: "
  \<lbrakk> finite I; a \<in> I; b \<in> I \<rbrakk> \<Longrightarrow>
  (mirror_elem b I \<le> mirror_elem a I) = (a \<le> b)"
apply (unfold mirror_elem_def)
apply (rule nat_mirror_le_conv)
apply (simp add: trans_le_add2)
done
lemma mirror_elem_less_conv: "
  \<lbrakk> finite I; a \<in> I; b \<in> I \<rbrakk> \<Longrightarrow>
  (mirror_elem b I < mirror_elem a I) = (a < b)"
unfolding mirror_elem_def nat_mirror_def
by (metis diff_less_mono2 nat_diff_left_cancel_less nat_ex_greater_infinite_finite_Max_conv' trans_less_add2)

thm nat_mirror_eq_conv
lemma mirror_elem_eq_conv: "
  \<lbrakk> a \<le> iMin I + Max I; b \<le> iMin I + Max I \<rbrakk> \<Longrightarrow>
  (mirror_elem a I = mirror_elem b I) = (a = b)"
by (simp add: mirror_elem_def nat_mirror_eq_conv)
lemma mirror_elem_eq_conv': "
  \<lbrakk> finite I; a \<in> I; b \<in> I \<rbrakk> \<Longrightarrow> (mirror_elem a I = mirror_elem b I) = (a = b)"
apply (rule mirror_elem_eq_conv)
apply (simp_all add: trans_le_add2)
done

definition
  imirror_bounds :: "nat set \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat set"
where
  "imirror_bounds I l r \<equiv> (\<lambda>x. nat_mirror x l r) ` I"

text {* Mirroring all elements between the interval boundaries of I *}
definition
  imirror :: "nat set \<Rightarrow> nat set"
where
  "imirror I \<equiv> (\<lambda>x. iMin I + Max I - x) ` I"

lemma imirror_eq_nat_mirror_image: "
  imirror I = (\<lambda>x. nat_mirror x (iMin I) (Max I)) ` I"
unfolding imirror_def nat_mirror_def by simp
lemma imirror_eq_mirror_elem_image: "
  imirror I = (\<lambda>x. mirror_elem x I) ` I"
by (simp add: mirror_elem_def imirror_eq_nat_mirror_image)

lemma imirror_eq_imirror_bounds: "
  imirror I = imirror_bounds I (iMin I) (Max I)"
unfolding imirror_def imirror_bounds_def nat_mirror_def by simp

lemma imirror_empty: "imirror {} = {}"
unfolding imirror_def by simp
lemma imirror_is_empty: "(imirror I = {}) = (I = {})"
unfolding imirror_def by simp
lemma imirror_not_empty: "I \<noteq> {} \<Longrightarrow> imirror I \<noteq> {}"
unfolding imirror_def by simp

lemma imirror_singleton: "imirror {a} = {a}"
unfolding imirror_def by simp

lemma imirror_finite: "finite I \<Longrightarrow> finite (imirror I)"
unfolding imirror_def by simp

lemma imirror_bounds_iMin: "
  \<lbrakk> finite I; I \<noteq> {}; iMin I \<le> l + r \<rbrakk> \<Longrightarrow>
  iMin (imirror_bounds I l r) = l + r - Max I"
apply (unfold imirror_bounds_def nat_mirror_def)
thm iMin_equality
apply (rule iMin_equality)
 apply (blast intro: Max_in)
apply (blast intro: Max_ge diff_le_mono2)
done

lemma imirror_bounds_Max: "
  \<lbrakk> finite I; I \<noteq> {}; Max I \<le> l + r \<rbrakk> \<Longrightarrow>
  Max (imirror_bounds I l r) = l + r - iMin I"
apply (unfold imirror_bounds_def nat_mirror_def)
apply (rule Max_equality)
  apply (blast intro: iMinI)
 apply simp
apply (blast intro: iMin_le diff_le_mono2)
done

lemma imirror_iMin: "finite I \<Longrightarrow> iMin (imirror I) = iMin I"
apply (case_tac "I = {}", simp add: imirror_empty)
apply (simp add: imirror_eq_imirror_bounds imirror_bounds_iMin le_add1)
done

lemma imirror_Max: "finite I \<Longrightarrow> Max (imirror I) = Max I"
apply (case_tac "I = {}", simp add: imirror_empty)
apply (simp add: imirror_eq_imirror_bounds imirror_bounds_Max trans_le_add2)
done
corollary imirror_iMin_Max: "\<lbrakk> finite I; n \<in> imirror I \<rbrakk> \<Longrightarrow> iMin I \<le> n \<and> n \<le> Max I"
apply (frule Max_ge[OF imirror_finite, of _ n], assumption)
thm imirror_iMin imirror_Max
apply (fastforce simp: imirror_iMin imirror_Max)
done

thm image_iff
lemma imirror_bounds_iff:
  "(n \<in> imirror_bounds I l r) = (\<exists>x\<in>I. n = l + r - x)"
by (simp add: imirror_bounds_def nat_mirror_def image_iff)
lemma imirror_iff: "(n \<in> imirror I) = (\<exists>x\<in>I. n = iMin I + Max I - x)"
by (simp add: imirror_def image_iff)

lemma imirror_bounds_imirror_bounds_ident: "
  \<lbrakk> finite I; Max I \<le> l + r \<rbrakk> \<Longrightarrow>
  imirror_bounds (imirror_bounds I l r) l r = I"
apply (rule set_eqI)
apply (simp add: imirror_bounds_def image_image image_iff)
thm nat_mirror_nat_mirror_ident
apply (rule iffI)
 apply (fastforce simp: nat_mirror_nat_mirror_ident)
apply (rule_tac x=x in bexI)
apply (fastforce simp: nat_mirror_nat_mirror_ident)+
done

lemma imirror_imirror_ident: "finite I \<Longrightarrow> imirror (imirror I) = I"
apply (case_tac "I = {}", simp add: imirror_empty)
thm imirror_eq_imirror_bounds
thm imirror_bounds_imirror_bounds_ident
apply (simp add: imirror_eq_imirror_bounds imirror_bounds_iMin imirror_bounds_Max
  le_add1 trans_le_add2 imirror_bounds_imirror_bounds_ident)
done
lemma mirror_elem_imirror: "
  finite I \<Longrightarrow> mirror_elem t (imirror I) = mirror_elem t I"
by (simp add: mirror_elem_def imirror_iMin imirror_Max)

lemma imirror_card: "finite I \<Longrightarrow> card (imirror I) = card I"
apply (simp only: imirror_eq_mirror_elem_image)
apply (rule inj_on_iff_eq_card[THEN iffD1], assumption)
apply (rule mirror_elem_inj_on, assumption)
done

lemma imirror_bounds_elem_conv: "
  \<lbrakk> finite I; n \<le> l + r; Max I \<le> l + r \<rbrakk> \<Longrightarrow>
  ((nat_mirror n l r) \<in> imirror_bounds I l r) = (n \<in> I)"
apply (unfold imirror_bounds_def)
thm inj_on_image_mem_iff[where A="{..l + r}"]
apply (rule inj_on_image_mem_iff)
apply (rule nat_mirror_inj_on)
apply fastforce
apply simp
done

lemma imirror_mem_conv: "
  \<lbrakk> finite I; n \<le> iMin I + Max I \<rbrakk> \<Longrightarrow> ((mirror_elem n I) \<in> imirror I) = (n \<in> I)"
thm imirror_bounds_elem_conv
by (simp add: mirror_elem_def imirror_eq_imirror_bounds imirror_bounds_elem_conv)

corollary in_imp_mirror_elem_in: "
  \<lbrakk> finite I; n \<in> I \<rbrakk> \<Longrightarrow> (mirror_elem n I) \<in> imirror I"
thm imirror_mem_conv[OF _ trans_le_add2[OF Max_ge], THEN iffD2]
by (rule imirror_mem_conv[OF _ trans_le_add2[OF Max_ge], THEN iffD2])

lemma imirror_cut_less: "
  finite I \<Longrightarrow>
  imirror I \<down>< (mirror_elem t I) =
  imirror_bounds (I \<down>> t) (iMin I) (Max I)"
apply (simp only: imirror_eq_imirror_bounds)
apply (unfold imirror_def imirror_bounds_def mirror_elem_def)
apply (rule set_eqI)
apply (simp add: Bex_def i_cut_mem_iff image_iff)
apply (rule iffI)
 thm nat_mirror_less_imp_less
 apply (bestsimp intro: nat_mirror_less_imp_less)
thm nat_mirror_less
apply (bestsimp simp add: nat_mirror_less)
done

lemma imirror_cut_le: "
  \<lbrakk> finite I; t \<le> iMin I + Max I \<rbrakk> \<Longrightarrow>
  imirror I \<down>\<le> (mirror_elem t I) =
  imirror_bounds (I \<down>\<ge> t) (iMin I) (Max I)"
thm nat_cut_le_less_conv nat_cut_greater_ge_conv
apply (simp only: nat_cut_le_less_conv)
apply (case_tac "t = 0")
 apply (simp add: cut_ge_0_all i_cut_empty)
 apply (simp only: imirror_eq_imirror_bounds[symmetric])
 apply (rule cut_less_Max_all)
  apply (rule imirror_finite, assumption)
 apply (simp add: mirror_elem_def nat_mirror_def imirror_Max)
apply (simp add: nat_cut_greater_ge_conv[symmetric])
thm imirror_cut_less
apply (rule subst[of "mirror_elem (t - Suc 0) I" "Suc (mirror_elem t I)"])
 apply (simp add: mirror_elem_def nat_mirror_diff)
apply (rule imirror_cut_less, assumption)
done

lemma imirror_cut_ge: "
  finite I \<Longrightarrow>
  imirror I \<down>\<ge> (mirror_elem t I) =
  imirror_bounds (I \<down>\<le> t) (iMin I) (Max I)"
  (is "?P \<Longrightarrow> ?lhs I = ?rhs I t")
apply (case_tac "iMin I + Max I < t")
 apply (simp add: mirror_elem_def nat_mirror_def cut_ge_0_all cut_le_Max_all imirror_eq_imirror_bounds)
apply (case_tac "t < iMin I")
 apply (simp add: cut_le_Min_empty imirror_bounds_def mirror_elem_def nat_mirror_def cut_ge_Max_empty imirror_Max imirror_finite)
apply (simp add: linorder_not_le linorder_not_less)
apply (rule subst[of "imirror (imirror I) \<down>\<le> mirror_elem (mirror_elem t I) (imirror I)" "I \<down>\<le> t"])
 thm mirror_elem_mirror_elem_ident
 apply (simp add: imirror_imirror_ident mirror_elem_imirror mirror_elem_mirror_elem_ident)
thm imirror_cut_le[of "imirror I" "mirror_elem t I", OF imirror_finite]
apply (subgoal_tac "mirror_elem t I \<le> Max (imirror I)")
 prefer 2
 apply (simp add: imirror_Max mirror_elem_def nat_mirror_def)
apply (simp add: imirror_cut_le imirror_finite)
by (metis cut_ge_Max_eq cut_ge_Max_not_empty imirror_Max imirror_bounds_imirror_bounds_ident imirror_finite imirror_iMin le_add2 nat_cut_ge_finite_iff)

lemma imirror_cut_greater: "\<lbrakk> finite I; t \<le> iMin I + Max I \<rbrakk> \<Longrightarrow>
  imirror I \<down>> (mirror_elem t I) =
  imirror_bounds (I \<down>< t) (iMin I) (Max I)"
apply (case_tac "t = 0")
 apply (simp add: cut_less_0_empty imirror_bounds_def)
 apply (rule cut_greater_Max_empty)
   apply (rule imirror_finite, assumption)
 apply (simp add: imirror_Max mirror_elem_def nat_mirror_def)
thm nat_cut_ge_greater_conv
apply (simp add: nat_cut_ge_greater_conv[symmetric])
thm subst[of "mirror_elem (t - Suc 0) I" "Suc (mirror_elem t I)"]
apply (rule subst[of "mirror_elem (t - Suc 0) I" "Suc (mirror_elem t I)"])
 thm nat_mirror_diff
 apply (simp add: mirror_elem_def nat_mirror_diff)
thm imirror_cut_ge nat_cut_less_le_conv
apply (simp add: imirror_cut_ge nat_cut_less_le_conv)
done

lemmas imirror_cut =
  imirror_cut_less imirror_cut_ge
  imirror_cut_le imirror_cut_greater
thm imirror_cut

corollary imirror_cut_le': "
  \<lbrakk> finite I; t \<in> I \<rbrakk> \<Longrightarrow>
  imirror I \<down>\<le> mirror_elem t I =
  imirror_bounds (I \<down>\<ge> t) (iMin I) (Max I)"
thm imirror_cut_le[OF _ trans_le_add2[OF Max_ge]]
by (rule imirror_cut_le[OF _ trans_le_add2[OF Max_ge]])
corollary imirror_cut_greater': "
  \<lbrakk> finite I; t \<in> I \<rbrakk> \<Longrightarrow>
  imirror I \<down>> mirror_elem t I =
  imirror_bounds (I \<down>< t) (iMin I) (Max I)"
by (rule imirror_cut_greater[OF _ trans_le_add2[OF Max_ge]])
lemmas imirror_cut' =
  imirror_cut_le' imirror_cut_greater'
thm
  imirror_cut
  imirror_cut'

lemma imirror_bounds_Un: "
  imirror_bounds (A \<union> B) l r =
  imirror_bounds A l r \<union> imirror_bounds B l r"
by (simp add: imirror_bounds_def image_Un)
lemma imirror_bounds_Int: "
  \<lbrakk> A \<subseteq> {..l + r}; B \<subseteq> {..l + r} \<rbrakk> \<Longrightarrow>
  imirror_bounds (A \<inter> B) l r =
  imirror_bounds A l r \<inter> imirror_bounds B l r"
apply (unfold imirror_bounds_def)
thm inj_on_image_Int[OF _ Un_upper1 Un_upper2]
apply (rule inj_on_image_Int[OF _ Un_upper1 Un_upper2])
thm nat_mirror_inj_on
thm subset_inj_on[OF nat_mirror_inj_on]
apply (rule subset_inj_on[OF nat_mirror_inj_on])
apply (rule Un_least[of A _ B], assumption+)
done

end