(*  Title:      ZF/UNITY/Increasing.thy
    Author:     Sidi O Ehmety, Cambridge University Computer Laboratory
    Copyright   2001  University of Cambridge

Increasing's parameters are a state function f, a domain A and an order
relation r over the domain A.
*)

section\<open>Charpentier's "Increasing" Relation\<close>

theory Increasing imports Constrains Monotonicity begin

definition
  increasing :: "[i, i, i=>i] => i" ("increasing[_]'(_, _')")  where
  "increasing[A](r, f) ==
    {F \<in> program. (\<forall>k \<in> A. F \<in> stable({s \<in> state. <k, f(s)> \<in> r})) &
                (\<forall>x \<in> state. f(x):A)}"

definition
  Increasing :: "[i, i, i=>i] => i" ("Increasing[_]'(_, _')")  where
  "Increasing[A](r, f) ==
    {F \<in> program. (\<forall>k \<in> A. F \<in> Stable({s \<in> state. <k, f(s)> \<in> r})) &
                (\<forall>x \<in> state. f(x):A)}"

abbreviation (input)
  IncWrt ::  "[i=>i, i, i] => i" ("(_ IncreasingWrt _ '/ _)" [60, 0, 60] 60)  where
  "f IncreasingWrt r/A == Increasing[A](r,f)"

(** increasing **)

lemma increasing_type: "increasing[A](r, f) \<subseteq> program"
by (unfold increasing_def, blast)

lemma increasing_into_program: "F \<in> increasing[A](r, f) ==> F \<in> program"
by (unfold increasing_def, blast)

lemma increasing_imp_stable:
"[| F \<in> increasing[A](r, f); x \<in> A |] ==>F \<in> stable({s \<in> state. <x, f(s)>:r})"
by (unfold increasing_def, blast)

lemma increasingD:
"F \<in> increasing[A](r,f) ==> F \<in> program & (\<exists>a. a \<in> A) & (\<forall>s \<in> state. f(s):A)"
apply (unfold increasing_def)
apply (subgoal_tac "\<exists>x. x \<in> state")
apply (auto dest: stable_type [THEN subsetD] intro: st0_in_state)
done

lemma increasing_constant [simp]:
 "F \<in> increasing[A](r, %s. c) \<longleftrightarrow> F \<in> program & c \<in> A"
apply (unfold increasing_def stable_def)
apply (subgoal_tac "\<exists>x. x \<in> state")
apply (auto dest: stable_type [THEN subsetD] intro: st0_in_state)
done

lemma subset_increasing_comp:
"[| mono1(A, r, B, s, g); refl(A, r); trans[B](s)  |] ==>
   increasing[A](r, f) \<subseteq> increasing[B](s, g comp f)"
apply (unfold increasing_def stable_def part_order_def
       constrains_def mono1_def metacomp_def, clarify, simp)
apply clarify
apply (subgoal_tac "xa \<in> state")
prefer 2 apply (blast dest!: ActsD)
apply (subgoal_tac "<f (xb), f (xb) >:r")
prefer 2 apply (force simp add: refl_def)
apply (rotate_tac 5)
apply (drule_tac x = "f (xb) " in bspec)
apply (rotate_tac [2] -1)
apply (drule_tac [2] x = act in bspec, simp_all)
apply (drule_tac A = "act``u" and c = xa for u in subsetD, blast)
apply (drule_tac x = "f(xa) " and x1 = "f(xb)" in bspec [THEN bspec])
apply (rule_tac [3] b = "g (f (xb))" and A = B in trans_onD)
apply simp_all
done

lemma imp_increasing_comp:
     "[| F \<in> increasing[A](r, f); mono1(A, r, B, s, g);
         refl(A, r); trans[B](s) |] ==> F \<in> increasing[B](s, g comp f)"
by (rule subset_increasing_comp [THEN subsetD], auto)

lemma strict_increasing:
   "increasing[nat](Le, f) \<subseteq> increasing[nat](Lt, f)"
by (unfold increasing_def Lt_def, auto)

lemma strict_gt_increasing:
   "increasing[nat](Ge, f) \<subseteq> increasing[nat](Gt, f)"
apply (unfold increasing_def Gt_def Ge_def, auto)
apply (erule natE)
apply (auto simp add: stable_def)
done

(** Increasing **)

lemma increasing_imp_Increasing:
     "F \<in> increasing[A](r, f) ==> F \<in> Increasing[A](r, f)"

apply (unfold increasing_def Increasing_def)
apply (auto intro: stable_imp_Stable)
done

lemma Increasing_type: "Increasing[A](r, f) \<subseteq> program"
by (unfold Increasing_def, auto)

lemma Increasing_into_program: "F \<in> Increasing[A](r, f) ==> F \<in> program"
by (unfold Increasing_def, auto)

lemma Increasing_imp_Stable:
"[| F \<in> Increasing[A](r, f); a \<in> A |] ==> F \<in> Stable({s \<in> state. <a,f(s)>:r})"
by (unfold Increasing_def, blast)

lemma IncreasingD:
"F \<in> Increasing[A](r, f) ==> F \<in> program & (\<exists>a. a \<in> A) & (\<forall>s \<in> state. f(s):A)"
apply (unfold Increasing_def)
apply (subgoal_tac "\<exists>x. x \<in> state")
apply (auto intro: st0_in_state)
done

lemma Increasing_constant [simp]:
     "F \<in> Increasing[A](r, %s. c) \<longleftrightarrow> F \<in> program & (c \<in> A)"
apply (subgoal_tac "\<exists>x. x \<in> state")
apply (auto dest!: IncreasingD intro: st0_in_state increasing_imp_Increasing)
done

lemma subset_Increasing_comp:
"[| mono1(A, r, B, s, g); refl(A, r); trans[B](s) |] ==>
   Increasing[A](r, f) \<subseteq> Increasing[B](s, g comp f)"
apply (unfold Increasing_def Stable_def Constrains_def part_order_def
       constrains_def mono1_def metacomp_def, safe)
apply (simp_all add: ActsD)
apply (subgoal_tac "xb \<in> state & xa \<in> state")
 prefer 2 apply (simp add: ActsD)
apply (subgoal_tac "<f (xb), f (xb) >:r")
prefer 2 apply (force simp add: refl_def)
apply (rotate_tac 5)
apply (drule_tac x = "f (xb) " in bspec)
apply simp_all
apply clarify
apply (rotate_tac -2)
apply (drule_tac x = act in bspec)
apply (drule_tac [2] A = "act``u" and c = xa for u in subsetD, simp_all, blast)
apply (drule_tac x = "f(xa)" and x1 = "f(xb)" in bspec [THEN bspec])
apply (rule_tac [3] b = "g (f (xb))" and A = B in trans_onD)
apply simp_all
done

lemma imp_Increasing_comp:
 "[| F \<in> Increasing[A](r, f); mono1(A, r, B, s, g); refl(A, r); trans[B](s) |]
  ==> F \<in> Increasing[B](s, g comp f)"
apply (rule subset_Increasing_comp [THEN subsetD], auto)
done

lemma strict_Increasing: "Increasing[nat](Le, f) \<subseteq> Increasing[nat](Lt, f)"
by (unfold Increasing_def Lt_def, auto)

lemma strict_gt_Increasing: "Increasing[nat](Ge, f)<= Increasing[nat](Gt, f)"
apply (unfold Increasing_def Ge_def Gt_def, auto)
apply (erule natE)
apply (auto simp add: Stable_def)
done

(** Two-place monotone operations **)

lemma imp_increasing_comp2:
"[| F \<in> increasing[A](r, f); F \<in> increasing[B](s, g);
    mono2(A, r, B, s, C, t, h); refl(A, r); refl(B, s); trans[C](t) |]
 ==> F \<in> increasing[C](t, %x. h(f(x), g(x)))"
apply (unfold increasing_def stable_def
       part_order_def constrains_def mono2_def, clarify, simp)
apply clarify
apply (rename_tac xa xb)
apply (subgoal_tac "xb \<in> state & xa \<in> state")
 prefer 2 apply (blast dest!: ActsD)
