(*  Title:      HOL/Probability/Regularity.thy
    Author:     Fabian Immler, TU München
*)

section {* Regularity of Measures *}

theory Regularity
imports Measure_Space Borel_Space
begin

lemma ereal_approx_SUP:
  fixes x::ereal
  assumes A_notempty: "A \<noteq> {}"
  assumes f_bound: "\<And>i. i \<in> A \<Longrightarrow> f i \<le> x"
  assumes f_fin: "\<And>i. i \<in> A \<Longrightarrow> f i \<noteq> \<infinity>"
  assumes f_nonneg: "\<And>i. 0 \<le> f i"
  assumes approx: "\<And>e. (e::real) > 0 \<Longrightarrow> \<exists>i \<in> A. x \<le> f i + e"
  shows "x = (SUP i : A. f i)"
proof (subst eq_commute, rule SUP_eqI)
  show "\<And>i. i \<in> A \<Longrightarrow> f i \<le> x" using f_bound by simp
next
  fix y :: ereal assume f_le_y: "(\<And>i::'a. i \<in> A \<Longrightarrow> f i \<le> y)"
  with A_notempty f_nonneg have "y \<ge> 0" by auto (metis order_trans)
  show "x \<le> y"
  proof (rule ccontr)
    assume "\<not> x \<le> y" hence "x > y" by simp
    hence y_fin: "\<bar>y\<bar> \<noteq> \<infinity>" using `y \<ge> 0` by auto
    have x_fin: "\<bar>x\<bar> \<noteq> \<infinity>" using `x > y` f_fin approx[where e = 1] by auto
    def e \<equiv> "real ((x - y) / 2)"
    have e: "x > y + e" "e > 0" using `x > y` y_fin x_fin by (auto simp: e_def field_simps)
    note e(1)
    also from approx[OF `e > 0`] obtain i where i: "i \<in> A" "x \<le> f i + e" by blast
    note i(2)
    finally have "y < f i" using y_fin f_fin by (metis add_right_mono linorder_not_le)
    moreover have "f i \<le> y" by (rule f_le_y) fact
    ultimately show False by simp
  qed
qed

lemma ereal_approx_INF:
  fixes x::ereal
  assumes A_notempty: "A \<noteq> {}"
  assumes f_bound: "\<And>i. i \<in> A \<Longrightarrow> x \<le> f i"
  assumes f_fin: "\<And>i. i \<in> A \<Longrightarrow> f i \<noteq> \<infinity>"
  assumes f_nonneg: "\<And>i. 0 \<le> f i"
  assumes approx: "\<And>e. (e::real) > 0 \<Longrightarrow> \<exists>i \<in> A. f i \<le> x + e"
  shows "x = (INF i : A. f i)"
proof (subst eq_commute, rule INF_eqI)
  show "\<And>i. i \<in> A \<Longrightarrow> x \<le> f i" using f_bound by simp
next
  fix y :: ereal assume f_le_y: "(\<And>i::'a. i \<in> A \<Longrightarrow> y \<le> f i)"
  with A_notempty f_fin have "y \<noteq> \<infinity>" by force
  show "y \<le> x"
  proof (rule ccontr)
    assume "\<not> y \<le> x" hence "y > x" by simp hence "y \<noteq> - \<infinity>" by auto
    hence y_fin: "\<bar>y\<bar> \<noteq> \<infinity>" using `y \<noteq> \<infinity>` by auto
    have x_fin: "\<bar>x\<bar> \<noteq> \<infinity>" using `y > x` f_fin f_nonneg approx[where e = 1] A_notempty
      apply auto by (metis ereal_infty_less_eq(2) f_le_y)
    def e \<equiv> "real ((y - x) / 2)"
    have e: "y > x + e" "e > 0" using `y > x` y_fin x_fin by (auto simp: e_def field_simps)
    from approx[OF `e > 0`] obtain i where i: "i \<in> A" "x + e \<ge> f i" by blast
    note i(2)
    also note e(1)
    finally have "y > f i" .
    moreover have "y \<le> f i" by (rule f_le_y) fact
    ultimately show False by simp
  qed
qed

lemma INF_approx_ereal:
  fixes x::ereal and e::real
  assumes "e > 0"
  assumes INF: "x = (INF i : A. f i)"
  assumes "\<bar>x\<bar> \<noteq> \<infinity>"
  shows "\<exists>i \<in> A. f i < x + e"
proof (rule ccontr, clarsimp)
  assume "\<forall>i\<in>A. \<not> f i < x + e"
  moreover
  from INF have "\<And>y. (\<And>i. i \<in> A \<Longrightarrow> y \<le> f i) \<Longrightarrow> y \<le> x" by (auto intro: INF_greatest)
  ultimately
  have "(INF i : A. f i) = x + e" using `e > 0`
    by (intro INF_eqI)
      (force, metis add.comm_neutral add_left_mono ereal_less(1)
        linorder_not_le not_less_iff_gr_or_eq)
  thus False using assms by auto
qed

lemma SUP_approx_ereal:
  fixes x::ereal and e::real
  assumes "e > 0"
  assumes SUP: "x = (SUP i : A. f i)"
  assumes "\<bar>x\<bar> \<noteq> \<infinity>"
  shows "\<exists>i \<in> A. x \<le> f i + e"
proof (rule ccontr, clarsimp)
  assume "\<forall>i\<in>A. \<not> x \<le> f i + e"
  moreover
  from SUP have "\<And>y. (\<And>i. i \<in> A \<Longrightarrow> f i \<le> y) \<Longrightarrow> y \<ge> x" by (auto intro: SUP_least)
  ultimately
  have "(SUP i : A. f i) = x - e" using `e > 0` `\<bar>x\<bar> \<noteq> \<infinity>`
    by (intro SUP_eqI)
       (metis PInfty_neq_ereal(2) abs_ereal.simps(1) ereal_minus_le linorder_linear,
        metis ereal_between(1) ereal_less(2) less_eq_ereal_def order_trans)
  thus False using assms by auto
qed

lemma
  fixes M::"'a::{second_countable_topology, complete_space} measure"
  assumes sb: "sets M = sets borel"
  assumes "emeasure M (space M) \<noteq> \<infinity>"
  assumes "B \<in> sets borel"
  shows inner_regular: "emeasure M B =
    (SUP K : {K. K \<subseteq> B \<and> compact K}. emeasure M K)" (is "?inner B")
  and outer_regular: "emeasure M B =
    (INF U : {U. B \<subseteq> U \<and> open U}. emeasure M U)" (is "?outer B")
