\<^marker>\<open>creator "Maximilian P.L. Haslbeck"\<close>
chapter \<open>Probabilistic Quantitative Hoare Logic\<close>
theory Probabilistic_Quantitative_Hoare_Logic
imports MDP_Semantics
begin

paragraph \<open>Summary\<close>

text \<open>This theory formalizes the probabilistic quantitative Hoare Logic from @{cite ngo2018bounded}.
  As a underlying semantics we use  @{term ert} -- the expected running time semantics of PGCL.
  This is a formalization of the theory in @{cite kaminskiESOP16} by Johannes Hölzl.

  We introduce a Hoare Logic to reason about the expected running time of PGCL programs.
  We prove soundness and completeness for the logic. Also, we come up with a VCG and prove it
  sound and complete.\<close>

paragraph \<open>Main Definitions\<close>

text \<open>
  \<^item> \<Turnstile> {P} c {Q}: a valid Hoare triple
  \<^item> @{text \<open>\<turnstile>\<^sub>Q {P} c {Q}\<close>}: the inference rules for the Hoare logic
  \<^item> time, pre, vc: the functions for the VCG.
\<close>

paragraph \<open>Main Theorems\<close>

text \<open>
  \<^item> Hoare Logic soundness and completeness: hoareQ_sound hoareQ_complete
  \<^item> VCG soundness and completeness: vc_sound' vc_completeness
\<close>

section \<open>Hoare Logic\<close>

definition Qw ("\<Turnstile> {(1_)}/ (_)/ { (1_)}" 50) where "\<Turnstile> {P} c {Q} \<equiv> \<forall>s. P s \<ge> ert c Q s"

lemma QwI: "ert c Q \<le> P \<Longrightarrow> \<Turnstile> {P} c {Q}"
  by(auto dest: le_funD simp: Qw_def)

lemma QwD: "\<Turnstile> {P} c {Q} \<Longrightarrow> ert c Q \<le> P"
  by(auto intro: le_funI simp: Qw_def)

lemma "ert c Q s \<ge> ert c 0 s"
  by (simp add: le_funD monoD mono_ert)

lemma ParRulew: assumes "Qw P c1 R" and "Qw P c2 R"
  shows "Qw P (Par c1 c2) R"
  using assms unfolding Qw_def apply auto done

definition lift :: "('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> ennreal" where "lift f s= (if f s then 0 else \<infinity>)"

lemma IfRulew: assumes "Qw (%s. P s + lift b s) c1 R" and "Qw (%s. P s + lift (\<lambda>s. ~ b s) s ) c2 R"
  shows "Qw (\<lambda>s. 1+ P s) (If b c1 c2) R"
  apply(auto intro!: le_funI QwI)
  subgoal using assms(1)[THEN QwD, unfolded lift_def, THEN le_funD]
      by (metis add.right_neutral)
    subgoal for s using assms(2)[unfolded Qw_def lift_def]
      by (metis add.right_neutral)
  done

lemma HaltRulew: "Qw P (Halt) R"
  by (simp add: Qw_def)

lemma SkipRulew: "Qw (%s. P s + 1) (Skip) P"
  by (simp add: Qw_def)

lemma EmptyRulew: "Qw P (Empty) P"
  by (simp add: Qw_def)

lemma SeqRulew': assumes "Qw P c1 Q" and "Qw Q c2 R"
  shows "Qw P (c1;;c2) R"
  using assms mono_ert[THEN monoD]
  apply(auto intro!: QwI dest!: QwD)
  using dual_order.trans by blast

lemma SeqRulew: assumes "Qw P c1 Q" and "Qw Q c2 R"
  shows "Qw P (c1;;c2) R"
  unfolding Qw_def
proof
  fix s
  from assms have 1: "\<forall>s. P s \<ge> ert c1 Q s"
      and 2: "\<forall>s. Q s \<ge> ert c2 R s" unfolding Qw_def by auto
  from 2 have 3: "Q \<ge> ert c2 R" by (simp add: le_funI)

  have "ert (c1;; c2) R s = ert c1 (ert c2 R) s"
    apply simp done
  also have "\<dots> \<le> ert c1 Q s" using monoD[OF mono_ert 3]
    by (auto dest: le_funD)
  also have "\<dots> \<le> P s" using 1 by auto
  finally
  show "ert (c1;; c2) R s \<le> P s" .
qed

lemma ConseqRulew:
assumes "P' \<ge> P" "Q \<ge> Q'" "Qw P c Q"
shows "Qw P' c Q'"
  unfolding Qw_def
proof
  fix s
  from assms(3)[unfolded Qw_def] have "ert c Q s \<le> P s" by auto

  have "ert c Q' s \<le> ert c Q s" using monoD[OF mono_ert assms(2)]
    by (simp add: le_funD)
  also have "\<dots> \<le> P s" using assms(3)[unfolded Qw_def] by auto
  also have "\<dots> \<le> P' s" using assms(1)
    by (simp add: le_funD)
  finally show "ert c Q' s \<le> P' s" .
qed

lemma chara:  "ert (While g c) R = (%x. 1 + (if g x then ert c (ert (While g c) R) x else R x))"
proof -
  let ?g = "(\<lambda>W x. 1 + (if g x then ert c W x else R x))"
  have M: "mono ?g"
    apply rule
    by (simp add: le_funD le_funI monoD mono_ert)

  have A: "ert (While g c) R = lfp  ?g"
    apply simp done thm lfp_unfold
  also have "\<dots> = ?g (lfp ?g)"
    apply(rule lfp_unfold) by fact
  also have "\<dots> = ?g (ert (While g c) R)" unfolding A[symmetric] by simp
  finally show "ert (While g c) R = (%x. 1 + (if g x then ert c (ert (While g c) R) x else R x))" .
qed

lemma WhileRulew: assumes "Qw (%s. P s + lift g s) c (%s. P s + 1)"
  shows "Qw (%s. P s + 1) (While g c) (%s. P s +  lift (\<lambda>s. \<not>g s) s)" (is "Qw ?P1 ?W ?R")
    unfolding Qw_def
proof
  fix s
  from assms have I: "\<And>s. P s + lift g s  \<ge> ert c (%s. P s + 1) s" unfolding Qw_def by auto

  let ?g = "(\<lambda>W x. 1 + (if g x then ert c W x else ?R x))"

  { fix s
    have "?g (%s. P s + 1) s \<le> (%s. P s + 1) s"
    proof (cases "P s < \<infinity>")
      case False
      then show ?thesis
        using top.not_eq_extremum by fastforce
    next
      case True
      show ?thesis
      proof (cases "P s + lift g s < \<infinity>")
        case True
        then have g: "g s" unfolding lift_def
          using less_irrefl by fastforce

        have "?g (%s. P s + 1) s = 1 + ert c (%s. P s + 1) s" using g by auto
        also have "\<dots> \<le> 1 + P s + lift g s"  using I by auto
        also have "\<dots> =  1 + P s" using g unfolding lift_def by auto
        finally show ?thesis by simp
      next
        case False
        with True have "P s + lift (%s. \<not>g s) s  < \<infinity>" unfolding lift_def by auto
        then have g: "\<not>g s" unfolding lift_def
          using less_irrefl by fastforce

        have "?g (%s. P s + 1) s = 1 + lift (\<lambda>s. \<not> g s) s + P s" using g by auto
        also have "\<dots> = (%s. P s + 1) s" using g unfolding lift_def by auto
        finally show ?thesis by simp
      qed
    qed
  }
  then have "?g (%s. P s + 1) \<le> (%s. P s + 1)"
    by (simp add: le_fun_def)
  then have "lfp ?g \<le> (%s. P s + 1)"
    by (simp add: lfp_lowerbound)      (* "park's theorem" *)
  then have "ert (While g c) ?R \<le> (%s. P s + 1)" by auto
  then show "ert (WHILE g DO c) ?R s \<le> P s + 1"
    by (simp add: le_fun_def)
qed

lemma assign_easy:   "(\<And>i s. 1 + Q i \<le> p s) \<Longrightarrow> Qw p (Assign (\<lambda>s. return_pmf i)) Q"
  unfolding Qw_def by auto

lemma assign_easy':   "(\<And>s. 1 + Q (f s) \<le> p s) \<Longrightarrow> Qw p (Assign (\<lambda>s. return_pmf (f s))) Q"
  unfolding Qw_def by auto

lemma "(\<And>s. 1 + integral\<^sup>N (measure_pmf (u s)) Q \<le> P s) \<Longrightarrow> Qw P (Assign u) Q"
  unfolding Qw_def apply simp done

lemma assign: fixes u::"'a \<Rightarrow> 'a pmf"
  assumes I: "\<And>i. Qw (p i) (Assign (\<lambda>s. return_pmf i)) Q"
    (* p i can be set to infinity for values i that are not reached by u
       this simplifies showing I for it, while being easy to show P for it,
     *)
    and P: "\<And>s. P s = (\<lambda>x. \<integral>\<^sup>+i. p i s \<partial>u x) s"
    shows  "Qw P (Assign u) Q"
  unfolding Qw_def
proof
  fix s
  from I have "\<And>s i . p i s \<ge> 1 +  (\<lambda>x. \<integral>\<^sup>+y. Q y \<partial>(\<lambda>s. return_pmf i) x) s" unfolding Qw_def by auto
  then have I: "\<And>s i . p i s \<ge> 1 + Q i" by simp

  have "ert (Assign u) Q s =  (\<lambda>x. \<integral>\<^sup>+y. 1 + Q y \<partial>u x) s"  by (auto simp: nn_integral_add)
  also have "\<dots> \<le> (\<lambda>x. \<integral>\<^sup>+y. p y s \<partial>u x) s" using I
    by (simp add: nn_integral_mono)
  also have "\<dots> = P s" using P by auto
  finally show "ert (Assign u) Q s \<le> P s" .
qed

lemma fixes s::nat
  shows "Qw (\<lambda>_. 1) (Assign (\<lambda>s. return_pmf (s+1))) (\<lambda>_. 0)"
  apply(rule assign[where p="%i s. (if i=s+1 then 1 else \<infinity>)"])
  subgoal for i unfolding Qw_def by simp
  subgoal by simp
  done

lemma fixes s::nat
  assumes [simp]: "0 \<le> p" "p \<le> 1"
  shows "Qw (\<lambda>_. 1) (Assign (%s. map_pmf (%b. if b then s else s+1) (bernoulli_pmf p))) (\<lambda>_. 0)"
  apply(rule assign[where p="%i s. (if i=s \<or> i=s+1 then 1 else \<infinity>)"])
  subgoal for i unfolding Qw_def by simp
  subgoal for s apply simp using assms
    by (metis add.right_neutral add_diff_eq cancel_comm_monoid_add_class.diff_cancel diff_add_eq diff_ge_0_iff_ge ennreal_1 ennreal_plus)
  done

subsection "inference rules"

type_synonym 'a qassn = "'a \<Rightarrow> ennreal" (* time bound *)

inductive
  hoareQ :: "'a qassn \<Rightarrow> 'a pgcl \<Rightarrow> 'a qassn \<Rightarrow> bool" ("\<turnstile>\<^sub>Q ({(1_)}/ (_)/ {(1_)})" 50)
where

Empty:  "\<turnstile>\<^sub>Q {P} Empty {P}"  |

Skip:  "\<turnstile>\<^sub>Q {\<lambda>s. 1 + P s} Skip {P}"  |

Halt:  "\<turnstile>\<^sub>Q {Q} Halt {P}"  |

Assign:  "(\<And>s. 1 + integral\<^sup>N (measure_pmf (u s)) Q \<le> P s)
               \<Longrightarrow> \<turnstile>\<^sub>Q {P} Assign u { Q }"  |

If: "\<lbrakk> \<turnstile>\<^sub>Q {\<lambda>s. P s + lift b s} c\<^sub>1 { Q};
       \<turnstile>\<^sub>Q {\<lambda>s. P s + lift (%s. \<not> b s) s} c\<^sub>2 { Q} \<rbrakk>
  \<Longrightarrow> \<turnstile>\<^sub>Q {\<lambda>s. 1 + P s} If b c\<^sub>1 c\<^sub>2 { Q }"  |

Seq: "\<lbrakk> \<turnstile>\<^sub>Q { P\<^sub>1 } c\<^sub>1 { P\<^sub>2 }; \<turnstile>\<^sub>Q {P\<^sub>2} c\<^sub>2 { P\<^sub>3 }\<rbrakk> \<Longrightarrow> \<turnstile>\<^sub>Q {P\<^sub>1} c\<^sub>1;;c\<^sub>2 {P\<^sub>3}"  |

