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

datatype ('a, 'b) pair = pair2 "'a" "'b"

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

datatype Nat = Z | S "Nat"

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

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

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

fun minus :: "Nat => Nat => Nat" where
  "minus (Z) z = Z"
| "minus (S z2) (S y2) = minus z2 y2"

fun lt :: "Nat => Nat => bool" where
  "lt y (Z) = False"
| "lt (Z) (S z2) = True"
| "lt (S n) (S z2) = lt n z2"

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 z l) = plus (S Z) (length l)"

fun le :: "Nat => Nat => bool" where
  "le (Z) z = True"
| "le (S z2) (Z) = False"
| "le (S z2) (S x2) = le z2 x2"

fun sort2 :: "Nat => Nat => Nat list" where
  "sort2 y z =
   (if le y z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun take :: "Nat => 'a list => 'a list" where
  "take y z =
   (if le y Z then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => (case y of S x2 => cons2 z2 (take x2 xs))))"

fun insert :: "Nat => Nat list => Nat list" where
  "insert y (nil2) = cons2 y (nil2)"
| "insert y (cons2 z2 xs) =
     (if le y z2 then cons2 y (cons2 z2 xs) else
        cons2 z2 (insert y xs))"

fun isort :: "Nat list => Nat list" where
  "isort (nil2) = nil2"
| "isort (cons2 z xs) = insert z (isort xs)"

(*fun did not finish the proof*)
function idiv :: "Nat => Nat => Nat" where
  "idiv y z = (if lt y z then Z else S (idiv (minus y z) z))"
  by pat_completeness auto

fun drop :: "Nat => 'a list => 'a list" where
  "drop y z =
   (if le y Z then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => (case y of S x2 => drop x2 xs1)))"

fun splitAt :: "Nat => 'a list =>
              (('a list), ('a list)) pair" where
  "splitAt y z = pair2 (take y z) (drop y z)"

function stooge1sort2 :: "Nat list => Nat list"
  and stoogesort :: "Nat list => Nat list"
  and stooge1sort1 :: "Nat list => Nat list" where
  "stooge1sort2 y =
   (case splitAt (idiv (length y) (S (S (S Z)))) (reverse y) of
      pair2 ys2 zs2 => x (stoogesort zs2) (reverse ys2))"
| "stoogesort (nil2) = nil2"
| "stoogesort (cons2 z (nil2)) = cons2 z (nil2)"
| "stoogesort (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "stoogesort (cons2 z (cons2 y2 (cons2 x3 x4))) =
     stooge1sort2
       (stooge1sort1 (stooge1sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "stooge1sort1 y =
     (case splitAt (idiv (length y) (S (S (S Z)))) y of
        pair2 ys2 zs1 => x ys2 (stoogesort zs1))"
  by pat_completeness auto

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

end


theory biconditional imports Main begin

text {*
  Proving the biconditional rule in propositional calculus
*}

lemma "((P\<longrightarrow>Q)\<and>(Q\<longrightarrow>P)) = (P=Q)"
  apply(rule iffI)
   apply(rule iffI)
    apply(erule conjE)
    apply(erule impE)
     apply assumption
    apply assumption
   apply(erule conjE)
   apply(erule impE)+
     apply assumption+
   apply(erule impE)
    apply assumption+
  apply (erule iffE)
  apply(rule conjI)
   apply assumption+
  done


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

datatype ('a, 'b) pair = pair2 "'a" "'b"

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

datatype Nat = Z | S "Nat"

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

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

fun minus :: "Nat => Nat => Nat" where
  "minus (Z) z = Z"
| "minus (S z2) (S y2) = minus z2 y2"

(*fun did not finish the proof*)
function third :: "Nat => Nat" where
  "third y =
   (if (y = (S (S Z))) then Z else
      (if (y = (S Z)) then Z else
         (case y of
            Z => Z
            | S z => plus (S Z) (third (minus y (S (S (S Z))))))))"
  by pat_completeness auto

(*fun did not finish the proof*)
function twoThirds :: "Nat => Nat" where
  "twoThirds y =
   (if (y = (S (S Z))) then S Z else
      (if (y = (S Z)) then S Z else
         (case y of
            Z => Z
            | S z => plus (S (S Z)) (twoThirds (minus y (S (S (S Z))))))))"
  by pat_completeness auto

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 z l) = plus (S Z) (length l)"

fun le :: "Nat => Nat => bool" where
  "le (Z) z = True"
| "le (S z2) (Z) = False"
| "le (S z2) (S x2) = le z2 x2"

fun sort2 :: "Nat => Nat => Nat list" where
  "sort2 y z =
   (if le y z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun take :: "Nat => 'a list => 'a list" where
  "take y z =
   (if le y Z then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => (case y of S x2 => cons2 z2 (take x2 xs))))"

fun drop :: "Nat => 'a list => 'a list" where
  "drop y z =
   (if le y Z then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => (case y of S x2 => drop x2 xs1)))"

fun splitAt :: "Nat => 'a list =>
              (('a list), ('a list)) pair" where
  "splitAt y z = pair2 (take y z) (drop y z)"

function nstooge2sort2 :: "Nat list => Nat list"
  and nstoogesort2 :: "Nat list => Nat list"
  and nstooge2sort1 :: "Nat list => Nat list" where
  "nstooge2sort2 y =
   (case splitAt (twoThirds (length y)) y of
      pair2 ys2 zs1 => x (nstoogesort2 ys2) zs1)"
