section "Relative Frequency LTL"

theory RF_LTL
  imports Main "HOL-Library.Sublist" Auxiliary DynamicArchitectures.Dynamic_Architecture_Calculus
begin

type_synonym 's seq = "nat \<Rightarrow> 's"

abbreviation "ccard n n' p \<equiv> card {i. i>n \<and> i \<le> n' \<and> p i}"

lemma ccard_same:
  assumes "\<not> p (Suc n')"
  shows "ccard n n' p = ccard n (Suc n') p"
proof -
  have "{i. i > n \<and> i \<le> Suc n' \<and> p i} = {i. i>n \<and> i \<le> n' \<and> p i}"
  proof
    show "{i. n < i \<and> i \<le> Suc n' \<and> p i} \<subseteq> {i. n < i \<and> i \<le> n' \<and> p i}"
    proof
      fix x assume "x \<in> {i. n < i \<and> i \<le> Suc n' \<and> p i}"
      hence "n<x" and "x\<le>Suc n'" and "p x" by auto
      with assms (1) have "x\<noteq>Suc n'" by auto
      with \<open>x\<le>Suc n'\<close> have "x \<le> n'" by simp
      with \<open>n<x\<close> \<open>p x\<close> show "x \<in> {i. n < i \<and> i \<le> n' \<and> p i}" by simp
    qed
  next
    show "{i. n < i \<and> i \<le> n' \<and> p i} \<subseteq> {i. n < i \<and> i \<le> Suc n' \<and> p i}" by auto
  qed
  thus ?thesis by simp
qed

lemma ccard_zero[simp]:
  fixes n::nat
  shows "ccard n n p = 0"
  by auto

lemma ccard_inc:
  assumes "p (Suc n')"
    and "n' \<ge> n"
  shows "ccard n (Suc n') p = Suc (ccard n n' p)"
proof -
  let ?A = "{i. i > n \<and> i \<le> n' \<and> p i}"
  have "finite ?A" by simp
  moreover have "Suc n' \<notin> ?A" by simp
  ultimately have "card (insert (Suc n') ?A) = Suc (card ?A)" using card_insert_disjoint[of ?A] by simp
  moreover have "insert (Suc n') ?A = {i. i>n \<and> i \<le> (Suc n') \<and> p i}"
  proof
    show "insert (Suc n') ?A \<subseteq> {i. n < i \<and> i \<le> Suc n' \<and> p i}"
    proof
      fix x assume "x \<in> insert (Suc n') {i. n < i \<and> i \<le> n' \<and> p i}"
      hence "x=Suc n' \<or> n < x \<and> x \<le> n' \<and> p x" by simp
      thus "x \<in> {i. n < i \<and> i \<le> Suc n' \<and> p i}"
      proof
        assume "x = Suc n'"
        with assms (1) assms (2) show ?thesis by simp
      next
        assume "n < x \<and> x \<le> n' \<and> p x"
        thus ?thesis by simp
      qed
    qed
  next
    show "{i. n < i \<and> i \<le> Suc n' \<and> p i} \<subseteq> insert (Suc n') ?A" by auto
  qed
  ultimately show ?thesis by simp
qed

lemma ccard_mono:
  assumes "n'\<ge>n"
  shows "n''\<ge>n' \<Longrightarrow> ccard n (n''::nat) p \<ge> ccard n n' p"
proof (induction n'' rule: dec_induct)
  case base
  then show ?case ..
next
  case (step n'')
  then show ?case
  proof cases
    assume "p (Suc n'')"
    moreover from step.hyps assms have "n\<le>n''" by simp
    ultimately have "ccard n (Suc n'') p = Suc (ccard n n'' p)" using ccard_inc[of p n'' n] by simp
    also have "\<dots> \<ge> ccard n n' p" using step.IH by simp
    finally show ?case .
  next
    assume "\<not> p (Suc n'')"
    moreover from step.hyps assms have "n\<le>n''" by simp
    ultimately have "ccard n (Suc n'') p = ccard n n'' p" using ccard_same[of p n'' n] by simp
    also have "\<dots> \<ge> ccard n n' p" using step.IH by simp
    finally show ?case by simp
  qed
qed

lemma ccard_ub[simp]:
  "ccard n n' p \<le> Suc n' - n"
proof -
  have "{i. i>n \<and> i \<le> n' \<and> p i} \<subseteq> {i. i\<ge>n \<and> i \<le> n'}" by auto
  hence "ccard n n' p \<le> card {i. i\<ge>n \<and> i \<le> n'}" by (simp add: card_mono)
  moreover have "{i. i\<ge>n \<and> i \<le> n'} = {n..n'}" by auto
  hence "card {i. i\<ge>n \<and> i \<le> n'} = Suc n' - n" by simp
  ultimately show ?thesis by simp
qed

lemma ccard_sum:
  fixes n::nat
  assumes "n'\<ge>n''"
    and "n''\<ge>n"
  shows "ccard n n' P = ccard n n'' P + ccard n'' n' P"
