(* Author: Gerwin Klein, Tobias Nipkow *)

theory Big_Step imports "./Com" begin

subsection "Big-Step Semantics of Commands"

text {*
The big-step semantics is a straight-forward inductive definition
with concrete syntax. Note that the first parameter is a tuple,
so the syntax becomes @{text "(c,s) \<Rightarrow> s'"}.
*}

text_raw{*\snip{BigStepdef}{0}{1}{% *}
inductive
  big_step :: "com \<times> state \<Rightarrow> com \<times> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
where
Skip: "(SKIP,s) \<Rightarrow> (SKIP, s)" |
Assign: "(x ::= a,s) \<Rightarrow> (SKIP, s(x := aval a s))" |
Seq1: "\<lbrakk> (c\<^sub>1,s\<^sub>1) \<Rightarrow> (SKIP, s\<^sub>2);  (c\<^sub>2,s\<^sub>2) \<Rightarrow>  s\<^sub>3 \<rbrakk> \<Longrightarrow> (c\<^sub>1;;c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
Seq2: "(c1, s1) \<Rightarrow> (THROW, s2) \<Longrightarrow> (c1;; c2, s1) \<Rightarrow> (THROW, s2)" |
IfTrue: "\<lbrakk> bval b s;  (c\<^sub>1,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
IfFalse: "\<lbrakk> \<not>bval b s;  (c\<^sub>2,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
WhileFalse: "\<not>bval b s \<Longrightarrow> (WHILE b DO c, s) \<Rightarrow> (SKIP, s)" |
WhileTrue1:
"\<lbrakk> bval b s\<^sub>1;  (c,s\<^sub>1) \<Rightarrow> (SKIP, s\<^sub>2);  (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
\<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
WhileTrue2: "\<lbrakk>bval b s1; (c, s1) \<Rightarrow> (THROW, s2)\<rbrakk> \<Longrightarrow> (WHILE b DO c, s1) \<Rightarrow> (THROW, s2)" |
Throw: "(THROW, s) \<Rightarrow> (THROW, s)" |
TryOk: "(c, s) \<Rightarrow> (SKIP, t) \<Longrightarrow> (TRY c CATCH c2, s) \<Rightarrow> (SKIP, t)" |
TryBad: "\<lbrakk>(c, s) \<Rightarrow> (THROW, t); (c2, t) \<Rightarrow> ct\<rbrakk> \<Longrightarrow> (TRY c CATCH c2, s) \<Rightarrow> ct"
text_raw{*}%endsnip*}

text_raw{*\snip{BigStepEx}{1}{2}{% *}
schematic_lemma ex: "(''x'' ::= N 5;; ''y'' ::= V ''x'', s) \<Rightarrow> ?t"
apply(rule Seq1)
apply(rule Assign)
apply simp
apply(rule Assign)
done
text_raw{*}%endsnip*}

thm ex[simplified]

text{* We want to execute the big-step rules: *}

code_pred big_step .

text{* For inductive definitions we need command
       \texttt{values} instead of \texttt{value}. *}

values "{t. (SKIP, \<lambda>_. 0) \<Rightarrow> t}"

text{* We need to translate the result state into a list
to display it. *}

values "{map t [''x''] |c t. (SKIP, <''x'' := 42>) \<Rightarrow> (c, t)}"

values "{map t [''x''] |c t. (''x'' ::= N 2, <''x'' := 42>) \<Rightarrow> (c, t)}"

values "{map t [''x'',''y''] |c t.
  (WHILE Less (V ''x'') (V ''y'') DO (''x'' ::= Plus (V ''x'') (N 5)),
   <''x'' := 0, ''y'' := 13>) \<Rightarrow> (c, t)}"

values "{(c', map t [''x'']) |c' t. (TRY ''x'' ::= N 2;; THROW;; ''x'' ::= N 4 CATCH ''x'' ::= N 3, <>) \<Rightarrow> (c', t)}"

text{* Proof automation: *}

text {* The introduction rules are good for automatically
construction small program executions. The recursive cases
may require backtracking, so we declare the set as unsafe
intro rules. *}
declare big_step.intros [intro]

text{* The standard induction rule
@{thm [display] big_step.induct [no_vars]} *}

thm big_step.induct