apply (subgoal_tac "<f (xb), f (xb) >:r & <g (xb), g (xb) >:s")
prefer 2 apply (force simp add: refl_def)
apply (rotate_tac 6)
apply (drule_tac x = "f (xb) " in bspec)
apply (rotate_tac [2] 1)
apply (drule_tac [2] x = "g (xb) " in bspec)
apply simp_all
apply (rotate_tac -1)
apply (drule_tac x = act in bspec)
apply (rotate_tac [2] -3)
apply (drule_tac [2] x = act in bspec, simp_all)
apply (drule_tac A = "act``u" and c = xa for u in subsetD)
apply (drule_tac [2] A = "act``u" and c = xa for u in subsetD, blast, blast)
apply (rotate_tac -4)
apply (drule_tac x = "f (xa) " and x1 = "f (xb) " in bspec [THEN bspec])
apply (rotate_tac [3] -1)
apply (drule_tac [3] x = "g (xa) " and x1 = "g (xb) " in bspec [THEN bspec])
apply simp_all
apply (rule_tac b = "h (f (xb), g (xb))" and A = C in trans_onD)
apply simp_all
done

lemma imp_Increasing_comp2:
"[| F \<in> Increasing[A](r, f); F \<in> Increasing[B](s, g);
  mono2(A, r, B, s, C, t, h); refl(A, r); refl(B, s); trans[C](t) |] ==>
  F \<in> Increasing[C](t, %x. h(f(x), g(x)))"
apply (unfold Increasing_def stable_def
       part_order_def constrains_def mono2_def Stable_def Constrains_def, safe)
apply (simp_all add: ActsD)
apply (subgoal_tac "xa \<in> state & x \<in> state")
prefer 2 apply (blast dest!: ActsD)
apply (subgoal_tac "<f (xa), f (xa) >:r & <g (xa), g (xa) >:s")
prefer 2 apply (force simp add: refl_def)
apply (rotate_tac 6)
apply (drule_tac x = "f (xa) " in bspec)
apply (rotate_tac [2] 1)
apply (drule_tac [2] x = "g (xa) " in bspec)
apply simp_all
apply clarify
apply (rotate_tac -2)
apply (drule_tac x = act in bspec)
apply (rotate_tac [2] -3)
apply (drule_tac [2] x = act in bspec, simp_all)
apply (drule_tac A = "act``u" and c = x for u in subsetD)
apply (drule_tac [2] A = "act``u" and c = x for u in subsetD, blast, blast)
apply (rotate_tac -9)
apply (drule_tac x = "f (x) " and x1 = "f (xa) " in bspec [THEN bspec])
apply (rotate_tac [3] -1)
apply (drule_tac [3] x = "g (x) " and x1 = "g (xa) " in bspec [THEN bspec])
apply simp_all
apply (rule_tac b = "h (f (xa), g (xa))" and A = C in trans_onD)
apply simp_all
done

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsubsection \<open>Alignment With Definitions from HOL\<close>
theory HOL_Alignment_Orders
  imports
    "HOL-Library.Preorder"
    HOL_Alignment_Binary_Relations
    HOL_Syntax_Bundles_Orders
    Orders
begin

named_theorems HOL_order_alignment

paragraph \<open>Functions\<close>
subparagraph \<open>Bi-Related\<close>

lemma (in preorder_equiv) equiv_eq_bi_related [HOL_order_alignment]:
  "equiv = bi_related (\<le>)"
  by (intro ext) (auto intro: equiv_antisym dest: equivD1 equivD2)

subparagraph \<open>Inflationary\<close>

overloading
  inflationary_on_set \<equiv> "inflationary_on :: 'a set \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool"
begin
  definition "inflationary_on_set (S :: 'a set) :: ('a \<Rightarrow> _) \<Rightarrow> _ \<equiv>
    inflationary_on (mem_of S)"
end

lemma inflationary_on_set_eq_inflationary_on_pred [simp]:
  "(inflationary_on (S :: 'a set) :: ('a \<Rightarrow> _) \<Rightarrow> _) = inflationary_on (mem_of S)"
  unfolding inflationary_on_set_def by simp

lemma inflationary_on_set_iff_inflationary_on_pred [iff]:
  "inflationary_on (S :: 'a set) (R :: 'a \<Rightarrow> _) f \<longleftrightarrow> inflationary_on (mem_of S) R f"
  by simp

text \<open>Terms like @{term deflationary_on}, @{term rel_equivalence_on},
and @{term idempotent_on} are automatically overloaded. One can get similar
correspondence lemmas by unfolding the corresponding definitional theorems,
e.g. @{thm deflationary_on_eq_inflationary_on_rel_inv}.\<close>

paragraph \<open>Properties\<close>
subparagraph \<open>Equivalence Relations\<close>

lemma equiv_eq_equivalence_rel [HOL_order_alignment]: "equivp = equivalence_rel"
  by (intro ext) (fastforce intro!: equivpI
    simp: HOL_bin_rel_alignment reflexive_eq_reflexive_on elim!: equivpE)

subparagraph \<open>Partial Equivalence Relations\<close>

lemma part_equiv_eq_partial_equivalence_rel_if_rel [HOL_order_alignment]:
  assumes "R x y"
  shows "part_equivp R = partial_equivalence_rel R"
  using assms by (fastforce intro!: part_equivpI
    simp: HOL_bin_rel_alignment elim!: part_equivpE)

subparagraph \<open>Partial Orders\<close>

lemma (in order) partial_order [HOL_order_alignment]: "partial_order (\<le>)"
  using order_refl order_trans order_antisym by blast

subparagraph \<open>Preorders\<close>

lemma (in partial_preordering) preorder [HOL_order_alignment]: "preorder (\<^bold>\<le>)"
  using refl trans by blast

lemma partial_preordering_eq [HOL_order_alignment]:
  "partial_preordering = Preorders.preorder"
  by (intro ext) (auto intro: partial_preordering.intro
    dest: partial_preordering.trans partial_preordering.refl reflexiveD)

end


(*  Title:       Executable multivariate polynomials
    Author:      Christian Sternagel <christian.sternagel@uibk.ac.at>
                 Rene Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  Christian Sternagel and Rene Thiemann
    License:     LGPL
*)

(*
Copyright 2010 Christian Sternagel and René Thiemann

This file is part of IsaFoR/CeTA.

IsaFoR/CeTA is free software: you can redistribute it and/or modify it under the
terms of the GNU Lesser General Public License as published by the Free Software
Foundation, either version 3 of the License, or (at your option) any later
version.

IsaFoR/CeTA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.  See the GNU Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public License along
with IsaFoR/CeTA. If not, see <http://www.gnu.org/licenses/>.
*)

section \<open>Carriers of Strongly Normalizing Orders\<close>

theory SN_Order_Carrier
imports
  SN_Orders
  HOL.Rat
begin

text \<open>
  This theory shows that standard semirings can be used
  in combination with polynomials, e.g. the naturals, integers,
  and arbitrary Archemedean fields by using delta-orders.

  It also contains the arctic integers and arctic delta-orders where
  0 is -infty, 1 is zero, + is max and * is plus.
\<close>

subsection \<open>The standard semiring over the naturals\<close>

instantiation nat :: large_ordered_semiring_1
begin
instance by (intro_classes, auto)
end

definition nat_mono :: "nat \<Rightarrow> bool" where "nat_mono x \<equiv> x \<noteq> 0"

interpretation nat_SN: SN_strict_mono_ordered_semiring_1 1 "(>) :: nat \<Rightarrow> nat \<Rightarrow> bool" nat_mono
  by (unfold_locales, insert SN_nat_gt, auto simp: nat_mono_def)

interpretation nat_poly: poly_order_carrier 1 "(>) :: nat \<Rightarrow> nat \<Rightarrow> bool" True discrete
proof (unfold_locales)
  fix x y :: nat
  assume ge: "x \<ge> y"
  obtain k where k: "x - y = k" by auto
  show "\<exists> k. x = ((+) 1 ^^ k) y"
  proof (rule exI[of _ k])
    from ge k have "x = k + y" by simp
    also have "\<dots> = ((+) 1 ^^ k) y"
      by (induct k, auto)
    finally show "x = ((+) 1 ^^ k) y" .
  qed
qed (auto simp: field_simps power_strict_mono)

subsection \<open>The standard semiring over the Archimedean fields using delta-orderings\<close>

definition delta_gt :: "'a :: floor_ceiling \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "delta_gt \<delta> \<equiv> (\<lambda> x y. x - y \<ge> \<delta>)"

