theory Chapter3
imports "~~/src/HOL/IMP/BExp"
        "~~/src/HOL/IMP/ASM"
begin

text{*
\section*{Chapter 3}

\exercise
To show that @{const asimp_const} really folds all subexpressions of the form
@{term "Plus (N i) (N j)"}, define a function
*}

fun optimal :: "aexp \<Rightarrow> bool" where
  "optimal (N _) = True" |
  "optimal (V _) = True" |
  "optimal (Plus (N _) (N _)) = False" |
  "optimal (Plus a b) = (optimal a \<and> optimal b)"

print_theorems

text{*
that checks that its argument does not contain a subexpression of the form
@{term "Plus (N i) (N j)"}. Then prove that the result of @{const asimp_const}
is optimal:
*}

lemma "optimal (asimp_const a)"
proof (induction a rule: asimp_const.induct)
  show "\<And>n. optimal (asimp_const (N n))" by simp
next
  show "\<And>v. optimal (asimp_const (V v))" by simp
next
  fix a b
  assume IH: "optimal (asimp_const a)" "optimal (asimp_const b)"
  show "optimal (asimp_const (Plus a b))"
  proof (rule asimp_const.elims)

text{*
This proof needs the same @{text "split:"} directive as the correctness proof of
@{const asimp_const}. This increases the chance of nontermination
of the simplifier. Therefore @{const optimal} should be defined purely by
pattern matching on the left-hand side,
without @{text case} expressions on the right-hand side.
\endexercise

\exercise
In this exercise we verify constant folding for @{typ aexp}
where we sum up all constants, even if they are not next to each other.
For example, @{term "Plus (N 1) (Plus (V x) (N 2))"} becomes
@{term "Plus (V x) (N 3)"}. This goes beyond @{const asimp}.
Below we follow a particular solution strategy but there are many others.

First, define a function @{text sumN} that returns the sum of all
constants in an expression and a function @{text zeroN} that replaces all
constants in an expression by zeroes (they will be optimized away later):
*}

fun sumN :: "aexp \<Rightarrow> int" where
(* your definition/proof here *)

fun zeroN :: "aexp \<Rightarrow> aexp" where
(* your definition/proof here *)

text {*
Next, define a function @{text sepN} that produces an arithmetic expression
that adds the results of @{const sumN} and @{const zeroN}. Prove that
@{text sepN} preserves the value of an expression.
*}

definition sepN :: "aexp \<Rightarrow> aexp" where
(* your definition/proof here *)

lemma aval_sepN: "aval (sepN t) s = aval t s"
(* your definition/proof here *)

text {*
Finally, define a function @{text full_asimp} that uses @{const asimp}
to eliminate the zeroes left over by @{const sepN}.
Prove that it preserves the value of an arithmetic expression.
*}

definition full_asimp :: "aexp \<Rightarrow> aexp" where
(* your definition/proof here *)

lemma aval_full_asimp: "aval (full_asimp t) s = aval t s"
(* your definition/proof here *)

text{*
\endexercise

\exercise\label{exe:subst}
Substitution is the process of replacing a variable
by an expression in an expression. Define a substitution function
*}

fun subst :: "vname \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
(* your definition/proof here *)

text{*
such that @{term "subst x a e"} is the result of replacing
every occurrence of variable @{text x} by @{text a} in @{text e}.
For example:
@{lemma[display] "subst ''x'' (N 3) (Plus (V ''x'') (V ''y'')) = Plus (N 3) (V ''y'')" by simp}

Prove the so-called \concept{substitution lemma} that says that we can either
substitute first and evaluate afterwards or evaluate with an updated state:
*}

lemma subst_lemma: "aval (subst x a e) s = aval e (s(x := aval a s))"
(* your definition/proof here *)

text {*
As a consequence prove that we can substitute equal expressions by equal expressions
and obtain the same result under evaluation:
*}
lemma "aval a1 s = aval a2 s
  \<Longrightarrow> aval (subst x a1 e) s = aval (subst x a2 e) s"
(* your definition/proof here *)

text{*
\endexercise

\exercise
Take a copy of theory @{theory AExp} and modify it as follows.
Extend type @{typ aexp} with a binary constructor @{text Times} that
represents multiplication. Modify the definition of the functions @{const aval}
and @{const asimp} accordingly. You can remove @{const asimp_const}.
Function @{const asimp} should eliminate 0 and 1 from multiplications
as well as evaluate constant subterms. Update all proofs concerned.
*}

text{*
\endexercise

\exercise
Define a datatype @{text aexp2} of extended arithmetic expressions that has,
in addition to the constructors of @{typ aexp}, a constructor for
modelling a C-like post-increment operation $x{++}$, where $x$ must be a
variable. Define an evaluation function @{text "aval2 :: aexp2 \<Rightarrow> state \<Rightarrow> val \<times> state"}
that returns both the value of the expression and the new state.
The latter is required because post-increment changes the state.

Extend @{text aexp2} and @{text aval2} with a division operation. Model partiality of
division by changing the return type of @{text aval2} to
@{typ "(val \<times> state) option"}. In case of division by 0 let @{text aval2}
return @{const None}. Division on @{typ int} is the infix @{text div}.
*}

text{*
\endexercise

\exercise
The following type adds a @{text LET} construct to arithmetic expressions:
*}

datatype lexp = Nl int | Vl vname | Plusl lexp lexp | LET vname lexp lexp

text{* The @{const LET} constructor introduces a local variable:
the value of @{term "LET x e\<^sub>1 e\<^sub>2"} is the value of @{text e\<^sub>2}
in the state where @{text x} is bound to the value of @{text e\<^sub>1} in the original state.
Define a function @{const lval} @{text"::"} @{typ "lexp \<Rightarrow> state \<Rightarrow> int"}
that evaluates @{typ lexp} expressions. Remember @{term"s(x := i)"}.

Define a conversion @{const inline} @{text"::"} @{typ "lexp \<Rightarrow> aexp"}.
The expression \mbox{@{term "LET x e\<^sub>1 e\<^sub>2"}} is inlined by substituting
the converted form of @{text e\<^sub>1} for @{text x} in the converted form of @{text e\<^sub>2}.
See Exercise~\ref{exe:subst} for more on substitution.
Prove that @{const inline} is correct w.r.t.\ evaluation.
\endexercise

\exercise
Show that equality and less-or-equal tests on @{text aexp} are definable
*}

definition Le :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
(* your definition/proof here *)

definition Eq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
(* your definition/proof here *)

text{*
and prove that they do what they are supposed to:
*}

lemma bval_Le: "bval (Le a1 a2) s = (aval a1 s \<le> aval a2 s)"
(* your definition/proof here *)

lemma bval_Eq: "bval (Eq a1 a2) s = (aval a1 s = aval a2 s)"
(* your definition/proof here *)

text{*
\endexercise

\exercise
Consider an alternative type of boolean expressions featuring a conditional: *}

datatype ifexp = Bc2 bool | If ifexp ifexp ifexp | Less2 aexp aexp

text {*  First define an evaluation function analogously to @{const bval}: *}

fun ifval :: "ifexp \<Rightarrow> state \<Rightarrow> bool" where
(* your definition/proof here *)

text{* Then define two translation functions *}

fun b2ifexp :: "bexp \<Rightarrow> ifexp" where
(* your definition/proof here *)

fun if2bexp :: "ifexp \<Rightarrow> bexp" where
(* your definition/proof here *)

text{* and prove their correctness: *}

lemma "bval (if2bexp exp) s = ifval exp s"
(* your definition/proof here *)

lemma "ifval (b2ifexp exp) s = bval exp s"
(* your definition/proof here *)

text{*
\endexercise

\exercise
We define a new type of purely boolean expressions without any arithmetic
*}

datatype pbexp =
  VAR vname | NOT pbexp | AND pbexp pbexp | OR pbexp pbexp

text{*
where variables range over values of type @{typ bool},
as can be seen from the evaluation function:
*}

fun pbval :: "pbexp \<Rightarrow> (vname \<Rightarrow> bool) \<Rightarrow> bool" where
"pbval (VAR x) s = s x"  |
"pbval (NOT b) s = (\<not> pbval b s)" |
"pbval (AND b1 b2) s = (pbval b1 s \<and> pbval b2 s)" |
"pbval (OR b1 b2) s = (pbval b1 s \<or> pbval b2 s)"

text {* Define a function that checks whether a boolean exression is in NNF
(negation normal form), i.e., if @{const NOT} is only applied directly
to @{const VAR}s: *}

fun is_nnf :: "pbexp \<Rightarrow> bool" where
(* your definition/proof here *)

text{*
Now define a function that converts a @{text bexp} into NNF by pushing
@{const NOT} inwards as much as possible:
*}

fun nnf :: "pbexp \<Rightarrow> pbexp" where
(* your definition/proof here *)

text{*
Prove that @{const nnf} does what it is supposed to do:
*}

lemma pbval_nnf: "pbval (nnf b) s = pbval b s"
(* your definition/proof here *)

lemma is_nnf_nnf: "is_nnf (nnf b)"
(* your definition/proof here *)

text{*
An expression is in DNF (disjunctive normal form) if it is in NNF
and if no @{const OR} occurs below an @{const AND}. Define a corresponding
test:
*}

fun is_dnf :: "pbexp \<Rightarrow> bool" where
(* your definition/proof here *)

text {*
An NNF can be converted into a DNF in a bottom-up manner.
The critical case is the conversion of @{term (sub) "AND b1 b2"}.
Having converted @{text b\<^sub>1} and @{text b\<^sub>2}, apply distributivity of @{const AND}
over @{const OR}. If we write @{const OR} as a multi-argument function,
we can express the distributivity step as follows:
@{text "dist_AND (OR a\<^sub>1 ... a\<^sub>n) (OR b\<^sub>1 ... b\<^sub>m)"}
= @{text "OR (AND a\<^sub>1 b\<^sub>1) (AND a\<^sub>1 b\<^sub>2) ... (AND a\<^sub>n b\<^sub>m)"}. Define
*}

fun dist_AND :: "pbexp \<Rightarrow> pbexp \<Rightarrow> pbexp" where
(* your definition/proof here *)

text {* and prove that it behaves as follows: *}

lemma pbval_dist: "pbval (dist_AND b1 b2) s = pbval (AND b1 b2) s"
(* your definition/proof here *)

lemma is_dnf_dist: "is_dnf b1 \<Longrightarrow> is_dnf b2 \<Longrightarrow> is_dnf (dist_AND b1 b2)"
(* your definition/proof here *)

text {* Use @{const dist_AND} to write a function that converts an NNF
  to a DNF in the above bottom-up manner.
*}

fun dnf_of_nnf :: "pbexp \<Rightarrow> pbexp" where
(* your definition/proof here *)

text {* Prove the correctness of your function: *}

lemma "pbval (dnf_of_nnf b) s = pbval b s"
(* your definition/proof here *)

lemma "is_nnf b \<Longrightarrow> is_dnf (dnf_of_nnf b)"
(* your definition/proof here *)

text{*
\endexercise

\exercise\label{exe:stack-underflow}
A \concept{stack underflow} occurs when executing an @{text ADD}
instruction on a stack of size less than two. In our semantics
stack underflow leads to a term involving @{term "hd []"},
which is not an error or exception --- HOL does not
have those concepts --- but some unspecified value. Modify
theory @{theory ASM} such that stack underflow is modelled by @{const None}
and normal execution by @{text Some}, i.e., the execution functions
have return type @{typ "stack option"}. Modify all theorems and proofs
accordingly.
Hint: you may find @{text"split: option.split"} useful in your proofs.
*}

text{*
\endexercise

\exercise\label{exe:register-machine}
This exercise is about a register machine
and compiler for @{typ aexp}. The machine instructions are
*}
type_synonym reg = nat
datatype instr = LDI val reg | LD vname reg | ADD reg reg

text {*
where type @{text reg} is a synonym for @{typ nat}.
Instruction @{term "LDI i r"} loads @{text i} into register @{text r},
@{term "LD x r"} loads the value of @{text x} into register @{text r},
and @{term[names_short] "ADD r\<^sub>1 r\<^sub>2"} adds register @{text r\<^sub>2} to register @{text r\<^sub>1}.

Define the execution of an instruction given a state and a register state;
the result is the new register state: *}

type_synonym rstate = "reg \<Rightarrow> val"

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> rstate \<Rightarrow> rstate" where
(* your definition/proof here *)

text{*
Define the execution @{const[source] exec} of a list of instructions as for the stack machine.

The compiler takes an arithmetic expression @{text a} and a register @{text r}
and produces a list of instructions whose execution places the value of @{text a}
into @{text r}. The registers @{text "> r"} should be used in a stack-like fashion
for intermediate results, the ones @{text "< r"} should be left alone.
Define the compiler and prove it correct:
*}

theorem "exec (comp a r) s rs r = aval a s"
(* your definition/proof here *)

text{*
\endexercise

\exercise\label{exe:accumulator}
This exercise is a variation of the previous one
with a different instruction set:
*}

datatype instr0 = LDI0 val | LD0 vname | MV0 reg | ADD0 reg

text{*
All instructions refer implicitly to register 0 as a source or target:
@{const LDI0} and @{const LD0} load a value into register 0, @{term "MV0 r"}
copies the value in register 0 into register @{text r}, and @{term "ADD0 r"}
adds the value in register @{text r} to the value in register 0;
@{term "MV0 0"} and @{term "ADD0 0"} are legal. Define the execution functions
*}

fun exec01 :: "instr0 \<Rightarrow> state \<Rightarrow> rstate \<Rightarrow> rstate" where
(* your definition/proof here *)

text{*
and @{const exec0} for instruction lists.

The compiler takes an arithmetic expression @{text a} and a register @{text r}
and produces a list of instructions whose execution places the value of @{text a}
into register 0. The registers @{text "> r"} should be used in a stack-like fashion
for intermediate results, the ones @{text "\<le> r"} should be left alone
(with the exception of 0). Define the compiler and prove it correct:
*}

theorem "exec0 (comp0 a r) s rs 0 = aval a s"
(* your definition/proof here *)

text{*
\endexercise
*}

end


(*  Title:       Examples of hybrid systems verifications
    Author:      Jonathan Julián Huerta y Munive, 2020
    Maintainer:  Jonathan Julián Huerta y Munive <jonjulian23@gmail.com>
*)

subsection \<open> Examples \<close>

text \<open> We prove partial correctness specifications of some hybrid systems with our
verification components.\<close>

theory HS_VC_Examples
  imports HS_VC_Spartan

begin

subsubsection \<open>Pendulum\<close>

text \<open> The ODEs @{text "x' t = y t"} and {text "y' t = - x t"} describe the circular motion of
a mass attached to a string looked from above. We use @{text "s$1"} to represent the x-coordinate
and @{text "s$2"} for the y-coordinate. We prove that this motion remains circular. \<close>

abbreviation fpend :: "real^2 \<Rightarrow> real^2" ("f")
  where "f s \<equiv> (\<chi> i. if i = 1 then s$2 else -s$1)"

abbreviation pend_flow :: "real \<Rightarrow> real^2 \<Rightarrow> real^2" ("\<phi>")
  where "\<phi> t s \<equiv> (\<chi> i. if i = 1 then s$1 * cos t + s$2 * sin t else - s$1 * sin t + s$2 * cos t)"