text{*
This induction schema is almost perfect for our purposes, but
our trick for reusing the tuple syntax means that the induction
schema has two parameters instead of the @{text c}, @{text s},
and @{text s'} that we are likely to encounter. Splitting
the tuple parameter fixes this:
*}
lemmas big_step_induct = big_step.induct[split_format(complete)]
thm big_step_induct
text {*
@{thm [display] big_step_induct [no_vars]}
*}

subsection "Rule inversion"

text{* What can we deduce from @{prop "(SKIP,s) \<Rightarrow> t"} ?
That @{prop "s = t"}. This is how we can automatically prove it: *}

inductive_cases SkipE[elim!]: "(SKIP,s) \<Rightarrow> t"
thm SkipE

text{* This is an \emph{elimination rule}. The [elim] attribute tells auto,
blast and friends (but not simp!) to use it automatically; [elim!] means that
it is applied eagerly.

Similarly for the other commands: *}

inductive_cases AssignE[elim!]: "(x ::= a,s) \<Rightarrow> t"
thm AssignE
inductive_cases SeqE[elim!]: "(c1;;c2,s1) \<Rightarrow> s3"
thm SeqE
inductive_cases IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<Rightarrow> t"
thm IfE

inductive_cases WhileE[elim]: "(WHILE b DO c,s) \<Rightarrow> t"
thm WhileE
text{* Only [elim]: [elim!] would not terminate. *}

inductive_cases ThrowE[elim!]: "(THROW, s) \<Rightarrow> t"
inductive_cases TryE[elim!]: "(TRY c1 CATCH c2, s) \<Rightarrow> t"
text{* An automatic example: *}

lemma "(IF b THEN SKIP ELSE SKIP, s) \<Rightarrow> (c, t) \<Longrightarrow> t = s"
by blast

text{* Rule inversion by hand via the ``cases'' method: *}

lemma assumes "(IF b THEN SKIP ELSE SKIP, s) \<Rightarrow> (c, t)"
shows "t = s"
proof-
  from assms show ?thesis
  proof cases  --"inverting assms"
    case IfTrue thm IfTrue
    thus ?thesis by blast
  next
    case IfFalse thus ?thesis by blast
  qed
qed

(* Using rule inversion to prove simplification rules: *)
lemma assign_simp:
  "(x ::= a,s) \<Rightarrow> (SKIP, s') \<longleftrightarrow> (s' = s(x := aval a s))"
  by auto

text {* An example combining rule inversion and derivations *}
lemma Seq_assoc:
  "(c1;; c2;; c3, s) \<Rightarrow> (SKIP, s') \<longleftrightarrow> (c1;; (c2;; c3), s) \<Rightarrow> (SKIP, s')"
proof
  assume "(c1;; c2;; c3, s) \<Rightarrow> (SKIP, s')"
  then obtain s1 s2 where
    c1: "(c1, s) \<Rightarrow> (SKIP, s1)" and
    c2: "(c2, s1) \<Rightarrow> (SKIP, s2)" and
    c3: "(c3, s2) \<Rightarrow> (SKIP, s')" by auto
  from c2 c3
  have "(c2;; c3, s1) \<Rightarrow> (SKIP, s')" by (rule Seq1)
  with c1
  show "(c1;; (c2;; c3), s) \<Rightarrow> (SKIP, s')" by (rule Seq1)
next
  -- "The other direction is analogous"
  assume "(c1;; (c2;; c3), s) \<Rightarrow> (SKIP, s')"
  thus "(c1;; c2;; c3, s) \<Rightarrow> (SKIP, s')" by auto
qed

subsection "Command Equivalence"

text {*
  We call two statements @{text c} and @{text c'} equivalent wrt.\ the
  big-step semantics when \emph{@{text c} started in @{text s} terminates
  in @{text s'} iff @{text c'} started in the same @{text s} also terminates
  in the same @{text s'}}. Formally:
*}
text_raw{*\snip{BigStepEquiv}{0}{1}{% *}
abbreviation
  equiv_c :: "com \<Rightarrow> com \<Rightarrow> bool" (infix "\<sim>" 50) where
  "c \<sim> c' \<equiv> (\<forall>s t. (c,s) \<Rightarrow> t  =  (c',s) \<Rightarrow> t)"
text_raw{*}%endsnip*}

text {*
Warning: @{text"\<sim>"} is the symbol written \verb!\ < s i m >! (without spaces).

  As an example, we show that loop unfolding is an equivalence
  transformation on programs:
*}

text {* Luckily, such lengthy proofs are seldom necessary.  Isabelle can
prove many such facts automatically.  *}

lemma while_unfold:
  "(WHILE b DO c) \<sim> (IF b THEN c;; WHILE b DO c ELSE SKIP)"
by blast

lemma triv_if:
  "(IF b THEN c ELSE c) \<sim> c"
by blast

lemma commute_if:
  "(IF b1 THEN (IF b2 THEN c11 ELSE c12) ELSE c2)
   \<sim>
   (IF b2 THEN (IF b1 THEN c11 ELSE c2) ELSE (IF b1 THEN c12 ELSE c2))"
by blast

lemma sim_while_cong_aux:
  "(WHILE b DO c,s) \<Rightarrow> (c1, t)  \<Longrightarrow> c \<sim> c' \<Longrightarrow>  (WHILE b DO c',s) \<Rightarrow> (c1, t)"
by (induction "WHILE b DO c" s c1 t arbitrary: b c rule: big_step_induct) blast+

lemma sim_while_cong: "c \<sim> c' \<Longrightarrow> WHILE b DO c \<sim> WHILE b DO c'"
using sim_while_cong_aux by auto

text {* Command equivalence is an equivalence relation, i.e.\ it is
reflexive, symmetric, and transitive. Because we used an abbreviation
above, Isabelle derives this automatically. *}

lemma sim_refl:  "c \<sim> c" by simp
lemma sim_sym:   "(c \<sim> c') = (c' \<sim> c)" by auto
lemma sim_trans: "c \<sim> c' \<Longrightarrow> c' \<sim> c'' \<Longrightarrow> c \<sim> c''" by auto

subsection "Execution is deterministic"

text {* This proof is automatic. *}

theorem big_step_determ: "\<lbrakk> (c,s) \<Rightarrow> t; (c,s) \<Rightarrow> u \<rbrakk> \<Longrightarrow> u = t"
  by (induction arbitrary: u rule: big_step.induct) blast+

end


theory Prd_distribR
  imports Main  "~~/src/HOL/Library/BNF_Corec" "$HIPSTER_HOME/IsaHipster"
begin

setup Tactic_Data.set_coinduct_sledgehammer

codatatype (sset: 'a) Stream =
  SCons (shd: 'a) (stl: "'a Stream")

primcorec pls :: "nat Stream \<Rightarrow> nat Stream \<Rightarrow> nat Stream" where
  "pls s t = SCons (plus (shd s) (shd t)) (pls (stl s) (stl t))"

friend_of_corec pls where
  "pls s t = SCons (plus (shd s) (shd t)) (pls (stl s) (stl t))"
   apply (rule pls.code)
  by transfer_prover

corec (friend) prd :: "nat Stream \<Rightarrow> nat Stream \<Rightarrow> nat Stream" where
  "prd s t = SCons ((shd s) * (shd t)) (pls (prd (stl s) t) (prd s (stl t)))"

datatype 'a Lst =
  Emp
  | Cons "'a" "'a Lst"

fun obsStream :: "int \<Rightarrow> 'a Stream \<Rightarrow> 'a Lst" where
"obsStream n s = (if (n \<le> 0) then Emp else Cons (shd s) (obsStream (n - 1) (stl s)))"

(*hipster_obs Stream Lst obsStream pls prd
Proving: times_nat x 0 = 0
Undefined fact: "Nat.nat.coinduct_strong" *)

theorem prd_distribR: "prd (pls s t) u = pls (prd s u) (prd t u)"
(*by hipster_coinduct_sledgehammer
Failed to apply initial proof method*)
end


theory zip
imports Main
        "../data/list"
        "../data/Pair2"
        "$HIPSTER_HOME/IsaHipster"

begin

fun zip2 :: "'a list => 'b list => (('a, 'b) Pair2) list" where
  "zip2 (Nil2) y = Nil2"
| "zip2 (Cons2 z x2) (Nil2) = Nil2"
| "zip2 (Cons2 z x2) (Cons2 x3 x4) = Cons2 (Pair2 z x3) (zip2 x2 x4)"

(*hipster zip2*)
lemma lemma_a [thy_expl]: "zip2 Nil2 x1 = zip2 x1 Nil2"
by (hipster_induct_schemes zip2.simps)

lemma lemma_aa [thy_expl]: "zip2 Nil2 x1 = zip2 y1 Nil2"
by (hipster_induct_schemes zip2.simps)

end


section \<open>Matrices\<close>
theory Matrices_Typed
  imports Nat
begin

\<comment> \<open>I want the following -- is this safe?\<close>
\<comment> \<open>declare [[coercion_enabled]] [[coercion Element]] [[coercion "apply"]]\<close>

definition upto ("{0..< _}") where "{0..< n} = {i \<in> \<nat> | i < n}"

\<comment> \<open>Note Kevin: Having both, HOL and set functions is pain.\<close>
definition [typedef]:
  "Matrix A m n \<equiv> Element {0..<m} \<Rightarrow> Element {0..<n} \<Rightarrow> Element A"

definition "matrix A m n \<equiv> {0..<m} \<rightarrow> {0..<n} \<rightarrow> A"

definition "Matrix_to_matrix m n M \<equiv> \<lambda>i \<in> {0..<m}. \<lambda>j \<in> {0..<n}. M i j"

lemma Matrix_to_matrix_type [type]:
  "Matrix_to_matrix : (m : Nat) \<Rightarrow> (n : Nat) \<Rightarrow> Matrix A m n \<Rightarrow>
    Element (matrix A m n)"
  unfolding matrix_def Matrix_def Matrix_to_matrix_def
  by discharge_types

definition "matrix_to_Matrix M \<equiv> \<lambda>i j. M `i `j"

lemma matrix_to_Matrix_type [type]:
  "matrix_to_Matrix : Element (matrix A m n) \<Rightarrow> Matrix A m n"
  unfolding matrix_to_Matrix_def Matrix_def matrix_def by discharge_types

subsection \<open>Addition\<close>

definition "Matrix_add A M N i j = add A (M i j) (N i j)"

lemma Matrix_add_type [type]: "Matrix_add: Add A \<Rightarrow> Matrix A m n \<Rightarrow>
  Matrix A m n \<Rightarrow> Matrix A m n"
  unfolding Matrix_def Matrix_add_def by discharge_types

definition "matrix_Add C A m n \<equiv> object {
  \<langle>@add, \<lambda>M N \<in> matrix C m n. Matrix_to_matrix m n
    (Matrix_add A (matrix_to_Matrix M) (matrix_to_Matrix N))\<rangle>
}"

lemma assumes "A: Add C" "m: Nat" "n: Nat"
  shows "matrix_Add C A m n: Add (matrix C m n)"
  unfolding matrix_Add_def by (rule Add_typeI) auto

\<comment> \<open>Note Kevin: Now, given "M N \<in> matrix A m n", I could write "M + N" but given
"M N: Matrix A m n", I could not write "M + N" but need to write
"matrix_to_Matrix (Matrix_to_matrix m n M + Matrix_to_matrix m n N).\<close>

lemma Matrix_add_assoc: assumes "M : Monoid A" "N : Matrix A m n"
  "O : Matrix A m n" "P : Matrix A m n"
  "i : Element {0..<m}" "j : Element {0..<n}"
  shows "Matrix_add M (Matrix_add M N O) P i j =
    Matrix_add M N (Matrix_add M O P) i j"
  unfolding Matrix_add_def
  using assms add_assoc by (auto simp: Matrix_def)

definition "matrix_add A m n M N \<equiv> Matrix_to_matrix m n
  (Matrix_add A (matrix_to_Matrix M) (matrix_to_Matrix N))"

lemma matrix_add_assoc: assumes "M : Monoid A" "N : Element (matrix A m n)"
  "O : Element (matrix A m n)" "P : Element (matrix A m n)"
  shows "matrix_add M m n (matrix_add M m n N O) P =
    matrix_add M m n N (matrix_add M m n O P)"
  oops

end


(*  Author:     Tobias Nipkow
*)

section \<open>More Rotation\<close>

theory Rotation
imports ListAux PlaneGraphIso
begin

definition rotate_to :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
"rotate_to vs v \<equiv>  v # snd (splitAt v vs) @ fst (splitAt v vs)"

definition rotate_min :: "nat list \<Rightarrow> nat list" where
"rotate_min vs \<equiv> rotate_to vs (min_list vs)"

lemma cong_rotate_to:
 "x \<in> set xs \<Longrightarrow> xs \<cong> rotate_to xs x"
proof -
  assume x: "x \<in> set xs"
  hence ls1: "xs = fst (splitAt x xs) @ x # snd (splitAt x xs)" by (auto dest: splitAt_ram)
  define i where "i = length(fst(splitAt x xs))"
  hence "i < length((fst(splitAt x xs)) @ [x] @ snd(splitAt x xs))" by auto
  with ls1 have i_len: "i < length xs" by auto
  hence ls2: "xs = take i xs @ xs!i # drop (Suc i) xs" by (auto intro: id_take_nth_drop)
  from i_len have "length (take i xs) = i" by auto
  with i_def have len_eq: "length(take i xs) = length(fst(splitAt x xs))" by auto
  moreover
  from ls1 ls2 have eq: "take i xs @ xs!i # drop (Suc i) xs = fst(splitAt x xs) @ x # snd(splitAt x xs)" by simp
  ultimately have
    v_simp: "x = xs!i" and
    take_i: "fst(splitAt x xs) = take i xs" and
    drop_i': "snd(splitAt x xs) = drop (Suc i) xs" by auto
  from i_len have ls3: "xs = take i xs @ drop i xs" by auto
  with take_i have eq: "xs = fst(splitAt x xs) @ drop i xs" by auto
  with ls1 have "fst(splitAt x xs) @ drop i xs = fst(splitAt x xs) @ x # snd(splitAt x xs)" by auto
  then have drop_i: "drop i xs = x # snd(splitAt x xs)" by auto
  have "rotate i xs = drop (i mod length xs) xs @ take (i mod length xs) xs" by (rule rotate_drop_take)
  with i_len have "rotate i xs = drop i xs @ take i xs" by auto
  with take_i drop_i have "rotate i xs = (x # snd(splitAt x xs)) @ fst(splitAt x xs)" by auto
  thus ?thesis apply (auto simp: congs_def rotate_to_def) apply (rule exI) apply (rule sym) .
qed

lemma face_cong_if_norm_eq:
 "\<lbrakk> rotate_min xs = rotate_min ys; xs \<noteq> []; ys \<noteq> [] \<rbrakk> \<Longrightarrow> xs \<cong> ys"
apply(simp add:rotate_min_def)
apply(subgoal_tac "xs \<cong> rotate_to xs (Min (set xs))")
 apply(subgoal_tac "ys \<cong> rotate_to ys (Min (set ys))")
  apply(simp) apply(blast intro:congs_sym congs_trans)
 apply(simp add: cong_rotate_to)
apply(drule sym)
apply(simp add: cong_rotate_to)
done

lemma norm_eq_if_face_cong:
  "\<lbrakk> xs \<cong> ys; distinct xs; xs \<noteq> [] \<rbrakk> \<Longrightarrow> rotate_min xs = rotate_min ys"
by(auto simp:congs_def rotate_min_def rotate_to_def
  splitAt_rotate_pair_conv insert_absorb)

lemma norm_eq_iff_face_cong:
 "\<lbrakk> distinct xs; xs \<noteq> []; ys \<noteq> [] \<rbrakk> \<Longrightarrow>
  (rotate_min xs = rotate_min ys) = (xs \<cong> ys)"
by(blast intro: face_cong_if_norm_eq norm_eq_if_face_cong)

lemma inj_on_rotate_min_iff:
assumes "\<forall>vs \<in> A. distinct vs"  "[] \<notin> A"
shows "inj_on rotate_min A = inj_on (\<lambda>vs. {vs}//{\<cong>}) A"
proof -
  { fix xs ys assume xs: "xs \<in> A" and ys : "ys \<in> A"
    hence "xs \<noteq> [] \<and> ys \<noteq> []" using assms(2) by blast
    hence "(rotate_min xs = rotate_min ys) = (xs \<cong> ys)"
      using xs assms(1)
      by(simp add: singleton_list_cong_eq_iff norm_eq_iff_face_cong)
  } thus ?thesis by(simp add:inj_on_def)
qed

end


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

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

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

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

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

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

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

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

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

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

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

function stooge2sort2 :: "int list => int list"
         and stoogesort2 :: "int list => int list"
         and stooge2sort1 :: "int list => int list" where
"stooge2sort2 y =
   (case splitAt ((op div) ((2 * (length y)) + 1) 3) y of
      pair2 ys2 zs1 => x (stoogesort2 ys2) zs1)"
| "stoogesort2 (nil2) = nil2"
| "stoogesort2 (cons2 z (nil2)) = cons2 z (nil2)"
| "stoogesort2 (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "stoogesort2 (cons2 z (cons2 y2 (cons2 x3 x4))) =
     stooge2sort2
       (stooge2sort1 (stooge2sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "stooge2sort1 y =
     (case splitAt ((op div) (length y) 3) y of
        pair2 ys2 zs1 => x ys2 (stoogesort2 zs1))"
by pat_completeness auto

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

end


chapter {* Case Study: Single and Multi-Mutator Garbage Collection Algorithms *}

section {* Formalization of the Memory *}

theory Graph imports Main begin

datatype node = Black | White

type_synonym nodes = "node list"
type_synonym edge = "nat \<times> nat"
type_synonym edges = "edge list"

consts Roots :: "nat set"

definition Proper_Roots :: "nodes \<Rightarrow> bool" where
  "Proper_Roots M \<equiv> Roots\<noteq>{} \<and> Roots \<subseteq> {i. i<length M}"

definition Proper_Edges :: "(nodes \<times> edges) \<Rightarrow> bool" where
  "Proper_Edges \<equiv> (\<lambda>(M,E). \<forall>i<length E. fst(E!i)<length M \<and> snd(E!i)<length M)"

definition BtoW :: "(edge \<times> nodes) \<Rightarrow> bool" where
  "BtoW \<equiv> (\<lambda>(e,M). (M!fst e)=Black \<and> (M!snd e)\<noteq>Black)"

definition Blacks :: "nodes \<Rightarrow> nat set" where
  "Blacks M \<equiv> {i. i<length M \<and> M!i=Black}"

definition Reach :: "edges \<Rightarrow> nat set" where
  "Reach E \<equiv> {x. (\<exists>path. 1<length path \<and> path!(length path - 1)\<in>Roots \<and> x=path!0
              \<and> (\<forall>i<length path - 1. (\<exists>j<length E. E!j=(path!(i+1), path!i))))
              \<or> x\<in>Roots}"

text{* Reach: the set of reachable nodes is the set of Roots together with the
nodes reachable from some Root by a path represented by a list of
  nodes (at least two since we traverse at least one edge), where two
consecutive nodes correspond to an edge in E. *}

subsection {* Proofs about Graphs *}

lemmas Graph_defs= Blacks_def Proper_Roots_def Proper_Edges_def BtoW_def
declare Graph_defs [simp]

subsubsection{* Graph 1 *}

lemma Graph1_aux [rule_format]:
  "\<lbrakk> Roots\<subseteq>Blacks M; \<forall>i<length E. \<not>BtoW(E!i,M)\<rbrakk>
  \<Longrightarrow> 1< length path \<longrightarrow> (path!(length path - 1))\<in>Roots \<longrightarrow>
  (\<forall>i<length path - 1. (\<exists>j. j < length E \<and> E!j=(path!(Suc i), path!i)))
  \<longrightarrow> M!(path!0) = Black"
apply(induct_tac "path")
 apply force
apply clarify
apply simp
apply(case_tac "list")
 apply force
apply simp
apply(rename_tac lista)
apply(rotate_tac -2)
apply(erule_tac x = "0" in all_dupE)
apply simp
apply clarify
apply(erule allE , erule (1) notE impE)
apply simp
apply(erule mp)
apply(case_tac "lista")
 apply force
apply simp
apply(erule mp)
apply clarify
apply(erule_tac x = "Suc i" in allE)
apply force
done

lemma Graph1:
  "\<lbrakk>Roots\<subseteq>Blacks M; Proper_Edges(M, E); \<forall>i<length E. \<not>BtoW(E!i,M) \<rbrakk>
  \<Longrightarrow> Reach E\<subseteq>Blacks M"
apply (unfold Reach_def)
apply simp
apply clarify
apply(erule disjE)
 apply clarify
 apply(rule conjI)
  apply(subgoal_tac "0< length path - Suc 0")
   apply(erule allE , erule (1) notE impE)
   apply force
  apply simp
 apply(rule Graph1_aux)
apply auto
done

subsubsection{* Graph 2 *}

lemma Ex_first_occurrence [rule_format]:
  "P (n::nat) \<longrightarrow> (\<exists>m. P m \<and> (\<forall>i. i<m \<longrightarrow> \<not> P i))"
apply(rule nat_less_induct)
apply clarify
apply(case_tac "\<forall>m. m<n \<longrightarrow> \<not> P m")
apply auto
done

lemma Compl_lemma: "(n::nat)\<le>l \<Longrightarrow> (\<exists>m. m\<le>l \<and> n=l - m)"
apply(rule_tac x = "l - n" in exI)
apply arith
done

lemma Ex_last_occurrence:
  "\<lbrakk>P (n::nat); n\<le>l\<rbrakk> \<Longrightarrow> (\<exists>m. P (l - m) \<and> (\<forall>i. i<m \<longrightarrow> \<not>P (l - i)))"
apply(drule Compl_lemma)
apply clarify
apply(erule Ex_first_occurrence)
done

lemma Graph2:
  "\<lbrakk>T \<in> Reach E; R<length E\<rbrakk> \<Longrightarrow> T \<in> Reach (E[R:=(fst(E!R), T)])"
apply (unfold Reach_def)
apply clarify
apply simp
apply(case_tac "\<forall>z<length path. fst(E!R)\<noteq>path!z")
 apply(rule_tac x = "path" in exI)
 apply simp
 apply clarify
 apply(erule allE , erule (1) notE impE)
 apply clarify
 apply(rule_tac x = "j" in exI)
 apply(case_tac "j=R")
  apply(erule_tac x = "Suc i" in allE)
  apply simp
 apply (force simp add:nth_list_update)
apply simp
apply(erule exE)
apply(subgoal_tac "z \<le> length path - Suc 0")
 prefer 2 apply arith
apply(drule_tac P = "\<lambda>m. m<length path \<and> fst(E!R)=path!m" in Ex_last_occurrence)
 apply assumption
apply clarify
apply simp
apply(rule_tac x = "(path!0)#(drop (length path - Suc m) path)" in exI)
apply simp
apply(case_tac "length path - (length path - Suc m)")
 apply arith
apply simp
apply(subgoal_tac "(length path - Suc m) + nat \<le> length path")
 prefer 2 apply arith
apply(subgoal_tac "length path - Suc m + nat = length path - Suc 0")
 prefer 2 apply arith
apply clarify
apply(case_tac "i")
 apply(force simp add: nth_list_update)
apply simp
apply(subgoal_tac "(length path - Suc m) + nata \<le> length path")
 prefer 2 apply arith
apply(subgoal_tac "(length path - Suc m) + (Suc nata) \<le> length path")
 prefer 2 apply arith
apply simp
apply(erule_tac x = "length path - Suc m + nata" in allE)
apply simp
apply clarify
apply(rule_tac x = "j" in exI)
apply(case_tac "R=j")
 prefer 2 apply force
apply simp
apply(drule_tac t = "path ! (length path - Suc m)" in sym)
apply simp
apply(case_tac " length path - Suc 0 < m")
 apply(subgoal_tac "(length path - Suc m)=0")
  prefer 2 apply arith
 apply(simp del: diff_is_0_eq)
 apply(subgoal_tac "Suc nata\<le>nat")
 prefer 2 apply arith
 apply(drule_tac n = "Suc nata" in Compl_lemma)
 apply clarify
 using [[linarith_split_limit = 0]]
 apply force
 using [[linarith_split_limit = 9]]
apply(drule leI)
apply(subgoal_tac "Suc (length path - Suc m + nata)=(length path - Suc 0) - (m - Suc nata)")
 apply(erule_tac x = "m - (Suc nata)" in allE)
 apply(case_tac "m")
  apply simp
 apply simp
apply simp
done

subsubsection{* Graph 3 *}

declare min.absorb1 [simp] min.absorb2 [simp]

lemma Graph3:
  "\<lbrakk> T\<in>Reach E; R<length E \<rbrakk> \<Longrightarrow> Reach(E[R:=(fst(E!R),T)]) \<subseteq> Reach E"
apply (unfold Reach_def)
apply clarify
apply simp
apply(case_tac "\<exists>i<length path - 1. (fst(E!R),T)=(path!(Suc i),path!i)")
--{* the changed edge is part of the path *}
 apply(erule exE)
 apply(drule_tac P = "\<lambda>i. i<length path - 1 \<and> (fst(E!R),T)=(path!Suc i,path!i)" in Ex_first_occurrence)
 apply clarify
 apply(erule disjE)
--{* T is NOT a root *}
  apply clarify
  apply(rule_tac x = "(take m path)@patha" in exI)
  apply(subgoal_tac "\<not>(length path\<le>m)")
   prefer 2 apply arith
  apply(simp)
  apply(rule conjI)
   apply(subgoal_tac "\<not>(m + length patha - 1 < m)")
    prefer 2 apply arith
   apply(simp add: nth_append)
  apply(rule conjI)
   apply(case_tac "m")
    apply force
   apply(case_tac "path")
    apply force
   apply force
  apply clarify
  apply(case_tac "Suc i\<le>m")
   apply(erule_tac x = "i" in allE)
   apply simp
   apply clarify
   apply(rule_tac x = "j" in exI)
   apply(case_tac "Suc i<m")
    apply(simp add: nth_append)
    apply(case_tac "R=j")
     apply(simp add: nth_list_update)
     apply(case_tac "i=m")
      apply force
     apply(erule_tac x = "i" in allE)
     apply force
    apply(force simp add: nth_list_update)
   apply(simp add: nth_append)
   apply(subgoal_tac "i=m - 1")
    prefer 2 apply arith
   apply(case_tac "R=j")
    apply(erule_tac x = "m - 1" in allE)
    apply(simp add: nth_list_update)
   apply(force simp add: nth_list_update)
  apply(simp add: nth_append)
  apply(rotate_tac -4)
  apply(erule_tac x = "i - m" in allE)
  apply(subgoal_tac "Suc (i - m)=(Suc i - m)" )
    prefer 2 apply arith
   apply simp
--{* T is a root *}
 apply(case_tac "m=0")
  apply force
 apply(rule_tac x = "take (Suc m) path" in exI)
 apply(subgoal_tac "\<not>(length path\<le>Suc m)" )
  prefer 2 apply arith
 apply clarsimp
 apply(erule_tac x = "i" in allE)
 apply simp
 apply clarify
 apply(case_tac "R=j")
  apply(force simp add: nth_list_update)
 apply(force simp add: nth_list_update)
--{* the changed edge is not part of the path *}
apply(rule_tac x = "path" in exI)
apply simp
apply clarify
apply(erule_tac x = "i" in allE)
apply clarify
apply(case_tac "R=j")
 apply(erule_tac x = "i" in allE)
 apply simp
apply(force simp add: nth_list_update)
done

subsubsection{* Graph 4 *}

lemma Graph4:
  "\<lbrakk>T \<in> Reach E; Roots\<subseteq>Blacks M; I\<le>length E; T<length M; R<length E;
  \<forall>i<I. \<not>BtoW(E!i,M); R<I; M!fst(E!R)=Black; M!T\<noteq>Black\<rbrakk> \<Longrightarrow>
  (\<exists>r. I\<le>r \<and> r<length E \<and> BtoW(E[R:=(fst(E!R),T)]!r,M))"
apply (unfold Reach_def)
apply simp
apply(erule disjE)
 prefer 2 apply force
apply clarify
--{* there exist a black node in the path to T *}
apply(case_tac "\<exists>m<length path. M!(path!m)=Black")
 apply(erule exE)
 apply(drule_tac P = "\<lambda>m. m<length path \<and> M!(path!m)=Black" in Ex_first_occurrence)
 apply clarify
 apply(case_tac "ma")
  apply force
 apply simp
 apply(case_tac "length path")
  apply force
 apply simp
 apply(erule_tac P = "\<lambda>i. i < nata \<longrightarrow> ?P i" and x = "nat" in allE)
 apply simp
 apply clarify
 apply(erule_tac P = "\<lambda>i. i < Suc nat \<longrightarrow> ?P i" and x = "nat" in allE)
 apply simp
 apply(case_tac "j<I")
  apply(erule_tac x = "j" in allE)
  apply force
 apply(rule_tac x = "j" in exI)
 apply(force  simp add: nth_list_update)
apply simp
apply(rotate_tac -1)
apply(erule_tac x = "length path - 1" in allE)
apply(case_tac "length path")
 apply force
apply force
done

declare min.absorb1 [simp del] min.absorb2 [simp del]

subsubsection {* Graph 5 *}

lemma Graph5:
  "\<lbrakk> T \<in> Reach E ; Roots \<subseteq> Blacks M; \<forall>i<R. \<not>BtoW(E!i,M); T<length M;
    R<length E; M!fst(E!R)=Black; M!snd(E!R)=Black; M!T \<noteq> Black\<rbrakk>
   \<Longrightarrow> (\<exists>r. R<r \<and> r<length E \<and> BtoW(E[R:=(fst(E!R),T)]!r,M))"
apply (unfold Reach_def)
apply simp
apply(erule disjE)
 prefer 2 apply force
apply clarify
--{* there exist a black node in the path to T*}
apply(case_tac "\<exists>m<length path. M!(path!m)=Black")
 apply(erule exE)
 apply(drule_tac P = "\<lambda>m. m<length path \<and> M!(path!m)=Black" in Ex_first_occurrence)
 apply clarify
 apply(case_tac "ma")
  apply force
 apply simp
 apply(case_tac "length path")
  apply force
 apply simp
 apply(erule_tac P = "\<lambda>i. i < nata \<longrightarrow> ?P i" and x = "nat" in allE)
 apply simp
 apply clarify
 apply(erule_tac P = "\<lambda>i. i < Suc nat \<longrightarrow> ?P i" and x = "nat" in allE)
 apply simp
 apply(case_tac "j\<le>R")
  apply(drule le_imp_less_or_eq [of _ R])
  apply(erule disjE)
   apply(erule allE , erule (1) notE impE)
   apply force
  apply force
 apply(rule_tac x = "j" in exI)
 apply(force  simp add: nth_list_update)
apply simp
apply(rotate_tac -1)
apply(erule_tac x = "length path - 1" in allE)
apply(case_tac "length path")
 apply force
apply force
done

subsubsection {* Other lemmas about graphs *}

lemma Graph6:
 "\<lbrakk>Proper_Edges(M,E); R<length E ; T<length M\<rbrakk> \<Longrightarrow> Proper_Edges(M,E[R:=(fst(E!R),T)])"
apply (unfold Proper_Edges_def)
 apply(force  simp add: nth_list_update)
done

lemma Graph7:
 "\<lbrakk>Proper_Edges(M,E)\<rbrakk> \<Longrightarrow> Proper_Edges(M[T:=a],E)"
apply (unfold Proper_Edges_def)
apply force
done

lemma Graph8:
 "\<lbrakk>Proper_Roots(M)\<rbrakk> \<Longrightarrow> Proper_Roots(M[T:=a])"
apply (unfold Proper_Roots_def)
apply force
done

text{* Some specific lemmata for the verification of garbage collection algorithms. *}

lemma Graph9: "j<length M \<Longrightarrow> Blacks M\<subseteq>Blacks (M[j := Black])"
apply (unfold Blacks_def)
 apply(force simp add: nth_list_update)
done

lemma Graph10 [rule_format (no_asm)]: "\<forall>i. M!i=a \<longrightarrow>M[i:=a]=M"
apply(induct_tac "M")
apply auto
apply(case_tac "i")
apply auto
done

lemma Graph11 [rule_format (no_asm)]:
  "\<lbrakk> M!j\<noteq>Black;j<length M\<rbrakk> \<Longrightarrow> Blacks M \<subset> Blacks (M[j := Black])"
apply (unfold Blacks_def)
apply(rule psubsetI)
 apply(force simp add: nth_list_update)
apply safe
apply(erule_tac c = "j" in equalityCE)
apply auto
done

lemma Graph12: "\<lbrakk>a\<subseteq>Blacks M;j<length M\<rbrakk> \<Longrightarrow> a\<subseteq>Blacks (M[j := Black])"
apply (unfold Blacks_def)
apply(force simp add: nth_list_update)
done

lemma Graph13: "\<lbrakk>a\<subset> Blacks M;j<length M\<rbrakk> \<Longrightarrow> a \<subset> Blacks (M[j := Black])"
apply (unfold Blacks_def)
apply(erule psubset_subset_trans)
apply(force simp add: nth_list_update)
done

declare Graph_defs [simp del]

end


theory OBTDemo
imports "$HIPSTER_HOME/IsaHipster"

begin
(*
fun len :: "'a list \<Rightarrow> nat"
where
  "len [] = 0"
| "len (x#xs) = 1 + (len xs)"
hipster len

fun rot :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "rot 0 xs = xs"
| "rot (Suc n) xs = (case xs of [] \<Rightarrow> []
                    | (x#xs) \<Rightarrow> rot n (xs @ [x]))"
*)
(* hipster rot  Fucked. Doesn't prove anything despite simple proofs exisitng! Skitprogram.*)

fun rev :: "'a list \<Rightarrow> 'a list"
where
  "rev [] = []"
| "rev (x#xs) = (rev xs) @ [x]"

fun qrev :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "qrev [] acc = acc"
| "qrev (x#xs) acc = qrev xs (x#acc)"

hipster rev
lemma lemma_a [thy_expl]: "OBTDemo.rev z @ OBTDemo.rev y = OBTDemo.rev (y @ z)"
apply (induction y)
apply simp
by simp

lemma lemma_aa [thy_expl]: "OBTDemo.rev (OBTDemo.rev y) = y"
apply (induction y)
apply simp
apply simp
by (metis List.rev.simps(2) OBTDemo.rev.simps(1) OBTDemo.rev.simps(2) append_Cons append_Nil append_Nil2 lemma_a list.sel(3) rev_is_Nil_conv)

hipster rev qrev
lemma lemma_ab [thy_expl]: "OBTDemo.rev y @ z = qrev y z"
apply (induction y)
apply simp
apply simp
by (metis append_Cons append_Nil append_assoc)

lemma lemma_ac [thy_expl]: "qrev y [] = OBTDemo.rev y"
sledgehammer
apply (induction y)
apply simp
apply simp
by (metis lemma_ab)

end


(* Title: Verification Component Based on KAT: Examples
   Author: Victor Gomes, Georg Struth
   Maintainer: Victor Gomes <victor.gomes@cl.cam.ac.uk>
               Georg Struth <g.struth@sheffield.ac.uk>
*)

subsubsection \<open>Verification Examples\<close>

theory VC_KAT_Examples
  imports VC_KAT
begin

lemma euclid:
  "PRE (\<lambda>s::nat store. s ''x'' = x \<and> s ''y'' = y)
   (WHILE (\<lambda>s. s ''y'' \<noteq> 0) INV (\<lambda>s. gcd (s ''x'') (s ''y'') = gcd x y)
    DO
     (''z'' ::= (\<lambda>s. s ''y''));
     (''y'' ::= (\<lambda>s. s ''x'' mod s ''y''));
     (''x'' ::= (\<lambda>s. s ''z''))
    OD)
   POST (\<lambda>s. s ''x'' = gcd x y)"
  apply (rule sH_while_inv)
  apply simp_all
  apply force
  apply (intro rel_kat.H_seq)
  apply (subst H_assign, simp)+
  apply (intro H_assign_var)
  using gcd_red_nat by auto

lemma maximum:
  "PRE (\<lambda>s:: nat store. True)
   (IF (\<lambda>s. s ''x'' \<ge> s ''y'')
    THEN (''z'' ::= (\<lambda>s. s ''x''))
    ELSE (''z'' ::= (\<lambda>s. s ''y''))
    FI)
   POST (\<lambda>s. s ''z'' = max (s ''x'') (s ''y''))"
  by auto

lemma integer_division:
  "PRE (\<lambda>s::nat store. s ''x'' \<ge> 0)
    (''q'' ::= (\<lambda>s. 0));
    (''r'' ::= (\<lambda>s. s ''x''));
    (WHILE (\<lambda>s. s ''y'' \<le> s ''r'') INV (\<lambda>s. s ''x'' = s ''q'' * s ''y'' + s ''r'' \<and> s ''r'' \<ge> 0)
     DO
      (''q'' ::= (\<lambda>s. s ''q'' + 1));
      (''r'' ::= (\<lambda>s. s ''r'' - s ''y''))
      OD)
   POST (\<lambda>s. s ''x'' = s ''q'' * s ''y'' + s ''r'' \<and> s ''r'' \<ge> 0 \<and> s ''r'' < s ''y'')"
  apply (intro rel_kat.H_seq, subst sH_while_inv, simp_all)
  apply auto[1]
  apply (intro rel_kat.H_seq)
  by (subst H_assign, simp_all)+

lemma imp_reverse:
  "PRE (\<lambda>s:: 'a list store. s ''x'' = X)
   (''y'' ::= (\<lambda>s. []));
   (WHILE (\<lambda>s. s ''x'' \<noteq> []) INV (\<lambda>s. rev (s ''x'') @ s ''y'' = rev X)
    DO
     (''y'' ::= (\<lambda>s. hd (s ''x'') # s ''y''));
     (''x'' ::= (\<lambda>s. tl (s ''x'')))
    OD)
   POST (\<lambda>s. s ''y''= rev X )"
  apply (intro rel_kat.H_seq, rule sH_while_inv)
  apply auto[2]
  apply (rule rel_kat.H_seq, rule H_assign_var)
  apply auto[1]
  apply (rule H_assign_var)
  apply (clarsimp, metis append.simps(1) append.simps(2) append_assoc hd_Cons_tl rev.simps(2))
  by simp

end


theory Individuals
  imports Common
begin

record 'i individual_structure =
  individuals :: "'i set" ("\<I>\<index>")
  inheres_in :: "'i \<Rightarrow> 'i \<Rightarrow> bool" (infix "\<triangleleft>\<index>" 75)
  exactly_similar_to :: "'i \<Rightarrow> 'i \<Rightarrow> bool" (infix "\<simeq>\<index>" 75)
  worlds :: "'i set set" ("\<W>\<index>")
  refers_to :: "'i \<Rightarrow> 'i \<Rightarrow> bool" (infix "\<hookrightarrow>\<index>" 75)

lemma individual_structure_eqI:
  fixes A B :: "'i individual_structure"
  assumes "\<I>\<^bsub>A\<^esub> = \<I>\<^bsub>B\<^esub>" "(\<triangleleft>\<^bsub>A\<^esub>) = (\<triangleleft>\<^bsub>B\<^esub>)" "(\<simeq>\<^bsub>A\<^esub>) = (\<simeq>\<^bsub>B\<^esub>)"
          "\<W>\<^bsub>A\<^esub> = \<W>\<^bsub>B\<^esub>" "(\<hookrightarrow>\<^bsub>A\<^esub>) = (\<hookrightarrow>\<^bsub>B\<^esub>)"
  shows "A = B"
  using assms by auto

definition substantials :: "'i individual_structure \<Rightarrow> 'i set" ("\<S>\<index>") where
    "\<S> \<equiv> { x . x \<in> \<I> \<and> (\<forall>y. \<not> x \<triangleleft> y) }"
  for IS :: "'i individual_structure" (structure)

lemma substantialsI[intro!]:
  fixes IS :: "'i individual_structure" (structure)
  assumes "x \<in> \<I>" "\<And>y. \<not> x \<triangleleft> y"
  shows "x \<in> \<S>"
  using assms by (auto simp: substantials_def)

lemma substantialsE[elim!]:
  fixes IS :: "'i individual_structure" (structure)
  assumes "x \<in> \<S>"
  obtains "x \<in> \<I>" "\<And>y. \<not> x \<triangleleft> y"
  using assms by (auto simp: substantials_def)

definition moments :: "'i individual_structure \<Rightarrow> 'i set" ("\<M>\<index>") where
    "\<M> \<equiv> { x . x \<in> \<I> \<and> (\<exists>y. x \<triangleleft> y) }"
  for IS :: "'i individual_structure" (structure)

definition bearer :: "'i individual_structure \<Rightarrow> 'i \<Rightarrow> 'i" ("\<beta>\<index>") where
    "\<beta> x \<equiv> if (\<exists>y. x \<triangleleft> y) then (THE y. x \<triangleleft> y) else undefined"
  for IS :: "'i individual_structure" (structure)

definition existentially_dependent :: "'i individual_structure \<Rightarrow> 'i \<Rightarrow> 'i \<Rightarrow> bool" ("ed\<index>") where
  "ed x y \<equiv> x \<in> \<I> \<and> y \<in> \<I> \<and> (\<forall>w \<in> \<W>. x \<in> w \<longrightarrow> y \<in> w)"
  for IS :: "'i individual_structure" (structure)

lemma ed_I[intro!]: "\<lbrakk> x \<in> \<I> ; y \<in> \<I> ; \<forall>w. w \<in> \<W> \<and> x \<in> w \<longrightarrow> y \<in> w \<rbrakk> \<Longrightarrow> ed x y" for IS (structure)
  by (auto simp: existentially_dependent_def)

(* UNUSED lemma ed_I_1: "\<lbrakk> x \<in> \<I> ; y \<in> \<I> ; \<And>w. \<lbrakk> w \<in> \<W> ; x \<in> w \<rbrakk> \<Longrightarrow> y \<in> w \<rbrakk> \<Longrightarrow> ed x y" for IS (structure)
  by (auto) *)

lemma ed_E[elim!]: "\<lbrakk> ed x y ; \<lbrakk> x \<in> \<I> ; y \<in> \<I> ; \<forall>w. w \<in> \<W> \<and> x \<in> w \<longrightarrow> y \<in> w \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P" for IS (structure)
  by (auto simp: existentially_dependent_def)

(* UNUSED lemma ed_E_1: "\<lbrakk> ed x y ; \<And>x y. \<lbrakk> x \<in> \<I> ; y \<in> \<I> ; \<And>w. \<lbrakk> w \<in> \<W> ; x \<in> w \<rbrakk> \<Longrightarrow> y \<in> w \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P" for IS (structure)
  by (auto) *)

(* UNUSED lemma ed_refl[intro!]: "x \<in> \<I> \<Longrightarrow> ed x x" for IS (structure)
  using ed_I by metis *)

(* UNUSED lemma ed_trans[trans]: "\<lbrakk> ed x y ; ed y z \<rbrakk> \<Longrightarrow> ed x z" for IS (structure)
  by (auto simp: existentially_dependent_def) *)

lemma moments_subset_individuals[simp,intro!]: "\<M> \<subseteq> \<I>"
  for IS :: "'i individual_structure" (structure)
  by (simp add: moments_def subset_eq)

lemma substantials_subset_individuals[simp,intro!]: "\<S> \<subseteq> \<I>"
  for IS :: "'i individual_structure" (structure)
  by blast

locale individual_structure_defs =
  fixes IS :: "'i individual_structure" (structure)
begin

end

locale individual_structure =
  individual_structure_defs  +
  assumes
    undefined_not_in_individuals[iff]: "undefined \<notin> \<I>" and

    inheres_in_scope: "x \<triangleleft> y \<Longrightarrow> x \<in> \<I> \<and> y \<in> \<I>" and
    inheres_in_sep: "x \<triangleleft> y \<Longrightarrow> \<not> y \<triangleleft> z" and
    inheres_in_single[dest]: "\<lbrakk> x \<triangleleft> y ; x \<triangleleft> z \<rbrakk> \<Longrightarrow> y = z" and

    exactly_similar_scope: "x \<simeq> y \<Longrightarrow> x \<in> \<M> \<and> y \<in> \<M>" and
    exactly_similar_refl[intro!]: "x \<in> \<M> \<Longrightarrow> x \<simeq> x" and
    exactly_similar_trans[trans]: "\<lbrakk> x \<simeq> y ; x \<simeq> z \<rbrakk> \<Longrightarrow> x \<simeq> z" and
    exactly_similar_sym[sym]: "x \<simeq> y \<Longrightarrow> y \<simeq> x"  and

    empty_world[iff]: "{} \<in> \<W>" and
    worlds_are_made_of_individuals: "w \<in> \<W> \<Longrightarrow> w \<subseteq> \<I>" and
    every_individual_exists_somewhere: "x \<in> \<I> \<Longrightarrow> \<exists>w \<in> \<W>. x \<in> w" and
    inherence_imp_ed: "x \<triangleleft> y \<Longrightarrow> ed x y" and

    refers_to_scope: "x \<hookrightarrow> y \<Longrightarrow> x \<in> \<M> \<and> y \<in> \<S>" and
    refers_to_diff_bearer: "\<lbrakk> x \<hookrightarrow> y ; x \<triangleleft> z \<rbrakk> \<Longrightarrow> z \<noteq> y" and
    refers_to_imp_ed: "x \<hookrightarrow> y \<Longrightarrow> ed x y" (* and

    moment_uniqueness: "\<lbrakk> x \<triangleleft> z ; y \<triangleleft> z ; x \<simeq> y ; \<forall>s. x \<hookrightarrow> s \<longleftrightarrow> y \<hookrightarrow> s \<rbrakk> \<Longrightarrow> x = y" *)

begin

lemma momentsI[intro]:
  assumes "x \<triangleleft> y"
  shows "x \<in> \<M>"
  using assms inheres_in_scope by (auto simp: moments_def)

lemma momentsE[elim]:
  assumes "x \<in> \<M>"
  obtains y where "x \<triangleleft> y"
  using assms by (auto simp: moments_def)

lemma substantialsI2[intro]:
  assumes "x \<triangleleft> y"
  shows "y \<in> \<S>"
  using inheres_in_sep inheres_in_scope assms substantialsI by metis

lemma individuals_moments_substantials: "\<I> = \<S> \<union> \<M>"
  using inheres_in_scope by (auto simp: substantials_def moments_def)

lemma substantials_moments_disj: "\<S> \<inter> \<M> = {}"
  by (auto simp: substantials_def moments_def)

(* UNUSED lemma substantials_eq_diff: "\<S> = \<I> - \<M>"
  using individuals_moments_substantials substantials_moments_disj by blast *)

(* UNUSED lemma moments_eq_diff: "\<M> = \<I> - \<S>"
  using individuals_moments_substantials substantials_moments_disj by blast *)

lemma individuals_cases[cases set]:
  assumes "x \<in> \<I>"
  obtains (substantial) "x \<in> \<S>" "x \<notin> \<M>" | (moment) "x \<in> \<M>" "x \<notin> \<S>"
  using assms individuals_moments_substantials substantials_moments_disj by blast

lemma bearer_eq:
  assumes "x \<triangleleft> y"
  shows "\<beta> x = y"
  using assms inheres_in_single
  by (auto simp: bearer_def)

lemma bearerI[intro]:
  assumes "x \<in> \<M>" "\<And>y. x \<triangleleft> y \<Longrightarrow> P y"
  shows "P (\<beta> x)"
  using assms apply (auto simp: bearer_def)
  using momentsE assms
  by (simp add: inheres_in_single the_equality)

(* UNUSED lemma bearer_eqE:
  assumes "\<beta> x = y"
  obtains "x \<in> \<M> \<Longrightarrow> x \<triangleleft> y"
  using assms by blast *)

lemma inheres_in_scope_2:
  assumes "x \<triangleleft> y"
  obtains "x \<in> \<M>" "y \<in> \<S>"
  using assms
  by (simp add: momentsI substantialsI2)

lemma inheres_in_scope_D:
  assumes "x \<triangleleft> y"
  shows "x \<in> \<M>" "y \<in> \<S>"
  using assms by (auto elim!: inheres_in_scope_2)

lemma inheres_in_out_scope: "x \<notin> \<M> \<Longrightarrow> \<not> x \<triangleleft> y" "x \<notin> \<S> \<Longrightarrow> \<not> y \<triangleleft> x"
  using inheres_in_scope_2 by metis+

lemma moments_are_individuals[dest]: "x \<in> \<M> \<Longrightarrow> x \<in> \<I>"
  by (meson moments_subset_individuals subset_iff)

lemma substantials_are_individuals[dest]: "x \<in> \<S> \<Longrightarrow> x \<in> \<I>" by blast

lemma substantials_moments_disj_2[dest]: "\<lbrakk> x \<in> \<M> ; x \<in> \<S> \<rbrakk> \<Longrightarrow> False" by blast

lemma undefined_not_in_moments[iff]: "undefined \<notin> \<M>"
  by (meson moments_are_individuals undefined_not_in_individuals)
lemma undefined_not_in_substantials[iff]: "undefined \<notin> \<S>"
  using undefined_not_in_individuals by blast

lemma inheres_in_sep_2[dest]:  "\<lbrakk> x \<triangleleft> y ; y \<triangleleft> z \<rbrakk> \<Longrightarrow> False"
  using inheres_in_sep by blast

lemma exactly_similar_sym_iff[iff]: "x \<simeq> y \<longleftrightarrow> y \<simeq> x"
  using exactly_similar_sym by blast

lemma individuals_iff: "x \<in> \<I> \<longleftrightarrow> (\<exists>w. w \<in> \<W> \<and> x \<in> w)"
  using worlds_are_made_of_individuals
    every_individual_exists_somewhere
  by (meson contra_subsetD)

(* UNUSED lemma ed_intro_1: "x \<triangleleft> y \<or> x \<hookrightarrow> y  \<Longrightarrow> ed x y"
  using inherence_imp_ed refers_to_imp_ed by metis *)

lemma ed_scope: "ed x y \<Longrightarrow> x \<in> \<I> \<and> y \<in> \<I>"
  by blast

lemma undefined_simps[iff]:
  "\<not> undefined \<triangleleft> x" "\<not> x \<triangleleft> undefined"
  "\<not> undefined \<simeq> x" "\<not> x \<simeq> undefined"
  "\<not> undefined \<hookrightarrow> x" "\<not> x \<hookrightarrow> undefined"
  "\<not> ed undefined x" "\<not> ed x undefined"
  using undefined_not_in_moments undefined_not_in_substantials undefined_not_in_individuals
    inheres_in_scope refers_to_scope exactly_similar_scope ed_scope
  by metis+

(* UNUSED lemma bearer_non_moment[simp,intro!]: "\<beta> x \<notin> \<M>"
  by (metis bearer_def bearer_eq inheres_in_sep momentsE undefined_not_in_moments) *)

lemma bearer_ex1[dest]:
  assumes "w \<in> \<W>" "x \<in> w" "x \<triangleleft> y"
  shows "y \<in> w"
  using assms inherence_imp_ed ed_E by metis

end

end


theory Lang_NI
imports Main
begin

locale Lang_NI =
  fixes lang_semantics :: "'state \<Rightarrow> 'prog \<Rightarrow> 'state \<Rightarrow> bool" ("_ \<turnstile> _ \<Rightarrow> _")
    and view :: "'state \<Rightarrow> 'state \<Rightarrow> bool" ("_ \<sim> _")
begin

text \<open>Termination-Sensitive Non-Interference (TSNI):\<close>

definition "TSNI c \<equiv>
  \<forall> \<mu>1 \<mu>2 \<mu>1'. ((\<mu>1 \<sim> \<mu>2) \<and> (\<mu>1 \<turnstile> c \<Rightarrow> \<mu>1'))
             \<longrightarrow> (\<exists> \<mu>2'. (\<mu>2 \<turnstile> c \<Rightarrow> \<mu>2') \<and> (\<mu>1' \<sim> \<mu>2'))"

text \<open>Termination-Insensitive Non-Interference (TINI):\<close>

definition "TINI c \<equiv>
  \<forall> \<mu>1 \<mu>2 \<mu>1' \<mu>2'. ((\<mu>1 \<sim> \<mu>2) \<and> (\<mu>1 \<turnstile> c \<Rightarrow> \<mu>1') \<and> (\<mu>2 \<turnstile> c \<Rightarrow> \<mu>2'))
             \<longrightarrow> (\<mu>1' \<sim> \<mu>2')"

text \<open>Deterministic programs:\<close>

definition "det c \<equiv>
  \<forall> \<mu> \<mu>' \<mu>''. (\<mu> \<turnstile> c \<Rightarrow> \<mu>') \<and> (\<mu> \<turnstile> c \<Rightarrow> \<mu>'') \<longrightarrow> \<mu>' = \<mu>''"

text \<open>Termination of a program, starting from \<mu>:\<close>

definition "term c \<mu> \<equiv>
  \<exists>\<mu>'. (\<mu> \<turnstile> c \<Rightarrow> \<mu>')"

text \<open>For deterministic programs that are guaranteed to terminate, these two notions of
noninterference coincide.

Note that the proofs of the following lemmas are automatic; we spell them out merely for
illustration purposes.\<close>

lemma TSNI_TINI:
  assumes "TSNI c"
      and "det c"
  shows "TINI c"
unfolding TINI_def
proof (intro allI impI, elim conjE)
  fix \<mu>1 \<mu>2 \<mu>1' \<mu>2'
  assume "\<mu>1 \<sim> \<mu>2" and "\<mu>1 \<turnstile> c \<Rightarrow> \<mu>1'" and \<mu>2': "\<mu>2 \<turnstile> c \<Rightarrow> \<mu>2'"
  with `TSNI c` obtain \<mu>2'' where "\<mu>1' \<sim> \<mu>2''" and \<mu>2'': "\<mu>2 \<turnstile> c \<Rightarrow> \<mu>2''"
    unfolding TSNI_def by blast
  moreover have "\<mu>2' = \<mu>2''" using `det c` \<mu>2' \<mu>2''
    unfolding det_def by blast
  ultimately show "\<mu>1' \<sim> \<mu>2'" by simp
qed

lemma TINI_TSNI:
  assumes "TINI c"
      and "\<forall> \<mu>. term c \<mu>"
  shows "TSNI c"
unfolding TSNI_def
proof (intro allI impI, elim conjE)
  fix \<mu>1 \<mu>2 \<mu>1'
  assume "\<mu>1 \<sim> \<mu>2" and "\<mu>1 \<turnstile> c \<Rightarrow> \<mu>1'"
  moreover obtain \<mu>2' where \<mu>2': "\<mu>2 \<turnstile> c \<Rightarrow> \<mu>2'"
    using assms(2) unfolding term_def by blast
  ultimately have "\<mu>1' \<sim> \<mu>2'"
    using `TINI c` unfolding TINI_def by blast
  with \<mu>2' show "\<exists>\<mu>2'. (\<mu>2 \<turnstile> c \<Rightarrow> \<mu>2') \<and> (\<mu>1' \<sim> \<mu>2')" by blast
qed

theorem
assumes "det c" and "\<forall>\<mu>. term c \<mu>"
shows "TSNI c \<longleftrightarrow> TINI c"
using assms TSNI_TINI TINI_TSNI by blast

end

end


(*  Title:     HOL/Probability/Sinc_Integral.thy
    Authors:   Jeremy Avigad (CMU), Luke Serafin (CMU)
    Authors:   Johannes Hölzl, TU München
*)

section \<open>Integral of sinc\<close>

theory Sinc_Integral
  imports Distributions
begin

subsection \<open>Various preparatory integrals\<close>

text \<open> Naming convention
The theorem name consists of the following parts:
  \<^item> Kind of integral: \<open>has_bochner_integral\<close> / \<open>integrable\<close> / \<open>LBINT\<close>
  \<^item> Interval: Interval (0 / infinity / open / closed) (infinity / open / closed)
  \<^item> Name of the occurring constants: power, exp, m (for minus), scale, sin, $\ldots$
\<close>

lemma has_bochner_integral_I0i_power_exp_m':
  "has_bochner_integral lborel (\<lambda>x. x^k * exp (-x) * indicator {0 ..} x::real) (fact k)"
  using nn_intergal_power_times_exp_Ici[of k]
  by (intro has_bochner_integral_nn_integral)
     (auto simp: nn_integral_set_ennreal split: split_indicator)

lemma has_bochner_integral_I0i_power_exp_m:
  "has_bochner_integral lborel (\<lambda>x. x^k * exp (-x) * indicator {0 <..} x::real) (fact k)"
  using AE_lborel_singleton[of 0]
  by (intro has_bochner_integral_cong_AE[THEN iffD1, OF _ _ _ has_bochner_integral_I0i_power_exp_m'])
     (auto split: split_indicator)

lemma integrable_I0i_exp_mscale: "0 < (u::real) \<Longrightarrow> set_integrable lborel {0 <..} (\<lambda>x. exp (-(x * u)))"
  using lborel_integrable_real_affine_iff[of u "\<lambda>x. indicator {0 <..} x *\<^sub>R exp (- x)" 0]
        has_bochner_integral_I0i_power_exp_m[of 0]
  by (simp add: indicator_def zero_less_mult_iff mult_ac integrable.intros set_integrable_def)

lemma LBINT_I0i_exp_mscale: "0 < (u::real) \<Longrightarrow> LBINT x=0..\<infinity>. exp (-(x * u)) = 1 / u"
  using lborel_integral_real_affine[of u "\<lambda>x. indicator {0<..} x *\<^sub>R exp (- x)" 0]
        has_bochner_integral_I0i_power_exp_m[of 0]
  by (auto simp: indicator_def zero_less_mult_iff interval_lebesgue_integral_0_infty set_lebesgue_integral_def field_simps
           dest!: has_bochner_integral_integral_eq)

lemma LBINT_I0c_exp_mscale_sin:
  "LBINT x=0..t. exp (-(u * x)) * sin x =
    (1 / (1 + u^2)) * (1 - exp (-(u * t)) * (u * sin t + cos t))" (is "_ = ?F t")
  unfolding zero_ereal_def
proof (subst interval_integral_FTC_finite)
  show "(?F has_vector_derivative exp (- (u * x)) * sin x) (at x within {min 0 t..max 0 t})" for x
    by (auto intro!: derivative_eq_intros
             simp: has_real_derivative_iff_has_vector_derivative[symmetric] power2_eq_square)
       (simp_all add: field_simps add_nonneg_eq_0_iff)
qed (auto intro: continuous_at_imp_continuous_on)

lemma LBINT_I0i_exp_mscale_sin:
  assumes "0 < x"
  shows "LBINT u=0..\<infinity>. \<bar>exp (-u * x) * sin x\<bar> = \<bar>sin x\<bar> / x"
proof (subst interval_integral_FTC_nonneg)
  let ?F = "\<lambda>u. 1 / x * (1 - exp (- u * x)) * \<bar>sin x\<bar>"
  show "\<And>t. (?F has_real_derivative \<bar>exp (- t * x) * sin x\<bar>) (at t)"
    using \<open>0 < x\<close> by (auto intro!: derivative_eq_intros simp: abs_mult)
  show "((?F \<circ> real_of_ereal) \<longlongrightarrow> 0) (at_right 0)"
    using \<open>0 < x\<close> by (auto simp: zero_ereal_def ereal_tendsto_simps intro!: tendsto_eq_intros)
  have *: "((\<lambda>t. exp (- t * x)) \<longlongrightarrow> 0) at_top"
    using \<open>0 < x\<close>
    by (auto intro!: exp_at_bot[THEN filterlim_compose] filterlim_tendsto_pos_mult_at_top filterlim_ident
             simp: filterlim_uminus_at_bot mult.commute[of _ x])
  show "((?F \<circ> real_of_ereal) \<longlongrightarrow> \<bar>sin x\<bar> / x) (at_left \<infinity>)"
    using \<open>0 < x\<close> unfolding ereal_tendsto_simps
    by (intro filterlim_compose[OF _ *]) (auto intro!: tendsto_eq_intros filterlim_ident)
qed auto

lemma
  shows integrable_inverse_1_plus_square:
      "set_integrable lborel (einterval (-\<infinity>) \<infinity>) (\<lambda>x. inverse (1 + x^2))"
  and LBINT_inverse_1_plus_square:
      "LBINT x=-\<infinity>..\<infinity>. inverse (1 + x^2) = pi"
proof -
  have 1: "- (pi / 2) < x \<Longrightarrow> x * 2 < pi \<Longrightarrow> (tan has_real_derivative 1 + (tan x)\<^sup>2) (at x)" for x
    using cos_gt_zero_pi[of x] by (subst tan_sec) (auto intro!: DERIV_tan simp: power_inverse)
  have 2: "- (pi / 2) < x \<Longrightarrow> x * 2 < pi \<Longrightarrow> isCont (\<lambda>x. 1 + (tan x)\<^sup>2) x" for x
    using cos_gt_zero_pi[of x] by auto
  have 3: "\<lbrakk>- (pi / 2) < x; x * 2 < pi\<rbrakk>  \<Longrightarrow> isCont (\<lambda>x. inverse (1 + x\<^sup>2)) (tan x)" for x
    by (rule continuous_intros | simp add: add_nonneg_eq_0_iff)+
  show "LBINT x=-\<infinity>..\<infinity>. inverse (1 + x^2) = pi"
    by (subst interval_integral_substitution_nonneg[of "-pi/2" "pi/2" tan "\<lambda>x. 1 + (tan x)^2"])
       (auto intro: derivative_eq_intros 1 2 3 filterlim_tan_at_right
             simp add: ereal_tendsto_simps filterlim_tan_at_left add_nonneg_eq_0_iff set_integrable_def)
  show "set_integrable lborel (einterval (-\<infinity>) \<infinity>) (\<lambda>x. inverse (1 + x^2))"
    by (subst interval_integral_substitution_nonneg[of "-pi/2" "pi/2" tan "\<lambda>x. 1 + (tan x)^2"])
       (auto intro: derivative_eq_intros 1 2 3 filterlim_tan_at_right
             simp add: ereal_tendsto_simps filterlim_tan_at_left add_nonneg_eq_0_iff set_integrable_def)
qed

lemma
  shows integrable_I0i_1_div_plus_square:
    "interval_lebesgue_integrable lborel 0 \<infinity> (\<lambda>x. 1 / (1 + x^2))"
  and LBINT_I0i_1_div_plus_square:
    "LBINT x=0..\<infinity>. 1 / (1 + x^2) = pi / 2"
proof -
  have 1: "0 < x \<Longrightarrow> x * 2 < pi \<Longrightarrow> (tan has_real_derivative 1 + (tan x)\<^sup>2) (at x)" for x
    using cos_gt_zero_pi[of x] by (subst tan_sec) (auto intro!: DERIV_tan simp: power_inverse)
  have 2: "0 < x \<Longrightarrow> x * 2 < pi \<Longrightarrow> isCont (\<lambda>x. 1 + (tan x)\<^sup>2) x" for x
    using cos_gt_zero_pi[of x] by auto
  show "LBINT x=0..\<infinity>. 1 / (1 + x^2) = pi / 2"
    by (subst interval_integral_substitution_nonneg[of "0" "pi/2" tan "\<lambda>x. 1 + (tan x)^2"])
       (auto intro: derivative_eq_intros 1 2 tendsto_eq_intros
             simp add: ereal_tendsto_simps filterlim_tan_at_left zero_ereal_def add_nonneg_eq_0_iff set_integrable_def)
  show "interval_lebesgue_integrable lborel 0 \<infinity> (\<lambda>x. 1 / (1 + x^2))"
    unfolding interval_lebesgue_integrable_def
    by (subst interval_integral_substitution_nonneg[of "0" "pi/2" tan "\<lambda>x. 1 + (tan x)^2"])
       (auto intro: derivative_eq_intros 1 2 tendsto_eq_intros
             simp add: ereal_tendsto_simps filterlim_tan_at_left zero_ereal_def add_nonneg_eq_0_iff set_integrable_def)
qed

section \<open>The sinc function, and the sine integral (Si)\<close>

abbreviation sinc :: "real \<Rightarrow> real" where
  "sinc \<equiv> (\<lambda>x. if x = 0 then 1 else sin x / x)"

lemma sinc_at_0: "((\<lambda>x. sin x / x::real) \<longlongrightarrow> 1) (at 0)"
  using DERIV_sin [of 0] by (auto simp add: has_field_derivative_def field_has_derivative_at)

lemma isCont_sinc: "isCont sinc x"
proof cases
  assume "x = 0" then show ?thesis
    using LIM_equal [where g = "\<lambda>x. sin x / x" and a=0 and f=sinc and l=1]
    by (auto simp: isCont_def sinc_at_0)
next
  assume "x \<noteq> 0" show ?thesis
    by (rule continuous_transform_within [where d = "abs x" and f = "\<lambda>x. sin x / x"])
       (auto simp add: dist_real_def \<open>x \<noteq> 0\<close>)
qed

lemma continuous_on_sinc[continuous_intros]:
  "continuous_on S f \<Longrightarrow> continuous_on S (\<lambda>x. sinc (f x))"
  using continuous_on_compose[of S f sinc, OF _ continuous_at_imp_continuous_on]
  by (auto simp: isCont_sinc)

lemma borel_measurable_sinc[measurable]: "sinc \<in> borel_measurable borel"
  by (intro borel_measurable_continuous_onI continuous_at_imp_continuous_on ballI isCont_sinc)

lemma sinc_AE: "AE x in lborel. sin x / x = sinc x"
  by (rule AE_I [where N = "{0}"], auto)

definition Si :: "real \<Rightarrow> real" where "Si t \<equiv> LBINT x=0..t. sin x / x"

lemma sinc_neg [simp]: "sinc (- x) = sinc x"
  by auto

(* TODO: Determine whether this can reasonably be eliminated by redefining Si. *)
lemma Si_alt_def : "Si t = LBINT x=0..t. sinc x"
proof cases
  assume "0 \<le> t" then show ?thesis
    using AE_lborel_singleton[of 0]
    by (auto simp: Si_def intro!: interval_lebesgue_integral_cong_AE)
next
  assume "\<not> 0 \<le> t" then show ?thesis
    unfolding Si_def using AE_lborel_singleton[of 0]
    by (subst (1 2) interval_integral_endpoints_reverse)
       (auto simp: Si_def intro!: interval_lebesgue_integral_cong_AE)
qed

lemma Si_neg:
  assumes "T \<ge> 0" shows "Si (- T) = - Si T"
proof -
  have "LBINT x=ereal 0..T. -1 *\<^sub>R sinc (- x) = LBINT y= ereal (- 0)..ereal (- T). sinc y"
    by (rule interval_integral_substitution_finite [OF assms])
       (auto intro: derivative_intros continuous_at_imp_continuous_on isCont_sinc)
  also have "(LBINT x=ereal 0..T. -1 *\<^sub>R sinc (- x)) = -(LBINT x=ereal 0..T. sinc x)"
    by (subst sinc_neg) (simp_all add: interval_lebesgue_integral_uminus)
  finally have *: "-(LBINT x=ereal 0..T. sinc x) = LBINT y= ereal 0..ereal (- T). sinc y"
    by simp
  show ?thesis
    using assms unfolding Si_alt_def
    by (subst zero_ereal_def)+ (auto simp add: * [symmetric])
qed

lemma integrable_sinc':
  "interval_lebesgue_integrable lborel (ereal 0) (ereal T) (\<lambda>t. sin (t * \<theta>) / t)"
proof -
  have *: "interval_lebesgue_integrable lborel (ereal 0) (ereal T) (\<lambda>t. \<theta> * sinc (t * \<theta>))"
    by (intro interval_lebesgue_integrable_mult_right interval_integrable_isCont continuous_within_compose3 [OF isCont_sinc])
       auto
  show ?thesis
    by (rule interval_lebesgue_integrable_cong_AE[THEN iffD1, OF _ _ _ *])
       (insert AE_lborel_singleton[of 0], auto)
qed

(* TODO: need a better version of FTC2 *)
lemma DERIV_Si: "(Si has_real_derivative sinc x) (at x)"
proof -
  have "(at x within {min 0 (x - 1)..max 0 (x + 1)}) = at x"
    by (intro at_within_interior) auto
  moreover have "min 0 (x - 1) \<le> x" "x \<le> max 0 (x + 1)"
    by auto
  ultimately show ?thesis
    using interval_integral_FTC2[of "min 0 (x - 1)" 0 "max 0 (x + 1)" sinc x]
    by (auto simp: continuous_at_imp_continuous_on isCont_sinc Si_alt_def[abs_def] zero_ereal_def
                   has_real_derivative_iff_has_vector_derivative
             split del: if_split)
qed

lemma isCont_Si: "isCont Si x"
  using DERIV_Si by (rule DERIV_isCont)

lemma borel_measurable_Si[measurable]: "Si \<in> borel_measurable borel"
  by (auto intro: isCont_Si continuous_at_imp_continuous_on borel_measurable_continuous_onI)

lemma Si_at_top_LBINT:
  "((\<lambda>t. (LBINT x=0..\<infinity>. exp (-(x * t)) * (x * sin t + cos t) / (1 + x^2))) \<longlongrightarrow> 0) at_top"
proof -
  let ?F = "\<lambda>x t. exp (- (x * t)) * (x * sin t + cos t) / (1 + x\<^sup>2) :: real"
  have int: "set_integrable lborel {0<..} (\<lambda>x. exp (- x) * (x + 1) :: real)"
    unfolding distrib_left
    using has_bochner_integral_I0i_power_exp_m[of 0] has_bochner_integral_I0i_power_exp_m[of 1]
    by (intro set_integral_add) (auto dest!: integrable.intros simp: ac_simps set_integrable_def)

  have "((\<lambda>t::real. LBINT x:{0<..}. ?F x t) \<longlongrightarrow> LBINT x::real:{0<..}. 0) at_top"
    unfolding set_lebesgue_integral_def
  proof (rule integral_dominated_convergence_at_top[OF _ _ int [unfolded set_integrable_def]],
         simp_all del: abs_divide split: split_indicator)
    have *: "0 < x \<Longrightarrow> \<bar>x * sin t + cos t\<bar> / (1 + x\<^sup>2) \<le> (x * 1 + 1) / 1" for x t :: real
      by (intro frac_le abs_triangle_ineq[THEN order_trans] add_mono)
         (auto simp add: abs_mult simp del: mult_1_right intro!: mult_mono)
    then have "1 \<le> t \<Longrightarrow> 0 < x \<Longrightarrow> \<bar>?F x t\<bar> \<le> exp (- x) * (x + 1)" for x t :: real
        by (auto simp add: abs_mult times_divide_eq_right[symmetric] simp del: times_divide_eq_right
                 intro!:  mult_mono)
    then show "\<forall>\<^sub>F i in at_top. AE x in lborel. 0 < x \<longrightarrow> \<bar>?F x i\<bar> \<le> exp (- x) * (x + 1)"
      by (auto intro: eventually_mono eventually_ge_at_top[of "1::real"])
    show "AE x in lborel. 0 < x \<longrightarrow> (?F x \<longlongrightarrow> 0) at_top"
    proof (intro always_eventually impI allI)
      fix x :: real assume "0 < x"
      show "((\<lambda>t. exp (- (x * t)) * (x * sin t + cos t) / (1 + x\<^sup>2)) \<longlongrightarrow> 0) at_top"
      proof (rule Lim_null_comparison)
        show "\<forall>\<^sub>F t in at_top. norm (?F x t) \<le> exp (- (x * t)) * (x + 1)"
          using eventually_ge_at_top[of "1::real"] * \<open>0 < x\<close>
          by (auto simp add: abs_mult times_divide_eq_right[symmetric] simp del: times_divide_eq_right
                   intro!: mult_mono elim: eventually_mono)
        show "((\<lambda>t. exp (- (x * t)) * (x + 1)) \<longlongrightarrow> 0) at_top"
          by (auto simp: filterlim_uminus_at_top [symmetric]
                   intro!: filterlim_tendsto_pos_mult_at_top[OF tendsto_const] \<open>0<x\<close> filterlim_ident
                           tendsto_mult_left_zero filterlim_compose[OF exp_at_bot])
      qed
    qed
  qed
  then show "((\<lambda>t. (LBINT x=0..\<infinity>. exp (-(x * t)) * (x * sin t + cos t) / (1 + x^2))) \<longlongrightarrow> 0) at_top"
    by (simp add: interval_lebesgue_integral_0_infty set_lebesgue_integral_def)
qed

lemma Si_at_top_integrable:
  assumes "t \<ge> 0"
  shows "interval_lebesgue_integrable lborel 0 \<infinity> (\<lambda>x. exp (- (x * t)) * (x * sin t + cos t) / (1 + x\<^sup>2))"
  using \<open>0 \<le> t\<close> unfolding le_less
proof
  assume "0 = t" then show ?thesis
    using integrable_I0i_1_div_plus_square by simp
next
  assume [arith]: "0 < t"
  have *: "0 \<le> a \<Longrightarrow> 0 < x \<Longrightarrow> a / (1 + x\<^sup>2) \<le> a" for a x :: real
    using zero_le_power2[of x, arith] using divide_left_mono[of 1 "1+x\<^sup>2" a] by auto
  have "set_integrable lborel {0<..} (\<lambda>x. (exp (- x) * x) * (sin t/t) + exp (- x) * cos t)"
    using has_bochner_integral_I0i_power_exp_m[of 0] has_bochner_integral_I0i_power_exp_m[of 1]
    by (intro set_integral_add set_integrable_mult_left)
       (auto dest!: integrable.intros simp: ac_simps set_integrable_def)
  from lborel_integrable_real_affine[OF this [unfolded set_integrable_def], of t 0]
  show ?thesis
    unfolding interval_lebesgue_integral_0_infty set_integrable_def
    by (rule Bochner_Integration.integrable_bound) (auto simp: field_simps * split: split_indicator)
qed

lemma Si_at_top: "(Si \<longlongrightarrow> pi / 2) at_top"
proof -
  have \<dagger>: "\<forall>\<^sub>F t in at_top. pi / 2 - (LBINT u=0..\<infinity>. exp (-(u * t)) * (u * sin t + cos t) / (1 + u^2)) = Si t"
    using eventually_ge_at_top[of 0]
  proof eventually_elim
    fix t :: real assume "t \<ge> 0"
    have "Si t = LBINT x=0..t. sin x * (LBINT u=0..\<infinity>. exp (-(u * x)))"
      unfolding Si_def using \<open>0 \<le> t\<close>
      by (intro interval_integral_discrete_difference[where X="{0}"]) (auto simp: LBINT_I0i_exp_mscale)
    also have "\<dots> = LBINT x. (LBINT u=ereal 0..\<infinity>. indicator {0 <..< t} x *\<^sub>R sin x * exp (-(u * x)))"
      using \<open>0\<le>t\<close> by (simp add: zero_ereal_def interval_lebesgue_integral_le_eq mult_ac set_lebesgue_integral_def)
    also have "\<dots> = LBINT x. (LBINT u. indicator ({0<..} \<times> {0 <..< t}) (u, x) *\<^sub>R (sin x * exp (-(u * x))))"
      apply (subst interval_integral_Ioi)
      unfolding set_lebesgue_integral_def  by(simp_all add: indicator_times ac_simps )
    also have "\<dots> = LBINT u. (LBINT x. indicator ({0<..} \<times> {0 <..< t}) (u, x) *\<^sub>R (sin x * exp (-(u * x))))"
    proof (intro lborel_pair.Fubini_integral[symmetric] lborel_pair.Fubini_integrable)
      show "(\<lambda>(x, y). indicator ({0<..} \<times> {0<..<t}) (y, x) *\<^sub>R (sin x * exp (- (y * x))))
          \<in> borel_measurable (lborel \<Otimes>\<^sub>M lborel)" (is "?f \<in> borel_measurable _")
        by measurable

      have "AE x in lborel. indicator {0..t} x *\<^sub>R abs (sinc x) = LBINT y. norm (?f (x, y))"
        using AE_lborel_singleton[of 0] AE_lborel_singleton[of t]
      proof eventually_elim
        fix x :: real assume x: "x \<noteq> 0" "x \<noteq> t"
        have "LBINT y. \<bar>indicator ({0<..} \<times> {0<..<t}) (y, x) *\<^sub>R (sin x * exp (- (y * x)))\<bar> =
            LBINT y. \<bar>sin x\<bar> * exp (- (y * x)) * indicator {0<..} y * indicator {0<..<t} x"
          by (intro Bochner_Integration.integral_cong) (auto split: split_indicator simp: abs_mult)
        also have "\<dots> = \<bar>sin x\<bar> * indicator {0<..<t} x * (LBINT y=0..\<infinity>.  exp (- (y * x)))"
          by (cases "x > 0")
             (auto simp: field_simps interval_lebesgue_integral_0_infty set_lebesgue_integral_def split: split_indicator)
        also have "\<dots> = \<bar>sin x\<bar> * indicator {0<..<t} x * (1 / x)"
          by (cases "x > 0") (auto simp add: LBINT_I0i_exp_mscale)
        also have "\<dots> = indicator {0..t} x *\<^sub>R \<bar>sinc x\<bar>"
          using x by (simp add: field_simps split: split_indicator)
        finally show "indicator {0..t} x *\<^sub>R abs (sinc x) = LBINT y. norm (?f (x, y))"
          by simp
      qed
      moreover have "integrable lborel (\<lambda>x. indicat_real {0..t} x *\<^sub>R \<bar>sinc x\<bar>)"
        by (auto intro!: borel_integrable_compact continuous_intros simp del: real_scaleR_def)
      ultimately show "integrable lborel (\<lambda>x. LBINT y. norm (?f (x, y)))"
        by (rule integrable_cong_AE_imp[rotated 2]) simp

      have "0 < x \<Longrightarrow> set_integrable lborel {0<..} (\<lambda>y. sin x * exp (- (y * x)))" for x :: real
          by (intro set_integrable_mult_right integrable_I0i_exp_mscale)
      then show "AE x in lborel. integrable lborel (\<lambda>y. ?f (x, y))"
        by (intro AE_I2) (auto simp: indicator_times set_integrable_def split: split_indicator)
    qed
    also have "... = LBINT u=0..\<infinity>. (LBINT x=0..t. exp (-(u * x)) * sin x)"
      using \<open>0\<le>t\<close>
      by (auto simp: interval_lebesgue_integral_def set_lebesgue_integral_def zero_ereal_def ac_simps
               split: split_indicator intro!: Bochner_Integration.integral_cong)
    also have "\<dots> = LBINT u=0..\<infinity>. 1 / (1 + u\<^sup>2) - 1 / (1 + u\<^sup>2) * (exp (- (u * t)) * (u * sin t + cos t))"
      by (auto simp: divide_simps LBINT_I0c_exp_mscale_sin intro!: interval_integral_cong)
    also have "... = pi / 2 - (LBINT u=0..\<infinity>. exp (- (u * t)) * (u * sin t + cos t) / (1 + u^2))"
      using Si_at_top_integrable[OF \<open>0\<le>t\<close>] by (simp add: integrable_I0i_1_div_plus_square LBINT_I0i_1_div_plus_square)
    finally show "pi / 2 - (LBINT u=0..\<infinity>. exp (-(u * t)) * (u * sin t + cos t) / (1 + u^2)) = Si t" ..
  qed
  show ?thesis
    by (rule Lim_transform_eventually [OF _ \<dagger>])
       (auto intro!: tendsto_eq_intros Si_at_top_LBINT)
qed

subsection \<open>The final theorems: boundedness and scalability\<close>

lemma bounded_Si: "\<exists>B. \<forall>T. \<bar>Si T\<bar> \<le> B"
proof -
  have *: "0 \<le> y \<Longrightarrow> dist x y < z \<Longrightarrow> abs x \<le> y + z" for x y z :: real
    by (simp add: dist_real_def)

  have "eventually (\<lambda>T. dist (Si T) (pi / 2) < 1) at_top"
    using Si_at_top by (elim tendstoD) simp
  then have "eventually (\<lambda>T. 0 \<le> T \<and> \<bar>Si T\<bar> \<le> pi / 2 + 1) at_top"
    using eventually_ge_at_top[of 0] by eventually_elim (insert *[of "pi/2" "Si _" 1], auto)
  then have "\<exists>T. 0 \<le> T \<and> (\<forall>t \<ge> T. \<bar>Si t\<bar> \<le> pi / 2 + 1)"
    by (auto simp add: eventually_at_top_linorder)
  then obtain T where T: "0 \<le> T" "\<And>t. t \<ge> T \<Longrightarrow> \<bar>Si t\<bar> \<le> pi / 2 + 1"
    by auto
  moreover have "t \<le> - T \<Longrightarrow> \<bar>Si t\<bar> \<le> pi / 2 + 1" for t
    using T(1) T(2)[of "-t"] Si_neg[of "- t"] by simp
  moreover have "\<exists>M. \<forall>t. -T \<le> t \<and> t \<le> T \<longrightarrow> \<bar>Si t\<bar> \<le> M"
    by (rule isCont_bounded) (auto intro!: isCont_Si continuous_intros \<open>0 \<le> T\<close>)
  then obtain M where M: "\<And>t. -T \<le> t \<and> t \<le> T \<Longrightarrow> \<bar>Si t\<bar> \<le> M"
    by auto
  ultimately show ?thesis
    by (intro exI[of _ "max M (pi/2 + 1)"]) (meson le_max_iff_disj linorder_not_le order_le_less)
qed

lemma LBINT_I0c_sin_scale_divide:
  assumes "T \<ge> 0"
  shows "LBINT t=0..T. sin (t * \<theta>) / t = sgn \<theta> * Si (T * \<bar>\<theta>\<bar>)"
proof -
  { assume "0 < \<theta>"
    have "(LBINT t=ereal 0..T. sin (t * \<theta>) / t) = (LBINT t=ereal 0..T. \<theta> *\<^sub>R sinc (t * \<theta>))"
      by (rule interval_integral_discrete_difference[of "{0}"]) auto
    also have "\<dots> = (LBINT t=ereal (0 * \<theta>)..T * \<theta>. sinc t)"
      apply (rule interval_integral_substitution_finite [OF assms])
      apply (subst mult.commute, rule DERIV_subset)
      by (auto intro!: derivative_intros continuous_at_imp_continuous_on isCont_sinc)
    also have "\<dots> = (LBINT t=ereal (0 * \<theta>)..T * \<theta>. sin t / t)"
      by (rule interval_integral_discrete_difference[of "{0}"]) auto
    finally have "(LBINT t=ereal 0..T. sin (t * \<theta>) / t) = (LBINT t=ereal 0..T * \<theta>. sin t / t)"
      by simp
    hence "LBINT x. indicator {0<..<T} x * sin (x * \<theta>) / x =
        LBINT x. indicator {0<..<T * \<theta>} x * sin x / x"
      using assms \<open>0 < \<theta>\<close> unfolding interval_lebesgue_integral_def einterval_eq zero_ereal_def
        by (auto simp: ac_simps set_lebesgue_integral_def)
  } note aux1 = this
  { assume "0 > \<theta>"
    have [simp]: "integrable lborel (\<lambda>x. sin (x * \<theta>) * indicator {0<..<T} x / x)"
      using integrable_sinc' [of T \<theta>] assms
      by (simp add: interval_lebesgue_integrable_def set_integrable_def ac_simps)
    have "(LBINT t=ereal 0..T. sin (t * -\<theta>) / t) = (LBINT t=ereal 0..T. -\<theta> *\<^sub>R sinc (t * -\<theta>))"
      by (rule interval_integral_discrete_difference[of "{0}"]) auto
    also have "\<dots> = (LBINT t=ereal (0 * -\<theta>)..T * -\<theta>. sinc t)"
      apply (rule interval_integral_substitution_finite [OF assms])
      apply (subst mult.commute, rule DERIV_subset)
      by (auto intro!: derivative_intros continuous_at_imp_continuous_on isCont_sinc)
    also have "\<dots> = (LBINT t=ereal (0 * -\<theta>)..T * -\<theta>. sin t / t)"
      by (rule interval_integral_discrete_difference[of "{0}"]) auto
    finally have "(LBINT t=ereal 0..T. sin (t * -\<theta>) / t) = (LBINT t=ereal 0..T * -\<theta>. sin t / t)"
      by simp
    hence "LBINT x. indicator {0<..<T} x * sin (x * \<theta>) / x =
       - (LBINT x. indicator {0<..<- (T * \<theta>)} x * sin x / x)"
      using assms \<open>0 > \<theta>\<close> unfolding interval_lebesgue_integral_def einterval_eq zero_ereal_def
        by (auto simp add: field_simps mult_le_0_iff set_lebesgue_integral_def split: if_split_asm)
  } note aux2 = this
  show ?thesis
    using assms unfolding Si_def interval_lebesgue_integral_def set_lebesgue_integral_def sgn_real_def einterval_eq zero_ereal_def
    by (auto simp: aux1 aux2)
qed

end


(*
  File: RealTopology.thy
  Author: Bohua Zhan

  Topology on real numbers.
*)

theory RealTopology
  imports Real Connected
begin

section \<open>Open intervals\<close>

lemma open_interval_to_abs [rewrite]:
  "is_ord_ring(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> a \<in>. R \<Longrightarrow> y \<in> open_interval(R,x -\<^sub>R a, x +\<^sub>R a) \<longleftrightarrow> (y \<in>. R \<and> \<bar>y -\<^sub>R x\<bar>\<^sub>R <\<^sub>R a)"
@proof
  @contradiction
  @have "y -\<^sub>R x <\<^sub>R a" @have "y -\<^sub>R x >\<^sub>R -\<^sub>R a"
@qed

section \<open>Topology on real numbers\<close>

lemma real_topology_is_openD [backward]:
  "is_open(\<real>,U) \<Longrightarrow> x \<in> U \<Longrightarrow> \<exists>c>\<^sub>\<real>\<zero>\<^sub>\<real>. \<forall>y\<in>.\<real>. \<bar>y -\<^sub>\<real> x\<bar>\<^sub>\<real> <\<^sub>\<real> c \<longrightarrow> y \<in> U"
@proof
  @obtain a b where "x \<in> open_interval(\<real>,a,b)" "open_interval(\<real>,a,b) \<subseteq> U"
  @have "x -\<^sub>\<real> a >\<^sub>\<real> \<zero>\<^sub>\<real>"
  @obtain c where "c >\<^sub>\<real> \<zero>\<^sub>\<real>" "c <\<^sub>\<real> min(\<real>, x -\<^sub>\<real> a, b -\<^sub>\<real> x)"
  @have "open_interval(\<real>, x -\<^sub>\<real> c, x +\<^sub>\<real> c) \<subseteq> open_interval(\<real>,a,b)"
  @have "\<forall>y\<in>.\<real>. \<bar>y -\<^sub>\<real> x\<bar>\<^sub>\<real> <\<^sub>\<real> c \<longrightarrow> y \<in> U" @with
    @have "y \<in> open_interval(\<real>, x -\<^sub>\<real> c, x +\<^sub>\<real> c)" @end
@qed

lemma real_topology_is_openD_less [backward]:
  "is_open(\<real>,U) \<Longrightarrow> x \<in> U \<Longrightarrow> d >\<^sub>\<real> \<zero>\<^sub>\<real> \<Longrightarrow> \<exists>c>\<^sub>\<real>\<zero>\<^sub>\<real>. c \<le>\<^sub>\<real> d \<and> (\<forall>y\<in>.\<real>. \<bar>y -\<^sub>\<real> x\<bar>\<^sub>\<real> <\<^sub>\<real> c \<longrightarrow> y \<in> U)"
@proof
  @obtain c where "c >\<^sub>\<real> \<zero>\<^sub>\<real>" "\<forall>y\<in>.\<real>. \<bar>y -\<^sub>\<real> x\<bar>\<^sub>\<real> <\<^sub>\<real> c \<longrightarrow> y \<in> U"
  @have "\<forall>y\<in>.\<real>. \<bar>y -\<^sub>\<real> x\<bar>\<^sub>\<real> <\<^sub>\<real> min(\<real>,c,d) \<longrightarrow> y \<in> U"
@qed

lemma real_topology_is_openI [forward]:
  "U \<subseteq> real \<Longrightarrow> \<forall>x\<in>U. \<exists>c>\<^sub>\<real>\<zero>\<^sub>\<real>. \<forall>y\<in>.\<real>. \<bar>y -\<^sub>\<real> x\<bar>\<^sub>\<real> <\<^sub>\<real> c \<longrightarrow> y \<in> U \<Longrightarrow> is_open(\<real>,U)"
@proof
  @have "\<forall>x\<in>U. \<exists>a b. x \<in> open_interval(\<real>,a,b) \<and> open_interval(\<real>,a,b) \<subseteq> U" @with
    @obtain c where "c >\<^sub>\<real> \<zero>\<^sub>\<real>" "\<forall>y\<in>.\<real>. \<bar>y -\<^sub>\<real> x\<bar>\<^sub>\<real> <\<^sub>\<real> c \<longrightarrow> y \<in> U"
    @have "x \<in> open_interval(\<real>,x -\<^sub>\<real> c, x +\<^sub>\<real> c)"
    @have "\<forall>y\<in>open_interval(\<real>,x -\<^sub>\<real> c, x +\<^sub>\<real> c). y \<in> U" @end
@qed

section \<open>Topology on real2\<close>

definition real2 :: i where [rewrite_bidir]:
  "real2 = real \<times> real"

definition real2_topology :: i  ("\<real>\<^sup>2") where [rewrite]:
  "\<real>\<^sup>2 = \<real> \<times>\<^sub>T \<real>"

lemma real2_topology_type [typing]: "\<real>\<^sup>2 \<in> raw_top_spaces(real2)" by auto2
lemma real2_topology_is_top_space [forward]: "is_top_space(\<real>\<^sup>2)" by auto2

abbreviation real2_dist_bound :: "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o" where
  "real2_dist_bound(x,y,c) \<equiv> \<bar>fst(y) -\<^sub>\<real> fst(x)\<bar>\<^sub>\<real> <\<^sub>\<real> c \<and> \<bar>snd(y) -\<^sub>\<real> snd(x)\<bar>\<^sub>\<real> <\<^sub>\<real> c"

lemma real2_topology_is_openI [forward]:
  "U \<subseteq> real2 \<Longrightarrow> \<forall>x\<in>U. \<exists>c>\<^sub>\<real>\<zero>\<^sub>\<real>. \<forall>y\<in>.\<real>\<^sup>2. real2_dist_bound(x,y,c) \<longrightarrow> y \<in> U \<Longrightarrow> is_open(\<real>\<^sup>2, U)"
@proof
  @have "\<forall>x\<in>U. \<exists>V W. is_open(\<real>,V) \<and> is_open(\<real>,W) \<and> x \<in>V\<times>W \<and> V\<times>W \<subseteq> U" @with
    @obtain c where "c >\<^sub>\<real> \<zero>\<^sub>\<real>" "\<forall>y\<in>.\<real>\<^sup>2. real2_dist_bound(x,y,c) \<longrightarrow> y \<in> U"
    @let "V = open_interval(\<real>, fst(x) -\<^sub>\<real> c, fst(x) +\<^sub>\<real> c)"
    @let "W = open_interval(\<real>, snd(x) -\<^sub>\<real> c, snd(x) +\<^sub>\<real> c)"
    @have "\<forall>y\<in>V \<times> W. y \<in> U" @with @have "real2_dist_bound(x,y,c)" @end
    @have "is_open(\<real>,V)" @have "is_open(\<real>,W)" @end
@qed

lemma real2_topology_is_openD [backward]:
  "is_open(\<real>\<^sup>2, U) \<Longrightarrow> x \<in> U \<Longrightarrow> \<exists>c>\<^sub>\<real>\<zero>\<^sub>\<real>. \<forall>y\<in>.\<real>\<^sup>2. real2_dist_bound(x,y,c) \<longrightarrow> y \<in> U"
@proof
  @obtain V W where "is_open(\<real>,V)" "is_open(\<real>,W)" "x \<in> V\<times>W" "V\<times>W \<subseteq> U"
  @obtain c' where "c' >\<^sub>\<real> \<zero>\<^sub>\<real>" "\<forall>y1\<in>.\<real>. \<bar>y1 -\<^sub>\<real> fst(x)\<bar>\<^sub>\<real> <\<^sub>\<real> c' \<longrightarrow> y1 \<in> V"
  @obtain c where "c >\<^sub>\<real> \<zero>\<^sub>\<real>" "c \<le>\<^sub>\<real> c'" "\<forall>y2\<in>.\<real>. \<bar>y2 -\<^sub>\<real> snd(x)\<bar>\<^sub>\<real> <\<^sub>\<real> c \<longrightarrow> y2 \<in> W"
  @have "\<forall>y\<in>.\<real>\<^sup>2. real2_dist_bound(x,y,c) \<longrightarrow> y \<in> U" @with
    @have "\<bar>fst(y) -\<^sub>\<real> fst(x)\<bar>\<^sub>\<real> <\<^sub>\<real> c'" @have "y \<in> V \<times> W" @end
@qed
setup {* del_prfstep_thm @{thm real2_topology_def} *}
setup {* add_rewrite_rule_back @{thm real2_topology_def} *}

section \<open>Continuous maps on the reals\<close>

definition real_fun :: "i \<Rightarrow> o" where [rewrite]:
  "real_fun(f) \<longleftrightarrow> (f \<in> \<real> \<rightharpoonup> \<real>)"

definition real_continuous_at :: "i \<Rightarrow> i \<Rightarrow> o" where [rewrite]:
  "real_continuous_at(f,x) \<longleftrightarrow> (\<forall>c>\<^sub>\<real>\<zero>\<^sub>\<real>. \<exists>d>\<^sub>\<real>\<zero>\<^sub>\<real>. \<forall>y\<in>.\<real>. \<bar>y -\<^sub>\<real> x\<bar>\<^sub>\<real> <\<^sub>\<real> d \<longrightarrow> \<bar>f`y -\<^sub>\<real> f`x\<bar>\<^sub>\<real> <\<^sub>\<real> c)"
setup {* register_wellform_data ("real_continuous_at(f,x)", ["x \<in>. \<real>"]) *}

lemma real_continuous_atD [backward2]:
  "real_continuous_at(f,x) \<Longrightarrow> c >\<^sub>\<real> \<zero>\<^sub>\<real> \<Longrightarrow> \<exists>d>\<^sub>\<real>\<zero>\<^sub>\<real>. \<forall>y\<in>.\<real>. \<bar>y -\<^sub>\<real> x\<bar>\<^sub>\<real> <\<^sub>\<real> d \<longrightarrow> \<bar>f`y -\<^sub>\<real> f`x\<bar>\<^sub>\<real> <\<^sub>\<real> c" by auto2

lemma real_continuous_atI [forward]:
  "\<forall>c>\<^sub>\<real>\<zero>\<^sub>\<real>. \<exists>d>\<^sub>\<real>\<zero>\<^sub>\<real>. \<forall>y\<in>.\<real>. \<bar>y -\<^sub>\<real> x\<bar>\<^sub>\<real> <\<^sub>\<real> d \<longrightarrow> \<bar>f`y -\<^sub>\<real> f`x\<bar>\<^sub>\<real> <\<^sub>\<real> c \<Longrightarrow> real_continuous_at(f,x)" by auto2
setup {* del_prfstep_thm @{thm real_continuous_at_def} *}

lemma real_fun_continuousI [forward]:
  "real_fun(f) \<Longrightarrow> \<forall>x\<in>.\<real>. real_continuous_at(f,x) \<Longrightarrow> continuous(f)"
@proof
  @have "\<forall>V\<in>open_sets(\<real>). is_open(\<real>, f -`` V)" @with
    @let "U = f -`` V" @have "U \<subseteq> real"
    @have "\<forall>x\<in>U. (\<exists>d>\<^sub>\<real>\<zero>\<^sub>\<real>. \<forall>y\<in>.\<real>. \<bar>y -\<^sub>\<real> x\<bar>\<^sub>\<real> <\<^sub>\<real> d \<longrightarrow> y \<in> U)" @with
      @obtain c where "c >\<^sub>\<real> \<zero>\<^sub>\<real>" "\<forall>y\<in>.\<real>. \<bar>y -\<^sub>\<real> f`x\<bar>\<^sub>\<real> <\<^sub>\<real> c \<longrightarrow> y \<in> V"
      @obtain d where "d >\<^sub>\<real> \<zero>\<^sub>\<real>" "\<forall>y\<in>.\<real>. \<bar>y -\<^sub>\<real> x\<bar>\<^sub>\<real> <\<^sub>\<real> d \<longrightarrow> \<bar>f`y -\<^sub>\<real> f`x\<bar>\<^sub>\<real> <\<^sub>\<real> c"
      @have "\<forall>y\<in>.\<real>. \<bar>y -\<^sub>\<real> x\<bar>\<^sub>\<real> <\<^sub>\<real> d \<longrightarrow> y \<in> U" @with @have "f`y \<in> V" @end
    @end
  @end
@qed

lemma real_fun_continuousD [resolve]:
  "real_fun(f) \<Longrightarrow> continuous(f) \<Longrightarrow> x \<in>. \<real> \<Longrightarrow> real_continuous_at(f,x)"
@proof
  @have "\<forall>c>\<^sub>\<real>\<zero>\<^sub>\<real>. \<exists>d>\<^sub>\<real>\<zero>\<^sub>\<real>. \<forall>y\<in>.\<real>. \<bar>y -\<^sub>\<real> x\<bar>\<^sub>\<real> <\<^sub>\<real> d \<longrightarrow> \<bar>f`y -\<^sub>\<real> f`x\<bar>\<^sub>\<real> <\<^sub>\<real> c" @with
    @let "V = open_interval(\<real>, f`x -\<^sub>\<real> c, f`x +\<^sub>\<real> c)"
    @obtain d where "d >\<^sub>\<real> \<zero>\<^sub>\<real>" "\<forall>y\<in>.\<real>. \<bar>y -\<^sub>\<real> x\<bar>\<^sub>\<real> <\<^sub>\<real> d \<longrightarrow> y \<in> f -`` V"
    @have "\<forall>y\<in>.\<real>. \<bar>y -\<^sub>\<real> x\<bar>\<^sub>\<real> <\<^sub>\<real> d \<longrightarrow> \<bar>f`y -\<^sub>\<real> f`x\<bar>\<^sub>\<real> <\<^sub>\<real> c" @with @have "f`y \<in> V" @end
  @end
@qed

lemma real_fun_continuousD' [backward]:
  "real_fun(f) \<Longrightarrow> continuous(f) \<Longrightarrow> x \<in>. \<real> \<Longrightarrow> c >\<^sub>\<real> \<zero>\<^sub>\<real> \<Longrightarrow>
   \<exists>d>\<^sub>\<real>\<zero>\<^sub>\<real>. \<forall>y\<in>.\<real>. \<bar>y -\<^sub>\<real> x\<bar>\<^sub>\<real> <\<^sub>\<real> d \<longrightarrow> \<bar>f`y -\<^sub>\<real> f`x\<bar>\<^sub>\<real> <\<^sub>\<real> c"
@proof @have "real_continuous_at(f,x)" @qed

section \<open>Continuous maps from real2 to real\<close>

definition real2_continuous_at :: "i \<Rightarrow> i \<Rightarrow> o" where [rewrite]:
  "real2_continuous_at(f,x) \<longleftrightarrow> (\<forall>c>\<^sub>\<real>\<zero>\<^sub>\<real>. \<exists>d>\<^sub>\<real>\<zero>\<^sub>\<real>. \<forall>y\<in>.\<real>\<^sup>2. real2_dist_bound(x,y,d) \<longrightarrow> \<bar>f`y -\<^sub>\<real> f`x\<bar>\<^sub>\<real> <\<^sub>\<real> c)"
setup {* register_wellform_data ("real2_continuous_at(f,x)", ["x \<in>. \<real>\<^sup>2"]) *}

lemma real2_continuous_atD [backward2]:
  "real2_continuous_at(f,x) \<Longrightarrow> c >\<^sub>\<real> \<zero>\<^sub>\<real> \<Longrightarrow>
   \<exists>d>\<^sub>\<real>\<zero>\<^sub>\<real>. \<forall>y\<in>.\<real>\<^sup>2. real2_dist_bound(x,y,d) \<longrightarrow> \<bar>f`y -\<^sub>\<real> f`x\<bar>\<^sub>\<real> <\<^sub>\<real> c" by auto2

lemma real2_continuous_atI [forward]:
  "\<forall>c>\<^sub>\<real>\<zero>\<^sub>\<real>. \<exists>d>\<^sub>\<real>\<zero>\<^sub>\<real>. \<forall>y\<in>.\<real>\<^sup>2. real2_dist_bound(x,y,d) \<longrightarrow> \<bar>f`y -\<^sub>\<real> f`x\<bar>\<^sub>\<real> <\<^sub>\<real> c \<Longrightarrow> real2_continuous_at(f,x)" by auto2
setup {* del_prfstep_thm @{thm real2_continuous_at_def} *}

lemma real2_fun_continuousI [forward]:
  "f \<in> \<real>\<^sup>2 \<rightharpoonup> \<real> \<Longrightarrow> \<forall>x\<in>.\<real>\<^sup>2. real2_continuous_at(f,x) \<Longrightarrow> continuous(f)"
@proof
  @have "\<forall>V\<in>open_sets(\<real>). is_open(\<real>\<^sup>2, f -`` V)" @with
    @let "U = f -`` V" @have "U \<subseteq> real2"
    @have "\<forall>x\<in>U. \<exists>d>\<^sub>\<real>\<zero>\<^sub>\<real>. \<forall>y\<in>.\<real>\<^sup>2. real2_dist_bound(x,y,d) \<longrightarrow> y \<in> U" @with
      @obtain c where "c >\<^sub>\<real> \<zero>\<^sub>\<real>" "\<forall>y\<in>.\<real>. \<bar>y -\<^sub>\<real> f`x\<bar>\<^sub>\<real> <\<^sub>\<real> c \<longrightarrow> y \<in> V"
      @obtain d where "d >\<^sub>\<real> \<zero>\<^sub>\<real>" "\<forall>y\<in>.\<real>\<^sup>2. real2_dist_bound(x,y,d) \<longrightarrow> \<bar>f`y -\<^sub>\<real> f`x\<bar>\<^sub>\<real> <\<^sub>\<real> c"
      @have "\<forall>y\<in>.\<real>\<^sup>2. real2_dist_bound(x,y,d) \<longrightarrow> y \<in> U" @with @have "f`y \<in> V" @end
    @end
  @end
@qed

lemma real2_fun_continuousD [resolve]:
  "x \<in>. \<real>\<^sup>2 \<Longrightarrow> f \<in> \<real>\<^sup>2 \<rightharpoonup>\<^sub>T \<real> \<Longrightarrow> real2_continuous_at(f,x)"
@proof
  @have "\<forall>c>\<^sub>\<real>\<zero>\<^sub>\<real>. \<exists>d>\<^sub>\<real>\<zero>\<^sub>\<real>. \<forall>y\<in>.\<real>\<^sup>2. real2_dist_bound(x,y,d) \<longrightarrow> \<bar>f`y -\<^sub>\<real> f`x\<bar>\<^sub>\<real> <\<^sub>\<real> c" @with
    @let "V = open_interval(\<real>, f`x -\<^sub>\<real> c, f`x +\<^sub>\<real> c)"
    @obtain d where "d >\<^sub>\<real> \<zero>\<^sub>\<real>" "\<forall>y\<in>.\<real>\<^sup>2. real2_dist_bound(x,y,d) \<longrightarrow> y \<in> f -`` V"
    @have "\<forall>y\<in>.\<real>\<^sup>2. real2_dist_bound(x,y,d) \<longrightarrow> \<bar>f`y -\<^sub>\<real> f`x\<bar>\<^sub>\<real> <\<^sub>\<real> c" @with @have "f`y \<in> V" @end
  @end
@qed

section \<open>Continuity of addition and multiplication\<close>

definition real_add :: i where [rewrite]:
  "real_add = Mor(\<real>\<^sup>2, \<real>, \<lambda>\<langle>x,y\<rangle>. x +\<^sub>\<real> y)"

lemma real_add_type [typing]: "real_add \<in> \<real>\<^sup>2 \<rightharpoonup> \<real>" by auto2
lemma real_add_eval [rewrite]: "\<langle>x,y\<rangle> \<in> source(real_add) \<Longrightarrow> real_add`\<langle>x,y\<rangle> = x +\<^sub>\<real> y" by auto2
setup {* del_prfstep_thm @{thm real_add_def} *}

lemma real_add_continuous [forward]: "continuous(real_add)"
@proof
  @let "f = real_add"
  @have "\<forall>x\<in>.\<real>\<^sup>2. real2_continuous_at(f,x)" @with
    @have "\<forall>c>\<^sub>\<real>\<zero>\<^sub>\<real>. \<exists>d>\<^sub>\<real>\<zero>\<^sub>\<real>. \<forall>y\<in>.\<real>\<^sup>2. real2_dist_bound(x,y,d) \<longrightarrow> \<bar>f`y -\<^sub>\<real> f`x\<bar>\<^sub>\<real> <\<^sub>\<real> c" @with
      @obtain d where "d >\<^sub>\<real> \<zero>\<^sub>\<real>" "c = d +\<^sub>\<real> d"
      @have "\<forall>y\<in>.\<real>\<^sup>2. real2_dist_bound(x,y,d) \<longrightarrow> \<bar>f`y -\<^sub>\<real> f`x\<bar>\<^sub>\<real> <\<^sub>\<real> c" @with
        @have "fst(y) +\<^sub>\<real> snd(y) -\<^sub>\<real> (fst(x) +\<^sub>\<real> snd(x)) = fst(y) -\<^sub>\<real> fst(x) +\<^sub>\<real> (snd(y) -\<^sub>\<real> snd(x))" @end
    @end
  @end
@qed

definition real_neg :: i where [rewrite]:
  "real_neg = Mor(\<real>, \<real>, \<lambda>x. -\<^sub>\<real> x)"

lemma real_neg_type [typing]: "real_neg \<in> \<real> \<rightharpoonup> \<real>" by auto2
lemma real_neg_eval [rewrite]: "x \<in> source(real_neg) \<Longrightarrow> real_neg`x = -\<^sub>\<real> x" by auto2
setup {* del_prfstep_thm @{thm real_neg_def} *}

lemma real_neg_continuous [forward]: "continuous(real_neg)"
@proof
  @let "f = real_neg"
  @have "real_fun(f)"
  @have "\<forall>x\<in>.\<real>. real_continuous_at(f,x)" @with
    @have "\<forall>c>\<^sub>\<real>\<zero>\<^sub>\<real>. \<exists>d>\<^sub>\<real>\<zero>\<^sub>\<real>. \<forall>y\<in>.\<real>. \<bar>y -\<^sub>\<real> x\<bar>\<^sub>\<real> <\<^sub>\<real> d \<longrightarrow> \<bar>f`y -\<^sub>\<real> f`x\<bar>\<^sub>\<real> <\<^sub>\<real> c" @with
      @have "\<forall>y\<in>.\<real>. \<bar>y -\<^sub>\<real> x\<bar>\<^sub>\<real> <\<^sub>\<real> c \<longrightarrow> \<bar>f`y -\<^sub>\<real> f`x\<bar>\<^sub>\<real> <\<^sub>\<real> c" @with
        @have "-\<^sub>\<real> y -\<^sub>\<real> (-\<^sub>\<real> x) = -\<^sub>\<real> (y -\<^sub>\<real> x)" @end
    @end
  @end
@qed

definition real_mult :: i where [rewrite]:
  "real_mult = Mor(\<real>\<^sup>2, \<real>, \<lambda>\<langle>x,y\<rangle>. x *\<^sub>\<real> y)"

lemma real_mult_type [typing]: "real_mult \<in> \<real>\<^sup>2 \<rightharpoonup> \<real>" by auto2
lemma real_mult_eval [rewrite]: "\<langle>x,y\<rangle> \<in> source(real_mult) \<Longrightarrow> real_mult`\<langle>x,y\<rangle> = x *\<^sub>\<real> y" by auto2
setup {* del_prfstep_thm @{thm real_mult_def} *}

lemma real_mult_continuous_aux [backward]:
  "x \<in>. \<real>\<^sup>2 \<Longrightarrow> c >\<^sub>\<real> \<zero>\<^sub>\<real> \<Longrightarrow> \<exists>d>\<^sub>\<real>\<zero>\<^sub>\<real>. \<forall>y\<in>.\<real>\<^sup>2. real2_dist_bound(x,y,d) \<longrightarrow> \<bar>real_mult`y -\<^sub>\<real> real_mult`x\<bar>\<^sub>\<real> <\<^sub>\<real> c"
@proof
  @let "x1 = fst(x)" "x2 = snd(x)"
  @have "\<bar>x1\<bar>\<^sub>\<real> +\<^sub>\<real> \<bar>x2\<bar>\<^sub>\<real> +\<^sub>\<real> 1\<^sub>\<real> >\<^sub>\<real> 0\<^sub>\<real>" @with
    @have "\<bar>x1\<bar>\<^sub>\<real> +\<^sub>\<real> \<bar>x2\<bar>\<^sub>\<real> \<ge>\<^sub>\<real> 0\<^sub>\<real>" @with @have "\<bar>x1\<bar>\<^sub>\<real> \<ge>\<^sub>\<real> 0\<^sub>\<real>" @end @end
  @have "min(\<real>,1\<^sub>\<real>,c /\<^sub>\<real> (\<bar>x1\<bar>\<^sub>\<real> +\<^sub>\<real> \<bar>x2\<bar>\<^sub>\<real> +\<^sub>\<real> 1\<^sub>\<real>)) >\<^sub>\<real> 0\<^sub>\<real>"
  @obtain d where "d >\<^sub>\<real> 0\<^sub>\<real>" "d <\<^sub>\<real> min(\<real>,1\<^sub>\<real>,c /\<^sub>\<real> (\<bar>x1\<bar>\<^sub>\<real> +\<^sub>\<real> \<bar>x2\<bar>\<^sub>\<real> +\<^sub>\<real> 1\<^sub>\<real>))"
  @have "\<forall>y\<in>.\<real>\<^sup>2. real2_dist_bound(x,y,d) \<longrightarrow> \<bar>real_mult`y -\<^sub>\<real> real_mult`x\<bar>\<^sub>\<real> <\<^sub>\<real> c" @with
    @let "y1 = fst(y)" "y2 = snd(y)"
    @have "c >\<^sub>\<real> d *\<^sub>\<real> (\<bar>x1\<bar>\<^sub>\<real> +\<^sub>\<real> \<bar>x2\<bar>\<^sub>\<real> +\<^sub>\<real> 1\<^sub>\<real>)"
    @have "c >\<^sub>\<real> (\<bar>x1\<bar>\<^sub>\<real> +\<^sub>\<real> 1\<^sub>\<real>) *\<^sub>\<real> d +\<^sub>\<real> d *\<^sub>\<real> \<bar>x2\<bar>\<^sub>\<real>"
    @have "y1 *\<^sub>\<real> y2 -\<^sub>\<real> x1 *\<^sub>\<real> x2 = y1 *\<^sub>\<real> (y2 -\<^sub>\<real> x2) +\<^sub>\<real> (y1 -\<^sub>\<real> x1) *\<^sub>\<real> x2"
    @have "\<bar>y1\<bar>\<^sub>\<real> <\<^sub>\<real> \<bar>x1\<bar>\<^sub>\<real> +\<^sub>\<real> d"
    @have "\<bar>y1 *\<^sub>\<real> (y2 -\<^sub>\<real> x2)\<bar>\<^sub>\<real> <\<^sub>\<real> (\<bar>x1\<bar>\<^sub>\<real> +\<^sub>\<real> 1\<^sub>\<real>) *\<^sub>\<real> d" @end
@qed

lemma real_mult_continuous [forward]: "continuous(real_mult)"
@proof
  @let "f = real_mult"
  @have "\<forall>x\<in>.\<real>\<^sup>2. real2_continuous_at(f,x)" @with
    @have "\<forall>c>\<^sub>\<real>\<zero>\<^sub>\<real>. \<exists>d>\<^sub>\<real>\<zero>\<^sub>\<real>. \<forall>y\<in>.\<real>\<^sup>2. real2_dist_bound(x,y,d) \<longrightarrow> \<bar>f`y -\<^sub>\<real> f`x\<bar>\<^sub>\<real> <\<^sub>\<real> c" @end
@qed
setup {* del_prfstep_thm @{thm real_mult_continuous_aux} *}

lemma real_add_fun_continuous [backward]:
  "F = Mor(X,\<real>,\<lambda>x. f(x)) \<Longrightarrow> G = Mor(X,\<real>,\<lambda>x. g(x)) \<Longrightarrow>
   F \<in> X \<rightharpoonup>\<^sub>T \<real> \<Longrightarrow> G \<in> X \<rightharpoonup>\<^sub>T \<real> \<Longrightarrow> continuous(Mor(X,\<real>,\<lambda>x. f(x) +\<^sub>\<real> g(x)))"
@proof
  @have (@rule) "\<forall>x\<in>.X. F`x = f(x) \<and> G`x = g(x)"
  @have "Mor(X, \<real>, \<lambda>x. f(x) +\<^sub>\<real> g(x)) = real_add \<circ>\<^sub>m prod_top_map(F,G) \<circ>\<^sub>m diag_top_map(X)"
@qed

lemma real_mult_fun_continuous [backward]:
  "F = Mor(X,\<real>,\<lambda>x. f(x)) \<Longrightarrow> G = Mor(X,\<real>,\<lambda>x. g(x)) \<Longrightarrow>
   F \<in> X \<rightharpoonup>\<^sub>T \<real> \<Longrightarrow> G \<in> X \<rightharpoonup>\<^sub>T \<real> \<Longrightarrow> continuous(Mor(X,\<real>,\<lambda>x. f(x) *\<^sub>\<real> g(x)))"
@proof
  @have (@rule) "\<forall>x\<in>.X. F`x = f(x) \<and> G`x = g(x)"
  @have "Mor(X,\<real>,\<lambda>x. f(x) *\<^sub>\<real> g(x)) = real_mult \<circ>\<^sub>m prod_top_map(F,G) \<circ>\<^sub>m diag_top_map(X)"
@qed

lemma real_neg_fun_continuous [backward]:
  "F = Mor(X,\<real>,\<lambda>x. f(x)) \<Longrightarrow> F \<in> X \<rightharpoonup>\<^sub>T \<real> \<Longrightarrow> continuous(Mor(X,\<real>,\<lambda>x. -\<^sub>\<real> f(x)))"
@proof
  @have (@rule) "\<forall>x\<in>.X. F`x = f(x)"
  @have "Mor(X, \<real>, \<lambda>x. -\<^sub>\<real> f(x)) = real_neg \<circ>\<^sub>m F"
@qed

lemma real_minus_fun_continuous [backward]:
  "F = Mor(X,\<real>,\<lambda>x. f(x)) \<Longrightarrow> G = Mor(X,\<real>,\<lambda>x. g(x)) \<Longrightarrow>
   F \<in> X \<rightharpoonup>\<^sub>T \<real> \<Longrightarrow> G \<in> X \<rightharpoonup>\<^sub>T \<real> \<Longrightarrow> continuous(Mor(X,\<real>,\<lambda>x. f(x) -\<^sub>\<real> g(x)))"
@proof
  @have (@rule) "\<forall>x\<in>.X. F`x = f(x) \<and> G`x = g(x)"
  @have "Mor(X, \<real>, \<lambda>x. f(x) -\<^sub>\<real> g(x)) = Mor(X, \<real>, \<lambda>x. f(x) +\<^sub>\<real> (-\<^sub>\<real> g(x)))"
@qed

lemma real_divide_const_continuous [backward]:
  "F = Mor(X,\<real>,\<lambda>x. f(x)) \<Longrightarrow> F \<in> X \<rightharpoonup>\<^sub>T \<real> \<Longrightarrow> c \<in> units(\<real>) \<Longrightarrow> continuous(Mor(X,\<real>,\<lambda>x. f(x) /\<^sub>\<real> c))"
@proof
  @have (@rule) "\<forall>x\<in>.X. F`x = f(x)"
  @have "Mor(X,\<real>,\<lambda>x. f(x) /\<^sub>\<real> c) = Mor(X,\<real>,\<lambda>x. f(x) *\<^sub>\<real> (1\<^sub>\<real> /\<^sub>\<real> c))"
@qed

section \<open>Continuity and convergent sequences\<close>

lemma continuous_on_converge_seq [backward]:
  "real_fun(f) \<Longrightarrow> continuous(f) \<Longrightarrow> X \<in> seqs(\<real>) \<Longrightarrow> converges_to(X,s) \<Longrightarrow>
   Y = Seq(\<real>,\<lambda>n. f`(X`n)) \<Longrightarrow> converges_to(Y,f`s)"
@proof
  @have "\<forall>r>\<^sub>\<real>\<zero>\<^sub>\<real>. \<exists>k\<in>.\<nat>. \<forall>n\<ge>\<^sub>\<nat>k. \<bar>Y`n -\<^sub>\<real> f`s\<bar>\<^sub>\<real> <\<^sub>\<real> r" @with
    @obtain d where "d >\<^sub>\<real> \<zero>\<^sub>\<real>" "\<forall>y\<in>.\<real>. \<bar>y -\<^sub>\<real> s\<bar>\<^sub>\<real> <\<^sub>\<real> d \<longrightarrow> \<bar>f`y -\<^sub>\<real> f`s\<bar>\<^sub>\<real> <\<^sub>\<real> r"
    @obtain "k \<in>. \<nat>" where "\<forall>n\<ge>\<^sub>\<nat>k. \<bar>X`n -\<^sub>\<real> s\<bar>\<^sub>\<real> <\<^sub>\<real> d"
    @have "\<forall>n\<ge>\<^sub>\<nat>k. \<bar>Y`n -\<^sub>\<real> f`s\<bar>\<^sub>\<real> <\<^sub>\<real> r"
  @end
@qed

section \<open>Intermediate value theorem\<close>

lemma real_connected [forward]: "connected(\<real>)" by auto2

lemma real_connected_interval [resolve]:
  "a <\<^sub>\<real> b \<Longrightarrow> connected_subset(\<real>,closed_interval(\<real>,a,b))"
@proof
  @let "I = closed_interval(\<real>,a,b)"
  @let "A = ord_subspace(\<real>,I)" "B = suborder(\<real>,I)" "C = subspace(\<real>,I)"
  @have "linear_continuum(A)" @with @have "eq_str_order(A,B)" @end
  @have "eq_str_top(C,A)"
@qed

lemma intermediate_value_theorem [backward1]:
  "real_fun(f) \<Longrightarrow> continuous(f) \<Longrightarrow> a <\<^sub>\<real> b \<Longrightarrow> y \<in> closed_interval(\<real>,f`a,f`b) \<Longrightarrow>
   \<exists>x\<in>closed_interval(\<real>,a,b). f`x = y"
@proof
  @let "I = closed_interval(\<real>,a,b)"
  @have "connected_subset(\<real>,f``I)"
  @have "order_convex(\<real>,f``I)"
  @have "closed_interval(\<real>,f`a,f`b) \<subseteq> f``I"
@qed

section \<open>Rempe-Gillen's challenge\<close>

definition incr_arg_fun :: "i \<Rightarrow> o" where [rewrite]:
  "incr_arg_fun(f) \<longleftrightarrow> (let S = source_str(f) in \<forall>x\<in>.S. f`x >\<^sub>S x)"

lemma incr_arg_funD:
  "incr_arg_fun(f) \<Longrightarrow> is_morphism(f) \<Longrightarrow> S = source_str(f) \<Longrightarrow> x \<in> source(f) \<Longrightarrow> f`x >\<^sub>S x" by auto2
setup {* add_forward_prfstep_cond @{thm incr_arg_funD} [with_term "?f`?x"] *}
setup {* del_prfstep_thm_eqforward @{thm incr_arg_fun_def} *}

lemma rempe_gillen_challenge:
  "real_fun(f) \<Longrightarrow> continuous(f) \<Longrightarrow> incr_arg_fun(f) \<Longrightarrow> x0 \<in>. \<real> \<Longrightarrow>
   S = Seq(\<real>,\<lambda>n. nfold(f,n,x0)) \<Longrightarrow> \<not>upper_bounded(S)"
@proof
  @contradiction
  @have "seq_incr(S)" @with @have "\<forall>n\<in>.\<nat>. S`(n +\<^sub>\<nat> 1) \<ge>\<^sub>\<real> S`n" @end
  @obtain x where "converges_to(S,x)"
  @let "T = Seq(\<real>,\<lambda>n. f`(S`n))"
  @have "converges_to(T,f`x)"
  @have "converges_to(T,x)" @with
    @have "\<forall>r>\<^sub>\<real>\<zero>\<^sub>\<real>. \<exists>k\<in>.\<nat>. \<forall>n\<ge>\<^sub>\<nat>k. \<bar>T`n -\<^sub>\<real> x\<bar>\<^sub>\<real> <\<^sub>\<real> r" @with
      @obtain "k \<in>. \<nat>" where "\<forall>n\<ge>\<^sub>\<nat>k. \<bar>S`n -\<^sub>\<real> x\<bar>\<^sub>\<real> <\<^sub>\<real> r"
      @have "\<forall>n\<ge>\<^sub>\<nat>k. \<bar>T`n -\<^sub>\<real> x\<bar>\<^sub>\<real> <\<^sub>\<real> r" @with @have "T`n = S`(n +\<^sub>\<nat> 1)" @end @end
  @end
@qed

end