lemma non_inf_delta_gt: assumes delta: "\<delta> > 0"
  shows "non_inf {(a,b) . delta_gt \<delta> a b}" (is "non_inf ?r")
proof
  let ?gt = "delta_gt \<delta>"
  fix a :: 'a and f
  assume "\<And> i. (f i, f (Suc i)) \<in> ?r"
  hence gt: "\<And> i. ?gt (f i) (f (Suc i))" by simp
  {
    fix i
    have "f i \<le> f 0 - \<delta> * of_nat i"
    proof (induct i)
      case (Suc i)
      thus ?case using gt[of i, unfolded delta_gt_def] by (auto simp: field_simps)
    qed simp
  } note fi = this
  {
    fix r :: 'a
    have "of_nat (nat (ceiling r)) \<ge> r"
      by (metis ceiling_le_zero le_of_int_ceiling less_le_not_le nat_0_iff not_less of_nat_0 of_nat_nat)
  } note ceil_elim = this
  define i where "i = nat (ceiling ((f 0 - a) / \<delta>))"
  from fi[of i] have "f i - f 0 \<le> - \<delta> * of_nat (nat (ceiling ((f 0 - a) / \<delta>)))" unfolding i_def by simp
  also have "\<dots> \<le> - \<delta> * ((f 0 - a) / \<delta>)" using ceil_elim[of "(f 0 - a) / \<delta>"] delta
    by (metis le_imp_neg_le minus_mult_commute mult_le_cancel_left_pos)
  also have "\<dots> = - f 0 + a" using delta by auto
  also have "\<dots> < - f 0 + a + \<delta>" using delta by auto
  finally have "\<not> ?gt (f i) a" unfolding delta_gt_def by arith
  thus "\<exists> i. (f i, a) \<notin> ?r" by blast
qed

lemma delta_gt_SN: assumes dpos: "\<delta> > 0" shows "SN {(x,y). 0 \<le> y \<and> delta_gt \<delta> x y}"
proof -
  from non_inf_imp_SN_bound[OF non_inf_delta_gt[OF dpos], of "- \<delta>"]
  show ?thesis unfolding delta_gt_def by auto
qed

definition delta_mono :: "'a :: floor_ceiling \<Rightarrow> bool" where "delta_mono x \<equiv> x \<ge> 1"

subclass (in floor_ceiling) large_ordered_semiring_1
proof
  fix x :: 'a
  from ex_le_of_int[of x] obtain z where x: "x \<le> of_int z" by auto
  have "z \<le> int (nat z)" by auto
  with x have "x \<le> of_int (int (nat z))"
    by (metis (full_types) le_cases of_int_0_le_iff of_int_of_nat_eq of_nat_0_le_iff of_nat_nat order_trans)
  also have "\<dots> = of_nat (nat z)" unfolding of_int_of_nat_eq ..
  finally
  show "\<exists> y. x \<le> of_nat y" by blast
qed (auto simp: mult_right_mono mult_left_mono mult_right_mono_neg max_def)

lemma delta_interpretation: assumes dpos: "\<delta> > 0" and default: "\<delta> \<le> def"
  shows "SN_strict_mono_ordered_semiring_1 def (delta_gt \<delta>) delta_mono"
proof -
  from dpos default have defz: "0 \<le> def" by auto
  show ?thesis
  proof (unfold_locales)
    show "SN {(x,y). y \<ge> 0 \<and> delta_gt \<delta> x y}" by (rule delta_gt_SN[OF dpos])
  next
    fix x y z :: 'a
    assume "delta_mono x" and yz: "delta_gt \<delta> y z"
    hence x: "1 \<le> x" unfolding delta_mono_def by simp
    have "\<exists> d > 0. delta_gt \<delta> = (\<lambda> x y. d \<le> x - y)"
      by (rule exI[of _ \<delta>], auto simp: dpos delta_gt_def)
    from this obtain d where d: "0 < d" and rat: "delta_gt \<delta> = (\<lambda> x y. d \<le> x - y)" by auto
    from yz have yzd: "d \<le> y - z" by (simp add: rat)
    show "delta_gt \<delta> (x * y) (x * z)"
    proof (simp only: rat)
      let ?p = "(x - 1) * (y - z)"
      from x have x1: "0 \<le> x - 1" by auto
      from yzd d have yz0: "0 \<le> y - z" by auto
      have "0 \<le> ?p"
        by (rule mult_nonneg_nonneg[OF x1 yz0])
      have "x * y - x * z = x * (y - z)" using right_diff_distrib[of x y z] by auto
      also have "\<dots> = ((x - 1) + 1) * (y - z)" by auto
      also have "\<dots> = ?p + 1 * ( y - z)" by (rule ring_distribs(2))
      also have "\<dots> = ?p + (y - z)" by simp
      also have "\<dots> \<ge> (0 + d)" using yzd \<open>0 \<le> ?p\<close> by auto
      finally
      show "d \<le> x * y - x * z" by auto
    qed
  qed (insert dpos, auto simp: delta_gt_def default defz)
qed

lemma delta_poly: assumes dpos: "\<delta> > 0" and default: "\<delta> \<le> def"
  shows "poly_order_carrier def (delta_gt \<delta>) (1 \<le> \<delta>) False"
proof -
  from delta_interpretation[OF dpos default]
  interpret SN_strict_mono_ordered_semiring_1 "def" "delta_gt \<delta>" delta_mono .
  interpret poly_order_carrier "def" "delta_gt \<delta>" False False
  proof(unfold_locales)
    fix y z x :: 'a
    assume gt: "delta_gt \<delta> y z" and ge: "x \<ge> 1"
    from ge have ge: "x \<ge> 0" and m: "delta_mono x" unfolding delta_mono_def by auto
    show "delta_gt \<delta> (y * x) (z * x)"
      using mono[OF m gt ge] by (auto simp: field_simps)
  next
    fix x y :: 'a and n :: nat
    assume False thus "delta_gt \<delta> (x ^ n) (y ^ n)" ..
  next
    fix x y :: 'a
    assume False
    thus "\<exists> k. x = ((+) 1 ^^ k) y" by simp
  qed
  show ?thesis
  proof(unfold_locales)
    fix x y :: 'a and n :: nat
    assume one: "1 \<le> \<delta>" and gt: "delta_gt \<delta> x y" and y: "y \<ge> 0" and n: "1 \<le> n"
    then obtain p where n: "n = Suc p" and x: "x \<ge> 1" and y2: "0 \<le> y" and xy: "x \<ge> y" by (cases n, auto simp: delta_gt_def)
    show "delta_gt \<delta> (x ^ n) (y ^ n)"
    proof (simp only: n, induct p, simp add: gt)
      case (Suc p)
      from times_gt_mono[OF this x]
      have one: "delta_gt \<delta> (x ^ Suc (Suc p)) (x * y ^ Suc p)" by (auto simp: field_simps)
      also have "\<dots> \<ge> y * y ^ Suc p"
        by (rule times_left_mono[OF _ xy], auto simp: zero_le_power[OF y2, of "Suc p", simplified])
      finally show ?case by auto
    qed
  next
    fix x y :: 'a
    assume False
    thus "\<exists> k. x = ((+) 1 ^^ k) y" by simp
  qed (rule times_gt_mono, auto)
qed

lemma delta_minimal_delta: assumes "\<And> x y. (x,y) \<in> set xys \<Longrightarrow> x > y"
  shows "\<exists> \<delta> > 0. \<forall> x y. (x,y) \<in> set xys \<longrightarrow> delta_gt \<delta> x y"
using assms
proof (induct xys)
  case Nil
  show ?case by (rule exI[of _ 1], auto)
next
  case (Cons xy xys)
  show ?case
  proof (cases xy)
    case (Pair x y)
    with Cons have "x > y" by auto
    then obtain d1 where "d1 = x - y" and d1pos: "d1 > 0" and "d1 \<le> x - y" by auto
    hence xy: "delta_gt d1 x y" unfolding delta_gt_def by auto
    from Cons obtain d2 where d2pos: "d2 > 0" and xys: "\<forall> x y. (x, y) \<in> set xys \<longrightarrow> delta_gt d2 x y" by auto
    obtain d where d: "d = min d1 d2" by auto
    with d1pos d2pos xy have dpos: "d > 0" and "delta_gt d x y" unfolding delta_gt_def by auto
    with xys d Pair have "\<forall> x y. (x,y) \<in> set (xy # xys) \<longrightarrow> delta_gt d x y" unfolding delta_gt_def by force
    with dpos show ?thesis by auto
  qed