Par: "\<lbrakk> \<turnstile>\<^sub>Q { P } c\<^sub>1 { Q }; \<turnstile>\<^sub>Q {P} c\<^sub>2 { Q }\<rbrakk> \<Longrightarrow> \<turnstile>\<^sub>Q {P} Par c\<^sub>1 c\<^sub>2 {Q}"  |

While:
  "\<lbrakk>   \<turnstile>\<^sub>Q { %s. I s + lift b s } c { %t. I t + 1 }   \<rbrakk>
   \<Longrightarrow> \<turnstile>\<^sub>Q {\<lambda>s. I s + 1 } WHILE b DO c {\<lambda>s.  I s + lift (%s. \<not> b s) s  }" |

conseq: "\<lbrakk> \<turnstile>\<^sub>Q {P}c{Q} ; P  \<le> P' ; Q'  \<le> Q  \<rbrakk> \<Longrightarrow>
           \<turnstile>\<^sub>Q {P'}c{ Q'}"

lemma hoareQ_sound: "\<turnstile>\<^sub>Q {P} c {Q} \<Longrightarrow> \<Turnstile> {P} c {Q}"
proof (induction rule: hoareQ.induct)
  case (If P b c\<^sub>1 Q c\<^sub>2)
  then show ?case using IfRulew by blast
next
  case (Seq P\<^sub>1 c\<^sub>1 P\<^sub>2 c\<^sub>2 P\<^sub>3)
  then show ?case using SeqRulew by blast
next
  case (While I b c)
  then show ?case  using WhileRulew by blast
next
  case (conseq P c Q P' Q')
  then show ?case using ConseqRulew by blast
qed  (auto simp: Qw_def)

subsection \<open>completeness\<close>

lemma hoareQ_complete_aux: "\<turnstile>\<^sub>Q {ert c Q} c {Q}"
proof (induct c arbitrary: Q)
  case Skip
  then show ?case by (auto intro: hoareQ.Skip)
next
  case (Par c1 c2)
  show ?case by (auto intro!: hoareQ.Par conseq[OF Par(1)] conseq[OF Par(2)] intro: le_funI)
next
  case (If b c1 c2)
  show ?case by(auto intro!: hoareQ.If conseq[OF If(1)] conseq[OF If(2)] intro: le_funI simp: lift_def add_top)
next
  case (While b c)
  show ?case
    apply(rule conseq)
      apply(rule hoareQ.While[where I="%s. (if b s then ert c (ert (WHILE b DO c) Q) s else Q s)"])
      apply(rule conseq)
        by (auto intro!: While[of "ert (WHILE b DO c) Q"] le_funI  simp del: ert.simps simp add: lift_def chara add_top)
qed (auto intro: hoareQ.Halt hoareQ.Empty hoareQ.Assign hoareQ.Seq)

lemma hoareQ_complete: " \<Turnstile> {P} c {Q} \<Longrightarrow> \<turnstile>\<^sub>Q {P} c {Q}"
proof -
  assume "Qw P c Q"
  then have 1: "\<forall>s. P s \<ge> ert c Q s" unfolding Qw_def by auto
  show ?thesis
    apply(rule conseq)
      apply(rule hoareQ_complete_aux)
    using 1 by(auto intro: le_funI)
qed

lemma "\<Turnstile> {P} c {Q} \<longleftrightarrow> \<turnstile>\<^sub>Q {P} c {Q}"
  using hoareQ_sound hoareQ_complete by auto

lemma "\<Turnstile> {P} c {Q} \<longleftrightarrow> Ert Q c \<le> P"
  unfolding Qw_def le_fun_def by (simp add: ert_eq_Ert)

section "VCG"

datatype 'a apgcl = aEmpty
                 | aSkip
                 | aHalt
                 | aAssign "'a \<Rightarrow> 'a pmf"
                 | aSeq (left: "'a apgcl") (right: "'a apgcl")
                 | aPar (left: "'a apgcl") (right: "'a apgcl")
                 | aIf "'a \<Rightarrow> bool" (left: "'a apgcl") (right: "'a apgcl")
                 | aWhile "'a \<Rightarrow> ennreal" "'a \<Rightarrow> bool" "'a apgcl"

fun strip ::"'a apgcl \<Rightarrow> 'a pgcl" where
  "strip aEmpty = Empty" |
  "strip aSkip = Skip" |
  "strip aHalt = Halt" |
  "strip (aAssign u) = (Assign u)" |
  "strip (aSeq c1 c2) = Seq (strip c1) (strip c2)" |
  "strip (aPar c1 c2) = Par (strip c1) (strip c2)" |
  "strip (aIf b c1 c2) = If b (strip c1) (strip c2)" |
  "strip (aWhile I g c) = While g (strip c)"

fun pre :: "'a apgcl \<Rightarrow> 'a qassn \<Rightarrow> 'a qassn" where
"pre aEmpty Q = Q" |
"pre aSkip Q = (%s. 1 + Q s)" |
"pre aHalt Q = (%s. 0)" |
"pre (aAssign u) Q = 1 + (\<lambda>x. \<integral>\<^sup>+y. Q y \<partial>u x)" |
"pre (aSeq C\<^sub>1 C\<^sub>2) Q = pre C\<^sub>1 (pre C\<^sub>2 Q)" |
"pre (aPar c\<^sub>1 c\<^sub>2) Q = pre c\<^sub>1 Q \<squnion> pre c\<^sub>2 Q" |
"pre (aIf b C\<^sub>1 C\<^sub>2) Q = 1 + (\<lambda>s. (if b s then pre C\<^sub>1 Q s  else pre C\<^sub>2 Q s  ))" |
"pre (aWhile I b C) Q = (\<lambda>s. I s + 1)"

 term ert

fun vc :: "'a apgcl \<Rightarrow> 'a qassn \<Rightarrow> bool" where
"vc aSkip Q = True" |
"vc aHalt Q = True" |
"vc aEmpty Q = True" |
"vc (aAssign u) Q = True" |
"vc (aSeq C\<^sub>1 C\<^sub>2) Q = ((vc C\<^sub>1 (pre C\<^sub>2 Q)) \<and> (vc C\<^sub>2 Q) )" |
"vc (aPar C\<^sub>1 C\<^sub>2) Q = ((vc C\<^sub>1 Q) \<and> (vc C\<^sub>2 Q) )" |
"vc (aIf b C\<^sub>1 C\<^sub>2) Q = (vc C\<^sub>1 Q \<and> vc C\<^sub>2 Q)" |
"vc (aWhile I b C) Q =  ((\<forall>s. (pre C (\<lambda>s. I s + 1) s \<le> I s + lift b s) \<and> (Q s \<le> I s + lift (%s. \<not>b s) s)) \<and> vc C (%s. I s + 1))"

subsubsection "VCG soundness"

lemma vc_sound: "vc C Q \<Longrightarrow>  \<turnstile>\<^sub>Q {pre C Q} strip C { Q }"
proof (induct C arbitrary: Q)
  case (aPar C1 C2)
  from aPar(3) have "vc C1 Q" "vc C2 Q" by auto
  with aPar(1,2) have 1: "\<turnstile>\<^sub>Q {pre C1 Q} strip C1 {Q}"
      and 2: "\<turnstile>\<^sub>Q {pre C2 Q} strip C2 {Q}" by auto
  show ?case
    using conseq[OF 1] conseq[OF 2] by (auto intro: hoareQ.Par simp add: le_funI)
next
  case (aIf b C1 C2)
  from aIf(3) have "vc C1 Q" "vc C2 Q" by auto
  with aIf(1,2) have 1: "\<turnstile>\<^sub>Q {pre C1 Q} strip C1 {Q}"
      and 2: "\<turnstile>\<^sub>Q {pre C2 Q} strip C2 {Q}" by auto
  show ?case apply(simp)
    apply(rule hoareQ.If[where P="%s. if b s then pre C1 Q s else pre C2 Q s" and Q="Q"])
    subgoal apply(rule conseq[OF 1]) apply (rule le_funI)
      subgoal for s apply(cases "b s") unfolding lift_def by (auto simp add: add_top)
        by simp
    subgoal apply(rule conseq[OF 2]) apply (rule le_funI)
      subgoal for s apply(cases "b s") unfolding lift_def by (auto simp add: add_top)
      by simp
    done
next
  case (aWhile I b C)
  from aWhile(2) have preT: "\<And>s. (pre C (\<lambda>s. I s + 1) s \<le> I s + lift b s)"
   and  preF: "\<And>s. Q s \<le> I s + lift (%s. \<not>b s) s" and vc: "vc C (%s. I s + 1)"  by auto
  from aWhile(1) vc have C: "\<turnstile>\<^sub>Q {pre C (\<lambda>s. I s + 1)} strip C {(\<lambda>s. I s + 1)}" by auto

  show ?case apply simp apply(rule conseq)
      apply(rule While)
      apply(rule conseq)
        apply(rule C) apply(rule le_funI)
       apply(rule preT)
      apply simp
     apply simp
      apply(rule le_funI)
      apply (rule preF)
    done
qed (auto intro: hoareQ.Skip hoareQ.Empty hoareQ.Halt hoareQ.Assign hoareQ.Seq )

lemma vc_sound': assumes "vc C Q " " P \<ge> pre C Q "" strip C = c " shows "  \<turnstile>\<^sub>Q {P} c { Q }"
proof -
  have "\<turnstile>\<^sub>Q {P} strip C { Q }"
    apply(rule conseq)
      apply(rule vc_sound)
      apply fact+ by auto
  then show ?thesis using assms(3) by auto
qed

subsubsection "VCG completeness"