proof -
  have Us: "UNIV = space M" by (metis assms(1) sets_eq_imp_space_eq space_borel)
  hence sU: "space M = UNIV" by simp
  interpret finite_measure M by rule fact
  have approx_inner: "\<And>A. A \<in> sets M \<Longrightarrow>
    (\<And>e. e > 0 \<Longrightarrow> \<exists>K. K \<subseteq> A \<and> compact K \<and> emeasure M A \<le> emeasure M K + ereal e) \<Longrightarrow> ?inner A"
    by (rule ereal_approx_SUP)
      (force intro!: emeasure_mono simp: compact_imp_closed emeasure_eq_measure)+
  have approx_outer: "\<And>A. A \<in> sets M \<Longrightarrow>
    (\<And>e. e > 0 \<Longrightarrow> \<exists>B. A \<subseteq> B \<and> open B \<and> emeasure M B \<le> emeasure M A + ereal e) \<Longrightarrow> ?outer A"
    by (rule ereal_approx_INF)
       (force intro!: emeasure_mono simp: emeasure_eq_measure sb)+
  from countable_dense_setE guess X::"'a set"  . note X = this
  {
    fix r::real assume "r > 0" hence "\<And>y. open (ball y r)" "\<And>y. ball y r \<noteq> {}" by auto
    with X(2)[OF this]
    have x: "space M = (\<Union>x\<in>X. cball x r)"
      by (auto simp add: sU) (metis dist_commute order_less_imp_le)
    let ?U = "\<Union>k. (\<Union>n\<in>{0..k}. cball (from_nat_into X n) r)"
    have "(\<lambda>k. emeasure M (\<Union>n\<in>{0..k}. cball (from_nat_into X n) r)) ----> M ?U"
      by (rule Lim_emeasure_incseq)
        (auto intro!: borel_closed bexI simp: closed_cball incseq_def Us sb)
    also have "?U = space M"
    proof safe
      fix x from X(2)[OF open_ball[of x r]] `r > 0` obtain d where d: "d\<in>X" "d \<in> ball x r" by auto
      show "x \<in> ?U"
        using X(1) d by (auto intro!: exI[where x="to_nat_on X d"] simp: dist_commute Bex_def)
    qed (simp add: sU)
    finally have "(\<lambda>k. M (\<Union>n\<in>{0..k}. cball (from_nat_into X n) r)) ----> M (space M)" .
  } note M_space = this
  {
    fix e ::real and n :: nat assume "e > 0" "n > 0"
    hence "1/n > 0" "e * 2 powr - n > 0" by (auto)
    from M_space[OF `1/n>0`]
    have "(\<lambda>k. measure M (\<Union>i\<in>{0..k}. cball (from_nat_into X i) (1/real n))) ----> measure M (space M)"
      unfolding emeasure_eq_measure by simp
    from metric_LIMSEQ_D[OF this `0 < e * 2 powr -n`]
    obtain k where "dist (measure M (\<Union>i\<in>{0..k}. cball (from_nat_into X i) (1/real n))) (measure M (space M)) <
      e * 2 powr -n"
      by auto
    hence "measure M (\<Union>i\<in>{0..k}. cball (from_nat_into X i) (1/real n)) \<ge>
      measure M (space M) - e * 2 powr -real n"
      by (auto simp: dist_real_def)
    hence "\<exists>k. measure M (\<Union>i\<in>{0..k}. cball (from_nat_into X i) (1/real n)) \<ge>
      measure M (space M) - e * 2 powr - real n" ..
  } note k=this
  hence "\<forall>e\<in>{0<..}. \<forall>(n::nat)\<in>{0<..}. \<exists>k.
    measure M (\<Union>i\<in>{0..k}. cball (from_nat_into X i) (1/real n)) \<ge> measure M (space M) - e * 2 powr - real n"
    by blast
  then obtain k where k: "\<forall>e\<in>{0<..}. \<forall>n\<in>{0<..}. measure M (space M) - e * 2 powr - real (n::nat)
    \<le> measure M (\<Union>i\<in>{0..k e n}. cball (from_nat_into X i) (1 / n))"
    by metis
  hence k: "\<And>e n. e > 0 \<Longrightarrow> n > 0 \<Longrightarrow> measure M (space M) - e * 2 powr - n
    \<le> measure M (\<Union>i\<in>{0..k e n}. cball (from_nat_into X i) (1 / n))"
    unfolding Ball_def by blast
  have approx_space:
    "\<And>e. e > 0 \<Longrightarrow>
      \<exists>K \<in> {K. K \<subseteq> space M \<and> compact K}. emeasure M (space M) \<le> emeasure M K + ereal e"
      (is "\<And>e. _ \<Longrightarrow> ?thesis e")
  proof -
    fix e :: real assume "e > 0"
    def B \<equiv> "\<lambda>n. \<Union>i\<in>{0..k e (Suc n)}. cball (from_nat_into X i) (1 / Suc n)"
    have "\<And>n. closed (B n)" by (auto simp: B_def closed_cball)
    hence [simp]: "\<And>n. B n \<in> sets M" by (simp add: sb)
    from k[OF `e > 0` zero_less_Suc]
    have "\<And>n. measure M (space M) - measure M (B n) \<le> e * 2 powr - real (Suc n)"
      by (simp add: algebra_simps B_def finite_measure_compl)
    hence B_compl_le: "\<And>n::nat. measure M (space M - B n) \<le> e * 2 powr - real (Suc n)"
      by (simp add: finite_measure_compl)
    def K \<equiv> "\<Inter>n. B n"
    from `closed (B _)` have "closed K" by (auto simp: K_def)
    hence [simp]: "K \<in> sets M" by (simp add: sb)
    have "measure M (space M) - measure M K = measure M (space M - K)"
      by (simp add: finite_measure_compl)
    also have "\<dots> = emeasure M (\<Union>n. space M - B n)" by (auto simp: K_def emeasure_eq_measure)
    also have "\<dots> \<le> (\<Sum>n. emeasure M (space M - B n))"
      by (rule emeasure_subadditive_countably) (auto simp: summable_def)
    also have "\<dots> \<le> (\<Sum>n. ereal (e*2 powr - real (Suc n)))"
      using B_compl_le by (intro suminf_le_pos) (simp_all add: measure_nonneg emeasure_eq_measure)
    also have "\<dots> \<le> (\<Sum>n. ereal (e * (1 / 2) ^ Suc n))"
      by (simp add: powr_minus inverse_eq_divide powr_realpow field_simps power_divide)
    also have "\<dots> = (\<Sum>n. ereal e * ((1 / 2) ^ Suc n))"
      unfolding times_ereal.simps[symmetric] ereal_power[symmetric] one_ereal_def numeral_eq_ereal
      by simp
    also have "\<dots> = ereal e * (\<Sum>n. ((1 / 2) ^ Suc n))"
      by (rule suminf_cmult_ereal) (auto simp: `0 < e` less_imp_le)
    also have "\<dots> = e" unfolding suminf_half_series_ereal by simp
    finally have "measure M (space M) \<le> measure M K + e" by simp
    hence "emeasure M (space M) \<le> emeasure M K + e" by (simp add: emeasure_eq_measure)
    moreover have "compact K"
      unfolding compact_eq_totally_bounded
    proof safe
      show "complete K" using `closed K` by (simp add: complete_eq_closed)
      fix e'::real assume "0 < e'"
      from nat_approx_posE[OF this] guess n . note n = this
      let ?k = "from_nat_into X ` {0..k e (Suc n)}"
      have "finite ?k" by simp
      moreover have "K \<subseteq> (\<Union>x\<in>?k. ball x e')" unfolding K_def B_def using n by force
      ultimately show "\<exists>k. finite k \<and> K \<subseteq> (\<Union>x\<in>k. ball x e')" by blast
    qed
    ultimately
    show "?thesis e " by (auto simp: sU)
  qed
  { fix A::"'a set" assume "closed A" hence "A \<in> sets borel" by (simp add: compact_imp_closed)
    hence [simp]: "A \<in> sets M" by (simp add: sb)
    have "?inner A"
    proof (rule approx_inner)
      fix e::real assume "e > 0"
      from approx_space[OF this] obtain K where
        K: "K \<subseteq> space M" "compact K" "emeasure M (space M) \<le> emeasure M K + e"
        by (auto simp: emeasure_eq_measure)
      hence [simp]: "K \<in> sets M" by (simp add: sb compact_imp_closed)
      have "M A - M (A \<inter> K) = measure M A - measure M (A \<inter> K)"
        by (simp add: emeasure_eq_measure)
      also have "\<dots> = measure M (A - A \<inter> K)"
        by (subst finite_measure_Diff) auto
      also have "A - A \<inter> K = A \<union> K - K" by auto
      also have "measure M \<dots> = measure M (A \<union> K) - measure M K"
        by (subst finite_measure_Diff) auto
      also have "\<dots> \<le> measure M (space M) - measure M K"
        by (simp add: emeasure_eq_measure sU sb finite_measure_mono)
      also have "\<dots> \<le> e" using K by (simp add: emeasure_eq_measure)
      finally have "emeasure M A \<le> emeasure M (A \<inter> K) + ereal e"
        by (simp add: emeasure_eq_measure algebra_simps)
      moreover have "A \<inter> K \<subseteq> A" "compact (A \<inter> K)" using `closed A` `compact K` by auto
      ultimately show "\<exists>K \<subseteq> A. compact K \<and> emeasure M A \<le> emeasure M K + ereal e"
        by blast
    qed simp
    have "?outer A"
    proof cases
      assume "A \<noteq> {}"
      let ?G = "\<lambda>d. {x. infdist x A < d}"
      {
        fix d
        have "?G d = (\<lambda>x. infdist x A) -` {..<d}" by auto
        also have "open \<dots>"
          by (intro continuous_open_vimage) (auto intro!: continuous_infdist continuous_at_id)
        finally have "open (?G d)" .
      } note open_G = this
      from in_closed_iff_infdist_zero[OF `closed A` `A \<noteq> {}`]
      have "A = {x. infdist x A = 0}" by auto
      also have "\<dots> = (\<Inter>i. ?G (1/real (Suc i)))"
      proof (auto, rule ccontr)
        fix x
        assume "infdist x A \<noteq> 0"
        hence pos: "infdist x A > 0" using infdist_nonneg[of x A] by simp
        from nat_approx_posE[OF this] guess n .
        moreover
        assume "\<forall>i. infdist x A < 1 / real (Suc i)"
        hence "infdist x A < 1 / real (Suc n)" by auto
        ultimately show False by simp
      qed
      also have "M \<dots> = (INF n. emeasure M (?G (1 / real (Suc n))))"
      proof (rule INF_emeasure_decseq[symmetric], safe)
        fix i::nat
        from open_G[of "1 / real (Suc i)"]
        show "?G (1 / real (Suc i)) \<in> sets M" by (simp add: sb borel_open)
      next
        show "decseq (\<lambda>i. {x. infdist x A < 1 / real (Suc i)})"
          by (auto intro: less_trans intro!: divide_strict_left_mono
            simp: decseq_def le_eq_less_or_eq)
      qed simp
      finally
      have "emeasure M A = (INF n. emeasure M {x. infdist x A < 1 / real (Suc n)})" .
      moreover
      have "\<dots> \<ge> (INF U:{U. A \<subseteq> U \<and> open U}. emeasure M U)"
      proof (intro INF_mono)
        fix m
        have "?G (1 / real (Suc m)) \<in> {U. A \<subseteq> U \<and> open U}" using open_G by auto
        moreover have "M (?G (1 / real (Suc m))) \<le> M (?G (1 / real (Suc m)))" by simp
        ultimately show "\<exists>U\<in>{U. A \<subseteq> U \<and> open U}.
          emeasure M U \<le> emeasure M {x. infdist x A < 1 / real (Suc m)}"
          by blast
      qed
      moreover
      have "emeasure M A \<le> (INF U:{U. A \<subseteq> U \<and> open U}. emeasure M U)"
        by (rule INF_greatest) (auto intro!: emeasure_mono simp: sb)
      ultimately show ?thesis by simp
    qed (auto intro!: INF_eqI)
    note `?inner A` `?outer A` }
  note closed_in_D = this
  from `B \<in> sets borel`
  have "Int_stable (Collect closed)" "Collect closed \<subseteq> Pow UNIV" "B \<in> sigma_sets UNIV (Collect closed)"
    by (auto simp: Int_stable_def borel_eq_closed)
  then show "?inner B" "?outer B"
  proof (induct B rule: sigma_sets_induct_disjoint)
    case empty
    { case 1 show ?case by (intro SUP_eqI[symmetric]) auto }
    { case 2 show ?case by (intro INF_eqI[symmetric]) (auto elim!: meta_allE[of _ "{}"]) }
  next
    case (basic B)
    { case 1 from basic closed_in_D show ?case by auto }
    { case 2 from basic closed_in_D show ?case by auto }
  next
    case (compl B)
    note inner = compl(2) and outer = compl(3)
    from compl have [simp]: "B \<in> sets M" by (auto simp: sb borel_eq_closed)
    case 2
    have "M (space M - B) = M (space M) - emeasure M B" by (auto simp: emeasure_compl)
    also have "\<dots> = (INF K:{K. K \<subseteq> B \<and> compact K}. M (space M) -  M K)"
      unfolding inner by (subst INF_ereal_cminus) force+
    also have "\<dots> = (INF U:{U. U \<subseteq> B \<and> compact U}. M (space M - U))"
      by (rule INF_cong) (auto simp add: emeasure_compl sb compact_imp_closed)
    also have "\<dots> \<ge> (INF U:{U. U \<subseteq> B \<and> closed U}. M (space M - U))"
      by (rule INF_superset_mono) (auto simp add: compact_imp_closed)
    also have "(INF U:{U. U \<subseteq> B \<and> closed U}. M (space M - U)) =
        (INF U:{U. space M - B \<subseteq> U \<and> open U}. emeasure M U)"
      by (subst INF_image [of "\<lambda>u. space M - u", symmetric, unfolded comp_def])
        (rule INF_cong, auto simp add: sU intro!: INF_cong)
    finally have
      "(INF U:{U. space M - B \<subseteq> U \<and> open U}. emeasure M U) \<le> emeasure M (space M - B)" .
    moreover have
      "(INF U:{U. space M - B \<subseteq> U \<and> open U}. emeasure M U) \<ge> emeasure M (space M - B)"
      by (auto simp: sb sU intro!: INF_greatest emeasure_mono)
    ultimately show ?case by (auto intro!: antisym simp: sets_eq_imp_space_eq[OF sb])

    case 1
    have "M (space M - B) = M (space M) - emeasure M B" by (auto simp: emeasure_compl)
    also have "\<dots> = (SUP U: {U. B \<subseteq> U \<and> open U}. M (space M) -  M U)"
      unfolding outer by (subst SUP_ereal_cminus) auto
    also have "\<dots> = (SUP U:{U. B \<subseteq> U \<and> open U}. M (space M - U))"
      by (rule SUP_cong) (auto simp add: emeasure_compl sb compact_imp_closed)
    also have "\<dots> = (SUP K:{K. K \<subseteq> space M - B \<and> closed K}. emeasure M K)"
      by (subst SUP_image [of "\<lambda>u. space M - u", symmetric, simplified comp_def])
         (rule SUP_cong, auto simp: sU)
    also have "\<dots> = (SUP K:{K. K \<subseteq> space M - B \<and> compact K}. emeasure M K)"
    proof (safe intro!: antisym SUP_least)
      fix K assume "closed K" "K \<subseteq> space M - B"
      from closed_in_D[OF `closed K`]
      have K_inner: "emeasure M K = (SUP K:{Ka. Ka \<subseteq> K \<and> compact Ka}. emeasure M K)" by simp
      show "emeasure M K \<le> (SUP K:{K. K \<subseteq> space M - B \<and> compact K}. emeasure M K)"
        unfolding K_inner using `K \<subseteq> space M - B`
        by (auto intro!: SUP_upper SUP_least)
    qed (fastforce intro!: SUP_least SUP_upper simp: compact_imp_closed)
    finally show ?case by (auto intro!: antisym simp: sets_eq_imp_space_eq[OF sb])
  next
    case (union D)
    then have "range D \<subseteq> sets M" by (auto simp: sb borel_eq_closed)
    with union have M[symmetric]: "(\<Sum>i. M (D i)) = M (\<Union>i. D i)" by (intro suminf_emeasure)
    also have "(\<lambda>n. \<Sum>i<n. M (D i)) ----> (\<Sum>i. M (D i))"
      by (intro summable_LIMSEQ summable_ereal_pos emeasure_nonneg)
    finally have measure_LIMSEQ: "(\<lambda>n. \<Sum>i<n. measure M (D i)) ----> measure M (\<Union>i. D i)"
      by (simp add: emeasure_eq_measure)
    have "(\<Union>i. D i) \<in> sets M" using `range D \<subseteq> sets M` by auto

    case 1
    show ?case
    proof (rule approx_inner)
      fix e::real assume "e > 0"
      with measure_LIMSEQ
      have "\<exists>no. \<forall>n\<ge>no. \<bar>(\<Sum>i<n. measure M (D i)) -measure M (\<Union>x. D x)\<bar> < e/2"
        by (auto simp: LIMSEQ_def dist_real_def simp del: less_divide_eq_numeral1)
      hence "\<exists>n0. \<bar>(\<Sum>i<n0. measure M (D i)) - measure M (\<Union>x. D x)\<bar> < e/2" by auto
      then obtain n0 where n0: "\<bar>(\<Sum>i<n0. measure M (D i)) - measure M (\<Union>i. D i)\<bar> < e/2"
        unfolding choice_iff by blast
      have "ereal (\<Sum>i<n0. measure M (D i)) = (\<Sum>i<n0. M (D i))"
        by (auto simp add: emeasure_eq_measure)
      also have "\<dots> \<le> (\<Sum>i. M (D i))" by (rule suminf_upper) (auto simp: emeasure_nonneg)
      also have "\<dots> = M (\<Union>i. D i)" by (simp add: M)
      also have "\<dots> = measure M (\<Union>i. D i)" by (simp add: emeasure_eq_measure)
      finally have n0: "measure M (\<Union>i. D i) - (\<Sum>i<n0. measure M (D i)) < e/2"
        using n0 by auto
      have "\<forall>i. \<exists>K. K \<subseteq> D i \<and> compact K \<and> emeasure M (D i) \<le> emeasure M K + e/(2*Suc n0)"
      proof
        fix i
        from `0 < e` have "0 < e/(2*Suc n0)" by simp
        have "emeasure M (D i) = (SUP K:{K. K \<subseteq> (D i) \<and> compact K}. emeasure M K)"
          using union by blast
        from SUP_approx_ereal[OF `0 < e/(2*Suc n0)` this]
        show "\<exists>K. K \<subseteq> D i \<and> compact K \<and> emeasure M (D i) \<le> emeasure M K + e/(2*Suc n0)"
          by (auto simp: emeasure_eq_measure)
      qed
      then obtain K where K: "\<And>i. K i \<subseteq> D i" "\<And>i. compact (K i)"
        "\<And>i. emeasure M (D i) \<le> emeasure M (K i) + e/(2*Suc n0)"
        unfolding choice_iff by blast
      let ?K = "\<Union>i\<in>{..<n0}. K i"
      have "disjoint_family_on K {..<n0}" using K `disjoint_family D`
        unfolding disjoint_family_on_def by blast
      hence mK: "measure M ?K = (\<Sum>i<n0. measure M (K i))" using K
        by (intro finite_measure_finite_Union) (auto simp: sb compact_imp_closed)
      have "measure M (\<Union>i. D i) < (\<Sum>i<n0. measure M (D i)) + e/2" using n0 by simp
      also have "(\<Sum>i<n0. measure M (D i)) \<le> (\<Sum>i<n0. measure M (K i) + e/(2*Suc n0))"
        using K by (auto intro: setsum_mono simp: emeasure_eq_measure)
      also have "\<dots> = (\<Sum>i<n0. measure M (K i)) + (\<Sum>i<n0. e/(2*Suc n0))"
        by (simp add: setsum.distrib)
      also have "\<dots> \<le> (\<Sum>i<n0. measure M (K i)) +  e / 2" using `0 < e`
        by (auto simp: real_of_nat_def[symmetric] field_simps intro!: mult_left_mono)
      finally
      have "measure M (\<Union>i. D i) < (\<Sum>i<n0. measure M (K i)) + e / 2 + e / 2"
        by auto
      hence "M (\<Union>i. D i) < M ?K + e" by (auto simp: mK emeasure_eq_measure)
      moreover
      have "?K \<subseteq> (\<Union>i. D i)" using K by auto
      moreover
      have "compact ?K" using K by auto
      ultimately
      have "?K\<subseteq>(\<Union>i. D i) \<and> compact ?K \<and> emeasure M (\<Union>i. D i) \<le> emeasure M ?K + ereal e" by simp
      thus "\<exists>K\<subseteq>\<Union>i. D i. compact K \<and> emeasure M (\<Union>i. D i) \<le> emeasure M K + ereal e" ..
    qed fact
    case 2
    show ?case
    proof (rule approx_outer[OF `(\<Union>i. D i) \<in> sets M`])
      fix e::real assume "e > 0"
      have "\<forall>i::nat. \<exists>U. D i \<subseteq> U \<and> open U \<and> e/(2 powr Suc i) > emeasure M U - emeasure M (D i)"
      proof
        fix i::nat
        from `0 < e` have "0 < e/(2 powr Suc i)" by simp
        have "emeasure M (D i) = (INF U:{U. (D i) \<subseteq> U \<and> open U}. emeasure M U)"
          using union by blast
        from INF_approx_ereal[OF `0 < e/(2 powr Suc i)` this]
        show "\<exists>U. D i \<subseteq> U \<and> open U \<and> e/(2 powr Suc i) > emeasure M U - emeasure M (D i)"
          by (auto simp: emeasure_eq_measure)
      qed
      then obtain U where U: "\<And>i. D i \<subseteq> U i" "\<And>i. open (U i)"
        "\<And>i. e/(2 powr Suc i) > emeasure M (U i) - emeasure M (D i)"
        unfolding choice_iff by blast
      let ?U = "\<Union>i. U i"
      have "M ?U - M (\<Union>i. D i) = M (?U - (\<Union>i. D i))" using U  `(\<Union>i. D i) \<in> sets M`
        by (subst emeasure_Diff) (auto simp: sb)
      also have "\<dots> \<le> M (\<Union>i. U i - D i)" using U  `range D \<subseteq> sets M`
        by (intro emeasure_mono) (auto simp: sb intro!: sets.countable_nat_UN sets.Diff)
      also have "\<dots> \<le> (\<Sum>i. M (U i - D i))" using U  `range D \<subseteq> sets M`
        by (intro emeasure_subadditive_countably) (auto intro!: sets.Diff simp: sb)
      also have "\<dots> \<le> (\<Sum>i. ereal e/(2 powr Suc i))" using U `range D \<subseteq> sets M`
        by (intro suminf_le_pos, subst emeasure_Diff)
           (auto simp: emeasure_Diff emeasure_eq_measure sb measure_nonneg intro: less_imp_le)
      also have "\<dots> \<le> (\<Sum>n. ereal (e * (1 / 2) ^ Suc n))"
        by (simp add: powr_minus inverse_eq_divide powr_realpow field_simps power_divide)
      also have "\<dots> = (\<Sum>n. ereal e * ((1 / 2) ^  Suc n))"
        unfolding times_ereal.simps[symmetric] ereal_power[symmetric] one_ereal_def numeral_eq_ereal
        by simp
      also have "\<dots> = ereal e * (\<Sum>n. ((1 / 2) ^ Suc n))"
        by (rule suminf_cmult_ereal) (auto simp: `0 < e` less_imp_le)
      also have "\<dots> = e" unfolding suminf_half_series_ereal by simp
      finally
      have "emeasure M ?U \<le> emeasure M (\<Union>i. D i) + ereal e" by (simp add: emeasure_eq_measure)
      moreover
      have "(\<Union>i. D i) \<subseteq> ?U" using U by auto
      moreover
      have "open ?U" using U by auto
      ultimately
      have "(\<Union>i. D i) \<subseteq> ?U \<and> open ?U \<and> emeasure M ?U \<le> emeasure M (\<Union>i. D i) + ereal e" by simp
      thus "\<exists>B. (\<Union>i. D i) \<subseteq> B \<and> open B \<and> emeasure M B \<le> emeasure M (\<Union>i. D i) + ereal e" ..
    qed
  qed