qed

interpretation weak_delta_SN: weak_SN_strict_mono_ordered_semiring_1 "(>)" 1 delta_mono
proof
  fix xysp :: "('a \<times> 'a) list"
  assume orient: "\<forall> x y. (x,y) \<in> set xysp \<longrightarrow> x > y"
  obtain xys where xsy: "xys = (1,0) # xysp" by auto
  with orient have "\<And> x y. (x,y) \<in> set xys \<Longrightarrow> x > y" by auto
  with delta_minimal_delta have "\<exists> \<delta> > 0. \<forall> x y. (x,y) \<in> set xys \<longrightarrow> delta_gt \<delta> x y" by auto
  then obtain \<delta> where dpos: "\<delta> > 0" and orient: "\<And> x y. (x,y) \<in> set xys \<Longrightarrow> delta_gt \<delta> x y" by auto
  from orient have orient1: "\<forall> x y. (x,y) \<in> set xysp \<longrightarrow> delta_gt \<delta> x y" and orient2: "delta_gt \<delta> 1 0" unfolding xsy by auto
  from orient2 have oned: "\<delta> \<le> 1" unfolding delta_gt_def by auto
  show " \<exists>gt. SN_strict_mono_ordered_semiring_1 1 gt delta_mono \<and> (\<forall>x y. (x, y) \<in> set xysp \<longrightarrow> gt x y)"
    by (intro exI conjI, rule delta_interpretation[OF dpos oned], rule orient1)
qed

subsection \<open>The standard semiring over the integers\<close>

definition int_mono :: "int \<Rightarrow> bool" where "int_mono x \<equiv> x \<ge> 1"

instantiation int :: large_ordered_semiring_1
begin
instance
proof
  fix y :: int
  show "\<exists> x. of_nat x \<ge> y"
    by (rule exI[of _ "nat y"], simp)
qed (auto simp: mult_right_mono mult_left_mono mult_right_mono_neg)
end

lemma non_inf_int_gt: "non_inf {(a,b :: int) . a > b}" (is "non_inf ?r")
  by (rule non_inf_image[OF non_inf_delta_gt, of 1 _ rat_of_int], auto simp: delta_gt_def)

interpretation int_SN: SN_strict_mono_ordered_semiring_1 1 "(>) :: int \<Rightarrow> int \<Rightarrow> bool" int_mono
proof (unfold_locales)
  have [simp]: "\<And> x :: int . (-1 < x) = (0 \<le> x)" by auto
  show "SN {(x,y). y \<ge> 0 \<and> (y :: int) < x}"
    using non_inf_imp_SN_bound[OF non_inf_int_gt, of "-1"] by auto
qed (auto simp: mult_strict_left_mono int_mono_def)

interpretation int_poly: poly_order_carrier 1 "(>) :: int \<Rightarrow> int \<Rightarrow> bool" True discrete
proof (unfold_locales)
  fix x y :: int
  assume ge: "x \<ge> y"
  then obtain k where k: "x - y = k" and kp: "0 \<le> k" by auto
  then obtain nk where nk: "nk = nat k" and k: "x - y = int nk" by auto
  show "\<exists> k. x = ((+) 1 ^^ k) y"
  proof (rule exI[of _ nk])
    from k have "x = int nk + y" by simp
    also have "\<dots> = ((+) 1 ^^ nk) y"
      by (induct nk, auto)
    finally show "x = ((+) 1 ^^ nk) y" .
  qed
qed (auto simp: field_simps power_strict_mono)

subsection \<open>The arctic semiring over the integers\<close>
text \<open>plus is interpreted as max, times is interpreted as plus, 0 is -infinity, 1 is 0\<close>

datatype arctic = MinInfty | Num_arc int

instantiation arctic :: ord
begin
fun less_eq_arctic :: "arctic \<Rightarrow> arctic \<Rightarrow> bool" where
  "less_eq_arctic MinInfty x = True"
| "less_eq_arctic (Num_arc _) MinInfty = False"
| "less_eq_arctic (Num_arc y) (Num_arc x) = (y \<le> x)"

fun less_arctic :: "arctic \<Rightarrow> arctic \<Rightarrow> bool" where
  "less_arctic MinInfty x = True"
| "less_arctic (Num_arc _) MinInfty = False"
| "less_arctic (Num_arc y) (Num_arc x) = (y < x)"

instance ..
end

instantiation arctic :: ordered_semiring_1
begin
fun plus_arctic :: "arctic \<Rightarrow> arctic \<Rightarrow> arctic" where
  "plus_arctic MinInfty y = y"
| "plus_arctic x MinInfty = x"
| "plus_arctic (Num_arc x) (Num_arc y) = (Num_arc (max x y))"

fun times_arctic :: "arctic \<Rightarrow> arctic \<Rightarrow> arctic" where
  "times_arctic MinInfty y = MinInfty"
| "times_arctic x MinInfty = MinInfty"
| "times_arctic (Num_arc x) (Num_arc y) = (Num_arc (x + y))"

definition zero_arctic :: arctic where
  "zero_arctic = MinInfty"

definition one_arctic :: arctic where
  "one_arctic = Num_arc 0"

instance
proof
  fix x y z :: arctic
  show "x + y = y + x"
    by (cases x, cases y, auto, cases y, auto)
  show "(x + y) + z = x + (y + z)"
    by (cases x, auto, cases y, auto, cases z, auto)
  show "(x * y) * z = x * (y * z)"
    by (cases x, auto, cases y, auto, cases z, auto)
  show "x * 0 = 0"
    by (cases x, auto simp: zero_arctic_def)
  show "x * (y + z) = x * y + x * z"
    by (cases x, auto, cases y, auto, cases z, auto)
  show "(x + y) * z = x * z + y * z"
    by (cases x, auto, cases y, cases z, auto, cases z, auto)
  show "1 * x = x"
    by (cases x, simp_all add: one_arctic_def)
  show "x * 1 = x"
    by (cases x, simp_all add: one_arctic_def)
  show "0 + x = x"
    by (simp add: zero_arctic_def)
  show "0 * x = 0"
    by (simp add: zero_arctic_def)
  show "(0 :: arctic) \<noteq> 1"
    by (simp add: zero_arctic_def one_arctic_def)
  show "x + 0 = x" by (cases x, auto simp: zero_arctic_def)
  show "x \<ge> x"
    by (cases x, auto)
  show "(1 :: arctic) \<ge> 0"
    by (simp add: zero_arctic_def one_arctic_def)
  show "max x y = max y x" unfolding max_def
    by (cases x, (cases y, auto)+)
  show "max x y \<ge> x" unfolding max_def
    by (cases x, (cases y, auto)+)
  assume ge: "x \<ge> y"
  from ge show "x + z \<ge> y + z"
    by (cases x, cases y, cases z, auto, cases y, cases z, auto, cases z, auto)
  from ge show "x * z \<ge> y * z"
    by (cases x, cases y, cases z, auto, cases y, cases z, auto, cases z, auto)
  from ge show "max x y = x" unfolding max_def
    by (cases x, (cases y, auto)+)
  from ge show "max z x \<ge> max z y" unfolding max_def
    by (cases z, cases x, auto, cases x, (cases y, auto)+)
next
  fix x y z :: arctic
  assume "x \<ge> y" and "y \<ge> z"
  thus "x \<ge> z"
    by (cases x, cases y, auto, cases y, cases z, auto, cases z, auto)
next
  fix x y z :: arctic
  assume "y \<ge> z"
  thus "x * y \<ge> x * z"
    by (cases x, cases y, cases z, auto, cases y, cases z, auto, cases z, auto)
next
  fix x y z :: arctic
  show "x \<ge> y \<Longrightarrow> 0 \<ge> z \<Longrightarrow> y * z \<ge> x * z"
    by (cases z, cases x, auto simp: zero_arctic_def)
qed
end

fun get_arctic_num :: "arctic \<Rightarrow> int"
where "get_arctic_num (Num_arc n) = n"