lemma pre_mono: assumes "\<And>s. P' s \<le> P s"
  shows "\<And>s. pre C P' s \<le> pre C P s"
  using assms by (induct C arbitrary: P P', auto simp: nn_integral_mono le_supI2 le_supI1)

lemma vc_mono: "P \<ge> Q \<Longrightarrow> vc C P \<Longrightarrow> vc C Q"
proof(induct C arbitrary: P Q)
  case (aSeq C1 C2)
  then show ?case apply (auto)
    by (metis le_fun_def pre_mono)
next
  case (aWhile x1 x2 C)
  then show ?case apply (auto)
    by (metis le_fun_def order_trans)
qed auto

lemma vc_completeness: "\<turnstile>\<^sub>Q {P} c { Q } \<Longrightarrow>
  \<exists>C. vc C Q \<and> P \<ge> pre C Q \<and> strip C = c "
proof(induct rule: hoareQ.induct)
  case (Empty P)
  then show ?case apply(rule exI[where x=aEmpty]) by auto
next
  case (Skip P)
  then show ?case  apply(rule exI[where x=aSkip]) by auto
next
  case (Halt Q P)
  then show ?case  apply(rule exI[where x=aHalt]) by (auto simp add: le_funI)
next
  case (Assign u Q P)
  show ?case apply(rule exI[where x="aAssign u"]) using Assign by (auto simp add: le_funI)
next
  case (If P b c\<^sub>1 Q c\<^sub>2)
  then obtain C1 C2 where C1: "vc C1 Q \<and> pre C1 Q \<le> (\<lambda>a. P a + lift b a) \<and> strip C1 = c\<^sub>1"
      and C2: "vc C2 Q \<and> pre C2 Q \<le> (\<lambda>a. P a + lift (\<lambda>s. \<not> b s) a) \<and> strip C2 = c\<^sub>2" by auto
  show ?case apply(rule exI[where x="aIf b C1 C2"])
    using C1 C2 apply (auto simp add: le_funI) apply (rule le_funI)  unfolding lift_def
     subgoal for x apply(cases "b x") apply auto
       apply (smt add.right_neutral le_fun_def)+ done done
next
  case (Seq P\<^sub>1 c\<^sub>1 P\<^sub>2 c\<^sub>2 P\<^sub>3)
  then obtain C1 C2 where C1: "vc C1 P\<^sub>2  \<and> pre C1 P\<^sub>2 \<le> P\<^sub>1 \<and> strip C1 = c\<^sub>1"
      and C2: "vc C2 P\<^sub>3  \<and> pre C2 P\<^sub>3  \<le> P\<^sub>2  \<and> strip C2 = c\<^sub>2" by auto
  show ?case apply(rule exI[where x="aSeq C1 C2"])
      using C1 C2 apply (auto simp: vc_mono)
      by (metis dual_order.trans le_fun_def pre_mono)
next
  case (Par P c\<^sub>1 Q c\<^sub>2)
  then obtain C1 C2 where C1: "vc C1 Q \<and> pre C1 Q \<le> P \<and> strip C1 = c\<^sub>1"
      and C2: "vc C2 Q \<and> pre C2 Q \<le> P \<and> strip C2 = c\<^sub>2" by auto
  show ?case apply(rule exI[where x="aPar C1 C2"])
      using C1 C2 by (auto simp: le_fun_def)
next
  case (While I b c)
  then obtain C where C: "vc C (\<lambda>a. I a + 1) \<and> pre C (\<lambda>a. I a + 1) \<le> (\<lambda>a. I a + lift b a) \<and> strip C = c" by auto
  show ?case apply(rule exI[where x="aWhile I b C"])
      using C by (auto simp: le_fun_def)
next
  case (conseq P c Q P' Q')
  then obtain C where C: "vc C Q \<and> pre C Q \<le> P \<and> strip C = c" by blast
  show ?case apply(rule exI[where x=C])
    using C conseq(3,4) vc_mono pre_mono apply (auto)
    by (metis dual_order.trans le_fun_def pre_mono)
qed

section \<open>Examples\<close>

subsection "simple Random Walk"

definition Rdwalk :: "nat pgcl"
  where "Rdwalk = While (%x. x>0) (Assign (%x. map_pmf (\<lambda>b. if b then x+1 else x-1) (bernoulli_pmf (1/4))))"

definition aRdwalk :: "(nat \<Rightarrow> ennreal) \<Rightarrow> nat apgcl"
  where "aRdwalk I = aWhile I (%x. x>0) (aAssign (%x. map_pmf (\<lambda>b. if b then x+1 else x-1) (bernoulli_pmf (1/4))))"

text \<open>Gather Information about the invariant\<close>
schematic_goal "vc (aRdwalk ?I) 0"
  unfolding aRdwalk_def apply auto unfolding lift_def apply auto
    apply (auto simp add: add_top)
  apply(simp only: ennreal_numeral[symmetric] inverse_ennreal ennreal_1[symmetric] )
  oops
\<comment> \<open>ennreal 1 + ((?I (s + 1) + 1) * (1 / 4) + (?I (s - 1) + 1) *  (3 / 4)) \<le> ?I s\<close>

definition "eI (s::nat) = 4 * s + 1"
definition "I s = ennreal (eI s)"
lemma "0 < s \<Longrightarrow> eI \<ge> 0  \<Longrightarrow> 1 + ((I (Suc s) + 1) * ennreal (1 / 4) + (I (s - Suc 0) + 1) * ennreal (3 / 4)) \<le> I s"
  unfolding I_def   apply auto
  apply(simp only: ennreal_numeral[symmetric] ennreal_plus[symmetric] ennreal_of_nat_eq_real_of_nat ennreal_mult[symmetric] ennreal_1[symmetric])
  apply(subst ennreal_plus[symmetric])
    apply (auto simp add: le_fun_def)[1] apply simp
  apply(subst ennreal_plus[symmetric])
    apply (auto simp add: le_fun_def)[1] apply simp
  apply(subst ennreal_le_iff)
   apply (auto simp add: le_fun_def)[1]
  unfolding eI_def apply auto
  by (simp only: add_divide_distrib)

lemma vc_Rdwalk: "vc (aRdwalk (%s. 4 * s + 1)) 0"
  apply (simp add: aRdwalk_def)
  by (auto intro: le_funI simp del: ennreal_plus ennreal_numeral ennreal_1
      simp: lift_def ennreal_mult[symmetric] ennreal_1[symmetric] ennreal_of_nat_eq_real_of_nat
      ennreal_numeral[symmetric] ennreal_plus[symmetric] add_divide_distrib)

lemma derive: "\<turnstile>\<^sub>Q {pre (aRdwalk (%s. 4 * s + 1)) 0} Rdwalk {0}"
  apply(rule vc_sound'[OF vc_Rdwalk])
  unfolding aRdwalk_def Rdwalk_def by auto

lemma "ert Rdwalk 0 s \<le> 1 + 4 * of_nat s + 1"
  using hoareQ_sound[OF derive, unfolded Qw_def aRdwalk_def, simplified]
  by auto

subsubsection "geometric"

definition Geo :: "nat pgcl"
  where "Geo = While (%x. x=0) (Assign (%x. map_pmf (\<lambda>b. if b then (1::nat) else 0) (bernoulli_pmf (1/2))))"

definition aGeo :: "(nat \<Rightarrow> ennreal) \<Rightarrow> nat apgcl"
  where "aGeo P  = aWhile P (%x. x=0) (aAssign (%x. map_pmf (\<lambda>b. if b then (1::nat) else 0) (bernoulli_pmf (1/2))))"

  lemma "vc (aGeo (%s. ennreal (real (P s)))) 0"
    unfolding aGeo_def apply auto unfolding lift_def apply (auto simp add: add_top)
  apply(simp only: ennreal_numeral[symmetric] inverse_ennreal ennreal_1[symmetric])
  apply (subst  ennreal_plus[symmetric])
    apply simp apply simp
  apply (subst  ennreal_mult[symmetric])
    apply simp apply simp
  apply (subst  ennreal_plus[symmetric])
    apply simp apply simp
  apply (subst  ennreal_mult[symmetric])
    apply simp apply simp
  apply (subst  ennreal_plus[symmetric])
    apply simp apply simp
  apply (subst  ennreal_plus[symmetric])
    apply simp apply simp
  apply (subst ennreal_le_iff) apply simp
      apply (simp only: distrib_right) apply auto oops
    (* left over: 2 + (real (P (Suc 0)) / 2 + real (P 0) / 2) \<le> real (P 0) *)

lemma vc_aGeo: "vc (aGeo (%s. if s=0 then 5 else 1)) 0"
  unfolding aGeo_def apply auto unfolding lift_def apply (auto simp add: add_top )
  apply(simp only: ennreal_numeral[symmetric] inverse_ennreal )
  apply (subst  ennreal_mult[symmetric])
    apply simp apply simp
  apply (subst  ennreal_mult[symmetric])
    apply simp apply simp apply simp done

lemma derive_aGeo: "\<turnstile>\<^sub>Q {pre (aGeo (%s. if s=0 then 5 else 1)) 0} Geo {0}"
  apply(rule vc_sound'[OF vc_aGeo])
    unfolding aGeo_def Geo_def by auto

lemma "ert Geo 0 s \<le> (if s=0 then 5 else 1) + 1"
using hoareQ_sound[OF derive_aGeo, unfolded Qw_def aGeo_def, simplified]
      by auto

subsection "Random walk from Hölzl rough diamond"

definition random_walk :: "int pgcl"
where
  "random_walk =
    Seq
      (Assign (\<lambda>i. return_pmf 10))
      (While (\<lambda>i. 0 < i)
             (Assign (\<lambda>i. map_pmf (\<lambda>True \<Rightarrow> i + 1 | False \<Rightarrow> i - 1) (bernoulli_pmf (1/2)))))"

definition arandom_walk :: "(int \<Rightarrow> ennreal) \<Rightarrow> int apgcl"
where
  "arandom_walk In =
    aSeq
      (aAssign (\<lambda>i. return_pmf 10))
      (aWhile In (\<lambda>i. 0 < i)
             (aAssign (\<lambda>i. map_pmf (\<lambda>True \<Rightarrow> i + 1 | False \<Rightarrow> i - 1) (bernoulli_pmf (1/2)))))"

lemma "vc (arandom_walk IN) 0"
  unfolding arandom_walk_def apply (auto simp add: lift_def add_top)  oops

lemma "pre (arandom_walk IN) 0 s = 2 + IN 10"
  unfolding arandom_walk_def by auto

subsection "Example: Coupon Collector"

definition DetAssign :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a pgcl"
where
  "DetAssign f = Assign (\<lambda>s. return_pmf (f s))"

definition aDetAssign :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a apgcl"
where
  "aDetAssign f = aAssign (\<lambda>s. return_pmf (f s))"

lemma ert_DetAssign[simp]: "ert (DetAssign f) g = 1 + (\<lambda>x. g (f x))"
  by (simp add: DetAssign_def)

record coupon_collector =
  cp :: "nat \<Rightarrow> bool"
  x :: nat
  i :: nat

definition cc :: "nat \<Rightarrow> coupon_collector pgcl"
where
  "cc N =
    DetAssign (\<lambda>_. \<lparr> cp = \<lambda>_. False, x = 0, i = 0 \<rparr>) ;;
    WHILE (\<lambda>s. x s < N) DO
      (WHILE (\<lambda>s. cp s (i s)) DO
        Assign (\<lambda>s. map_pmf (\<lambda>i'. s\<lparr> i := i' \<rparr>) (pmf_of_set {0 ..< N})) ;;
      DetAssign (\<lambda>s. s\<lparr> cp := (cp s)(i s := True)\<rparr>) ;;
      DetAssign (\<lambda>s. s\<lparr> x := x s + 1 \<rparr>))"

definition acc  :: "(coupon_collector \<Rightarrow> ennreal) \<Rightarrow> (coupon_collector \<Rightarrow> ennreal) \<Rightarrow> nat \<Rightarrow> coupon_collector apgcl"
where
  "acc OI II N =
   aSeq (aDetAssign (\<lambda>_. \<lparr> cp = \<lambda>_. False, x = 0, i = 0 \<rparr>))
    (aWhile OI (\<lambda>s. x s < N) (
      (aWhile II (\<lambda>s. cp s (i s)) (
       aSeq (aAssign (\<lambda>s. map_pmf (\<lambda>i'. s\<lparr> i := i' \<rparr>) (pmf_of_set {0 ..< N}))) (
      aSeq (aDetAssign (\<lambda>s. s\<lparr> cp := (cp s)(i s := True)\<rparr>)) (
      aDetAssign (\<lambda>s. s\<lparr> x := x s + 1 \<rparr>)))))))"

lemma "0 < N \<Longrightarrow> vc (acc OI II N) 0"
  unfolding acc_def apply (auto simp add: aDetAssign_def lift_def add_top nn_integral_pmf_of_set) oops

term "(\<lambda>_. ennreal (real (2 + N * 4) + real (2 * N) * (\<Sum>i<N - 1. 1 / real (Suc i))))"

lemma "0 < N \<Longrightarrow> vc (acc OI II 10) 0"
  unfolding acc_def apply (auto simp add: aDetAssign_def lift_def add_top nn_integral_pmf_of_set)
  oops

end


section \<open>A Simplification of Jeroslow's Original Argument\<close>

(*<*)
theory Jeroslow_Simplified imports Abstract_Jeroslow_Encoding
begin
(*>*)

text \<open>This is the simplified version of Jeroslow's Second Incompleteness Theorem
reported in our CADE 2019 paper~\cite{DBLP:conf/cade/0001T19}.
The simplification consists of replacing pseudo-terms with plain terms
and representability with (what we call in the paper) term-representability.
This simplified version does not incur the complications of the original.\<close>

subsection \<open>Jeroslow-style term-based diagonalization\<close>

locale Jeroslow_Diagonalization =
Deduct_with_False
  var trm fmla Var FvarsT substT Fvars subst
  eql cnj imp all exi
  fls
  num
  prv
+
Encode
  var trm fmla Var FvarsT substT Fvars subst
  num
  enc
+
TermEncode
  var trm fmla Var FvarsT substT Fvars subst
  num
  Ops tenc
for
var :: "'var set" and trm :: "'trm set" and fmla :: "'fmla set"
and Var FvarsT substT Fvars subst
and eql cnj imp all exi
and fls
and num
and prv
and enc ("\<langle>_\<rangle>")
and Ops and tenc
+
fixes F :: "('trm \<Rightarrow> 'trm) set"
  and encF :: "('trm \<Rightarrow> 'trm) \<Rightarrow> ('trm \<Rightarrow> 'trm)"
  and N :: "'trm \<Rightarrow> 'trm"
  and ssap :: "'fmla \<Rightarrow> 'trm \<Rightarrow> 'trm"
assumes
F[simp,intro!]: "\<And> f n. f \<in> F \<Longrightarrow> n \<in> num \<Longrightarrow> f n \<in> num"
and
encF[simp,intro!]: "\<And> f. f \<in> F \<Longrightarrow> encF f \<in> Ops"
and
N[simp,intro!]: "N \<in> F"
and
ssap[simp]: "\<And>\<phi>. \<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {xx} \<Longrightarrow> ssap \<phi> \<in> F"
and
ReprF: "\<And>f n. f \<in> F \<Longrightarrow> n \<in> num \<Longrightarrow> prv (eql (encF f n) (f n))"
and
CapN: "\<And>\<phi>. \<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {} \<Longrightarrow> N \<langle>\<phi>\<rangle> = \<langle>neg \<phi>\<rangle>"
and
CapSS:
"\<And> \<psi> f. \<psi> \<in> fmla \<Longrightarrow> Fvars \<psi> = {xx} \<Longrightarrow> f \<in> F \<Longrightarrow>
    ssap \<psi> (tenc (encF f)) = \<langle>inst \<psi> (encF f (tenc (encF f)))\<rangle>"
begin

definition tJ :: "'fmla \<Rightarrow> 'trm" where
"tJ \<psi> \<equiv> encF (ssap \<psi>) (tenc (encF (ssap \<psi>)))"

definition \<phi>J :: "'fmla \<Rightarrow> 'fmla" where
"\<phi>J \<psi> \<equiv> subst \<psi> (tJ \<psi>) xx"

lemma tJ[simp]:
assumes "\<psi> \<in> fmla" and "Fvars \<psi> = {xx}"
shows "tJ \<psi> \<in> trm"
using assms tJ_def by auto

lemma FvarsT_tJ[simp]:
assumes "\<psi> \<in> fmla" and "Fvars \<psi> = {xx}"
shows "FvarsT (tJ \<psi>) = {}"
using assms tJ_def by auto

lemma \<phi>J[simp]:
assumes "\<psi> \<in> fmla" and "Fvars \<psi> = {xx}"
shows "\<phi>J \<psi> \<in> fmla"
using assms \<phi>J_def by auto

lemma Fvars_\<phi>J[simp]:
assumes "\<psi> \<in> fmla" and "Fvars \<psi> = {xx}"
shows "Fvars (\<phi>J \<psi>) = {}"
using assms \<phi>J_def by auto

lemma diagonalization:
assumes "\<psi> \<in> fmla" and "Fvars \<psi> = {xx}"
shows "prv (eql (tJ \<psi>) \<langle>inst \<psi> (tJ \<psi>)\<rangle>) \<and>
       prv (eqv (\<phi>J \<psi>) (inst \<psi> \<langle>\<phi>J \<psi>\<rangle>))"
proof
  define fJ where "fJ \<equiv> ssap \<psi>"
  have fJ[simp]: "fJ \<in> F" unfolding fJ_def using assms by auto
  have "fJ (tenc (encF fJ)) = \<langle>inst \<psi> (tJ \<psi>)\<rangle>"
   by (simp add: CapSS assms fJ_def tJ_def)
  thus **: "prv (eql (tJ \<psi>) \<langle>inst \<psi> (tJ \<psi>)\<rangle>)"
   using ReprF fJ fJ_def tJ_def by fastforce
  show "prv (eqv (\<phi>J \<psi>) (inst \<psi> \<langle>\<phi>J \<psi>\<rangle>))"
   using assms prv_eql_subst_trm_eqv[OF xx _  _ _ **, of "\<psi>"]
   by (auto simp: \<phi>J_def inst_def)
qed

end \<comment> \<open>context @{locale Jeroslow_Diagonalization}\<close>

subsection \<open>Term-based version of Jeroslow's Second Incompleteness Theorem\<close>

locale Jeroslow_Godel_Second =
Jeroslow_Diagonalization
  var trm fmla Var FvarsT substT Fvars subst
  eql cnj imp all exi
  fls
  num
  prv
  enc
  Ops tenc
  F encF N ssap
+
HBL1
  var trm fmla Var FvarsT substT Fvars subst
  num
  eql cnj imp all exi
  prv prv
  enc
  P
for
var :: "'var set" and trm :: "'trm set" and fmla :: "'fmla set"
and Var FvarsT substT Fvars subst
and eql cnj imp all exi
and fls
and num
and prv
and enc ("\<langle>_\<rangle>")
and Ops and tenc
and P
and F encF N ssap
+
assumes
SHBL3: "\<And>t. t \<in> trm \<Longrightarrow> FvarsT t = {} \<Longrightarrow> prv (imp (PP t) (PP \<langle>PP t\<rangle>))"
begin

text \<open>Consistency formula a la Jeroslow:\<close>
definition jcons :: "'fmla" where
"jcons \<equiv> all xx (neg (cnj (PP (Var xx)) (PP (encF N (Var (xx))))))"

lemma prv_eql_subst_trm3:
"x \<in> var \<Longrightarrow> \<phi> \<in> fmla \<Longrightarrow> t1 \<in> trm \<Longrightarrow> t2 \<in> trm \<Longrightarrow>
prv (eql t1 t2) \<Longrightarrow> prv (subst \<phi> t1 x) \<Longrightarrow> prv (subst \<phi> t2 x)"
using prv_eql_subst_trm2
  by (meson subst prv_imp_mp)

lemma prv_eql_neg_encF_N:
assumes "\<phi> \<in> fmla" and "Fvars \<phi> = {}"
shows "prv (eql \<langle>neg \<phi>\<rangle> (encF N \<langle>\<phi>\<rangle>))"
  unfolding CapN[symmetric, OF assms]
  by (rule prv_prv_eql_sym) (auto simp: assms intro: ReprF)

lemma prv_imp_neg_encF_N_aux:
assumes "\<phi> \<in> fmla" and "Fvars \<phi> = {}"
shows "prv (imp (PP \<langle>neg \<phi>\<rangle>) (PP (encF N \<langle>\<phi>\<rangle>)))"
using assms prv_eql_subst_trm2[OF _ _ _ _ prv_eql_neg_encF_N[OF assms],
  of xx "PP (Var xx)"]
  unfolding PP_def by auto

lemma prv_cnj_neg_encF_N_aux:
assumes "\<phi> \<in> fmla" and "Fvars \<phi> = {}" "\<chi> \<in> fmla" "Fvars \<chi> = {}"
and "prv (neg (cnj \<chi> (PP \<langle>neg \<phi>\<rangle>)))"
shows"prv (neg (cnj \<chi> (PP (encF N \<langle>\<phi>\<rangle>))))"
using assms prv_eql_subst_trm3[OF _ _ _ _ prv_eql_neg_encF_N,
  of xx "neg (cnj \<chi> (PP (Var xx)))"]
  unfolding PP_def by auto

theorem jeroslow_godel_second:
assumes consistent
shows "\<not> prv jcons"
proof
  assume *: "prv jcons"
  define \<psi> where "\<psi> \<equiv> PP (encF N (Var xx))"
  define t where "t \<equiv> tJ \<psi>"
  have \<psi>[simp,intro]: "\<psi> \<in> fmla" "Fvars \<psi> = {xx}"
  and t[simp,intro]: "t \<in> trm" "FvarsT t = {}"
    unfolding \<psi>_def t_def by auto

  have sPP[simp]: "subst (PP (encF N (Var xx))) \<langle>PP (encF N t)\<rangle> xx =
             PP (encF N \<langle>PP (encF N t)\<rangle>)"
    unfolding PP_def by (subst subst_compose_eq_or) auto
  have sPP2[simp]: "subst (PP (encF N (Var xx))) t xx = PP (encF N t)"
    unfolding PP_def by (subst subst_compose_eq_or) auto
  have 00: "PP (encF N t) = inst \<psi> t" unfolding \<psi>_def inst_def PP_def
    by (subst subst_compose_eq_or) auto

  define \<phi> where "\<phi> \<equiv> \<phi>J \<psi>"
  have [simp]: "\<phi> \<in> fmla" "Fvars \<phi> = {}" unfolding \<phi>_def by auto
  have **: "prv (eql t \<langle>\<phi>\<rangle>)"
    unfolding 00 \<phi>_def
    using \<phi>J_def diagonalization inst_def t_def by auto
  have \<phi>: "\<phi> = PP (encF N t)" unfolding \<phi>_def \<phi>J_def t_def \<psi>_def
    using sPP2 \<psi>_def t_def by blast
  have 1: "prv (imp \<phi> (PP \<langle>\<phi>\<rangle>))" using SHBL3[of "encF N t"]
    using 00 \<phi>J_def \<phi>_def \<psi>_def inst_def t_def by auto
  have eqv_\<phi>: "prv (eqv \<phi> (PP (encF N \<langle>\<phi>\<rangle>)))"  using diagonalization
    by (metis "00" sPP \<phi>J_def \<phi>_def \<psi> \<psi>_def diagonalization inst_def t_def)
  have 2: "prv (imp \<phi> (PP (encF N \<langle>\<phi>\<rangle>)))"
   using prv_cnjEL[OF _ _ eqv_\<phi>[unfolded eqv_def]] by auto
  have "prv (imp (PP (encF N \<langle>\<phi>\<rangle>)) \<phi>)"
   using prv_cnjER[OF _ _ eqv_\<phi>[unfolded eqv_def]] by auto
  from  prv_prv_imp_trans[OF _ _ _ prv_imp_neg_encF_N_aux this]
  have 22: "prv (imp (PP \<langle>neg \<phi>\<rangle>) \<phi>)" by auto
  have 3: "prv (imp \<phi> (cnj (PP \<langle>\<phi>\<rangle>) (PP (encF N \<langle>\<phi>\<rangle>))))"
    by (rule prv_imp_cnj[OF _ _ _ 1 2]) (auto simp: \<phi>_def)
  have 4: "prv (neg (cnj (PP \<langle>\<phi>\<rangle>) (PP (encF N \<langle>\<phi>\<rangle>))))"
     using prv_allE[OF _ _ _ *[unfolded jcons_def], of "\<langle>\<phi>\<rangle>"]
  by (simp add: \<phi> \<psi>_def)
  have 5: "prv (neg \<phi>)"
    unfolding neg_def
    by (rule prv_prv_imp_trans[OF _ _ _ 3 4[unfolded neg_def]]) auto
  hence "prv (PP \<langle>neg \<phi>\<rangle>)" using
      HBL1_PP[OF _ _ 5] by auto
  hence "prv \<phi>" using prv_imp_mp[OF _ _ 22] by auto
  with 5 assms show False unfolding consistent_def3 by auto
qed

subsection \<open>A variant of the Second Incompleteness Theorem\<close>

text \<open>This variant (also discussed in our CADE 2019 paper~\cite{DBLP:conf/cade/0001T19}) strengthens
the conclusion of the theorem to the standard formulation
of "does not prove its own consistency" at the expense of two
additional derivability-like conditions, HBL4 and WHBL2.\<close>

theorem jeroslow_godel_second_standardCon:
assumes consistent
and HBL4: "\<And>\<phi>1 \<phi>2. {\<phi>1,\<phi>2} \<subseteq> fmla \<Longrightarrow> Fvars \<phi>1 = {} \<Longrightarrow> Fvars \<phi>2 = {} \<Longrightarrow>
   prv (imp (cnj (PP \<langle>\<phi>1\<rangle>) (PP \<langle>\<phi>2\<rangle>)) (PP \<langle>cnj \<phi>1 \<phi>2\<rangle>))"
and WHBL2: "\<And>\<phi>1 \<phi>2. {\<phi>1,\<phi>2} \<subseteq> fmla \<Longrightarrow> Fvars \<phi>1 = {} \<Longrightarrow> Fvars \<phi>2 = {} \<Longrightarrow>
   prv (imp \<phi>1 \<phi>2) \<Longrightarrow> prv (imp (PP \<langle>\<phi>1\<rangle>) (PP \<langle>\<phi>2\<rangle>))"
shows "\<not> prv (neg (PP \<langle>fls\<rangle>))"
proof
  assume *:  "prv (neg (PP \<langle>fls\<rangle>))"
  define \<psi> where "\<psi> \<equiv> PP (encF N (Var xx))"
  define t where "t \<equiv> tJ \<psi>"
  have \<psi>[simp,intro]: "\<psi> \<in> fmla" "Fvars \<psi> = {xx}"
  and t[simp,intro]: "t \<in> trm" "FvarsT t = {}"
    unfolding \<psi>_def t_def by auto

  have [simp]: "subst (PP (encF N (Var xx))) \<langle>PP (encF N t)\<rangle> xx =
             PP (encF N \<langle>PP (encF N t)\<rangle>)"
    unfolding PP_def by (subst subst_compose_eq_or) auto
  have [simp]: "subst (PP (encF N (Var xx))) t xx = PP (encF N t)"
    unfolding PP_def by (subst subst_compose_eq_or) auto
  have 00: "PP (encF N t) = inst \<psi> t" unfolding \<psi>_def inst_def PP_def
    by (subst subst_compose_eq_or) auto

  define \<phi> where "\<phi> = PP (encF N t)"
  have [simp]: "\<phi> \<in> fmla" "Fvars \<phi> = {}" unfolding \<phi>_def by auto
  have **: "prv (eql t \<langle>PP (encF N t)\<rangle>)"
    unfolding 00 by (simp add: diagonalization t_def)
  have 1: "prv (imp \<phi> (PP \<langle>\<phi>\<rangle>))" using SHBL3[of "encF N t"]
    by (auto simp: \<phi>_def)
  have 2: "prv (imp \<phi> (PP (encF N \<langle>\<phi>\<rangle>)))"
   using prv_eql_subst_trm2[OF xx _  _ _ **, of "PP (encF N (Var xx))"]
   by (auto simp: \<phi>_def)
  have "prv (imp (PP (encF N \<langle>\<phi>\<rangle>)) \<phi>)"
   using prv_eql_subst_trm_rev2[OF xx _  _ _ **, of "PP (encF N (Var xx))"]
   by (auto simp: \<phi>_def)
  from prv_prv_imp_trans[OF _ _ _ prv_imp_neg_encF_N_aux this]
  have 22: "prv (imp (PP \<langle>neg \<phi>\<rangle>) \<phi>)" by auto
  have 3: "prv (imp \<phi> (cnj (PP \<langle>\<phi>\<rangle>) (PP (encF N \<langle>\<phi>\<rangle>))))"
    by (rule prv_imp_cnj[OF _ _ _ 1 2]) (auto simp: \<phi>_def)

  \<comment> \<open>This is the modification from the proof of @{thm jeroslow_godel_second}:\<close>
  have 41: "prv (imp (cnj (PP \<langle>\<phi>\<rangle>) (PP \<langle>neg \<phi>\<rangle>)) (PP \<langle>cnj \<phi> (neg \<phi>)\<rangle>))"
  using HBL4[of \<phi> "neg \<phi>"] by auto
  have "prv (imp (cnj \<phi> (neg \<phi>)) (fls))"
    by (simp add: prv_cnj_imp_monoR2 prv_imp_neg_fls)
  from WHBL2[OF _ _ _ this]
  have 42: "prv (imp (PP \<langle>cnj \<phi> (neg \<phi>)\<rangle>) (PP \<langle>fls\<rangle>))" by auto
  from prv_prv_imp_trans[OF _ _ _ 41 42]
  have "prv (imp (cnj (PP \<langle>\<phi>\<rangle>) (PP \<langle>neg \<phi>\<rangle>)) (PP \<langle>fls\<rangle>))" by auto
  from prv_prv_imp_trans[OF _ _ _ this *[unfolded neg_def]]
  have "prv (neg (cnj (PP \<langle>\<phi>\<rangle>) (PP \<langle>neg \<phi>\<rangle>)))"
  unfolding neg_def by auto
  from prv_cnj_neg_encF_N_aux[OF _ _ _ _ this]
  have 4: "prv (neg (cnj (PP \<langle>\<phi>\<rangle>) (PP (encF N \<langle>\<phi>\<rangle>))))" by auto
  \<comment> \<open>End modification\<close>

  have 5: "prv (neg \<phi>)"
    unfolding neg_def
    by (rule prv_prv_imp_trans[OF _ _ _ 3 4[unfolded neg_def]]) auto
  hence "prv (PP \<langle>neg \<phi>\<rangle>)" using HBL1_PP[OF _ _ 5] by auto
  hence "prv \<phi>" using prv_imp_mp[OF _ _ 22] by auto
  with 5 assms show False unfolding consistent_def3 by auto
qed

text \<open>Next we perform a formal analysis of some connection between the
above theorems' hypotheses.\<close>

definition noContr :: bool where
"noContr \<equiv> \<forall> \<phi> \<in> fmla. Fvars \<phi> = {} \<longrightarrow> prv (neg (cnj (PP \<langle>\<phi>\<rangle>) (PP \<langle>neg \<phi>\<rangle>)))"

lemma jcons_noContr:
assumes j: "prv jcons"
shows "noContr"
unfolding noContr_def proof safe
  fix \<phi> assume \<phi>[simp]: "\<phi> \<in> fmla" "Fvars \<phi> = {}"
  have [simp]: "subst (PP (encF N (Var xx))) \<langle>\<phi>\<rangle> xx =
               PP (encF N \<langle>\<phi>\<rangle>)"
  unfolding PP_def by (simp add: subst_compose_same)
  note j = allE_id[OF _ _ j[unfolded jcons_def], simplified]
  have 0: "prv (neg (cnj (PP \<langle>\<phi>\<rangle>)
                         (PP (encF N \<langle>\<phi>\<rangle>))))"
  (is "prv (neg (cnj (PP \<langle>\<phi>\<rangle>) ?j))")
    using prv_subst[OF _ _ _ j, of xx "\<langle>\<phi>\<rangle>"] by simp
  have 1: "prv (imp (PP \<langle>neg \<phi>\<rangle>) ?j)"
  using prv_eql_neg_encF_N[of \<phi>, simplified]
  using prv_imp_neg_encF_N_aux by auto
  have 2: "prv (imp (cnj (PP \<langle>\<phi>\<rangle>) (PP \<langle>neg \<phi>\<rangle>))
                    (cnj (PP \<langle>\<phi>\<rangle>) ?j))"
  using 0 1 by (simp add:  prv_cnj_mono prv_imp_refl)

  have "prv (imp (cnj (PP \<langle>\<phi>\<rangle>) (PP \<langle>neg \<phi>\<rangle>))
                 (cnj (PP \<langle>\<phi>\<rangle>) ?j))"
    by (simp add: 2 prv_cnj_mono prv_imp_refl)
  thus "prv (neg (cnj (PP \<langle>\<phi>\<rangle>) (PP \<langle>neg \<phi>\<rangle>)))" using 0
    unfolding neg_def
    by (elim prv_prv_imp_trans[rotated 3]) auto