\<comment> \<open>Verified with annotated dynamics. \<close>

lemma pendulum_dyn: "(\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2) \<le> |EVOL \<phi> G T] (\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2)"
  by force

\<comment> \<open>Verified with differential invariants. \<close>

lemma pendulum_inv: "(\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2) \<le> |x\<acute>= f & G] (\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2)"
  by (auto intro!: diff_invariant_rules poly_derivatives)

\<comment> \<open>Verified with the flow. \<close>

lemma local_flow_pend: "local_flow f UNIV UNIV \<phi>"
  apply(unfold_locales, simp_all add: local_lipschitz_def lipschitz_on_def vec_eq_iff, clarsimp)
    apply(rule_tac x="1" in exI, clarsimp, rule_tac x=1 in exI)
    apply(simp add: dist_norm norm_vec_def L2_set_def power2_commute UNIV_2)
  by (auto simp: forall_2 intro!: poly_derivatives)

lemma pendulum_flow: "(\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2) \<le> |x\<acute>=f & G] (\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2)"
  by (force simp: local_flow.fbox_g_ode_subset[OF local_flow_pend])

no_notation fpend ("f")
        and pend_flow ("\<phi>")

subsubsection \<open> Bouncing Ball \<close>

text \<open> A ball is dropped from rest at an initial height @{text "h"}. The motion is described with
the free-fall equations @{text "x' t = v t"} and @{text "v' t = g"} where @{text "g"} is the
constant acceleration due to gravity. The bounce is modelled with a variable assignment that
flips the velocity. That is, we model it as a completely elastic collision with the ground. We use
@{text "s$1"} to represent the ball's height and @{text "s$2"} for its velocity. We prove that the
ball remains above ground and below its initial resting position. \<close>

abbreviation fball :: "real \<Rightarrow> real^2 \<Rightarrow> real^2" ("f")
  where "f g s \<equiv> (\<chi> i. if i = 1 then s$2 else g)"

abbreviation ball_flow :: "real \<Rightarrow> real \<Rightarrow> real^2 \<Rightarrow> real^2" ("\<phi>")
  where "\<phi> g t s \<equiv> (\<chi> i. if i = 1 then g * t ^ 2/2 + s$2 * t + s$1 else g * t + s$2)"

\<comment> \<open>Verified with differential invariants. \<close>

named_theorems bb_real_arith "real arithmetic properties for the bouncing ball."

lemma inv_imp_pos_le[bb_real_arith]:
  assumes "0 > g" and inv: "2 * g * x - 2 * g * h = v * v"
  shows "(x::real) \<le> h"
proof-
  have "v * v = 2 * g * x - 2 * g * h \<and> 0 > g"
    using inv and \<open>0 > g\<close> by auto
  hence obs:"v * v = 2 * g * (x - h) \<and> 0 > g \<and> v * v \<ge> 0"
    using left_diff_distrib mult.commute by (metis zero_le_square)
  hence "(v * v)/(2 * g) = (x - h)"
    by auto
  also from obs have "(v * v)/(2 * g) \<le> 0"
    using divide_nonneg_neg by fastforce
  ultimately have "h - x \<ge> 0"
    by linarith
  thus ?thesis by auto
qed

lemma "diff_invariant (\<lambda>s. 2 * g * s$1 - 2 * g * h - s$2 * s$2 = 0) (\<lambda>t. f g) (\<lambda>s. UNIV) S t\<^sub>0 G"
  by (auto intro!: poly_derivatives diff_invariant_rules)

lemma bouncing_ball_inv: "g < 0 \<Longrightarrow> h \<ge> 0 \<Longrightarrow>
  (\<lambda>s. s$1 = h \<and> s$2 = 0) \<le>
  |LOOP (
    (x\<acute>=(f g) & (\<lambda> s. s$1 \<ge> 0) DINV (\<lambda>s. 2 * g * s$1 - 2 * g * h - s$2 * s$2 = 0)) ;
    (IF (\<lambda> s. s$1 = 0) THEN (2 ::= (\<lambda>s. - s$2)) ELSE skip))
  INV (\<lambda>s. 0 \<le> s$1 \<and> 2 * g * s$1 - 2 * g * h - s$2 * s$2 = 0)]
  (\<lambda>s. 0 \<le> s$1 \<and> s$1 \<le> h)"
  apply(rule fbox_loopI, simp_all, force, force simp: bb_real_arith)
  by (rule fbox_g_odei) (auto intro!: poly_derivatives diff_invariant_rules)

\<comment> \<open>Verified with annotated dynamics. \<close>

lemma inv_conserv_at_ground[bb_real_arith]:
  assumes invar: "2 * g * x = 2 * g * h + v * v"
    and pos: "g * \<tau>\<^sup>2 / 2 + v * \<tau> + (x::real) = 0"
  shows "2 * g * h + (g * \<tau> + v) * (g * \<tau> + v) = 0"
proof-
  from pos have "g * \<tau>\<^sup>2  + 2 * v * \<tau> + 2 * x = 0" by auto
  then have "g\<^sup>2 * \<tau>\<^sup>2  + 2 * g * v * \<tau> + 2 * g * x = 0"
    by (metis (mono_tags) Groups.mult_ac(1,3) mult_zero_right
        monoid_mult_class.power2_eq_square semiring_class.distrib_left)
  hence "g\<^sup>2 * \<tau>\<^sup>2 + 2 * g * v * \<tau> + v\<^sup>2 + 2 * g * h = 0"
    using invar by (simp add: monoid_mult_class.power2_eq_square)
  hence obs: "(g * \<tau> + v)\<^sup>2 + 2 * g * h = 0"
    apply(subst power2_sum) by (metis (no_types) Groups.add_ac(2, 3)
        Groups.mult_ac(2, 3) monoid_mult_class.power2_eq_square nat_distrib(2))
  thus "2 * g * h + (g * \<tau> + v) * (g * \<tau> + v) = 0"
    by (simp add: add.commute distrib_right power2_eq_square)
qed

lemma inv_conserv_at_air[bb_real_arith]:
  assumes invar: "2 * g * x = 2 * g * h + v * v"
  shows "2 * g * (g * \<tau>\<^sup>2 / 2 + v * \<tau> + (x::real)) =
  2 * g * h + (g * \<tau> + v) * (g * \<tau> + v)" (is "?lhs = ?rhs")
proof-
  have "?lhs = g\<^sup>2 * \<tau>\<^sup>2 + 2 * g * v * \<tau> + 2 * g * x"
    by(auto simp: algebra_simps semiring_normalization_rules(29))
  also have "... = g\<^sup>2 * \<tau>\<^sup>2 + 2 * g * v * \<tau> + 2 * g * h + v * v" (is "... = ?middle")
    by(subst invar, simp)
  finally have "?lhs = ?middle".
  moreover
  {have "?rhs = g * g * (\<tau> * \<tau>) + 2 * g * v * \<tau> + 2 * g * h + v * v"
    by (simp add: Groups.mult_ac(2,3) semiring_class.distrib_left)
  also have "... = ?middle"
    by (simp add: semiring_normalization_rules(29))
  finally have "?rhs = ?middle".}
  ultimately show ?thesis by auto
qed

lemma bouncing_ball_dyn: "g < 0 \<Longrightarrow> h \<ge> 0 \<Longrightarrow>
  (\<lambda>s. s$1 = h \<and> s$2 = 0) \<le>
  |LOOP (
    (EVOL (\<phi> g) (\<lambda> s. s$1 \<ge> 0) T) ;
    (IF (\<lambda> s. s$1 = 0) THEN (2 ::= (\<lambda>s. - s$2)) ELSE skip))
  INV (\<lambda>s. 0 \<le> s$1 \<and>2 * g * s$1 = 2 * g * h + s$2 * s$2)]
  (\<lambda>s. 0 \<le> s$1 \<and> s$1 \<le> h)"
  by (rule fbox_loopI) (auto simp: bb_real_arith)

\<comment> \<open>Verified with the flow. \<close>

lemma local_flow_ball: "local_flow (f g) UNIV UNIV (\<phi> g)"
  apply(unfold_locales, simp_all add: local_lipschitz_def lipschitz_on_def vec_eq_iff, clarsimp)
    apply(rule_tac x="1/2" in exI, clarsimp, rule_tac x=1 in exI)
    apply(simp add: dist_norm norm_vec_def L2_set_def UNIV_2)
  by (auto simp: forall_2 intro!: poly_derivatives)

lemma bouncing_ball_flow: "g < 0 \<Longrightarrow> h \<ge> 0 \<Longrightarrow>
  (\<lambda>s. s$1 = h \<and> s$2 = 0) \<le>
  |LOOP (
    (x\<acute>=(\<lambda>t. f g) & (\<lambda> s. s$1 \<ge> 0) on (\<lambda>s. UNIV) UNIV @ 0) ;
    (IF (\<lambda> s. s$1 = 0) THEN (2 ::= (\<lambda>s. - s$2)) ELSE skip))
  INV (\<lambda>s. 0 \<le> s$1 \<and>2 * g * s$1 = 2 * g * h + s$2 * s$2)]
  (\<lambda>s. 0 \<le> s$1 \<and> s$1 \<le> h)"
  apply(rule fbox_loopI, simp_all add: local_flow.fbox_g_ode_subset[OF local_flow_ball])
  by (auto simp: bb_real_arith)

no_notation fball ("f")
        and ball_flow ("\<phi>")

subsubsection \<open> Thermostat \<close>

text \<open> A thermostat has a chronometer, a thermometer and a switch to turn on and off a heater.
At most every @{text "t"} minutes, it sets its chronometer to @{term "0::real"}, it registers
the room temperature, and it turns the heater on (or off) based on this reading. The temperature
follows the ODE @{text "T' = - a * (T - U)"} where @{text "U"} is @{text "L \<ge> 0"} when the heater
is on, and @{text "0"} when it is off. We use @{term "1::4"} to denote the room's temperature,
@{term "2::4"} is time as measured by the thermostat's chronometer, @{term "3::4"} is the
temperature detected by the thermometer, and @{term "4::4"} states whether the heater is on
(@{text "s$4 = 1"}) or off (@{text "s$4 = 0"}). We prove that the thermostat keeps the room's
temperature between @{text "Tmin"} and @{text "Tmax"}. \<close>

abbreviation temp_vec_field :: "real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> real^4" ("f")
  where "f a L s \<equiv> (\<chi> i. if i = 2 then 1 else (if i = 1 then - a * (s$1 - L) else 0))"

abbreviation temp_flow :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> real^4" ("\<phi>")
  where "\<phi> a L t s \<equiv> (\<chi> i. if i = 1 then - exp(-a * t) * (L - s$1) + L else
  (if i = 2 then t + s$2 else s$i))"

\<comment> \<open>Verified with the flow. \<close>

lemma norm_diff_temp_dyn: "0 < a \<Longrightarrow> \<parallel>f a L s\<^sub>1 - f a L s\<^sub>2\<parallel> = \<bar>a\<bar> * \<bar>s\<^sub>1$1 - s\<^sub>2$1\<bar>"
proof(simp add: norm_vec_def L2_set_def, unfold UNIV_4, simp)
  assume a1: "0 < a"
  have f2: "\<And>r ra. \<bar>(r::real) + - ra\<bar> = \<bar>ra + - r\<bar>"
    by (metis abs_minus_commute minus_real_def)
  have "\<And>r ra rb. (r::real) * ra + - (r * rb) = r * (ra + - rb)"
    by (metis minus_real_def right_diff_distrib)
  hence "\<bar>a * (s\<^sub>1$1 + - L) + - (a * (s\<^sub>2$1 + - L))\<bar> = a * \<bar>s\<^sub>1$1 + - s\<^sub>2$1\<bar>"
    using a1 by (simp add: abs_mult)
  thus "\<bar>a * (s\<^sub>2$1 - L) - a * (s\<^sub>1$1 - L)\<bar> = a * \<bar>s\<^sub>1$1 - s\<^sub>2$1\<bar>"
    using f2 minus_real_def by presburger
qed

lemma local_lipschitz_temp_dyn:
  assumes "0 < (a::real)"
  shows "local_lipschitz UNIV UNIV (\<lambda>t::real. f a L)"
  apply(unfold local_lipschitz_def lipschitz_on_def dist_norm)
  apply(clarsimp, rule_tac x=1 in exI, clarsimp, rule_tac x=a in exI)
  using assms
  apply(simp add: norm_diff_temp_dyn)
  apply(simp add: norm_vec_def L2_set_def, unfold UNIV_4, clarsimp)
  unfolding real_sqrt_abs[symmetric] by (rule real_le_lsqrt) auto

lemma local_flow_temp: "a > 0 \<Longrightarrow> local_flow (f a L) UNIV UNIV (\<phi> a L)"
  by (unfold_locales, auto intro!: poly_derivatives local_lipschitz_temp_dyn simp: forall_4 vec_eq_iff)

lemma temp_dyn_down_real_arith:
  assumes "a > 0" and Thyps: "0 < Tmin" "Tmin \<le> T" "T \<le> Tmax"
    and thyps: "0 \<le> (t::real)" "\<forall>\<tau>\<in>{0..t}. \<tau> \<le> - (ln (Tmin / T) / a) "
  shows "Tmin \<le> exp (-a * t) * T" and "exp (-a * t) * T \<le> Tmax"
proof-
  have "0 \<le> t \<and> t \<le> - (ln (Tmin / T) / a)"
    using thyps by auto
  hence "ln (Tmin / T) \<le> - a * t \<and> - a * t \<le> 0"
    using assms(1) divide_le_cancel by fastforce
  also have "Tmin / T > 0"
    using Thyps by auto
  ultimately have obs: "Tmin / T \<le> exp (-a * t)" "exp (-a * t) \<le> 1"
    using exp_ln exp_le_one_iff by (metis exp_less_cancel_iff not_less, simp)
  thus "Tmin \<le> exp (-a * t) * T"
    using Thyps by (simp add: pos_divide_le_eq)
  show "exp (-a * t) * T \<le> Tmax"
    using Thyps mult_left_le_one_le[OF _ exp_ge_zero obs(2), of T]
      less_eq_real_def order_trans_rules(23) by blast
qed

lemma temp_dyn_up_real_arith:
  assumes "a > 0" and Thyps: "Tmin \<le> T" "T \<le> Tmax" "Tmax < (L::real)"
    and thyps: "0 \<le> t" "\<forall>\<tau>\<in>{0..t}. \<tau> \<le> - (ln ((L - Tmax) / (L - T)) / a) "
  shows "L - Tmax \<le> exp (-(a * t)) * (L - T)"
    and "L - exp (-(a * t)) * (L - T) \<le> Tmax"
    and "Tmin \<le> L - exp (-(a * t)) * (L - T)"