fun pos_arctic :: "arctic \<Rightarrow> bool"
where "pos_arctic MinInfty = False"
    | "pos_arctic (Num_arc n) = (0 <= n)"

interpretation arctic_SN: SN_both_mono_ordered_semiring_1 1 "(>)" pos_arctic
proof
  fix x y z :: arctic
  assume "x \<ge> y" and "y > z"
  thus "x > z"
    by (cases z, simp, cases y, simp, cases x, auto)
next
  fix x y z :: arctic
  assume "x > y" and "y \<ge> z"
  thus "x > z"
    by (cases z, simp, cases y, simp, cases x, auto)
next
  fix x y z :: arctic
  assume "x > y"
  thus "x \<ge> y"
    by (cases x, (cases y, auto)+)
next
  fix x y z u :: arctic
  assume "x > y" and "z > u"
  thus "x + z > y + u"
    by (cases y, cases u, simp, cases z, auto, cases x, auto, cases u, auto, cases z, auto, cases x, auto, cases x, auto, cases z, auto, cases x, auto)
next
  fix x y z :: arctic
  assume "x > y"
  thus "x * z > y * z"
    by (cases y, simp, cases z, simp, cases x, auto)
next
  fix x :: arctic
  assume "0 > x"
  thus "x = 0"
    by (cases x, auto simp: zero_arctic_def)
next
  fix x :: arctic
  show "pos_arctic 1" unfolding one_arctic_def by simp
  show "x > 0" unfolding zero_arctic_def by simp
  show "(1 :: arctic) \<ge> 0" unfolding zero_arctic_def by simp
  show "x \<ge> 0" unfolding zero_arctic_def by simp
  show "\<not> pos_arctic 0" unfolding zero_arctic_def by simp
next
  fix x y
  assume "pos_arctic x"
  thus "pos_arctic (x + y)" by (cases x, simp, cases y, auto)
next
  fix x y
  assume "pos_arctic x" and "pos_arctic y"
  thus "pos_arctic (x * y)" by (cases x, simp, cases y, auto)
next
  show "SN {(x,y). pos_arctic y \<and> x > y}" (is "SN ?rel")
  proof - {
    fix x
    assume "\<exists> f . f 0 = x \<and> (\<forall> i. (f i, f (Suc i)) \<in> ?rel)"
    from this obtain f where "f 0 = x" and seq: "\<forall> i. (f i, f (Suc i)) \<in> ?rel" by auto
    from seq have steps: "\<forall> i. f i > f (Suc i) \<and> pos_arctic (f (Suc i)) " by auto
    let ?g = "\<lambda> i. get_arctic_num (f i)"
    have "\<forall> i. ?g (Suc i) \<ge> 0 \<and> ?g i  > ?g (Suc i)"
    proof
      fix i
      from steps have i: "f i > f (Suc i) \<and> pos_arctic (f (Suc i))" by auto
      from i obtain n where fi: "f i = Num_arc n" by (cases "f (Suc i)", simp, cases "f i", auto)
      from i obtain m where fsi: "f (Suc i) = Num_arc m" by (cases "f (Suc i)", auto)
      with i have gz: "0 \<le> m" by simp
      from i fi fsi have "n > m" by auto
      with fi fsi gz
      show "?g (Suc i) \<ge> 0 \<and> ?g i > ?g (Suc i)" by auto
    qed
    from this obtain g where "\<forall> i. g (Suc i) \<ge> 0 \<and> ((>) :: int \<Rightarrow> int \<Rightarrow> bool) (g i) (g (Suc i))" by auto
    hence "\<exists> f. f 0 = g 0 \<and> (\<forall> i. (f i, f (Suc i)) \<in> {(x,y). y \<ge> 0 \<and> x > y})" by auto
    with int_SN.SN have False unfolding SN_defs by auto
  }
  thus ?thesis unfolding SN_defs by auto
  qed
next
  fix y z x :: arctic
  assume "y > z"
  thus "x * y > x * z"
    by (cases x, simp, cases z, simp, cases y, auto)
next
  fix c d
  assume "pos_arctic d"
  then obtain n where d: "d = Num_arc n" and n: "0 \<le> n"
    by (cases d, auto)
  show "\<exists> e. e \<ge> 0 \<and> pos_arctic e \<and> \<not> c \<ge> d * e"
  proof (cases c)
    case MinInfty
    show ?thesis
      by (rule exI[of _ "Num_arc 0"],
        unfold d MinInfty zero_arctic_def, simp)
  next
    case (Num_arc m)
    show ?thesis
      by (rule exI[of _ "Num_arc (abs m  + 1)"], insert n,
        unfold d Num_arc zero_arctic_def, simp)
  qed
qed

subsection \<open>The arctic semiring over an arbitrary archimedean field\<close>

text \<open>completely analogous to the integers, where one has to use delta-orderings\<close>

datatype 'a arctic_delta = MinInfty_delta | Num_arc_delta 'a

instantiation arctic_delta :: (ord) ord
begin
fun less_eq_arctic_delta :: "'a arctic_delta \<Rightarrow> 'a arctic_delta \<Rightarrow> bool" where
  "less_eq_arctic_delta MinInfty_delta x = True"
| "less_eq_arctic_delta (Num_arc_delta _) MinInfty_delta = False"
| "less_eq_arctic_delta (Num_arc_delta y) (Num_arc_delta x) = (y \<le> x)"

fun less_arctic_delta :: "'a arctic_delta \<Rightarrow> 'a arctic_delta \<Rightarrow> bool" where
  "less_arctic_delta MinInfty_delta x = True"
| "less_arctic_delta (Num_arc_delta _) MinInfty_delta = False"
| "less_arctic_delta (Num_arc_delta y) (Num_arc_delta x) = (y < x)"

instance ..
end

instantiation arctic_delta :: (linordered_field) ordered_semiring_1
begin
fun plus_arctic_delta :: "'a arctic_delta \<Rightarrow> 'a arctic_delta \<Rightarrow> 'a arctic_delta" where
  "plus_arctic_delta MinInfty_delta y = y"
| "plus_arctic_delta x MinInfty_delta = x"
| "plus_arctic_delta (Num_arc_delta x) (Num_arc_delta y) = (Num_arc_delta (max x y))"

fun times_arctic_delta :: "'a arctic_delta \<Rightarrow> 'a arctic_delta \<Rightarrow> 'a arctic_delta" where
  "times_arctic_delta MinInfty_delta y = MinInfty_delta"
| "times_arctic_delta x MinInfty_delta = MinInfty_delta"
| "times_arctic_delta (Num_arc_delta x) (Num_arc_delta y) = (Num_arc_delta (x + y))"

definition zero_arctic_delta :: "'a arctic_delta" where
  "zero_arctic_delta = MinInfty_delta"

definition one_arctic_delta :: "'a arctic_delta" where
  "one_arctic_delta = Num_arc_delta 0"

instance
proof
  fix x y z :: "'a arctic_delta"
  show "x + y = y + x"
    by (cases x, cases y, auto, cases y, auto)
  show "(x + y) + z = x + (y + z)"
    by (cases x, auto, cases y, auto, cases z, auto)
  show "(x * y) * z = x * (y * z)"
    by (cases x, auto, cases y, auto, cases z, auto)
  show "x * 0 = 0"
    by (cases x, auto simp: zero_arctic_delta_def)
  show "x * (y + z) = x * y + x * z"
    by (cases x, auto, cases y, auto, cases z, auto)
  show "(x + y) * z = x * z + y * z"
    by (cases x, auto, cases y, cases z, auto, cases z, auto)
  show "1 * x = x"
    by (cases x, simp_all add: one_arctic_delta_def)
  show "x * 1 = x"
    by (cases x, simp_all add: one_arctic_delta_def)
  show "0 + x = x"
    by (simp add: zero_arctic_delta_def)
  show "0 * x = 0"
    by (simp add: zero_arctic_delta_def)
  show "(0 :: 'a arctic_delta) \<noteq> 1"
    by (simp add: zero_arctic_delta_def one_arctic_delta_def)
  show "x + 0 = x" by (cases x, auto simp: zero_arctic_delta_def)
  show "x \<ge> x"
    by (cases x, auto)
  show "(1 :: 'a arctic_delta) \<ge> 0"
    by (simp add: zero_arctic_delta_def one_arctic_delta_def)
  show "max x y = max y x" unfolding max_def
    by (cases x, (cases y, auto)+)
  show "max x y \<ge> x" unfolding max_def
    by (cases x, (cases y, auto)+)
  assume ge: "x \<ge> y"
  from ge show "x + z \<ge> y + z"
    by (cases x, cases y, cases z, auto, cases y, cases z, auto, cases z, auto)
  from ge show "x * z \<ge> y * z"
    by (cases x, cases y, cases z, auto, cases y, cases z, auto, cases z, auto)
  from ge show "max x y = x" unfolding max_def
    by (cases x, (cases y, auto)+)
  from ge show "max z x \<ge> max z y" unfolding max_def
    by (cases z, cases x, auto, cases x, (cases y, auto)+)