qed

text \<open>@{term noContr} is still stronger than the standard notion of proving own consistency:\<close>

lemma noContr_implies_neg_PP_fls:
 assumes "noContr"
 shows "prv (neg (PP \<langle>fls\<rangle>))"
proof-
  have "prv (neg (cnj (PP \<langle>fls\<rangle>) (PP \<langle>neg fls\<rangle>)))"
    using assms unfolding noContr_def by auto
  thus ?thesis
  using Fvars_tru enc in_num tru_def PP PP_def fls imp HBL1 neg_def
       prv_cnj_imp prv_fls prv_imp_com prv_imp_mp
  by (metis Encode.enc HBL1_axioms HBL1_def)
qed

corollary jcons_implies_neg_PP_fls:
assumes "prv jcons"
shows "prv (neg (PP \<langle>fls\<rangle>))"
by (simp add: assms noContr_implies_neg_PP_fls jcons_noContr)

text \<open>However, unlike @{term jcons}, which seems to be quite a bit stronger,
@{term noContr} is equivalent to the standard notion under a slightly
stronger assumption than our WWHBL2, namely, a binary version of that:\<close>

lemma neg_PP_fls_implies_noContr:
 assumes WWHBL22:
"\<And>\<phi> \<chi> \<psi>. \<phi> \<in> fmla \<Longrightarrow> \<chi> \<in> fmla \<Longrightarrow> \<psi> \<in> fmla \<Longrightarrow>
   Fvars \<phi> = {} \<Longrightarrow> Fvars \<chi> = {} \<Longrightarrow> Fvars \<psi> = {} \<Longrightarrow>
   prv (imp \<phi> (imp \<chi> \<psi>)) \<Longrightarrow> prv (imp (PP \<langle>\<phi>\<rangle>) (imp (PP \<langle>\<chi>\<rangle>) (PP \<langle>\<psi>\<rangle>)))"
 assumes p: "prv (neg (PP \<langle>fls\<rangle>))"
 shows "noContr"