proof-
  have "0 \<le> t \<and> t \<le> - (ln ((L - Tmax) / (L - T)) / a)"
    using thyps by auto
  hence "ln ((L - Tmax) / (L - T)) \<le> - a * t \<and> - a * t \<le> 0"
    using assms(1) divide_le_cancel by fastforce
  also have "(L - Tmax) / (L - T) > 0"
    using Thyps by auto
  ultimately have "(L - Tmax) / (L - T) \<le> exp (-a * t) \<and> exp (-a * t) \<le> 1"
    using exp_ln exp_le_one_iff by (metis exp_less_cancel_iff not_less)
  moreover have "L - T > 0"
    using Thyps by auto
  ultimately have obs: "(L - Tmax) \<le> exp (-a * t) * (L - T) \<and> exp (-a * t) * (L - T) \<le> (L - T)"
    by (simp add: pos_divide_le_eq)
  thus "(L - Tmax) \<le> exp (-(a * t)) * (L - T)"
    by auto
  thus "L - exp (-(a * t)) * (L - T) \<le> Tmax"
    by auto
  show "Tmin \<le> L - exp (-(a * t)) * (L - T)"
    using Thyps and obs by auto
qed

lemmas fbox_temp_dyn = local_flow.fbox_g_ode_subset[OF local_flow_temp]

lemma thermostat:
  assumes "a > 0" and "0 < Tmin" and "Tmax < L"
  shows "(\<lambda>s. Tmin \<le> s$1 \<and> s$1 \<le> Tmax \<and> s$4 = 0) \<le>
  |LOOP
    \<comment> \<open>control\<close>
    ((2 ::= (\<lambda>s. 0));(3 ::= (\<lambda>s. s$1));
    (IF (\<lambda>s. s$4 = 0 \<and> s$3 \<le> Tmin + 1) THEN (4 ::= (\<lambda>s.1)) ELSE
    (IF (\<lambda>s. s$4 = 1 \<and> s$3 \<ge> Tmax - 1) THEN (4 ::= (\<lambda>s.0)) ELSE skip));
    \<comment> \<open>dynamics\<close>
    (IF (\<lambda>s. s$4 = 0) THEN (x\<acute>= f a 0 & (\<lambda>s. s$2 \<le> - (ln (Tmin/s$3))/a))
    ELSE (x\<acute>= f a L & (\<lambda>s. s$2 \<le> - (ln ((L-Tmax)/(L-s$3)))/a))) )
  INV (\<lambda>s. Tmin \<le>s$1 \<and> s$1 \<le> Tmax \<and> (s$4 = 0 \<or> s$4 = 1))]
  (\<lambda>s. Tmin \<le> s$1 \<and> s$1 \<le> Tmax)"
  apply(rule fbox_loopI, simp_all add: fbox_temp_dyn[OF assms(1)] le_fun_def)
  using temp_dyn_up_real_arith[OF assms(1) _ _ assms(3), of Tmin]
    and temp_dyn_down_real_arith[OF assms(1,2), of _ Tmax] by auto

no_notation temp_vec_field ("f")
        and temp_flow ("\<phi>")

subsubsection \<open> Tank \<close>

text \<open> A controller turns a water pump on and off to keep the level of water @{text "h"} in a tank
within an acceptable range @{text "hmin \<le> h \<le> hmax"}. Just like in the previous example, after
each intervention, the controller registers the current level of water and resets its chronometer,
then it changes the status of the water pump accordingly. The level of water grows linearly
@{text "h' = k"} at a rate of @{text "k = c\<^sub>i-c\<^sub>o"} if the pump is on, and at a rate of
@{text "k = -c\<^sub>o"} if the pump is off. We use @{term "1::4"} to denote the tank's level of water,
@{term "2::4"} is time as measured by the controller's chronometer, @{term "3::4"} is the
level of water measured by the chronometer, and @{term "4::4"} states whether the pump is on
(@{text "s$4 = 1"}) or off (@{text "s$4 = 0"}). We prove that the controller keeps the level of
water between @{text "hmin"} and @{text "hmax"}. \<close>

abbreviation tank_vec_field :: "real \<Rightarrow> real^4 \<Rightarrow> real^4" ("f")
  where "f k s \<equiv> (\<chi> i. if i = 2 then 1 else (if i = 1 then k else 0))"

abbreviation tank_flow :: "real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> real^4" ("\<phi>")
  where "\<phi> k \<tau> s \<equiv> (\<chi> i. if i = 1 then k * \<tau> + s$1 else
  (if i = 2 then \<tau> + s$2 else s$i))"

abbreviation tank_guard :: "real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> bool" ("G")
  where "G Hm k s \<equiv> s$2 \<le> (Hm - s$3)/k"

abbreviation tank_loop_inv :: "real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> bool" ("I")
  where "I hmin hmax s \<equiv> hmin \<le> s$1 \<and> s$1 \<le> hmax \<and> (s$4 = 0 \<or> s$4 = 1)"

abbreviation tank_diff_inv :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> bool" ("dI")
  where "dI hmin hmax k s \<equiv> s$1 = k * s$2 + s$3 \<and> 0 \<le> s$2 \<and>
    hmin \<le> s$3 \<and> s$3 \<le> hmax \<and> (s$4 =0 \<or> s$4 = 1)"

lemma local_flow_tank: "local_flow (f k) UNIV UNIV (\<phi> k)"
  apply (unfold_locales, unfold local_lipschitz_def lipschitz_on_def, simp_all, clarsimp)
  apply(rule_tac x="1/2" in exI, clarsimp, rule_tac x=1 in exI)
  apply(simp add: dist_norm norm_vec_def L2_set_def, unfold UNIV_4)
  by (auto intro!: poly_derivatives simp: vec_eq_iff)

lemma tank_arith:
  assumes "0 \<le> (\<tau>::real)" and "0 < c\<^sub>o" and "c\<^sub>o < c\<^sub>i"
  shows "\<forall>\<tau>\<in>{0..\<tau>}. \<tau> \<le> - ((hmin - y) / c\<^sub>o) \<Longrightarrow>  hmin \<le> y - c\<^sub>o * \<tau>"
    and "\<forall>\<tau>\<in>{0..\<tau>}. \<tau> \<le> (hmax - y) / (c\<^sub>i - c\<^sub>o) \<Longrightarrow>  (c\<^sub>i - c\<^sub>o) * \<tau> + y \<le> hmax"
    and "hmin \<le> y \<Longrightarrow> hmin \<le> (c\<^sub>i - c\<^sub>o) * \<tau> + y"
    and "y \<le> hmax \<Longrightarrow> y - c\<^sub>o * \<tau> \<le> hmax"
  apply(simp_all add: field_simps le_divide_eq assms)
  using assms apply (meson add_mono less_eq_real_def mult_left_mono)
  using assms by (meson add_increasing2 less_eq_real_def mult_nonneg_nonneg)

lemma tank_flow:
  assumes "0 < c\<^sub>o" and "c\<^sub>o < c\<^sub>i"
  shows "I hmin hmax \<le>
  |LOOP
    \<comment> \<open>control\<close>
    ((2 ::=(\<lambda>s.0));(3 ::=(\<lambda>s. s$1));
    (IF (\<lambda>s. s$4 = 0 \<and> s$3 \<le> hmin + 1) THEN (4 ::= (\<lambda>s.1)) ELSE
    (IF (\<lambda>s. s$4 = 1 \<and> s$3 \<ge> hmax - 1) THEN (4 ::= (\<lambda>s.0)) ELSE skip));
    \<comment> \<open>dynamics\<close>
    (IF (\<lambda>s. s$4 = 0) THEN (x\<acute>= f (c\<^sub>i-c\<^sub>o) & (G hmax (c\<^sub>i-c\<^sub>o)))
     ELSE (x\<acute>= f (-c\<^sub>o) & (G hmin (-c\<^sub>o)))) ) INV I hmin hmax]
  I hmin hmax"
  apply(rule fbox_loopI, simp_all add: le_fun_def)
  apply(clarsimp simp: le_fun_def local_flow.fbox_g_ode_subset[OF local_flow_tank])
  using assms tank_arith[OF _ assms] by auto

no_notation tank_vec_field ("f")
        and tank_flow ("\<phi>")
        and tank_loop_inv ("I")
        and tank_diff_inv ("dI")
        and tank_guard ("G")

end


theory
  Vector_Derivative_On
imports
  "HOL-Analysis.Analysis"
begin

subsection \<open>Vector derivative on a set\<close>
  \<comment> \<open>TODO: also for the other derivatives?!\<close>
  \<comment> \<open>TODO: move to repository and rewrite assumptions of common lemmas?\<close>

definition
  has_vderiv_on :: "(real \<Rightarrow> 'a::real_normed_vector) \<Rightarrow> (real \<Rightarrow> 'a) \<Rightarrow> real set \<Rightarrow> bool"
  (infix "(has'_vderiv'_on)" 50)
where
  "(f has_vderiv_on f') S \<longleftrightarrow> (\<forall>x \<in> S. (f has_vector_derivative f' x) (at x within S))"

lemma has_vderiv_on_empty[intro, simp]: "(f has_vderiv_on f') {}"
  by (auto simp: has_vderiv_on_def)

lemma has_vderiv_on_subset:
  assumes "(f has_vderiv_on f') S"
  assumes "T \<subseteq> S"
  shows "(f has_vderiv_on f') T"
  by (meson assms(1) assms(2) contra_subsetD has_vderiv_on_def has_vector_derivative_within_subset)

lemma has_vderiv_on_compose:
  assumes "(f has_vderiv_on f') (g ` T)"
  assumes "(g has_vderiv_on g') T"
  shows "(f o g has_vderiv_on (\<lambda>x. g' x *\<^sub>R f' (g x))) T"
  using assms
  unfolding has_vderiv_on_def
  by (auto intro!: vector_diff_chain_within)

lemma has_vderiv_on_open:
  assumes "open T"
  shows "(f has_vderiv_on f') T \<longleftrightarrow> (\<forall>t \<in> T. (f has_vector_derivative f' t) (at t))"
  by (auto simp: has_vderiv_on_def at_within_open[OF _ \<open>open T\<close>])

lemma has_vderiv_on_eq_rhs:\<comment> \<open>TODO: integrate intro \<open>derivative_eq_intros\<close>\<close>
  "(f has_vderiv_on g') T \<Longrightarrow> (\<And>x. x \<in> T \<Longrightarrow> g' x = f' x) \<Longrightarrow> (f has_vderiv_on f') T"
  by (auto simp: has_vderiv_on_def)

lemma [THEN has_vderiv_on_eq_rhs, derivative_intros]:
  shows has_vderiv_on_id: "((\<lambda>x. x) has_vderiv_on (\<lambda>x. 1)) T"
    and has_vderiv_on_const: "((\<lambda>x. c) has_vderiv_on (\<lambda>x. 0)) T"
  by (auto simp: has_vderiv_on_def intro!: derivative_eq_intros)

lemma [THEN has_vderiv_on_eq_rhs, derivative_intros]:
  fixes f::"real \<Rightarrow> 'a::real_normed_vector"
  assumes "(f has_vderiv_on f') T"
  shows has_vderiv_on_uminus: "((\<lambda>x. - f x) has_vderiv_on (\<lambda>x. - f' x)) T"
  using assms
  by (auto simp: has_vderiv_on_def intro!: derivative_eq_intros)

lemma [THEN has_vderiv_on_eq_rhs, derivative_intros]:
  fixes f g::"real \<Rightarrow> 'a::real_normed_vector"
  assumes "(f has_vderiv_on f') T"
  assumes "(g has_vderiv_on g') T"
  shows has_vderiv_on_add: "((\<lambda>x. f x + g x) has_vderiv_on (\<lambda>x. f' x + g' x)) T"
   and has_vderiv_on_diff: "((\<lambda>x. f x - g x) has_vderiv_on (\<lambda>x. f' x - g' x)) T"
  using assms
  by (auto simp: has_vderiv_on_def intro!: derivative_eq_intros)

lemma [THEN has_vderiv_on_eq_rhs, derivative_intros]:
  fixes f::"real \<Rightarrow> real" and g::"real \<Rightarrow> 'a::real_normed_vector"
  assumes "(f has_vderiv_on f') T"
  assumes "(g has_vderiv_on g') T"
  shows has_vderiv_on_scaleR: "((\<lambda>x. f x *\<^sub>R g x) has_vderiv_on (\<lambda>x. f x *\<^sub>R g' x + f' x *\<^sub>R g x)) T"
  using assms
  by (auto simp: has_vderiv_on_def has_field_derivative_iff_has_vector_derivative
    intro!: derivative_eq_intros)

lemma [THEN has_vderiv_on_eq_rhs, derivative_intros]:
  fixes f g::"real \<Rightarrow> 'a::real_normed_algebra"
  assumes "(f has_vderiv_on f') T"
  assumes "(g has_vderiv_on g') T"
  shows has_vderiv_on_mult: "((\<lambda>x. f x * g x) has_vderiv_on (\<lambda>x. f x * g' x + f' x * g x)) T"
  using assms
  by (auto simp: has_vderiv_on_def intro!: derivative_eq_intros)

lemma has_vderiv_on_ln[THEN has_vderiv_on_eq_rhs, derivative_intros]:
  fixes g::"real \<Rightarrow> real"
  assumes "\<And>x. x \<in> s \<Longrightarrow> 0 < g x"
  assumes "(g has_vderiv_on g') s"
  shows "((\<lambda>x. ln (g x)) has_vderiv_on (\<lambda>x. g' x / g x)) s"
  using assms
  unfolding has_vderiv_on_def
  by (auto simp: has_vderiv_on_def has_field_derivative_iff_has_vector_derivative[symmetric]
    intro!: derivative_eq_intros)

lemma fundamental_theorem_of_calculus':
  fixes f :: "real \<Rightarrow> 'a::banach"
  shows "a \<le> b \<Longrightarrow> (f has_vderiv_on f') {a .. b} \<Longrightarrow> (f' has_integral (f b - f a)) {a .. b}"
  by (auto intro!: fundamental_theorem_of_calculus simp: has_vderiv_on_def)

lemma has_vderiv_on_If:
  assumes "U = S \<union> T"
  assumes "(f has_vderiv_on f') (S \<union> (closure T \<inter> closure S))"
  assumes "(g has_vderiv_on g') (T \<union> (closure T \<inter> closure S))"
  assumes "\<And>x. x \<in> closure T \<Longrightarrow> x \<in> closure S \<Longrightarrow> f x = g x"
  assumes "\<And>x. x \<in> closure T \<Longrightarrow> x \<in> closure S \<Longrightarrow> f' x = g' x"
  shows "((\<lambda>t. if t \<in> S then f t else g t) has_vderiv_on (\<lambda>t. if t \<in> S then f' t else g' t)) U"
  using assms
  by (auto simp: has_vderiv_on_def ac_simps
      intro!: has_vector_derivative_If_within_closures
      split del: if_split)

lemma mvt_very_simple_closed_segmentE:
  fixes f::"real\<Rightarrow>real"
  assumes "(f has_vderiv_on f') (closed_segment a b)"
  obtains y where "y \<in> closed_segment a b"  "f b - f a = (b - a) * f' y"
proof cases
  assume "a \<le> b"
  with mvt_very_simple[of a b f "\<lambda>x i. i *\<^sub>R f' x"] assms
  obtain y where "y \<in> closed_segment a b"  "f b - f a = (b - a) * f' y"
    by (auto simp: has_vector_derivative_def closed_segment_eq_real_ivl has_vderiv_on_def)
  thus ?thesis ..