qed

end


(*  Title:      HOL/Library/While_Combinator.thy
    Author:     Tobias Nipkow
    Author:     Alexander Krauss
*)

section \<open>A general ``while'' combinator\<close>

theory While_Combinator
imports MainRLT
begin

subsection \<open>Partial version\<close>

definition while_option :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a option" where
"while_option b c s = (if (\<exists>k. \<not> b ((c ^^ k) s))
   then Some ((c ^^ (LEAST k. \<not> b ((c ^^ k) s))) s)
   else None)"

theorem while_option_unfold[code]:
"while_option b c s = (if b s then while_option b c (c s) else Some s)"
proof cases
  assume "b s"
  show ?thesis
  proof (cases "\<exists>k. \<not> b ((c ^^ k) s)")
    case True
    then obtain k where 1: "\<not> b ((c ^^ k) s)" ..
    with \<open>b s\<close> obtain l where "k = Suc l" by (cases k) auto
    with 1 have "\<not> b ((c ^^ l) (c s))" by (auto simp: funpow_swap1)
    then have 2: "\<exists>l. \<not> b ((c ^^ l) (c s))" ..
    from 1
    have "(LEAST k. \<not> b ((c ^^ k) s)) = Suc (LEAST l. \<not> b ((c ^^ Suc l) s))"
      by (rule Least_Suc) (simp add: \<open>b s\<close>)
    also have "... = Suc (LEAST l. \<not> b ((c ^^ l) (c s)))"
      by (simp add: funpow_swap1)
    finally
    show ?thesis
      using True 2 \<open>b s\<close> by (simp add: funpow_swap1 while_option_def)
  next
    case False
    then have "\<not> (\<exists>l. \<not> b ((c ^^ Suc l) s))" by blast
    then have "\<not> (\<exists>l. \<not> b ((c ^^ l) (c s)))"
      by (simp add: funpow_swap1)
    with False  \<open>b s\<close> show ?thesis by (simp add: while_option_def)
  qed
next
  assume [simp]: "\<not> b s"
  have least: "(LEAST k. \<not> b ((c ^^ k) s)) = 0"
    by (rule Least_equality) auto
  moreover
  have "\<exists>k. \<not> b ((c ^^ k) s)" by (rule exI[of _ "0::nat"]) auto
  ultimately show ?thesis unfolding while_option_def by auto
qed

lemma while_option_stop2:
 "while_option b c s = Some t \<Longrightarrow> \<exists>k. t = (c^^k) s \<and> \<not> b t"
apply(simp add: while_option_def split: if_splits)
by (metis (lifting) LeastI_ex)

lemma while_option_stop: "while_option b c s = Some t \<Longrightarrow> \<not> b t"
by(metis while_option_stop2)

theorem while_option_rule:
  assumes step: "!!s. P s ==> b s ==> P (c s)"
    and result: "while_option b c s = Some t"
    and init: "P s"
  shows "P t"
proof -
  define k where "k = (LEAST k. \<not> b ((c ^^ k) s))"
  from assms have t: "t = (c ^^ k) s"
    by (simp add: while_option_def k_def split: if_splits)
  have 1: "\<forall>i<k. b ((c ^^ i) s)"
    by (auto simp: k_def dest: not_less_Least)

  { fix i assume "i \<le> k" then have "P ((c ^^ i) s)"
      by (induct i) (auto simp: init step 1) }
  thus "P t" by (auto simp: t)
qed

lemma funpow_commute:
  "\<lbrakk>\<forall>k' < k. f (c ((c^^k') s)) = c' (f ((c^^k') s))\<rbrakk> \<Longrightarrow> f ((c^^k) s) = (c'^^k) (f s)"
by (induct k arbitrary: s) auto

lemma while_option_commute_invariant:
assumes Invariant: "\<And>s. P s \<Longrightarrow> b s \<Longrightarrow> P (c s)"
assumes TestCommute: "\<And>s. P s \<Longrightarrow> b s = b' (f s)"
assumes BodyCommute: "\<And>s. P s \<Longrightarrow> b s \<Longrightarrow> f (c s) = c' (f s)"
assumes Initial: "P s"
shows "map_option f (while_option b c s) = while_option b' c' (f s)"
unfolding while_option_def
proof (rule trans[OF if_distrib if_cong], safe, unfold option.inject)
  fix k
  assume "\<not> b ((c ^^ k) s)"
  with Initial show "\<exists>k. \<not> b' ((c' ^^ k) (f s))"
  proof (induction k arbitrary: s)
    case 0 thus ?case by (auto simp: TestCommute intro: exI[of _ 0])
  next
    case (Suc k) thus ?case
    proof (cases "b s")
      assume "b s"
      with Suc.IH[of "c s"] Suc.prems show ?thesis
        by (metis BodyCommute Invariant comp_apply funpow.simps(2) funpow_swap1)
    next
      assume "\<not> b s"
      with Suc show ?thesis by (auto simp: TestCommute intro: exI [of _ 0])
    qed
  qed
next
  fix k
  assume "\<not> b' ((c' ^^ k) (f s))"
  with Initial show "\<exists>k. \<not> b ((c ^^ k) s)"
  proof (induction k arbitrary: s)
    case 0 thus ?case by (auto simp: TestCommute intro: exI[of _ 0])
  next
    case (Suc k) thus ?case
    proof (cases "b s")
       assume "b s"
      with Suc.IH[of "c s"] Suc.prems show ?thesis
        by (metis BodyCommute Invariant comp_apply funpow.simps(2) funpow_swap1)
    next
      assume "\<not> b s"
      with Suc show ?thesis by (auto simp: TestCommute intro: exI [of _ 0])
    qed
  qed