unfolding noContr_def proof safe
  fix \<phi> assume \<phi>[simp]: "\<phi> \<in> fmla" "Fvars \<phi> = {}"
  have 0: "prv (imp \<phi> (imp (neg \<phi>) fls))"
    by (simp add: prv_imp_neg_fls)
  have 1: "prv (imp (PP \<langle>\<phi>\<rangle>) (imp (PP \<langle>neg \<phi>\<rangle>) (PP \<langle>fls\<rangle>)))"
    using WWHBL22[OF _ _ _ _ _ _ 0] by auto
  show "prv (neg (cnj (PP \<langle>\<phi>\<rangle>) (PP \<langle>neg \<phi>\<rangle>)))" using 1 p
    unfolding neg_def
    by (elim prv_cnj_imp_monoR2[rotated 3, OF prv_prv_imp_trans[rotated 3]])
      (auto intro!: prv_imp_monoL)
qed

end \<comment> \<open>context @{locale Jeroslow_Godel_Second}\<close>

(*<*)
end
(*>*)


(* Author: Alexander Maletzky *)

theory Groebner_PM
  imports Polynomials.MPoly_PM Reduced_GB
begin

text \<open>We prove results that hold specifically for Gr\"obner bases in polynomial rings, where the
  polynomials really have @{emph \<open>indeterminates\<close>}.\<close>

context pm_powerprod
begin

lemmas finite_reduced_GB_Polys =
  punit.finite_reduced_GB_dgrad_p_set[simplified, OF dickson_grading_varnum, where m=0, simplified dgrad_p_set_varnum]
lemmas reduced_GB_is_reduced_GB_Polys =
  punit.reduced_GB_is_reduced_GB_dgrad_p_set[simplified, OF dickson_grading_varnum, where m=0, simplified dgrad_p_set_varnum]
lemmas reduced_GB_is_GB_Polys =
  punit.reduced_GB_is_GB_dgrad_p_set[simplified, OF dickson_grading_varnum, where m=0, simplified dgrad_p_set_varnum]
lemmas reduced_GB_is_auto_reduced_Polys =
  punit.reduced_GB_is_auto_reduced_dgrad_p_set[simplified, OF dickson_grading_varnum, where m=0, simplified dgrad_p_set_varnum]
lemmas reduced_GB_is_monic_set_Polys =
  punit.reduced_GB_is_monic_set_dgrad_p_set[simplified, OF dickson_grading_varnum, where m=0, simplified dgrad_p_set_varnum]
lemmas reduced_GB_nonzero_Polys =
  punit.reduced_GB_nonzero_dgrad_p_set[simplified, OF dickson_grading_varnum, where m=0, simplified dgrad_p_set_varnum]
lemmas reduced_GB_ideal_Polys =
  punit.reduced_GB_pmdl_dgrad_p_set[simplified, OF dickson_grading_varnum, where m=0, simplified dgrad_p_set_varnum]
lemmas reduced_GB_unique_Polys =
  punit.reduced_GB_unique_dgrad_p_set[simplified, OF dickson_grading_varnum, where m=0, simplified dgrad_p_set_varnum]
lemmas reduced_GB_Polys =
  punit.reduced_GB_dgrad_p_set[simplified, OF dickson_grading_varnum, where m=0, simplified dgrad_p_set_varnum]
lemmas ideal_eq_UNIV_iff_reduced_GB_eq_one_Polys =
  ideal_eq_UNIV_iff_reduced_GB_eq_one_dgrad_p_set[simplified, OF dickson_grading_varnum, where m=0, simplified dgrad_p_set_varnum]

subsection \<open>Univariate Polynomials\<close>

lemma (in -) adds_univariate_linear:
  assumes "finite X" and "card X \<le> 1" and "s \<in> .[X]" and "t \<in> .[X]"
  obtains "s adds t" | "t adds s"
proof (cases "s adds t")
  case True
  thus ?thesis ..
next
  case False
  then obtain x where 1: "lookup t x < lookup s x" by (auto simp: adds_poly_mapping le_fun_def not_le)
  hence "x \<in> keys s" by (simp add: in_keys_iff)
  also from assms(3) have "\<dots> \<subseteq> X" by (rule PPsD)
  finally have "x \<in> X" .
  have "t adds s" unfolding adds_poly_mapping le_fun_def
  proof
    fix y
    show "lookup t y \<le> lookup s y"
    proof (cases "y \<in> keys t")
      case True
      also from assms(4) have "keys t \<subseteq> X" by (rule PPsD)
      finally have "y \<in> X" .
      with assms(1, 2) \<open>x \<in> X\<close> have "x = y" by (simp add: card_le_Suc0_iff_eq)
      with 1 show ?thesis by simp
    next
      case False
      thus ?thesis by (simp add: in_keys_iff)
    qed
  qed
  thus ?thesis ..
qed

context
  fixes X :: "'x set"
  assumes fin_X: "finite X" and card_X: "card X \<le> 1"
begin

lemma ord_iff_adds_univariate:
  assumes "s \<in> .[X]" and "t \<in> .[X]"
  shows "s \<preceq> t \<longleftrightarrow> s adds t"