next
  fix x y z :: "'a arctic_delta"
  assume "x \<ge> y" and "y \<ge> z"
  thus "x \<ge> z"
    by (cases x, cases y, auto, cases y, cases z, auto, cases z, auto)
next
  fix x y z :: "'a arctic_delta"
  assume "y \<ge> z"
  thus "x * y \<ge> x * z"
    by (cases x, cases y, cases z, auto, cases y, cases z, auto, cases z, auto)
next
  fix x y z :: "'a arctic_delta"
  show "x \<ge> y \<Longrightarrow> 0 \<ge> z \<Longrightarrow> y * z \<ge> x * z"
    by (cases z, cases x, auto simp: zero_arctic_delta_def)
qed
end

text \<open>x >d y is interpreted as y = -inf or (x,y != -inf and x >d y)\<close>
fun gt_arctic_delta :: "'a :: floor_ceiling \<Rightarrow> 'a arctic_delta \<Rightarrow> 'a arctic_delta \<Rightarrow> bool"
where "gt_arctic_delta \<delta> _ MinInfty_delta = True"
   |  "gt_arctic_delta \<delta> MinInfty_delta (Num_arc_delta _) = False"
   |  "gt_arctic_delta \<delta> (Num_arc_delta x) (Num_arc_delta y) = delta_gt \<delta> x y"

fun get_arctic_delta_num :: "'a arctic_delta \<Rightarrow> 'a"
where "get_arctic_delta_num (Num_arc_delta n) = n"

fun pos_arctic_delta :: "('a :: floor_ceiling) arctic_delta \<Rightarrow> bool"
where "pos_arctic_delta MinInfty_delta = False"
    | "pos_arctic_delta (Num_arc_delta n) = (0 \<le> n)"

lemma arctic_delta_interpretation: assumes dpos: "\<delta> > 0" shows "SN_both_mono_ordered_semiring_1 1 (gt_arctic_delta \<delta>) pos_arctic_delta"
proof -
  from delta_interpretation[OF dpos] interpret SN_strict_mono_ordered_semiring_1 \<delta> "delta_gt \<delta>" delta_mono by simp
  show ?thesis
  proof
    fix x y z :: "'a arctic_delta"
    assume "x \<ge> y" and "gt_arctic_delta \<delta> y z"
    thus "gt_arctic_delta \<delta> x z"
      by (cases z, simp, cases y, simp, cases x, simp, simp add: compat)
  next
    fix x y z :: "'a arctic_delta"
    assume "gt_arctic_delta \<delta> x y" and "y \<ge> z"
    thus "gt_arctic_delta \<delta> x z"
      by (cases z, simp, cases y, simp, cases x, simp, simp add: compat2)
  next
    fix x y :: "'a arctic_delta"
    assume "gt_arctic_delta \<delta> x y"
    thus "x \<ge> y"
      by (cases x, insert dpos, (cases y, auto simp: delta_gt_def)+)
  next
    fix x y z u
    assume "gt_arctic_delta \<delta> x y" and "gt_arctic_delta \<delta> z u"
    thus "gt_arctic_delta \<delta> (x + z) (y + u)"
      by (cases y, cases u, simp, cases z, simp, cases x, simp, simp add: delta_gt_def,
        cases z, cases x, simp, cases u, simp, simp, cases x, simp, cases z, simp, cases u, simp add: delta_gt_def, simp add: delta_gt_def)
  next
    fix x y z
    assume "gt_arctic_delta \<delta> x y"
    thus "gt_arctic_delta \<delta> (x * z) (y * z)"
      by (cases y, simp, cases z, simp, cases x, simp, simp add: plus_gt_left_mono)
  next
    fix x
    assume "gt_arctic_delta \<delta> 0 x"
    thus "x = 0"
      by (cases x, auto simp: zero_arctic_delta_def)
  next
    fix x
    show "pos_arctic_delta 1" unfolding one_arctic_delta_def by simp
    show "gt_arctic_delta \<delta> x 0" unfolding zero_arctic_delta_def by simp
    show "(1 :: 'a arctic_delta) \<ge> 0" unfolding zero_arctic_delta_def by simp
    show "x \<ge> 0" unfolding zero_arctic_delta_def by simp
    show "\<not> pos_arctic_delta 0" unfolding zero_arctic_delta_def by simp
  next
    fix x y :: "'a arctic_delta"
    assume "pos_arctic_delta x"
    thus "pos_arctic_delta (x + y)" by (cases x, simp, cases y, auto)
  next
    fix x y :: "'a arctic_delta"
    assume "pos_arctic_delta x" and "pos_arctic_delta y"
    thus "pos_arctic_delta (x * y)" by (cases x, simp, cases y, auto)
  next
    show "SN {(x,y). pos_arctic_delta y \<and> gt_arctic_delta \<delta> x y}" (is "SN ?rel")
    proof - {
      fix x
      assume "\<exists> f . f 0 = x \<and> (\<forall> i. (f i, f (Suc i)) \<in> ?rel)"
      from this obtain f where "f 0 = x" and seq: "\<forall> i. (f i, f (Suc i)) \<in> ?rel" by auto
      from seq have steps: "\<forall> i. gt_arctic_delta \<delta> (f i) (f (Suc i)) \<and> pos_arctic_delta (f (Suc i)) " by auto
      let ?g = "\<lambda> i. get_arctic_delta_num (f i)"
      have "\<forall> i. ?g (Suc i) \<ge> 0 \<and> delta_gt \<delta> (?g i) (?g (Suc i))"
      proof
        fix i
        from steps have i: "gt_arctic_delta \<delta> (f i) (f (Suc i)) \<and> pos_arctic_delta (f (Suc i))" by auto
        from i obtain n where fi: "f i = Num_arc_delta n" by (cases "f (Suc i)", simp, cases "f i", auto)
        from i obtain m where fsi: "f (Suc i) = Num_arc_delta m" by (cases "f (Suc i)", auto)
        with i have gz: "0 \<le> m" by simp
        from i fi fsi have "delta_gt \<delta> n m" by auto
        with fi fsi gz
        show "?g (Suc i) \<ge> 0 \<and> delta_gt \<delta> (?g i) (?g (Suc i))" by auto
      qed
      from this obtain g where "\<forall> i. g (Suc i) \<ge> 0 \<and> delta_gt \<delta> (g i) (g (Suc i))" by auto
      hence "\<exists> f. f 0 = g 0 \<and> (\<forall> i. (f i, f (Suc i)) \<in> {(x,y). y \<ge> 0 \<and> delta_gt \<delta> x y})" by auto
      with SN have False unfolding SN_defs by auto
    }
    thus ?thesis unfolding SN_defs by auto
    qed
  next
    fix c d :: "'a arctic_delta"
    assume "pos_arctic_delta d"
    then obtain n where d: "d = Num_arc_delta n" and n: "0 \<le> n"
      by (cases d, auto)
    show "\<exists> e. e \<ge> 0 \<and> pos_arctic_delta e \<and> \<not> c \<ge> d * e"
    proof (cases c)
      case MinInfty_delta
      show ?thesis
        by (rule exI[of _ "Num_arc_delta 0"],
          unfold d MinInfty_delta zero_arctic_delta_def, simp)
    next
      case (Num_arc_delta m)
      show ?thesis
        by (rule exI[of _ "Num_arc_delta (abs m  + 1)"], insert n,
          unfold d Num_arc_delta zero_arctic_delta_def, simp)
    qed
  next
    fix x y z
    assume gt: "gt_arctic_delta \<delta> y z"
    {
      fix x y z
      assume gt: "delta_gt \<delta> y z"
      have "delta_gt \<delta> (x + y) (x + z)"
        using plus_gt_left_mono[OF gt] by (auto simp: field_simps)
    }
    with gt show "gt_arctic_delta \<delta> (x * y) (x * z)"
      by (cases x, simp, cases z, simp, cases y, simp_all)
  qed