next
  fix k
  assume k: "\<not> b' ((c' ^^ k) (f s))"
  have *: "(LEAST k. \<not> b' ((c' ^^ k) (f s))) = (LEAST k. \<not> b ((c ^^ k) s))"
          (is "?k' = ?k")
  proof (cases ?k')
    case 0
    have "\<not> b' ((c' ^^ 0) (f s))"
      unfolding 0[symmetric] by (rule LeastI[of _ k]) (rule k)
    hence "\<not> b s" by (auto simp: TestCommute Initial)
    hence "?k = 0" by (intro Least_equality) auto
    with 0 show ?thesis by auto
  next
    case (Suc k')
    have "\<not> b' ((c' ^^ Suc k') (f s))"
      unfolding Suc[symmetric] by (rule LeastI) (rule k)
    moreover
    { fix k assume "k \<le> k'"
      hence "k < ?k'" unfolding Suc by simp
      hence "b' ((c' ^^ k) (f s))" by (rule iffD1[OF not_not, OF not_less_Least])
    }
    note b' = this
    { fix k assume "k \<le> k'"
      hence "f ((c ^^ k) s) = (c' ^^ k) (f s)"
      and "b ((c ^^ k) s) = b' ((c' ^^ k) (f s))"
      and "P ((c ^^ k) s)"
        by (induct k) (auto simp: b' assms)
      with \<open>k \<le> k'\<close>
      have "b ((c ^^ k) s)"
      and "f ((c ^^ k) s) = (c' ^^ k) (f s)"
      and "P ((c ^^ k) s)"
        by (auto simp: b')
    }
    note b = this(1) and body = this(2) and inv = this(3)
    hence k': "f ((c ^^ k') s) = (c' ^^ k') (f s)" by auto
    ultimately show ?thesis unfolding Suc using b
    proof (intro Least_equality[symmetric], goal_cases)
      case 1
      hence Test: "\<not> b' (f ((c ^^ Suc k') s))"
        by (auto simp: BodyCommute inv b)
      have "P ((c ^^ Suc k') s)" by (auto simp: Invariant inv b)
      with Test show ?case by (auto simp: TestCommute)
    next
      case 2
      thus ?case by (metis not_less_eq_eq)
    qed
  qed
  have "f ((c ^^ ?k) s) = (c' ^^ ?k') (f s)" unfolding *
  proof (rule funpow_commute, clarify)
    fix k assume "k < ?k"
    hence TestTrue: "b ((c ^^ k) s)" by (auto dest: not_less_Least)
    from \<open>k < ?k\<close> have "P ((c ^^ k) s)"
    proof (induct k)
      case 0 thus ?case by (auto simp: assms)
    next
      case (Suc h)
      hence "P ((c ^^ h) s)" by auto
      with Suc show ?case
        by (auto, metis (lifting, no_types) Invariant Suc_lessD not_less_Least)
    qed
    with TestTrue show "f (c ((c ^^ k) s)) = c' (f ((c ^^ k) s))"
      by (metis BodyCommute)
  qed
  thus "\<exists>z. (c ^^ ?k) s = z \<and> f z = (c' ^^ ?k') (f s)" by blast
qed

lemma while_option_commute:
  assumes "\<And>s. b s = b' (f s)" "\<And>s. \<lbrakk>b s\<rbrakk> \<Longrightarrow> f (c s) = c' (f s)"
  shows "map_option f (while_option b c s) = while_option b' c' (f s)"
by(rule while_option_commute_invariant[where P = "\<lambda>_. True"])
  (auto simp add: assms)

subsection \<open>Total version\<close>

definition while :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a"
where "while b c s = the (while_option b c s)"

lemma while_unfold [code]:
  "while b c s = (if b s then while b c (c s) else s)"
unfolding while_def by (subst while_option_unfold) simp

lemma def_while_unfold:
  assumes fdef: "f == while test do"
  shows "f x = (if test x then f(do x) else x)"
unfolding fdef by (fact while_unfold)

text \<open>
 The proof rule for \<^term>\<open>while\<close>, where \<^term>\<open>P\<close> is the invariant.
\<close>

theorem while_rule_lemma:
  assumes invariant: "!!s. P s ==> b s ==> P (c s)"
    and terminate: "!!s. P s ==> \<not> b s ==> Q s"
    and wf: "wf {(t, s). P s \<and> b s \<and> t = c s}"
  shows "P s \<Longrightarrow> Q (while b c s)"
  using wf
  apply (induct s)
  apply simp
  apply (subst while_unfold)
  apply (simp add: invariant terminate)
  done

theorem while_rule:
  "[| P s;
      !!s. [| P s; b s  |] ==> P (c s);
      !!s. [| P s; \<not> b s  |] ==> Q s;
      wf r;
      !!s. [| P s; b s  |] ==> (c s, s) \<in> r |] ==>
   Q (while b c s)"
  apply (rule while_rule_lemma)
     prefer 4 apply assumption
    apply blast
   apply blast
  apply (erule wf_subset)
  apply blast
  done

text\<open>Proving termination:\<close>

theorem wf_while_option_Some:
  assumes "wf {(t, s). (P s \<and> b s) \<and> t = c s}"
  and "\<And>s. P s \<Longrightarrow> b s \<Longrightarrow> P(c s)" and "P s"
  shows "\<exists>t. while_option b c s = Some t"
using assms(1,3)
proof (induction s)
  case less thus ?case using assms(2)
    by (subst while_option_unfold) simp
qed

lemma wf_rel_while_option_Some:
assumes wf: "wf R"
assumes smaller: "\<And>s. P s \<and> b s \<Longrightarrow> (c s, s) \<in> R"
assumes inv: "\<And>s. P s \<and> b s \<Longrightarrow> P(c s)"
assumes init: "P s"
shows "\<exists>t. while_option b c s = Some t"
proof -
 from smaller have "{(t,s). P s \<and> b s \<and> t = c s} \<subseteq> R" by auto
 with wf have "wf {(t,s). P s \<and> b s \<and> t = c s}" by (auto simp: wf_subset)
 with inv init show ?thesis by (auto simp: wf_while_option_Some)
qed

theorem measure_while_option_Some: fixes f :: "'s \<Rightarrow> nat"
shows "(\<And>s. P s \<Longrightarrow> b s \<Longrightarrow> P(c s) \<and> f(c s) < f s)
  \<Longrightarrow> P s \<Longrightarrow> \<exists>t. while_option b c s = Some t"
by(blast intro: wf_while_option_Some[OF wf_if_measure, of P b f])

text\<open>Kleene iteration starting from the empty set and assuming some finite
bounding set:\<close>

lemma while_option_finite_subset_Some: fixes C :: "'a set"
  assumes "mono f" and "!!X. X \<subseteq> C \<Longrightarrow> f X \<subseteq> C" and "finite C"
  shows "\<exists>P. while_option (\<lambda>A. f A \<noteq> A) f {} = Some P"
proof(rule measure_while_option_Some[where
    f= "%A::'a set. card C - card A" and P= "%A. A \<subseteq> C \<and> A \<subseteq> f A" and s= "{}"])
  fix A assume A: "A \<subseteq> C \<and> A \<subseteq> f A" "f A \<noteq> A"
  show "(f A \<subseteq> C \<and> f A \<subseteq> f (f A)) \<and> card C - card (f A) < card C - card A"
    (is "?L \<and> ?R")
  proof
    show ?L by(metis A(1) assms(2) monoD[OF \<open>mono f\<close>])
    show ?R by (metis A assms(2,3) card_seteq diff_less_mono2 equalityI linorder_le_less_linear rev_finite_subset)
  qed
qed simp

lemma lfp_the_while_option:
  assumes "mono f" and "!!X. X \<subseteq> C \<Longrightarrow> f X \<subseteq> C" and "finite C"
  shows "lfp f = the(while_option (\<lambda>A. f A \<noteq> A) f {})"
proof-
  obtain P where "while_option (\<lambda>A. f A \<noteq> A) f {} = Some P"
    using while_option_finite_subset_Some[OF assms] by blast
  with while_option_stop2[OF this] lfp_Kleene_iter[OF assms(1)]
  show ?thesis by auto
qed

lemma lfp_while:
  assumes "mono f" and "!!X. X \<subseteq> C \<Longrightarrow> f X \<subseteq> C" and "finite C"
  shows "lfp f = while (\<lambda>A. f A \<noteq> A) f {}"
unfolding while_def using assms by (rule lfp_the_while_option) blast

lemma wf_finite_less:
  assumes "finite (C :: 'a::order set)"
  shows "wf {(x, y). {x, y} \<subseteq> C \<and> x < y}"
by (rule wf_measure[where f="\<lambda>b. card {a. a \<in> C \<and> a < b}", THEN wf_subset])
   (fastforce simp: less_eq assms intro: psubset_card_mono)

lemma wf_finite_greater:
  assumes "finite (C :: 'a::order set)"
  shows "wf {(x, y). {x, y} \<subseteq> C \<and> y < x}"
by (rule wf_measure[where f="\<lambda>b. card {a. a \<in> C \<and> b < a}", THEN wf_subset])
   (fastforce simp: less_eq assms intro: psubset_card_mono)

lemma while_option_finite_increasing_Some:
  fixes f :: "'a::order \<Rightarrow> 'a"
  assumes "mono f" and "finite (UNIV :: 'a set)" and "s \<le> f s"
  shows "\<exists>P. while_option (\<lambda>A. f A \<noteq> A) f s = Some P"
by (rule wf_rel_while_option_Some[where R="{(x, y). y < x}" and P="\<lambda>A. A \<le> f A" and s="s"])
   (auto simp: assms monoD intro: wf_finite_greater[where C="UNIV::'a set", simplified])

lemma lfp_the_while_option_lattice:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  assumes "mono f" and "finite (UNIV :: 'a set)"
  shows "lfp f = the (while_option (\<lambda>A. f A \<noteq> A) f bot)"
proof -
  obtain P where "while_option (\<lambda>A. f A \<noteq> A) f bot = Some P"
    using while_option_finite_increasing_Some[OF assms, where s=bot] by simp blast
  with while_option_stop2[OF this] lfp_Kleene_iter[OF assms(1)]
  show ?thesis by auto
qed

lemma lfp_while_lattice:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  assumes "mono f" and "finite (UNIV :: 'a set)"
  shows "lfp f = while (\<lambda>A. f A \<noteq> A) f bot"
unfolding while_def using assms by (rule lfp_the_while_option_lattice)

lemma while_option_finite_decreasing_Some:
  fixes f :: "'a::order \<Rightarrow> 'a"
  assumes "mono f" and "finite (UNIV :: 'a set)" and "f s \<le> s"
  shows "\<exists>P. while_option (\<lambda>A. f A \<noteq> A) f s = Some P"
by (rule wf_rel_while_option_Some[where R="{(x, y). x < y}" and P="\<lambda>A. f A \<le> A" and s="s"])
   (auto simp add: assms monoD intro: wf_finite_less[where C="UNIV::'a set", simplified])

lemma gfp_the_while_option_lattice:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  assumes "mono f" and "finite (UNIV :: 'a set)"
  shows "gfp f = the(while_option (\<lambda>A. f A \<noteq> A) f top)"
proof -
  obtain P where "while_option (\<lambda>A. f A \<noteq> A) f top = Some P"
    using while_option_finite_decreasing_Some[OF assms, where s=top] by simp blast
  with while_option_stop2[OF this] gfp_Kleene_iter[OF assms(1)]
  show ?thesis by auto
qed

lemma gfp_while_lattice:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  assumes "mono f" and "finite (UNIV :: 'a set)"
  shows "gfp f = while (\<lambda>A. f A \<noteq> A) f top"
unfolding while_def using assms by (rule gfp_the_while_option_lattice)

text\<open>Computing the reflexive, transitive closure by iterating a successor
function. Stops when an element is found that dos not satisfy the test.

More refined (and hence more efficient) versions can be found in ITP 2011 paper
by Nipkow (the theories are in the AFP entry Flyspeck by Nipkow)
and the AFP article Executable Transitive Closures by René Thiemann.\<close>

context
fixes p :: "'a \<Rightarrow> bool"
and f :: "'a \<Rightarrow> 'a list"
and x :: 'a
begin

qualified fun rtrancl_while_test :: "'a list \<times> 'a set \<Rightarrow> bool"
where "rtrancl_while_test (ws,_) = (ws \<noteq> [] \<and> p(hd ws))"

qualified fun rtrancl_while_step :: "'a list \<times> 'a set \<Rightarrow> 'a list \<times> 'a set"
where "rtrancl_while_step (ws, Z) =
  (let x = hd ws; new = remdups (filter (\<lambda>y. y \<notin> Z) (f x))
  in (new @ tl ws, set new \<union> Z))"

definition rtrancl_while :: "('a list * 'a set) option"
where "rtrancl_while = while_option rtrancl_while_test rtrancl_while_step ([x],{x})"

qualified fun rtrancl_while_invariant :: "'a list \<times> 'a set \<Rightarrow> bool"
where "rtrancl_while_invariant (ws, Z) =
   (x \<in> Z \<and> set ws \<subseteq> Z \<and> distinct ws \<and> {(x,y). y \<in> set(f x)} `` (Z - set ws) \<subseteq> Z \<and>
    Z \<subseteq> {(x,y). y \<in> set(f x)}\<^sup>* `` {x} \<and> (\<forall>z\<in>Z - set ws. p z))"

qualified lemma rtrancl_while_invariant:
  assumes inv: "rtrancl_while_invariant st" and test: "rtrancl_while_test st"
  shows   "rtrancl_while_invariant (rtrancl_while_step st)"
proof (cases st)
  fix ws Z assume st: "st = (ws, Z)"
  with test obtain h t where "ws = h # t" "p h" by (cases ws) auto
  with inv st show ?thesis by (auto intro: rtrancl.rtrancl_into_rtrancl)
qed

lemma rtrancl_while_Some: assumes "rtrancl_while = Some(ws,Z)"
shows "if ws = []
       then Z = {(x,y). y \<in> set(f x)}\<^sup>* `` {x} \<and> (\<forall>z\<in>Z. p z)
       else \<not>p(hd ws) \<and> hd ws \<in> {(x,y). y \<in> set(f x)}\<^sup>* `` {x}"
proof -
  have "rtrancl_while_invariant ([x],{x})" by simp
  with rtrancl_while_invariant have I: "rtrancl_while_invariant (ws,Z)"
    by (rule while_option_rule[OF _ assms[unfolded rtrancl_while_def]])
  { assume "ws = []"
    hence ?thesis using I
      by (auto simp del:Image_Collect_case_prod dest: Image_closed_trancl)
  } moreover
  { assume "ws \<noteq> []"
    hence ?thesis using I while_option_stop[OF assms[unfolded rtrancl_while_def]]
      by (simp add: subset_iff)
  }
  ultimately show ?thesis by simp
qed

lemma rtrancl_while_finite_Some:
  assumes "finite ({(x, y). y \<in> set (f x)}\<^sup>* `` {x})" (is "finite ?Cl")
  shows "\<exists>y. rtrancl_while = Some y"
proof -
  let ?R = "(\<lambda>(_, Z). card (?Cl - Z)) <*mlex*> (\<lambda>(ws, _). length ws) <*mlex*> {}"
  have "wf ?R" by (blast intro: wf_mlex)
  then show ?thesis unfolding rtrancl_while_def
  proof (rule wf_rel_while_option_Some[of ?R rtrancl_while_invariant])
    fix st assume *: "rtrancl_while_invariant st \<and> rtrancl_while_test st"
    hence I: "rtrancl_while_invariant (rtrancl_while_step st)"
      by (blast intro: rtrancl_while_invariant)
    show "(rtrancl_while_step st, st) \<in> ?R"
    proof (cases st)
      fix ws Z let ?ws = "fst (rtrancl_while_step st)" and ?Z = "snd (rtrancl_while_step st)"
      assume st: "st = (ws, Z)"
      with * obtain h t where ws: "ws = h # t" "p h" by (cases ws) auto
      { assume "remdups (filter (\<lambda>y. y \<notin> Z) (f h)) \<noteq> []"
        then obtain z where "z \<in> set (remdups (filter (\<lambda>y. y \<notin> Z) (f h)))" by fastforce
        with st ws I have "Z \<subset> ?Z" "Z \<subseteq> ?Cl" "?Z \<subseteq> ?Cl" by auto
        with assms have "card (?Cl - ?Z) < card (?Cl - Z)" by (blast intro: psubset_card_mono)
        with st ws have ?thesis unfolding mlex_prod_def by simp
      }
      moreover
      { assume "remdups (filter (\<lambda>y. y \<notin> Z) (f h)) = []"
        with st ws have "?Z = Z" "?ws = t"  by (auto simp: filter_empty_conv)
        with st ws have ?thesis unfolding mlex_prod_def by simp
      }
      ultimately show ?thesis by blast
    qed
  qed (simp_all add: rtrancl_while_invariant)
qed

end

end


(*  Title:      Well-Quasi-Orders
    Author:     Christian Sternagel <c.sternagel@gmail.com>
    Maintainer: Christian Sternagel
    License:    LGPL
*)

section \<open>Multiset Extension Preserves Well-Quasi-Orders\<close>

theory Wqo_Multiset
imports
  Multiset_Extension
  Well_Quasi_Orders
begin

lemma list_emb_imp_reflclp_mulex_on:
  assumes "xs \<in> lists A" and "ys \<in> lists A"
    and "list_emb P xs ys"
  shows "(mulex_on P A)\<^sup>=\<^sup>= (mset xs) (mset ys)"
using assms(3, 1, 2)
proof (induct)
  case (list_emb_Nil ys)
  then show ?case
    by (cases ys) (auto intro!: empty_mulex_on simp: multisets_def)
next
  case (list_emb_Cons xs ys y)
  then show ?case by (auto intro!: mulex_on_self_add_singleton_right simp: multisets_def)
next
  case (list_emb_Cons2 x y xs ys)
  then show ?case
    by (force intro: union_mulex_on_mono mulex_on_add_mset
             mulex_on_add_mset' mulex_on_add_mset_mono
             simp: multisets_def)
qed

text \<open>The (reflexive closure of the) multiset extension of an almost-full relation
is almost-full.\<close>
lemma almost_full_on_multisets:
  assumes "almost_full_on P A"
  shows "almost_full_on (mulex_on P A)\<^sup>=\<^sup>= (multisets A)"
proof -
  let ?P = "(mulex_on P A)\<^sup>=\<^sup>="
  from almost_full_on_hom [OF _ almost_full_on_lists, of A P ?P mset,
    OF list_emb_imp_reflclp_mulex_on, simplified]
    show ?thesis using assms by blast
qed

lemma wqo_on_multisets:
  assumes "wqo_on P A"
  shows "wqo_on (mulex_on P A)\<^sup>=\<^sup>= (multisets A)"
proof
  from transp_on_mulex_on [of "multisets A" P A]
    show "transp_on (multisets A) (mulex_on P A)\<^sup>=\<^sup>="
    unfolding transp_on_def by blast
next
  from almost_full_on_multisets [OF assms [THEN wqo_on_imp_almost_full_on]]
    show "almost_full_on (mulex_on P A)\<^sup>=\<^sup>= (multisets A)" .
qed

end


theory More_List
imports Main "HOL-Library.Multiset"
begin

subsection \<open>Swap two elements of a list, by index\<close>

(* Move to List *)

definition "swap l i j \<equiv> l[i := l!j, j:=l!i]"
lemma swap_nth: "\<lbrakk>i < length l; j<length l; k<length l\<rbrakk> \<Longrightarrow>
  swap l i j!k = (
    if k=i then l!j
    else if k=j then l!i
    else l!k
  )"
  unfolding swap_def
  by auto

lemma swap_set[simp]: "\<lbrakk> i < length l; j<length l \<rbrakk> \<Longrightarrow> set (swap l i j) = set l"
  unfolding swap_def
  by auto

lemma swap_length[simp]: "length (swap l i j) = length l"
  unfolding swap_def
  by auto

lemma swap_same[simp]: "swap l i i = l"
  unfolding swap_def by auto

lemma distinct_swap[simp]:
  "\<lbrakk>i<length l; j<length l\<rbrakk> \<Longrightarrow> distinct (swap l i j) = distinct l"
  unfolding swap_def
  by auto

lemma map_swap: "\<lbrakk>i<length l; j<length l\<rbrakk>
  \<Longrightarrow> map f (swap l i j) = swap (map f l) i j"
  unfolding swap_def
  by (auto simp add: map_update)

(* Move to Multiset *)

lemma swap_multiset[simp]: "\<lbrakk> i < length l; j<length l \<rbrakk> \<Longrightarrow> mset (swap l i j) = mset l"
  unfolding swap_def
  by (auto simp: mset_swap)

end


(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Code Generation for Basic Matrix Operations\<close>

text \<open>In this theory we implement matrices as arrays of arrays.
  Due to the target language serialization, access to matrix
  entries should be constant time. Hence operations like
  matrix addition, multiplication, etc.~should all have their
  standard complexity.

  There might be room for optimizations.

  To implement the infinite carrier set, we use A.\ Lochbihler's container framework
  \cite{Containers-AFP}.\<close>

theory Matrix_IArray_Impl
imports
  Matrix
  "HOL-Library.IArray"
  Containers.Set_Impl
begin

typedef 'a vec_impl = "{(n,v :: 'a iarray). IArray.length v = n}" by auto
typedef 'a mat_impl = "{(nr,nc,m :: 'a iarray iarray).
  IArray.length m = nr \<and> IArray.all (\<lambda> r. IArray.length r = nc) m}"
  by (rule exI[of _ "(0,0,IArray [])"], auto)

setup_lifting type_definition_vec_impl
setup_lifting type_definition_mat_impl

lift_definition vec_impl :: "'a vec_impl \<Rightarrow> 'a vec" is
  "\<lambda> (n,v). (n,mk_vec n (IArray.sub v))" by auto

lift_definition vec_add_impl :: "'a::plus vec_impl \<Rightarrow> 'a vec_impl \<Rightarrow> 'a vec_impl" is
  "\<lambda> (n,v) (m,w).
  (n, IArray.of_fun (\<lambda>i. IArray.sub v i + IArray.sub w i) n)"
by auto

lift_definition mat_impl :: "'a mat_impl \<Rightarrow> 'a mat" is
  "\<lambda> (nr,nc,m). (nr,nc,mk_mat nr nc (\<lambda> (i,j). IArray.sub (IArray.sub m i) j))" by auto

lift_definition vec_of_list_impl :: "'a list \<Rightarrow> 'a vec_impl" is
  "\<lambda> v. (length v, IArray v)" by auto

lift_definition list_of_vec_impl :: "'a vec_impl \<Rightarrow> 'a list" is
  "\<lambda> (n,v). IArray.list_of v" .

lift_definition vec_of_fun :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> 'a vec_impl" is
  "\<lambda> n f. (n, IArray.of_fun f n)" by auto

lift_definition mat_of_fun :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat \<Rightarrow> 'a) \<Rightarrow> 'a mat_impl" is
  "\<lambda> nr nc f. (nr, nc, IArray.of_fun (\<lambda> i. IArray.of_fun (\<lambda> j. f (i,j)) nc) nr)" by auto

lift_definition vec_index_impl :: "'a vec_impl \<Rightarrow> nat \<Rightarrow> 'a"
  is "\<lambda> (n,v). IArray.sub v" .