proof
  assume "s \<preceq> t"
  from fin_X card_X assms show "s adds t"
  proof (rule adds_univariate_linear)
    assume "t adds s"
    hence "t \<preceq> s" by (rule ord_adds)
    with \<open>s \<preceq> t\<close> have "s = t" by (rule ordered_powerprod_lin.antisym)
    thus ?thesis by simp
  qed
qed (rule ord_adds)

lemma adds_iff_deg_le_univariate:
  assumes "s \<in> .[X]" and "t \<in> .[X]"
  shows "s adds t \<longleftrightarrow> deg_pm s \<le> deg_pm t"
proof
  assume *: "deg_pm s \<le> deg_pm t"
  from fin_X card_X assms show "s adds t"
  proof (rule adds_univariate_linear)
    assume "t adds s"
    hence "t = s" using * by (rule adds_deg_pm_antisym)
    thus ?thesis by simp
  qed
qed (rule deg_pm_mono)

corollary ord_iff_deg_le_univariate: "s \<in> .[X] \<Longrightarrow> t \<in> .[X] \<Longrightarrow> s \<preceq> t \<longleftrightarrow> deg_pm s \<le> deg_pm t"
  by (simp only: ord_iff_adds_univariate adds_iff_deg_le_univariate)

lemma poly_deg_univariate:
  assumes "p \<in> P[X]"
  shows "poly_deg p = deg_pm (lpp p)"
proof (cases "p = 0")
  case True
  thus ?thesis by simp
next
  case False
  hence lp_in: "lpp p \<in> keys p" by (rule punit.lt_in_keys)
  also from assms have "\<dots> \<subseteq> .[X]" by (rule PolysD)
  finally have "lpp p \<in> .[X]" .
  show ?thesis
  proof (intro antisym poly_deg_leI)
    fix t
    assume "t \<in> keys p"
    hence "t \<preceq> lpp p" by (rule punit.lt_max_keys)
    moreover from \<open>t \<in> keys p\<close> \<open>keys p \<subseteq> .[X]\<close> have "t \<in> .[X]" ..
    ultimately show "deg_pm t \<le> deg_pm (lpp p)" using \<open>lpp p \<in> .[X]\<close>
      by (simp only: ord_iff_deg_le_univariate)
  next
    from lp_in show "deg_pm (lpp p) \<le> poly_deg p" by (rule poly_deg_max_keys)
  qed
qed

lemma reduced_GB_univariate_cases:
  assumes "F \<subseteq> P[X]"
  obtains g where "g \<in> P[X]" and "g \<noteq> 0" and "lcf g = 1" and "punit.reduced_GB F = {g}" |
    "punit.reduced_GB F = {}"
proof (cases "punit.reduced_GB F = {}")
  case True
  thus ?thesis ..
next
  case False
  let ?G = "punit.reduced_GB F"
  from fin_X assms have ar: "punit.is_auto_reduced ?G" and "0 \<notin> ?G" and "?G \<subseteq> P[X]"
    and m: "punit.is_monic_set ?G"
    by (rule reduced_GB_is_auto_reduced_Polys, rule reduced_GB_nonzero_Polys, rule reduced_GB_Polys,
        rule reduced_GB_is_monic_set_Polys)
  from False obtain g where "g \<in> ?G" by blast
  with \<open>0 \<notin> ?G\<close> \<open>?G \<subseteq> P[X]\<close> have "g \<noteq> 0" and "g \<in> P[X]" by blast+
  from this(1) have lp_g: "lpp g \<in> keys g" by (rule punit.lt_in_keys)
  also from \<open>g \<in> P[X]\<close> have "\<dots> \<subseteq> .[X]" by (rule PolysD)
  finally have "lpp g \<in> .[X]" .
  note \<open>g \<in> P[X]\<close> \<open>g \<noteq> 0\<close>
  moreover from m \<open>g \<in> ?G\<close> \<open>g \<noteq> 0\<close> have "lcf g = 1" by (rule punit.is_monic_setD)
  moreover have "?G = {g}"
  proof
    show "?G \<subseteq> {g}"
    proof
      fix g'
      assume "g' \<in> ?G"
      with \<open>0 \<notin> ?G\<close> \<open>?G \<subseteq> P[X]\<close> have "g' \<noteq> 0" and "g' \<in> P[X]" by blast+
      from this(1) have lp_g': "lpp g' \<in> keys g'" by (rule punit.lt_in_keys)
      also from \<open>g' \<in> P[X]\<close> have "\<dots> \<subseteq> .[X]" by (rule PolysD)
      finally have "lpp g' \<in> .[X]" .
      have "g' = g"
      proof (rule ccontr)
        assume "g' \<noteq> g"
        with \<open>g \<in> ?G\<close> \<open>g' \<in> ?G\<close> have g: "g \<in> ?G - {g'}" and g': "g' \<in> ?G - {g}" by blast+
        from fin_X card_X \<open>lpp g \<in> .[X]\<close> \<open>lpp g' \<in> .[X]\<close> show False
        proof (rule adds_univariate_linear)
          assume *: "lpp g adds lpp g'"
          from ar \<open>g' \<in> ?G\<close> have "\<not> punit.is_red (?G - {g'}) g'" by (rule punit.is_auto_reducedD)
          moreover from g \<open>g \<noteq> 0\<close> lp_g' * have "punit.is_red (?G - {g'}) g'"
            by (rule punit.is_red_addsI[simplified])
          ultimately show ?thesis ..
        next
          assume *: "lpp g' adds lpp g"
          from ar \<open>g \<in> ?G\<close> have "\<not> punit.is_red (?G - {g}) g" by (rule punit.is_auto_reducedD)
          moreover from g' \<open>g' \<noteq> 0\<close> lp_g * have "punit.is_red (?G - {g}) g"
            by (rule punit.is_red_addsI[simplified])
          ultimately show ?thesis ..
        qed
      qed
      thus "g' \<in> {g}" by simp
    qed
  next
    from \<open>g \<in> ?G\<close> show "{g} \<subseteq> ?G" by simp
  qed
  ultimately show ?thesis ..
qed

corollary deg_reduced_GB_univariate_le:
  assumes "F \<subseteq> P[X]" and "f \<in> ideal F" and "f \<noteq> 0" and "g \<in> punit.reduced_GB F"
  shows "poly_deg g \<le> poly_deg f"
  using assms(1)
proof (rule reduced_GB_univariate_cases)
  let ?G = "punit.reduced_GB F"
  fix g'
  assume "g' \<in> P[X]" and "g' \<noteq> 0" and G: "?G = {g'}"
  from fin_X assms(1) have gb: "punit.is_Groebner_basis ?G" and "ideal ?G = ideal F"
    and "?G \<subseteq> P[X]"
    by (rule reduced_GB_is_GB_Polys, rule reduced_GB_ideal_Polys, rule reduced_GB_Polys)
  from assms(2) this(2) have "f \<in> ideal ?G" by simp
  with gb obtain g'' where "g'' \<in> ?G" and "lpp g'' adds lpp f"
    using assms(3) by (rule punit.GB_adds_lt[simplified])
  with assms(4) have "lpp g adds lpp f" by (simp add: G)
  hence "deg_pm (lpp g) \<le> deg_pm (lpp f)" by (rule deg_pm_mono)
  moreover from assms(4) \<open>?G \<subseteq> P[X]\<close> have "g \<in> P[X]" ..
  ultimately have "poly_deg g \<le> deg_pm (lpp f)" by (simp only: poly_deg_univariate)
  also from punit.lt_in_keys have "\<dots> \<le> poly_deg f" by (rule poly_deg_max_keys) fact
  finally show ?thesis .
next
  assume "punit.reduced_GB F = {}"
  with assms(4) show ?thesis by simp
qed

end

subsection \<open>Homogeneity\<close>

lemma is_reduced_GB_homogeneous:
  assumes "\<And>f. f \<in> F \<Longrightarrow> homogeneous f" and "punit.is_reduced_GB G" and "ideal G = ideal F"
    and "g \<in> G"
  shows "homogeneous g"
proof (rule homogeneousI)
  fix s t
  have 1: "deg_pm u = deg_pm (lpp g)" if "u \<in> keys g" for u
  proof -
    from assms(4) have "g \<in> ideal G" by (rule ideal.span_base)
    hence "g \<in> ideal F" by (simp only: assms(3))
    from that have "u \<in> Keys (hom_components g)" by (simp only: Keys_hom_components)
    then obtain q where q: "q \<in> hom_components g" and "u \<in> keys q" by (rule in_KeysE)
    from assms(1) \<open>g \<in> ideal F\<close> q have "q \<in> ideal F" by (rule homogeneous_ideal')
    from assms(2) have "punit.is_Groebner_basis G" by (rule punit.reduced_GB_D1)
    moreover from \<open>q \<in> ideal F\<close> have "q \<in> ideal G" by (simp only: assms(3))
    moreover from q have "q \<noteq> 0" by (rule hom_components_nonzero)
    ultimately obtain g' where "g' \<in> G" and "g' \<noteq> 0" and adds: "lpp g' adds lpp q"
      by (rule punit.GB_adds_lt[simplified])
    from \<open>q \<noteq> 0\<close> have "lpp q \<in> keys q" by (rule punit.lt_in_keys)
    also from q have "\<dots> \<subseteq> Keys (hom_components g)" by (rule keys_subset_Keys)
    finally have "lpp q \<in> keys g" by (simp only: Keys_hom_components)
    with _ \<open>g' \<noteq> 0\<close> have red: "punit.is_red {g'} g"
      using adds by (rule punit.is_red_addsI[simplified]) simp
    from assms(2) have "punit.is_auto_reduced G" by (rule punit.reduced_GB_D2)
    hence "\<not> punit.is_red (G - {g}) g" using assms(4) by (rule punit.is_auto_reducedD)
    with red have "\<not> {g'} \<subseteq> G - {g}" using punit.is_red_subset by blast
    with \<open>g' \<in> G\<close> have "g' = g" by simp
    from \<open>lpp q \<in> keys g\<close> have "lpp q \<preceq> lpp g" by (rule punit.lt_max_keys)
    moreover from adds have "lpp g \<preceq> lpp q"
      unfolding \<open>g' = g\<close> by (rule punit.ord_adds_term[simplified])
    ultimately have eq: "lpp q = lpp g" by (rule ordered_powerprod_lin.antisym)
    from q have "homogeneous q" by (rule hom_components_homogeneous)
    hence "deg_pm u = deg_pm (lpp q)"
      using \<open>u \<in> keys q\<close> \<open>lpp q \<in> keys q\<close> by (rule homogeneousD)
    thus ?thesis by (simp only: eq)
  qed
  assume "s \<in> keys g"
  hence 2: "deg_pm s = deg_pm (lpp g)" by (rule 1)
  assume "t \<in> keys g"
  hence "deg_pm t = deg_pm (lpp g)" by (rule 1)
  with 2 show "deg_pm s = deg_pm t" by simp
qed

lemma lp_dehomogenize:
  assumes "is_hom_ord x" and "homogeneous p"
  shows "lpp (dehomogenize x p) = except (lpp p) {x}"
proof (cases "p = 0")
  case True
  thus ?thesis by simp
next
  case False
  hence "lpp p \<in> keys p" by (rule punit.lt_in_keys)
  with assms(2) have "except (lpp p) {x} \<in> keys (dehomogenize x p)"
    by (rule keys_dehomogenizeI)
  thus ?thesis
  proof (rule punit.lt_eqI_keys)
    fix t
    assume "t \<in> keys (dehomogenize x p)"
    then obtain s where "s \<in> keys p" and t: "t = except s {x}" by (rule keys_dehomogenizeE)
    from this(1) have "s \<preceq> lpp p" by (rule punit.lt_max_keys)
    moreover from assms(2) \<open>s \<in> keys p\<close> \<open>lpp p \<in> keys p\<close> have "deg_pm s = deg_pm (lpp p)"
      by (rule homogeneousD)
    ultimately show "t \<preceq> except (lpp p) {x}" using assms(1) by (simp add: t is_hom_ordD)
  qed
qed

lemma isGB_dehomogenize:
  assumes "is_hom_ord x" and "finite X" and "G \<subseteq> P[X]" and "punit.is_Groebner_basis G"
    and "\<And>g. g \<in> G \<Longrightarrow> homogeneous g"
  shows "punit.is_Groebner_basis (dehomogenize x ` G)"
  using dickson_grading_varnum
proof (rule punit.isGB_I_adds_lt[simplified])
  from assms(2) show "finite (X - {x})" by simp