qed

fun weak_gt_arctic_delta :: "('a :: floor_ceiling) arctic_delta \<Rightarrow> 'a arctic_delta \<Rightarrow> bool"
where "weak_gt_arctic_delta _ MinInfty_delta = True"
   |  "weak_gt_arctic_delta MinInfty_delta (Num_arc_delta _) = False"
   |  "weak_gt_arctic_delta (Num_arc_delta x) (Num_arc_delta y) = (x > y)"

interpretation weak_arctic_delta_SN: weak_SN_both_mono_ordered_semiring_1 weak_gt_arctic_delta 1 pos_arctic_delta
proof
  fix xys
  assume orient: "\<forall> x y. (x,y) \<in> set xys \<longrightarrow> weak_gt_arctic_delta x y"
  obtain xysp where xysp: "xysp = map (\<lambda> (ax, ay). (case ax of Num_arc_delta x \<Rightarrow> x , case ay of Num_arc_delta y \<Rightarrow> y)) (filter (\<lambda> (ax,ay). ax \<noteq> MinInfty_delta \<and> ay \<noteq> MinInfty_delta) xys)"
    (is "_ = map ?f _")
    by auto
  have "\<forall> x y. (x,y) \<in> set xysp \<longrightarrow> x > y"
  proof (intro allI impI)
    fix x y
    assume "(x,y) \<in> set xysp"
    with xysp obtain ax ay where "(ax,ay) \<in> set xys" and "ax \<noteq> MinInfty_delta" and "ay \<noteq> MinInfty_delta" and "(x,y) = ?f (ax,ay)" by auto
    hence "(Num_arc_delta x, Num_arc_delta y) \<in> set xys" by (cases ax, simp, cases ay, auto)
    with orient show "x > y" by force
  qed
  with delta_minimal_delta[of xysp] obtain \<delta> where dpos: "\<delta> > 0" and orient2: "\<And> x y. (x, y) \<in> set xysp \<Longrightarrow> delta_gt \<delta> x y" by auto
  have orient: "\<forall> x y. (x,y) \<in> set xys \<longrightarrow> gt_arctic_delta \<delta> x y"
  proof(intro allI impI)
    fix ax ay
    assume axay: "(ax,ay) \<in> set xys"
    with orient have orient: "weak_gt_arctic_delta ax ay" by auto
    show "gt_arctic_delta \<delta> ax ay"
    proof (cases ay, simp)
      case (Num_arc_delta y) note ay = this
      show ?thesis
      proof (cases ax)
        case MinInfty_delta
        with ay orient show ?thesis by auto
      next
        case (Num_arc_delta x) note ax = this
        from ax ay axay have "(x,y) \<in> set xysp" unfolding xysp by force
        from ax ay orient2[OF this] show ?thesis by simp
      qed
    qed
  qed
  show "\<exists>gt. SN_both_mono_ordered_semiring_1 1 gt pos_arctic_delta \<and> (\<forall>x y. (x, y) \<in> set xys \<longrightarrow> gt x y)"
    by (intro exI conjI, rule arctic_delta_interpretation[OF dpos], rule orient)
qed

end


section "Auxilliary Lemmas"
theory Kruskal_Misc
  imports
    "Collections.Partial_Equivalence_Relation"
    "Automatic_Refinement.Misc"
    Refine_Imperative_HOL.Sepref
begin

lemma card2_get2: assumes "card x = 2"
  obtains a b where  "x = {a, b}" "a \<noteq> b"
proof -
  from assms have [simp,intro!]: "finite x" apply(rule_tac ccontr) by auto
  from assms obtain a where ax: "a \<in> x"
    by fastforce
  with assms  have "card (x - {a}) = 1" by fastforce
  then obtain b where "x - {a} = {b}" "a \<noteq> b"
    by (metis Diff_cancel Diff_idemp card_1_singletonE insert_not_empty)
  with that ax show ?thesis by blast
qed

subsection "Lemmas on equivalence relations"

lemma equiv_sym: "equiv V R \<Longrightarrow> (x,y)\<in>R \<Longrightarrow> (y,x)\<in>R"
  by (metis equiv_def symD)

lemma equiv_trans: "equiv V R \<Longrightarrow> (x,y)\<in>R \<Longrightarrow> (y,z)\<in>R \<Longrightarrow> (x,z)\<in>R"
  by (metis equiv_def transD)

lemma equiv_trans_sym:
  "\<lbrakk> equiv V R; (a,b)\<in>R; (c,b)\<in>R \<rbrakk> \<Longrightarrow> (a,c)\<in>R"
  "\<lbrakk> equiv V R; (a,b)\<in>R; (a,c)\<in>R \<rbrakk> \<Longrightarrow> (b,c)\<in>R"
  apply (metis equiv_sym equiv_trans)+
  done

lemma union_equiv:
  "equiv V R \<Longrightarrow> equiv V (per_union R a b)"
  apply (rule equivI)
  unfolding per_union_def
  subgoal unfolding equiv_def refl_on_def by auto
  subgoal apply (rule symI) by (auto dest: equiv_sym)
  subgoal apply (rule transI) by (auto dest: equiv_trans equiv_trans_sym)
  done

lemma equiv_mono: "E'\<subseteq>E \<Longrightarrow> equiv E R1 \<Longrightarrow> equiv E' (R1 \<inter> E'\<times>E')"
  apply(rule equivI)
  subgoal unfolding equiv_def
    by (simp add: refl_on_def subset_iff)
  subgoal unfolding equiv_def
    by (metis mem_Sigma_iff symI sym_Int)
  subgoal unfolding equiv_def using trans_Restr by fastforce
  done

lemma unify2EquivClasses_alt:
  assumes "R``{x} \<noteq> R``{y}" and inV: "y\<in>V" "x\<in>V" and "R\<subseteq>V\<times>V"
   and eq: "equiv V R" and [simp]: "finite V"
  shows "Suc (card (quotient V (per_union R x y))) = card (quotient V R)"