lift_definition index_mat_impl :: "'a mat_impl \<Rightarrow> nat \<times> nat \<Rightarrow> 'a"
  is "\<lambda> (nr,nc,m) (i,j). if i < nr then IArray.sub (IArray.sub m i) j
    else IArray.sub (IArray ([] ! (i - nr))) j" .

lift_definition vec_equal_impl :: "'a vec_impl \<Rightarrow> 'a vec_impl \<Rightarrow> bool"
  is "\<lambda> (n1,v1) (n2,v2). n1 = n2 \<and> v1 = v2" .

lift_definition mat_equal_impl :: "'a mat_impl \<Rightarrow> 'a mat_impl \<Rightarrow> bool"
  is "\<lambda> (nr1,nc1,m1) (nr2,nc2,m2). nr1 = nr2 \<and> nc1 = nc2 \<and> m1 = m2" .

lift_definition dim_vec_impl :: "'a vec_impl \<Rightarrow> nat" is fst .

lift_definition dim_row_impl :: "'a mat_impl \<Rightarrow> nat" is fst .
lift_definition dim_col_impl :: "'a mat_impl \<Rightarrow> nat" is "fst o snd" .

code_datatype vec_impl
code_datatype mat_impl

lemma vec_code[code]: "vec n f = vec_impl (vec_of_fun n f)"
  by (transfer, auto simp: mk_vec_def)

lemma mat_code[code]: "mat nr nc f = mat_impl (mat_of_fun nr nc f)"
  by (transfer, auto simp: mk_mat_def, intro ext, clarsimp,
  auto intro: undef_cong_mat)

lemma vec_of_list[code]: "vec_of_list v = vec_impl (vec_of_list_impl v)"
  by (transfer, auto simp: mk_vec_def)

lemma list_of_vec_code[code]: "list_of_vec (vec_impl v) = list_of_vec_impl v"
  by (transfer, auto simp: mk_vec_def, case_tac b, auto intro: nth_equalityI)

lemma empty_nth: "\<not> i < length x \<Longrightarrow> x ! i = [] ! (i - length x)"
  by (metis append_Nil2 nth_append)

lemma undef_vec: "\<not> i < length x \<Longrightarrow> undef_vec (i - length x) = x ! i"
  unfolding undef_vec_def by (rule empty_nth[symmetric])

lemma vec_index_code[code]: "(vec_impl v) $ i = vec_index_impl v i"
  by (transfer, auto simp: mk_vec_def, case_tac b, auto simp: undef_vec)

lemma index_mat_code[code]: "(mat_impl m) $$ ij = (index_mat_impl m ij :: 'a)"
proof (transfer, unfold o_def, clarify)
  fix m :: "'a iarray iarray" and i j nc
  assume all: "IArray.all (\<lambda>r. IArray.length r = nc) m"
  obtain mm where m: "m = IArray mm" by (cases m)
  with all have all: "\<And> v. v \<in> set mm \<Longrightarrow> IArray.length v = nc" by auto
  show "snd (snd (IArray.length m, nc, mk_mat (IArray.length m) nc (\<lambda>(i, y). m !! i !! y))) (i, j) =
     (if i < IArray.length m then m !! i !! j
        else IArray ([] ! (i - IArray.length m)) !! j)" (is "?l = ?r")
  proof (cases "i < length mm")
    case False
    hence "\<And> f. \<not> i < length (map f [0..<length mm])" by simp
    note [simp] = empty_nth[OF this]
    have "?l = [] ! (i - length mm) ! j" using False unfolding m mk_mat_def undef_mat_def by simp
    also have "\<dots> = ?r" unfolding m by (simp add: False empty_nth[OF False])
    finally show ?thesis .
  next
    case True
    obtain v where mm: "mm ! i = IArray v" by (cases "mm ! i")
    with True all[of "mm ! i"] have len: "length v = nc" unfolding set_conv_nth by force
    from mm True have "?l = map ((!) v) [0..<nc] ! j" (is "_ = ?m") unfolding m mk_mat_def undef_mat_def by simp
    also have "?m = m !! i !! j"
    proof (cases "j < length v")
      case True
      thus ?thesis unfolding m using mm len by auto
    next
      case False
      hence j: "\<not> j < length (map ((!) v) [0..<length v])" by simp
      show ?thesis unfolding m using mm len by (auto simp: empty_nth[OF j] empty_nth[OF False])
    qed
    also have "\<dots> = ?r" using True m by simp
    finally show ?thesis .
  qed
qed

lift_definition (code_dt) mat_of_rows_list_impl :: "nat \<Rightarrow> 'a list list \<Rightarrow> 'a mat_impl option" is
  "\<lambda> n rows. if list_all (\<lambda> r. length r = n) rows then Some (length rows, n, IArray (map IArray rows))
  else None"
  by (auto split: if_splits simp: list_all_iff)

lemma mat_of_rows_list_impl: "mat_of_rows_list_impl n rs = Some A \<Longrightarrow> mat_impl A = mat_of_rows_list n rs"
  unfolding mat_of_rows_list_def
  by (transfer, auto split: if_splits simp: list_all_iff intro!: cong_mk_mat)

lemma mat_of_rows_list_code[code]: "mat_of_rows_list nc vs =
  (case mat_of_rows_list_impl nc vs of Some A \<Rightarrow> mat_impl A
  | None \<Rightarrow> mat_of_rows nc (map (\<lambda> v. vec nc (nth v)) vs))"
proof (cases "mat_of_rows_list_impl nc vs")
  case (Some A)
  from mat_of_rows_list_impl[OF this] show ?thesis unfolding Some by simp
next
  case None
  show ?thesis unfolding None unfolding mat_of_rows_list_def mat_of_rows_def
    by (intro eq_matI, auto)
qed

lemma dim_vec_code[code]: "dim_vec (vec_impl v) = dim_vec_impl v"
  by (transfer, auto)

lemma dim_row_code[code]: "dim_row (mat_impl m) = dim_row_impl m"
  by (transfer, auto)

lemma dim_col_code[code]: "dim_col (mat_impl m) = dim_col_impl m"
  by (transfer, auto)

instantiation vec :: (type)equal
begin
  definition "(equal_vec :: ('a vec \<Rightarrow> 'a vec \<Rightarrow> bool)) = (=)"
instance
  by (intro_classes, auto simp: equal_vec_def)
end

instantiation mat :: (type)equal
begin
  definition "(equal_mat :: ('a mat \<Rightarrow> 'a mat \<Rightarrow> bool)) = (=)"
instance
  by (intro_classes, auto simp: equal_mat_def)
end

lemma veq_equal_code[code]: "HOL.equal (vec_impl (v1 :: 'a vec_impl)) (vec_impl v2) = vec_equal_impl v1 v2"
proof -
  {
    fix x1 x2 :: "'a list"
    assume len: "length x1 = length x2"
       and index: "(\<lambda>i. if i < length x2 then IArray x1 !! i else undef_vec (i - length (IArray.list_of (IArray x1)))) =
            (\<lambda>i. if i < length x2 then IArray x2 !! i else undef_vec (i - length (IArray.list_of (IArray x2))))"
    have "x1 = x2"
    proof (intro nth_equalityI[OF len])
      fix i
      assume "i < length x1"
      with fun_cong[OF index, of i] len show "x1 ! i = x2 ! i" by simp
    qed
  } note * = this
  show ?thesis unfolding equal_vec_def
    by (transfer, insert *, auto simp: mk_vec_def, case_tac b, case_tac ba, auto)
qed

lemma mat_equal_code[code]: "HOL.equal (mat_impl (m1 :: 'a mat_impl)) (mat_impl m2) = mat_equal_impl m1 m2"
proof -
  show ?thesis unfolding equal_mat_def
  proof (transfer, auto, case_tac b, case_tac ba, auto)
    fix x1 x2 :: "'a iarray list" and nc
    assume len: "\<forall>r\<in>set x1. length (IArray.list_of r) = nc"
      "\<forall>r\<in>set x2. length (IArray.list_of r) = nc"
      "length x1 = length x2"
    and index: "mk_mat (length x2) nc (\<lambda>(i, j). x1 ! i !! j) = mk_mat (length x2) nc (\<lambda>(i, j). x2 ! i !! j)"
    show "x1 = x2"
    proof (rule nth_equalityI[OF len(3)])
      fix i
      assume i: "i < length x1"
      obtain ia1 where 1: "x1 ! i = IArray ia1" by (cases "x1 ! i")
      obtain ia2 where 2: "x2 ! i = IArray ia2" by (cases "x2 ! i")
      from i 1 len(1) have l1: "length ia1 = nc" using nth_mem by fastforce
      from i 2 len(2-3) have l2: "length ia2 = nc" using nth_mem by fastforce
      from l1 l2 have l: "length ia1 = length ia2" by simp
      show "x1 ! i = x2 ! i" unfolding 1 2
      proof (simp, rule nth_equalityI[OF l])
        fix j
        assume j: "j < length ia1"
        with fun_cong[OF index, of "(i,j)"] i len(3)
        have "x1 ! i !! j = x2 ! i !! j"
          by (simp add: mk_mat_def l1)
        thus "ia1 ! j = ia2 ! j" unfolding 1 2 by simp
      qed
    qed
  qed
qed

declare prod.set_conv_list[code del, code_unfold]

derive (eq) ceq mat vec
derive (no) ccompare mat vec
derive (dlist) set_impl mat vec
derive (no) cenum mat vec

lemma carrier_mat_code[code]: "carrier_mat nr nc = Collect_set (\<lambda> A. dim_row A = nr \<and> dim_col A = nc)" by auto
lemma carrier_vec_code[code]: "carrier_vec n = Collect_set (\<lambda> v. dim_vec v = n)"
  unfolding carrier_vec_def by auto

end


theory CJ_DDL_Tests imports CJ_DDL           (* Christoph Benzmüller, Ali Farjami, Xavier Parent, 2020  *)
begin (* Some Tests on the Meta-Theory of DDL*)
lemma True nitpick [satisfy,user_axioms,expect=genuine] oops  (* Consistency confirmed by Nitpick *)

lemma MP: "\<lbrakk>\<lfloor>A\<rfloor>; \<lfloor>A \<^bold>\<rightarrow> B\<rfloor>\<rbrakk> \<Longrightarrow> \<lfloor>B\<rfloor>" by simp
lemma Nec: "\<lfloor>A\<rfloor> \<Longrightarrow> \<lfloor>\<^bold>\<box>A\<rfloor>" by simp
lemma Neca: "\<lfloor>A\<rfloor> \<Longrightarrow> \<lfloor>\<^bold>\<box>\<^sub>aA\<rfloor>"  by simp
lemma Necp: "\<lfloor>A\<rfloor> \<Longrightarrow> \<lfloor>\<^bold>\<box>\<^sub>p A\<rfloor>"  by simp

(* "\<^bold>\<box>" is an S5 modality *)
lemma C_1_refl: "\<lfloor>\<^bold>\<box>A \<^bold>\<rightarrow> A\<rfloor>" by simp
lemma C_1_trans: "\<lfloor>\<^bold>\<box>A \<^bold>\<rightarrow> (\<^bold>\<box>(\<^bold>\<box>A))\<rfloor>"  by simp
lemma C_1_sym: "\<lfloor>A \<^bold>\<rightarrow> (\<^bold>\<box>(\<^bold>\<diamond>A))\<rfloor>"  by simp

(* "\<^bold>\<box>\<^sub>p" is an KT modality *)
lemma C_9_p_refl: "\<lfloor>\<^bold>\<box>\<^sub>pA \<^bold>\<rightarrow> A\<rfloor>"  by (simp add: ax_4b)
lemma "\<lfloor>\<^bold>\<box>\<^sub>pA \<^bold>\<rightarrow> (\<^bold>\<box>\<^sub>p(\<^bold>\<box>\<^sub>pA))\<rfloor>" nitpick [user_axioms] oops (* countermodel *)
lemma "\<lfloor>A \<^bold>\<rightarrow> (\<^bold>\<box>\<^sub>p(\<^bold>\<diamond>\<^sub>pA))\<rfloor>"   nitpick [user_axioms] oops (* countermodel *)

(* "\<^bold>\<box>\<^sub>a" is an KD modality *)
lemma C_10_a_serial: "\<lfloor>\<^bold>\<box>\<^sub>aA \<^bold>\<rightarrow> \<^bold>\<diamond>\<^sub>aA\<rfloor>"  by (simp add: ax_3a)
lemma "\<lfloor>\<^bold>\<box>\<^sub>aA \<^bold>\<rightarrow> A\<rfloor>" nitpick [user_axioms] oops (* countermodel *)
lemma "\<lfloor>\<^bold>\<box>\<^sub>aA \<^bold>\<rightarrow> (\<^bold>\<box>\<^sub>a(\<^bold>\<box>\<^sub>aA))\<rfloor>" nitpick [user_axioms] oops (* countermodel *)
lemma "\<lfloor>A \<^bold>\<rightarrow> (\<^bold>\<box>\<^sub>a(\<^bold>\<diamond>\<^sub>aA))\<rfloor>" nitpick [user_axioms] oops (* countermodel *)

(* Relationship between "\<^bold>\<box>,\<^bold>\<box>\<^sub>a,\<^bold>\<box>\<^sub>p" *)
lemma C_11: "\<lfloor>\<^bold>\<box>A \<^bold>\<rightarrow> \<^bold>\<box>\<^sub>pA\<rfloor>" sledgehammer by simp
lemma C_12: "\<lfloor>\<^bold>\<box>\<^sub>pA \<^bold>\<rightarrow> \<^bold>\<box>\<^sub>aA\<rfloor>"  using ax_4a by auto

(* Observation II-2-1 *)
lemma ax_5b': "ob X Y \<longleftrightarrow> ob X (\<lambda>z. X z \<and> Y z)" by (metis (no_types, lifting) ax_5b)
lemma ax_5b'': "ob X Y \<longleftrightarrow> ob X (\<lambda>z. Y z \<and> X z)" by (metis (no_types, lifting) ax_5b)