next
  assume "\<not> a \<le> b"
  with mvt_very_simple[of b a f "\<lambda>x i. i *\<^sub>R f' x"] assms
  obtain y where "y \<in> closed_segment a b"  "f b - f a = (b - a) * f' y"
    by (force simp: has_vector_derivative_def has_vderiv_on_def closed_segment_eq_real_ivl algebra_simps)
  thus ?thesis ..
qed

lemma mvt_simple_closed_segmentE:
  fixes f::"real\<Rightarrow>real"
  assumes "(f has_vderiv_on f') (closed_segment a b)"
  assumes "a \<noteq> b"
  obtains y where "y \<in> open_segment a b"  "f b - f a = (b - a) * f' y"
proof cases
  assume "a \<le> b"
  with assms have "a < b" by simp
  with mvt_simple[of a b f "\<lambda>x i. i *\<^sub>R f' x"] assms
  obtain y where "y \<in> open_segment a b"  "f b - f a = (b - a) * f' y"
    by (auto simp: has_vector_derivative_def closed_segment_eq_real_ivl has_vderiv_on_def
        open_segment_eq_real_ivl)
  thus ?thesis ..
next
  assume "\<not> a \<le> b"
  then have "b < a" by simp
  with mvt_simple[of b a f "\<lambda>x i. i *\<^sub>R f' x"] assms
  obtain y where "y \<in> open_segment a b"  "f b - f a = (b - a) * f' y"
    by (force simp: has_vector_derivative_def has_vderiv_on_def closed_segment_eq_real_ivl algebra_simps
      open_segment_eq_real_ivl)
  thus ?thesis ..
qed

lemma differentiable_bound_general_open_segment:
  fixes a :: "real"
    and b :: "real"
    and f :: "real \<Rightarrow> 'a::real_normed_vector"
    and f' :: "real \<Rightarrow> 'a"
  assumes "continuous_on (closed_segment a b) f"
  assumes "continuous_on (closed_segment a b) g"
    and "(f has_vderiv_on f') (open_segment a b)"
    and "(g has_vderiv_on g') (open_segment a b)"
    and "\<And>x. x \<in> open_segment a b \<Longrightarrow> norm (f' x) \<le> g' x"
  shows "norm (f b - f a) \<le> abs (g b - g a)"
proof -
  {
    assume "a = b"
    hence ?thesis by simp
  } moreover {
    assume "a < b"
    with assms
    have "continuous_on {a .. b} f"
      and "continuous_on {a .. b} g"
      and "\<And>x. x\<in>{a<..<b} \<Longrightarrow> (f has_vector_derivative f' x) (at x)"
      and "\<And>x. x\<in>{a<..<b} \<Longrightarrow> (g has_vector_derivative g' x) (at x)"
      and "\<And>x. x\<in>{a<..<b} \<Longrightarrow> norm (f' x) \<le> g' x"
      by (auto simp: open_segment_eq_real_ivl closed_segment_eq_real_ivl has_vderiv_on_def
        at_within_open[where S="{a<..<b}"])
    from differentiable_bound_general[OF \<open>a < b\<close> this]
    have ?thesis by auto
  } moreover {
    assume "b < a"
    with assms
    have "continuous_on {b .. a} f"
      and "continuous_on {b .. a} g"
      and "\<And>x. x\<in>{b<..<a} \<Longrightarrow> (f has_vector_derivative f' x) (at x)"
      and "\<And>x. x\<in>{b<..<a} \<Longrightarrow> (g has_vector_derivative g' x) (at x)"
      and "\<And>x. x\<in>{b<..<a} \<Longrightarrow> norm (f' x) \<le> g' x"
      by (auto simp: open_segment_eq_real_ivl closed_segment_eq_real_ivl has_vderiv_on_def
        at_within_open[where S="{b<..<a}"])
    from differentiable_bound_general[OF \<open>b < a\<close> this]
    have "norm (f a - f b) \<le> g a - g b" by simp
    also have "\<dots> \<le> abs (g b - g a)" by simp
    finally have ?thesis by (simp add: norm_minus_commute)
  } ultimately show ?thesis by arith
qed

lemma has_vderiv_on_union_closed:
  assumes "(f has_vderiv_on g) s"
  assumes "(f has_vderiv_on g) t"
  assumes "closed s" "closed t"
  shows "(f has_vderiv_on g) (s \<union> t)"
  using has_vderiv_on_If[OF refl, of f g s t f g] assms
  by (auto simp: has_vderiv_on_subset)

lemma vderiv_on_continuous_on: "(f has_vderiv_on f') S \<Longrightarrow> continuous_on S f"
  by (auto intro!: continuous_on_vector_derivative simp: has_vderiv_on_def)

lemma has_vderiv_on_cong[cong]:
  assumes "\<And>x. x \<in> S \<Longrightarrow> f x = g x"
  assumes "\<And>x. x \<in> S \<Longrightarrow> f' x = g' x"
  assumes "S = T"
  shows "(f has_vderiv_on f') S = (g has_vderiv_on g') T"
  using assms
  by (metis has_vector_derivative_transform has_vderiv_on_def)

lemma has_vderiv_eq:
  assumes "(f has_vderiv_on f') S"
  assumes "\<And>x. x \<in> S \<Longrightarrow> f x = g x"
  assumes "\<And>x. x \<in> S \<Longrightarrow> f' x = g' x"
  assumes "S = T"
  shows "(g has_vderiv_on g') T"
  using assms by simp

lemma has_vderiv_on_compose':
  assumes "(f has_vderiv_on f') (g ` T)"
  assumes "(g has_vderiv_on g') T"
  shows "((\<lambda>x. f (g x)) has_vderiv_on (\<lambda>x. g' x *\<^sub>R f' (g x))) T"
  using has_vderiv_on_compose[OF assms]
  by simp

lemma has_vderiv_on_compose2:
  assumes "(f has_vderiv_on f') S"
  assumes "(g has_vderiv_on g') T"
  assumes "\<And>t. t \<in> T \<Longrightarrow> g t \<in> S"
  shows "((\<lambda>x. f (g x)) has_vderiv_on (\<lambda>x. g' x *\<^sub>R f' (g x))) T"
  using has_vderiv_on_compose[OF has_vderiv_on_subset[OF assms(1)] assms(2)] assms(3)
  by force

lemma has_vderiv_on_singleton: "(y has_vderiv_on y') {t0}"
  by (auto simp: has_vderiv_on_def has_vector_derivative_def has_derivative_within_singleton_iff
      bounded_linear_scaleR_left)

lemma
  has_vderiv_on_zero_constant:
  assumes "convex s"
  assumes "(f has_vderiv_on (\<lambda>h. 0)) s"
  obtains c where "\<And>x. x \<in> s \<Longrightarrow> f x = c"
  using has_vector_derivative_zero_constant[of s f] assms
  by (auto simp: has_vderiv_on_def)