| "nstoogesort2 (nil2) = nil2"
| "nstoogesort2 (cons2 z (nil2)) = cons2 z (nil2)"
| "nstoogesort2 (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "nstoogesort2 (cons2 z (cons2 y2 (cons2 x3 x4))) =
     nstooge2sort2
       (nstooge2sort1 (nstooge2sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "nstooge2sort1 y =
     (case splitAt (third (length y)) y of
        pair2 ys2 zs1 => x ys2 (nstoogesort2 zs1))"
  by pat_completeness auto

fun count :: "'a => 'a list => Nat" where
  "count y (nil2) = Z"
| "count y (cons2 z2 ys) =
     (if (y = z2) then plus (S Z) (count y ys) else count y ys)"

theorem property0 :
  "((count y (nstoogesort2 xs)) = (count y xs))"
  oops

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_63
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

fun len :: "'a list => Nat" where
  "len (nil2) = Z"
| "len (cons2 y xs) = S (len xs)"

fun last :: "Nat list => Nat" where
  "last (nil2) = Z"
| "last (cons2 y (nil2)) = y"
| "last (cons2 y (cons2 x2 x3)) = last (cons2 x2 x3)"

fun drop :: "Nat => 'a list => 'a list" where
  "drop (Z) y = y"
| "drop (S z) (nil2) = nil2"
| "drop (S z) (cons2 x2 x3) = drop z x3"

fun t2 :: "Nat => Nat => bool" where
  "t2 x (Z) = False"
| "t2 (Z) (S z) = True"
| "t2 (S x2) (S z) = t2 x2 z"

theorem property0 :
  "((t2 n (len xs)) ==> ((last (drop n xs)) = (last xs)))"
  oops

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_prop_42
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

fun y :: "Nat => Nat => bool" where
  "y (Z) (Z) = True"
| "y (Z) (S z2) = False"
| "y (S x2) (Z) = False"
| "y (S x2) (S y22) = y x2 y22"

fun x :: "bool => bool => bool" where
  "x True y2 = True"
| "x False y2 = y2"

fun elem :: "Nat => Nat list => bool" where
  "elem z (nil2) = False"
| "elem z (cons2 z2 xs) = x (y z z2) (elem z xs)"

fun union :: "Nat list => Nat list => Nat list" where
  "union (nil2) y2 = y2"
| "union (cons2 z2 xs) y2 =
     (if elem z2 y2 then union xs y2 else cons2 z2 (union xs y2))"

theorem property0 :
  "((elem z y2) ==> (elem z (union y2 z2)))"
  oops

end


(* Title:      Iterings
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Iterings\<close>

text \<open>
This theory introduces algebraic structures with an operation that describes iteration in various relational computation models.
An iteration describes the repeated sequential execution of a computation.
This is typically modelled by fixpoints, but different computation models use different fixpoints in the refinement order.
We therefore look at equational and simulation axioms rather than induction axioms.
Our development is based on \<^cite>\<open>"Guttmann2012c"\<close> and the proposed algebras generalise Kleene algebras.

We first consider a variant of Conway semirings \<^cite>\<open>"BloomEsik1993a"\<close> based on idempotent left semirings.
Conway semirings expand semirings by an iteration operation satisfying Conway's sumstar and productstar axioms \<^cite>\<open>"Conway1971"\<close>.
Many properties of iteration follow already from these equational axioms.

Next we introduce iterings, which use generalised versions of simulation axioms in addition to sumstar and productstar.
Unlike the induction axioms of the Kleene star, which hold only in partial-correctness models, the simulation axioms are also valid in total and general correctness models.
They are still powerful enough to prove the correctness of complex results such as separation theorems of \<^cite>\<open>"Cohen2000"\<close> and Back's atomicity refinement theorem \<^cite>\<open>"BackWright1999" and "Wright2004"\<close>.
\<close>

theory Iterings

imports Stone_Relation_Algebras.Semirings

begin

subsection \<open>Conway Semirings\<close>

text \<open>
In this section, we consider equational axioms for iteration.
The algebraic structures are based on idempotent left semirings, which are expanded by a unary iteration operation.
We start with an unfold property, one inequality of the sliding rule and distributivity over joins, which is similar to Conway's sumstar.
\<close>

class circ =
  fixes circ :: "'a \<Rightarrow> 'a" ("_\<^sup>\<circ>" [100] 100)

class left_conway_semiring = idempotent_left_semiring + circ +
  assumes circ_left_unfold: "1 \<squnion> x * x\<^sup>\<circ> = x\<^sup>\<circ>"
  assumes circ_left_slide: "(x * y)\<^sup>\<circ> * x \<le> x * (y * x)\<^sup>\<circ>"
  assumes circ_sup_1: "(x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> * (y * x\<^sup>\<circ>)\<^sup>\<circ>"
begin

text \<open>
We obtain one inequality of Conway's productstar, as well as of the other unfold rule.
\<close>

lemma circ_mult_sub:
  "1 \<squnion> x * (y * x)\<^sup>\<circ> * y \<le> (x * y)\<^sup>\<circ>"
  by (metis sup_right_isotone circ_left_slide circ_left_unfold mult_assoc mult_right_isotone)

lemma circ_right_unfold_sub:
  "1 \<squnion> x\<^sup>\<circ> * x \<le> x\<^sup>\<circ>"
  by (metis circ_mult_sub mult_1_left mult_1_right)

lemma circ_zero:
  "bot\<^sup>\<circ> = 1"
  by (metis sup_monoid.add_0_right circ_left_unfold mult_left_zero)

lemma circ_increasing:
  "x \<le> x\<^sup>\<circ>"
  by (metis le_supI2 circ_left_unfold circ_right_unfold_sub mult_1_left mult_right_sub_dist_sup_left order_trans)

lemma circ_reflexive:
  "1 \<le> x\<^sup>\<circ>"
  by (metis sup_left_divisibility circ_left_unfold)

lemma circ_mult_increasing:
  "x \<le> x * x\<^sup>\<circ>"
  by (metis circ_reflexive mult_right_isotone mult_1_right)

lemma circ_mult_increasing_2:
  "x \<le> x\<^sup>\<circ> * x"
  by (metis circ_reflexive mult_left_isotone mult_1_left)

lemma circ_transitive_equal:
  "x\<^sup>\<circ> * x\<^sup>\<circ> = x\<^sup>\<circ>"
  by (metis sup_idem circ_sup_1 circ_left_unfold mult_assoc)

text \<open>
While iteration is not idempotent, a fixpoint is reached after applying this operation twice.
Iteration is idempotent for the unit.
\<close>

lemma circ_circ_circ:
  "x\<^sup>\<circ>\<^sup>\<circ>\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>"
  by (metis sup_idem circ_sup_1 circ_increasing circ_transitive_equal le_iff_sup)

lemma circ_one:
  "1\<^sup>\<circ> = 1\<^sup>\<circ>\<^sup>\<circ>"
  by (metis circ_circ_circ circ_zero)

lemma circ_sup_sub:
  "(x\<^sup>\<circ> * y)\<^sup>\<circ> * x\<^sup>\<circ> \<le> (x \<squnion> y)\<^sup>\<circ>"
  by (metis circ_sup_1 circ_left_slide)

lemma circ_plus_one:
  "x\<^sup>\<circ> = 1 \<squnion> x\<^sup>\<circ>"
  by (metis le_iff_sup circ_reflexive)

text \<open>
Iteration satisfies a characteristic property of reflexive transitive closures.
\<close>

lemma circ_rtc_2:
  "1 \<squnion> x \<squnion> x\<^sup>\<circ> * x\<^sup>\<circ> = x\<^sup>\<circ>"
  by (metis sup_assoc circ_increasing circ_plus_one circ_transitive_equal le_iff_sup)

lemma mult_zero_circ:
  "(x * bot)\<^sup>\<circ> = 1 \<squnion> x * bot"
  by (metis circ_left_unfold mult_assoc mult_left_zero)

lemma mult_zero_sup_circ:
  "(x \<squnion> y * bot)\<^sup>\<circ> = x\<^sup>\<circ> * (y * bot)\<^sup>\<circ>"
  by (metis circ_sup_1 mult_assoc mult_left_zero)

lemma circ_plus_sub:
  "x\<^sup>\<circ> * x \<le> x * x\<^sup>\<circ>"
  by (metis circ_left_slide mult_1_left mult_1_right)

lemma circ_loop_fixpoint:
  "y * (y\<^sup>\<circ> * z) \<squnion> z = y\<^sup>\<circ> * z"
  by (metis sup_commute circ_left_unfold mult_assoc mult_1_left mult_right_dist_sup)

lemma left_plus_below_circ:
  "x * x\<^sup>\<circ> \<le> x\<^sup>\<circ>"
  by (metis sup.cobounded2 circ_left_unfold)

lemma right_plus_below_circ:
  "x\<^sup>\<circ> * x \<le> x\<^sup>\<circ>"
  using circ_right_unfold_sub by auto

lemma circ_sup_upper_bound:
  "x \<le> z\<^sup>\<circ> \<Longrightarrow> y \<le> z\<^sup>\<circ> \<Longrightarrow> x \<squnion> y \<le> z\<^sup>\<circ>"
  by simp

lemma circ_mult_upper_bound:
  "x \<le> z\<^sup>\<circ> \<Longrightarrow> y \<le> z\<^sup>\<circ> \<Longrightarrow> x * y \<le> z\<^sup>\<circ>"
  by (metis mult_isotone circ_transitive_equal)

lemma circ_sub_dist:
  "x\<^sup>\<circ> \<le> (x \<squnion> y)\<^sup>\<circ>"
  by (metis circ_sup_sub circ_plus_one mult_1_left mult_right_sub_dist_sup_left order_trans)

lemma circ_sub_dist_1:
  "x \<le> (x \<squnion> y)\<^sup>\<circ>"
  using circ_increasing le_supE by blast

lemma circ_sub_dist_2:
  "x * y \<le> (x \<squnion> y)\<^sup>\<circ>"
  by (metis sup_commute circ_mult_upper_bound circ_sub_dist_1)

lemma circ_sub_dist_3:
  "x\<^sup>\<circ> * y\<^sup>\<circ> \<le> (x \<squnion> y)\<^sup>\<circ>"
  by (metis sup_commute circ_mult_upper_bound circ_sub_dist)

lemma circ_isotone:
  "x \<le> y \<Longrightarrow> x\<^sup>\<circ> \<le> y\<^sup>\<circ>"
  by (metis circ_sub_dist le_iff_sup)

lemma circ_sup_2:
  "(x \<squnion> y)\<^sup>\<circ> \<le> (x\<^sup>\<circ> * y\<^sup>\<circ>)\<^sup>\<circ>"
  by (metis sup.bounded_iff circ_increasing circ_isotone circ_reflexive mult_isotone mult_1_left mult_1_right)

lemma circ_sup_one_left_unfold:
  "1 \<le> x \<Longrightarrow> x * x\<^sup>\<circ> = x\<^sup>\<circ>"
  by (metis order.antisym le_iff_sup mult_1_left mult_right_sub_dist_sup_left left_plus_below_circ)

lemma circ_sup_one_right_unfold:
  "1 \<le> x \<Longrightarrow> x\<^sup>\<circ> * x = x\<^sup>\<circ>"
  by (metis order.antisym le_iff_sup mult_left_sub_dist_sup_left mult_1_right right_plus_below_circ)

lemma circ_decompose_4:
  "(x\<^sup>\<circ> * y\<^sup>\<circ>)\<^sup>\<circ> = x\<^sup>\<circ> * (y\<^sup>\<circ> * x\<^sup>\<circ>)\<^sup>\<circ>"
  by (metis sup_assoc sup_commute circ_sup_1 circ_loop_fixpoint circ_plus_one circ_rtc_2 circ_transitive_equal mult_assoc)

lemma circ_decompose_5:
  "(x\<^sup>\<circ> * y\<^sup>\<circ>)\<^sup>\<circ> = (y\<^sup>\<circ> * x\<^sup>\<circ>)\<^sup>\<circ>"
  by (metis circ_decompose_4 circ_loop_fixpoint order.antisym mult_right_sub_dist_sup_right mult_assoc)

lemma circ_decompose_6:
  "x\<^sup>\<circ> * (y * x\<^sup>\<circ>)\<^sup>\<circ> = y\<^sup>\<circ> * (x * y\<^sup>\<circ>)\<^sup>\<circ>"
  by (metis sup_commute circ_sup_1)

lemma circ_decompose_7:
  "(x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> * y\<^sup>\<circ> * (x \<squnion> y)\<^sup>\<circ>"
  by (metis circ_sup_1 circ_decompose_6 circ_transitive_equal mult_assoc)

lemma circ_decompose_8:
  "(x \<squnion> y)\<^sup>\<circ> = (x \<squnion> y)\<^sup>\<circ> * x\<^sup>\<circ> * y\<^sup>\<circ>"
  by (metis order.antisym eq_refl mult_assoc mult_isotone mult_1_right circ_mult_upper_bound circ_reflexive circ_sub_dist_3)

lemma circ_decompose_9:
  "(x\<^sup>\<circ> * y\<^sup>\<circ>)\<^sup>\<circ> = x\<^sup>\<circ> * y\<^sup>\<circ> * (x\<^sup>\<circ> * y\<^sup>\<circ>)\<^sup>\<circ>"
  by (metis circ_decompose_4 mult_assoc)

lemma circ_decompose_10:
  "(x\<^sup>\<circ> * y\<^sup>\<circ>)\<^sup>\<circ> = (x\<^sup>\<circ> * y\<^sup>\<circ>)\<^sup>\<circ> * x\<^sup>\<circ> * y\<^sup>\<circ>"
  by (metis sup_ge2 circ_loop_fixpoint circ_reflexive circ_sup_one_right_unfold mult_assoc order_trans)

lemma circ_back_loop_prefixpoint:
  "(z * y\<^sup>\<circ>) * y \<squnion> z \<le> z * y\<^sup>\<circ>"
  by (metis sup.bounded_iff circ_left_unfold mult_assoc mult_left_sub_dist_sup_left mult_right_isotone mult_1_right right_plus_below_circ)

text \<open>
We obtain the fixpoint and prefixpoint properties of iteration, but not least or greatest fixpoint properties.
\<close>

lemma circ_loop_is_fixpoint:
  "is_fixpoint (\<lambda>x . y * x \<squnion> z) (y\<^sup>\<circ> * z)"
  by (metis circ_loop_fixpoint is_fixpoint_def)

lemma circ_back_loop_is_prefixpoint:
  "is_prefixpoint (\<lambda>x . x * y \<squnion> z) (z * y\<^sup>\<circ>)"
  by (metis circ_back_loop_prefixpoint is_prefixpoint_def)

lemma circ_circ_sup:
  "(1 \<squnion> x)\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>"
  by (metis sup_commute circ_sup_1 circ_decompose_4 circ_zero mult_1_right)

lemma circ_circ_mult_sub:
  "x\<^sup>\<circ> * 1\<^sup>\<circ> \<le> x\<^sup>\<circ>\<^sup>\<circ>"
  by (metis circ_increasing circ_isotone circ_mult_upper_bound circ_reflexive)

lemma left_plus_circ:
  "(x * x\<^sup>\<circ>)\<^sup>\<circ> = x\<^sup>\<circ>"
  by (metis circ_left_unfold circ_sup_1 mult_1_right mult_sub_right_one sup.absorb1 mult_assoc)

lemma right_plus_circ:
  "(x\<^sup>\<circ> * x)\<^sup>\<circ> = x\<^sup>\<circ>"
  by (metis sup_commute circ_isotone circ_loop_fixpoint circ_plus_sub circ_sub_dist order.eq_iff left_plus_circ)

lemma circ_square:
  "(x * x)\<^sup>\<circ> \<le> x\<^sup>\<circ>"
  by (metis circ_increasing circ_isotone left_plus_circ mult_right_isotone)

lemma circ_mult_sub_sup:
  "(x * y)\<^sup>\<circ> \<le> (x \<squnion> y)\<^sup>\<circ>"
  by (metis sup_ge1 sup_ge2 circ_isotone circ_square mult_isotone order_trans)

lemma circ_sup_mult_zero:
  "x\<^sup>\<circ> * y = (x \<squnion> y * bot)\<^sup>\<circ> * y"
proof -
  have "(x \<squnion> y * bot)\<^sup>\<circ> * y = x\<^sup>\<circ> * (1 \<squnion> y * bot) * y"
    by (metis mult_zero_sup_circ mult_zero_circ)
  also have "... = x\<^sup>\<circ> * (y \<squnion> y * bot)"
    by (metis mult_assoc mult_1_left mult_left_zero mult_right_dist_sup)
  also have "... = x\<^sup>\<circ> * y"
    by (metis sup_commute le_iff_sup zero_right_mult_decreasing)
  finally show ?thesis
    by simp
qed

lemma troeger_1:
  "(x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> * (1 \<squnion> y * (x \<squnion> y)\<^sup>\<circ>)"
  by (metis circ_sup_1 circ_left_unfold mult_assoc)

lemma troeger_2:
  "(x \<squnion> y)\<^sup>\<circ> * z = x\<^sup>\<circ> * (y * (x \<squnion> y)\<^sup>\<circ> * z \<squnion> z)"
  by (metis circ_sup_1 circ_loop_fixpoint mult_assoc)

lemma troeger_3:
  "(x \<squnion> y * bot)\<^sup>\<circ> = x\<^sup>\<circ> * (1 \<squnion> y * bot)"
  by (metis mult_zero_sup_circ mult_zero_circ)

lemma circ_sup_sub_sup_one_1:
  "x \<squnion> y \<le> x\<^sup>\<circ> * (1 \<squnion> y)"
  by (metis circ_increasing circ_left_unfold mult_1_left mult_1_right mult_left_sub_dist_sup mult_right_sub_dist_sup_left order_trans sup_mono)

lemma circ_sup_sub_sup_one_2:
  "x\<^sup>\<circ> * (x \<squnion> y) \<le> x\<^sup>\<circ> * (1 \<squnion> y)"
  by (metis circ_sup_sub_sup_one_1 circ_transitive_equal mult_assoc mult_right_isotone)

lemma circ_sup_sub_sup_one:
  "x * x\<^sup>\<circ> * (x \<squnion> y) \<le> x * x\<^sup>\<circ> * (1 \<squnion> y)"
  by (metis circ_sup_sub_sup_one_2 mult_assoc mult_right_isotone)

lemma circ_square_2:
  "(x * x)\<^sup>\<circ> * (x \<squnion> 1) \<le> x\<^sup>\<circ>"
  by (metis sup.bounded_iff circ_increasing circ_mult_upper_bound circ_reflexive circ_square)

lemma circ_extra_circ:
  "(y * x\<^sup>\<circ>)\<^sup>\<circ> = (y * y\<^sup>\<circ> * x\<^sup>\<circ>)\<^sup>\<circ>"
  by (metis circ_decompose_6 circ_transitive_equal left_plus_circ mult_assoc)

lemma circ_circ_sub_mult:
  "1\<^sup>\<circ> * x\<^sup>\<circ> \<le> x\<^sup>\<circ>\<^sup>\<circ>"
  by (metis circ_increasing circ_isotone circ_mult_upper_bound circ_reflexive)

lemma circ_decompose_11:
  "(x\<^sup>\<circ> * y\<^sup>\<circ>)\<^sup>\<circ> = (x\<^sup>\<circ> * y\<^sup>\<circ>)\<^sup>\<circ> * x\<^sup>\<circ>"
  by (metis circ_decompose_10 circ_decompose_4 circ_decompose_5 circ_decompose_9 left_plus_circ)

lemma circ_mult_below_circ_circ:
  "(x * y)\<^sup>\<circ> \<le> (x\<^sup>\<circ> * y)\<^sup>\<circ> * x\<^sup>\<circ>"
  by (metis circ_increasing circ_isotone circ_reflexive dual_order.trans mult_left_isotone mult_right_isotone mult_1_right)

(*
lemma circ_right_unfold: "1 \<squnion> x\<^sup>\<circ> * x = x\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma circ_mult: "1 \<squnion> x * (y * x)\<^sup>\<circ> * y = (x * y)\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma circ_slide: "(x * y)\<^sup>\<circ> * x = x * (y * x)\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma circ_plus_same: "x\<^sup>\<circ> * x = x * x\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma "1\<^sup>\<circ> * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * 1\<^sup>\<circ>" nitpick [expect=genuine,card=7] oops
lemma circ_circ_mult_1: "x\<^sup>\<circ> * 1\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>" nitpick [expect=genuine,card=7] oops
lemma "x\<^sup>\<circ> * 1\<^sup>\<circ> \<le> 1\<^sup>\<circ> * x\<^sup>\<circ>" nitpick [expect=genuine,card=7] oops
lemma circ_circ_mult: "1\<^sup>\<circ> * x\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>" nitpick [expect=genuine,card=7] oops
lemma circ_sup: "(x\<^sup>\<circ> * y)\<^sup>\<circ> * x\<^sup>\<circ> = (x \<squnion> y)\<^sup>\<circ>" nitpick [expect=genuine,card=8] oops
lemma circ_unfold_sum: "(x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> \<squnion> x\<^sup>\<circ> * y * (x \<squnion> y)\<^sup>\<circ>" nitpick [expect=genuine,card=7] oops

lemma mult_zero_sup_circ_2: "(x \<squnion> y * bot)\<^sup>\<circ> = x\<^sup>\<circ> \<squnion> x\<^sup>\<circ> * y * bot" nitpick [expect=genuine,card=7] oops
lemma sub_mult_one_circ: "x * 1\<^sup>\<circ> \<le> 1\<^sup>\<circ> * x" nitpick [expect=genuine] oops
lemma circ_back_loop_fixpoint: "(z * y\<^sup>\<circ>) * y \<squnion> z = z * y\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma circ_back_loop_is_fixpoint: "is_fixpoint (\<lambda>x . x * y \<squnion> z) (z * y\<^sup>\<circ>)" nitpick [expect=genuine] oops
lemma "x\<^sup>\<circ> * y\<^sup>\<circ> \<le> (x\<^sup>\<circ> * y)\<^sup>\<circ> * x\<^sup>\<circ>" nitpick [expect=genuine,card=7] oops
*)

end

text \<open>
The next class considers the interaction of iteration with a greatest element.
\<close>

class bounded_left_conway_semiring = bounded_idempotent_left_semiring + left_conway_semiring
begin

lemma circ_top:
  "top\<^sup>\<circ> = top"
  by (simp add: order.antisym circ_increasing)

lemma circ_right_top:
  "x\<^sup>\<circ> * top = top"
  by (metis sup_right_top circ_loop_fixpoint)

lemma circ_left_top:
  "top * x\<^sup>\<circ> = top"
  by (metis circ_right_top circ_top circ_decompose_11)

lemma mult_top_circ:
  "(x * top)\<^sup>\<circ> = 1 \<squnion> x * top"
  by (metis circ_left_top circ_left_unfold mult_assoc)

end

class left_zero_conway_semiring = idempotent_left_zero_semiring + left_conway_semiring
begin

lemma mult_zero_sup_circ_2:
  "(x \<squnion> y * bot)\<^sup>\<circ> = x\<^sup>\<circ> \<squnion> x\<^sup>\<circ> * y * bot"
  by (metis mult_assoc mult_left_dist_sup mult_1_right troeger_3)

lemma circ_unfold_sum:
  "(x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> \<squnion> x\<^sup>\<circ> * y * (x \<squnion> y)\<^sup>\<circ>"
  by (metis mult_assoc mult_left_dist_sup mult_1_right troeger_1)

end

text \<open>
The next class assumes the full sliding equation.
\<close>

class left_conway_semiring_1 = left_conway_semiring +
  assumes circ_right_slide: "x * (y * x)\<^sup>\<circ> \<le> (x * y)\<^sup>\<circ> * x"
begin

lemma circ_slide_1:
  "x * (y * x)\<^sup>\<circ> = (x * y)\<^sup>\<circ> * x"
  by (metis order.antisym circ_left_slide circ_right_slide)

text \<open>
This implies the full unfold rules and Conway's productstar.
\<close>

lemma circ_right_unfold_1:
  "1 \<squnion> x\<^sup>\<circ> * x = x\<^sup>\<circ>"
  by (metis circ_left_unfold circ_slide_1 mult_1_left mult_1_right)

lemma circ_mult_1:
  "(x * y)\<^sup>\<circ> = 1 \<squnion> x * (y * x)\<^sup>\<circ> * y"
  by (metis circ_left_unfold circ_slide_1 mult_assoc)

lemma circ_sup_9:
  "(x \<squnion> y)\<^sup>\<circ> = (x\<^sup>\<circ> * y)\<^sup>\<circ> * x\<^sup>\<circ>"
  by (metis circ_sup_1 circ_slide_1)

lemma circ_plus_same:
  "x\<^sup>\<circ> * x = x * x\<^sup>\<circ>"
  by (metis circ_slide_1 mult_1_left mult_1_right)

lemma circ_decompose_12:
  "x\<^sup>\<circ> * y\<^sup>\<circ> \<le> (x\<^sup>\<circ> * y)\<^sup>\<circ> * x\<^sup>\<circ>"
  by (metis circ_sup_9 circ_sub_dist_3)

end

class left_zero_conway_semiring_1 = left_zero_conway_semiring + left_conway_semiring_1
begin

lemma circ_back_loop_fixpoint:
  "(z * y\<^sup>\<circ>) * y \<squnion> z = z * y\<^sup>\<circ>"
  by (metis sup_commute circ_left_unfold circ_plus_same mult_assoc mult_left_dist_sup mult_1_right)

lemma circ_back_loop_is_fixpoint:
  "is_fixpoint (\<lambda>x . x * y \<squnion> z) (z * y\<^sup>\<circ>)"
  by (metis circ_back_loop_fixpoint is_fixpoint_def)

lemma circ_elimination:
  "x * y = bot \<Longrightarrow> x * y\<^sup>\<circ> \<le> x"
  by (metis sup_monoid.add_0_left circ_back_loop_fixpoint circ_plus_same mult_assoc mult_left_zero order_refl)

end

subsection \<open>Iterings\<close>

text \<open>
This section adds simulation axioms to Conway semirings.
We consider several classes with increasingly general simulation axioms.
\<close>

class itering_1 = left_conway_semiring_1 +
  assumes circ_simulate: "z * x \<le> y * z \<longrightarrow> z * x\<^sup>\<circ> \<le> y\<^sup>\<circ> * z"
begin

lemma circ_circ_mult:
  "1\<^sup>\<circ> * x\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>"
  by (metis order.antisym circ_circ_sup circ_reflexive circ_simulate circ_sub_dist_3 circ_sup_one_left_unfold circ_transitive_equal mult_1_left order_refl)

lemma sub_mult_one_circ:
  "x * 1\<^sup>\<circ> \<le> 1\<^sup>\<circ> * x"
  by (metis circ_simulate mult_1_left mult_1_right order_refl)

text \<open>
The left simulation axioms is enough to prove a basic import property of tests.
\<close>

lemma circ_import:
  assumes "p \<le> p * p"
      and "p \<le> 1"
      and "p * x \<le> x * p"
    shows "p * x\<^sup>\<circ> = p * (p * x)\<^sup>\<circ>"
proof -
  have "p * x \<le> p * (p * x * p) * p"
    by (metis assms coreflexive_transitive order.eq_iff test_preserves_equation mult_assoc)
  hence "p * x\<^sup>\<circ> \<le> p * (p * x)\<^sup>\<circ>"
    by (metis (no_types) assms circ_simulate circ_slide_1 test_preserves_equation)
  thus ?thesis
    by (metis assms(2) circ_isotone mult_left_isotone mult_1_left mult_right_isotone order.antisym)
qed

end

text \<open>
Including generalisations of both simulation axioms allows us to prove separation rules.
\<close>

class itering_2 = left_conway_semiring_1 +
  assumes circ_simulate_right: "z * x \<le> y * z \<squnion> w \<longrightarrow> z * x\<^sup>\<circ> \<le> y\<^sup>\<circ> * (z \<squnion> w * x\<^sup>\<circ>)"
  assumes circ_simulate_left: "x * z \<le> z * y \<squnion> w \<longrightarrow> x\<^sup>\<circ> * z \<le> (z \<squnion> x\<^sup>\<circ> * w) * y\<^sup>\<circ>"
begin

subclass itering_1
  apply unfold_locales
  by (metis sup_monoid.add_0_right circ_simulate_right mult_left_zero)

lemma circ_simulate_left_1:
  "x * z \<le> z * y \<Longrightarrow> x\<^sup>\<circ> * z \<le> z * y\<^sup>\<circ> \<squnion> x\<^sup>\<circ> * bot"
  by (metis sup_monoid.add_0_right circ_simulate_left mult_assoc mult_left_zero mult_right_dist_sup)

lemma circ_separate_1:
  assumes "y * x \<le> x * y"
    shows "(x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> * y\<^sup>\<circ>"
proof -
  have "y\<^sup>\<circ> * x \<le> x * y\<^sup>\<circ> \<squnion> y\<^sup>\<circ> * bot"
    by (metis assms circ_simulate_left_1)
  hence "y\<^sup>\<circ> * x * y\<^sup>\<circ> \<le> x * y\<^sup>\<circ> * y\<^sup>\<circ> \<squnion> y\<^sup>\<circ> * bot * y\<^sup>\<circ>"
    by (metis mult_assoc mult_left_isotone mult_right_dist_sup)
  also have "... = x * y\<^sup>\<circ> \<squnion> y\<^sup>\<circ> * bot"
    by (metis circ_transitive_equal mult_assoc mult_left_zero)
  finally have "y\<^sup>\<circ> * (x * y\<^sup>\<circ>)\<^sup>\<circ> \<le> x\<^sup>\<circ> * (y\<^sup>\<circ> \<squnion> y\<^sup>\<circ> * bot)"
    using circ_simulate_right mult_assoc by fastforce
  also have "... = x\<^sup>\<circ> * y\<^sup>\<circ>"
    by (simp add: sup_absorb1 zero_right_mult_decreasing)
  finally have "(x \<squnion> y)\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ>"
    by (simp add: circ_decompose_6 circ_sup_1)
  thus ?thesis
    by (simp add: order.antisym circ_sub_dist_3)
qed

lemma circ_circ_mult_1:
  "x\<^sup>\<circ> * 1\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>"
  by (metis sup_commute circ_circ_sup circ_separate_1 mult_1_left mult_1_right order_refl)

end

text \<open>
With distributivity, we also get Back's atomicity refinement theorem.
\<close>

class itering_3 = itering_2 + left_zero_conway_semiring_1
begin

lemma circ_simulate_1:
  assumes "y * x \<le> x * y"
    shows "y\<^sup>\<circ> * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ>"
proof -
  have "y * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * y"
    by (metis assms circ_simulate)
  hence "y\<^sup>\<circ> * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ> \<squnion> y\<^sup>\<circ> * bot"
    by (metis circ_simulate_left_1)
  thus ?thesis
    by (metis sup_assoc sup_monoid.add_0_right circ_loop_fixpoint mult_assoc mult_left_zero mult_zero_sup_circ_2)
qed

lemma atomicity_refinement:
  assumes "s = s * q"
      and "x = q * x"
      and "q * b = bot"
      and "r * b \<le> b * r"
      and "r * l \<le> l * r"
      and "x * l \<le> l * x"
      and "b * l \<le> l * b"
      and "q * l \<le> l * q"
      and "r\<^sup>\<circ> * q \<le> q * r\<^sup>\<circ>"
      and "q \<le> 1"
    shows "s * (x \<squnion> b \<squnion> r \<squnion> l)\<^sup>\<circ> * q \<le> s * (x * b\<^sup>\<circ> * q \<squnion> r \<squnion> l)\<^sup>\<circ>"
proof -
  have "(x \<squnion> b \<squnion> r) * l \<le> l * (x \<squnion> b \<squnion> r)"
    using assms(5-7) mult_left_dist_sup mult_right_dist_sup semiring.add_mono by presburger
  hence "s * (x \<squnion> b \<squnion> r \<squnion> l)\<^sup>\<circ> * q = s * l\<^sup>\<circ> * (x \<squnion> b \<squnion> r)\<^sup>\<circ> * q"
    by (metis sup_commute circ_separate_1 mult_assoc)
  also have "... = s * l\<^sup>\<circ> * b\<^sup>\<circ> * r\<^sup>\<circ> * q * (x * b\<^sup>\<circ> * r\<^sup>\<circ> * q)\<^sup>\<circ>"
  proof -
    have "(b \<squnion> r)\<^sup>\<circ> = b\<^sup>\<circ> * r\<^sup>\<circ>"
      by (simp add: assms(4) circ_separate_1)
    hence "b\<^sup>\<circ> * r\<^sup>\<circ> * (q * (x * b\<^sup>\<circ> * r\<^sup>\<circ>))\<^sup>\<circ> = (x \<squnion> b \<squnion> r)\<^sup>\<circ>"
      by (metis (full_types) assms(2) circ_sup_1 sup_assoc sup_commute mult_assoc)
    thus ?thesis
      by (metis circ_slide_1 mult_assoc)
  qed
  also have "... \<le> s * l\<^sup>\<circ> * b\<^sup>\<circ> * r\<^sup>\<circ> * q * (x * b\<^sup>\<circ> * q * r\<^sup>\<circ>)\<^sup>\<circ>"
    by (metis assms(9) circ_isotone mult_assoc mult_right_isotone)
  also have "... \<le> s * q * l\<^sup>\<circ> * b\<^sup>\<circ> * r\<^sup>\<circ> * (x * b\<^sup>\<circ> * q * r\<^sup>\<circ>)\<^sup>\<circ>"
    by (metis assms(1,10) mult_left_isotone mult_right_isotone mult_1_right)
  also have "... \<le> s * l\<^sup>\<circ> * q * b\<^sup>\<circ> * r\<^sup>\<circ> * (x * b\<^sup>\<circ> * q * r\<^sup>\<circ>)\<^sup>\<circ>"
    by (metis assms(1,8) circ_simulate mult_assoc mult_left_isotone mult_right_isotone)
  also have "... \<le> s * l\<^sup>\<circ> * r\<^sup>\<circ> * (x * b\<^sup>\<circ> * q * r\<^sup>\<circ>)\<^sup>\<circ>"
    by (metis assms(3,10) sup_monoid.add_0_left circ_back_loop_fixpoint circ_plus_same mult_assoc mult_left_zero mult_left_isotone mult_right_isotone mult_1_right)
  also have "... \<le> s * (x * b\<^sup>\<circ> * q \<squnion> r \<squnion> l)\<^sup>\<circ>"
    by (metis sup_commute circ_sup_1 circ_sub_dist_3 mult_assoc mult_right_isotone)
  finally show ?thesis
    .
qed

end

text \<open>
The following class contains the most general simulation axioms we consider.
They allow us to prove further separation properties.
\<close>

class itering = idempotent_left_zero_semiring + circ +
  assumes circ_sup: "(x \<squnion> y)\<^sup>\<circ> = (x\<^sup>\<circ> * y)\<^sup>\<circ> * x\<^sup>\<circ>"
  assumes circ_mult: "(x * y)\<^sup>\<circ> = 1 \<squnion> x * (y * x)\<^sup>\<circ> * y"
  assumes circ_simulate_right_plus: "z * x \<le> y * y\<^sup>\<circ> * z \<squnion> w \<longrightarrow> z * x\<^sup>\<circ> \<le> y\<^sup>\<circ> * (z \<squnion> w * x\<^sup>\<circ>)"
  assumes circ_simulate_left_plus: "x * z \<le> z * y\<^sup>\<circ> \<squnion> w \<longrightarrow> x\<^sup>\<circ> * z \<le> (z \<squnion> x\<^sup>\<circ> * w) * y\<^sup>\<circ>"
begin

lemma circ_right_unfold:
  "1 \<squnion> x\<^sup>\<circ> * x = x\<^sup>\<circ>"
  by (metis circ_mult mult_1_left mult_1_right)

lemma circ_slide:
  "x * (y * x)\<^sup>\<circ> = (x * y)\<^sup>\<circ> * x"
proof -
  have "x * (y * x)\<^sup>\<circ> = Rf x (y * 1 \<squnion> y * (x * (y * x)\<^sup>\<circ> * y)) * x"
    by (metis (no_types) circ_mult mult_1_left mult_1_right mult_left_dist_sup mult_right_dist_sup mult_assoc)
  thus ?thesis
    by (metis (no_types) circ_mult mult_1_right mult_left_dist_sup mult_assoc)
qed

subclass itering_3
  apply unfold_locales
  apply (metis circ_mult mult_1_left mult_1_right)
  apply (metis circ_slide order_refl)
  apply (metis circ_sup circ_slide)
  apply (metis circ_slide order_refl)
  apply (metis sup_left_isotone circ_right_unfold mult_left_isotone mult_left_sub_dist_sup_left mult_1_right order_trans circ_simulate_right_plus)
  by (metis sup_commute sup_ge1 sup_right_isotone circ_mult mult_right_isotone mult_1_right order_trans circ_simulate_left_plus)

lemma circ_simulate_right_plus_1:
  "z * x \<le> y * y\<^sup>\<circ> * z \<Longrightarrow> z * x\<^sup>\<circ> \<le> y\<^sup>\<circ> * z"
  by (metis sup_monoid.add_0_right circ_simulate_right_plus mult_left_zero)

lemma circ_simulate_left_plus_1:
  "x * z \<le> z * y\<^sup>\<circ> \<Longrightarrow> x\<^sup>\<circ> * z \<le> z * y\<^sup>\<circ> \<squnion> x\<^sup>\<circ> * bot"
  by (metis sup_monoid.add_0_right circ_simulate_left_plus mult_assoc mult_left_zero mult_right_dist_sup)

lemma circ_simulate_2:
  "y * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ> \<longleftrightarrow> y\<^sup>\<circ> * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ>"
  apply (rule iffI)
  apply (metis sup_assoc sup_monoid.add_0_right circ_loop_fixpoint circ_simulate_left_plus_1 mult_assoc mult_left_zero mult_zero_sup_circ_2)
  by (metis circ_increasing mult_left_isotone order_trans)

lemma circ_simulate_absorb:
  "y * x \<le> x \<Longrightarrow> y\<^sup>\<circ> * x \<le> x \<squnion> y\<^sup>\<circ> * bot"
  by (metis circ_simulate_left_plus_1 circ_zero mult_1_right)

lemma circ_simulate_3:
  "y * x\<^sup>\<circ> \<le> x\<^sup>\<circ> \<Longrightarrow> y\<^sup>\<circ> * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ>"
  by (metis sup.bounded_iff circ_reflexive circ_simulate_2 le_iff_sup mult_right_isotone mult_1_right)

lemma circ_separate_mult_1:
  "y * x \<le> x * y \<Longrightarrow> (x * y)\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ>"
  by (metis circ_mult_sub_sup circ_separate_1)

lemma circ_separate_unfold:
  "(y * x\<^sup>\<circ>)\<^sup>\<circ> = y\<^sup>\<circ> \<squnion> y\<^sup>\<circ> * y * x * x\<^sup>\<circ> * (y * x\<^sup>\<circ>)\<^sup>\<circ>"
  by (metis circ_back_loop_fixpoint circ_plus_same circ_unfold_sum sup_commute mult_assoc)

lemma separation:
  assumes "y * x \<le> x * y\<^sup>\<circ>"
    shows "(x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> * y\<^sup>\<circ>"
proof -
  have "y\<^sup>\<circ> * x * y\<^sup>\<circ> \<le> x * y\<^sup>\<circ> \<squnion> y\<^sup>\<circ> * bot"
    by (metis assms circ_simulate_left_plus_1 circ_transitive_equal mult_assoc mult_left_isotone)
  thus ?thesis
    by (metis sup_commute circ_sup_1 circ_simulate_right circ_sub_dist_3 le_iff_sup mult_assoc mult_left_zero zero_right_mult_decreasing)
qed

lemma simulation:
  "y * x \<le> x * y\<^sup>\<circ> \<Longrightarrow> y\<^sup>\<circ> * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ>"
  by (metis sup_ge2 circ_isotone circ_mult_upper_bound circ_sub_dist separation)

lemma circ_simulate_4:
  assumes "y * x \<le> x * x\<^sup>\<circ> * (1 \<squnion> y)"
    shows "y\<^sup>\<circ> * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ>"
proof -
  have "x \<squnion> (x * x\<^sup>\<circ> * x * x \<squnion> x * x) = x * x\<^sup>\<circ>"
    by (metis (no_types) circ_back_loop_fixpoint mult_right_dist_sup sup_commute)
  hence "x \<le> x * x\<^sup>\<circ> * 1 \<squnion> x * x\<^sup>\<circ> * y"
    by (metis mult_1_right sup_assoc sup_ge1)
  hence "(1 \<squnion> y) * x \<le> x * x\<^sup>\<circ> * (1 \<squnion> y)"
    using assms mult_left_dist_sup mult_right_dist_sup by force
  hence "y * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ>"
    by (metis circ_sup_upper_bound circ_increasing circ_reflexive circ_simulate_right_plus_1 mult_right_isotone mult_right_sub_dist_sup_right order_trans)
  thus ?thesis
    by (metis circ_simulate_2)
qed

lemma circ_simulate_5:
  "y * x \<le> x * x\<^sup>\<circ> * (x \<squnion> y) \<Longrightarrow> y\<^sup>\<circ> * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ>"
  by (metis circ_sup_sub_sup_one circ_simulate_4 order_trans)

lemma circ_simulate_6:
  "y * x \<le> x * (x \<squnion> y) \<Longrightarrow> y\<^sup>\<circ> * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ>"
  by (metis sup_commute circ_back_loop_fixpoint circ_simulate_5 mult_right_sub_dist_sup_left order_trans)

lemma circ_separate_4:
  assumes "y * x \<le> x * x\<^sup>\<circ> * (1 \<squnion> y)"
    shows "(x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> * y\<^sup>\<circ>"
proof -
  have "y * x * x\<^sup>\<circ> \<le> x * x\<^sup>\<circ> * (1 \<squnion> y) * x\<^sup>\<circ>"
    by (simp add: assms mult_left_isotone)
  also have "... = x * x\<^sup>\<circ> \<squnion> x * x\<^sup>\<circ> * y * x\<^sup>\<circ>"
    by (simp add: circ_transitive_equal mult_left_dist_sup mult_right_dist_sup mult_assoc)
  also have "... \<le> x * x\<^sup>\<circ> \<squnion> x * x\<^sup>\<circ> * x\<^sup>\<circ> * y\<^sup>\<circ>"
    by (metis assms sup_right_isotone circ_simulate_2 circ_simulate_4 mult_assoc mult_right_isotone)
  finally have "y * x * x\<^sup>\<circ> \<le> x * x\<^sup>\<circ> * y\<^sup>\<circ>"
    by (metis circ_reflexive circ_transitive_equal le_iff_sup mult_assoc mult_right_isotone mult_1_right)
  thus ?thesis
    by (metis circ_sup_1 left_plus_circ mult_assoc separation)
qed

lemma circ_separate_5:
  "y * x \<le> x * x\<^sup>\<circ> * (x \<squnion> y) \<Longrightarrow> (x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> * y\<^sup>\<circ>"
  by (metis circ_sup_sub_sup_one circ_separate_4 order_trans)

lemma circ_separate_6:
  "y * x \<le> x * (x \<squnion> y) \<Longrightarrow> (x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> * y\<^sup>\<circ>"
  by (metis sup_commute circ_back_loop_fixpoint circ_separate_5 mult_right_sub_dist_sup_left order_trans)

end

class bounded_itering = bounded_idempotent_left_zero_semiring + itering
begin

subclass bounded_left_conway_semiring ..

(*
lemma "1 = x\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma "x = x\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma "x = x * x\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma "x * x\<^sup>\<circ> = x\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma "x\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma "(x * y)\<^sup>\<circ> = (x \<squnion> y)\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma "x\<^sup>\<circ> * y\<^sup>\<circ> = (x \<squnion> y)\<^sup>\<circ>" nitpick [expect=genuine,card=6] oops
lemma "(x \<squnion> y)\<^sup>\<circ> = (x\<^sup>\<circ> * y\<^sup>\<circ>)\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma "1 = 1\<^sup>\<circ>" nitpick [expect=genuine] oops

lemma "1 = (x * bot)\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma "1 \<squnion> x * bot = x\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma "x\<^sup>\<circ> = x\<^sup>\<circ> * 1\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma "z \<squnion> y * x = x \<longrightarrow> y\<^sup>\<circ> * z \<le> x" nitpick [expect=genuine] oops
lemma "y * x = x \<longrightarrow> y\<^sup>\<circ> * x \<le> x" nitpick [expect=genuine] oops
lemma "z \<squnion> x * y = x \<longrightarrow> z * y\<^sup>\<circ> \<le> x" nitpick [expect=genuine] oops
lemma "x * y = x \<longrightarrow> x * y\<^sup>\<circ> \<le> x" nitpick [expect=genuine] oops
lemma "x = z \<squnion> y * x \<longrightarrow> x \<le> y\<^sup>\<circ> * z" nitpick [expect=genuine] oops
lemma "x = y * x \<longrightarrow> x \<le> y\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma "x * z = z * y \<longrightarrow> x\<^sup>\<circ> * z \<le> z * y\<^sup>\<circ>" nitpick [expect=genuine] oops

lemma "x\<^sup>\<circ> = (x * x)\<^sup>\<circ> * (x \<squnion> 1)" oops
lemma "y\<^sup>\<circ> * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ> \<longrightarrow> (x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> * y\<^sup>\<circ>" oops
lemma "y * x \<le> (1 \<squnion> x) * y\<^sup>\<circ> \<longrightarrow> (x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> * y\<^sup>\<circ>" oops
lemma "y * x \<le> x \<longrightarrow> y\<^sup>\<circ> * x \<le> 1\<^sup>\<circ> * x" oops
*)

end

text \<open>
We finally expand Conway semirings and iterings by an element that corresponds to the endless loop.
\<close>

class L =
  fixes L :: "'a"

class left_conway_semiring_L = left_conway_semiring + L +
  assumes one_circ_mult_split: "1\<^sup>\<circ> * x = L \<squnion> x"
  assumes L_split_sup: "x * (y \<squnion> L) \<le> x * y \<squnion> L"
begin

lemma L_def:
  "L = 1\<^sup>\<circ> * bot"
  by (metis sup_monoid.add_0_right one_circ_mult_split)

lemma one_circ_split:
  "1\<^sup>\<circ> = L \<squnion> 1"
  by (metis mult_1_right one_circ_mult_split)

lemma one_circ_circ_split:
  "1\<^sup>\<circ>\<^sup>\<circ> = L \<squnion> 1"
  by (metis circ_one one_circ_split)

lemma sub_mult_one_circ:
  "x * 1\<^sup>\<circ> \<le> 1\<^sup>\<circ> * x"
  by (metis L_split_sup sup_commute mult_1_right one_circ_mult_split)

lemma one_circ_mult_split_2:
  "1\<^sup>\<circ> * x = x * 1\<^sup>\<circ> \<squnion> L"
proof -
  have 1: "x * 1\<^sup>\<circ> \<le> L \<squnion> x"
    using one_circ_mult_split sub_mult_one_circ by presburger
  have "x \<squnion> x * 1\<^sup>\<circ> = x * 1\<^sup>\<circ>"
    by (meson circ_back_loop_prefixpoint le_iff_sup sup.boundedE)
  thus ?thesis
    using 1 by (simp add: le_iff_sup one_circ_mult_split sup_assoc sup_commute)
qed

lemma sub_mult_one_circ_split:
  "x * 1\<^sup>\<circ> \<le> x \<squnion> L"
  by (metis sup_commute one_circ_mult_split sub_mult_one_circ)

lemma sub_mult_one_circ_split_2:
  "x * 1\<^sup>\<circ> \<le> x \<squnion> 1\<^sup>\<circ>"
  by (metis L_def sup_right_isotone order_trans sub_mult_one_circ_split zero_right_mult_decreasing)

lemma L_split:
  "x * L \<le> x * bot \<squnion> L"
  by (metis L_split_sup sup_monoid.add_0_left)

lemma L_left_zero:
  "L * x = L"
  by (metis L_def mult_assoc mult_left_zero)

lemma one_circ_L:
  "1\<^sup>\<circ> * L = L"
  by (metis L_def circ_transitive_equal mult_assoc)

lemma mult_L_circ:
  "(x * L)\<^sup>\<circ> = 1 \<squnion> x * L"
  by (metis L_left_zero circ_left_unfold mult_assoc)

lemma mult_L_circ_mult:
  "(x * L)\<^sup>\<circ> * y = y \<squnion> x * L"
  by (metis L_left_zero mult_L_circ mult_assoc mult_1_left mult_right_dist_sup)

lemma circ_L:
  "L\<^sup>\<circ> = L \<squnion> 1"
  by (metis L_left_zero sup_commute circ_left_unfold)

lemma L_below_one_circ:
  "L \<le> 1\<^sup>\<circ>"
  by (metis L_def zero_right_mult_decreasing)

lemma circ_circ_mult_1:
  "x\<^sup>\<circ> * 1\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>"
  by (metis L_left_zero sup_commute circ_sup_1 circ_circ_sup mult_zero_circ one_circ_split)

lemma circ_circ_mult:
  "1\<^sup>\<circ> * x\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>"
  by (metis order.antisym circ_circ_mult_1 circ_circ_sub_mult sub_mult_one_circ)

lemma circ_circ_split:
  "x\<^sup>\<circ>\<^sup>\<circ> = L \<squnion> x\<^sup>\<circ>"
  by (metis circ_circ_mult one_circ_mult_split)

lemma circ_sup_6:
  "L \<squnion> (x \<squnion> y)\<^sup>\<circ> = (x\<^sup>\<circ> * y\<^sup>\<circ>)\<^sup>\<circ>"
  by (metis sup_assoc sup_commute circ_sup_1 circ_circ_sup circ_circ_split circ_decompose_4)

end

class itering_L = itering + L +
  assumes L_def: "L = 1\<^sup>\<circ> * bot"
begin

lemma one_circ_split:
  "1\<^sup>\<circ> = L \<squnion> 1"
  by (metis L_def sup_commute order.antisym circ_sup_upper_bound circ_reflexive circ_simulate_absorb mult_1_right order_refl zero_right_mult_decreasing)

lemma one_circ_mult_split:
  "1\<^sup>\<circ> * x = L \<squnion> x"
  by (metis L_def sup_commute circ_loop_fixpoint mult_assoc mult_left_zero mult_zero_circ one_circ_split)

lemma sub_mult_one_circ_split:
  "x * 1\<^sup>\<circ> \<le> x \<squnion> L"
  by (metis sup_commute one_circ_mult_split sub_mult_one_circ)

lemma sub_mult_one_circ_split_2:
  "x * 1\<^sup>\<circ> \<le> x \<squnion> 1\<^sup>\<circ>"
  by (metis L_def sup_right_isotone order_trans sub_mult_one_circ_split zero_right_mult_decreasing)

lemma L_split:
  "x * L \<le> x * bot \<squnion> L"
  by (metis L_def mult_assoc mult_left_isotone mult_right_dist_sup sub_mult_one_circ_split_2)

subclass left_conway_semiring_L
  apply unfold_locales
  apply (metis L_def sup_commute circ_loop_fixpoint mult_assoc mult_left_zero mult_zero_circ one_circ_split)
  by (metis sup_commute mult_assoc mult_left_isotone one_circ_mult_split sub_mult_one_circ)

lemma circ_left_induct_mult_L:
  "L \<le> x \<Longrightarrow> x * y \<le> x \<Longrightarrow> x * y\<^sup>\<circ> \<le> x"
  by (metis circ_one circ_simulate le_iff_sup one_circ_mult_split)

lemma circ_left_induct_mult_iff_L:
  "L \<le> x \<Longrightarrow> x * y \<le> x \<longleftrightarrow> x * y\<^sup>\<circ> \<le> x"
  by (metis sup.bounded_iff circ_back_loop_fixpoint circ_left_induct_mult_L le_iff_sup)

lemma circ_left_induct_L:
  "L \<le> x \<Longrightarrow> x * y \<squnion> z \<le> x \<Longrightarrow> z * y\<^sup>\<circ> \<le> x"
  by (metis sup.bounded_iff circ_left_induct_mult_L le_iff_sup mult_right_dist_sup)

end

end


header {* Euclidean Space: Executability *}
theory Executable_Euclidean_Space
imports
  "~~/src/HOL/Multivariate_Analysis/Multivariate_Analysis"
  Float_Real
begin

subsection {* Ordered representation of Basis and Rounding of Components *}

class executable_euclidean_space = ordered_euclidean_space +
  fixes Basis_list eucl_down eucl_truncate_down eucl_truncate_up
  assumes eucl_down_def:
    "eucl_down p b = (\<Sum>i \<in> Basis. round_down p (b \<bullet> i) *\<^sub>R i)"
  assumes eucl_truncate_down_def:
    "eucl_truncate_down q b = (\<Sum>i \<in> Basis. truncate_down q (b \<bullet> i) *\<^sub>R i)"
  assumes eucl_truncate_up_def:
    "eucl_truncate_up q b = (\<Sum>i \<in> Basis. truncate_up q (b \<bullet> i) *\<^sub>R i)"
  assumes Basis_list[simp]: "set Basis_list = Basis"
  assumes distinct_Basis_list[simp]: "distinct Basis_list"
begin

lemma length_Basis_list:
  "length Basis_list = card Basis"
  by (metis Basis_list distinct_Basis_list distinct_card)

end

lemma eucl_truncate_down_zero[simp]: "eucl_truncate_down p 0 = 0"
  by (auto simp: eucl_truncate_down_def truncate_down_zero)

lemma eucl_truncate_up_zero[simp]: "eucl_truncate_up p 0 = 0"
  by (auto simp: eucl_truncate_up_def)

subsection {* Instantiations *}

instantiation real::executable_euclidean_space
begin

definition Basis_list_real :: "real list" where
  "Basis_list_real = [1]"

definition "eucl_down prec b = round_down prec b"
definition "eucl_truncate_down prec b = truncate_down prec b"
definition "eucl_truncate_up prec b = truncate_up prec b"

instance proof qed (auto simp: Basis_list_real_def eucl_down_real_def eucl_truncate_down_real_def
  eucl_truncate_up_real_def)

end

instantiation prod::(executable_euclidean_space, executable_euclidean_space) executable_euclidean_space
begin

definition Basis_list_prod :: "('a \<times> 'b) list" where
  "Basis_list_prod = zip Basis_list (replicate (length (Basis_list::'a list)) 0) @ zip (replicate (length (Basis_list::'b list)) 0) Basis_list"

definition "eucl_down p a = (eucl_down p (fst a), eucl_down p (snd a))"
definition "eucl_truncate_down p a = (eucl_truncate_down p (fst a), eucl_truncate_down p (snd a))"
definition "eucl_truncate_up p a = (eucl_truncate_up p (fst a), eucl_truncate_up p (snd a))"

instance
proof
  show "set Basis_list = (Basis::('a*'b) set)"
    by (auto simp: Basis_list_prod_def Basis_prod_def elim!: in_set_zipE)
      (auto simp: Basis_list[symmetric] in_set_zip in_set_conv_nth simp del: Basis_list)
  show "distinct (Basis_list::('a*'b)list)"
    using distinct_Basis_list[where 'a='a] distinct_Basis_list[where 'a='b]
    by (auto simp: Basis_list_prod_def Basis_list intro: distinct_zipI1 distinct_zipI2
      elim!: in_set_zipE)
qed
  (auto simp: eucl_down_prod_def eucl_truncate_down_prod_def eucl_truncate_up_prod_def
    setsum_Basis_prod_eq inner_add_left inner_setsum_left inner_Basis eucl_down_def
    eucl_truncate_down_def eucl_truncate_up_def
    intro!: euclidean_eqI[where 'a="'a*'b"])

end

lemma eucl_truncate_down_Basis[simp]: "i \<in> Basis \<Longrightarrow> eucl_truncate_down e x \<bullet> i = truncate_down e (x \<bullet> i)"
  by (simp add: eucl_truncate_down_def)

lemma eucl_truncate_down_correct:
  "dist (x::'a::executable_euclidean_space) (eucl_down e x) \<in> {0..sqrt (DIM('a)) * 2 powr real (- e)}"
proof -
  have "dist x (eucl_down e x) = sqrt (\<Sum>i\<in>Basis. (dist (x \<bullet> i) (eucl_down e x \<bullet> i))\<^sup>2)"
    unfolding euclidean_dist_l2[where 'a='a] setL2_def ..
  also have "\<dots> \<le> sqrt (\<Sum>i\<in>(Basis::'a set). ((2 powr real (- e))\<^sup>2))"
    by (intro real_sqrt_le_mono setsum_mono power_mono)
      (auto simp: dist_real_def eucl_down_def abs_round_down_le simp del: real_of_int_minus)
  finally show ?thesis
    by (simp add: real_sqrt_mult real_of_nat_def)
qed

lemma eucl_down: "eucl_down e (x::'a::executable_euclidean_space) \<le> x"
  by (auto simp add: eucl_le[where 'a='a] round_down eucl_down_def)

lemma eucl_truncate_down: "eucl_truncate_down e (x::'a::executable_euclidean_space) \<le> x"
  by (auto simp add: eucl_le[where 'a='a] truncate_down)

lemma eucl_truncate_down_le: "x \<le> y \<Longrightarrow> eucl_truncate_down w x \<le> (y::'a::executable_euclidean_space)"
  using eucl_truncate_down
  by (rule order.trans)

lemma eucl_truncate_up_Basis[simp]: "i \<in> Basis \<Longrightarrow> eucl_truncate_up e x \<bullet> i = truncate_up e (x \<bullet> i)"
  by (simp add: eucl_truncate_up_def truncate_up_def)

lemma eucl_truncate_up: "x \<le> eucl_truncate_up e (x::'a::executable_euclidean_space)"
  by (auto simp add: eucl_le[where 'a='a] round_up truncate_up_def)

lemma eucl_truncate_up_le: "x \<le> y \<Longrightarrow> x \<le> eucl_truncate_up e (y::'a::executable_euclidean_space)"
  using _ eucl_truncate_up
  by (rule order.trans)

lemma eucl_truncate_down_mono:
  fixes x::"'a::executable_euclidean_space"
  shows "x \<le> y \<Longrightarrow> eucl_truncate_down p x \<le> eucl_truncate_down p y"
  by (auto simp: eucl_le[where 'a='a] intro!: truncate_down_mono)

lemma eucl_truncate_up_mono:
  fixes x::"'a::executable_euclidean_space"
  shows "x \<le> y \<Longrightarrow> eucl_truncate_up p x \<le> eucl_truncate_up p y"
  by (auto simp: eucl_le[where 'a='a] intro!: truncate_up_mono)

lemma infnorm[code]:
  fixes x::"'a::executable_euclidean_space"
  shows "infnorm x = fold max (map (\<lambda>i. abs (x \<bullet> i)) Basis_list) 0"
  by (auto simp: Max.set_eq_fold[symmetric] infnorm_Max[symmetric] infnorm_pos_le
    intro!: max.absorb2[symmetric])

declare Inf_real_def[code del]
declare Sup_real_def[code del]
declare Inf_prod_def[code del]
declare Sup_prod_def[code del]
declare [[code abort: "Inf::real set \<Rightarrow> real"]]
declare [[code abort: "Sup::real set \<Rightarrow> real"]]
declare [[code abort: "Inf::('a::Inf * 'b::Inf) set \<Rightarrow> 'a * 'b"]]
declare [[code abort: "Sup::('a::Sup * 'b::Sup) set \<Rightarrow> 'a * 'b"]]

end


(* Author: Gerwin Klein, 2012
   Maintainers: Gerwin Klein <kleing at cse.unsw.edu.au>
                Rafal Kolanski <rafal.kolanski at nicta.com.au>
*)

header "Equivalence between Separation Algebra Formulations"

theory Sep_Eq
imports Separation_Algebra Separation_Algebra_Alt
begin

text {*
  In this theory we show that our total formulation of separation algebra is
  equivalent in strength to Calcagno et al's original partial one.

  This theory is not intended to be included in own developments.
*}

no_notation map_add (infixl "++" 100)

section "Total implies Partial"

definition add2 :: "'a::sep_algebra => 'a => 'a option" where
  "add2 x y \<equiv> if x ## y then Some (x + y) else None"

lemma add2_zero: "add2 x 0 = Some x"
  by (simp add: add2_def)

lemma add2_assoc:
  "lift2 add2 a (lift2 add2 b c) = lift2 add2 (lift2 add2 a b) c"
  by (auto simp: add2_def lift2_def sep_add_assoc
              dest: sep_disj_addD sep_disj_addI3
                    sep_add_disjD sep_disj_addI2 sep_disj_commuteI
              split: option.splits)

interpretation total_partial: sep_algebra_alt 0 add2
  by (unfold_locales) (auto intro: add2_zero add2_comm add2_assoc)

section "Partial implies Total"

definition
  sep_add' :: "'a \<Rightarrow> 'a \<Rightarrow> 'a :: sep_algebra_alt" where
  "sep_add' x y \<equiv> if disjoint x y then the (add x y) else undefined"

lemma sep_disj_zero':
  "disjoint x 0"
  by simp

lemma sep_disj_commuteI':
  "disjoint x y \<Longrightarrow> disjoint y x"
  by (clarsimp simp: disjoint_def add_comm)

lemma sep_add_zero':
  "sep_add' x 0 = x"
  by (simp add: sep_add'_def)

lemma sep_add_commute':
  "disjoint x y \<Longrightarrow> sep_add' x y = sep_add' y x"
  by (clarsimp simp: sep_add'_def disjoint_def add_comm)

lemma sep_add_assoc':
  "\<lbrakk> disjoint x y; disjoint y z; disjoint x z \<rbrakk> \<Longrightarrow>
  sep_add' (sep_add' x y) z = sep_add' x (sep_add' y z)"
  using add_assoc [of "Some x" "Some y" "Some z"]
  by (clarsimp simp: disjoint_def sep_add'_def lift2_def
               split: option.splits)

lemma sep_disj_addD1':
  "disjoint x (sep_add' y z) \<Longrightarrow> disjoint y z \<Longrightarrow> disjoint x y"
proof (clarsimp simp: disjoint_def sep_add'_def)
  fix a assume a: "y \<oplus> z = Some a"
  fix b assume b: "x \<oplus> a = Some b"
  with a have "Some x ++ (Some y ++ Some z) = Some b" by (simp add: lift2_def)
  hence "(Some x ++ Some y) ++ Some z = Some b" by (simp add: add_assoc)
  thus "\<exists>b. x \<oplus> y = Some b" by (simp add: lift2_def split: option.splits)
qed

lemma sep_disj_addI1':
  "disjoint x (sep_add' y z) \<Longrightarrow> disjoint y z \<Longrightarrow> disjoint (sep_add' x y) z"
  apply (clarsimp simp: disjoint_def sep_add'_def)
  apply (rule conjI)
   apply clarsimp
   apply (frule lift_to_add2, assumption)
   apply (simp add: add_assoc)
   apply (clarsimp simp: lift2_def add_comm)
  apply clarsimp
  apply (frule lift_to_add2, assumption)
  apply (simp add: add_assoc)
  apply (clarsimp simp: lift2_def)
  done

interpretation partial_total: sep_algebra sep_add' 0 disjoint
  apply (unfold_locales)
        apply (rule sep_disj_zero')
       apply (erule sep_disj_commuteI')
      apply (rule sep_add_zero')
     apply (erule sep_add_commute')
    apply (erule (2) sep_add_assoc')
   apply (erule (1) sep_disj_addD1')
  apply (erule (1) sep_disj_addI1')
  done

end


subsubsection\<open>Soundness, Completeness\<close>

theory SC_Sema
imports SC Sema
begin

definition sequent_semantics :: "'a valuation \<Rightarrow> 'a formula multiset \<Rightarrow> 'a formula multiset \<Rightarrow> bool" ("(_ \<Turnstile> (_ \<Rightarrow>/ _))" [53, 53,53] 53) where
"\<A> \<Turnstile> \<Gamma> \<Rightarrow> \<Delta> \<equiv> (\<forall>\<gamma> \<in># \<Gamma>. \<A> \<Turnstile> \<gamma>) \<longrightarrow> (\<exists>\<delta> \<in># \<Delta>. \<A> \<Turnstile> \<delta>)"
abbreviation sequent_valid :: "'a formula multiset \<Rightarrow> 'a formula multiset \<Rightarrow> bool" ("(\<Turnstile> (_ \<Rightarrow>/ _))" [53,53] 53) where
"\<Turnstile> \<Gamma> \<Rightarrow> \<Delta> \<equiv> \<forall>A. A \<Turnstile> \<Gamma> \<Rightarrow> \<Delta>"
abbreviation sequent_nonvalid :: "'a valuation \<Rightarrow> 'a formula multiset \<Rightarrow> 'a formula multiset \<Rightarrow> bool" ("(_ \<not>\<Turnstile> (_ \<Rightarrow>/ _))" [53, 53,53] 53) where
"\<A> \<not>\<Turnstile> \<Gamma> \<Rightarrow> \<Delta> \<equiv> \<not>\<A>\<Turnstile> \<Gamma> \<Rightarrow> \<Delta>"

lemma sequent_intuitonistic_semantics: "\<Turnstile> \<Gamma> \<Rightarrow> {#\<delta>#} \<longleftrightarrow> set_mset \<Gamma> \<TTurnstile> \<delta>"
  unfolding sequent_semantics_def entailment_def by simp

lemma SC_soundness: "\<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> \<Turnstile> \<Gamma> \<Rightarrow> \<Delta>"
  by(induction rule: SCp.induct) (auto simp add: sequent_semantics_def)

definition "sequent_cost \<Gamma> \<Delta> = Suc (sum_list (sorted_list_of_multiset (image_mset size (\<Gamma> + \<Delta>))))"

function(sequential)
  sc :: "'a formula list \<Rightarrow> 'a list \<Rightarrow> 'a formula list \<Rightarrow> 'a list \<Rightarrow> ('a list \<times> 'a list) set" where
"sc (\<bottom> # \<Gamma>) A \<Delta> B = {}" |
"sc [] A [] B = (if set A \<inter> set B = {} then {(remdups A,remdups B)} else {})" |
"sc (Atom k # \<Gamma>) A  \<Delta> B = sc \<Gamma> (k#A) \<Delta> B" |
"sc (Not F # \<Gamma>) A \<Delta> B = sc \<Gamma> A (F#\<Delta>) B" |
"sc (And F G # \<Gamma>) A \<Delta> B = sc (F#G#\<Gamma>) A \<Delta> B" |
"sc (Or F G # \<Gamma>) A \<Delta> B = sc (F#\<Gamma>) A \<Delta> B \<union> sc (G#\<Gamma>) A \<Delta> B" |
"sc (Imp F G # \<Gamma>) A \<Delta> B = sc \<Gamma> A (F#\<Delta>) B \<union> sc (G#\<Gamma>) A \<Delta> B" |
"sc \<Gamma> A (\<bottom>#\<Delta>) B = sc \<Gamma> A \<Delta> B" |
"sc \<Gamma> A (Atom k # \<Delta>) B = sc \<Gamma> A \<Delta> (k#B)" |
"sc \<Gamma> A (Not F # \<Delta>) B = sc (F#\<Gamma>) A \<Delta> B" |
"sc \<Gamma> A (And F G # \<Delta>) B = sc \<Gamma> A (F#\<Delta>) B \<union> sc \<Gamma> A (G#\<Delta>) B" |
"sc \<Gamma> A (Or F G # \<Delta>) B = sc \<Gamma> A (F#G#\<Delta>) B" |
"sc \<Gamma> A (Imp F G # \<Delta>) B = sc (F#\<Gamma>) A (G#\<Delta>) B"
  by pat_completeness auto
(* Paremeters 2 and 4:
   atoms are stored in lists, not sets, simply because lists are automatically finite;
   finiteness is required when we relate back to sequents, which are finite. *)

definition "list_sequent_cost \<Gamma> \<Delta> = 2*sum_list (map size (\<Gamma>@\<Delta>)) + length (\<Gamma>@\<Delta>)"
termination sc by (relation "measure (\<lambda>(\<Gamma>,A,\<Delta>,B). list_sequent_cost \<Gamma> \<Delta>)") (simp_all add: list_sequent_cost_def)

lemma "sc [] [] [((Atom 0 \<^bold>\<rightarrow> Atom 1) \<^bold>\<rightarrow> Atom 0) \<^bold>\<rightarrow> Atom 1] [] = {([0], [1 :: nat])}"
  (* An atom may appear twice in one of the lists, but that is of no concern.
     Using sets for the atoms stands in the way of automation. *)
by code_simp

lemma sc_sim:
  fixes \<Gamma> \<Delta> :: "'a formula list" and G D :: "'a list"
  assumes "sc \<Gamma> A \<Delta> B = {}"
  shows "image_mset Atom (mset A) + mset \<Gamma> \<Rightarrow> image_mset Atom (mset B) + mset \<Delta>"
proof -
  have *[simp]: "image_mset Atom (mset A) \<Rightarrow> image_mset Atom (mset B)" (is ?k) if "k \<in> set A" "k \<in> set B" for A B :: "'a list" and k
  proof -
    from that obtain a where "a \<in> set A" "a \<in> set B" by blast
    thus ?k by(force simp: in_image_mset intro: SCp.Ax[where k=a])
  qed
  from assms show ?thesis
    by(induction rule: sc.induct[where 'a='a]) (auto
        simp add: list_sequent_cost_def add.assoc Bot_delR_simp
        split: if_splits option.splits
        intro: SCp.intros(3-))
qed

lemma scc_ce_distinct:
  "(C,E) \<in> sc \<Gamma> G \<Delta> D \<Longrightarrow> set C \<inter> set E = {}"
by(induction \<Gamma> G \<Delta> D arbitrary: C E rule: sc.induct)
  (fastforce split: if_splits)+

text\<open>Completeness set aside, this is an interesting fact on the side: Sequent Calculus can provide counterexamples.\<close>
theorem SC_counterexample:
  "(C,D) \<in> sc \<Gamma> A \<Delta> B \<Longrightarrow>
  (\<lambda>a. a \<in> set C) \<not>\<Turnstile> image_mset Atom (mset A) + mset \<Gamma> \<Rightarrow> image_mset Atom (mset B) + mset \<Delta>"
by(induction rule: sc.induct[where 'a='a];
   simp add: sequent_semantics_def split: if_splits;
   (* used to be only for one, now it's four\<dots> *) blast)

corollary SC_counterexample':
  assumes "(C,D) \<in> sc \<Gamma> [] \<Delta> []"
  shows "(\<lambda>k. k \<in> set C) \<not>\<Turnstile> mset \<Gamma> \<Rightarrow> mset \<Delta>"
using SC_counterexample[OF assms] by simp

theorem SC_sound_complete: "\<Gamma> \<Rightarrow> \<Delta> \<longleftrightarrow> \<Turnstile> \<Gamma> \<Rightarrow> \<Delta>"
proof
  assume "\<Gamma> \<Rightarrow> \<Delta>" thus "\<Turnstile> \<Gamma> \<Rightarrow> \<Delta>" using SC_soundness by blast
next
  obtain \<Gamma>' \<Delta>' where [simp]: "\<Gamma> = mset  \<Gamma>'" "\<Delta> = mset \<Delta>'" by (metis ex_mset)
  assume "\<Turnstile> \<Gamma> \<Rightarrow> \<Delta>"
  hence "sc \<Gamma>' [] \<Delta>' [] = {}"
  proof(rule contrapos_pp)
    assume "sc \<Gamma>' [] \<Delta>' [] \<noteq> {}"
    then obtain C E where "(C,E) \<in> sc \<Gamma>' [] \<Delta>' []" by fast
    thus "\<not> \<Turnstile> \<Gamma> \<Rightarrow> \<Delta>" using SC_counterexample' by fastforce
  qed
  from sc_sim[OF this] show "\<Gamma> \<Rightarrow> \<Delta>" by auto
qed

theorem "\<Turnstile> \<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta>"
proof -
  assume s: "\<Turnstile> \<Gamma> \<Rightarrow> \<Delta>"
  obtain \<Gamma>' \<Delta>' where p: "\<Gamma> = mset \<Gamma>'" "\<Delta> = mset \<Delta>'" by (metis ex_mset)
  have "mset \<Gamma>' \<Rightarrow> mset \<Delta>'"
  proof cases \<comment> \<open>just to show that we didn't need to show the lemma above by contraposition. It's just quicker to do so.\<close>
    assume "sc \<Gamma>' [] \<Delta>' [] = {}"
    from sc_sim[OF this] show "mset \<Gamma>' \<Rightarrow> mset \<Delta>'" by auto
  next
    assume "sc \<Gamma>' [] \<Delta>' [] \<noteq> {}"
    with SC_counterexample have "\<not> \<Turnstile> mset \<Gamma>' \<Rightarrow> mset \<Delta>'" by fastforce
    moreover note s[unfolded p]
    ultimately have False ..
    thus "mset \<Gamma>' \<Rightarrow> mset \<Delta>'" ..
  qed
  thus ?thesis unfolding p .
qed

(*
Just as a side-note: some textbooks advertise completeness as a consequence of cut elimination.
This only makes sense if you have a cut-rule in the rules of SC to begin with.
But even if we did, this proof of completeness would not change a bit.
So\<dots> huh.
*)

end


section {* Types of cardinality 2 or greater *}

theory Two
imports Real
begin

class two =
  assumes card_two: "infinite (UNIV :: 'a set) \<or> card (UNIV :: 'a set) \<ge> 2"
begin
lemma two_diff: "\<exists> x y :: 'a. x \<noteq> y"
proof -
  obtain A where "finite A" "card A = 2" "A \<subseteq> (UNIV :: 'a set)"
  proof (cases "infinite (UNIV :: 'a set)")
    case True
    with infinite_arbitrarily_large[of "UNIV :: 'a set" 2] that
    show ?thesis by auto
  next
    case False
    with card_two that
    show ?thesis
      by (metis UNIV_bool card_UNIV_bool card_image card_le_inj finite.intros(1) finite_insert finite_subset)
  qed
  thus ?thesis
    by (metis (full_types) One_nat_def Suc_1 UNIV_eq_I card.empty card.insert finite.intros(1) insertCI nat.inject nat.simps(3))
qed
end

instance bool :: two
  by (intro_classes, auto)

instance nat :: two
  by (intro_classes, auto)

instance int :: two
  by (intro_classes, auto simp add: infinite_UNIV_int)

instance rat :: two
  by (intro_classes, auto simp add: infinite_UNIV_char_0)

instance real :: two
  by (intro_classes, auto simp add: infinite_UNIV_char_0)

instance list :: (type) two
  by (intro_classes, auto simp add: infinite_UNIV_listI)

end


section \<open>Some preliminaries on equivalence relations and quotients\<close>

theory Equiv_Relation2 imports Preliminaries Pick
begin

text\<open>Unary predicates vs. sets:\<close>

definition "S2P A \<equiv> \<lambda> x. x \<in> A"

lemma S2P_app[simp]: "S2P r x \<longleftrightarrow> x \<in> r"
unfolding S2P_def by auto

lemma S2P_Collect[simp]: "S2P (Collect \<phi>) = \<phi>"
apply(rule ext)+ by simp

lemma Collect_S2P[simp]: "Collect (S2P r) = r"
by (metis Collect_mem_eq S2P_Collect)

text\<open>Binary predicates vs. relatipons:\<close>
definition "P2R \<phi> \<equiv> {(x,y). \<phi> x y}"
definition "R2P r \<equiv> \<lambda> x y. (x,y) \<in> r"

lemma in_P2R[simp]: "xy \<in> P2R \<phi> \<longleftrightarrow> \<phi> (fst xy) (snd xy)"
unfolding P2R_def by auto

lemma in_P2R_pair[simp]: "(x,y) \<in> P2R \<phi> \<longleftrightarrow> \<phi> x y"
by simp

lemma R2P_app[simp]: "R2P r x y \<longleftrightarrow> (x,y) \<in> r"
unfolding R2P_def by auto

lemma R2P_P2R[simp]: "R2P (P2R \<phi>) = \<phi>"
apply(rule ext)+ by simp

lemma P2R_R2P[simp]: "P2R (R2P r) = r"
using Collect_mem_eq P2R_def R2P_P2R  case_prod_curry by metis

definition "reflP P \<phi> \<equiv> (\<forall> x y. \<phi> x y \<or> \<phi> y x \<longrightarrow> P x) \<and> (\<forall> x. P x \<longrightarrow> \<phi> x x)"
definition "symP \<phi> \<equiv> \<forall> x y. \<phi> x y \<longrightarrow> \<phi> y x"
definition transP where "transP \<phi> \<equiv> \<forall> x y z. \<phi> x y \<and> \<phi> y z \<longrightarrow> \<phi> x z"
definition "equivP A \<phi> \<equiv> reflP A \<phi> \<and> symP \<phi> \<and> transP \<phi>"

lemma refl_on_P2R[simp]: "refl_on (Collect P) (P2R \<phi>) \<longleftrightarrow> reflP P \<phi>"
unfolding reflP_def refl_on_def by force

lemma reflP_R2P[simp]: "reflP (S2P A) (R2P r) \<longleftrightarrow> refl_on A r"
unfolding reflP_def refl_on_def by auto

lemma sym_P2R[simp]: "sym (P2R \<phi>) \<longleftrightarrow> symP \<phi>"
unfolding symP_def sym_def by auto

lemma symP_R2P[simp]: "symP (R2P r) \<longleftrightarrow> sym r"
unfolding symP_def sym_def by auto

lemma trans_P2R[simp]: "trans (P2R \<phi>) \<longleftrightarrow> transP \<phi>"
unfolding transP_def trans_def by auto

lemma transP_R2P[simp]: "transP (R2P r) \<longleftrightarrow> trans r"
unfolding transP_def trans_def by auto

lemma equiv_P2R[simp]: "equiv (Collect P) (P2R \<phi>) \<longleftrightarrow> equivP P \<phi>"
unfolding equivP_def equiv_def by auto

lemma equivP_R2P[simp]: "equivP (S2P A) (R2P r) \<longleftrightarrow> equiv A r"
unfolding equivP_def equiv_def by auto

lemma in_P2R_Im_singl[simp]: "y \<in> P2R \<phi> `` {x} \<longleftrightarrow> \<phi> x y" by simp

definition proj :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a set" where
"proj \<phi> x \<equiv> {y. \<phi> x y}"

lemma proj_P2R: "proj \<phi> x = P2R \<phi> `` {x}" unfolding proj_def by auto

lemma proj_P2R_raw: "proj \<phi> = (\<lambda> x. P2R \<phi> `` {x})"
apply(rule ext) unfolding proj_P2R ..

definition univ :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a set \<Rightarrow> 'b)"
where "univ f X == f (SOME x. x \<in> X)"

definition quotientP ::
"('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a set \<Rightarrow> bool)"  (infixl "'/'/'/" 90)
where "P /// \<phi> \<equiv> S2P ((Collect P) // (P2R \<phi>))"

lemma proj_preserves:
"P x \<Longrightarrow> (P /// \<phi>) (proj \<phi> x)"
unfolding proj_P2R quotientP_def
by (metis S2P_def mem_Collect_eq quotientI)

lemma proj_in_iff:
assumes "equivP P \<phi>"
shows "(P///\<phi>) (proj \<phi> x)  \<longleftrightarrow> P x"
using assms unfolding quotientP_def proj_def
by (metis (mono_tags) Collect_mem_eq Equiv_Relation2.proj_def
  Equiv_Relation2.proj_preserves S2P_Collect empty_Collect_eq equivP_def
  equiv_P2R in_quotient_imp_non_empty quotientP_def reflP_def)

lemma proj_iff[simp]:
"\<lbrakk>equivP P \<phi>; P x; P y\<rbrakk> \<Longrightarrow> proj \<phi> x = proj \<phi> y \<longleftrightarrow> \<phi> x y"
unfolding proj_P2R
by (metis (full_types) equiv_P2R equiv_class_eq_iff equiv_class_self
          in_P2R_pair mem_Collect_eq proj_P2R proj_def)

lemma in_proj[simp]: "\<lbrakk>equivP P \<phi>; P x\<rbrakk> \<Longrightarrow> x \<in> proj \<phi> x"
unfolding proj_P2R equiv_def refl_on_def equiv_P2R[symmetric]
by auto

lemma proj_image[simp]: "(proj \<phi>) ` (Collect P) = Collect (P///\<phi>)"
unfolding proj_P2R_raw quotientP_def quotient_def by auto

lemma in_quotientP_imp_in_rel:
"\<lbrakk>equivP P \<phi>; (P///\<phi>) X; x \<in> X; y \<in> X\<rbrakk> \<Longrightarrow> \<phi> x y"
unfolding equiv_P2R[symmetric] quotientP_def quotient_eq_iff
by (metis S2P_def in_P2R_pair quotient_eq_iff)

lemma in_quotientP_imp_closed:
"\<lbrakk>equivP P \<phi>; (P///\<phi>) X; x \<in> X; \<phi> x y\<rbrakk> \<Longrightarrow> y \<in> X"
using S2P_Collect S2P_def equivP_def proj_P2R_raw proj_def
        quotientE quotientP_def transP_def
by metis

lemma in_quotientP_imp_subset:
assumes "equivP P \<phi>" and "(P///\<phi>) X"
shows "X \<subseteq> Collect P"
by (metis (mono_tags, lifting) CollectI assms equivP_def in_quotientP_imp_in_rel reflP_def subsetI)

lemma equivP_pick_in:
assumes  "equivP P \<phi> " and "(P///\<phi>) X"
shows "pick X \<in> X"
by (metis assms in_quotientP_imp_non_empty pick_NE)

lemma equivP_pick_preserves:
assumes  "equivP P \<phi> " and "(P///\<phi>) X"
shows "P (pick X)"
by (metis assms equivP_pick_in in_quotientP_imp_subset mem_Collect_eq set_rev_mp)

lemma proj_pick:
assumes \<phi>: "equivP P \<phi>" and X: "(P///\<phi>) X"
shows "proj \<phi> (pick X) = X"
by (smt proj_def Equiv_Relation2.proj_iff Equiv_Relation2.proj_image X
   \<phi> equivP_pick_in equivP_pick_preserves image_iff mem_Collect_eq)

lemma pick_proj:
assumes "equivP P \<phi>" and "P x"
shows "\<phi> (pick (proj \<phi> x)) x"
by (metis assms equivP_def in_proj mem_Collect_eq pick proj_def symP_def)

lemma equivP_pick_iff[simp]:
assumes \<phi>: "equivP P \<phi>" and X: "(P///\<phi>) X" and Y: "(P///\<phi>) Y"
shows "\<phi> (pick X) (pick Y) \<longleftrightarrow> X = Y"
by (metis Equiv_Relation2.proj_iff X Y \<phi> equivP_pick_preserves proj_pick)

lemma equivP_pick_inj_on:
assumes "equivP P \<phi>"
shows "inj_on pick (Collect (P///\<phi>))"
using assms unfolding inj_on_def
by (metis assms equivP_pick_iff mem_Collect_eq)

definition congruentP where
"congruentP \<phi> f \<equiv> \<forall> x y. \<phi> x y \<longrightarrow> f x = f y"

abbreviation RESPECTS_P (infixr "respectsP" 80) where
"f respectsP r == congruentP r f"

lemma congruent_P2R: "congruent (P2R \<phi>) f = congruentP \<phi> f"
unfolding congruent_def congruentP_def by auto

lemma univ_commute[simp]:
assumes "equivP P \<phi>" and "f respectsP \<phi>" and "P x"
shows "(univ f) (proj \<phi> x) = f x"
unfolding congruent_P2R[symmetric]
by (metis (full_types) assms pick_def congruentP_def pick_proj univ_def)

lemma univ_unique:
assumes "equivP P \<phi>" and "f respectsP \<phi>" and "\<And> x. P x \<Longrightarrow> G (proj \<phi> x) = f x"
shows "\<forall> X. (P///\<phi>) X \<longrightarrow> G X = univ f X"
by (metis assms equivP_pick_preserves proj_pick univ_commute)

lemma univ_preserves:
assumes "equivP P \<phi> " and "f respectsP \<phi>" and "\<And> x. P x \<Longrightarrow> f x \<in> B"
shows "\<forall> X. (P///\<phi>) X \<longrightarrow> univ f X \<in> B"
by (metis Equiv_Relation2.univ_commute assms
          equivP_pick_preserves proj_pick)

end


header {* Bounded Continuous Functions *}
theory Bounded_Continuous_Function
imports "../ODE_Auxiliarities"
begin

text{*\label{sec:bcontfun}*}

subsection{* Definition *}

definition "bcontfun = {f :: 'a::topological_space \<Rightarrow> 'b::metric_space. continuous_on UNIV f \<and> bounded (range f)}"

typedef ('a, 'b) bcontfun =
    "bcontfun :: ('a::topological_space \<Rightarrow> 'b::metric_space) set"
  by (auto simp: bcontfun_def intro: continuous_intros simp: bounded_def)

lemma bcontfunE:
  assumes "f \<in> bcontfun"
  obtains y where "continuous_on UNIV f" "\<And>x. dist (f x) u \<le> y"
  using assms unfolding bcontfun_def
  by (metis (lifting) bounded_any_center dist_commute mem_Collect_eq rangeI)

lemma bcontfunE':
  assumes "f \<in> bcontfun"
  obtains y where "continuous_on UNIV f" "\<And>x. dist (f x) undefined \<le> y"
  using assms bcontfunE
  by metis

lemma bcontfunI:
  "continuous_on UNIV f \<Longrightarrow> (\<And>x. dist (f x) u \<le> b) \<Longrightarrow> f \<in> bcontfun"
  unfolding bcontfun_def
  by (metis (lifting, no_types) bounded_def dist_commute mem_Collect_eq rangeE)

lemma bcontfunI':
  "continuous_on UNIV f \<Longrightarrow> (\<And>x. dist (f x) undefined \<le> b) \<Longrightarrow> f \<in> bcontfun"
  using bcontfunI by metis

lemma continuous_on_Rep_bcontfun[intro, simp]: "continuous_on T (Rep_bcontfun x)"
  using Rep_bcontfun[of x]
  by (auto simp: bcontfun_def intro: continuous_on_subset)

instantiation bcontfun :: (topological_space, metric_space) metric_space
begin

definition dist_bcontfun::"('a, 'b) bcontfun \<Rightarrow> ('a, 'b) bcontfun \<Rightarrow> real" where
  "dist_bcontfun f g = (SUP x. dist (Rep_bcontfun f x) (Rep_bcontfun g x))"

definition
  open_bcontfun::"('a, 'b) bcontfun set \<Rightarrow> bool" where
  "open_bcontfun S = (\<forall>x\<in>S. \<exists>e>0. \<forall>y. dist y x < e \<longrightarrow> y \<in> S)"

lemma dist_bounded:
  fixes f ::"('a, 'b) bcontfun"
  shows "dist (Rep_bcontfun f x) (Rep_bcontfun g x) \<le> dist f g"
proof -
  have "Rep_bcontfun f \<in> bcontfun" using Rep_bcontfun .
  from bcontfunE'[OF this] obtain y where y:
    "continuous_on UNIV (Rep_bcontfun f)"
    "\<And>x. dist (Rep_bcontfun f x) undefined \<le> y"
    by auto
  have "Rep_bcontfun g \<in> bcontfun" using Rep_bcontfun .
  from bcontfunE'[OF this] obtain z where z:
    "continuous_on UNIV (Rep_bcontfun g)"
    "\<And>x. dist (Rep_bcontfun g x) undefined \<le> z"
    by auto
  show ?thesis unfolding dist_bcontfun_def
  proof (intro cSUP_upper bdd_aboveI2)
    fix x
    have "dist (Rep_bcontfun f x) (Rep_bcontfun g x) \<le> dist (Rep_bcontfun f x) undefined + dist (Rep_bcontfun g x) undefined"
      by (rule dist_triangle2)
    also have "\<dots> \<le> y + z" using y(2)[of x] z(2)[of x] by (rule add_mono)
    finally show "dist (Rep_bcontfun f x) (Rep_bcontfun g x) \<le> y + z" .
  qed simp
qed

lemma dist_bound:
  fixes f ::"('a, 'b) bcontfun"
  assumes "\<And>x. dist (Rep_bcontfun f x) (Rep_bcontfun g x) \<le> b"
  shows "dist f g \<le> b"
  using assms by (auto simp: dist_bcontfun_def intro: cSUP_least)

lemma dist_bounded_Abs:
  fixes f g ::"'a \<Rightarrow> 'b"
  assumes "f \<in> bcontfun" "g \<in> bcontfun"
  shows "dist (f x) (g x) \<le> dist (Abs_bcontfun f) (Abs_bcontfun g)"
  by (metis Abs_bcontfun_inverse assms dist_bounded)

lemma const_bcontfun: "(\<lambda>x::'a. b::'b) \<in> bcontfun"
  by (auto intro: bcontfunI continuous_on_const)

lemma dist_fun_lt_imp_dist_val_lt:
  assumes "dist f g < e"
  shows "dist (Rep_bcontfun f x) (Rep_bcontfun g x) < e"
  using dist_bounded assms by (rule le_less_trans)

lemma dist_val_lt_imp_dist_fun_le:
  assumes "\<forall>x. dist (Rep_bcontfun f x) (Rep_bcontfun g x) < e"
  shows "dist f g \<le> e"
unfolding dist_bcontfun_def
proof (intro cSUP_least)
  fix x
  show "dist (Rep_bcontfun f x) (Rep_bcontfun g x) \<le> e"
    using assms[THEN spec[where x=x]] by (simp add: dist_norm)
qed (simp)

instance
proof
  fix f g::"('a, 'b) bcontfun"
  show "dist f g = 0 \<longleftrightarrow> f = g"
  proof
    have "\<And>x. dist (Rep_bcontfun f x) (Rep_bcontfun g x) \<le> dist f g" by (rule dist_bounded)
    also assume "dist f g = 0"
    finally  show "f = g" by (auto simp: Rep_bcontfun_inject[symmetric] Abs_bcontfun_inverse)
  qed (auto simp: dist_bcontfun_def SUP_def simp del: Sup_image_eq intro!: cSup_eq)
next
  fix f g h :: "('a, 'b) bcontfun"
  show "dist f g \<le> dist f h + dist g h"
  proof (subst dist_bcontfun_def, safe intro!: cSUP_least)
    fix x
    have "dist (Rep_bcontfun f x) (Rep_bcontfun g x) \<le>
      dist (Rep_bcontfun f x) (Rep_bcontfun h x) + dist (Rep_bcontfun g x) (Rep_bcontfun h x)"
      by (rule dist_triangle2)
    also have "dist (Rep_bcontfun f x) (Rep_bcontfun h x) \<le> dist f h" by (rule dist_bounded)
    also have "dist (Rep_bcontfun g x) (Rep_bcontfun h x) \<le> dist g h" by (rule dist_bounded)
    finally show "dist (Rep_bcontfun f x) (Rep_bcontfun g x) \<le> dist f h + dist g h" by simp
  qed
qed (simp add: open_bcontfun_def)
end

lemma closed_Pi_bcontfun:
  fixes I::"'a::metric_space set" and X::"'a \<Rightarrow> 'b::complete_space set"
  assumes "\<And>i. i \<in> I \<Longrightarrow> closed (X i)"
  shows "closed (Abs_bcontfun ` (Pi I X \<inter> bcontfun))"
  unfolding closed_sequential_limits
proof safe
  fix f l
  assume seq: "\<forall>n. f n \<in> Abs_bcontfun ` (Pi I X \<inter> bcontfun)" and lim: "f ----> l"
  have lim_fun: "\<forall>e>0. \<exists>N. \<forall>n\<ge>N. \<forall>x. dist (Rep_bcontfun (f n) x) (Rep_bcontfun l x) < e"
    using LIMSEQ_imp_Cauchy[OF lim, simplified Cauchy_def] metric_LIMSEQ_D[OF lim]
    by (intro uniformly_cauchy_imp_uniformly_convergent[where P="%_. True", simplified])
      (metis dist_fun_lt_imp_dist_val_lt)+
  show "l \<in> Abs_bcontfun ` (Pi I X \<inter> bcontfun)"
  proof (rule, safe)
    fix x assume "x \<in> I"
    hence "closed (X x)" using assms by simp
    moreover have "eventually (\<lambda>xa. Rep_bcontfun (f xa) x \<in> X x) sequentially"
    proof (rule always_eventually, safe)
      fix i
      from seq[THEN spec, of i] `x \<in> I`
      show "Rep_bcontfun (f i) x \<in> X x"
        by (auto simp: Abs_bcontfun_inverse)
    qed
    moreover note sequentially_bot
    moreover have "(\<lambda>n. Rep_bcontfun (f n) x) ----> Rep_bcontfun l x"
      using lim_fun by (blast intro!: metric_LIMSEQ_I)
    ultimately show "Rep_bcontfun l x \<in> X x"
      by (rule Lim_in_closed_set)
  qed (auto simp: Rep_bcontfun Rep_bcontfun_inverse)
qed

subsection {* Complete Space *}

instance bcontfun :: (metric_space, complete_space) complete_space
proof
  fix f::"nat \<Rightarrow> ('a,'b) bcontfun"
  assume "Cauchy f" --{* Cauchy equals uniform convergence *}
  then obtain g where limit_function:
    "\<forall>e>0. \<exists>N. \<forall>n\<ge>N. \<forall>x. dist (Rep_bcontfun (f n) x) (g x) < e"
    using uniformly_convergent_eq_cauchy[of "\<lambda>_. True"
      "\<lambda>n. Rep_bcontfun (f n)"]
    unfolding Cauchy_def by (metis dist_fun_lt_imp_dist_val_lt)

  then obtain N where fg_dist: --{* for an upper bound on g *}
    "\<forall>n\<ge>N. \<forall>x. dist (g x) ( Rep_bcontfun (f n) x) < 1"
    by (force simp add: dist_commute)
  from bcontfunE'[OF Rep_bcontfun, of "f N"] obtain b where
    f_bound: "\<forall>x. dist (Rep_bcontfun (f N) x) undefined \<le> b" by force
  have "g \<in> bcontfun" --{* The limit function is bounded and continuous *}
  proof (intro bcontfunI)
    show "continuous_on UNIV g"
      using bcontfunE[OF Rep_bcontfun] limit_function
      by (intro continuous_uniform_limit[where
        f="%n. Rep_bcontfun (f n)" and F="sequentially"]) (auto
        simp add: eventually_sequentially trivial_limit_def dist_norm)
  next
    fix x
    from fg_dist have "dist (g x) (Rep_bcontfun (f N) x) < 1"
      by (simp add: dist_norm norm_minus_commute)
    with dist_triangle[of "g x" undefined "Rep_bcontfun (f N) x"]
    show "dist (g x) undefined \<le> 1 + b" using f_bound[THEN spec, of x]
      by simp
  qed
  show "convergent f"
  proof (rule convergentI, subst LIMSEQ_def, safe)
    --{* The limit function converges according to its norm *}
    fix e::real
    assume "e > 0" hence "e/2 > 0" by simp
    with limit_function[THEN spec, of"e/2"]
    have "\<exists>N. \<forall>n\<ge>N. \<forall>x. dist (Rep_bcontfun (f n) x) (g x) < e/2"
      by simp
    then obtain N where N: "\<forall>n\<ge>N. \<forall>x. dist (Rep_bcontfun (f n) x) (g x) < e / 2" by auto
    show "\<exists>N. \<forall>n\<ge>N. dist (f n) (Abs_bcontfun g) < e"
    proof (rule, safe)
      fix n
      assume "N \<le> n"
      with N show "dist (f n) (Abs_bcontfun g) < e"
        using dist_val_lt_imp_dist_fun_le[of
          "f n" "Abs_bcontfun g" "e/2"]
          Abs_bcontfun_inverse[OF `g \<in> bcontfun`] `e > 0` by simp
    qed
  qed
qed

subsection{* Supremum norm for a normed vector space *}

instantiation bcontfun :: (topological_space, real_normed_vector) real_vector
begin

definition "-f = Abs_bcontfun (\<lambda>x. -(Rep_bcontfun f x))"

definition "f + g = Abs_bcontfun (\<lambda>x. Rep_bcontfun f x + Rep_bcontfun g x)"

definition "f - g = Abs_bcontfun (\<lambda>x. Rep_bcontfun f x - Rep_bcontfun g x)"

definition "0 = Abs_bcontfun (\<lambda>x. 0)"

definition "scaleR r f = Abs_bcontfun (\<lambda>x. r *\<^sub>R Rep_bcontfun f x)"

lemma plus_cont:
  fixes f g ::"'a \<Rightarrow> 'b"
  assumes f: "f \<in> bcontfun" and g: "g \<in> bcontfun"
  shows "(\<lambda>x. f x + g x) \<in> bcontfun"
proof -
  from bcontfunE'[OF f] obtain y where "continuous_on UNIV f" "\<And>x. dist (f x) undefined \<le> y"
    by auto
  moreover
  from bcontfunE'[OF g] obtain z where "continuous_on UNIV g" "\<And>x. dist (g x) undefined \<le> z"
    by auto
  ultimately show ?thesis
  proof (intro bcontfunI)
    fix x
    have "dist (f x + g x) 0 = dist (f x + g x) (0 + 0)" by simp
    also have "\<dots> \<le> dist (f x) 0 + dist (g x) 0" by (rule dist_triangle_add)
    also have "\<dots> \<le> dist (Abs_bcontfun f) 0 + dist (Abs_bcontfun g) 0"
      unfolding zero_bcontfun_def using assms
      by (auto intro!: add_mono dist_bounded_Abs const_bcontfun)
    finally
    show "dist (f x + g x) 0 <= dist (Abs_bcontfun f) 0 + dist (Abs_bcontfun g) 0" .
  qed (simp add: continuous_on_add)
qed

lemma Rep_bcontfun_plus[simp]: "Rep_bcontfun (f + g) x = Rep_bcontfun f x + Rep_bcontfun g x"
  by (simp add: plus_bcontfun_def Abs_bcontfun_inverse plus_cont Rep_bcontfun)

lemma uminus_cont:
  fixes f ::"'a \<Rightarrow> 'b"
  assumes "f \<in> bcontfun"
  shows "(\<lambda>x. - f x) \<in> bcontfun"
proof -
  from bcontfunE[OF assms, of 0] obtain y where "continuous_on UNIV f" "\<And>x. dist (f x) 0 \<le> y"
    by auto
  thus ?thesis
  proof (intro bcontfunI)
    fix x
    assume "\<And>x. dist (f x) 0 \<le> y"
    thus "dist (- f x) 0 \<le> y" by (subst dist_minus[symmetric]) simp
  qed (simp add: continuous_on_minus)
qed

lemma Rep_bcontfun_uminus[simp]:
  "Rep_bcontfun (- f) x = - Rep_bcontfun f x"
  by (simp add: uminus_bcontfun_def Abs_bcontfun_inverse uminus_cont Rep_bcontfun)

lemma minus_cont:
  fixes f g ::"'a \<Rightarrow> 'b"
  assumes f: "f \<in> bcontfun" and g: "g \<in> bcontfun"
  shows "(\<lambda>x. f x - g x) \<in> bcontfun"
  using plus_cont [of f "- g"] assms by (simp add: uminus_cont fun_Compl_def)

lemma Rep_bcontfun_minus[simp]:
  "Rep_bcontfun (f - g) x = Rep_bcontfun f x - Rep_bcontfun g x"
  by (simp add: minus_bcontfun_def Abs_bcontfun_inverse minus_cont Rep_bcontfun)

lemma scaleR_cont:
  fixes a and f::"'a \<Rightarrow> 'b"
  assumes "f \<in> bcontfun"
  shows " (\<lambda>x. a *\<^sub>R f x) \<in> bcontfun"
proof -
  from bcontfunE[OF assms, of 0] obtain y where "continuous_on UNIV f" "\<And>x. dist (f x) 0 \<le> y"
    by auto
  thus ?thesis
  proof (intro bcontfunI)
    fix x assume "\<And>x. dist (f x) 0 \<le> y"
    thus "dist (a *\<^sub>R f x) 0 \<le> abs a * y"
      by (metis abs_ge_zero comm_semiring_1_class.normalizing_semiring_rules(7) mult_right_mono
        norm_conv_dist norm_scaleR)
  qed (simp add: continuous_intros)
qed

lemma Rep_bcontfun_scaleR[simp]:
   "Rep_bcontfun (a *\<^sub>R g) x = a *\<^sub>R Rep_bcontfun g x"
  by (simp add: scaleR_bcontfun_def Abs_bcontfun_inverse scaleR_cont Rep_bcontfun)

instance
proof
qed (simp_all add: plus_bcontfun_def zero_bcontfun_def minus_bcontfun_def scaleR_bcontfun_def
    Abs_bcontfun_inverse Rep_bcontfun_inverse Rep_bcontfun algebra_simps
    plus_cont const_bcontfun minus_cont scaleR_cont)
end

instantiation bcontfun :: (topological_space, real_normed_vector) real_normed_vector
begin

definition norm_bcontfun::"('a, 'b) bcontfun \<Rightarrow> real" where
  "norm_bcontfun f = dist f 0"

definition "sgn (f::('a,'b) bcontfun) = f /\<^sub>R norm f"

instance
proof
  fix f g::"('a, 'b) bcontfun"
  show "dist f g = norm (f - g)"
    by (simp add: norm_bcontfun_def dist_bcontfun_def zero_bcontfun_def
    Abs_bcontfun_inverse const_bcontfun norm_conv_dist[symmetric] dist_norm)
  show "norm (f + g) \<le> norm f + norm g"
    unfolding norm_bcontfun_def
  proof (subst dist_bcontfun_def, safe intro!: cSUP_least)
    fix x
    have "dist (Rep_bcontfun (f + g) x) (Rep_bcontfun 0 x) \<le>
      dist (Rep_bcontfun f x) 0 + dist (Rep_bcontfun g x) 0"
      by (metis (hide_lams, no_types) Rep_bcontfun_minus Rep_bcontfun_plus diff_0_right dist_norm
        le_less_linear less_irrefl norm_triangle_lt)
    also have "dist (Rep_bcontfun f x) 0 \<le> dist f 0"
      using dist_bounded[of f x 0]
      by (simp add: Abs_bcontfun_inverse const_bcontfun zero_bcontfun_def)
    also have "dist (Rep_bcontfun g x) 0 \<le> dist g 0" using dist_bounded[of g x 0]
      by (simp add: Abs_bcontfun_inverse const_bcontfun zero_bcontfun_def)
    finally show "dist (Rep_bcontfun (f + g) x) (Rep_bcontfun 0 x) \<le> dist f 0 + dist g 0" by simp
  qed
next
  fix a and f g:: "('a, 'b) bcontfun"
  show "norm (a *\<^sub>R f) = \<bar>a\<bar> * norm f"
    unfolding norm_bcontfun_def
  proof -
    have "Sup (op * \<bar>a\<bar> ` range (\<lambda>x. dist (Rep_bcontfun f x) 0)) =
      \<bar>a\<bar> * Sup (range (\<lambda>x. dist (Rep_bcontfun f x) 0))"
    proof (intro Sup_real_mult[symmetric] bdd_aboveI2)
      fix x
      show "dist (Rep_bcontfun f x) 0 \<le> norm f" using dist_bounded[of f x 0]
        by (simp add: norm_bcontfun_def norm_conv_dist Abs_bcontfun_inverse zero_bcontfun_def
          const_bcontfun)
    qed simp_all
    moreover
    have "range (\<lambda>x. dist (Rep_bcontfun (a *\<^sub>R f) x) 0) =
      (\<lambda>x. \<bar>a\<bar> * x) ` (range (\<lambda>x. dist (Rep_bcontfun f x) 0))"
      by (auto simp: norm_conv_dist[symmetric])
    ultimately
    show "dist (a *\<^sub>R f) 0 = \<bar>a\<bar> * dist f 0"
      by (simp add: dist_bcontfun_def norm_conv_dist[symmetric] Abs_bcontfun_inverse
        zero_bcontfun_def const_bcontfun SUP_def del: Sup_image_eq)
  qed
qed (auto simp: norm_bcontfun_def sgn_bcontfun_def)

end

lemma bcontfun_normI:
  "continuous_on UNIV f \<Longrightarrow> (\<And>x. norm (f x) \<le> b) \<Longrightarrow> f \<in> bcontfun"
  unfolding norm_conv_dist
  by (auto intro: bcontfunI)

lemma norm_bounded:
  fixes f ::"('a::topological_space, 'b::real_normed_vector) bcontfun"
  shows "norm (Rep_bcontfun f x) \<le> norm f"
  using dist_bounded[of f x 0]
  by (simp add: norm_bcontfun_def norm_conv_dist Abs_bcontfun_inverse zero_bcontfun_def
    const_bcontfun)

lemma norm_bound:
  fixes f ::"('a::topological_space, 'b::real_normed_vector) bcontfun"
  assumes "\<And>x. norm (Rep_bcontfun f x) \<le> b"
  shows "norm f \<le> b"
  using dist_bound[of f 0 b] assms
  by (simp add: norm_bcontfun_def norm_conv_dist Abs_bcontfun_inverse zero_bcontfun_def
    const_bcontfun)

subsection{* Continuously Extended Functions *}

definition clamp::"'a::ordered_euclidean_space \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" where
  "clamp a b x = (\<Sum>i\<in>Basis. (if x\<bullet>i < a\<bullet>i then a\<bullet>i else if x\<bullet>i \<le> b\<bullet>i then x\<bullet>i else b\<bullet>i) *\<^sub>R i)"

definition ext_cont::
  "('a::ordered_euclidean_space \<Rightarrow> 'b::real_normed_vector) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> ('a, 'b) bcontfun"
  where "ext_cont f a b = Abs_bcontfun ((\<lambda>x. f (clamp a b x)))"

lemma ext_cont_def':
  "ext_cont f a b = Abs_bcontfun (\<lambda>x.
    f (\<Sum>i\<in>Basis. (if x\<bullet>i < a\<bullet>i then a\<bullet>i else if x\<bullet>i \<le> b\<bullet>i then x\<bullet>i else b\<bullet>i) *\<^sub>R i))"
unfolding ext_cont_def clamp_def ..

lemma clamp_in_interval:
  assumes "a \<le> b"
  shows "clamp a b x \<in> {a..b}"
  unfolding clamp_def
  using box_ne_empty(1)[of a b] assms
  by (auto simp add: eucl_le[of a] eucl_le[where y=b])

lemma dist_clamps_le_dist_args:
  fixes x::"'a::ordered_euclidean_space"
  assumes "a \<le> b"
  shows "dist (clamp a b y) (clamp a b x) \<le> dist y x"
proof -
    from box_ne_empty(1)[of a b] assms have "(\<forall>i\<in>Basis. a \<bullet> i \<le> b \<bullet> i)"
      by (simp add: cbox_def eucl_le[where 'a='a])
    hence "(\<Sum>i\<in>Basis. (dist (clamp a b y \<bullet> i) (clamp a b x \<bullet> i))\<^sup>2)
        \<le> (\<Sum>i\<in>Basis. (dist (y \<bullet> i) (x \<bullet> i))\<^sup>2)"
      by (auto intro!: setsum_mono
        simp add: clamp_def dist_real_def real_abs_le_square_iff[symmetric])
    thus ?thesis
      by (auto intro: real_sqrt_le_mono
        simp add: euclidean_dist_l2[where y=x] euclidean_dist_l2[where y="clamp a b x"] setL2_def)
qed

lemma clamp_continuous_at:
  fixes f::"'a::ordered_euclidean_space \<Rightarrow> 'b::metric_space"
  fixes x
  assumes "a \<le> b"
  assumes f_cont: "continuous_on {a..b} f"
  shows "continuous (at x) (\<lambda>x. f (clamp a b x))"
unfolding continuous_at_eps_delta
proof (safe)
  fix x::'a and e::real
  assume "0 < e"
  moreover
  have "clamp a b x \<in> {a..b}" using clamp_in_interval assms by simp
  moreover
  note f_cont[simplified continuous_on_iff]
  ultimately
  obtain d where d: "0 < d"
    "\<And>x'. x' \<in> {a..b} \<Longrightarrow> dist x' (clamp a b x) < d \<Longrightarrow> dist (f x') (f (clamp a b x)) < e"
    by force
  show "\<exists>d>0. \<forall>x'. dist x' x < d \<longrightarrow>
    dist (f (clamp a b x')) (f (clamp a b x)) < e"
  proof (rule+)
    show "\<forall>x'. dist x' x < d \<longrightarrow>
      dist (f (clamp a b x')) (f (clamp a b x)) < e"
    proof (safe)
      fix x'
      assume "dist x' x < d"
      with dist_clamps_le_dist_args[OF assms(1), of x' x] d
      show "dist (f (clamp a b x')) (f (clamp a b x)) < e"
        using clamp_in_interval[OF assms(1), of x']
        by (simp add: ext_cont_def)
    qed
  qed (simp add: d)
qed

lemma clamp_continuous_on:
  fixes f::"'a::ordered_euclidean_space \<Rightarrow> 'b::metric_space"
  assumes "a \<le> b"
  assumes f_cont: "continuous_on {a..b} f"
  shows "continuous_on UNIV (\<lambda>x. f (clamp a b x))"
  using assms
  by (auto intro: continuous_at_imp_continuous_on clamp_continuous_at)

lemma clamp_bcontfun:
  fixes f::"'a::ordered_euclidean_space \<Rightarrow> 'b::real_normed_vector"
  assumes "a \<le> b"
  assumes continuous: "continuous_on {a..b} f"
  shows "(\<lambda>x. f (clamp a b x)) \<in> bcontfun"
proof -
  from compact_continuous_image[OF continuous compact_interval[of a b], THEN compact_imp_bounded]
  have "bounded (f ` {a..b})" .
  then obtain c where f_bound: "\<forall>x\<in>f ` {a..b}. norm x \<le> c" by (auto simp add: bounded_pos)
  show "(\<lambda>x. f (clamp a b x)) \<in> bcontfun"
  proof (intro bcontfun_normI)
    fix x
    from clamp_in_interval[OF assms(1), of x] f_bound
    show "norm (f (clamp a b x)) \<le> c" by (simp add: ext_cont_def)
  qed (simp add: clamp_continuous_on assms)
qed

lemma integral_clamp:
  "integral {t0::real..clamp t0 t1 x} f =
    (if x < t0 then 0 else if x \<le> t1 then integral {t0..x} f else integral {t0..t1} f)"
  by (auto simp: clamp_def)

declare [[coercion Rep_bcontfun]]

lemma ext_cont_cancel[simp]:
  fixes x a b::"'a::ordered_euclidean_space"
  assumes x: "x \<in> {a..b}"
  assumes "continuous_on {a..b} f"
  shows "ext_cont f a b x = f x"
  using assms
  unfolding ext_cont_def
proof (subst Abs_bcontfun_inverse[OF clamp_bcontfun])
  show "f (clamp a b x) = f x"
    using x unfolding clamp_def mem_box
    by (intro arg_cong[where f=f] euclidean_eqI[where 'a='a]) (simp add: not_less eucl_le[where 'a='a])
qed auto

lemma ext_cont_cong:
  assumes "t0 = s0"
  assumes "t1 = s1"
  assumes "\<And>t. t \<in> {t0..t1} \<Longrightarrow> f t = g t"
  assumes "continuous_on {t0..t1} f"
  assumes "continuous_on {s0..s1} g"
  assumes "t0 \<le> t1"
  shows "ext_cont f t0 t1 = ext_cont g s0 s1"
  unfolding assms ext_cont_def
  using assms clamp_in_interval[OF `t0 \<le> t1`]
  by (subst Rep_bcontfun_inject[symmetric]) simp

end