next
  have "dehomogenize x ` G \<subseteq> P[X - {x}]"
  proof
    fix g
    assume "g \<in> dehomogenize x ` G"
    then obtain g' where "g' \<in> G" and g: "g = dehomogenize x g'" ..
    from this(1) assms(3) have "g' \<in> P[X]" ..
    hence "indets g' \<subseteq> X" by (rule PolysD)
    have "indets g \<subseteq> indets g' - {x}" by (simp only: g indets_dehomogenize)
    also from \<open>indets g' \<subseteq> X\<close> subset_refl have "\<dots> \<subseteq> X - {x}" by (rule Diff_mono)
    finally show "g \<in> P[X - {x}]" by (rule PolysI_alt)
  qed
  thus "dehomogenize x ` G \<subseteq> punit.dgrad_p_set (varnum (X - {x})) 0"
    by (simp only: dgrad_p_set_varnum)
next
  fix p
  assume "p \<in> ideal (dehomogenize x ` G)"
  then obtain G0 q where "G0 \<subseteq> dehomogenize x ` G" and "finite G0" and p: "p = (\<Sum>g\<in>G0. q g * g)"
    by (rule ideal.spanE)
  from this(1) obtain G' where "G' \<subseteq> G" and G0: "G0 = dehomogenize x ` G'"
    and inj: "inj_on (dehomogenize x) G'" by (rule subset_imageE_inj)
  define p' where "p' = (\<Sum>g\<in>G'. q (dehomogenize x g) * g)"
  have "p' \<in> ideal G'" unfolding p'_def by (rule ideal.sum_in_spanI)
  also from \<open>G' \<subseteq> G\<close> have "\<dots> \<subseteq> ideal G" by (rule ideal.span_mono)
  finally have "p' \<in> ideal G" .
  with assms(5) have "homogenize x p' \<in> ideal G" (is "?p \<in> _") by (rule homogeneous_ideal_homogenize)

  assume "p \<in> punit.dgrad_p_set (varnum (X - {x})) 0"
  hence "p \<in> P[X - {x}]" by (simp only: dgrad_p_set_varnum)
  hence "indets p \<subseteq> X - {x}" by (rule PolysD)
  hence "x \<notin> indets p" by blast
  have "p = dehomogenize x p" by (rule sym) (simp add: \<open>x \<notin> indets p\<close>)
  also from inj have "\<dots> = dehomogenize x (\<Sum>g\<in>G'. q (dehomogenize x g) * dehomogenize x g)"
    by (simp add: p G0 sum.reindex)
  also have "\<dots> = dehomogenize x ?p"
    by (simp add: dehomogenize_sum dehomogenize_times p'_def)
  finally have p: "p = dehomogenize x ?p" .
  moreover assume "p \<noteq> 0"
  ultimately have "?p \<noteq> 0" by (auto simp del: dehomogenize_homogenize)
  with assms(4) \<open>?p \<in> ideal G\<close> obtain g where "g \<in> G" and "g \<noteq> 0" and adds: "lpp g adds lpp ?p"
    by (rule punit.GB_adds_lt[simplified])
  from this(1) have "homogeneous g" by (rule assms(5))
  show "\<exists>g\<in>dehomogenize x ` G. g \<noteq> 0 \<and> lpp g adds lpp p"
  proof (intro bexI conjI notI)
    assume "dehomogenize x g = 0"
    hence "g = 0" using \<open>homogeneous g\<close> by (rule dehomogenize_zeroD)
    with \<open>g \<noteq> 0\<close> show False ..
  next
    from assms(1) \<open>homogeneous g\<close> have "lpp (dehomogenize x g) = except (lpp g) {x}"
      by (rule lp_dehomogenize)
    also from adds have "\<dots> adds except (lpp ?p) {x}"
      by (simp add: adds_poly_mapping le_fun_def lookup_except)
    also from assms(1) homogeneous_homogenize have "\<dots> = lpp (dehomogenize x ?p)"
      by (rule lp_dehomogenize[symmetric])
    finally show "lpp (dehomogenize x g) adds lpp p" by (simp only: p)
  next
    from \<open>g \<in> G\<close> show "dehomogenize x g \<in> dehomogenize x ` G" by (rule imageI)
  qed
qed

end (* pm_powerprod *)

context extended_ord_pm_powerprod
begin

lemma extended_ord_lp:
  assumes "None \<notin> indets p"
  shows "restrict_indets_pp (extended_ord.lpp p) = lpp (restrict_indets p)"
proof (cases "p = 0")
  case True
  thus ?thesis by simp
next
  case False
  hence "extended_ord.lpp p \<in> keys p" by (rule extended_ord.punit.lt_in_keys)
  hence "restrict_indets_pp (extended_ord.lpp p) \<in> restrict_indets_pp ` keys p" by (rule imageI)
  also from assms have eq: "\<dots> = keys (restrict_indets p)" by (rule keys_restrict_indets[symmetric])
  finally show ?thesis
  proof (rule punit.lt_eqI_keys[symmetric])
    fix t
    assume "t \<in> keys (restrict_indets p)"
    then obtain s where "s \<in> keys p" and t: "t = restrict_indets_pp s" unfolding eq[symmetric] ..
    from this(1) have "extended_ord s (extended_ord.lpp p)" by (rule extended_ord.punit.lt_max_keys)
    thus "t \<preceq> restrict_indets_pp (extended_ord.lpp p)" by (auto simp: t extended_ord_def)
  qed
qed

lemma restrict_indets_reduced_GB:
  assumes "finite X" and "F \<subseteq> P[X]"
  shows "punit.is_Groebner_basis (restrict_indets ` extended_ord.punit.reduced_GB (homogenize None ` extend_indets ` F))"
          (is ?thesis1)
    and "ideal (restrict_indets ` extended_ord.punit.reduced_GB (homogenize None ` extend_indets ` F)) = ideal F"
          (is ?thesis2)
    and "restrict_indets ` extended_ord.punit.reduced_GB (homogenize None ` extend_indets ` F) \<subseteq> P[X]"
          (is ?thesis3)
proof -
  let ?F = "homogenize None ` extend_indets ` F"
  let ?G = "extended_ord.punit.reduced_GB ?F"
  from assms(1) have "finite (insert None (Some ` X))" by simp
  moreover have "?F \<subseteq> P[insert None (Some ` X)]"
  proof
    fix hf
    assume "hf \<in> ?F"
    then obtain f where "f \<in> F" and hf: "hf = homogenize None (extend_indets f)" by auto
    from this(1) assms(2) have "f \<in> P[X]" ..
    hence "indets f \<subseteq> X" by (rule PolysD)
    hence "Some ` indets f \<subseteq> Some ` X" by (rule image_mono)
    with indets_extend_indets[of f] have "indets (extend_indets f) \<subseteq> Some ` X" by blast
    hence "insert None (indets (extend_indets f)) \<subseteq> insert None (Some ` X)" by blast
    with indets_homogenize_subset have "indets hf \<subseteq> insert None (Some ` X)"
      unfolding hf by (rule subset_trans)
    thus "hf \<in> P[insert None (Some ` X)]" by (rule PolysI_alt)
  qed
  ultimately have G_sub: "?G \<subseteq> P[insert None (Some ` X)]"
    and ideal_G: "ideal ?G = ideal ?F"
    and GB_G: "extended_ord.punit.is_reduced_GB ?G"
    by (rule extended_ord.reduced_GB_Polys, rule extended_ord.reduced_GB_ideal_Polys,
        rule extended_ord.reduced_GB_is_reduced_GB_Polys)

  show ?thesis3
  proof
    fix g
    assume "g \<in> restrict_indets ` ?G"
    then obtain g' where "g' \<in> ?G" and g: "g = restrict_indets g'" ..
    from this(1) G_sub have "g' \<in> P[insert None (Some ` X)]" ..
    hence "indets g' \<subseteq> insert None (Some ` X)" by (rule PolysD)
    have "indets g \<subseteq> the ` (indets g' - {None})" by (simp only: g indets_restrict_indets_subset)
    also from \<open>indets g' \<subseteq> insert None (Some ` X)\<close> have "\<dots> \<subseteq> X" by auto
    finally show "g \<in> P[X]" by (rule PolysI_alt)
  qed

  from dickson_grading_varnum show ?thesis1
  proof (rule punit.isGB_I_adds_lt[simplified])
    from \<open>?thesis3\<close> show "restrict_indets ` ?G \<subseteq> punit.dgrad_p_set (varnum X) 0"
      by (simp only: dgrad_p_set_varnum)
  next
    fix p :: "('a \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'b"
    assume "p \<noteq> 0"
    assume "p \<in> ideal (restrict_indets ` ?G)"
    hence "extend_indets p \<in> extend_indets ` ideal (restrict_indets ` ?G)" by (rule imageI)
    also have "\<dots> \<subseteq> ideal (extend_indets ` restrict_indets ` ?G)" by (fact extend_indets_ideal_subset)
    also have "\<dots> = ideal (dehomogenize None ` ?G)"
      by (simp only: image_comp extend_indets_comp_restrict_indets)
    finally have p_in_ideal: "extend_indets p \<in> ideal (dehomogenize None ` ?G)" .
    assume "p \<in> punit.dgrad_p_set (varnum X) 0"
    hence "p \<in> P[X]" by (simp only: dgrad_p_set_varnum)
    have "extended_ord.punit.is_Groebner_basis (dehomogenize None ` ?G)"
      using extended_ord_is_hom_ord \<open>finite (insert None (Some ` X))\<close> G_sub
    proof (rule extended_ord.isGB_dehomogenize)
      from GB_G show "extended_ord.punit.is_Groebner_basis ?G"
        by (rule extended_ord.punit.reduced_GB_D1)
    next
      fix g
      assume "g \<in> ?G"
      with _ GB_G ideal_G show "homogeneous g"
      proof (rule extended_ord.is_reduced_GB_homogeneous)
        fix hf
        assume "hf \<in> ?F"
        then obtain f where "hf = homogenize None f" ..
        thus "homogeneous hf" by (simp only: homogeneous_homogenize)
      qed
    qed
    moreover note p_in_ideal
    moreover from \<open>p \<noteq> 0\<close> have "extend_indets p \<noteq> 0" by simp
    ultimately obtain g where g_in: "g \<in> dehomogenize None ` ?G" and "g \<noteq> 0"
      and adds: "extended_ord.lpp g adds extended_ord.lpp (extend_indets p)"
      by (rule extended_ord.punit.GB_adds_lt[simplified])
    have "None \<notin> indets g"
    proof
      assume "None \<in> indets g"
      moreover from g_in obtain g0 where "g = dehomogenize None g0" ..
      ultimately show False using indets_dehomogenize[of None g0] by blast
    qed
    show "\<exists>g\<in>restrict_indets ` ?G. g \<noteq> 0 \<and> lpp g adds lpp p"
    proof (intro bexI conjI notI)
      have "lpp (restrict_indets g) = restrict_indets_pp (extended_ord.lpp g)"
        by (rule sym, intro extended_ord_lp \<open>None \<notin> indets g\<close>)
      also from adds have "\<dots> adds restrict_indets_pp (extended_ord.lpp (extend_indets p))"
        by (simp add: adds_poly_mapping le_fun_def lookup_restrict_indets_pp)
      also have "\<dots> = lpp (restrict_indets (extend_indets p))"
      proof (intro extended_ord_lp notI)
        assume "None \<in> indets (extend_indets p)"
        thus False by (simp add: indets_extend_indets)
      qed
      also have "\<dots> = lpp p" by simp
      finally show "lpp (restrict_indets g) adds lpp p" .
    next
      from g_in have "restrict_indets g \<in> restrict_indets ` dehomogenize None ` ?G" by (rule imageI)
      also have "\<dots> = restrict_indets ` ?G" by (simp only: image_comp restrict_indets_comp_dehomogenize)
      finally show "restrict_indets g \<in> restrict_indets ` ?G" .
    next
      assume "restrict_indets g = 0"
      with \<open>None \<notin> indets g\<close> extend_restrict_indets have "g = 0" by fastforce
      with \<open>g \<noteq> 0\<close> show False ..
    qed
  qed (fact assms(1))

  from ideal_G show ?thesis2 by (rule ideal_restrict_indets)
qed

end

end (* theory *)


subsection \<open>A Comparator-Interface to Red-Black-Trees\<close>

theory RBT_Comparator_Impl
imports
  "HOL-Library.RBT_Impl"
  Comparator
begin

text \<open>For all of the main algorithms of red-black trees, we
  provide alternatives which are completely based on comparators,
  and which are provable equivalent. At the time of writing,
  this interface is used in the Container AFP-entry.

  It does not rely on the modifications of code-equations as in
  the previous subsection.\<close>

context
  fixes c :: "'a comparator"
begin

primrec rbt_comp_lookup :: "('a, 'b) rbt \<Rightarrow> 'a \<rightharpoonup> 'b"
where
  "rbt_comp_lookup RBT_Impl.Empty k = None"
| "rbt_comp_lookup (Branch _ l x y r) k =
   (case c k x of Lt \<Rightarrow> rbt_comp_lookup l k
     | Gt \<Rightarrow> rbt_comp_lookup r k
     | Eq \<Rightarrow> Some y)"

fun
  rbt_comp_ins :: "('a \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> ('a,'b) rbt \<Rightarrow> ('a,'b) rbt"
where
  "rbt_comp_ins f k v RBT_Impl.Empty = Branch RBT_Impl.R RBT_Impl.Empty k v  RBT_Impl.Empty" |
  "rbt_comp_ins f k v (Branch RBT_Impl.B l x y r) = (case c k x of
      Lt \<Rightarrow> balance (rbt_comp_ins f k v l) x y r
    | Gt \<Rightarrow> balance l x y (rbt_comp_ins f k v r)
    | Eq \<Rightarrow> Branch RBT_Impl.B l x (f k y v) r)" |
  "rbt_comp_ins f k v (Branch RBT_Impl.R l x y r) = (case c k x of
      Lt \<Rightarrow> Branch RBT_Impl.R (rbt_comp_ins f k v l) x y r
    | Gt \<Rightarrow> Branch RBT_Impl.R l x y (rbt_comp_ins f k v r)
    | Eq \<Rightarrow> Branch RBT_Impl.R l x (f k y v) r)"