(* Characterisation of "\<^bold>O" *)
lemma C_2: "\<lfloor>\<^bold>O\<^bold>\<langle>A\<^bold>|B\<^bold>\<rangle> \<^bold>\<rightarrow> \<^bold>\<diamond>(B \<^bold>\<and> A)\<rfloor>"  by (metis ax_5a ax_5b)
lemma C_3: "\<lfloor>(\<^bold>\<diamond>(A \<^bold>\<and> B \<^bold>\<and> C) \<^bold>\<and> \<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle> \<^bold>\<and> \<^bold>O\<^bold>\<langle>C\<^bold>|A\<^bold>\<rangle> ) \<^bold>\<rightarrow> \<^bold>O\<^bold>\<langle>(B \<^bold>\<and> C)\<^bold>|A\<^bold>\<rangle>\<rfloor>" using ax_5c by auto
lemma C_4: "\<lfloor>(\<^bold>\<box>(A \<^bold>\<rightarrow> B) \<^bold>\<and> (\<^bold>\<diamond>(A \<^bold>\<and> C)) \<^bold>\<and> \<^bold>O\<^bold>\<langle>C\<^bold>|B\<^bold>\<rangle>) \<^bold>\<rightarrow> \<^bold>O\<^bold>\<langle>C\<^bold>|A\<^bold>\<rangle>\<rfloor>"   using ax_5e by blast
lemma C_5: "\<lfloor>\<^bold>\<box>(A \<^bold>\<leftrightarrow> B) \<^bold>\<rightarrow> (\<^bold>O\<^bold>\<langle>C\<^bold>|A\<^bold>\<rangle> \<^bold>\<leftrightarrow> \<^bold>O\<^bold>\<langle>C\<^bold>|B\<^bold>\<rangle>)\<rfloor>"  by presburger
lemma C_6: "\<lfloor>\<^bold>\<box>(C \<^bold>\<rightarrow> (A \<^bold>\<leftrightarrow> B)) \<^bold>\<rightarrow> (\<^bold>O\<^bold>\<langle>A\<^bold>|C\<^bold>\<rangle> \<^bold>\<leftrightarrow> \<^bold>O\<^bold>\<langle>B\<^bold>|C\<^bold>\<rangle>)\<rfloor>"  by (smt ax_5b)
lemma C_7: "\<lfloor>\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle> \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle>)\<rfloor>"  by blast
lemma C_8: "\<lfloor>\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle> \<^bold>\<rightarrow> \<^bold>O\<^bold>\<langle>(A \<^bold>\<rightarrow> B)\<^bold>|\<^bold>\<top>\<^bold>\<rangle>\<rfloor>"
 proof -
  have  "\<forall>X Y Z. (ob X Y \<and> (\<forall>w. X w  \<longrightarrow> Z w)) \<longrightarrow> ob Z (\<lambda>w. (Z w \<and> \<not>X w) \<or> Y w)" by  (smt ax_5d  ax_5b ax_5b'')
  thus ?thesis  using ax_5b by fastforce qed

(* Relationship between "\<^bold>O\<^sub>a,\<^bold>O\<^sub>p,\<^bold>\<box>\<^sub>a,\<^bold>\<box>\<^sub>p" *)
lemma C_13_a: "\<lfloor>\<^bold>\<box>\<^sub>aA \<^bold>\<rightarrow> (\<^bold>\<not>\<^bold>O\<^sub>aA \<^bold>\<and> \<^bold>\<not>\<^bold>O\<^sub>a(\<^bold>\<not>A))\<rfloor>"  by (metis (full_types) ax_5a ax_5b)
lemma C_13_b: "\<lfloor>\<^bold>\<box>\<^sub>pA \<^bold>\<rightarrow> (\<^bold>\<not>\<^bold>O\<^sub>pA \<^bold>\<and> \<^bold>\<not>\<^bold>O\<^sub>p(\<^bold>\<not>A))\<rfloor>"   by (metis (full_types) ax_5a ax_5b)
lemma C_14_a: "\<lfloor>\<^bold>\<box>\<^sub>a(A \<^bold>\<leftrightarrow> B) \<^bold>\<rightarrow> (\<^bold>O\<^sub>aA \<^bold>\<leftrightarrow> \<^bold>O\<^sub>aB)\<rfloor>"  by (metis ax_5b)
lemma C_14_b: "\<lfloor>\<^bold>\<box>\<^sub>p(A \<^bold>\<leftrightarrow> B) \<^bold>\<rightarrow> (\<^bold>O\<^sub>pA \<^bold>\<leftrightarrow> \<^bold>O\<^sub>pB)\<rfloor>"  by (metis ax_5b)

(* Relationship between "\<^bold>O\<^sub>,\<^bold>O\<^sub>a,\<^bold>O\<^sub>p,\<^bold>\<box>\<^sub>a,\<^bold>\<box>\<^sub>p" *)
lemma C_15_a: "\<lfloor>(\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle> \<^bold>\<and> \<^bold>\<box>\<^sub>aA \<^bold>\<and> \<^bold>\<diamond>\<^sub>aB \<^bold>\<and> \<^bold>\<diamond>\<^sub>a(\<^bold>\<not>B)) \<^bold>\<rightarrow> \<^bold>O\<^sub>aB\<rfloor>"  using ax_5e by blast
lemma C_15_b: "\<lfloor>(\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle> \<^bold>\<and> \<^bold>\<box>\<^sub>pA \<^bold>\<and> \<^bold>\<diamond>\<^sub>pB \<^bold>\<and> \<^bold>\<diamond>\<^sub>p(\<^bold>\<not>B)) \<^bold>\<rightarrow> \<^bold>O\<^sub>pB\<rfloor>"  using ax_5e by blast

(* Soundness and consistency *)
lemma II_3_1: "((\<lfloor>\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle>\<rfloor>) \<and> (\<exists>x. Z(x) \<and> A(x) \<and> B(x))) \<longrightarrow> ob(Z)(A \<^bold>\<rightarrow> B)"
  proof
    assume "(\<lfloor>\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle>\<rfloor>) \<and> (\<exists>x. Z(x) \<and> A(x) \<and> B(x))"
     hence "ob (\<lambda>z. A z \<and> Z z) (\<lambda>z. A z \<and> Z z \<and> B z)" using ax_5e ax_5b  ax_5b' ax_5d by smt
     hence "ob (\<lambda>z. Z z \<and> A z) (\<lambda>z. Z z \<and> A z \<and> B z)" using ax_5e ax_5b  ax_5b' ax_5d by smt
     hence "ob Z (\<lambda>w. (Z w \<and> \<not>(Z w \<and> A w)) \<or> (Z w \<and> A w \<and> B w))" by (metis (mono_tags) ax_5d)
     from this show  L19: "ob(Z)(A \<^bold>\<rightarrow> B)" by (smt ax_5b)  qed

(* Some theorems and derived (proof) rules *)
lemma II_4_1: "\<lfloor>\<^bold>\<box>(A \<^bold>\<leftrightarrow> B) \<^bold>\<rightarrow> (C(A) \<^bold>\<leftrightarrow> C(B))\<rfloor>"  using ext by blast
lemma obs_II_4_1_a  : "\<lfloor>A \<^bold>\<leftrightarrow> B\<rfloor> \<Longrightarrow> \<lfloor>C(A) \<^bold>\<leftrightarrow> C(B)\<rfloor>"  using ext by blast
lemma obs_II_4_1_b  : "\<lfloor>A \<^bold>\<leftrightarrow> B\<rfloor> \<Longrightarrow> \<lfloor>(\<^bold>\<diamond>(A \<^bold>\<and> C) \<^bold>\<and> \<^bold>O\<^bold>\<langle>C\<^bold>|B\<^bold>\<rangle>) \<^bold>\<rightarrow> \<^bold>O\<^bold>\<langle>C\<^bold>|A\<^bold>\<rangle>\<rfloor>"  using ax_5e by blast
lemma obs_II_4_1_c_1: "\<lfloor>\<^bold>\<diamond>(\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle>) \<^bold>\<rightarrow> \<^bold>\<diamond>(\<^bold>\<box>(\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle>))\<rfloor>"  by blast
lemma obs_II_4_1_c_2: "\<lfloor>\<^bold>\<diamond>(\<^bold>\<box>(\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle>)) \<^bold>\<rightarrow> \<^bold>\<diamond>(\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle>)\<rfloor>"  by auto
lemma obs_II_4_1_c_3: "\<lfloor>\<^bold>\<diamond>(\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle>) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle>)\<rfloor>"  by blast
lemma obs_II_4_1_c_4: "\<lfloor>\<^bold>\<diamond>(\<^bold>\<not>(\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle>)) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<not>(\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle>))\<rfloor>"  by blast
lemma res_II_4_1_a_1: "\<lfloor>\<^bold>\<not>(\<^bold>O\<^bold>\<langle>\<^bold>\<bottom>\<^bold>|A\<^bold>\<rangle>)\<rfloor>"  by (simp add: ax_5a)
lemma res_II_4_1_a_2: "\<lfloor>(\<^bold>\<diamond>\<^sub>p(A \<^bold>\<and> B \<^bold>\<and> C) \<^bold>\<and> \<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle> \<^bold>\<and> \<^bold>O\<^bold>\<langle>C\<^bold>|A\<^bold>\<rangle>) \<^bold>\<rightarrow> \<^bold>O\<^bold>\<langle>(B \<^bold>\<and> C)\<^bold>|A\<^bold>\<rangle>\<rfloor>"  using C_3  by auto
lemma res_II_4_1_a_3: "\<lfloor>\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle> \<^bold>\<rightarrow> \<^bold>O\<^bold>\<langle>B\<^bold>|(A \<^bold>\<and> B)\<^bold>\<rangle>\<rfloor>"  by (smt ax_5a ax_5b ax_5e)
lemma res_II_4_1_a_4: "\<lfloor>\<^bold>\<diamond>\<^sub>p(\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle>) \<^bold>\<rightarrow> \<^bold>\<box>\<^sub>p(\<^bold>O\<^bold>\<langle>B\<^bold>|(A \<^bold>\<and> B)\<^bold>\<rangle>)\<rfloor>"  by (smt ax_5a ax_5b ax_5e)
lemma res_II_4_1_a_5: "\<lfloor>(\<^bold>\<diamond>\<^sub>p(A \<^bold>\<and> B \<^bold>\<and> C) \<^bold>\<and> \<^bold>O\<^bold>\<langle>C\<^bold>|A\<^bold>\<rangle>) \<^bold>\<rightarrow> \<^bold>O\<^bold>\<langle>C\<^bold>|(A \<^bold>\<and> B)\<^bold>\<rangle>\<rfloor>"  by (smt ax_5a ax_5b ax_5e)
lemma res_II_4_1_b_1:  "\<lfloor>A \<^bold>\<leftrightarrow> B\<rfloor> \<Longrightarrow> \<lfloor>\<^bold>O\<^bold>\<langle>C\<^bold>|A\<^bold>\<rangle> \<^bold>\<leftrightarrow> \<^bold>O\<^bold>\<langle>C\<^bold>|B\<^bold>\<rangle>\<rfloor>"  by (smt ax_5a ax_5b ax_5e)
lemma res_II_4_1_b_2:  "\<lfloor>C \<^bold>\<rightarrow> (A \<^bold>\<leftrightarrow> B)\<rfloor> \<Longrightarrow> \<lfloor>\<^bold>O\<^bold>\<langle>A\<^bold>|C\<^bold>\<rangle> \<^bold>\<leftrightarrow> \<^bold>O\<^bold>\<langle>B\<^bold>|C\<^bold>\<rangle>\<rfloor>"  by (smt ax_5b)
lemma obs_II_4_2_1: "\<lfloor>(\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle> \<^bold>\<and> \<^bold>\<diamond>\<^sub>a(A \<^bold>\<and> B) \<^bold>\<and> \<^bold>\<diamond>\<^sub>a(A \<^bold>\<and> \<^bold>\<not>B)) \<^bold>\<rightarrow> (\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle> \<^bold>\<and> \<^bold>\<diamond>\<^sub>a(A \<^bold>\<rightarrow> B) \<^bold>\<and> \<^bold>\<diamond>\<^sub>a(\<^bold>\<not>(A \<^bold>\<rightarrow> B)))\<rfloor>"  by blast
lemma obs_II_4_2_2: "\<lfloor>\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle> \<^bold>\<rightarrow> \<^bold>O\<^bold>\<langle>(A \<^bold>\<rightarrow> B)\<^bold>|\<^bold>\<top>\<^bold>\<rangle>\<rfloor>" by (simp add: C_8)
lemma obs_II_4_2_3: "\<lfloor>(\<^bold>O\<^bold>\<langle>(A \<^bold>\<rightarrow> B)\<^bold>|\<^bold>\<top>\<^bold>\<rangle> \<^bold>\<and> \<^bold>\<box>\<^sub>a\<^bold>\<top> \<^bold>\<and> \<^bold>\<diamond>\<^sub>a(A \<^bold>\<rightarrow> B) \<^bold>\<and> \<^bold>\<diamond>\<^sub>a(\<^bold>\<not>(A \<^bold>\<rightarrow> B))) \<^bold>\<rightarrow> \<^bold>O\<^sub>a(A \<^bold>\<rightarrow> B)\<rfloor>"  by (smt ax_5e)
lemma obs_II_4_2_4: "\<lfloor>\<^bold>\<box>\<^sub>a\<^bold>\<top>\<rfloor>"  by simp
lemma obs_II_4_2_5: "\<lfloor>(\<^bold>O\<^bold>\<langle>(A \<^bold>\<rightarrow> B)\<^bold>|\<^bold>\<top>\<^bold>\<rangle> \<^bold>\<and> \<^bold>\<diamond>\<^sub>a(A \<^bold>\<rightarrow> B) \<^bold>\<and> \<^bold>\<diamond>\<^sub>a(\<^bold>\<not>(A \<^bold>\<rightarrow> B))) \<^bold>\<rightarrow> \<^bold>O\<^sub>a(A \<^bold>\<rightarrow> B)\<rfloor>"  by (smt ax_5e)
lemma obs_II_4_2_6: "\<lfloor>(\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle> \<^bold>\<and> \<^bold>\<diamond>\<^sub>a(A \<^bold>\<and> B) \<^bold>\<and> \<^bold>\<diamond>\<^sub>a(A \<^bold>\<and> \<^bold>\<not>B)) \<^bold>\<rightarrow> \<^bold>O\<^sub>a(A \<^bold>\<rightarrow> B)\<rfloor>"   by (simp add: II_3_1)
lemma obs_II_4_2_6_p: "\<lfloor>(\<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle> \<^bold>\<and> \<^bold>\<diamond>\<^sub>p(A \<^bold>\<and> B) \<^bold>\<and> \<^bold>\<diamond>\<^sub>p(A \<^bold>\<and> \<^bold>\<not>B)) \<^bold>\<rightarrow> \<^bold>O\<^sub>p(A \<^bold>\<rightarrow> B)\<rfloor>"   by (simp add: II_3_1)

lemma Oa_C: "\<lfloor>\<^bold>\<diamond>\<^sub>a(A \<^bold>\<and> B) \<^bold>\<and> \<^bold>O\<^sub>aA \<^bold>\<and> \<^bold>O\<^sub>aB \<^bold>\<rightarrow>  \<^bold>O\<^sub>a(A \<^bold>\<and> B)\<rfloor>" using ax_5c by auto
lemma Op_C: "\<lfloor>\<^bold>\<diamond>\<^sub>p(A \<^bold>\<and> B) \<^bold>\<and> \<^bold>O\<^sub>pA \<^bold>\<and> \<^bold>O\<^sub>pB \<^bold>\<rightarrow>  \<^bold>O\<^sub>p(A \<^bold>\<and> B)\<rfloor>" using ax_5c by auto
lemma Oa_DD: "\<lfloor>(\<^bold>O\<^sub>aA \<^bold>\<and> \<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle> \<^bold>\<and> \<^bold>\<diamond>\<^sub>a(A \<^bold>\<and> B)) \<^bold>\<rightarrow> \<^bold>O\<^sub>a(A \<^bold>\<and> B)\<rfloor>" using ax_5b ax_5c obs_II_4_2_6 by smt
declare [[smt_timeout=300]]
lemma Op_DD: "\<lfloor>(\<^bold>O\<^sub>pA \<^bold>\<and> \<^bold>O\<^bold>\<langle>B\<^bold>|A\<^bold>\<rangle> \<^bold>\<and> \<^bold>\<diamond>\<^sub>p(A \<^bold>\<and> B)) \<^bold>\<rightarrow> \<^bold>O\<^sub>p(A \<^bold>\<and> B)\<rfloor>" using ax_5b ax_5c obs_II_4_2_6_p by smt
end