proof -
  have "ccard n n' P = card {i. i>n \<and> i \<le> n' \<and> P i}" by simp
  moreover have "{i. i>n \<and> i \<le> n' \<and> P i} =
    {i. i>n \<and> i \<le> n'' \<and> P i} \<union> {i. i>n'' \<and> i \<le> n' \<and> P i}" (is "?LHS = ?RHS")
  proof
    show "?LHS \<subseteq> ?RHS" by auto
  next
    show "?RHS \<subseteq> ?LHS"
    proof
      fix x
      assume "x\<in>?RHS"
      hence "x>n \<and> x \<le> n'' \<and> P x \<or> x>n'' \<and> x \<le> n' \<and> P x" by auto
      thus "x\<in>?LHS"
      proof
        assume "n < x \<and> x \<le> n'' \<and> P x"
        with assms show ?thesis by simp
      next
        assume "n'' < x \<and> x \<le> n' \<and> P x"
        with assms show ?thesis by simp
      qed
    qed
  qed
  hence "card ?LHS = card ?RHS" by simp
  ultimately have "ccard n n' P = card ?RHS" by simp
  moreover have "card ?RHS = card {i. i>n \<and> i \<le> n'' \<and> P i} + card {i. i>n'' \<and> i \<le> n' \<and> P i}"
  proof (rule card_Un_disjoint)
    show "finite {i. n < i \<and> i \<le> n'' \<and> P i}" by simp
    show "finite {i. n'' < i \<and> i \<le> n' \<and> P i}" by simp
    show "{i. n < i \<and> i \<le> n'' \<and> P i} \<inter> {i. n'' < i \<and> i \<le> n' \<and> P i} = {}" by auto
  qed
  moreover have "ccard n n'' P = card {i. i>n \<and> i \<le> n'' \<and> P i}" by simp
  moreover have "ccard n'' n' P= card {i. i>n'' \<and> i \<le> n' \<and> P i}" by simp
  ultimately show ?thesis by simp
qed

lemma ccard_ex:
  fixes n::nat
  shows "c\<ge>1 \<Longrightarrow> c < ccard n n'' P \<Longrightarrow> \<exists>n'<n''. n'>n \<and> ccard n n' P = c"
proof (induction c rule: dec_induct)
  let ?l = "LEAST i::nat. n < i \<and> i < n'' \<and> P i"
  case base
  moreover have "ccard n n'' P \<le> Suc (card {i. n < i \<and> i < n'' \<and> P i})"
  proof -
    from \<open>ccard n n'' P > 1\<close> have "n''>n" using less_le_trans by force
    then obtain n' where "Suc n' = n''" and "Suc n' \<ge> n" by (metis lessE less_imp_le_nat)
    moreover have "{i. n < i \<and> i < Suc n' \<and> P i} = {i. n < i \<and> i \<le> n' \<and> P i}" by auto
    hence "card {i. n < i \<and> i < Suc n' \<and> P i} = card {i. n < i \<and> i \<le> n' \<and> P i}" by simp
    moreover have "card {i. n < i \<and> i \<le> Suc n' \<and> P i} \<le> Suc (card {i. n < i \<and> i \<le> n' \<and> P i})"
    proof cases
      assume "P (Suc n')"
      moreover from \<open>n''>n\<close> \<open>Suc n'=n''\<close> have "n'\<ge>n" by simp
      ultimately show ?thesis using ccard_inc[of P n' n] by simp
    next
      assume "\<not> P (Suc n')"
      moreover from \<open>n''>n\<close> \<open>Suc n'=n''\<close> have "n'\<ge>n" by simp
      ultimately show ?thesis using ccard_same[of P n' n] by simp
    qed
    ultimately show ?thesis by simp
  qed
  ultimately have "card {i. n < i \<and> i < n'' \<and> P i} \<ge> 1" by simp
  hence "{i. n < i \<and> i < n'' \<and> P i} \<noteq> {}" by fastforce
  hence "\<exists>i. n < i \<and> i < n'' \<and> P i" by auto
  hence "?l>n" and "?l<n''" and "P ?l" using LeastI_ex[of "\<lambda>i::nat. n < i \<and> i < n'' \<and> P i"] by auto
  moreover have "{i. n < i \<and> i \<le> ?l \<and> P i} = {?l}"
  proof
    show "{i. n < i \<and> i \<le> ?l \<and> P i} \<subseteq> {?l}"
    proof
      fix i
      assume "i\<in>{i. n < i \<and> i \<le> ?l \<and> P i}"
      hence "n < i" and "i \<le> ?l" and "P i" by auto
      with \<open>\<exists>i. n < i \<and> i < n'' \<and> P i\<close> have "i=?l"
        using Least_le[of "\<lambda>i. n < i \<and> i < n'' \<and> P i"] by (meson antisym le_less_trans)
      thus "i\<in>{?l}" by simp
    qed
  next
    show "{?l} \<subseteq> {i. n < i \<and> i \<le> ?l \<and> P i}"
    proof
      fix i
      assume "i\<in>{?l}"
      hence "i=?l" by simp
      with \<open>?l>n\<close> \<open>?l<n''\<close> \<open>P ?l\<close> show "i\<in>{i. n < i \<and> i \<le> ?l \<and> P i}" by simp
    qed
  qed
  hence "ccard n ?l P = 1" by simp
  ultimately show ?case by auto
next
  case (step c)
  moreover from step.prems have "Suc c<ccard n n'' P" by simp
  ultimately obtain n' where "n'<n''" and "n < n'" and "ccard n n' P = c" by auto
  hence "ccard n n'' P = ccard n n' P + ccard n' n'' P" using ccard_sum[of n' n'' n] by simp
  with \<open>Suc c<ccard n n'' P\<close> \<open>ccard n n' P = c\<close> have "ccard n' n'' P>1" by simp
  moreover have "ccard n' n'' P \<le> Suc (card {i. n' < i \<and> i < n'' \<and> P i})"
  proof -
    from \<open>ccard n' n'' P > 1\<close> have "n''>n'" using less_le_trans by force
    then obtain n''' where "Suc n''' = n''" and "Suc n''' \<ge> n'" by (metis lessE less_imp_le_nat)
    moreover have "{i. n' < i \<and> i < Suc n''' \<and> P i} = {i. n' < i \<and> i \<le> n''' \<and> P i}" by auto
    hence "card {i. n' < i \<and> i < Suc n''' \<and> P i} = card {i. n' < i \<and> i \<le> n''' \<and> P i}" by simp
    moreover have "card {i. n' < i \<and> i \<le> Suc n''' \<and> P i} \<le> Suc (card {i. n' < i \<and> i \<le> n''' \<and> P i})"
    proof cases
      assume "P (Suc n''')"
      moreover from \<open>n''>n'\<close> \<open>Suc n'''=n''\<close> have "n'''\<ge>n'" by simp
      ultimately show ?thesis using ccard_inc[of P n''' n'] by simp
    next
      assume "\<not> P (Suc n''')"
      moreover from \<open>n''>n'\<close> \<open>Suc n'''=n''\<close> have "n'''\<ge>n'" by simp
      ultimately show ?thesis using ccard_same[of P n''' n'] by simp
    qed
    ultimately show ?thesis by simp
  qed
  ultimately have "card {i. n' < i \<and> i < n'' \<and> P i} \<ge> 1" by simp
  hence "{i. n' < i \<and> i < n'' \<and> P i} \<noteq> {}" by fastforce
  hence "\<exists>i. n' < i \<and> i < n'' \<and> P i" by auto
  let ?l = "LEAST i::nat. n' < i \<and> i < n'' \<and> P i"
  from \<open>\<exists>i. n' < i \<and> i < n'' \<and> P i\<close> have "n' < ?l"
    using LeastI_ex[of "\<lambda>i::nat. n' < i \<and> i < n'' \<and> P i"] by auto
  with \<open>n < n'\<close> have "ccard n ?l P = ccard n n' P + ccard n' ?l P" using ccard_sum[of n' ?l n] by simp
  moreover have "{i. n' < i \<and> i \<le> ?l \<and> P i} = {?l}"
  proof
    show "{i. n' < i \<and> i \<le> ?l \<and> P i} \<subseteq> {?l}"
    proof
      fix i
      assume "i\<in>{i. n' < i \<and> i \<le> ?l \<and> P i}"
      hence "n' < i" and "i \<le> ?l" and "P i" by auto
      with \<open>\<exists>i. n' < i \<and> i < n'' \<and> P i\<close> have "i=?l"
        using Least_le[of "\<lambda>i. n' < i \<and> i < n'' \<and> P i"] by (meson antisym le_less_trans)
      thus "i\<in>{?l}" by simp
    qed
  next
    show "{?l} \<subseteq> {i. n' < i \<and> i \<le> ?l \<and> P i}"
    proof
      fix i
      assume "i\<in>{?l}"
      hence "i=?l" by simp
      moreover from \<open>\<exists>i. n' < i \<and> i < n'' \<and> P i\<close> have "?l<n''" and "P ?l"
        using LeastI_ex[of "\<lambda>i. n' < i \<and> i < n'' \<and> P i"] by auto
      ultimately show "i\<in>{i. n' < i \<and> i \<le> ?l \<and> P i}" using \<open>?l>n'\<close> by simp
    qed
  qed
  hence "ccard n' ?l P = 1" by simp
  ultimately have "card {i. n < i \<and> i \<le> ?l \<and> P i} = Suc c" using \<open>ccard n n' P = c\<close> by simp
  moreover from \<open>\<exists>i. n' < i \<and> i < n'' \<and> P i\<close> have "n' < ?l" and "?l < n''" and "P ?l"
    using LeastI_ex[of "\<lambda>i::nat. n' < i \<and> i < n'' \<and> P i"] by auto
  with \<open>n < n'\<close> have "n<?l" and "?l<n''" by auto
  ultimately show ?case by auto
qed

lemma ccard_freq:
  assumes "(n'::nat)\<ge>n"
    and "ccard n n' P > ccard n n' Q + cnf"
  shows "\<exists>n' n''. ccard n' n'' P > cnf \<and> ccard n' n'' Q \<le> cnf"
proof cases
  assume "cnf = 0"
  with assms(2) have "ccard n n' P > ccard n n' Q" by simp
  hence "card {i. n < i \<and> i \<le> n' \<and> P i}>card {i. n < i \<and> i \<le> n' \<and> Q i}" (is "card ?LHS>card ?RHS")
    by simp
  then obtain i where "i\<in>?LHS" and "\<not> i \<in> ?RHS" and "i>0" using cardEx[of ?LHS ?RHS] by auto
  hence "P i" and "\<not> Q i" by auto
  with \<open>i>0\<close> obtain n'' where "P (Suc n'')" and "\<not>Q (Suc n'')" using gr0_implies_Suc by auto
  hence "ccard n'' (Suc n'') P = 1" using ccard_inc by auto
  with \<open>cnf = 0\<close> have "ccard n'' (Suc n'') P > cnf" by simp
  moreover from \<open>\<not>Q (Suc n'')\<close> have "ccard n'' (Suc n'') Q = 0" using ccard_same[of Q n'' n''] by auto
  with \<open>cnf = 0\<close> have "ccard n'' (Suc n'') Q \<le> cnf" by simp
  ultimately show ?thesis by auto
next
  assume "\<not> cnf = 0"
  show ?thesis
  proof (rule ccontr)
    assume "\<not> (\<exists>n' n''. ccard n' n'' P > cnf \<and> ccard n' n'' Q \<le> cnf)"
    hence hyp: "\<forall>n' n''. ccard n' n'' Q \<le> cnf \<longrightarrow> ccard n' n'' P \<le> cnf"
      using leI less_imp_le_nat by blast
    show False
    proof cases
      assume "ccard n n' Q \<le> cnf"
      with hyp have "ccard n n' P \<le> cnf" by simp
      with assms show False by simp
    next
      let ?gcond="\<lambda>n''. n''\<ge>n \<and> n''\<le>n' \<and> (\<exists>x\<ge>1. ccard n n'' Q = x * cnf)"
      let ?g= "GREATEST n''. ?gcond n''"
      assume "\<not> ccard n n' Q \<le> cnf"
      hence "ccard n n' Q > cnf" by simp
      hence "\<exists>n''. ?gcond n''"
      proof -
        from \<open>ccard n n' Q > cnf\<close> \<open>\<not>cnf=0\<close> obtain n'' where "n''>n" and "n''\<le>n'" and "ccard n n'' Q = cnf"
          using ccard_ex[of cnf n n' Q ] by auto
        moreover from \<open>ccard n n'' Q = cnf\<close> have "\<exists>x\<ge>1. ccard n n'' Q = x * cnf" by auto
        ultimately show ?thesis using less_imp_le_nat by blast
      qed
      moreover have "\<forall>n''>n'. \<not> ?gcond n''" by simp
      ultimately have gex: "\<exists>n''. ?gcond n'' \<and> (\<forall>n'''. ?gcond n''' \<longrightarrow> n'''\<le>n'')"
        using boundedGreatest[of ?gcond _ n'] by blast
      hence "\<exists>x\<ge>1. ccard n ?g Q = x * cnf" and "?g \<ge> n" using GreatestI_ex_nat[of ?gcond] by auto
      moreover {fix n''
      have "n''\<ge>n \<Longrightarrow> \<exists>x\<ge>1. ccard n n'' Q = x * cnf \<Longrightarrow> ccard n n'' P \<le> ccard n n'' Q"
      proof (induction n'' rule: ge_induct)
        case (step n')
        from step.prems obtain x where "x\<ge>1" and cas: "ccard n n' Q = x * cnf" by auto
        then show ?case
        proof cases
          assume "x=1"
          with cas have "ccard n n' Q = cnf" by simp
          with hyp have "ccard n n' P \<le> cnf" by simp
          with \<open>ccard n n' Q = cnf\<close> show ?thesis by simp
        next
          assume "\<not>x=1"
          with \<open>x\<ge>1\<close> have "x>1" by simp
          hence "x-1 \<ge> 1" by simp
          moreover from \<open>cnf\<noteq>0\<close> \<open>x-1 \<ge> 1\<close> have "(x-1) * cnf < x * cnf \<and> (x - 1) * cnf \<noteq> 0" by auto
          with \<open>x-1 \<ge> 1\<close> \<open>cnf\<noteq>0\<close>\<open>ccard n n' Q = x * cnf\<close> obtain n''
            where "n''>n" and "n''<n'" and "ccard n n'' Q = (x-1) * cnf"
            using ccard_ex[of "(x-1)*cnf" n n' Q ] by auto
          ultimately have "\<exists>x\<ge>1. ccard n n'' Q = x * cnf" and "n''\<ge>n" by auto
          with \<open>n''\<ge>n\<close> \<open>n''<n'\<close> have "ccard n n'' P \<le> ccard n n'' Q" using step.IH by simp
          moreover have "ccard n'' n' Q = cnf"
          proof -
            from \<open>x-1 \<ge> 1\<close> have "x*cnf = ((x-1) * cnf) + cnf"
              using semiring_normalization_rules(2)[of "(x - 1)" cnf] by simp
            with \<open>ccard n n'' Q = (x-1) * cnf\<close> \<open>ccard n n' Q = x * cnf\<close>
            have "ccard n n' Q = ccard n n'' Q + cnf" by simp
            moreover from \<open>n''\<ge>n\<close> \<open>n''<n'\<close> have "ccard n n' Q = ccard n n'' Q + ccard n'' n' Q"
              using ccard_sum[of n'' n' n] by simp
            ultimately show ?thesis by simp
          qed
          moreover from \<open>ccard n'' n' Q = cnf\<close> have "ccard n'' n' P \<le> cnf" using hyp by simp
          ultimately show ?thesis using \<open>n''\<ge>n\<close> \<open>n''<n'\<close> ccard_sum[of n'' n' n] by simp
        qed
      qed } note geq = this
      ultimately have "ccard n ?g P \<le> ccard n ?g Q" by simp
      moreover have "ccard ?g n' P \<le> cnf"
      proof (rule ccontr)
        assume "\<not> ccard ?g n' P \<le> cnf"
        hence "ccard ?g n' P > cnf" by simp
        have "ccard ?g n' Q > cnf"
        proof (rule ccontr)
          assume "\<not>ccard ?g n' Q > cnf"
          hence "ccard ?g n' Q \<le> cnf" by simp
          with \<open>ccard ?g n' P > cnf\<close> show False
            using \<open>\<not> (\<exists>n' n''. ccard n' n'' P > cnf \<and> ccard n' n'' Q \<le> cnf)\<close> by simp
        qed
        with \<open>\<not> cnf=0\<close> obtain n'' where "n''>?g" and "n''<n'" and "ccard ?g n'' Q = cnf"
          using ccard_ex[of cnf ?g n' Q] by auto
        moreover have "\<exists>x\<ge>1. ccard n n'' Q = x * cnf"
        proof -
          from \<open>\<exists>x\<ge>1. ccard n ?g Q = x * cnf\<close> obtain x where "x\<ge>1" and "ccard n ?g Q = x * cnf" by auto
          from \<open>n''>?g\<close> \<open>?g\<ge>n\<close> have "ccard n n'' Q = ccard n ?g Q + ccard ?g n'' Q"
            using ccard_sum[of ?g n'' n Q] by simp
          with \<open>ccard n ?g Q = x * cnf\<close> have "ccard n n'' Q = x * cnf + ccard ?g n'' Q" by simp
          with \<open>ccard ?g n'' Q = cnf\<close> have "ccard n n'' Q = Suc x * cnf" by simp
          thus ?thesis by auto
        qed
        moreover from \<open>n''>?g\<close> \<open>?g\<ge>n\<close> have "n''\<ge>n" by simp
        ultimately have "\<exists>n''>?g. ?gcond n''" by auto
        moreover from gex have "\<forall>n'''. ?gcond n''' \<longrightarrow> n'''\<le>?g" using Greatest_le_nat[of ?gcond] by auto
        ultimately show False by auto
      qed
      moreover from gex have "n'\<ge>?g" using GreatestI_ex_nat[of ?gcond] by auto
      ultimately have "ccard n n' P\<le>ccard n n' Q + cnf" using ccard_sum[of ?g n' n] using \<open>?g \<ge> n\<close> by simp
      with assms show False by simp
    qed
  qed
qed

locale honest =
  fixes bc:: "('a list) seq"
    and n::nat
  assumes growth: "n'\<noteq>0 \<Longrightarrow> n'\<le>n \<Longrightarrow> bc n' = bc (n'-1) \<or> (\<exists>b. bc n' = bc (n' - 1) @ b)"
begin
end

locale dishonest =
  fixes bc:: "('a list) seq"
    and mining::"bool seq"
  assumes growth: "\<And>n::nat. prefix (bc (Suc n)) (bc n) \<or> (\<exists>b::'a. bc (Suc n) = bc n @ [b]) \<and> mining (Suc n)"
begin

lemma prefix_save:
  assumes "prefix sbc (bc n')"
    and "\<forall>n'''>n'. n'''\<le>n'' \<longrightarrow> length (bc n''') \<ge> length sbc"
  shows "n''\<ge>n' \<Longrightarrow> prefix sbc (bc n'')"
proof (induction n'' rule: dec_induct)
  case base
  with assms(1) show ?case by simp
next
  case (step n)
  from growth[of n] show ?case
  proof
    assume "prefix (bc (Suc n)) (bc n)"
    moreover from step.hyps have "length (bc (Suc n)) \<ge> length sbc" using assms(2) by simp
    ultimately show ?thesis using step.IH using prefix_length_prefix by auto
  next
    assume "(\<exists>b. bc (Suc n) = bc n @ [b]) \<and> mining (Suc n)"
    with step.IH show ?thesis by auto
  qed
qed

theorem prefix_length:
  assumes "prefix sbc (bc n')" and "\<not> prefix sbc (bc n'')" and "n'\<le>n''"
  shows "\<exists>n'''>n'. n'''\<le>n'' \<and> length (bc n''') < length sbc"
proof (rule ccontr)
  assume "\<not> (\<exists>n'''>n'. n'''\<le>n'' \<and> length (bc n''') < length sbc)"
  hence "\<forall>n'''>n'. n'''\<le>n'' \<longrightarrow> length (bc n''') \<ge> length sbc" by auto
  with assms have "prefix sbc (bc n'')" using prefix_save[of sbc n' n''] by simp
  with assms (2) show False by simp
qed

theorem grow_mining:
  assumes "length (bc n) < length (bc (Suc n))"
  shows "mining (Suc n)"
  using assms growth leD prefix_length_le by blast

lemma length_suc_length:
  "length (bc (Suc n)) \<le> Suc (length (bc n))"
  by (metis eq_iff growth le_SucI length_append_singleton prefix_length_le)

end

locale dishonest_growth =
  fixes bc:: "nat seq"
    and mining:: "nat \<Rightarrow> bool"
  assumes as1: "\<And>n::nat. bc (Suc n) \<le> Suc (bc n)"
    and as2: "\<And>n::nat. bc (Suc n) > bc n \<Longrightarrow> mining (Suc n)"
begin

end

sublocale dishonest \<subseteq> dishonest_growth "\<lambda>n. length (bc n)" using grow_mining length_suc_length by unfold_locales auto

context dishonest_growth
begin

locale honest_growth =
  fixes bc:: "nat seq"
    and mining:: "nat \<Rightarrow> bool"
    and init:: nat
  assumes as1: "\<And>n::nat. bc (Suc n) \<ge> bc n"
    and as2: "\<And>n::nat. mining (Suc n) \<Longrightarrow> bc (Suc n) > bc n"
begin
  lemma grow_mono: "n'\<ge>n\<Longrightarrow>bc n'\<ge>bc n"
  proof (induction n' rule: dec_induct)
    case base
    then show ?case by simp
  next
    case (step n')
    then show ?case using as1[of n'] by simp
  qed

  theorem ccard_diff_lgth:
    shows "n'\<ge>n \<Longrightarrow> bc n' - bc n \<ge> ccard n n' (\<lambda>n. mining n)"
  proof (induction n' rule: dec_induct)
    case base
    then show ?case by simp
  next
    case (step n')
    then show ?case
    proof cases
      assume "mining (Suc n')"
      with as2 have "bc (Suc n') > bc n'" by simp
      moreover from step.hyps have "bc n'\<ge>bc n" using grow_mono by simp
      ultimately have "bc (Suc n') - bc n > bc n' - bc n" by simp
      moreover from as1 have "bc (Suc n') - bc n \<ge> bc n' - bc n" by (simp add: diff_le_mono)
      moreover from \<open>mining (Suc n')\<close> step.hyps
        have "ccard n (Suc n') (\<lambda>n. mining n) \<le> Suc (ccard n n' (\<lambda>n. mining n))"
        using ccard_inc by simp
      ultimately show ?thesis using step.IH by simp
    next
      assume "\<not> mining (Suc n')"
      hence "ccard n (Suc n') (\<lambda>n. mining n) \<le> (ccard n n' (\<lambda>n. mining n))" using ccard_same by simp
      moreover from as1 have "bc (Suc n') - bc n \<ge> bc n' - bc n" by (simp add: diff_le_mono)
      ultimately show ?thesis using step.IH by simp
    qed
  qed
end

locale bounded_growth = hg: honest_growth hbc hmining + dg: dishonest_growth dbc dmining
    for hbc:: "nat seq"
    and dbc:: "nat seq"
    and hmining:: "nat \<Rightarrow> bool"
    and dmining:: "nat \<Rightarrow> bool"
    and sbc::nat
    and cnf::nat +
  assumes fair: "\<And>n n'. ccard n n' (\<lambda>n. dmining n) > cnf \<Longrightarrow> ccard n n' (\<lambda>n. hmining n) > cnf"
    and a2: "hbc 0 \<ge> sbc+cnf"
    and a3: "dbc 0 < sbc"
begin

theorem hn_upper_bound: shows "dbc n < hbc n"
proof (rule ccontr)
  assume "\<not> dbc n < hbc n"
  hence "dbc n \<ge> hbc n" by simp
  moreover from a2 a3 have "hbc 0 > dbc 0 + cnf" by simp
  moreover have "hbc n\<ge>hbc 0" using hg.grow_mono by simp
  ultimately have "dbc n - dbc 0 > hbc n - hbc 0 + cnf" by simp
  moreover have "ccard 0 n (\<lambda>n. hmining n) \<le> hbc n - hbc 0" using hg.ccard_diff_lgth by simp
  moreover have "dbc n - dbc 0 \<le> ccard 0 n (\<lambda>n. dmining n)" using dg.ccard_diff_lgth by simp
  ultimately have "ccard 0 n (\<lambda>n. dmining n) > ccard 0 n (\<lambda>n. hmining n) + cnf" by simp
  hence "\<exists>n' n''. ccard n' n'' (\<lambda>n. dmining n) > cnf \<and> ccard n' n'' (\<lambda>n. hmining n) \<le> cnf"
    using ccard_freq by blast
  with fair show False using leD by blast
qed

end

end


section {*\isaheader{Implementation of Priority Queues by Skew Binomial Heaps}*}

theory SkewPrioImpl
imports
  "../../../Binomial-Heaps/SkewBinomialHeap"
  "../spec/PrioSpec"
  "../tools/Record_Intf"
  "../tools/Locale_Code"
begin

(*@impl Prio
  @type ('a,'p::linorder) skew
  @abbrv skew
  Priority queues by skew binomial heaps.
*)

subsection "Definitions"
type_synonym ('a,'b) skew = "('a, 'b) SkewBinomialHeap"

definition skew_\<alpha> where "skew_\<alpha> q \<equiv> SkewBinomialHeap.to_mset q"
definition skew_insert where "skew_insert \<equiv> SkewBinomialHeap.insert"
abbreviation (input) skew_invar :: "('a, 'b) SkewBinomialHeap \<Rightarrow> bool"
  where "skew_invar \<equiv> \<lambda>_. True"
definition skew_find where "skew_find \<equiv> SkewBinomialHeap.findMin"
definition skew_delete where "skew_delete \<equiv> SkewBinomialHeap.deleteMin"
definition skew_meld where "skew_meld \<equiv> SkewBinomialHeap.meld"
definition skew_empty where "skew_empty \<equiv> \<lambda>_::unit. SkewBinomialHeap.empty"
definition skew_isEmpty where "skew_isEmpty = SkewBinomialHeap.isEmpty"

definition [icf_rec_def]: "skew_ops == \<lparr>
  prio_op_\<alpha> = skew_\<alpha>,
  prio_op_invar = skew_invar,
  prio_op_empty = skew_empty,
  prio_op_isEmpty = skew_isEmpty,
  prio_op_insert = skew_insert,
  prio_op_find = skew_find,
  prio_op_delete = skew_delete,
  prio_op_meld = skew_meld
\<rparr>"

lemmas skew_defs =
  skew_\<alpha>_def
  skew_insert_def
  skew_find_def
  skew_delete_def
  skew_meld_def
  skew_empty_def
  skew_isEmpty_def

subsection "Correctness"

theorem skew_empty_impl: "prio_empty skew_\<alpha> skew_invar skew_empty"
  by (unfold_locales, auto simp add: skew_defs)

theorem skew_isEmpty_impl: "prio_isEmpty skew_\<alpha> skew_invar skew_isEmpty"
  by unfold_locales
     (simp add: skew_defs SkewBinomialHeap.isEmpty_correct SkewBinomialHeap.empty_correct)

theorem skew_find_impl: "prio_find skew_\<alpha> skew_invar skew_find"
  apply unfold_locales
  apply (simp add: skew_defs SkewBinomialHeap.empty_correct SkewBinomialHeap.findMin_correct)
  done

lemma skew_insert_impl: "prio_insert skew_\<alpha> skew_invar skew_insert"
  apply(unfold_locales)
  apply(unfold skew_defs)
  apply (simp_all add: SkewBinomialHeap.insert_correct)
  done

lemma skew_meld_impl: "prio_meld skew_\<alpha> skew_invar skew_meld"
  apply(unfold_locales)
  apply(unfold skew_defs)
  apply(simp_all add: SkewBinomialHeap.meld_correct)
  done

lemma skew_delete_impl:
  "prio_delete skew_\<alpha> skew_invar skew_find skew_delete"
  apply intro_locales
  apply (rule skew_find_impl)
  apply(unfold_locales)
  apply(simp_all add: skew_defs SkewBinomialHeap.empty_correct SkewBinomialHeap.deleteMin_correct)
done

setup Locale_Code.open_block
interpretation skew: StdPrio skew_ops
  apply (rule StdPrio.intro)
  apply (simp_all add: icf_rec_unf)
  apply (rule
    skew_empty_impl
    skew_isEmpty_impl
    skew_find_impl
    skew_insert_impl
    skew_meld_impl
    skew_delete_impl
  )+
  done
interpretation skew: StdPrio_no_invar skew_ops
  by unfold_locales (simp add: icf_rec_unf)
setup Locale_Code.close_block

definition test_codegen where "test_codegen \<equiv> (
  skew.empty,
  skew.isEmpty,
  skew.find,
  skew.insert,
  skew.meld,
  skew.delete
)"

export_code test_codegen in SML

end


(*
 * Copyright Brian Huffman, PSU; Jeremy Dawson and Gerwin Klein, NICTA
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section \<open>Comprehension syntax for bit expressions\<close>

theory Bit_Comprehension
  imports
    "HOL-Library.Word"
begin

class bit_comprehension = ring_bit_operations +
  fixes set_bits :: \<open>(nat \<Rightarrow> bool) \<Rightarrow> 'a\<close>  (binder \<open>BITS \<close> 10)
  assumes set_bits_bit_eq: \<open>set_bits (bit a) = a\<close>
begin

lemma set_bits_False_eq [simp]:
  \<open>(BITS _. False) = 0\<close>
  using set_bits_bit_eq [of 0] by (simp add: bot_fun_def)

end

instantiation word :: (len) bit_comprehension
begin

definition word_set_bits_def:
  \<open>(BITS n. P n) = (horner_sum of_bool 2 (map P [0..<LENGTH('a)]) :: 'a word)\<close>

instance by standard
  (simp add: word_set_bits_def horner_sum_bit_eq_take_bit)

end

lemma bit_set_bits_word_iff [bit_simps]:
  \<open>bit (set_bits P :: 'a::len word) n \<longleftrightarrow> n < LENGTH('a) \<and> P n\<close>
  by (auto simp add: word_set_bits_def bit_horner_sum_bit_word_iff)

lemma word_of_int_conv_set_bits: "word_of_int i = (BITS n. bit i n)"
  by (rule bit_eqI) (auto simp add: bit_simps)

lemma set_bits_K_False:
  \<open>set_bits (\<lambda>_. False) = (0 :: 'a :: len word)\<close>
  by (fact set_bits_False_eq)

lemma word_test_bit_set_bits: "bit (BITS n. f n :: 'a :: len word) n \<longleftrightarrow> n < LENGTH('a) \<and> f n"
  by (fact bit_set_bits_word_iff)

context
  includes bit_operations_syntax
  fixes f :: \<open>nat \<Rightarrow> bool\<close>
begin

definition set_bits_aux :: \<open>nat \<Rightarrow> 'a word \<Rightarrow> 'a::len word\<close>
  where \<open>set_bits_aux n w = push_bit n w OR take_bit n (set_bits f)\<close>

lemma bit_set_bit_aux [bit_simps]:
  \<open>bit (set_bits_aux n w) m \<longleftrightarrow> m < LENGTH('a) \<and>
    (if m < n then f m else bit w (m - n))\<close> for w :: \<open>'a::len word\<close>
  by (auto simp add: bit_simps set_bits_aux_def)

corollary set_bits_conv_set_bits_aux:
  \<open>set_bits f = (set_bits_aux LENGTH('a) 0 :: 'a :: len word)\<close>
  by (rule bit_word_eqI) (simp add: bit_simps)

lemma set_bits_aux_0 [simp]:
  \<open>set_bits_aux 0 w = w\<close>
  by (simp add: set_bits_aux_def)

lemma set_bits_aux_Suc [simp]:
  \<open>set_bits_aux (Suc n) w = set_bits_aux n (push_bit 1 w OR (if f n then 1 else 0))\<close>
  by (rule bit_word_eqI) (auto simp add: bit_simps le_less_Suc_eq mult.commute [of _ 2])

lemma set_bits_aux_simps [code]:
  \<open>set_bits_aux 0 w = w\<close>
  \<open>set_bits_aux (Suc n) w = set_bits_aux n (push_bit 1 w OR (if f n then 1 else 0))\<close>
  by simp_all

lemma set_bits_aux_rec:
  \<open>set_bits_aux n w =
  (if n = 0 then w
   else let n' = n - 1 in set_bits_aux n' (push_bit 1 w OR (if f n' then 1 else 0)))\<close>
  by (cases n) simp_all

end

end


text \<open> Version 0.5, last changed 2018-03-28
  (C) fovefi ltd, www.fovefi.co
  (author: Lukas Bulwahn [lubu@fovefi.co], comments by Manfred Kerber [make@fovefi.co])

  Dually licenced under
  Creative Commons Attribution (CC-BY) 4.0 [https://creativecommons.org/licenses/by/4.0/]
  ISC License (1-clause BSD License)       [https://www.isc.org/downloads/software-support-policy/isc-license/]
  See LICENSE files for details.
  (Rationale for this dual licence: http://arxiv.org/abs/1107.3212)

  In the following, an executable definition of the percentile function is given that is
  close to the one used in OpenSIMM, a system with a standard implementation for the computation
  of risk.
  \<close>

theory Percentile_Code
  imports Percentile
begin

section \<open>Code Generation of Percentile\<close>
paragraph \<open>The percentile definition close to the Java implementation\<close>

text \<open> In the Java code follows a check that the level is below 1 - 1/(2*size).
 * If not, it throws an exception. In the Isabelle implementation (there is no exception
 * handling in Isabelle), the code is underspecified, that is, no specific values will be
 * returned for larger values. This will be fixed in the definition of the percentile function
 * in the next section.
 \<close>
term "ceiling"
find_theorems "ceiling"

text \<open> An integer greater equal 0 considered as a real number is the same as the integer first considered
 * as a natural number and this then considered as a real number. \<close>
lemma real_of_int:
  assumes "0 \<le> i"
  shows "real_of_int i = real (nat i)"
by (simp add: assms)

text \<open> The value of the minimum of the domain of equidistant point is determined. \<close>
lemma Min_equidistant_points_on_unit_interval_of_bounded:
  fixes x :: real
  assumes "ys \<noteq> []"
  assumes "1 / (2 * length ys) < x"
  assumes "x \<le> 1 - 1 / (2 * length ys)"
  shows "Min {x' \<in> dom (equidistant_points_on_unit_interval_of ys). x \<le> x'} = (ceiling (length ys * x - 0.5) + 0.5) / length ys"
  (is "Min ?A = ?expr")
proof (rule Min_eqI)
  text \<open>let ?A = "{x' \<in> dom (equidistant_points_on_unit_interval_of ys). x \<le> x'}"\<close>
  show "finite ?A" by simp
  show "?expr \<le> y" if "y \<in> ?A" for y
  proof -
    from that \<open>ys \<noteq> []\<close> obtain n where "y = (real n + 1 / 2) / real (length ys)" and "x \<le> y"
      unfolding equidistant_points_on_unit_interval_of_def
      apply auto done
    obtain i where "i = int n" by auto
    from this \<open>y = _\<close> have y: "y = (real_of_int i + 1 / 2) / real (length ys)"
      by simp
    have "i \<ge> ceiling (length ys * x - 0.5)"
    proof -
      have "x \<le> (real_of_int i + 1 / 2) / real (length ys)"
        using \<open>x \<le> y\<close> y by blast
      from this have "length ys * x \<le> (real_of_int i + 1 / 2)"
        apply -
        apply (frule mult_left_mono[where c="real (length ys)"])
         apply simp
        by (simp add: assms(1))
        find_theorems "_ * _ \<le> _ * _"
      from this have "length ys * x - 1 / 2 \<le> real_of_int i" by linarith
      from this show ?thesis
        by (simp add: ceiling_le)
    qed
    from this y have "y \<ge> (real_of_int (ceiling (length ys * x - 0.5)) + 1 / 2) / real (length ys)"
      apply simp
      find_theorems "_ / _ \<le> _ / _"
      apply (rule divide_right_mono)
      apply simp
      apply simp
      done
    from this show ?thesis by simp
  qed
  show "?expr \<in> ?A"
  proof -
    from assms have "0 \<le> real (length ys) * x - 1 / 2"
      apply auto
      by (simp add: Groups.mult_ac(2) divide_less_eq)
    from this have "0 \<le> \<lceil>real (length ys) * x - 1 / 2\<rceil>" by simp
    from this have a: "real_of_int \<lceil>real (length ys) * x - 1 / 2\<rceil> = real (nat \<lceil>real (length ys) * x - 1 / 2\<rceil>)"
      by simp
    have b: "nat \<lceil>real (length ys) * x - 1 / 2\<rceil> \<in> {0..<length ys}"
    proof -
      have "real (length ys) * x - 1 / 2 \<le> (length ys - 1)"
      proof -
        have "real (length ys) * x - 1 / 2 \<le> real (length ys) * (1 - 1 / real (2 * length ys)) - 1 / 2"
          using assms(1, 3) by simp
        also have "\<dots> = real (length ys) - 1"
          apply auto
          apply (subst right_diff_distrib)
          apply simp
          by (simp add: assms(1))
        also have "\<dots> = real (length ys - 1)"
          by (metis One_nat_def Suc_pred assms(1) diff_Suc_Suc diff_is_0_eq length_greater_0_conv of_nat_1 of_nat_diff zero_diff)
        finally show ?thesis .
      qed
      text \<open>have "\<lceil>real (length ys) * x - 1 / 2\<rceil> \<ge> 0" s_orry\<close>
      from this have a: "\<lceil>real (length ys) * x - 1 / 2\<rceil> \<le> \<lceil>real (length ys - 1)\<rceil>"
        using ceiling_mono by blast
      have "\<lceil>real (length ys - 1)\<rceil> = int (length ys - 1)" by simp
      from a this have "nat \<lceil>real (length ys) * x - 1 / 2\<rceil> < length ys"
        by (smt assms(1) int_nat_eq length_greater_0_conv nat_less_le of_nat_0_less_iff of_nat_1 of_nat_diff of_nat_less_imp_less zero_less_diff)
      from this show ?thesis
        apply auto done
    qed
    have "(real_of_int \<lceil>real (length ys) * x - 5 / 10\<rceil> + 5 / 10) / real (length ys)
      \<in> dom (equidistant_points_on_unit_interval_of ys)"
      unfolding dom_equidistant_points_on_unit_interval_of
      apply auto
      apply (subst a)
      apply (rule image_eqI)
       apply (rule refl)
      apply (rule b) done
      find_theorems "dom (equidistant_points_on_unit_interval_of _)"
    moreover have "x \<le> (real_of_int \<lceil>real (length ys) * x - 5 / 10\<rceil> + 5 / 10) / real (length ys)"
    proof -
      have "real (length ys) > 0" (* only need \<ge> *)
        by (simp add: assms)
      have a: "real (length ys) * x - 5 / 10 \<le> real_of_int \<lceil>real (length ys) * x - 5 / 10\<rceil>"
        by linarith
      have "x \<le> ((real (length ys) * x - 5 / 10) + 5 / 10) / real (length ys)"
        using \<open>real (length ys) > 0\<close> by auto
      also have "\<dots> \<le> (real_of_int \<lceil>real (length ys) * x - 5 / 10\<rceil> + 5 / 10) / real (length ys)"
        using \<open>real (length ys) > 0\<close> a
        apply -
        apply (rule divide_right_mono)
        apply linarith
        apply simp done
      finally show ?thesis .
    qed
    ultimately show ?thesis by auto
  qed
qed

text \<open> A property of the ceiling function. \<close>
lemma ceiling_minus_leq:
  assumes "a + b \<ge> 1"
  shows "real_of_int \<lceil>x - a\<rceil> - b \<le> x"
using assms by linarith

text \<open> Relationship between floor and ceiling (floor plus 1 is less equal ceiling). \<close>
lemma floor_leq_ceiling:
  fixes x :: real
  assumes "x \<notin> real_of_int ` UNIV"
  shows "1 + real_of_int (floor x) \<le> real_of_int (ceiling x)"
using assms by (smt UNIV_I ceiling_correct image_eqI int_less_real_le le_floor_iff)

text \<open> If an i < y for two integers then i \<le> y - 1 (when converted to real).\<close>
lemma less_to_leq:
  fixes y :: real
  assumes "real i < y"
  assumes "y \<in> real_of_int ` UNIV"
  shows "real i \<le> y - 1"
proof -
  from assms(2) obtain j where "y = real_of_int j"
    apply auto done
  obtain k where "j = int k"
    by (smt \<open>y = real_of_int j\<close> assms(1) int_less_real_le nat_0_le of_int_1 of_nat_0_le_iff)
  from this \<open>y = _\<close> assms(1) show ?thesis by auto
qed

text \<open> The value of the maximum of the domain of equidistant point is determined. \<close>
lemma Max_equidistant_points_on_unit_interval_of_bounded:
  fixes x :: real
  assumes "ys \<noteq> []"
  assumes "1 / (2 * length ys) < x" "x \<le> 1 - 1 / (2 * length ys)"
  shows "Max {x' \<in> dom (equidistant_points_on_unit_interval_of ys). x' < x} = (ceiling (length ys * x - 0.5) - 0.5) / length ys"
    (is "_ = ?expr")
proof -
  let ?A = "{x' \<in> (\<lambda>x. (1 / length ys) * (x + 0.5)) ` {0..<length ys}. x' < x}"
  have "Max ?A = ?expr"
  find_theorems "_ ` _" "Max"
  proof (rule Max_eqI)
    show "finite ?A" by simp
    show "y \<le> ?expr" if "y \<in> ?A" for y
    proof -
      show ?thesis
      proof (cases "real (length ys) * x - 1 / 2 \<in> range real_of_int")
        case True
          from that obtain i where "i \<in> {0..<length ys}"
            and y: "y = 1 / real (length ys) * (real i + 5 / 10)" and "y < x" by auto
          have "(real i + 5 / 10) < real (length ys) * x"
            by (metis \<open>y < x\<close> assms(1) divide_less_eq length_greater_0_conv mult.commute mult_numeral_1 numeral_One of_nat_0_less_iff times_divide_eq_right y)
          from this have "real i < real (length ys) * x - 0.5"
            by linarith
          from this have "real i \<le> real (length ys) * x - 1.5"
            apply -
            apply (frule less_to_leq)
            apply (simp add: True)
            by linarith
          from this have "(real i + 5 / 10) \<le> real (length ys) * x - 1"
            apply simp done
          have "1 / real (length ys) > 0" by (simp add: assms(1))
          from this assms y have y2: "y \<le> 1 / real (length ys) * (real (length ys) * x - 1)"
            using \<open>real i + 5 / 10 \<le> real (length ys) * x - 1\<close> real_mult_le_cancel_iff2 by blast
          have "real (length ys) * x - 1 / 2 \<le> real_of_int \<lceil>real (length ys) * x - 1 / 2\<rceil>"
            by simp
          from this have "real (length ys) * x - 1 \<le> real_of_int \<lceil>real (length ys) * x - 1 / 2\<rceil> - 1 / 2"
          proof -
            have "real (length ys) * x - 1 = (real (length ys) * x - 1 / 2) - 1 / 2" by simp
            also have "\<dots> \<le> real_of_int \<lceil>real (length ys) * x - 1 / 2\<rceil> - 1 / 2"
              by linarith
            finally show ?thesis .
          qed
        from this y2 show ?thesis
          apply auto
          find_theorems "?a \<le> ?b \<Longrightarrow> ?b \<le> ?c \<Longrightarrow> ?a \<le> ?c"
          apply (rule order.trans)
          apply assumption
          apply (rule divide_right_mono)
          apply simp apply simp done
          find_theorems "_ / _ \<le> _ / _"
      next
        case False
        then show ?thesis
        proof -
          have "y \<le> 1 / real (length ys) * (real_of_int \<lfloor>real (length ys) * x - 5 / 10\<rfloor> + 5 / 10)"
          proof -
            from that obtain i where "i \<in> {0..<length ys}"
              and "y = 1 / real (length ys) * (real i + 5 / 10)" and "y \<le> x" by auto
            have "i \<le> \<lfloor>real (length ys) * x - 5 / 10\<rfloor>"
        proof -
          have a: "1 / real (length ys) * (real i + 5 / 10) \<le> x"
            using \<open>y = _\<close> \<open>y \<le> x\<close> by blast
          have "(real i + 5 / 10) \<le> real (length ys) * x"
          proof -
            have "(real i + 5 / 10) = real (length ys) * (1 / real (length ys) * (real i + 5 / 10))"
              by (simp add: assms(1))
            also have "\<dots> \<le> real (length ys) * x"
              using a mult_left_mono of_nat_0_le_iff by blast
            finally show ?thesis .
          qed
          from this have "real i \<le> real (length ys) * x - 5 / 10" by linarith
          from this show ?thesis by linarith
        qed
        from this \<open>y = _\<close> show ?thesis
        proof -
          have "real (length ys) > 0" by (simp add: assms(1))
          from \<open>i \<le> floor _\<close> have "(real i + 5 / 10) \<le> real_of_int \<lfloor>real (length ys) * x - 5 / 10\<rfloor> + 5 / 10"
            by linarith
          from this \<open>y = _\<close> \<open>real (length ys) > 0\<close> show ?thesis
            using real_mult_le_cancel_iff2 by fastforce
        qed
      qed
      also have "\<dots> \<le> (real_of_int \<lceil>real (length ys) * x - 5 / 10\<rceil> - 5 / 10) / real (length ys)"
      proof -
        from False
        have "(real_of_int \<lfloor>real (length ys) * x - 5 / 10\<rfloor> + 5 / 10) \<le> (real_of_int \<lceil>real (length ys) * x - 5 / 10\<rceil> - 5 / 10)"
          apply simp
          apply (rule floor_leq_ceiling)
          apply assumption
          done
        from this show ?thesis
          apply simp
          apply (rule divide_right_mono)
           apply simp apply simp done
      qed
      finally show ?thesis .
    qed
    qed qed
    show "?expr \<in> ?A"
    proof -
      have "?expr \<in> (\<lambda>x. 1 / real (length ys) * (real x + 5 / 10)) ` {0..<length ys}"
      proof
        have "real (length ys) * x - 1 / 2 > 0"
          by (metis assms(1) assms(2) diff_gt_0_iff_gt divide_divide_eq_left divide_less_eq length_greater_0_conv mult.commute of_nat_0_less_iff of_nat_mult of_nat_numeral)
        from this have "nat \<lceil>real (length ys) * x - 1 / 2\<rceil> \<ge> 1"
          by linarith
        from this show "(real_of_int \<lceil>real (length ys) * x - 5 / 10\<rceil> - 5 / 10) / real (length ys) =
          1 / real (length ys) * (real (nat \<lceil>real (length ys) * x - 5 / 10\<rceil> - 1) + 5 / 10)"
          using \<open>ys \<noteq> []\<close>
          apply auto done
        have "real (length ys) \<ge> 0" by auto
        have "x \<le> 1"
          by (smt assms(3) divide_less_0_1_iff of_nat_0_le_iff)
        from this have "real (length ys) * x \<le> length ys"
          by (simp add: mult_left_le)
        from this \<open>real (length ys) \<ge> 0\<close> have "real (length ys) * x \<le> length ys + 1 / 2"
          by linarith
        from this have "real (length ys) * x - 1 / 2 \<le> length ys"
          by fastforce
        from this show "nat \<lceil>real (length ys) * x - 5 / 10\<rceil> - 1 \<in> {0..<length ys}"
          apply auto
          using \<open>1 \<le> nat \<lceil>real (length ys) * x - 1 / 2\<rceil>\<close> by linarith
      qed
      moreover have "?expr < x"
      proof -
        have "real_of_int \<lceil>real (length ys) * x - 5 / 10\<rceil> < real (length ys) * x + 5 / 10"
          by linarith
        then have "real_of_int \<lceil>real (length ys) * x - 5 / 10\<rceil> < x * real (length ys) + 5 / 10"
          by (simp add: mult.commute)
        have "real_of_int \<lceil>real (length ys) * x - 5 / 10\<rceil> - 5 / 10 < x * real (length ys)"
          using \<open>real_of_int \<lceil>real (length ys) * x - 5 / 10\<rceil> < x * real (length ys) + 5 / 10\<close> by linarith
        from this show "(real_of_int \<lceil>real (length ys) * x - 5 / 10\<rceil> - 5 / 10) / real (length ys) < x"
          apply auto
          by (simp add: assms(1) divide_less_eq)
      qed
      ultimately show ?thesis by auto
    qed
  qed
  from this show ?thesis
    unfolding equidistant_points_on_unit_interval_of_def by simp
qed

text \<open> The lemma determines the values of equidistant point on the unit interval. \<close>
lemma equidistant_points_on_unit_interval_of_eq_nth2:
  fixes i :: int
  assumes "0 \<le> i" "nat i < length ys"
  shows "the (equidistant_points_on_unit_interval_of ys ((real_of_int i + 5 / 10) / size ys)) = ys ! (nat i)"
proof -
  let ?xs = "map (\<lambda>x. (real x + 1 / 2) / real (length ys)) [0..<length ys]"
  have "distinct ?xs" by (auto intro!: inj_onI simp add: distinct_map)
  have eq: "(real_of_int i + 1 / 2) / real (length ys) = ?xs ! nat i"
    using assms by auto
  show ?thesis
    unfolding equidistant_points_on_unit_interval_of_def
    apply simp
    apply (subst eq)
    thm map_of_zip_nth
    apply (subst map_of_zip_nth)
       apply simp
      apply (rule \<open>distinct ?xs\<close>)
     apply (rule assms)
    apply simp done
qed

text \<open> The lemma gives an alternative characterization of the values of equidistant point on the unit interval. \<close>
lemma equidistant_points_on_unit_interval_of_eq_nth1:
  fixes i :: int
  assumes "1 \<le> i" "i \<le> length ys"
  shows "the (equidistant_points_on_unit_interval_of ys ((real_of_int i - 5 / 10) / size ys)) = ys ! nat (i - 1)"
proof -
  (* todo: size ys = real (length ys); which is better to write down? *)
  let ?f = "\<lambda>x. the (equidistant_points_on_unit_interval_of ys (x / size ys))"
  have "?f (real_of_int i - 5 / 10) = ?f (real_of_int (i - 1) + 5 / 10)" by force
  also have "\<dots> = ys ! nat (i - 1)"
    using assms by (simp only: equidistant_points_on_unit_interval_of_eq_nth2)
  finally show ?thesis .
qed

text \<open> The definition contains executable version of the percentile function which is close to the
 * Java implementation in the OpenSIMM implementation. \<close>
definition percentile_impl :: "real list \<Rightarrow> real \<Rightarrow> real"
where
  "percentile_impl values level_orig =
    (let   level = level_orig - epsilon;
           (size :: real) = (real (length values));
           (sorted :: (real list)) = sort values;
           i = (ceiling (size * level - 0.5));
           (lower :: real) = (i - 0.5) / size;
           (upper ::real) = (i + 0.5) / size;
           (lower_value :: real)  = sorted ! (nat (i-1));
           (upper_value :: real)  = sorted ! (nat i)
    in lower_value + (level - lower) * (upper_value - lower_value) / (upper - lower))"

lemma percentile_impl_var:
    "percentile_impl values level =
    (let
           (size :: real) = (real (length values));
           (sorted :: (real list)) = sort values;
           i = (ceiling (size * (level - epsilon) - 0.5));
           (lower :: real) = (i - 0.5) / size;
           (upper ::real) = (i + 0.5) / size;
           (lower_value :: real)  = sorted ! (nat (i-1));
           (upper_value :: real)  = sorted ! (nat i)
    in lower_value + ((level - epsilon) - lower) * (upper_value - lower_value) / (upper - lower))"
  by (metis percentile_impl_def)

text \<open> The theorem states the equivalence of the abstract definition of the percentile function from
 * the Percentile theory and the computational version in the standard interval. \<close>
theorem percentile_java_equiv:
  assumes "values \<noteq> []"
  assumes "1 / real (2 * length values) < (level - epsilon)" (* todo: lesseq instead of less *)
  assumes "(level - epsilon) \<le> 1 - 1 / real (2 * length values)"
  shows "Percentile.percentile values level = percentile_impl values level"
proof -
  from assms(2) have "(level - epsilon) \<noteq> 1 / real (2 * length values)" by linarith
  let ?def = "(let p = equidistant_points_on_unit_interval_of (sort values);
         (x1, x2) = (Max {x' \<in> dom p. x' < (level - epsilon)}, Min {x' \<in> dom p. (level - epsilon) \<le> x'});
         (y1, y2) = (the (p x1), the (p x2))
     in linear (x1, y1) (x2, y2) (level - epsilon))"
  {
    fix size sorted i lower upper lower_value upper_value
    assume "size = real (length values)"
    assume "sorted = sort values"
    assume "i = \<lceil>size * (level - epsilon) - 5 / 10\<rceil>"
    assume "lower = (real_of_int i - 5 / 10) / size"
    assume "upper = (real_of_int i + 5 / 10) / size"
    assume "lower_value = sorted ! nat (i - 1)"
    assume "upper_value = sorted ! nat i"
    have "length values = length sorted" and "sorted \<noteq> []" (* is this noteq Nil fact needed? *) and "length sorted > 0"
      using \<open>sorted = _\<close> \<open>_ \<noteq> []\<close> apply auto
      by (metis length_0_conv length_sort) (* todo: find a better lemma *)
    have "lower_value + ((level - epsilon) - lower) * (upper_value - lower_value) / (upper - lower) =
      linear (lower, lower_value) (upper, upper_value) (level - epsilon)"
      apply (subst linear_eq[symmetric]) ..
    also have "\<dots> = ?def"
    proof -
      have b1: "0 \<le> \<lceil>real (length sorted) * (level - epsilon) - 5 / 10\<rceil>"
      proof -
        have "- 1 / 2 \<le> real (length sorted) * (level - epsilon) - 5 / 10"
          apply simp
          by (meson assms(2) le_less_trans less_eq_real_def of_nat_0_le_iff zero_le_divide_1_iff zero_le_mult_iff)
          (* strange proof? *)
        from this show ?thesis by linarith
      qed
      have b2: "nat \<lceil>real (length sorted) * (level - epsilon) - 5 / 10\<rceil> < length sorted"
      proof -
        have "real (length sorted) * (level - epsilon) \<le> real (length sorted) - 1 / 2"
        proof -
          from assms(3) have "(level - epsilon) \<le> 1 - 1 / real (2 * length sorted)"
            using \<open>length values = length sorted\<close> by simp
          from this have "real (length sorted) * (level - epsilon) \<le> real (length sorted) * (1 - 1 / real (2 * length sorted))"
            using \<open>0 < length sorted\<close> by auto
          also have "\<dots> = real (length sorted) - 1 / 2"
            apply simp
            by (metis \<open>length values = length sorted\<close> \<open>size = real (length values)\<close> assms(1)
                      length_0_conv mult.commute mult.right_neutral mult_cancel_left
                      nonzero_mult_divide_mult_cancel_left of_nat_eq_iff of_nat_mult
                      right_diff_distrib' times_divide_eq_right)
          finally show ?thesis .
        qed
        from this show ?thesis
          using b1 by linarith
      qed
      have b3: "1 \<le> \<lceil>real (length sorted) * (level - epsilon) - 5 / 10\<rceil>"
      proof -
        show ?thesis
          using assms(2) \<open>length _ = _\<close> \<open>length sorted > 0\<close>
          by (simp add: Groups.mult_ac(2) divide_less_eq)
      qed
      from b2 have b4: "\<lceil>real (length sorted) * (level - epsilon) - 5 / 10\<rceil> \<le> int (length sorted)" by simp
      have "Max {x' \<in> dom (equidistant_points_on_unit_interval_of sorted). x' < (level - epsilon)} = lower"
        using \<open>lower = _\<close> \<open>i = _\<close> \<open>size = _\<close> \<open>length values = _\<close>
        apply (subst Max_equidistant_points_on_unit_interval_of_bounded)
           prefer 4
           apply simp
        using \<open>sorted \<noteq> []\<close> apply blast
        using assms(2) apply auto[1]
        using assms(3) by auto
      moreover have "Min {x' \<in> dom (equidistant_points_on_unit_interval_of sorted). (level - epsilon) \<le> x'} = upper"
        using \<open>upper = _\<close> \<open>i = _\<close> \<open>size = _\<close> \<open>length values = _\<close>
        apply (subst Min_equidistant_points_on_unit_interval_of_bounded)
         prefer 4
         apply simp
        using \<open>sorted \<noteq> []\<close> apply blast
        using assms(2) apply auto[1]
        using assms(3) by auto
      moreover have "the (equidistant_points_on_unit_interval_of sorted lower) = lower_value"
        using \<open>i = _\<close>  \<open>size = _\<close> \<open>lower_value = _\<close> \<open>lower = _\<close> \<open>length values = _\<close>
        apply (simp only:)
        apply (subst equidistant_points_on_unit_interval_of_eq_nth1)
        apply (rule b3)
        apply (rule b4)
        apply simp
        done
      moreover have "the (equidistant_points_on_unit_interval_of sorted upper) = upper_value"
        using \<open>i = _\<close>  \<open>size = _\<close> \<open>upper_value = _\<close> \<open>upper = _\<close> \<open>length values = _\<close>
        apply (simp only:)
        apply (subst equidistant_points_on_unit_interval_of_eq_nth2)
        apply (rule b1)
        apply (rule b2)
        apply simp done
      ultimately show ?thesis
        using \<open>sorted = _\<close> by simp
    qed
    finally have "lower_value + ((level - epsilon) - lower) * (upper_value - lower_value) / (upper - lower) =
       ?def" by simp (* intermediate proof step not needed? change proof structure? *)
  }
  from this \<open>(level - epsilon) \<noteq> _\<close> show ?thesis
    by (simp add: percentile_alternative_pseudo_def percentile_impl_var)
qed

(*
lemma percentile_impl_lower_bound:
  assumes "values \<noteq> []"
  assumes "1 / real (2 * length values) < level"
  assumes "level \<le> 1 - 1 / real (2 * length values)"
  shows "Min (set values) \<le> percentile_impl values level"
  using assms
  apply -
  apply (subst percentile_java_equiv[symmetric])
  apply assumption+
  apply (rule percentile_lower_bound)
  apply assumption
  apply simp done

lemma percentile_impl_upper_bound:
  assumes "values \<noteq> []"
  assumes "1 / real (2 * length values) < level"
  assumes "level \<le> 1 - 1 / real (2 * length values)"
  shows "percentile_impl values level \<le> Max (set values)"
  using assms
  apply -
  apply (subst percentile_java_equiv[symmetric])
  apply assumption+
  apply (rule percentile_upper_bound)
  apply assumption
  apply simp done

lemma
  assumes "values \<noteq> []"
  assumes "1 / real (2 * length values) < level"
  assumes "level' \<le> 1 - 1 / real (2 * length values)"
  assumes "level \<le> level'"
  shows "percentile_impl values level \<le> percentile_impl values level'"
  using assms
  apply -
  apply (subst percentile_java_equiv[symmetric])
  apply assumption+
  apply simp
  apply (subst percentile_java_equiv[symmetric])
  apply assumption+
  apply simp
  apply assumption+
  apply (rule percentile_monotonic)
  apply assumption+
  apply simp
  apply assumption+
  done
*)
export_code percentile_impl in Scala

end


theory SC_Cut
imports SC
begin

subsubsection\<open>Contraction\<close>

text\<open>First, we need contraction:\<close>
lemma contract:
  "(F,F,\<Gamma> \<Rightarrow> \<Delta> \<longrightarrow> F,\<Gamma> \<Rightarrow> \<Delta>) \<and> (\<Gamma> \<Rightarrow> F,F,\<Delta> \<longrightarrow> \<Gamma> \<Rightarrow> F,\<Delta>)"
proof(induction F arbitrary: \<Gamma> \<Delta>)
  case (Atom k)
  have "Atom k, Atom k, \<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> Atom k, \<Gamma> \<Rightarrow> \<Delta>"
    by(induction "Atom k, Atom k, \<Gamma>" \<Delta> arbitrary: \<Gamma> rule: SCp.induct)
      (auto dest!: multi_member_split intro!: SCp.intros(3-) simp add: lem2 lem1 SCp.intros)
  moreover have "\<Gamma> \<Rightarrow> Atom k, Atom k, \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> Atom k, \<Delta>"
    by(induction "\<Gamma>" "Atom k, Atom k, \<Delta>" arbitrary: \<Delta> rule: SCp.induct)
      (auto dest!: multi_member_split intro!: SCp.intros(3-) simp add: lem2 lem1 SCp.intros)
  ultimately show ?case by blast
next
  case Bot
  have "\<bottom>, \<bottom>, \<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> \<bottom>, \<Gamma> \<Rightarrow> \<Delta>" by(induction "\<bottom>, \<bottom>, \<Gamma>" \<Delta> rule: SCp.induct; blast)
  moreover have "(\<Gamma> \<Rightarrow> \<bottom>, \<bottom>, \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<bottom>, \<Delta>)"
    using Bot_delR by fastforce
  ultimately show ?case by blast
next
  case (Not F)
  then show ?case by (meson NotL_inv NotR_inv SCp.NotL SCp.NotR)
next
  case (And F1 F2) then show ?case by(auto intro!: SCp.intros(3-) dest!: AndR_inv AndL_inv) (metis add_mset_commute)
next
  case (Or F1 F2) then show ?case by(auto intro!: SCp.intros(3-) dest!: OrR_inv OrL_inv) (metis add_mset_commute)
next
  (* Okay, so the induction hypothesis is poison for the simplifier.
     For some reason, this didn't cause trouble for the other two cases, but here, it does. *)
  case (Imp F1 F2) show ?case by(auto dest!: ImpR_inv ImpL_inv intro!: SCp.intros(3-)) (insert Imp.IH; blast)+
qed
corollary
  shows contractL: "F, F, \<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> F, \<Gamma> \<Rightarrow> \<Delta>"
  and contractR:   "\<Gamma> \<Rightarrow> F, F, \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> F, \<Delta>"
  using contract by blast+

subsubsection\<open>Cut\<close>

text\<open>Which cut rule we show is up to us:\<close>
lemma cut_cs_cf:
  assumes context_sharing_Cut: "\<And>(A::'a formula) \<Gamma> \<Delta>. \<Gamma> \<Rightarrow> A,\<Delta> \<Longrightarrow> A,\<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta>"
  shows context_free_Cut: "\<Gamma> \<Rightarrow> (A::'a formula),\<Delta> \<Longrightarrow> A,\<Gamma>' \<Rightarrow> \<Delta>' \<Longrightarrow> \<Gamma> + \<Gamma>' \<Rightarrow> \<Delta> + \<Delta>'"
  by(intro context_sharing_Cut[of "\<Gamma> + \<Gamma>'" A "\<Delta> + \<Delta>'"])
    (metis add.commute union_mset_add_mset_left weakenL_set weakenR_set)+
lemma cut_cf_cs:
  assumes context_free_Cut: "\<And>(A::'a formula) \<Gamma> \<Gamma>' \<Delta> \<Delta>'. \<Gamma> \<Rightarrow> A,\<Delta> \<Longrightarrow> A,\<Gamma>' \<Rightarrow> \<Delta>' \<Longrightarrow> \<Gamma> + \<Gamma>' \<Rightarrow> \<Delta> + \<Delta>'"
  shows context_sharing_Cut: "\<Gamma> \<Rightarrow> (A::'a formula),\<Delta> \<Longrightarrow> A,\<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta>"
proof -
  have contract\<Gamma>\<Gamma>: "\<Gamma>+\<Gamma>' \<Rightarrow> \<Delta> \<Longrightarrow> \<Gamma>' \<subseteq># \<Gamma> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta>" for \<Gamma> \<Gamma>' \<Delta>
  proof(induction "\<Gamma>'" arbitrary: \<Gamma>)
    case empty thus ?case using weakenL_set by force
  next
    case (add x \<Gamma>' \<Gamma>)
    from add.prems(2) have "x \<in># \<Gamma>" by (simp add: insert_subset_eq_iff)
    then obtain \<Gamma>'' where \<Gamma>[simp]: "\<Gamma> = x,\<Gamma>''" by (meson multi_member_split)
    from add.prems(1) have "x,x,\<Gamma>'' + \<Gamma>' \<Rightarrow> \<Delta>" by simp
    with contractL have "x, \<Gamma>'' + \<Gamma>' \<Rightarrow> \<Delta>" .
    with add.IH[of \<Gamma>] show ?case using \<Gamma>  add.prems(2) subset_mset.order.trans by force
  qed
  have contract\<Delta>\<Delta>: "\<Gamma> \<Rightarrow> \<Delta>+\<Delta>' \<Longrightarrow> \<Delta>' \<subseteq># \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta>" for \<Gamma> \<Delta> \<Delta>'
  proof(induction "\<Delta>'" arbitrary: \<Delta>)
    case empty thus ?case using weakenL_set by force
  next
    case (add x \<Delta>' \<Delta>)
    from add.prems(2) have "x \<in># \<Delta>" by (simp add: insert_subset_eq_iff)
    then obtain \<Delta>'' where \<Delta>[simp]: "\<Delta> = x,\<Delta>''" by (metis multi_member_split)
    from add.prems(1) have "\<Gamma> \<Rightarrow> x,x,\<Delta>'' + \<Delta>'" by simp
    with contractR have "\<Gamma> \<Rightarrow> x, \<Delta>'' + \<Delta>'" .
    with add.IH[of \<Delta>] show ?case using \<Delta> add.prems(2) subset_mset.order.trans by force
  qed
  show "\<Gamma> \<Rightarrow> A,\<Delta> \<Longrightarrow> A,\<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta>"
    using context_free_Cut[of \<Gamma> A \<Delta> \<Gamma> \<Delta>] contract\<Gamma>\<Gamma> contract\<Delta>\<Delta>
    by blast
qed
(* since these are the only lemmas that need contraction on sets, I've decided to transfer those in place *)
text\<open>According to Troelstra and Schwichtenberg~\cite{troelstra2000basic}, the sharing variant is the one we want to prove.\<close>

lemma Cut_Atom_pre: "Atom k,\<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> Atom k,\<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta>"
proof(induction "Atom k,\<Gamma>" "\<Delta>" arbitrary: \<Gamma> rule: SCp.induct)
  case BotL
  hence "\<bottom> \<in># \<Gamma>" by simp
  thus ?case using SCp.BotL by blast
next
  case (Ax l \<Delta>)
  show ?case proof cases
    assume "l = k"
    with \<open>Atom l \<in># \<Delta>\<close> obtain \<Delta>' where "\<Delta> = Atom k, \<Delta>'" by (meson multi_member_split)
    with \<open>\<Gamma> \<Rightarrow> Atom k, \<Delta>\<close> have "\<Gamma> \<Rightarrow> \<Delta>" using contractR by blast
    thus ?thesis by auto
  next
    assume "l \<noteq> k"
    with \<open>Atom l \<in># Atom k, \<Gamma>\<close> have "Atom l \<in># \<Gamma>" by simp
    with \<open>Atom l \<in># \<Delta>\<close> show ?thesis using SCp.Ax[of l] by blast
  qed
next
  case NotL
  thus ?case by(auto simp: add_eq_conv_ex intro!: SCp.NotL dest!: NotL_inv)
next
  case NotR
  then show ?case by(auto intro!: SCp.NotR dest!: NotR_inv)
next
  case AndL
  thus ?case by(auto simp: add_eq_conv_ex intro!: SCp.AndL dest!: AndL_inv)
next
  case AndR
  then show ?case by(auto intro!: SCp.AndR dest!: AndR_inv)
next
  case OrL
  thus ?case by(auto simp: add_eq_conv_ex intro!: SCp.OrL dest!: OrL_inv)
next
  case OrR
  thus ?case by(auto intro!: SCp.OrR dest!: OrR_inv)
next
  case ImpL
  thus ?case by(auto simp: add_eq_conv_ex intro!: SCp.ImpL dest!: ImpL_inv)
next
  case ImpR
  then show ?case by (auto dest!: ImpR_inv intro!: SCp.ImpR)
qed

text\<open>We can show the admissibility of the cut rule by induction on the cut formula
(or, if you will, as a procedure that splits the cut into smaller formulas that get cut).
The only mildly complicated case is that of cutting in an @{term "Atom k"}.
It is, contrary to the general case, only mildly complicated, since the cut formula can only appear principal in the axiom rules.\<close>

theorem cut: "\<Gamma> \<Rightarrow> F,\<Delta> \<Longrightarrow> F,\<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta>"
proof(induction F arbitrary: \<Gamma> \<Delta>)
  case Atom thus ?case using Cut_Atom_pre by metis
next
  case Bot thus ?case using Bot_delR by fastforce
next
  case Not with  NotL_inv NotR_inv show ?case by blast
next
  case And thus ?case by (meson AndL_inv AndR_inv weakenL)
next
  case Or thus ?case by (metis OrL_inv OrR_inv weakenR)
next
  case (Imp F G)
(* an automatic proof:
  thus ?case by (meson ImpL_inv ImpR_inv weakenR)
   a readable one: *)
  from ImpR_inv \<open>\<Gamma> \<Rightarrow> F \<^bold>\<rightarrow> G, \<Delta>\<close> have R: "F, \<Gamma> \<Rightarrow> G, \<Delta>" by blast
  from ImpL_inv \<open>F \<^bold>\<rightarrow> G, \<Gamma> \<Rightarrow> \<Delta>\<close> have L: "\<Gamma> \<Rightarrow> F, \<Delta>" "G, \<Gamma> \<Rightarrow> \<Delta>" by blast+
  from L(1) have "\<Gamma> \<Rightarrow> F, G, \<Delta>" using weakenR add_ac(3) by blast
  with R have "\<Gamma> \<Rightarrow> G, \<Delta>" using Imp.IH(1) by simp
  with L(2) show "\<Gamma> \<Rightarrow> \<Delta>" using Imp.IH(2) by clarsimp
qed
  (* For this proof to work with FOL, I think we would need very special inversion rules.
  For example, for \<forall>R, we would need that there's a (finite!) multiset of substitutions S, such that
  instead of having \<forall>x.F,\<Delta>, having {F[s/x] | s \<in> S} + \<Delta> is enough. I don't think that holds,
  but we may be able to cheat ourselves around it\<dots> *)

corollary cut_cf: "\<lbrakk> \<Gamma> \<Rightarrow> A, \<Delta>; A, \<Gamma>' \<Rightarrow> \<Delta>'\<rbrakk> \<Longrightarrow> \<Gamma> + \<Gamma>' \<Rightarrow> \<Delta> + \<Delta>'"
  using cut_cs_cf cut by metis

lemma assumes cut: "\<And> \<Gamma>' \<Delta>' (A::'a formula). \<lbrakk>\<Gamma>' \<Rightarrow> A, \<Delta>'; A, \<Gamma>' \<Rightarrow> \<Delta>'\<rbrakk> \<Longrightarrow> \<Gamma>' \<Rightarrow> \<Delta>'"
  shows contraction_admissibility: "F,F,\<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> (F::'a formula),\<Gamma> \<Rightarrow> \<Delta>"
  by(rule cut[of "F,\<Gamma>" F \<Delta>, OF extended_Ax]) simp_all
(* yes, unpublished Chapman p 2/5, second to last paragraph. that's right. we can prove contraction with cut. but what's that good for? *)

end