proof -

  from eq have Rtrancl: "R\<^sup>+ = R" by (auto elim: equivE)
  from \<open>equiv V R\<close> have sym: "sym R" unfolding equiv_def by auto

  let ?R' = "per_union R x y"

  \<comment> \<open> the equivalence classes not contining x and y, stay unchanged when performing @{term per_union} \<close>
  have "\<And>z. z \<in> V \<Longrightarrow> z \<notin> R `` {x} \<Longrightarrow> z \<notin> R `` {y} \<Longrightarrow> per_union R x y `` {z} = R `` {z}"
    using sym by(auto simp: sym_def per_union_def)
  then have K: "(\<Union>x \<in> (V-(R``{x})-(R``{y})). {?R'``{x}}) = (\<Union>x \<in> (V-(R``{x})-(R``{y})). {R``{x}})"
    by auto

  have R_respect: "(\<lambda>x. {R `` {x}}) respects R"
    unfolding congruent_def using eq equiv_class_eq_iff by fastforce+

  have R'_respect: "(\<lambda>xa. {?R' `` {xa}}) respects R"
    unfolding congruent_def per_union_def
      using eq equiv_class_eq_iff by force+

  \<comment> \<open>some facts about the equivalence class of x, before and after the @{term per_union} operation\<close>
  have xdrin: "(R``{x}) \<subseteq> V" using assms(4) by auto
  have x1: "(\<Union>x \<in> (R``{x}). {?R'``{x}}) = {?R'``{x}}"
    apply(rule UN_equiv_class) by fact+
  have x2: "(\<Union>x \<in> (R``{x}). {R``{x}}) = {R``{x}}"
    apply(rule UN_equiv_class) by fact+

  \<comment> \<open>some facts about the equivalence class of y, before and after the @{term per_union} operation\<close>
  have ydrin: "(R``{y}) \<subseteq> V" using assms(4) by auto
  have y1: "(\<Union>x \<in> (R``{y}). {?R'``{x}}) = {?R'``{y}}"
    apply(rule UN_equiv_class) by fact+
  have y2: "(\<Union>x \<in> (R``{y}). {R``{x}}) = {R``{y}}"
    apply(rule UN_equiv_class) by fact+

  have z: "(y,x)\<in>?R'" unfolding per_union_def using sym sym_def
    using assms(2) assms(3) eq eq_equiv_class by fastforce
  have bla: "?R'``{y} = ?R'``{x}"
    apply(rule equiv_class_eq)
     apply(rule union_equiv)
     apply fact
    by fact

  let ?Vm = "(\<Union>x \<in> (V-(R``{x})-(R``{y})). {R``{x}})"

  \<comment> \<open>now consider the set of quotients wrt. the relation after the @{term per_union}\<close>
  have "quotient V ?R' = (\<Union>x \<in> V. {?R'``{x}})" unfolding quotient_def by auto
  also  \<comment> \<open>decompose it into the quotients for elements equivalent to x, y in R, and the rest\<close>
  have "\<dots> = (\<Union>x \<in> (V-(R``{x})-(R``{y})). {?R'``{x}})
             \<union> (\<Union>x \<in> (R``{y}). {?R'``{x}}) \<union> (\<Union>x \<in> (R``{x}). {?R'``{x}})"
    using xdrin ydrin by auto
  also  \<comment> \<open>for the elements equivalent to x and y in R the quotient is
            the quotient containing x and y respectively \<close>
  have "\<dots> = (\<Union>x \<in> (V-(R``{x})-(R``{y})). {?R'``{x}}) \<union> {?R'``{y}} \<union> {?R'``{x}}" using x1 y1 by auto
  also  \<comment> \<open>which is after uniting them, the same quotient \<close>
  have "\<dots> = (\<Union>x \<in> (V-(R``{x})-(R``{y})). {R``{x}}) \<union> {?R'``{y}}" using K bla by auto
  also
  have "\<dots> = insert (?R'``{y}) ?Vm" by auto
  finally have leftside: "quotient V ?R' = insert (?R'``{y}) ?Vm" .

  have notin: "?R'``{y} \<notin> ?Vm"
    apply (auto simp: per_union_def)
    by (metis (no_types, lifting) Image_singleton_iff UnI1 assms(2) eq equiv_class_self local.sym symE)

  have o: "card (quotient V ?R') = Suc (card ?Vm)"
    unfolding leftside apply(rule card_insert_disjoint)
     using notin by auto

  \<comment> \<open>now consider the set of quotients wrt. the relation before the @{term per_union}\<close>
  have "quotient V R = (\<Union>x \<in> V. {R``{x}})" unfolding quotient_def by auto
  also \<comment> \<open>decompose it into the quotients for elements equivalent to x, y in R, and the rest\<close>
  have "\<dots> = (\<Union>x \<in> (V-(R``{x})-(R``{y})). {R``{x}})
           \<union> (\<Union>x \<in> (R``{y}). {R``{x}}) \<union> (\<Union>x \<in> (R``{x}). {R``{x}})"
    using xdrin ydrin by auto
  also \<comment> \<open>for the elements equivalent to x and y in R the quotient is
            the quotient containing x and y respectively \<close>
  have "\<dots> = (\<Union>x \<in> (V-(R``{x})-(R``{y})). {R``{x}}) \<union> {R``{y}} \<union> {R``{x}}" using x2 y2 by auto
  also \<comment> \<open> these are two distinct quotients  \<close>
  have "\<dots> = insert (R``{y}) (insert (R``{x}) ?Vm)" by auto
  finally have ii: "quotient V R = insert (R``{y}) (insert (R``{x}) ?Vm)" .

  have "R``{x} \<notin> ?Vm"
    using eq equiv_class_self by fastforce
  have "R``{y} \<notin> ?Vm"
    using eq equiv_class_self by fastforce
  with assms(1)
  have "R``{y} \<notin> (insert (R``{x}) ?Vm)" by blast
  have "card (quotient V R) = Suc (card (insert (R``{x}) ?Vm))"
    apply(simp only: ii)
    apply(rule card_insert_disjoint)
     apply simp
    apply fact done
  also have "card (insert (R``{x}) ?Vm) = Suc (card ?Vm)"
    apply(rule card_insert_disjoint)
     apply simp
    apply fact done
  finally have a: "card (quotient V R) = Suc (Suc (card ?Vm))" by auto

  from a o show ?thesis by auto
qed

subsection "On the pigeon hole principle"

subsection "On sorting and \<open>max_node\<close>"

definition edges_less_eq :: "('a \<times> 'w::{linorder, ordered_comm_monoid_add} \<times> 'a) \<Rightarrow> ('a \<times> 'w \<times> 'a) \<Rightarrow> bool"
  where "edges_less_eq a b \<equiv> fst(snd a) \<le> fst(snd b)"

definition "sort_edges \<equiv> quicksort_by_rel edges_less_eq []"

definition "max_node l \<equiv> Max (insert 0 (fst`set l \<union> (snd o snd)`set l))"

lemma max_node_impl[code]: "max_node l = fold (\<lambda>(u,_,w) x. max u (max w x)) l 0"
proof -
  have "fold (\<lambda>(u,_,w) x. max u (max w x)) l a = Max (insert a (fst`set l \<union> (snd o snd)`set l))" for a
    apply (induction l arbitrary: a)
     apply (auto simp:  )
    subgoal for a b l aa
      apply (cases l)
      by (auto simp: ac_simps)
    done
  thus ?thesis unfolding max_node_def by auto
qed

definition "is_linorder_rel R \<equiv> (\<forall>x y. R x y \<or> R y x) \<and> (\<forall>x y z. R x y \<longrightarrow> R y z \<longrightarrow> R x z)"

lemma edges_less_eq_linorder: "is_linorder_rel edges_less_eq"
  unfolding edges_less_eq_def is_linorder_rel_def
  by (metis linear order_trans)

lemma sort_edges_correct: "sorted_wrt edges_less_eq (quicksort_by_rel edges_less_eq [] l)"
  by (metis (no_types, hide_lams) edges_less_eq_linorder is_linorder_rel_def sorted_wrt_quicksort_by_rel)

lemma distinct_mset_eq:"distinct a \<Longrightarrow> mset a = mset b \<Longrightarrow> distinct b"
  by (metis card_distinct distinct_card set_mset_mset size_mset)

lemma quicksort_by_rel_distinct: "distinct l \<Longrightarrow> distinct (quicksort_by_rel edges_less_eq [] l)"
  by (auto intro: distinct_mset_eq)

subsection "On @{term list_rel}"

lemma map_in_list_rel_conv:
  shows "(l, l') \<in> \<langle>br \<alpha> I\<rangle>list_rel \<longleftrightarrow> ((\<forall>x\<in>set l. I x) \<and> l'=map \<alpha> l)"
proof (induction l arbitrary: l')
  case (Cons a l l')
  then show ?case apply(cases l') by (auto simp add: in_br_conv)
qed simp

lemma list_relD: "(x, y) \<in> \<langle>br a I\<rangle>list_rel \<Longrightarrow> y = map a x"
  by(auto simp: map_in_list_rel_conv)

lemma list_relD2: "(x, y) \<in> \<langle>br a I\<rangle>list_rel \<Longrightarrow> y = map a x \<and> (\<forall>x\<in>set x. I x)"
  by(auto simp: map_in_list_rel_conv)

lemma list_set_rel_append: "(x,s)\<in>br a I \<Longrightarrow> (xs,S)\<in>\<langle>br a I\<rangle>list_set_rel \<Longrightarrow> s\<notin>S
     \<Longrightarrow> (xs@[x],insert s S)\<in>\<langle>br a I\<rangle>list_set_rel"
  unfolding list_set_rel_def
  apply(intro relcompI[where b="map a (xs @ [x])"])
   apply (auto simp: in_br_conv)
      apply parametricity by (auto dest: list_relD simp add: in_br_conv)

subsection "Auxiliary lemmas for Sepref"

lemma pure_fold: "(\<lambda>a c. \<up> (c = a)) = pure Id" unfolding pure_def by auto
lemma list_assn_emp: "list_assn id_assn L L = emp"
  apply(induct L) apply simp by (simp add: pure_def)

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>\<open>"DBLP:conf/cade/0001T19"\<close>.
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>\<open>"DBLP:conf/cade/0001T19"\<close>) 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
(*>*)