theory plus
imports Main

begin

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

lemma lemma_ag [thy_expl]: "plus x2 Z = x2"
by (hipster_induct_schemes plus.simps)

lemma lemma_ah [thy_expl]: "plus (plus x2 y2) z2 = plus x2 (plus y2 z2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ai [thy_expl]: "plus x2 (S y2) = S (plus x2 y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_aj [thy_expl]: "plus x2 (plus y2 x2) = plus y2 (plus x2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ak [thy_expl]: "plus x2 (plus y2 y2) = plus y2 (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_al [thy_expl]: "plus x2 (S y2) = S (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_am [thy_expl]: "plus (plus x2 y2) x2 = plus x2 (plus x2 y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_bg [thy_expl]: "plus x2 y2 = plus y2 x2"
by (hipster_induct_schemes plus.simps)
lemma lemma_an [thy_expl]: "plus (S x2) y2 = S (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ao [thy_expl]: "plus (plus x3 y3) (plus x3 z3) =
plus (plus x3 z3) (plus x3 y3)"
by (hipster_induct_schemes )

lemma lemma_ap [thy_expl]: "plus (plus x2 y2) (plus z2 y2) =
plus (plus x2 z2) (plus y2 y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_aq [thy_expl]: "plus (plus x3 y3) (plus z3 z3) =
plus (plus x3 z3) (plus z3 y3)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ar [thy_expl]: "plus (plus x2 y2) (S z2) =
plus (plus x2 z2) (S y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_as [thy_expl]: "plus (plus x2 y2) (plus z2 x2) =
plus (plus z2 x2) (plus x2 y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_at [thy_expl]: "plus (plus x2 y2) (plus z2 y2) =
plus (plus z2 x2) (plus y2 y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_au [thy_expl]: "plus (plus x3 y3) (plus z3 z3) =
plus (plus z3 x3) (plus z3 y3)"
by (hipster_induct_schemes plus.simps)

lemma lemma_av [thy_expl]: "plus (plus x2 y2) (S z2) =
plus (plus z2 x2) (S y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_aw [thy_expl]: "plus (plus x2 x2) (plus y2 z2) =
plus (plus x2 y2) (plus x2 z2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ax [thy_expl]: "plus (plus x2 x2) (plus y2 z2) =
plus (plus y2 x2) (plus x2 z2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ay [thy_expl]: "plus (S x2) (plus y2 z2) =
plus (plus y2 x2) (S z2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_az [thy_expl]: "plus (S x2) (plus y2 z2) =
plus (plus y2 z2) (S x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ba [thy_expl]: "plus (plus x2 x2) (plus y2 y2) =
plus (plus x2 y2) (plus x2 y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_bb [thy_expl]: "plus (plus x2 x2) (S y2) =
plus (plus x2 y2) (S x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_bc [thy_expl]: "plus (plus x2 x2) (plus y2 y2) =
plus (plus y2 x2) (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_bd [thy_expl]: "plus (S x2) (plus x2 y2) =
plus (plus x2 y2) (S x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_be [thy_expl]: "plus (S x2) (plus y2 x2) =
plus (plus y2 x2) (S x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_bf [thy_expl]: "plus (S x2) (S y2) = plus (S y2) (S x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_bg [thy_expl]: "plus x2 y2 = plus y2 x2"
by (hipster_induct_schemes plus.simps)

lemma lemma_bh [thy_expl]: "plus x2 (plus y2 z2) = plus y2 (plus x2 z2)"
by (hipster_induct_schemes plus.simps)

end


theory Bellman_Ford
  imports "../DP_Lifting" "../DP_CRelVS" "../DP_Proof"
begin

consts n :: nat
consts W :: "nat \<Rightarrow> nat \<Rightarrow> int"
term 0 (**)

  (*
fun bf :: "nat\<times>nat \<Rightarrow> int" where
  "bf (0,j) = W 0 j"
| "bf (Suc k, j) = fold min [bf (k, i) + W i j. i \<leftarrow> [0..<n]] (bf (k, j))"
term 0 (**)
*)

fun bf :: "nat\<times>nat \<Rightarrow> int" where
  "bf (0, j) = W 0 j"
| "bf (Suc k, j) =
    fold
      (min)
      (map
          (\<lambda>i. plus (W i j) (bf (k, i)))
          (upt 0 n))
      (bf (k, j))"
thm bf.simps
thm bf.induct
term 0 (**)

ML_file \<open>../scratch/Transform.ML\<close>
local_setup \<open>
lift_fun NONE
\<close>
print_theorems

interpretation bf: dp_consistency bf .

lemma "bf.consistentDP bf\<^sub>T"
  by (dp_match induct: bf\<^sub>T.crel_vs_induct simp: bf.simps simp\<^sub>T: bf\<^sub>T.simps)
end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_NMSortTDIsSort
  imports "../../Test_Base"
begin

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

fun take :: "int => 'a list => 'a list" where
  "take x y =
   (if x <= 0 then nil2 else
      (case y of
         nil2 => nil2
         | cons2 z xs => cons2 z (take (x - 1) xs)))"

(*fun did not finish the proof*)
function nmsorttdhalf1 :: "int => int" where
  "nmsorttdhalf1 x =
   (if (x = 1) then 0 else
      (if (x = 0) then 0 else 1 + (nmsorttdhalf1 (x - 2))))"
  by pat_completeness auto

fun lmerge :: "int list => int list => int list" where
  "lmerge (nil2) y = y"
| "lmerge (cons2 z x2) (nil2) = cons2 z x2"
| "lmerge (cons2 z x2) (cons2 x3 x4) =
     (if z <= x3 then cons2 z (lmerge x2 (cons2 x3 x4)) else
        cons2 x3 (lmerge (cons2 z x2) x4))"

fun length :: "'a list => int" where
  "length (nil2) = 0"
| "length (cons2 y l) = 1 + (length l)"

fun insert :: "int => int list => int list" where
  "insert x (nil2) = cons2 x (nil2)"
| "insert x (cons2 z xs) =
     (if x <= z then cons2 x (cons2 z xs) else cons2 z (insert x xs))"

fun isort :: "int list => int list" where
  "isort (nil2) = nil2"
| "isort (cons2 y xs) = insert y (isort xs)"

fun drop :: "int => 'a list => 'a list" where
  "drop x y =
   (if x <= 0 then y else
      (case y of
         nil2 => nil2
         | cons2 z xs1 => drop (x - 1) xs1))"

(*fun did not finish the proof*)
function nmsorttd :: "int list => int list" where
  "nmsorttd (nil2) = nil2"
| "nmsorttd (cons2 y (nil2)) = cons2 y (nil2)"
| "nmsorttd (cons2 y (cons2 x2 x3)) =
     (let k :: int = nmsorttdhalf1 (length (cons2 y (cons2 x2 x3)))
     in lmerge
          (nmsorttd (take k (cons2 y (cons2 x2 x3))))
          (nmsorttd (drop k (cons2 y (cons2 x2 x3)))))"
  by pat_completeness auto

theorem property0 :
  "((nmsorttd xs) = (isort xs))"
  oops

end


theory min
imports Main
        "../data/Natu"
        "$HIPSTER_HOME/IsaHipster"

begin

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

lemma lemma_a [thy_expl]: "min2 x x = x"
by (hipster_induct_schemes min2.simps)

lemma lemma_aa [thy_expl]: "min2 x Z = Z"
by (hipster_induct_schemes min2.simps)

lemma lemma_ab [thy_expl]: "min2 x (min2 x y) = min2 x y"
by (hipster_induct_schemes min2.simps)

lemma lemma_ac [thy_expl]: "min2 x (min2 y x) = min2 y x"
by (hipster_induct_schemes min2.simps)

lemma lemma_ad [thy_expl]: "min2 (min2 x y) x = min2 x y"
by (hipster_induct_schemes min2.simps)

lemma lemma_ae []: "min2 (S x) y = min2 y (S x)"
by (hipster_induct_schemes min2.simps)

lemma lemma_af [thy_expl]: "min2 x y = min2 y x"
by (hipster_induct_schemes min2.simps)

end


theory Simplificacion
imports Main
begin

section {* El método de simplificación *}

section {* Seguimiento de la simplificación  *}

lemma "rev [x] = [x]"
using [[simp_trace]]
apply simp
done

text {* El resultado de la traza es
     proof (prove)
     goal:
     No subgoals!
     [1]SIMPLIFIER INVOKED ON THE FOLLOWING TERM:
     rev [x] = [x]
     [1]Applying instance of rewrite rule "??.unknown":
     rev (?x1 # ?xs1) \<equiv> rev ?xs1 @ [?x1]
     [1]Rewriting:
     rev [x] \<equiv> rev [] @ [x]
     [1]Applying instance of rewrite rule "??.unknown":
     rev [] \<equiv> []
     [1]Rewriting:
     rev [] \<equiv> []
     [1]Applying instance of rewrite rule "List.append.append_Nil":
     [] @ ?y \<equiv> ?y
     [1]Rewriting:
     [] @ [x] \<equiv> [x]
     [1]Applying instance of rewrite rule "HOL.simp_thms_6":
     ?x1 = ?x1 \<equiv> True
     [1]Rewriting:
     [x] = [x] \<equiv> True

  El significado de la traza es
       (rev [x]      = [x])
     = (rev [] @ [x] = [x])     [por "rev (x1 # xs1) = rev xs1 @ [x1]"]
     = ([]     @ [x] = [x])     [por "rev [] = []"]
     = ([x]          = [x])     [por List.append.append_Nil]
     = True                     [por HOL.simp_thms_6]
*}

text{* Ejemplo de simplificación no condicional *}
lemma "(ys @ [] = []) =
       (ys = [])"
apply simp
done

text{* Ejemplo de simplificación usando supuestos *}
lemma "\<lbrakk> xs @ zs = ys @ xs
       ; [] @ xs = [] @ [] \<rbrakk>
       \<Longrightarrow> ys = zs"
apply simp
done

lemma
  "\<lbrakk>  0 + n           = n
   ; (Suc m) + n     = Suc (m + n)
   ; (Suc m \<le> Suc n) = (m \<le> n)
   ; (0 \<le> m)         = True \<rbrakk>
   \<Longrightarrow> 0 + Suc 0 \<le> (Suc 0) + x"
apply simp
done

text {* Ejemplo de simplificación con reglas auxiliares *}
lemma "(a+b)*(a-b) = a*a - b*(b::int)"
apply (simp add: algebra_simps)
done

text {* Las reglas de algebra_simps son
  (a + b) + c = a + (b + c)
  a + b = b + a
  b + (a + c) = a + (b + c)
  (a * b) * c = a * (b * c)
  a * b = b * a
  b * (a * c) = a * (b * c)
  a - (b - c) = a - (b + c)
  a + (b - c) = a + b - c
  (a - b = c) = (a = c + b)
  (a = c - b) = (a + b = c)
  a - (b - c) = (a + c) - b
  (a - b) + c = (a + c) - b
  (a - b < c) = (a < c + b)
  (a < c - b) = (a + b < c)
  (a - b \<le> c) = (a \<le> c + b)
  (a \<le> c - b) = (a + b \<le> c)
  (a + b) * c = a * c + b * c
  a * (b + c) = a * b + a * c
  a * (b - c) = a * b - a * c
  (b - c) * a = b * a - c * a
  a * (b - c) = a * b - a * c
  (a - b) * c = a * c - b * c
*}
thm algebra_simps [no_vars]

text {* Declaración de reglas como de simplificación *}
declare algebra_simps [simp]

text {* Ejemplo de simplificación con declaradas como simplificadores *}
lemma "(a+b)*(a-b) = a*a - b*(b::int)"
apply simp
done

section {* Reescritura condicional *}

lemma aux1: "P 0"
sorry

lemma aux2: "P x \<Longrightarrow> f x = g x"
sorry

lemma "f 0 \<Longrightarrow> g 0"
apply (simp add: aux1 aux2)
done

lemma "f 1 \<Longrightarrow> g 1"
apply (simp add: aux1 aux2)
oops

section {* Reescritura con definiciones *}

text {* Ejemplo de definición: (cuadrado x) es el cuadrado de x. Por
  ejemplo,
     cuadrado (Suc (Suc 0)) = Suc (Suc (Suc (Suc 0)))
*}
definition cuadrado :: "nat \<Rightarrow> nat"
where
  "cuadrado n = n*n"

value "cuadrado (Suc (Suc 0))"

text {* Ejemplo de lema con reescritura usando definición: *}
lemma "cuadrado (Suc (Suc 0)) = Suc (Suc (Suc (Suc 0)))"
apply (simp add: cuadrado_def)
done

text {* Ejemplo de lema con reescritura usando definición: *}
lemma "cuadrado(n*n) = cuadrado(n)*cuadrado(n)"
apply (simp add: cuadrado_def)
done

subsection{* Distinción de casos *}

text {* Ejemplos de distinción automática de casos con if *}
lemma "P (if A then s else t)
       = ((A \<longrightarrow> P(s)) \<and> (\<not>A \<longrightarrow> P(t)))"
apply simp
done

lemma "(if A then B else False)
       = (A \<and> B)"
apply simp
done

lemma "(if A then B else C)
       = ((A \<longrightarrow> B) \<and> (\<not>A \<longrightarrow> C))"
apply simp
done

text {* Ejemplos de distinción no automática de casos con case *}

lemma "P (case e of 0 \<Rightarrow> a | Suc n \<Rightarrow> b)
       = ((e = 0 \<longrightarrow> P(a)) \<and> (\<forall> n. e = Suc n \<longrightarrow> P(b)))"
apply (simp split: nat.split)
done

lemma "P (case xs of [] \<Rightarrow> a | (y#ys) \<Rightarrow> b)
       = ((xs = [] \<longrightarrow> P a ) \<and> ((\<exists>y ys. xs = y # ys) \<longrightarrow> P b))"
apply (simp split: list.split)
done

lemma "1 \<le> (case ns of [] \<Rightarrow> 1 | n#_ \<Rightarrow> Suc n)"
apply (simp split: list.split)
done

lemma "P (case t of (x,y) \<Rightarrow> f x y)
       = (\<forall> x y. t = (x,y) \<longrightarrow> P (f x y))"
apply (simp split: prod.split)
done

text {* Ejemplos de distinción no automática de casos con let *}

lemma "P (let (x,y) = t in f x y)
       = (\<forall> x y. t = (x,y) \<longrightarrow> P (f x y))"
apply (simp split: prod.split)
done

section {* Simplificación en aritmética lineal *}

text {* Ejemplo de simplificación con las reglas de la aritmética
  lineal. *}
lemma "\<lbrakk> (x::nat) \<le> y+z
       ; z+x < y \<rbrakk>
       \<Longrightarrow> x < y"
apply simp
done

end


(* Author: Tobias Nipkow *)

section "Splay Tree Implementation of Maps"

theory Splay_Map
imports
  Splay_Tree
  "HOL-Data_Structures.Map_Specs"
begin

function splay :: "'a::linorder \<Rightarrow> ('a*'b) tree \<Rightarrow> ('a*'b) tree" where
"splay x Leaf = Leaf" |
"x = fst a \<Longrightarrow> splay x (Node t1 a t2) = Node t1 a t2" |
"x = fst a \<Longrightarrow> x < fst b \<Longrightarrow> splay x (Node (Node t1 a t2) b t3) = Node t1 a (Node t2 b t3)" |
"x < fst a \<Longrightarrow> splay x (Node Leaf a t) = Node Leaf a t" |
"x < fst a \<Longrightarrow> x < fst b \<Longrightarrow> splay x (Node (Node Leaf a t1) b t2) = Node Leaf a (Node t1 b t2)" |
"x < fst a \<Longrightarrow> x < fst b \<Longrightarrow> t1 \<noteq> Leaf \<Longrightarrow>
 splay x (Node (Node t1 a t2) b t3) =
 (case splay x t1 of Node t11 y t12 \<Rightarrow> Node t11 y (Node t12 a (Node t2 b t3)))" |
"fst a < x \<Longrightarrow> x < fst b \<Longrightarrow> splay x (Node (Node t1 a Leaf) b t2) = Node t1 a (Node Leaf b t2)" |
"fst a < x \<Longrightarrow> x < fst b \<Longrightarrow> t2 \<noteq> Leaf \<Longrightarrow>
 splay x (Node (Node t1 a t2) b t3) =
 (case splay x t2 of Node t21 y t22 \<Rightarrow> Node (Node t1 a t21) y (Node t22 b t3))" |
"fst a < x \<Longrightarrow> x = fst b \<Longrightarrow> splay x (Node t1 a (Node t2 b t3)) = Node (Node t1 a t2) b t3" |
"fst a < x \<Longrightarrow> splay x (Node t a Leaf) = Node t a Leaf" |
"fst a < x \<Longrightarrow> x < fst b \<Longrightarrow>  t2 \<noteq> Leaf \<Longrightarrow>
 splay x (Node t1 a (Node t2 b t3)) =
 (case splay x t2 of Node t21 y t22 \<Rightarrow> Node (Node t1 a t21) y (Node t22 b t3))" |
"fst a < x \<Longrightarrow> x < fst b \<Longrightarrow> splay x (Node t1 a (Node Leaf b t2)) = Node (Node t1 a Leaf) b t2" |
"fst a < x \<Longrightarrow> fst b < x \<Longrightarrow> splay x (Node t1 a (Node t2 b Leaf)) = Node (Node t1 a t2) b Leaf" |
"fst a < x \<Longrightarrow> fst b < x \<Longrightarrow> t3 \<noteq> Leaf \<Longrightarrow>
 splay x (Node t1 a (Node t2 b t3)) =
 (case splay x t3 of Node t31 y t32 \<Rightarrow> Node (Node (Node t1 a t2) b t31) y t32)"
apply(atomize_elim)
apply(auto)
(* 1 subgoal *)
apply (subst (asm) neq_Leaf_iff)
apply(auto)
apply (metis tree.exhaust surj_pair less_linear)+
done

termination splay
by lexicographic_order

lemma splay_code: "splay (x::_::linorder) t = (case t of Leaf \<Rightarrow> Leaf |
  Node al a ar \<Rightarrow> (case cmp x (fst a) of
    EQ \<Rightarrow> t |
    LT \<Rightarrow> (case al of
      Leaf \<Rightarrow> t |
      Node bl b br \<Rightarrow> (case cmp x (fst b) of
        EQ \<Rightarrow> Node bl b (Node br a ar) |
        LT \<Rightarrow> if bl = Leaf then Node bl b (Node br a ar)
              else case splay x bl of
                Node bll y blr \<Rightarrow> Node bll y (Node blr b (Node br a ar)) |
        GT \<Rightarrow> if br = Leaf then Node bl b (Node br a ar)
              else case splay x br of
                Node brl y brr \<Rightarrow> Node (Node bl b brl) y (Node brr a ar))) |
    GT \<Rightarrow> (case ar of
      Leaf \<Rightarrow> t |
      Node bl b br \<Rightarrow> (case cmp x (fst b) of
        EQ \<Rightarrow> Node (Node al a bl) b br |
        LT \<Rightarrow> if bl = Leaf then Node (Node al a bl) b br
              else case splay x bl of
                Node bll y blr \<Rightarrow> Node (Node al a bll) y (Node blr b br) |
        GT \<Rightarrow> if br=Leaf then Node (Node al a bl) b br
              else case splay x br of
                Node bll y blr \<Rightarrow> Node (Node (Node al a bl) b bll) y blr))))"
by(auto split!: tree.split)

definition lookup :: "('a*'b)tree \<Rightarrow> 'a::linorder \<Rightarrow> 'b option" where "lookup t x =
  (case splay x t of Leaf \<Rightarrow> None | Node _ (a,b) _ \<Rightarrow> if x=a then Some b else None)"

hide_const (open) insert

fun update :: "'a::linorder \<Rightarrow> 'b \<Rightarrow> ('a*'b) tree \<Rightarrow> ('a*'b) tree" where
"update x y t =  (if t = Leaf then Node Leaf (x,y) Leaf
  else case splay x t of
    Node l a r \<Rightarrow> if x = fst a then Node l (x,y) r
      else if x < fst a then Node l (x,y) (Node Leaf a r) else Node (Node l a Leaf) (x,y) r)"

definition delete :: "'a::linorder \<Rightarrow> ('a*'b) tree \<Rightarrow> ('a*'b) tree" where
"delete x t = (if t = Leaf then Leaf
  else case splay x t of Node l a r \<Rightarrow>
    if x = fst a
    then if l = Leaf then r else case splay_max l of Node l' m r' \<Rightarrow> Node l' m r
    else Node l a r)"

subsection "Functional Correctness Proofs"

lemma splay_Leaf_iff: "(splay x t = Leaf) = (t = Leaf)"
by(induction x t rule: splay.induct) (auto split: tree.splits)

subsubsection "Proofs for lookup"

lemma lookup_eq:
  "sorted1(inorder t) \<Longrightarrow> lookup t x = map_of (inorder t) x"
by(auto simp: lookup_def splay_Leaf_iff splay_map_of_inorder split: tree.split)

subsubsection "Proofs for update"

lemma inorder_splay: "inorder(splay x t) = inorder t"
by(induction x t rule: splay.induct)
  (auto simp: neq_Leaf_iff split: tree.split)

lemma sorted_splay:
  "sorted1(inorder t) \<Longrightarrow> splay x t = Node l a r \<Longrightarrow>
  sorted(map fst (inorder l) @ x # map fst (inorder r))"
unfolding inorder_splay[of x t, symmetric]
by(induction x t arbitrary: l a r rule: splay.induct)
  (auto simp: sorted_lems sorted_Cons_le sorted_snoc_le splay_Leaf_iff split: tree.splits)

lemma inorder_update_splay:
  "sorted1(inorder t) \<Longrightarrow> inorder(update x y t) = upd_list x y (inorder t)"
using inorder_splay[of x t, symmetric] sorted_splay[of t x]
by(auto simp: upd_list_simps upd_list_Cons upd_list_snoc neq_Leaf_iff split: tree.split)

subsubsection "Proofs for delete"

lemma inorder_splay_maxD:
  "splay_max t = Node l a r \<Longrightarrow> sorted1(inorder t) \<Longrightarrow>
  inorder l @ [a] = inorder t \<and> r = Leaf"
by(induction t arbitrary: l a r rule: splay_max.induct)
  (auto simp: sorted_lems split: tree.splits if_splits)

lemma inorder_delete_splay:
  "sorted1(inorder t) \<Longrightarrow> inorder(delete x t) = del_list x (inorder t)"
using inorder_splay[of x t, symmetric] sorted_splay[of t x]
by (auto simp: del_list_simps del_list_sorted_app delete_def del_list_notin_Cons inorder_splay_maxD
  split: tree.splits)

subsubsection "Overall Correctness"

interpretation Map_by_Ordered
where empty = empty and lookup = lookup and update = update
and delete = delete and inorder = inorder and inv = "\<lambda>_. True"
proof (standard, goal_cases)
  case 2 thus ?case by(simp add: lookup_eq)
next
  case 3 thus ?case by(simp add: inorder_update_splay del: update.simps)
next
  case 4 thus ?case by(simp add: inorder_delete_splay)
qed (auto simp: empty_def)

end


theory Auto_Proof_Demo
imports Main
begin

section{* Logic and sets *}

lemma "ALL x. EX y. x=y"
by auto

lemma "A \<subseteq> B \<inter> C \<Longrightarrow> A \<subseteq> B \<union> C"
by auto

text{* Note the bounded quantification notation: *}

lemma "\<lbrakk> \<forall>xs \<in> A. \<exists>ys. xs = ys @ ys;  us:A \<rbrakk> \<Longrightarrow> \<exists>n. length us = n+n"
by fastforce

text{*
 Most simple proofs in FOL and set theory are automatic.
 Example: if T is total, A is antisymmetric
 and T is a subset of A, then A is a subset of T.
*}

lemma AT:
  "\<lbrakk> \<forall>x y. T x y \<or> T y x;
     \<forall>x y. A x y \<and> A y x \<longrightarrow> x = y;
     \<forall>x y. T x y \<longrightarrow> A x y \<rbrakk>
   \<Longrightarrow> \<forall>x y. A x y \<longrightarrow> T x y"
by blast

section{* Sledgehammer *}

lemma "R^* \<subseteq> (R \<union> S)^*"
oops

(* Find a suitable P and try sledgehammer: *)

lemma "a # xs = ys @ [a] \<Longrightarrow> P"
oops

section{* Arithmetic *}

lemma "\<forall> (k::nat) > 7. \<exists> i j. k = 3*i + 5*j"
by arith

end


theory prop_77
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun le :: "Nat => Nat => bool" where
  "le (Z) y = True"
  | "le (S z) (Z) = False"
  | "le (S z) (S x2) = le z x2"
  fun sorted :: "Nat list => bool" where
  "sorted (Nil2) = True"
  | "sorted (Cons2 y (Nil2)) = True"
  | "sorted (Cons2 y (Cons2 y2 ys)) =
       (if le y y2 then sorted (Cons2 y2 ys) else False)"
  fun insort :: "Nat => Nat list => Nat list" where
  "insort x (Nil2) = Cons2 x (Nil2)"
  | "insort x (Cons2 z xs) =
       (if le x z then Cons2 x (Cons2 z xs) else Cons2 z (insort x xs))"
  (*hipster le sorted insort *)
(*hipster insort le*)
lemma lemma_a [thy_expl]: "le x2 x2 = True"
by (hipster_induct_schemes le.simps)

lemma lemma_aa [thy_expl]: "le x2 (S x2) = True"
by (hipster_induct_schemes le.simps)

lemma lemma_ab [thy_expl]: "le (S x2) x2 = False"
by (hipster_induct_schemes le.simps)

lemma unknown [thy_expl]: "insort x (insort y z) = insort y (insort x z)"
oops

lemma unknown [thy_expl]: "insort Z (insort x y) = insort x (insort Z y)"
oops

(*hipster_cond le*)
lemma lemma_ac [thy_expl]: "le x2 y2 \<Longrightarrow> le x2 (S y2) = True"
by (hipster_induct_schemes le.simps)

lemma lemma_ad [thy_expl]: "le y2 x2 \<Longrightarrow> le (S x2) y2 = False"
by (hipster_induct_schemes le.simps)

lemma lemma_ae [thy_expl]: "le y x \<and> le x y \<Longrightarrow> x = y"
by (hipster_induct_schemes le.simps Nat.exhaust)

lemma lemma_af [thy_expl]: "le z y \<and> le x z \<Longrightarrow> le x y = True"
by (hipster_induct_schemes le.simps Nat.exhaust)

(*hipster insort le*)
lemma lemma_ag [thy_expl]: "insort Z (insort x2 y2) =
insort x2 (insort Z y2)"
by (hipster_induct_schemes insort.simps le.simps)

(*hipster_cond sorted insort*)
lemma lemma_ah [thy_expl]: "sorted (insort Z x4) = sorted x4"
by (hipster_induct_schemes sorted.simps insort.simps)

lemma unknown [thy_expl]: "insort x (insort y z) = insort y (insort x z)"
oops

lemma unknown [thy_expl]: "sorted (insort x y) = sorted y"
oops

fun nole:: "Nat \<Rightarrow> Nat \<Rightarrow> bool" where
  "nole x y = (\<not> le x y)"

(*hipster_cond nole*)
lemma lemma_ai [thy_expl]: "le (S x2) y2 = nole y2 x2"
by (hipster_induct_schemes nole.simps)

lemma lemma_aj [thy_expl]: "nole x2 y2 \<Longrightarrow> le x2 Z = False"
by (hipster_induct_schemes nole.simps)

lemma lemma_ak [thy_expl]: "sorted y \<Longrightarrow> sorted (insort x y) = True"
apply(induction y arbitrary: x rule: sorted.induct)
apply(simp_all)
apply(metis nole.simps thy_expl)
by(metis (full_types) thy_expl sorted.simps insort.simps nole.simps)

(*
lemma timpano []: "\<not> (le m n) \<Longrightarrow> le n m"
by (hipster_induct_schemes le.simps)
lemma tt []: "\<lbrakk> le m n; le n m \<rbrakk> \<Longrightarrow> m = n"
by (metis thy_expl)
by (hipster_induct_schemes le.simps Nat.exhaust)*)

  theorem x0 :
    "(sorted xs) ==> (sorted (insort x xs))"
    by (hipster_induct_schemes insort.simps sorted.simps)
    (*apply(induction xs rule:sorted.induct)
    apply (simp_all add: timpano)
    (*apply(metis sorted.simps insort.simps timpano thy_expl)*)
    (*apply(metis le.simps sorted.simps insort.simps thy_expl*)
    (*apply(metis insort.simps le.simps)*)
    by (tactic {* Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1 *})*)

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_list_nat_perm_trans
imports "../../Test_Base"
begin

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

fun elem :: "'a => 'a list => bool" where
"elem x (nil2) = False"
| "elem x (cons2 z xs) = ((z = x) | (elem x xs))"

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
"deleteBy x y (nil2) = nil2"
| "deleteBy x y (cons2 y2 ys) =
     (if (x y) y2 then ys else cons2 y2 (deleteBy x y ys))"

fun isPermutation :: "'a list => 'a list => bool" where
"isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z x2) = False"
| "isPermutation (cons2 x3 xs) y =
     ((elem x3 y) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 y)))"

theorem property0 :
  "((isPermutation xs ys) ==>
      ((isPermutation ys zs) ==> (isPermutation xs zs)))"
  oops

end