definition rbt_comp_insert_with_key :: "('a \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> ('a,'b) rbt \<Rightarrow> ('a,'b) rbt"
where "rbt_comp_insert_with_key f k v t = paint RBT_Impl.B (rbt_comp_ins f k v t)"

definition rbt_comp_insert :: "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt" where
  "rbt_comp_insert = rbt_comp_insert_with_key (\<lambda>_ _ nv. nv)"

fun
  rbt_comp_del_from_left :: "'a \<Rightarrow> ('a,'b) rbt \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> ('a,'b) rbt \<Rightarrow> ('a,'b) rbt" and
  rbt_comp_del_from_right :: "'a \<Rightarrow> ('a,'b) rbt \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> ('a,'b) rbt \<Rightarrow> ('a,'b) rbt" and
  rbt_comp_del :: "'a\<Rightarrow> ('a,'b) rbt \<Rightarrow> ('a,'b) rbt"
where
  "rbt_comp_del x RBT_Impl.Empty = RBT_Impl.Empty" |
  "rbt_comp_del x (Branch _ a y s b) =
   (case c x y of
        Lt \<Rightarrow> rbt_comp_del_from_left x a y s b
      | Gt \<Rightarrow> rbt_comp_del_from_right x a y s b
      | Eq \<Rightarrow> combine a b)" |
  "rbt_comp_del_from_left x (Branch RBT_Impl.B lt z v rt) y s b = balance_left (rbt_comp_del x (Branch RBT_Impl.B lt z v rt)) y s b" |
  "rbt_comp_del_from_left x a y s b = Branch RBT_Impl.R (rbt_comp_del x a) y s b" |
  "rbt_comp_del_from_right x a y s (Branch RBT_Impl.B lt z v rt) = balance_right a y s (rbt_comp_del x (Branch RBT_Impl.B lt z v rt))" |
  "rbt_comp_del_from_right x a y s b = Branch RBT_Impl.R a y s (rbt_comp_del x b)"

definition "rbt_comp_delete k t = paint RBT_Impl.B (rbt_comp_del k t)"

definition "rbt_comp_bulkload xs = foldr (\<lambda>(k, v). rbt_comp_insert k v) xs RBT_Impl.Empty"

primrec
  rbt_comp_map_entry :: "'a \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt"
where
  "rbt_comp_map_entry k f RBT_Impl.Empty = RBT_Impl.Empty"
| "rbt_comp_map_entry k f (Branch cc lt x v rt) =
    (case c k x of
        Lt \<Rightarrow> Branch cc (rbt_comp_map_entry k f lt) x v rt
      | Gt \<Rightarrow> Branch cc lt x v (rbt_comp_map_entry k f rt)
      | Eq \<Rightarrow> Branch cc lt x (f v) rt)"

function comp_sunion_with :: "('a \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> ('a \<times> 'b) list"
where
  "comp_sunion_with f ((k, v) # as) ((k', v') # bs) =
   (case c k' k of
        Lt \<Rightarrow> (k', v') # comp_sunion_with f ((k, v) # as) bs
      | Gt \<Rightarrow> (k, v) # comp_sunion_with f as ((k', v') # bs)
      | Eq \<Rightarrow> (k, f k v v') # comp_sunion_with f as bs)"
| "comp_sunion_with f [] bs = bs"
| "comp_sunion_with f as [] = as"
by pat_completeness auto
termination by lexicographic_order

function comp_sinter_with :: "('a \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> ('a \<times> 'b) list"
where
  "comp_sinter_with f ((k, v) # as) ((k', v') # bs) =
  (case c k' k of
      Lt \<Rightarrow> comp_sinter_with f ((k, v) # as) bs
    | Gt \<Rightarrow> comp_sinter_with f as ((k', v') # bs)
    | Eq \<Rightarrow> (k, f k v v') # comp_sinter_with f as bs)"
| "comp_sinter_with f [] _ = []"
| "comp_sinter_with f _ [] = []"
by pat_completeness auto
termination by lexicographic_order

definition rbt_comp_union_with_key :: "('a \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt"
where
  "rbt_comp_union_with_key f t1 t2 =
  (case RBT_Impl.compare_height t1 t1 t2 t2
   of compare.EQ \<Rightarrow> rbtreeify (comp_sunion_with f (RBT_Impl.entries t1) (RBT_Impl.entries t2))
    | compare.LT \<Rightarrow> RBT_Impl.fold (rbt_comp_insert_with_key (\<lambda>k v w. f k w v)) t1 t2
    | compare.GT \<Rightarrow> RBT_Impl.fold (rbt_comp_insert_with_key f) t2 t1)"

definition rbt_comp_inter_with_key :: "('a \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt"
where
  "rbt_comp_inter_with_key f t1 t2 =
  (case RBT_Impl.compare_height t1 t1 t2 t2
   of compare.EQ \<Rightarrow> rbtreeify (comp_sinter_with f (RBT_Impl.entries t1) (RBT_Impl.entries t2))
    | compare.LT \<Rightarrow> rbtreeify (List.map_filter (\<lambda>(k, v). map_option (\<lambda>w. (k, f k v w)) (rbt_comp_lookup t2 k)) (RBT_Impl.entries t1))
    | compare.GT \<Rightarrow> rbtreeify (List.map_filter (\<lambda>(k, v). map_option (\<lambda>w. (k, f k w v)) (rbt_comp_lookup t1 k)) (RBT_Impl.entries t2)))"

context
  assumes c: "comparator c"
begin

lemma rbt_comp_lookup: "rbt_comp_lookup = ord.rbt_lookup (lt_of_comp c)"
proof (intro ext)
  fix k and t :: "('a,'b)rbt"
  show "rbt_comp_lookup t k = ord.rbt_lookup (lt_of_comp c) t k"
    by (induct t, unfold rbt_comp_lookup.simps ord.rbt_lookup.simps
      comparator.two_comparisons_into_case_order[OF c])
      (auto split: order.splits)
qed

lemma rbt_comp_ins: "rbt_comp_ins = ord.rbt_ins (lt_of_comp c)"
proof (intro ext)
  fix f k v and t :: "('a,'b)rbt"
  show "rbt_comp_ins f k v t = ord.rbt_ins (lt_of_comp c) f k v t"
    by (induct f k v t rule: rbt_comp_ins.induct, unfold rbt_comp_ins.simps ord.rbt_ins.simps
      comparator.two_comparisons_into_case_order[OF c])
      (auto split: order.splits)
qed

lemma rbt_comp_insert_with_key: "rbt_comp_insert_with_key = ord.rbt_insert_with_key (lt_of_comp c)"
  unfolding rbt_comp_insert_with_key_def[abs_def] ord.rbt_insert_with_key_def[abs_def]
  unfolding rbt_comp_ins ..

lemma rbt_comp_insert: "rbt_comp_insert = ord.rbt_insert (lt_of_comp c)"
  unfolding rbt_comp_insert_def[abs_def] ord.rbt_insert_def[abs_def]
  unfolding rbt_comp_insert_with_key ..

lemma rbt_comp_del: "rbt_comp_del = ord.rbt_del (lt_of_comp c)"
proof - {
  fix k a b and s t :: "('a,'b)rbt"
  have
    "rbt_comp_del_from_left k t a b s = ord.rbt_del_from_left (lt_of_comp c) k t a b s"
    "rbt_comp_del_from_right k t a b s = ord.rbt_del_from_right (lt_of_comp c) k t a b s"
    "rbt_comp_del k t = ord.rbt_del (lt_of_comp c) k t"
  by (induct k t a b s and k t a b s and k t rule: rbt_comp_del_from_left_rbt_comp_del_from_right_rbt_comp_del.induct,
    unfold
      rbt_comp_del.simps ord.rbt_del.simps
      rbt_comp_del_from_left.simps ord.rbt_del_from_left.simps
      rbt_comp_del_from_right.simps ord.rbt_del_from_right.simps
      comparator.two_comparisons_into_case_order[OF c],
    auto split: order.split)
  }
  thus ?thesis by (intro ext)
qed

lemma rbt_comp_delete: "rbt_comp_delete = ord.rbt_delete (lt_of_comp c)"
  unfolding rbt_comp_delete_def[abs_def] ord.rbt_delete_def[abs_def]
  unfolding rbt_comp_del ..

lemma rbt_comp_bulkload: "rbt_comp_bulkload = ord.rbt_bulkload (lt_of_comp c)"
  unfolding rbt_comp_bulkload_def[abs_def] ord.rbt_bulkload_def[abs_def]
  unfolding rbt_comp_insert ..

lemma rbt_comp_map_entry: "rbt_comp_map_entry = ord.rbt_map_entry (lt_of_comp c)"
proof (intro ext)
  fix f k and t :: "('a,'b)rbt"
  show "rbt_comp_map_entry f k t = ord.rbt_map_entry (lt_of_comp c) f k t"
    by (induct t, unfold rbt_comp_map_entry.simps ord.rbt_map_entry.simps
      comparator.two_comparisons_into_case_order[OF c])
      (auto split: order.splits)
qed

lemma comp_sunion_with: "comp_sunion_with = ord.sunion_with (lt_of_comp c)"
proof (intro ext)
  fix f and as bs :: "('a \<times> 'b)list"
  show "comp_sunion_with f as bs = ord.sunion_with (lt_of_comp c) f as bs"
    by (induct f as bs rule: comp_sunion_with.induct,
      unfold comp_sunion_with.simps ord.sunion_with.simps
      comparator.two_comparisons_into_case_order[OF c])
      (auto split: order.splits)
qed

lemma comp_sinter_with: "comp_sinter_with = ord.sinter_with (lt_of_comp c)"
proof (intro ext)
  fix f and as bs :: "('a \<times> 'b)list"
  show "comp_sinter_with f as bs = ord.sinter_with (lt_of_comp c) f as bs"
    by (induct f as bs rule: comp_sinter_with.induct,
      unfold comp_sinter_with.simps ord.sinter_with.simps
      comparator.two_comparisons_into_case_order[OF c])
      (auto split: order.splits)
qed

lemma rbt_comp_union_with_key: "rbt_comp_union_with_key = ord.rbt_union_with_key (lt_of_comp c)"
  unfolding rbt_comp_union_with_key_def[abs_def] ord.rbt_union_with_key_def[abs_def]
  unfolding rbt_comp_insert_with_key comp_sunion_with ..

lemma rbt_comp_inter_with_key: "rbt_comp_inter_with_key = ord.rbt_inter_with_key (lt_of_comp c)"
  unfolding rbt_comp_inter_with_key_def[abs_def] ord.rbt_inter_with_key_def[abs_def]
  unfolding rbt_comp_insert_with_key comp_sinter_with rbt_comp_lookup ..

lemmas rbt_comp_simps =
  rbt_comp_insert
  rbt_comp_lookup
  rbt_comp_delete
  rbt_comp_bulkload
  rbt_comp_map_entry
  rbt_comp_union_with_key
  rbt_comp_inter_with_key
end
end

end