lemma bounded_vderiv_on_imp_lipschitz:
  assumes "(f has_vderiv_on f') X"
  assumes convex: "convex X"
  assumes "\<And>x. x \<in> X \<Longrightarrow> norm (f' x) \<le> C" "0 \<le> C"
  shows "C-lipschitz_on X f"
  using assms
  by (auto simp: has_vderiv_on_def has_vector_derivative_def onorm_scaleR_left onorm_id
    intro!: bounded_derivative_imp_lipschitz[where f' = "\<lambda>x d. d *\<^sub>R f' x"])

end


theory Ex5_5
  imports Main
begin

(*
By: Vadim Zaliva <vzaliva@cmu.edu>
From: T. Nipkow and G. Klein, Concrete Semantics with Isabelle/HOL. Springer, 2014.
Exercise 5.5:
*)

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
  refl: "star r x x" |
  step: "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
  zero: "iter r 0 x x" |
  step: "r x y \<Longrightarrow> iter r n y z \<Longrightarrow> iter r (Suc n) x z"

lemma iter_star :  "iter r n x y \<Longrightarrow> star r x y"
proof (induction rule: iter.induct)
  case zero
  show ?case by (rule star.refl)
next
  case step
  then show ?case by (metis star.step)
qed

end


section \<open>\isaheader{Operations on sorted Lists}\<close>
theory Sorted_List_Operations
imports Main Automatic_Refinement.Misc
begin

fun inter_sorted :: "'a::{linorder} list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   "inter_sorted [] l2 = []"
 | "inter_sorted l1 [] = []"
 | "inter_sorted (x1 # l1) (x2 # l2) =
    (if (x1 < x2) then (inter_sorted l1 (x2 # l2)) else
     (if (x1 = x2) then x1 # (inter_sorted l1 l2) else inter_sorted (x1 # l1) l2))"

lemma inter_sorted_correct :
assumes l1_OK: "distinct l1 \<and> sorted l1"
assumes l2_OK: "distinct l2 \<and> sorted l2"
shows "distinct (inter_sorted l1 l2) \<and> sorted (inter_sorted l1 l2) \<and>
       set (inter_sorted l1 l2) = set l1 \<inter> set l2"
using assms
proof (induct l1 arbitrary: l2)
  case Nil thus ?case by simp
next
  case (Cons x1 l1 l2)
  note x1_l1_props = Cons(2)
  note l2_props = Cons(3)

  from x1_l1_props have l1_props: "distinct l1 \<and> sorted l1"
                    and x1_nin_l1: "x1 \<notin> set l1"
                    and x1_le: "\<And>x. x \<in> set l1 \<Longrightarrow> x1 \<le> x"
    by (simp_all add: Ball_def)

  note ind_hyp_l1 = Cons(1)[OF l1_props]

  show ?case
  using l2_props
  proof (induct l2)
    case Nil with x1_l1_props show ?case by simp
  next
    case (Cons x2 l2)
    note x2_l2_props = Cons(2)
    from x2_l2_props have l2_props: "distinct l2 \<and> sorted l2"
                    and x2_nin_l2: "x2 \<notin> set l2"
                    and x2_le: "\<And>x. x \<in> set l2 \<Longrightarrow> x2 \<le> x"
    by (simp_all add: Ball_def)

    note ind_hyp_l2 = Cons(1)[OF l2_props]
    show ?case
    proof (cases "x1 < x2")
      case True note x1_less_x2 = this

      from ind_hyp_l1[OF x2_l2_props] x1_less_x2 x1_nin_l1 x1_le x2_le
      show ?thesis
        apply (auto simp add: Ball_def)
        apply (metis linorder_not_le)
      done
    next
      case False note x2_le_x1 = this

      show ?thesis
      proof (cases "x1 = x2")
        case True note x1_eq_x2 = this

        from ind_hyp_l1[OF l2_props] x1_le x2_le x2_nin_l2 x1_eq_x2 x1_nin_l1
        show ?thesis by (simp add: x1_eq_x2 Ball_def)
      next
        case False note x1_neq_x2 = this
        with x2_le_x1 have x2_less_x1 : "x2 < x1" by auto

        from ind_hyp_l2 x2_le_x1 x1_neq_x2 x2_le x2_nin_l2 x1_le
        show ?thesis
          apply (auto simp add: x2_less_x1 Ball_def)
          apply (metis linorder_not_le x2_less_x1)
        done
      qed
    qed
  qed
qed

fun diff_sorted :: "'a::{linorder} list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   "diff_sorted [] l2 = []"
 | "diff_sorted l1 [] = l1"
 | "diff_sorted (x1 # l1) (x2 # l2) =
    (if (x1 < x2) then x1 # (diff_sorted l1 (x2 # l2)) else
     (if (x1 = x2) then (diff_sorted l1 l2) else diff_sorted (x1 # l1) l2))"

lemma diff_sorted_correct :
assumes l1_OK: "distinct l1 \<and> sorted l1"
assumes l2_OK: "distinct l2 \<and> sorted l2"
shows "distinct (diff_sorted l1 l2) \<and> sorted (diff_sorted l1 l2) \<and>
       set (diff_sorted l1 l2) = set l1 - set l2"
using assms
proof (induct l1 arbitrary: l2)
  case Nil thus ?case by simp
next
  case (Cons x1 l1 l2)
  note x1_l1_props = Cons(2)
  note l2_props = Cons(3)

  from x1_l1_props have l1_props: "distinct l1 \<and> sorted l1"
                    and x1_nin_l1: "x1 \<notin> set l1"
                    and x1_le: "\<And>x. x \<in> set l1 \<Longrightarrow> x1 \<le> x"
    by (simp_all add: Ball_def)

  note ind_hyp_l1 = Cons(1)[OF l1_props]

  show ?case
  using l2_props
  proof (induct l2)
    case Nil with x1_l1_props show ?case by simp
  next
    case (Cons x2 l2)
    note x2_l2_props = Cons(2)
    from x2_l2_props have l2_props: "distinct l2 \<and> sorted l2"
                    and x2_nin_l2: "x2 \<notin> set l2"
                    and x2_le: "\<And>x. x \<in> set l2 \<Longrightarrow> x2 \<le> x"
    by (simp_all add: Ball_def)

    note ind_hyp_l2 = Cons(1)[OF l2_props]
    show ?case
    proof (cases "x1 < x2")
      case True note x1_less_x2 = this

      from ind_hyp_l1[OF x2_l2_props] x1_less_x2 x1_nin_l1 x1_le x2_le
      show ?thesis
        apply simp
        apply (simp add: Ball_def set_eq_iff)
        apply (metis linorder_not_le order_less_imp_not_eq2)
      done
    next
      case False note x2_le_x1 = this

      show ?thesis
      proof (cases "x1 = x2")
        case True note x1_eq_x2 = this

        from ind_hyp_l1[OF l2_props] x1_le x2_le x2_nin_l2 x1_eq_x2 x1_nin_l1
        show ?thesis by (simp add: x1_eq_x2 Ball_def)
      next
        case False note x1_neq_x2 = this
        with x2_le_x1 have x2_less_x1 : "x2 < x1" by auto

        from x2_less_x1 x1_le have x2_nin_l1: "x2 \<notin> set l1"
           by (metis linorder_not_less)

        from ind_hyp_l2 x1_le x2_nin_l1
        show ?thesis
          apply (simp add: x2_less_x1 x1_neq_x2 x2_le_x1 x1_nin_l1 Ball_def set_eq_iff)
          apply (metis x1_neq_x2)
        done
      qed
    qed
  qed
qed

fun subset_sorted :: "'a::{linorder} list \<Rightarrow> 'a list \<Rightarrow> bool" where
   "subset_sorted [] l2 = True"
 | "subset_sorted (x1 # l1) [] = False"
 | "subset_sorted (x1 # l1) (x2 # l2) =
    (if (x1 < x2) then False else
     (if (x1 = x2) then (subset_sorted l1 l2) else subset_sorted (x1 # l1) l2))"

lemma subset_sorted_correct :
assumes l1_OK: "distinct l1 \<and> sorted l1"
assumes l2_OK: "distinct l2 \<and> sorted l2"
shows "subset_sorted l1 l2 \<longleftrightarrow> set l1 \<subseteq> set l2"
using assms
proof (induct l1 arbitrary: l2)
  case Nil thus ?case by simp
next
  case (Cons x1 l1 l2)
  note x1_l1_props = Cons(2)
  note l2_props = Cons(3)

  from x1_l1_props have l1_props: "distinct l1 \<and> sorted l1"
                    and x1_nin_l1: "x1 \<notin> set l1"
                    and x1_le: "\<And>x. x \<in> set l1 \<Longrightarrow> x1 \<le> x"
    by (simp_all add: Ball_def)

  note ind_hyp_l1 = Cons(1)[OF l1_props]

  show ?case
  using l2_props
  proof (induct l2)
    case Nil with x1_l1_props show ?case by simp
  next
    case (Cons x2 l2)
    note x2_l2_props = Cons(2)
    from x2_l2_props have l2_props: "distinct l2 \<and> sorted l2"
                    and x2_nin_l2: "x2 \<notin> set l2"
                    and x2_le: "\<And>x. x \<in> set l2 \<Longrightarrow> x2 \<le> x"
    by (simp_all add: Ball_def)

    note ind_hyp_l2 = Cons(1)[OF l2_props]
    show ?case
    proof (cases "x1 < x2")
      case True note x1_less_x2 = this

      from ind_hyp_l1[OF x2_l2_props] x1_less_x2 x1_nin_l1 x1_le x2_le
      show ?thesis
        apply (auto simp add: Ball_def)
        apply (metis linorder_not_le)
      done
    next
      case False note x2_le_x1 = this

      show ?thesis
      proof (cases "x1 = x2")
        case True note x1_eq_x2 = this

        from ind_hyp_l1[OF l2_props] x1_le x2_le x2_nin_l2 x1_eq_x2 x1_nin_l1
        show ?thesis
          apply (simp add: subset_iff x1_eq_x2 Ball_def)
          apply metis
        done
      next
        case False note x1_neq_x2 = this
        with x2_le_x1 have x2_less_x1 : "x2 < x1" by auto

        from ind_hyp_l2 x2_le_x1 x1_neq_x2 x2_le x2_nin_l2 x1_le
        show ?thesis
          apply (simp add: subset_iff x2_less_x1 Ball_def)
          apply (metis linorder_not_le x2_less_x1)
        done
      qed
    qed
  qed
qed

lemma set_eq_sorted_correct :
  assumes l1_OK: "distinct l1 \<and> sorted l1"
  assumes l2_OK: "distinct l2 \<and> sorted l2"
  shows "l1 = l2 \<longleftrightarrow> set l1 = set l2"
  using assms
proof -
  have l12_eq: "l1 = l2 \<longleftrightarrow> subset_sorted l1 l2 \<and> subset_sorted l2 l1"
  proof (induct l1 arbitrary: l2)
    case Nil thus ?case by (cases l2) auto
  next
    case (Cons x1 l1')
    note ind_hyp = Cons(1)

    show ?case
    proof (cases l2)
      case Nil thus ?thesis by simp
    next
      case (Cons x2 l2')
      thus ?thesis by (simp add: ind_hyp)
    qed
  qed
  also have "\<dots> \<longleftrightarrow> ((set l1 \<subseteq> set l2) \<and> (set l2 \<subseteq> set l1))"
    using subset_sorted_correct[OF l1_OK l2_OK] subset_sorted_correct[OF l2_OK l1_OK]
    by simp
  also have "\<dots> \<longleftrightarrow> set l1 = set l2" by auto
  finally show ?thesis .
qed

fun memb_sorted where
   "memb_sorted [] x = False"
 | "memb_sorted (y # xs) x =
    (if (y < x) then memb_sorted xs x else (x = y))"

lemma memb_sorted_correct :
  "sorted xs \<Longrightarrow> memb_sorted xs x \<longleftrightarrow> x \<in> set xs"
by (induct xs) (auto simp add: Ball_def)

fun insertion_sort where
   "insertion_sort x [] = [x]"
 | "insertion_sort x (y # xs) =
    (if (y < x) then y # insertion_sort x xs else
     (if (x = y) then y # xs else x # y # xs))"

lemma insertion_sort_correct :
  "sorted xs \<Longrightarrow> distinct xs \<Longrightarrow>
   distinct (insertion_sort x xs) \<and>
   sorted (insertion_sort x xs) \<and>
   set (insertion_sort x xs) = set (x # xs)"
by (induct xs) (auto simp add: Ball_def)

fun delete_sorted where
   "delete_sorted x [] = []"
 | "delete_sorted x (y # xs) =
    (if (y < x) then y # delete_sorted x xs else
     (if (x = y) then xs else y # xs))"

lemma delete_sorted_correct :
  "sorted xs \<Longrightarrow> distinct xs \<Longrightarrow>
   distinct (delete_sorted x xs) \<and>
   sorted (delete_sorted x xs) \<and>
   set (delete_sorted x xs) = set xs - {x}"
apply (induct xs)
apply simp
apply (simp add: Ball_def set_eq_iff)
apply (metis order_less_le)
done

end


(*  Title:      Sequents/LK/Propositional.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge
*)

section \<open>Classical sequent calculus: examples with propositional connectives\<close>

theory Propositional
imports "../LK"
begin

text "absorptive laws of \<and> and \<or>"

lemma "\<turnstile> P \<and> P \<longleftrightarrow> P"
  by fast_prop

lemma "\<turnstile> P \<or> P \<longleftrightarrow> P"
  by fast_prop

text "commutative laws of \<and> and \<or>"

lemma "\<turnstile> P \<and> Q \<longleftrightarrow> Q \<and> P"
  by fast_prop

lemma "\<turnstile> P \<or> Q \<longleftrightarrow> Q \<or> P"
  by fast_prop

text "associative laws of \<and> and \<or>"

lemma "\<turnstile> (P \<and> Q) \<and> R \<longleftrightarrow> P \<and> (Q \<and> R)"
  by fast_prop

lemma "\<turnstile> (P \<or> Q) \<or> R \<longleftrightarrow> P \<or> (Q \<or> R)"
  by fast_prop

text "distributive laws of \<and> and \<or>"

lemma "\<turnstile> (P \<and> Q) \<or> R \<longleftrightarrow> (P \<or> R) \<and> (Q \<or> R)"
  by fast_prop

lemma "\<turnstile> (P \<or> Q) \<and> R \<longleftrightarrow> (P \<and> R) \<or> (Q \<and> R)"
  by fast_prop

text "Laws involving implication"

lemma "\<turnstile> (P \<or> Q \<longrightarrow> R) \<longleftrightarrow> (P \<longrightarrow> R) \<and> (Q \<longrightarrow> R)"
  by fast_prop

lemma "\<turnstile> (P \<and> Q \<longrightarrow> R) \<longleftrightarrow> (P \<longrightarrow> (Q \<longrightarrow> R))"
  by fast_prop

lemma "\<turnstile> (P \<longrightarrow> Q \<and> R) \<longleftrightarrow> (P \<longrightarrow> Q) \<and> (P \<longrightarrow> R)"
  by fast_prop

text "Classical theorems"

lemma "\<turnstile> P \<or> Q \<longrightarrow> P \<or> \<not> P \<and> Q"
  by fast_prop

lemma "\<turnstile> (P \<longrightarrow> Q) \<and> (\<not> P \<longrightarrow> R) \<longrightarrow> (P \<and> Q \<or> R)"
  by fast_prop

lemma "\<turnstile> P \<and> Q \<or> \<not> P \<and> R \<longleftrightarrow> (P \<longrightarrow> Q) \<and> (\<not> P \<longrightarrow> R)"
  by fast_prop

lemma "\<turnstile> (P \<longrightarrow> Q) \<or> (P \<longrightarrow> R) \<longleftrightarrow> (P \<longrightarrow> Q \<or> R)"
  by fast_prop

(*If and only if*)

lemma "\<turnstile> (P \<longleftrightarrow> Q) \<longleftrightarrow> (Q \<longleftrightarrow> P)"
  by fast_prop

lemma "\<turnstile> \<not> (P \<longleftrightarrow> \<not> P)"
  by fast_prop

(*Sample problems from
  F. J. Pelletier,
  Seventy-Five Problems for Testing Automatic Theorem Provers,
  J. Automated Reasoning 2 (1986), 191-216.
  Errata, JAR 4 (1988), 236-236.
*)

(*1*)
lemma "\<turnstile> (P \<longrightarrow> Q) \<longleftrightarrow> (\<not> Q \<longrightarrow> \<not> P)"
  by fast_prop

(*2*)
lemma "\<turnstile> \<not> \<not> P \<longleftrightarrow> P"
  by fast_prop

(*3*)
lemma "\<turnstile> \<not> (P \<longrightarrow> Q) \<longrightarrow> (Q \<longrightarrow> P)"
  by fast_prop

(*4*)
lemma "\<turnstile> (\<not> P \<longrightarrow> Q) \<longleftrightarrow> (\<not> Q \<longrightarrow> P)"
  by fast_prop

(*5*)
lemma "\<turnstile> ((P \<or> Q) \<longrightarrow> (P \<or> R)) \<longrightarrow> (P \<or> (Q \<longrightarrow> R))"
  by fast_prop

(*6*)
lemma "\<turnstile> P \<or> \<not> P"
  by fast_prop

(*7*)
lemma "\<turnstile> P \<or> \<not> \<not> \<not> P"
  by fast_prop

(*8.  Peirce's law*)
lemma "\<turnstile> ((P \<longrightarrow> Q) \<longrightarrow> P) \<longrightarrow> P"
  by fast_prop

(*9*)
lemma "\<turnstile> ((P \<or> Q) \<and> (\<not> P \<or> Q) \<and> (P \<or> \<not> Q)) \<longrightarrow> \<not> (\<not> P \<or> \<not> Q)"
  by fast_prop

(*10*)
lemma "Q \<longrightarrow> R, R \<longrightarrow> P \<and> Q, P \<longrightarrow> (Q \<or> R) \<turnstile> P \<longleftrightarrow> Q"
  by fast_prop

(*11.  Proved in each direction (incorrectly, says Pelletier!!)  *)
lemma "\<turnstile> P \<longleftrightarrow> P"
  by fast_prop

(*12.  "Dijkstra's law"*)
lemma "\<turnstile> ((P \<longleftrightarrow> Q) \<longleftrightarrow> R) \<longleftrightarrow> (P \<longleftrightarrow> (Q \<longleftrightarrow> R))"
  by fast_prop

(*13.  Distributive law*)
lemma "\<turnstile> P \<or> (Q \<and> R) \<longleftrightarrow> (P \<or> Q) \<and> (P \<or> R)"
  by fast_prop

(*14*)
lemma "\<turnstile> (P \<longleftrightarrow> Q) \<longleftrightarrow> ((Q \<or> \<not> P) \<and> (\<not> Q \<or> P))"
  by fast_prop

(*15*)
lemma "\<turnstile> (P \<longrightarrow> Q) \<longleftrightarrow> (\<not> P \<or> Q)"
  by fast_prop

(*16*)
lemma "\<turnstile> (P \<longrightarrow> Q) \<or> (Q \<longrightarrow> P)"
  by fast_prop

(*17*)
lemma "\<turnstile> ((P \<and> (Q \<longrightarrow> R)) \<longrightarrow> S) \<longleftrightarrow> ((\<not> P \<or> Q \<or> S) \<and> (\<not> P \<or> \<not> R \<or> S))"
  by fast_prop

end


(*  Title:       Computing Square Roots using the Babylonian Method
    Author:      René Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  René Thiemann
    License:     LGPL
*)

(*
Copyright 2009-2014 René Thiemann

This file is part of IsaFoR/CeTA.

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

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

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

theory Sqrt_Babylonian
imports
  Sqrt_Babylonian_Auxiliary
  NthRoot_Impl
begin

section \<open>Executable algorithms for square roots\<close>

text \<open>
  This theory provides executable algorithms for computing square-roots of numbers which
  are all based on the Babylonian method (which is also known as Heron's method or Newton's method).

  For integers / naturals / rationals precise algorithms are given, i.e., here $sqrt\ x$ delivers
  a list of all integers / naturals / rationals $y$ where $y^2 = x$.
  To this end, the Babylonian method has been adapted by using integer-divisions.

  In addition to the precise algorithms, we also provide approximation algorithms. One works for
  arbitrary linear ordered fields, where some number $y$ is computed such that
  @{term "abs(y^2 - x) < \<epsilon>"}. Moreover, for the naturals, integers, and rationals we provide algorithms to compute
  @{term "floor (sqrt x)"} and @{term "ceiling (sqrt x)"} which are all based
  on the underlying algorithm that is used to compute the precise square-roots on integers, if these
  exist.

  The major motivation for developing the precise algorithms was given by \ceta{} \cite{CeTA},
  a tool for certifiying termination proofs. Here, non-linear equations of the form
  $(a_1x_1 + \dots a_nx_n)^2 = p$ had to be solved over the integers, where $p$ is a concrete polynomial.
  For example, for the equation $(ax + by)^2 = 4x^2 - 12xy + 9y^2$ one easily figures out that
  $a^2 = 4, b^2 = 9$, and $ab = -6$, which results in a possible solution $a = \sqrt 4 = 2, b = - \sqrt 9 = -3$.
\<close>

subsection \<open>The Babylonian method\<close>

text \<open>
The Babylonian method for computing $\sqrt n$ iteratively computes
\[
x_{i+1} = \frac{\frac n{x_i} + x_i}2
\]
until $x_i^2 \approx n$. Note that if $x_0^2 \geq n$, then for all $i$ we have both
$x_i^2 \geq n$ and $x_i \geq x_{i+1}$.
\<close>

subsection \<open>The Babylonian method using integer division\<close>
text \<open>
  First, the algorithm is developed for the non-negative integers.
  Here, the division operation $\frac xy$ is replaced by @{term "x div y = \<lfloor>of_int x / of_int y\<rfloor>"}.
  Note that replacing @{term "\<lfloor>of_int x / of_int y\<rfloor>"} by @{term "\<lceil>of_int x / of_int y\<rceil>"} would lead to non-termination
  in the following algorithm.

  We explicititly develop the algorithm on the integers and not on the naturals, as the calculations
  on the integers have been much easier. For example, $y - x + x = y$ on the integers, which would require
  the side-condition $y \geq x$ for the naturals. These conditions will make the reasoning much more tedious---as
  we have experienced in an earlier state of this development where everything was based on naturals.

  Since the elements
  $x_0, x_1, x_2,\dots$ are monotone decreasing, in the main algorithm we abort as soon as $x_i^2 \leq n$.\<close>

text \<open>\textbf{Since in the meantime, all of these algorithms have been generalized to arbitrary
  $p$-th roots in @{theory Sqrt_Babylonian.NthRoot_Impl}, we just instantiate the general algorithms by $p = 2$ and then provide
  specialized code equations which are more efficient than the general purpose algorithms.}\<close>

definition sqrt_int_main' :: "int \<Rightarrow> int \<Rightarrow> int \<times> bool" where
  [simp]: "sqrt_int_main' x n = root_int_main' 1 1 2 x n"

lemma sqrt_int_main'_code[code]: "sqrt_int_main' x n = (let x2 = x * x in if x2 \<le> n then (x, x2 = n)
    else sqrt_int_main' ((n div x + x) div 2) n)"
  using root_int_main'.simps[of 1 1 2 x n]
  unfolding Let_def by auto

definition sqrt_int_main :: "int \<Rightarrow> int \<times> bool" where
  [simp]: "sqrt_int_main x = root_int_main 2 x"

lemma sqrt_int_main_code[code]: "sqrt_int_main x = sqrt_int_main' (start_value x 2) x"
  by (simp add: root_int_main_def Let_def)

definition sqrt_int :: "int \<Rightarrow> int list" where
  "sqrt_int x = root_int 2 x"

lemma sqrt_int_code[code]: "sqrt_int x = (if x < 0 then [] else case sqrt_int_main x of (y,True) \<Rightarrow> if y = 0 then [0] else [y,-y] | _ \<Rightarrow> [])"
proof -
  interpret fixed_root 2 1 by (unfold_locales, auto)
  obtain b y where res: "root_int_main 2 x = (b,y)" by force
  show ?thesis
    unfolding sqrt_int_def root_int_def Let_def
    using root_int_main[OF _ res]
    using res
    by simp
qed

lemma sqrt_int[simp]: "set (sqrt_int x) = {y. y * y = x}"
  unfolding sqrt_int_def by (simp add: power2_eq_square)

lemma sqrt_int_pos: assumes res: "sqrt_int x = Cons s ms"
  shows "s \<ge> 0"
proof -
  note res = res[unfolded sqrt_int_code Let_def, simplified]
  from res have x0: "x \<ge> 0" by (cases ?thesis, auto)
  obtain ss b where call: "sqrt_int_main x = (ss,b)" by force
  from res[unfolded call] x0 have "ss = s"
    by (cases b, cases "ss = 0", auto)
  from root_int_main(1)[OF x0 call[unfolded this sqrt_int_main_def]]
  show ?thesis .
qed

definition [simp]: "sqrt_int_floor_pos x = root_int_floor_pos 2 x"

lemma sqrt_int_floor_pos_code[code]: "sqrt_int_floor_pos x = fst (sqrt_int_main x)"
  by (simp add: root_int_floor_pos_def)

lemma sqrt_int_floor_pos: assumes x: "x \<ge> 0"
  shows "sqrt_int_floor_pos x = \<lfloor> sqrt (of_int x) \<rfloor>"
  using root_int_floor_pos[OF x, of 2] by (simp add: sqrt_def)

definition [simp]: "sqrt_int_ceiling_pos x = root_int_ceiling_pos 2 x"

lemma sqrt_int_ceiling_pos_code[code]: "sqrt_int_ceiling_pos x = (case sqrt_int_main x of (y,b) \<Rightarrow> if b then y else y + 1)"
  by (simp add: root_int_ceiling_pos_def)

lemma sqrt_int_ceiling_pos: assumes x: "x \<ge> 0"
  shows "sqrt_int_ceiling_pos x = \<lceil> sqrt (of_int x) \<rceil>"
  using root_int_ceiling_pos[OF x, of 2] by (simp add: sqrt_def)

definition "sqrt_int_floor x = root_int_floor 2 x"

lemma sqrt_int_floor_code[code]: "sqrt_int_floor x = (if x \<ge> 0 then sqrt_int_floor_pos x else - sqrt_int_ceiling_pos (- x))"
  unfolding sqrt_int_floor_def root_int_floor_def by simp

lemma sqrt_int_floor[simp]: "sqrt_int_floor x = \<lfloor> sqrt (of_int x) \<rfloor>"
  by (simp add: sqrt_int_floor_def sqrt_def)

definition "sqrt_int_ceiling x = root_int_ceiling 2 x"

lemma sqrt_int_ceiling_code[code]: "sqrt_int_ceiling x = (if x \<ge> 0 then sqrt_int_ceiling_pos x else - sqrt_int_floor_pos (- x))"
  unfolding sqrt_int_ceiling_def root_int_ceiling_def by simp

lemma sqrt_int_ceiling[simp]: "sqrt_int_ceiling x = \<lceil> sqrt (of_int x) \<rceil>"
  by (simp add: sqrt_int_ceiling_def sqrt_def)

lemma sqrt_int_ceiling_bound: "0 \<le> x \<Longrightarrow> x \<le> (sqrt_int_ceiling x)^2"
  unfolding sqrt_int_ceiling using le_of_int_ceiling sqrt_le_D
  by (metis of_int_power_le_of_int_cancel_iff)

subsection \<open>Square roots for the naturals\<close>

definition sqrt_nat :: "nat \<Rightarrow> nat list"
  where "sqrt_nat x = root_nat 2 x"

lemma sqrt_nat_code[code]: "sqrt_nat x \<equiv> map nat (take 1 (sqrt_int (int x)))"
  unfolding sqrt_nat_def root_nat_def sqrt_int_def by simp

lemma sqrt_nat[simp]: "set (sqrt_nat x) = { y. y * y = x}"
  unfolding sqrt_nat_def using root_nat[of 2 x] by (simp add: power2_eq_square)

definition sqrt_nat_floor :: "nat \<Rightarrow> int" where
  "sqrt_nat_floor x = root_nat_floor 2 x"

lemma sqrt_nat_floor_code[code]: "sqrt_nat_floor x = sqrt_int_floor_pos (int x)"
  unfolding sqrt_nat_floor_def root_nat_floor_def by simp

lemma sqrt_nat_floor[simp]: "sqrt_nat_floor x = \<lfloor> sqrt (real x) \<rfloor>"
  unfolding sqrt_nat_floor_def by (simp add: sqrt_def)

definition sqrt_nat_ceiling :: "nat \<Rightarrow> int" where
  "sqrt_nat_ceiling x = root_nat_ceiling 2 x"

lemma sqrt_nat_ceiling_code[code]: "sqrt_nat_ceiling x = sqrt_int_ceiling_pos (int x)"
  unfolding sqrt_nat_ceiling_def root_nat_ceiling_def by simp

lemma sqrt_nat_ceiling[simp]: "sqrt_nat_ceiling x = \<lceil> sqrt (real x) \<rceil>"
  unfolding sqrt_nat_ceiling_def by (simp add: sqrt_def)

subsection \<open>Square roots for the rationals\<close>

definition sqrt_rat :: "rat \<Rightarrow> rat list" where
  "sqrt_rat x = root_rat 2 x"

lemma sqrt_rat_code[code]: "sqrt_rat x = (case quotient_of x of (z,n) \<Rightarrow> (case sqrt_int n of
    [] \<Rightarrow> []
  | sn # xs \<Rightarrow> map (\<lambda> sz. of_int sz / of_int sn) (sqrt_int z)))"
proof -
  obtain z n where q: "quotient_of x = (z,n)" by force
  show ?thesis
  unfolding sqrt_rat_def root_rat_def q split sqrt_int_def
  by (cases "root_int 2 n", auto)
qed

lemma sqrt_rat[simp]: "set (sqrt_rat x) = { y. y * y = x}"
  unfolding sqrt_rat_def using root_rat[of 2 x]
  by (simp add: power2_eq_square)

lemma sqrt_rat_pos: assumes sqrt: "sqrt_rat x = Cons s ms"
  shows "s \<ge> 0"
proof -
  obtain z n where q: "quotient_of x = (z,n)" by force
  note sqrt = sqrt[unfolded sqrt_rat_code q, simplified]
  let ?sz = "sqrt_int z"
  let ?sn = "sqrt_int n"
  from q have n: "n > 0" by (rule quotient_of_denom_pos)
  from sqrt obtain sz mz where sz: "?sz = sz # mz" by (cases ?sn, auto)
  from sqrt obtain sn mn where sn: "?sn = sn # mn" by (cases ?sn, auto)
  from sqrt_int_pos[OF sz] sqrt_int_pos[OF sn] have pos: "0 \<le> sz" "0 \<le> sn" by auto
  from sqrt sz sn have s: "s = of_int sz / of_int sn" by auto
  show ?thesis unfolding s using pos
    by (metis of_int_0_le_iff zero_le_divide_iff)
qed

definition sqrt_rat_floor :: "rat \<Rightarrow> int" where
  "sqrt_rat_floor x = root_rat_floor 2 x"

lemma sqrt_rat_floor_code[code]: "sqrt_rat_floor x = (case quotient_of x of (a,b) \<Rightarrow> sqrt_int_floor (a * b) div b)"
  unfolding sqrt_rat_floor_def root_rat_floor_def by (simp add: sqrt_def)

lemma sqrt_rat_floor[simp]: "sqrt_rat_floor x = \<lfloor> sqrt (of_rat x) \<rfloor>"
  unfolding sqrt_rat_floor_def by (simp add: sqrt_def)

definition sqrt_rat_ceiling :: "rat \<Rightarrow> int" where
  "sqrt_rat_ceiling x = root_rat_ceiling 2 x"

lemma sqrt_rat_ceiling_code[code]: "sqrt_rat_ceiling x = - (sqrt_rat_floor (-x))"
  unfolding sqrt_rat_ceiling_def sqrt_rat_floor_def root_rat_ceiling_def by simp

lemma sqrt_rat_ceiling: "sqrt_rat_ceiling x = \<lceil> sqrt (of_rat x) \<rceil>"
  unfolding sqrt_rat_ceiling_def by (simp add: sqrt_def)

lemma sqr_rat_of_int: assumes x: "x * x = rat_of_int i"
  shows "\<exists> j :: int. j * j = i"
proof -
  from x have mem: "x \<in> set (sqrt_rat (rat_of_int i))" by simp
  from x have "rat_of_int i \<ge> 0" by (metis zero_le_square)
  hence *: "quotient_of (rat_of_int i) = (i,1)" by (metis quotient_of_int)
  have 1: "sqrt_int 1 = [1,-1]" by code_simp
  from mem sqrt_rat_code * split 1
  have x: "x \<in> rat_of_int ` {y. y * y = i}" by auto
  thus ?thesis by auto
qed

subsection \<open>Approximating square roots\<close>

text \<open>
  The difference to the previous algorithms is that now we abort, once the distance is below
  $\epsilon$.
  Moreover, here we use standard division and not integer division.
  This part is not yet generalized by @{theory Sqrt_Babylonian.NthRoot_Impl}.

  We first provide the executable version without guard @{term "x > 0"} as partial function,
  and afterwards prove termination and soundness for a similar algorithm that is defined within the upcoming
locale.
\<close>

partial_function (tailrec) sqrt_approx_main_impl :: "'a :: linordered_field \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" where
  [code]: "sqrt_approx_main_impl \<epsilon> n x = (if x * x - n < \<epsilon> then x else sqrt_approx_main_impl \<epsilon> n
    ((n / x + x) / 2))"

text \<open>We setup a locale where we ensure that we have standard assumptions: positive $\epsilon$ and
  positive $n$. We require sort @{term floor_ceiling}, since @{term "\<lfloor> x \<rfloor>"} is used for the termination
  argument.\<close>
locale sqrt_approximation =
  fixes \<epsilon> :: "'a :: {linordered_field,floor_ceiling}"
  and n :: 'a
  assumes \<epsilon> : "\<epsilon> > 0"
  and n: "n > 0"
begin

function sqrt_approx_main :: "'a \<Rightarrow> 'a" where
  "sqrt_approx_main x = (if x > 0 then (if x * x - n < \<epsilon> then x else sqrt_approx_main
    ((n / x + x) / 2)) else 0)"
    by pat_completeness auto

text \<open>Termination essentially is a proof of convergence. Here, one complication is the fact
  that the limit is not always defined. E.g., if @{typ "'a"} is @{typ rat} then there is no
  square root of 2. Therefore, the error-rate $\frac x{\sqrt n} - 1$ is not expressible.
  Instead we use the expression $\frac{x^2}n - 1$ as error-rate which
  does not require any square-root operation.\<close>
termination
proof -
  define er where "er x = (x * x / n - 1)" for x
  define c where "c = 2 * n / \<epsilon>"
  define m where "m x = nat \<lfloor> c * er x \<rfloor>" for x
  have c: "c > 0" unfolding c_def using n \<epsilon> by auto
  show ?thesis
  proof
    show "wf (measures [m])" by simp
  next
    fix x
    assume x: "0 < x" and xe: "\<not> x * x - n < \<epsilon>"
    define y where "y = (n / x + x) / 2"
    show "((n / x + x) / 2,x) \<in> measures [m]" unfolding y_def[symmetric]
    proof (rule measures_less)
      from n have inv_n: "1 / n > 0" by auto
      from xe have "x * x - n \<ge> \<epsilon>" by simp
      from this[unfolded mult_le_cancel_left_pos[OF inv_n, of \<epsilon>, symmetric]]
      have erxen: "er x \<ge> \<epsilon> / n" unfolding er_def using n by (simp add: field_simps)
      have en: "\<epsilon> / n > 0" and ne: "n / \<epsilon> > 0" using \<epsilon> n by auto
      from en erxen have erx: "er x > 0" by linarith
      have pos: "er x * 4 + er x * (er x * 4) > 0" using erx
        by (auto intro: add_pos_nonneg)
      have "er y = 1 / 4 * (n / (x * x) - 2  + x * x / n)" unfolding er_def y_def using x n
        by (simp add: field_simps)
      also have "\<dots> = 1 / 4 * er x * er x / (1 + er x)" unfolding er_def using x n
        by (simp add: field_simps)
      finally have "er y = 1 / 4 * er x * er x / (1 + er x)" .
      also have "\<dots> < 1 / 4 * (1 + er x) * er x / (1 + er x)" using erx erx pos
        by (auto simp: field_simps)
      also have "\<dots> = er x / 4" using erx by (simp add: field_simps)
      finally have er_y_x: "er y \<le> er x / 4" by linarith
      from erxen have "c * er x \<ge> 2" unfolding c_def mult_le_cancel_left_pos[OF ne, of _ "er x", symmetric]
        using n \<epsilon> by (auto simp: field_simps)
      hence pos: "\<lfloor>c * er x\<rfloor> > 0" "\<lfloor>c * er x\<rfloor> \<ge> 2" by auto
      show "m y < m x" unfolding m_def nat_mono_iff[OF pos(1)]
      proof -
        have "\<lfloor>c * er y\<rfloor> \<le> \<lfloor>c * (er x / 4)\<rfloor>"
          by (rule floor_mono, unfold mult_le_cancel_left_pos[OF c], rule er_y_x)
        also have "\<dots> < \<lfloor>c * er x / 4 + 1\<rfloor>" by auto
        also have "\<dots> \<le> \<lfloor>c * er x\<rfloor>"
          by (rule floor_mono, insert pos(2), simp add: field_simps)
        finally show "\<lfloor>c * er y\<rfloor> < \<lfloor>c * er x\<rfloor>" .
      qed
    qed
  qed
qed

text \<open>Once termination is proven, it is easy to show equivalence of
  @{const sqrt_approx_main_impl} and @{const sqrt_approx_main}.\<close>
lemma sqrt_approx_main_impl: "x > 0 \<Longrightarrow> sqrt_approx_main_impl \<epsilon> n x = sqrt_approx_main x"
proof (induct x rule: sqrt_approx_main.induct)
  case (1 x)
  hence x: "x > 0" by auto
  hence nx: "0 < (n / x + x) / 2" using n by (auto intro: pos_add_strict)
  note simps = sqrt_approx_main_impl.simps[of _ _ x] sqrt_approx_main.simps[of x]
  show ?case
  proof (cases "x * x - n < \<epsilon>")
    case True
    thus ?thesis unfolding simps using x by auto
  next
    case False
    show ?thesis using 1(1)[OF x False nx] unfolding simps using x False by auto
  qed
qed

text \<open>Also soundness is not complicated.\<close>

lemma sqrt_approx_main_sound: assumes x: "x > 0" and xx: "x * x > n"
  shows "sqrt_approx_main x * sqrt_approx_main x > n \<and> sqrt_approx_main x * sqrt_approx_main x - n < \<epsilon>"
  using assms
proof (induct x rule: sqrt_approx_main.induct)
  case (1 x)
  from 1 have x:  "x > 0" "(x > 0) = True" by auto
  note simp = sqrt_approx_main.simps[of x, unfolded x if_True]
  show ?case
  proof (cases "x * x - n < \<epsilon>")
    case True
    with 1 show ?thesis unfolding simp by simp
  next
    case False
    let ?y = "(n / x + x) / 2"
    from False simp have simp: "sqrt_approx_main x = sqrt_approx_main ?y" by simp
    from n x have y: "?y > 0" by (auto intro: pos_add_strict)
    note IH = 1(1)[OF x(1) False y]
    from x have x4: "4 * x * x > 0" by (auto intro: mult_sign_intros)
    show ?thesis unfolding simp
    proof (rule IH)
      show "n < ?y * ?y"
        unfolding mult_less_cancel_left_pos[OF x4, of n, symmetric]
      proof -
        have id: "4 * x * x * (?y * ?y) = 4 * x * x * n + (n - x * x) * (n - x * x)" using x(1)
          by (simp add: field_simps)
        from 1(3) have "x * x - n > 0" by auto
        from mult_pos_pos[OF this this]
        show "4 * x * x * n < 4 * x * x * (?y * ?y)" unfolding id
          by (simp add: field_simps)
      qed
    qed
  qed
qed

end

text \<open>It remains to assemble everything into one algorithm.\<close>

definition sqrt_approx :: "'a :: {linordered_field,floor_ceiling} \<Rightarrow> 'a \<Rightarrow> 'a" where
  "sqrt_approx \<epsilon> x \<equiv> if \<epsilon> > 0 then (if x = 0 then 0 else let xpos = abs x in sqrt_approx_main_impl \<epsilon> xpos (xpos + 1)) else 0"

lemma sqrt_approx: assumes \<epsilon>: "\<epsilon> > 0"
  shows "\<bar>sqrt_approx \<epsilon> x * sqrt_approx \<epsilon> x - \<bar>x\<bar>\<bar> < \<epsilon>"
proof (cases "x = 0")
  case True
  with \<epsilon> show ?thesis unfolding sqrt_approx_def by auto
next
  case False
  let ?x = "\<bar>x\<bar>"
  let ?sqrti = "sqrt_approx_main_impl \<epsilon> ?x (?x + 1)"
  let ?sqrt = "sqrt_approximation.sqrt_approx_main \<epsilon> ?x (?x + 1)"
  define sqrt where "sqrt = ?sqrt"
  from False have x: "?x > 0" "?x + 1 > 0" by auto
  interpret sqrt_approximation \<epsilon> ?x
    by (unfold_locales, insert x \<epsilon>, auto)
  from False \<epsilon> have "sqrt_approx \<epsilon> x = ?sqrti" unfolding sqrt_approx_def by (simp add: Let_def)
  also have "?sqrti = ?sqrt"
    by (rule sqrt_approx_main_impl, auto)
  finally have id: "sqrt_approx \<epsilon> x = sqrt" unfolding sqrt_def .
  have sqrt: "sqrt * sqrt > ?x \<and> sqrt * sqrt - ?x < \<epsilon>" unfolding sqrt_def
    by (rule sqrt_approx_main_sound[OF x(2)], insert x mult_pos_pos[OF x(1) x(1)], auto simp: field_simps)
  show ?thesis unfolding id using sqrt by auto
qed

subsection \<open>Some tests\<close>

text \<open>Testing executabity and show that sqrt 2 is irrational\<close>
lemma "\<not> (\<exists> i :: rat. i * i = 2)"
proof -
  have "set (sqrt_rat 2) = {}" by eval
  thus ?thesis by simp
qed

text \<open>Testing speed\<close>
lemma "\<not> (\<exists> i :: int. i * i = 1234567890123456789012345678901234567890)"
proof -
  have "set (sqrt_int 1234567890123456789012345678901234567890) = {}" by eval
  thus ?thesis by simp
qed

text \<open>The following test\<close>

value "let \<epsilon> = 1 / 100000000 :: rat; s = sqrt_approx \<epsilon> 2 in (s, s * s - 2, \<bar>s * s - 2\<bar> < \<epsilon>)"

text \<open>results in (1.4142135623731116, 4.738200762148612e-14, True).\<close>

end


 (*
    File:      Group_Adjoin.thy
    Author:    Manuel Eberl, TU München
*)
section \<open>Adjoining Elements to a Finite Abelian Group\<close>
theory Group_Adjoin
imports
  Complex_Main
  "HOL-Algebra.Multiplicative_Group"
begin

text \<open>
  This theory provides the notion of adjoining a single element to a subgroup of a finite
  abelian group, and, in particular, an induction principle based upon this: We can show that
  some property holds for a group by showing that it holds for some fixed subgroup and that
  it is preserved when adjoining a single element.

  The general idea for this was taken from Apostol's
  ``Analytic Number Theory''~\cite{apostol1976analytic}.
\<close>

subsection \<open>Miscellaneous Group Theory\<close>

lemma (in group) ord_min:
  assumes "m \<ge> 1" "x \<in> carrier G" "x [^] m = \<one>"
  shows   "ord x \<le> m"
  using assms pow_eq_id by auto

lemma (in group) bij_betw_mult_left [intro]:
  assumes [simp]: "x \<in> carrier G"
  shows "bij_betw (\<lambda>y. x \<otimes> y) (carrier G) (carrier G)"
  by (intro bij_betwI[where ?g = "\<lambda>y. inv x \<otimes> y"])
     (auto simp: m_assoc [symmetric])

locale finite_comm_group = comm_group +
  assumes fin [intro]: "finite (carrier G)"
begin

lemma order_gt_0 [simp,intro]: "order G > 0"
  by (subst order_gt_0_iff_finite) auto

lemma subgroup_imp_finite_comm_group:
  assumes "subgroup H G"
  shows   "finite_comm_group (G\<lparr>carrier := H\<rparr>)"
proof -
  interpret G': group "G\<lparr>carrier := H\<rparr>" by (intro subgroup_imp_group) fact+
  interpret H: subgroup H G by fact
  show ?thesis by standard (insert finite_subset[OF H.subset fin], auto simp: m_comm)
qed

end

subsection \<open>Subgroup indicators and adjoining elements\<close>

definition subgroup_indicator :: "('a, 'b) monoid_scheme \<Rightarrow> 'a set \<Rightarrow> 'a \<Rightarrow> nat" where
  "subgroup_indicator G H a = (LEAST k. k > 0 \<and> a [^]\<^bsub>G\<^esub> k \<in> H)"

definition adjoin :: "('a, 'b) monoid_scheme \<Rightarrow> 'a set \<Rightarrow> 'a \<Rightarrow> 'a set" where
  "adjoin G H a = {x \<otimes>\<^bsub>G\<^esub> a [^]\<^bsub>G\<^esub> k |x k. x \<in> H \<and> k < subgroup_indicator G H a}"

lemma (in subgroup) nat_pow_closed [simp,intro]: "a \<in> H \<Longrightarrow> pow G a (n::nat) \<in> H"
  by (induction n) (auto simp: nat_pow_def)

lemma nat_pow_modify_carrier: "a [^]\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> b = a [^]\<^bsub>G\<^esub> (b::nat)"
  by (simp add: nat_pow_def)

lemma subgroup_indicator_modify_carrier [simp]:
  "subgroup_indicator (G\<lparr>carrier := H'\<rparr>) H a = subgroup_indicator G H a"
  by (auto simp: subgroup_indicator_def nat_pow_def)

lemma adjoin_modify_carrier [simp]:
  "adjoin (G\<lparr>carrier := H'\<rparr>) H a = adjoin G H a"
  by (simp_all add: adjoin_def nat_pow_def)

context group
begin

lemma subgroup_indicator_eq_1:
  assumes "a \<in> H" "a \<in> carrier G"
  shows   "subgroup_indicator G H a = 1"
proof -
  from assms show ?thesis
    unfolding subgroup_indicator_def
    by (intro Least_equality) (auto simp: nat_pow_def)
qed

lemma subgroup_indicator_le:
  assumes "a [^] n \<in> H" "n > 0"  "a \<in> carrier G"
  shows   "subgroup_indicator G H a \<le> n"
  using assms unfolding subgroup_indicator_def by (intro Least_le) auto

end

context finite_comm_group
begin

lemma ord_pos:
  assumes "x \<in> carrier G"
  shows   "ord x > 0"
  using ord_ge_1[of x] assms fin by auto

lemma
  assumes "subgroup H G" and a: "a \<in> carrier G"
  shows subgroup_indicator_pos: "subgroup_indicator G H a > 0" (is "?h > 0")
  and   pow_subgroup_indicator: "a [^] subgroup_indicator G H a \<in> H"
proof -
  interpret subgroup H G by fact
  from a have "\<exists>h>0. a [^] (h::nat) \<in> H"
    by (intro exI[of _ "ord a"]) (auto simp: ord_pos pow_ord_eq_1 fin)
  hence "?h > 0 \<and> a [^] ?h \<in> H" unfolding subgroup_indicator_def
    by (rule LeastI_ex)
  thus "?h > 0" and "a [^] ?h \<in> H" by auto
qed

lemma subgroup_indicator_le_ord:
  assumes "a \<in> carrier G" "subgroup H G"
  shows   "subgroup_indicator G H a \<le> ord a"
proof -
  interpret subgroup H G by fact
  from assms show ?thesis by (intro subgroup_indicator_le) (auto simp: pow_ord_eq_1 fin ord_pos)
qed

lemma subgroup_indicator_trivial:
  assumes "a \<in> carrier G"
  shows   "subgroup_indicator G {\<one>} a = group.ord G a"
proof -
  have sg[simp]: "subgroup {\<one>} G" by standard auto
  from pow_subgroup_indicator[OF sg assms] and assms show ?thesis
    by (intro antisym subgroup_indicator_le_ord ord_min)
       (auto simp: Suc_le_eq subgroup_indicator_pos)
qed

lemma mem_adjoin:
  assumes "subgroup H G" "x \<in> H" "a \<in> carrier G"
  shows   "x \<in> adjoin G H a"
proof -
  interpret subgroup H G by fact
  from assms show ?thesis
    by (auto simp: adjoin_def intro!: exI[of _ x] exI[of _ 0] subgroup_indicator_pos)
qed

lemma adjoin_subgroup:
  assumes "subgroup H G" and a: "a \<in> carrier G"
  shows   "subgroup (adjoin G H a) G"
proof (standard, goal_cases)
  case 1
  interpret subgroup H G by fact
  from a show ?case by (auto simp: adjoin_def)
next
  case (2 x y)
  interpret subgroup H G by fact
  define h where "h = subgroup_indicator G H a"
  from assms have [simp]: "h > 0"
    unfolding h_def by (intro subgroup_indicator_pos) auto
  from 2(1) obtain x' :: 'a and k :: nat where [simp]: "x' \<in> H" "x = x' \<otimes> a [^] k"
    by (auto simp: adjoin_def)
  from 2(2) obtain y' :: 'a and l :: nat where [simp]: "y' \<in> H" "y = y' \<otimes> a [^] l"
    by (auto simp: adjoin_def)
  define a' where "a' = (a [^] h) [^] ((k + l) div h)"
  have [simp]: "a' \<in> H" unfolding a'_def
    by (rule nat_pow_closed) (insert assms, auto simp: h_def intro!: pow_subgroup_indicator)
  from a have "x \<otimes> y = (x' \<otimes> y') \<otimes> a [^] (k + l)"
    by (simp add: nat_pow_mult [symmetric] m_ac)
  also have "k + l = h * ((k + l) div h) + (k + l) mod h"
    by (rule mult_div_mod_eq [symmetric])
  also from a fin have "a [^] \<dots> = a' \<otimes> a [^] ((k + l) mod h)"
    by (subst nat_pow_mult [symmetric])
       (simp_all add: nat_pow_pow [symmetric] pow_ord_eq_1 a'_def [symmetric])
  finally have "x \<otimes> y = x' \<otimes> y' \<otimes> a' \<otimes> a [^] ((k + l) mod h)"
    using a by (simp add: m_ac)
  moreover from a have "(k + l) mod h < h"
    by (intro mod_less_divisor) (auto simp: ord_pos)
  ultimately show ?case
    by (auto simp: adjoin_def h_def intro!: exI[of _ "x' \<otimes> y' \<otimes> a'"] exI[of _ "(k + l) mod h"])
next
  case 3
  interpret subgroup H G by fact
  from assms show ?case
    by (auto simp: adjoin_def intro!: exI[of _ \<one>] exI[of _ 0] subgroup_indicator_pos)
next
  case (4 x)
  interpret H: subgroup H G by fact
  define h where "h = subgroup_indicator G H a"
  define a' where "a' = a [^] h"
  from assms have [simp]: "a' \<in> H" unfolding a'_def h_def
    by (intro pow_subgroup_indicator) auto
  from 4 obtain x' and k :: nat where [simp]: "x' \<in> H" "x = x' \<otimes> a [^] k" and "k < h"
    by (auto simp: adjoin_def h_def)
  show ?case
  proof (cases "k = 0")
    case True
    with assms show ?thesis
      by (auto simp: mem_adjoin)
  next
    case False
    from a have "inv x = inv x' \<otimes> inv (a [^] k)"
      by (simp add: inv_mult)
    also have "\<dots> = inv x' \<otimes> (inv a' \<otimes> a') \<otimes> inv (a [^] k)" by simp
    also have "\<dots> = inv x' \<otimes> inv a' \<otimes> (a' \<otimes> inv (a [^] k))"
      by (simp only: \<open>a' \<in> H\<close> \<open>x' \<in> H\<close> inv_closed m_closed H.mem_carrier m_ac nat_pow_closed a)
    also from a have "a' \<otimes> inv (a [^] k) = a [^] (int h - int k)"
      by (subst int_pow_diff) (auto simp: a'_def int_pow_int)
    also from \<open>k < h\<close> have "int h - int k = int (h - k)"
      by simp
    also have "a [^] \<dots> = a [^] (h - k)"
      by (simp add: int_pow_int)
    finally have "inv x = inv x' \<otimes> inv a' \<otimes> a [^] (h - k)" .
    moreover have "h - k < h" using \<open>k < h\<close> and False by simp
    ultimately show ?thesis
      by (auto simp: adjoin_def h_def intro!: exI[of _ "inv x' \<otimes> inv a'"] exI[of _ "h - k"])
  qed
qed

lemma adjoin_id:
  assumes "subgroup H G" and a: "a \<in> H"
  shows   "adjoin G H a = H"
proof -
  interpret subgroup H G by fact
  show ?thesis
  proof safe
    fix x assume "x \<in> H"
    with assms show "x \<in> adjoin G H a"
      by (auto simp: adjoin_def intro!: exI[of _ x] exI[of _ 0] subgroup_indicator_pos)
  qed (insert a, auto simp: adjoin_def)
qed

lemma adjoined_in_adjoin:
  assumes "subgroup H G" and a: "a \<in> carrier G"
  shows   "a \<in> adjoin G H a"
proof (cases "a \<in> H")
  case True
  with assms show ?thesis by (subst adjoin_id) auto
next
  case False
  interpret subgroup H G by fact
  from assms have "subgroup_indicator G H a > 0"
    by (intro subgroup_indicator_pos) auto
  moreover from False and assms and pow_subgroup_indicator[OF assms]
    have "subgroup_indicator G H a \<noteq> 1" by (intro notI) auto
  ultimately have "subgroup_indicator G H a > 1" by simp
  with assms show ?thesis
    by (auto simp: adjoin_def intro!: exI[of _ \<one>] exI[of _ 1])
qed

lemma adjoin_subset:
  assumes "subgroup H G" and a: "a \<in> carrier G"
  shows   "adjoin G H a \<subseteq> carrier G"
proof -
  interpret subgroup H G by fact
  from a show ?thesis by (auto simp: adjoin_def)
qed

lemma inj_on_adjoin:
  assumes "subgroup H G" and a: "a \<in> carrier G" "a \<notin> H"
  defines "h \<equiv> subgroup_indicator G H a"
  shows   "inj_on (\<lambda>(x, k). x \<otimes> a [^] k) (H \<times> {..<h})"
proof (intro inj_onI, clarify, goal_cases)
  case (1 x k y l)
  interpret H: subgroup H G by fact
  have wf: "x \<in> carrier G" "y \<in> carrier G" "a [^] k \<in> carrier G" "a [^] l \<in> carrier G"
    using 1 a by auto
  have "x \<otimes> inv y = (x \<otimes> inv y) \<otimes> (a [^] k \<otimes> inv (a [^] k))"
    by (simp add: wf)
  also have "\<dots> = x \<otimes> a [^] k \<otimes> inv y \<otimes> inv (a [^] k)"
    by (simp only: m_ac wf inv_closed m_closed)
  also from a have "\<dots> = y \<otimes> a [^] l \<otimes> inv y \<otimes> inv (a [^] k)"
    by (subst 1) (simp_all)
  also have "\<dots> = y \<otimes> inv y \<otimes> (a [^] l \<otimes> inv (a [^] k))"
    by (simp only: m_ac wf inv_closed m_closed)
  also from wf have "\<dots> = a [^] int l \<otimes> inv (a [^] int k)"
    by (simp add: int_pow_int)
  also have "\<dots> = a [^] (int l - int k)"
    by (rule int_pow_diff [symmetric]) fact+
  finally have *: "x \<otimes> inv y = a [^] (int l - int k)" .

  have **: "a [^] (nat \<bar>int l - int k\<bar>) \<in> H"
  proof (cases "k \<le> l")
    case True
    from 1 have "a [^] (int l - int k) \<in> H" by (subst * [symmetric]) auto
    also have "a [^] (int l - int k) = a [^] (nat \<bar>int l - int k\<bar>)"
      using True by (simp add: nat_diff_distrib int_pow_int [symmetric] of_nat_diff)
    finally show ?thesis .
  next
    case False
    from 1 have "inv (a [^] (int l - int k)) \<in> H" by (subst * [symmetric]) auto
    also have "inv (a [^] (int l - int k)) = a [^] (nat \<bar>int l - int k\<bar>)" using False a
      by (simp add: int_pow_neg [symmetric] nat_diff_distrib int_pow_int [symmetric] of_nat_diff)
    finally show ?thesis .
  qed
  have "k = l"
  proof (rule ccontr)
    assume "k \<noteq> l"
    with a and ** have "h \<le> nat \<bar>int l - int k\<bar>" unfolding h_def
      by (intro subgroup_indicator_le) auto
    also have "\<dots> < h" using \<open>l < h\<close> and \<open>k < h\<close> by linarith
    finally show False ..
  qed
  with 1 and a show ?case by simp
qed

lemma card_adjoin:
  assumes "subgroup H G" and a: "a \<in> carrier G" "a \<notin> H"
  shows   "card (adjoin G H a) = card H * subgroup_indicator G H a"
proof -
  interpret H: subgroup H G by fact
  define h where "h = subgroup_indicator G H a"
  have "adjoin G H a = (\<lambda>(x,k). x \<otimes> a [^] k) ` (H \<times> {..<h})"
    by (auto simp: adjoin_def h_def)
  also have "card \<dots> = card (H \<times> {..<h})" unfolding h_def
    by (intro card_image inj_on_adjoin assms)
  finally show ?thesis by (simp add: h_def card_cartesian_product)
qed

end

locale finite_comm_group_adjoin = finite_comm_group + subgroup H
  for H +
  fixes a :: 'a
  assumes a_in_carrier [simp]: "a \<in> carrier G"
  assumes a_notin_subgroup: "a \<notin> H"
begin

definition unadjoin :: "'a \<Rightarrow> 'a \<times> nat"  where
  "unadjoin x =
     (THE z. z \<in> H \<times> {..<subgroup_indicator G H a} \<and> x = fst z \<otimes>\<^bsub>G\<^esub> a [^]\<^bsub>G\<^esub> snd z)"

lemma adjoin_unique:
  assumes "x \<in> adjoin G H a"
  defines "h \<equiv> subgroup_indicator G H a"
  shows   "\<exists>!z. z \<in> H \<times> {..<subgroup_indicator G H a} \<and> x = fst z \<otimes>\<^bsub>G\<^esub> a [^]\<^bsub>G\<^esub> snd z"
proof (rule ex_ex1I, goal_cases)
  case 1
  from assms show ?case by (auto simp: adjoin_def)
next
  case (2 z1 z2)
  have "subgroup H G" ..
  from inj_on_adjoin[OF this a_in_carrier a_notin_subgroup]
  show ?case by (rule inj_onD) (use 2 in auto)
qed

lemma unadjoin_correct:
  assumes "x \<in> adjoin G H a"
  shows   "fst (unadjoin x) \<in> H" and "snd (unadjoin x) < subgroup_indicator G H a"
          "fst (unadjoin x) \<otimes> a [^] snd (unadjoin x) = x"
  using theI'[OF adjoin_unique[OF assms], folded unadjoin_def] by auto

lemma unadjoin_unique:
  assumes "y \<in> H" "h < subgroup_indicator G H a"
  shows   "unadjoin (y \<otimes> a [^] h) = (y, h)"
proof -
  from assms have "y \<otimes> a [^] h \<in> adjoin G H a" by (auto simp: adjoin_def)
  note * = theI'[OF adjoin_unique[OF this], folded unadjoin_def]
  from inj_on_adjoin[OF is_subgroup a_in_carrier a_notin_subgroup] show ?thesis
    by (rule inj_onD) (insert * assms, auto)
qed

lemma unadjoin_unique':
  assumes "y \<in> H" "h < subgroup_indicator G H a" "x = y \<otimes> a [^] h"
  shows   "unadjoin x = (y, h)"
  using unadjoin_unique[OF assms(1,2)] assms(3) by simp

lemma unadjoin_1 [simp]: "unadjoin \<one> = (\<one>, 0)"
  by (intro unadjoin_unique') (auto intro!: subgroup_indicator_pos is_subgroup)

lemma unadjoin_in_base [simp]: "x \<in> H \<Longrightarrow> unadjoin x = (x, 0)"
  by (intro unadjoin_unique') (auto intro!: subgroup_indicator_pos is_subgroup)

lemma unadjoin_adjoined [simp]: "unadjoin a = (\<one>, 1)"
proof (rule unadjoin_unique')
  have "subgroup_indicator G H a \<noteq> 1" using is_subgroup a_notin_subgroup
    using pow_subgroup_indicator[of H a] by auto
  with subgroup_indicator_pos [OF is_subgroup a_in_carrier]
    show "subgroup_indicator G H a > 1" by simp
qed auto

end

subsection \<open>Induction by adjoining elements\<close>

context finite_comm_group
begin

lemma group_decompose_adjoin_aux:
  assumes "subgroup H G"
  shows   "H = carrier G \<or>
           (\<exists>H' a. H \<subseteq> H' \<and> subgroup H' G \<and> a \<in> carrier G - H' \<and> carrier G = adjoin G H' a)"
proof -
  have ind: "(\<And>H. subgroup H G \<Longrightarrow> H \<noteq> carrier G \<Longrightarrow> P (adjoin G H (SOME a. a \<in> carrier G - H))
                \<Longrightarrow> P H) \<Longrightarrow> (\<And>H. subgroup H G \<Longrightarrow> H = carrier G \<Longrightarrow> P H) \<Longrightarrow>
                (\<And>H. \<not> subgroup H G \<Longrightarrow> P H) \<Longrightarrow> P a0" for P a0
  proof (induction_schema, force, rule wf_bounded_set)
    fix H assume H: "subgroup H G" "H \<noteq> carrier G"
    interpret subgroup H G by fact
    from H have H': "H \<subset> carrier G" by auto
    define a where "a = (SOME a. a \<in> carrier G - H)"
    have a: "a \<in> carrier G - H" unfolding a_def
      by (rule someI_ex) (insert H', auto)
    from a and H have "adjoin G H a \<subseteq> carrier G" by (intro adjoin_subset) auto
    from a and H have "a \<in> adjoin G H a" "a \<notin> H"
      by (auto simp: adjoined_in_adjoin)
    hence "adjoin G H a \<noteq> H" by blast
    with H and a show "(adjoin G H a, H) \<in> {(B,A). A \<subset> B \<and> B \<subseteq> carrier G}"
      using adjoin_subset[of H a] by (auto intro: mem_adjoin)
  next
    fix A B assume "(B, A) \<in> {(B, A). A \<subset> B \<and> B \<subseteq> carrier G}"
    thus "finite (carrier G) \<and> carrier G \<subseteq> carrier G \<and> B \<subseteq> carrier G \<and> A \<subset> B"
      by auto
  qed

  from assms show ?thesis
  proof (induction H rule: ind)
    case (1 H)
    interpret subgroup H G by fact
    define a where "a = (SOME a. a \<in> carrier G - H)"
    from "1.hyps" have "\<exists>a. a \<in> carrier G - H" by auto
    hence a: "a \<in> carrier G - H" unfolding a_def by (rule someI_ex)

    from "1.hyps" and a have "subgroup (adjoin G H a) G"
      by (intro adjoin_subgroup) auto
    from "1.IH"[folded a_def, OF this]
      have "(\<exists>H' a. H \<subseteq> H' \<and> subgroup H' G \<and> a \<in> carrier G - H' \<and> carrier G = adjoin G H' a)"
    proof (elim disjE, goal_cases)
      case 1
      with a and \<open>subgroup H G\<close> show ?case
        by (intro exI[of _ H] exI[of _ a]) simp_all
    next
      case 2
      then obtain H' a' where *: "adjoin G H a \<subseteq> H'" "subgroup H' G"
                                 "a' \<in> carrier G - H'" "carrier G = adjoin G H' a'" by blast
      thus ?case using mem_adjoin[OF \<open>subgroup H G\<close>, of _ a] a
        by (intro exI[of _ H'] exI[of _ a']) auto
    qed
    thus ?case by blast
  qed auto
qed

lemma group_decompose_adjoin:
  assumes "subgroup H0 G" "H0 \<noteq> carrier G"
  obtains H a where "H0 \<subseteq> H" "subgroup H G" "a \<in> carrier G - H" "carrier G = adjoin G H a"
proof -
  from group_decompose_adjoin_aux[OF assms(1)] and assms(2) and that show ?thesis by blast
qed

lemma subgroup_adjoin_induct [consumes 1, case_names base adjoin]:
  assumes "subgroup H0 G"
  assumes base: "P (G\<lparr>carrier := H0\<rparr>)"
  assumes adjoin: "\<And>H a. subgroup H G \<Longrightarrow> H0 \<subseteq> H \<Longrightarrow> a \<in> carrier G - H \<Longrightarrow> P (G\<lparr>carrier := H\<rparr>) \<Longrightarrow>
                           P (G\<lparr>carrier := adjoin G H a\<rparr>)"
  shows   "P G"
proof -
  define H where "H = carrier G"
  have "finite H" by (auto simp: H_def fin)
  moreover have "subgroup H G" unfolding H_def by standard auto
  moreover {
    interpret subgroup H0 G by fact
    have "H0 \<subseteq> H" by (simp add: H_def subset)
  }
  ultimately have "P (G\<lparr>carrier := H\<rparr>)"
  proof (induction H rule: finite_psubset_induct)
    case (psubset H)
    show ?case
    proof (cases "H = H0")
      case True
      thus ?thesis by (simp add: base)
    next
      case False
      interpret H_sg: subgroup H G by fact
      interpret H: finite_comm_group "G\<lparr>carrier := H\<rparr>"
        by (rule subgroup_imp_finite_comm_group) fact
      have sg: "subgroup H0 (G\<lparr>carrier := H\<rparr>)"
        by (simp add: H_sg.subgroup_axioms \<open>subgroup H0 G\<close> psubset.prems(2) subgroup_incl)
      from H.group_decompose_adjoin[OF sg] and False
        obtain H' a where H': "H0 \<subseteq> H'" "subgroup H' (G\<lparr>carrier := H\<rparr>)" "a \<in> H - H'"
                              "H = adjoin G H' a" by (auto simp: order_def)
      have "subgroup H' G"
        using \<open>subgroup H G\<close> and H'(2) group.incl_subgroup by blast
      from H' and adjoined_in_adjoin[of H' a] and \<open>subgroup H' G\<close> and mem_adjoin[of H' _ a]
        have "a \<in> H" and "a \<notin> H'" and "H' \<subseteq> H" by auto
      hence "H' \<subset> H" by blast
      from psubset.IH [OF \<open>H' \<subset> H\<close> \<open>subgroup H' G\<close> \<open>H0 \<subseteq> H'\<close>] have "P (G\<lparr>carrier := H'\<rparr>)" .
      with H' and \<open>subgroup H' G\<close> have "P (G\<lparr>carrier := adjoin G H' a\<rparr>)"
        by (intro adjoin) auto
      also from H' have "adjoin G H' a = H" by simp
      finally show ?thesis .
    qed
  qed
  thus "P G" by (simp add: H_def)
qed

lemma subgroup_adjoin_induct' [case_names singleton adjoin]:
  assumes singleton: "P (G\<lparr>carrier := {\<one>}\<rparr>)"
  assumes adjoin: "\<And>H a. subgroup H G \<Longrightarrow> a \<in> carrier G - H \<Longrightarrow> P (G\<lparr>carrier := H\<rparr>) \<Longrightarrow>
                           P (G\<lparr>carrier := adjoin G H a\<rparr>)"
  shows   "P G"
proof -
  have "subgroup {\<one>} G" by standard auto
  from this and assms show ?thesis by (rule subgroup_adjoin_induct)
qed

end

end