theory Chapter3
imports "HOL-IMP.BExp"
        "HOL-IMP.ASM"
        (*"Short_Theory_AExp"*)
        (*"Short_Theory_ASM"*)
begin

text \<open>
\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
\<close>

fun optimal :: "aexp \<Rightarrow> bool" where
  "optimal (N i) = True" |
  "optimal (V x) = True" |
  "optimal (Plus (N i) (N j)) = False" |
  "optimal (Plus a\<^sub>1 a\<^sub>2) \<longleftrightarrow> optimal a\<^sub>1 \<and> optimal a\<^sub>2"

text \<open>
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:
\<close>

lemma "optimal (asimp_const a)"
  apply (induction a)
    apply (auto split: aexp.split)
  done

text \<open>
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):
\<close>

fun sumN :: "aexp \<Rightarrow> int" where
  "sumN (N i) = i" |
  "sumN (V x) = 0" |
  "sumN (Plus a\<^sub>1 a\<^sub>2) = sumN a\<^sub>1 + sumN a\<^sub>2"

fun zeroN :: "aexp \<Rightarrow> aexp" where
  "zeroN (N i) = N 0" |
  "zeroN (V x) = V x" |
  "zeroN (Plus a\<^sub>1 a\<^sub>2) = Plus (zeroN a\<^sub>1) (zeroN a\<^sub>2)"

text \<open>
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.
\<close>

definition sepN :: "aexp \<Rightarrow> aexp" where
  "sepN a = Plus (zeroN a) (N (sumN a))"

lemma aval_sepN: "aval (sepN t) s = aval t s"
  apply (induction t)
    apply (auto simp add: sepN_def)
  done

text \<open>
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.
\<close>

definition full_asimp :: "aexp \<Rightarrow> aexp" where
  "full_asimp t = asimp (sepN t)"

lemma aval_full_asimp: "aval (full_asimp t) s = aval t s"
  apply (simp add: full_asimp_def aval_sepN)
  done

text \<open>
\endexercise

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

fun subst :: "vname \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
  "subst _ _ (N i) = N i" |
  "subst x a (V y) = (if x = y then a else V y)" |
  "subst x a (Plus e\<^sub>1 e\<^sub>2) = Plus (subst x a e\<^sub>1) (subst x a e\<^sub>2)"

text \<open>
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:
\<close>

lemma subst_lemma: "aval (subst x a e) s = aval e (s(x := aval a s))"
  apply (induction e)
    apply auto
  done

text \<open>
As a consequence prove that we can substitute equal expressions by equal expressions
and obtain the same result under evaluation:
\<close>
lemma "aval a1 s = aval a2 s
  \<Longrightarrow> aval (subst x a1 e) s = aval (subst x a2 e) s"
  apply (auto simp add: subst_lemma)
  done

text \<open>
\endexercise

\exercise
Take a copy of theory @{text "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.
\<close>

(* See Short_Theory.thy *)

text \<open>
\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}.
 \<close>

datatype aexp2 = N2 int | V2  vname | Plus2 aexp2 aexp2 | PIncr2 vname | Divide2 aexp2 aexp2

fun aval2 :: "aexp2 \<Rightarrow> state \<Rightarrow> (val \<times> state) option" where
  "aval2 (N2 i) s = Some (i, s)" |
  "aval2 (V2 x) s = Some (s x, s)" |
  "aval2 (Plus2 a\<^sub>1 a\<^sub>2) s =
    (case aval2 a\<^sub>2 s of
      Some (v\<^sub>2, s\<^sub>2) \<Rightarrow>
        (case (aval2 a\<^sub>1 s, aval2 a\<^sub>1 s\<^sub>2) of
          (Some (v\<^sub>1, _), Some (_, s\<^sub>1)) \<Rightarrow> Some (v\<^sub>1 + v\<^sub>2, s\<^sub>1) |
          (_, _) \<Rightarrow> None) |
      _ \<Rightarrow> None)" |
  "aval2 (PIncr2 x) s = Some (s x, s (x := s x + 1))" |
  "aval2 (Divide2 a\<^sub>1 a\<^sub>2) s =
    (case aval2 a\<^sub>2 s of
      Some (v\<^sub>2, s\<^sub>2) \<Rightarrow>
        (if v\<^sub>2 = 0 then None else
          case (aval2 a\<^sub>1 s, aval2 a\<^sub>1 s\<^sub>2) of
            (Some (v\<^sub>1, _), Some (_, s\<^sub>1)) \<Rightarrow> Some (v\<^sub>1 div v\<^sub>2, s\<^sub>1) |
            (_, _) \<Rightarrow> None) |
      _ \<Rightarrow> None)"

text \<open>
\endexercise

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

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

text \<open> 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 @{text lval} @{text"::"} @{typ "lexp \<Rightarrow> state \<Rightarrow> int"}
that evaluates @{typ lexp} expressions. Remember @{term"s(x := i)"}.

Define a conversion @{text 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 @{text inline} is correct w.r.t.\ evaluation.
 \<close>

fun lval :: "lexp \<Rightarrow> state \<Rightarrow> int" where
  "lval (Nl i) _ = i" |
  "lval (Vl x) s = s x" |
  "lval (Plusl e\<^sub>1 e\<^sub>2) s = lval e\<^sub>1 s + lval e\<^sub>2 s" |
  "lval (LET x e\<^sub>1 e\<^sub>2) s = lval e\<^sub>2 (s (x := lval e\<^sub>1 s))"

fun inline :: "lexp \<Rightarrow> aexp" where
  "inline (Nl i) = N i" |
  "inline (Vl x) = V x" |
  "inline (Plusl e\<^sub>1 e\<^sub>2) = Plus (inline e\<^sub>1) (inline e\<^sub>2)" |
  "inline (LET x e\<^sub>1 e\<^sub>2) = subst x (inline e\<^sub>1) (inline e\<^sub>2)"

lemma "aval (inline e) s = lval e s"
  apply (induction e arbitrary: s)
     apply (auto simp add: subst_lemma)
  done

text \<open>
\endexercise

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

definition Le :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
  "Le a\<^sub>1 a\<^sub>2 = Not (Less a\<^sub>2 a\<^sub>1)"

definition Eq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
  "Eq a\<^sub>1 a\<^sub>2 = And (Le a\<^sub>1 a\<^sub>2) (Le a\<^sub>2 a\<^sub>1)"

text \<open>
and prove that they do what they are supposed to:
 \<close>

lemma bval_Le: "bval (Le a1 a2) s = (aval a1 s \<le> aval a2 s)"
  apply (induction a1 arbitrary: a2)
    apply (auto simp add: Le_def)
  done

lemma bval_Eq: "bval (Eq a1 a2) s = (aval a1 s = aval a2 s)"
  apply (induction a1 arbitrary: a2)
    apply (auto simp add: Eq_def Le_def)
  done

text \<open>
\endexercise

\exercise
Consider an alternative type of boolean expressions featuring a conditional:  \<close>

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

text  \<open>  First define an evaluation function analogously to @{const bval}:  \<close>

fun ifval :: "ifexp \<Rightarrow> state \<Rightarrow> bool" where
  "ifval (Bc2 b) _ = b" |
  "ifval (If e\<^sub>1 e\<^sub>2 e\<^sub>3) s = (if ifval e\<^sub>1 s then ifval e\<^sub>2 s else ifval e\<^sub>3 s)" |
  "ifval (Less2 a\<^sub>1 a\<^sub>2) s \<longleftrightarrow> aval a\<^sub>1 s < aval a\<^sub>2 s"
(* your definition/proof here *)

text \<open> Then define two translation functions  \<close>

fun b2ifexp :: "bexp \<Rightarrow> ifexp" where
  "b2ifexp (Bc v) = Bc2 v" |
  "b2ifexp (Not b) = If (b2ifexp b) (Bc2 False) (Bc2 True)" |
  "b2ifexp (And b\<^sub>1 b\<^sub>2) = If (b2ifexp b\<^sub>1) (b2ifexp b\<^sub>2) (Bc2 False)" |
  "b2ifexp (Less a\<^sub>1 a\<^sub>2) = Less2 a\<^sub>1 a\<^sub>2"

fun if2bexp :: "ifexp \<Rightarrow> bexp" where
  "if2bexp (Bc2 v) = Bc v" |
  "if2bexp (If e\<^sub>1 e\<^sub>2 e\<^sub>3) =
  Not (And (Not (And (if2bexp e\<^sub>1) (if2bexp e\<^sub>2))) (Not (And (Not (if2bexp e\<^sub>1)) (if2bexp e\<^sub>3))))" |
  "if2bexp (Less2 a\<^sub>1 a\<^sub>2) = Less a\<^sub>1 a\<^sub>2"

text \<open> and prove their correctness:  \<close>

lemma "bval (if2bexp exp) s = ifval exp s"
  apply (induction exp)
    apply auto
  done

lemma "ifval (b2ifexp exp) s = bval exp s"
  apply (induction exp)
     apply auto
  done

text \<open>
\endexercise

\exercise
We define a new type of purely boolean expressions without any arithmetic
 \<close>

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

text \<open>
where variables range over values of type @{typ bool},
as can be seen from the evaluation function:
 \<close>

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  \<open> 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:  \<close>

fun is_nnf :: "pbexp \<Rightarrow> bool" where
  "is_nnf (VAR _) = True" |
  "is_nnf (NOT (VAR _)) = True" |
  "is_nnf (NOT _) = False" |
  "is_nnf (AND b1 b2) \<longleftrightarrow> is_nnf b1 \<and> is_nnf b2" |
  "is_nnf (OR b1 b2) \<longleftrightarrow> is_nnf b1 \<and> is_nnf b2"

text \<open>
Now define a function that converts a @{text bexp} into NNF by pushing
@{const NOT} inwards as much as possible:
 \<close>

fun nnf :: "pbexp \<Rightarrow> pbexp" where
  "nnf (VAR x) = VAR x" |
  "nnf (NOT (VAR x)) = NOT (VAR x)" |
  "nnf (NOT (NOT b)) = nnf b" |
  "nnf (NOT (AND b1 b2)) = OR (nnf (NOT b1)) (nnf (NOT b2))" |
  "nnf (NOT (OR b1 b2)) = AND (nnf (NOT b1)) (nnf (NOT b2))" |
  "nnf (AND b1 b2) = AND (nnf b1) (nnf b2)" |
  "nnf (OR b1 b2) = OR (nnf b1) (nnf b2)"

text \<open>
Prove that @{const nnf} does what it is supposed to do:
 \<close>

lemma pbval_nnf: "pbval (nnf b) s = pbval b s"
  apply (induction b rule: nnf.induct)
        apply auto
  done

lemma is_nnf_nnf: "is_nnf (nnf b)"
  apply (induction b rule: nnf.induct)
        apply auto
  done

text \<open>
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:
 \<close>

fun is_dnf :: "pbexp \<Rightarrow> bool" where
  "is_dnf (VAR _) = True" |
  "is_dnf (NOT (VAR _)) = True" |
  "is_dnf (NOT _) = False" |
  "is_dnf (OR e\<^sub>1 e\<^sub>2) \<longleftrightarrow> is_dnf e\<^sub>1 \<and> is_dnf e\<^sub>2" |
  "is_dnf (AND (OR _ _) _) = False" |
  "is_dnf (AND _ (OR _ _)) = False" |
  "is_dnf (AND e\<^sub>1 e\<^sub>2) \<longleftrightarrow> is_dnf e\<^sub>1 \<and> is_dnf e\<^sub>2"

text  \<open>
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
 \<close>

fun dist_AND :: "pbexp \<Rightarrow> pbexp \<Rightarrow> pbexp" where
  "dist_AND (OR e\<^sub>1 e\<^sub>2) e\<^sub>3 = OR (dist_AND e\<^sub>1 e\<^sub>3) (dist_AND e\<^sub>2 e\<^sub>3)" |
  "dist_AND e\<^sub>1 (OR e\<^sub>2 e\<^sub>3) = OR (dist_AND e\<^sub>1 e\<^sub>2) (dist_AND e\<^sub>1 e\<^sub>3)" |
  "dist_AND e\<^sub>1 e\<^sub>2 = AND e\<^sub>1 e\<^sub>2"

text  \<open> and prove that it behaves as follows:  \<close>

lemma pbval_dist: "pbval (dist_AND b1 b2) s = pbval (AND b1 b2) s"
  apply (induction b1 b2 rule: dist_AND.induct)
              apply auto
  done

lemma is_dnf_dist: "is_dnf b1 \<Longrightarrow> is_dnf b2 \<Longrightarrow> is_dnf (dist_AND b1 b2)"
  apply (induction b1 b2 rule: dist_AND.induct)
              apply auto
  done

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

fun dnf_of_nnf :: "pbexp \<Rightarrow> pbexp" where
  "dnf_of_nnf (VAR x) = VAR x" |
  "dnf_of_nnf (NOT v) = NOT v" |
  "dnf_of_nnf (OR e\<^sub>1 e\<^sub>2) = OR (dnf_of_nnf e\<^sub>1) (dnf_of_nnf e\<^sub>2)" |
  "dnf_of_nnf (AND e\<^sub>1 e\<^sub>2) = dist_AND (dnf_of_nnf e\<^sub>1) (dnf_of_nnf e\<^sub>2)"

text  \<open> Prove the correctness of your function:  \<close>

lemma "pbval (dnf_of_nnf b) s = pbval b s"
  apply (induction b)
     apply (auto simp add: pbval_dist)
  done

lemma nnf_dnf_NOT: "is_nnf (NOT b) \<Longrightarrow> is_dnf (NOT b)"
  apply (cases b)
     apply auto
  done

lemma "is_nnf b \<Longrightarrow> is_dnf (dnf_of_nnf b)"
  apply (induction b)
     apply (auto simp add: is_dnf_dist nnf_dnf_NOT)
  done

text \<open>
\endexercise

\exercise\label{exe:stack-underflow}
A \concept{stack underflow} occurs when executing an @{text ADD}
instruction on a stack of size less than 2. In our semantics
a term @{term "exec1 ADD s stk"} where @{prop "length stk < 2"}
is simply some unspecified value, not an error or exception --- HOL does not have those concepts.
Modify theory @{text "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.
 \<close>

(* See Short_Theory_ASM.thy *)

text \<open>
\endexercise

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

text  \<open>
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:  \<close>

type_synonym rstate = "reg \<Rightarrow> val"

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> rstate \<Rightarrow> rstate" where
  "exec1 (LDI i r) _ rs = rs (r := i)" |
  "exec1 (LD x r) s rs = rs (r := s x)" |
  "exec1 (ADD r\<^sub>1 r\<^sub>2) s rs = rs (r\<^sub>1 := rs r\<^sub>1 + rs r\<^sub>2)"

fun exec :: "instr list \<Rightarrow> state \<Rightarrow> rstate \<Rightarrow> rstate" where
  "exec [] _ rs = rs" |
  "exec (i # is) s rs = exec is s (exec1 i s rs)"

text \<open>
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:
 \<close>

lemma exec_app: "exec (is\<^sub>1 @ is\<^sub>2) s rs r = exec is\<^sub>2 s (exec is\<^sub>1 s rs) r"
  apply (induction is\<^sub>1 arbitrary: rs r)
   apply auto
  done

fun comp :: "aexp \<Rightarrow> reg \<Rightarrow> instr list" where
  "comp (N i) r = [LDI i r]" |
  "comp (V x) r = [LD x r]" |
  "comp (Plus a\<^sub>1 a\<^sub>2) r = comp a\<^sub>1 r @ comp a\<^sub>2 (Suc r) @ [ADD r (Suc r)]"

lemma exec_comp_inacc: "r < r\<^sub>1 \<Longrightarrow> exec (comp a r\<^sub>1) s rs r = rs r"
  apply (induction a arbitrary: r\<^sub>1 rs)
    apply (auto simp add: exec_app)
  done

theorem "exec (comp a r) s rs r = aval a s"
  apply (induction a arbitrary: r rs)
    apply (auto simp add: exec_app exec_comp_inacc)
  done

text \<open>
\endexercise

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

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

text \<open>
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
 \<close>

fun exec01 :: "instr0 \<Rightarrow> state \<Rightarrow> rstate \<Rightarrow> rstate" where
  "exec01 (LDI0 i) _ rs = rs (0 := i)" |
  "exec01 (LD0 x) s rs = rs (0 := s x)" |
  "exec01 (MV0 r) _ rs = rs (r := rs 0)" |
  "exec01 (ADD0 r) _ rs = rs (0 := rs 0 + rs r)"

fun exec0 :: "instr0 list \<Rightarrow> state \<Rightarrow> rstate \<Rightarrow> rstate" where
  "exec0 [] _ rs = rs" |
  "exec0 (i # is) s rs = exec0 is s (exec01 i s rs)"

lemma exec0_app: "exec0 (is\<^sub>1 @ is\<^sub>2) s rs r = exec0 is\<^sub>2 s (exec0 is\<^sub>1 s rs) r"
  apply (induction is\<^sub>1 arbitrary: rs r)
   apply auto
  done

text \<open>
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:
 \<close>

fun comp0 :: "aexp \<Rightarrow> reg \<Rightarrow> instr0 list" where
  "comp0 (N i) _ = [LDI0 i]" |
  "comp0 (V x) _ = [LD0 x]" |
  "comp0 (Plus a\<^sub>1 a\<^sub>2) r = comp0 a\<^sub>1 (Suc r) @ MV0 (Suc r) # comp0 a\<^sub>2 (Suc (Suc r)) @ [ADD0 (Suc r)]"

lemma exec0_comp0_inacc: "0 < r \<Longrightarrow> r < r\<^sub>1 \<Longrightarrow> exec0 (comp0 a r\<^sub>1) s rs r = rs r"
  apply (induction a arbitrary: r r\<^sub>1 rs)
    apply (auto simp add: exec0_app)
  done

lemma exec0_comp0: "exec0 (comp0 a r) s rs 0 = aval a s"
  apply (induction a arbitrary: r rs)
    apply (auto simp add: exec0_app exec0_comp0_inacc)
  done

text \<open>
\endexercise
 \<close>

end


theory Sets
  imports Main
begin

text \<open> Finite sets can obviously be implemented by lists.  In the
following, you will be asked to implement the set operations union,
intersection and difference and to show that these implementations are
correct.  Thus, for a function \<close>

primrec  list_union :: "['a list, 'a list] \<Rightarrow> 'a list"
  where
"list_union [] ys = ys" |
"list_union (x#xs) ys = (if (x\<in>set ys) then list_union xs ys else x#list_union xs ys)"

text \<open> to be defined by you it has to be shown that \<close>

lemma union_is_union:"set (list_union xs ys) = set xs \<union> set ys"
  apply (induction xs) by auto

text \<open> In addition, the functions should be space efficient in the
sense that one obtains lists without duplicates (@{text "distinct"})
whenever the parameters of the functions are duplicate-free.  Thus, for
example, \<close>

lemma union_distinct[rule_format]:
  "distinct xs \<longrightarrow> distinct ys \<longrightarrow> (distinct (list_union xs ys))"
  apply (induction xs) by (auto simp add: union_is_union)

text \<open> \emph{Hint:} @{text "distinct"} is defined in @{text List.thy}. \<close>

subsubsection \<open> Quantification over Sets \<close>

text \<open> Define a (non-trivial) set @{text S} such that the following
proposition holds: \<close>

lemma "((\<forall> x \<in> A. P x) \<and> (\<forall> x \<in> B. P x)) \<longrightarrow> (\<forall> x \<in> (A \<union> B). P x)"
  by blast

text \<open> Define a (non-trivial) predicate @{text P} such that \<close>

lemma "\<forall> x \<in> A. Q (f x) \<Longrightarrow>  \<forall> y \<in> f ` A. Q y"
  by blast

(*<*) end (*>*)


section \<open>Equipollence and Other Relations Connected with Cardinality\<close>

theory "Equipollence"
  imports FuncSet
begin

subsection\<open>Eqpoll\<close>

definition eqpoll :: "'a set \<Rightarrow> 'b set \<Rightarrow> bool" (infixl "\<approx>" 50)
  where "eqpoll A B \<equiv> \<exists>f. bij_betw f A B"

definition lepoll :: "'a set \<Rightarrow> 'b set \<Rightarrow> bool" (infixl "\<lesssim>" 50)
  where "lepoll A B \<equiv> \<exists>f. inj_on f A \<and> f ` A \<subseteq> B"

definition lesspoll :: "'a set \<Rightarrow> 'b set \<Rightarrow> bool" (infixl \<open>\<prec>\<close> 50)
  where "A \<prec> B == A \<lesssim> B \<and> ~(A \<approx> B)"

lemma lepoll_empty_iff_empty [simp]: "A \<lesssim> {} \<longleftrightarrow> A = {}"
  by (auto simp: lepoll_def)

lemma eqpoll_iff_card_of_ordIso: "A \<approx> B \<longleftrightarrow> ordIso2 (card_of A) (card_of B)"
  by (simp add: card_of_ordIso eqpoll_def)

lemma eqpoll_refl [iff]: "A \<approx> A"
  by (simp add: card_of_refl eqpoll_iff_card_of_ordIso)

lemma eqpoll_finite_iff: "A \<approx> B \<Longrightarrow> finite A \<longleftrightarrow> finite B"
  by (meson bij_betw_finite eqpoll_def)

lemma eqpoll_iff_card:
  assumes "finite A" "finite B"
  shows  "A \<approx> B \<longleftrightarrow> card A = card B"
  using assms by (auto simp: bij_betw_iff_card eqpoll_def)

lemma lepoll_antisym:
  assumes "A \<lesssim> B" "B \<lesssim> A" shows "A \<approx> B"
  using assms unfolding eqpoll_def lepoll_def by (metis Schroeder_Bernstein)

lemma lepoll_trans [trans]: "\<lbrakk>A \<lesssim> B; B \<lesssim> C\<rbrakk> \<Longrightarrow> A \<lesssim> C"
  apply (clarsimp simp: lepoll_def)
  apply (rename_tac f g)
  apply (rule_tac x="g \<circ> f" in exI)
  apply (auto simp: image_subset_iff inj_on_def)
  done

lemma lepoll_trans1 [trans]: "\<lbrakk>A \<approx> B; B \<lesssim> C\<rbrakk> \<Longrightarrow> A \<lesssim> C"
  by (meson card_of_ordLeq eqpoll_iff_card_of_ordIso lepoll_def lepoll_trans ordIso_iff_ordLeq)

lemma lepoll_trans2 [trans]: "\<lbrakk>A \<lesssim> B; B \<approx> C\<rbrakk> \<Longrightarrow> A \<lesssim> C"
  apply (clarsimp simp: eqpoll_def lepoll_def bij_betw_def)
  apply (rename_tac f g)
  apply (rule_tac x="g \<circ> f" in exI)
  apply (auto simp: image_subset_iff inj_on_def)
  done

lemma eqpoll_sym: "A \<approx> B \<Longrightarrow> B \<approx> A"
  unfolding eqpoll_def
  using bij_betw_the_inv_into by auto

lemma eqpoll_trans [trans]: "\<lbrakk>A \<approx> B; B \<approx> C\<rbrakk> \<Longrightarrow> A \<approx> C"
  unfolding eqpoll_def using bij_betw_trans by blast

lemma eqpoll_imp_lepoll: "A \<approx> B \<Longrightarrow> A \<lesssim> B"
  unfolding eqpoll_def lepoll_def by (metis bij_betw_def order_refl)

lemma subset_imp_lepoll: "A \<subseteq> B \<Longrightarrow> A \<lesssim> B"
  by (force simp: lepoll_def)

lemma lepoll_refl [iff]: "A \<lesssim> A"
  by (simp add: subset_imp_lepoll)

lemma lepoll_iff: "A \<lesssim> B \<longleftrightarrow> (\<exists>g. A \<subseteq> g ` B)"
  unfolding lepoll_def
proof safe
  fix g assume "A \<subseteq> g ` B"
  then show "\<exists>f. inj_on f A \<and> f ` A \<subseteq> B"
    by (rule_tac x="inv_into B g" in exI) (auto simp: inv_into_into inj_on_inv_into)
qed (metis image_mono the_inv_into_onto)

lemma empty_lepoll [iff]: "{} \<lesssim> A"
  by (simp add: lepoll_iff)

lemma subset_image_lepoll: "B \<subseteq> f ` A \<Longrightarrow> B \<lesssim> A"
  by (auto simp: lepoll_iff)

lemma image_lepoll: "f ` A \<lesssim> A"
  by (auto simp: lepoll_iff)

lemma infinite_le_lepoll: "infinite A \<longleftrightarrow> (UNIV::nat set) \<lesssim> A"
apply (auto simp: lepoll_def)
  apply (simp add: infinite_countable_subset)
  using infinite_iff_countable_subset by blast

lemma lepoll_Pow_self: "A \<lesssim> Pow A"
  unfolding lepoll_def inj_def
  proof (intro exI conjI)
    show "inj_on (\<lambda>x. {x}) A"
      by (auto simp: inj_on_def)
qed auto

lemma eqpoll_iff_bijections:
   "A \<approx> B \<longleftrightarrow> (\<exists>f g. (\<forall>x \<in> A. f x \<in> B \<and> g(f x) = x) \<and> (\<forall>y \<in> B. g y \<in> A \<and> f(g y) = y))"
    by (auto simp: eqpoll_def bij_betw_iff_bijections)

lemma lepoll_restricted_funspace:
   "{f. f ` A \<subseteq> B \<and> {x. f x \<noteq> k x} \<subseteq> A \<and> finite {x. f x \<noteq> k x}} \<lesssim> Fpow (A \<times> B)"
proof -
  have *: "\<exists>U \<in> Fpow (A \<times> B). f = (\<lambda>x. if \<exists>y. (x, y) \<in> U then SOME y. (x,y) \<in> U else k x)"
    if "f ` A \<subseteq> B" "{x. f x \<noteq> k x} \<subseteq> A" "finite {x. f x \<noteq> k x}" for f
    apply (rule_tac x="(\<lambda>x. (x, f x)) ` {x. f x \<noteq> k x}" in bexI)
    using that by (auto simp: image_def Fpow_def)
  show ?thesis
    apply (rule subset_image_lepoll [where f = "\<lambda>U x. if \<exists>y. (x,y) \<in> U then @y. (x,y) \<in> U else k x"])
    using * by (auto simp: image_def)
qed

lemma singleton_lepoll: "{x} \<lesssim> insert y A"
  by (force simp: lepoll_def)

lemma singleton_eqpoll: "{x} \<approx> {y}"
  by (blast intro: lepoll_antisym singleton_lepoll)

lemma subset_singleton_iff_lepoll: "(\<exists>x. S \<subseteq> {x}) \<longleftrightarrow> S \<lesssim> {()}"
proof safe
  show "S \<lesssim> {()}" if "S \<subseteq> {x}" for x
    using subset_imp_lepoll [OF that] by (simp add: singleton_eqpoll lepoll_trans2)
  show "\<exists>x. S \<subseteq> {x}" if "S \<lesssim> {()}"
  by (metis (no_types, opaque_lifting) image_empty image_insert lepoll_iff that)
qed

lemma infinite_insert_lepoll:
  assumes "infinite A" shows "insert a A \<lesssim> A"
proof -
  obtain f :: "nat \<Rightarrow> 'a" where "inj f" and f: "range f \<subseteq> A"
    using assms infinite_countable_subset by blast
  let ?g = "(\<lambda>z. if z=a then f 0 else if z \<in> range f then f (Suc (inv f z)) else z)"
  show ?thesis
    unfolding lepoll_def
  proof (intro exI conjI)
    show "inj_on ?g (insert a A)"
      using inj_on_eq_iff [OF \<open>inj f\<close>]
      by (auto simp: inj_on_def)
    show "?g ` insert a A \<subseteq> A"
      using f by auto
  qed
qed

lemma infinite_insert_eqpoll: "infinite A \<Longrightarrow> insert a A \<approx> A"
  by (simp add: lepoll_antisym infinite_insert_lepoll subset_imp_lepoll subset_insertI)

lemma finite_lepoll_infinite:
  assumes "infinite A" "finite B" shows "B \<lesssim> A"
proof -
  have "B \<lesssim> (UNIV::nat set)"
    unfolding lepoll_def
    using finite_imp_inj_to_nat_seg [OF \<open>finite B\<close>] by blast
  then show ?thesis
    using \<open>infinite A\<close> infinite_le_lepoll lepoll_trans by auto
qed

subsection\<open>The strict relation\<close>

lemma lesspoll_not_refl [iff]: "~ (i \<prec> i)"
  by (simp add: lepoll_antisym lesspoll_def)

lemma lesspoll_imp_lepoll: "A \<prec> B ==> A \<lesssim> B"
by (unfold lesspoll_def, blast)

lemma lepoll_iff_leqpoll: "A \<lesssim> B \<longleftrightarrow> A \<prec> B | A \<approx> B"
  using eqpoll_imp_lepoll lesspoll_def by blast

lemma lesspoll_trans [trans]: "\<lbrakk>X \<prec> Y; Y \<prec> Z\<rbrakk> \<Longrightarrow> X \<prec> Z"
  by (meson eqpoll_sym lepoll_antisym lepoll_trans lepoll_trans1 lesspoll_def)

lemma lesspoll_trans1 [trans]: "\<lbrakk>X \<lesssim> Y; Y \<prec> Z\<rbrakk> \<Longrightarrow> X \<prec> Z"
  by (meson eqpoll_sym lepoll_antisym lepoll_trans lepoll_trans1 lesspoll_def)

lemma lesspoll_trans2 [trans]: "\<lbrakk>X \<prec> Y; Y \<lesssim> Z\<rbrakk> \<Longrightarrow> X \<prec> Z"
  by (meson eqpoll_imp_lepoll eqpoll_sym lepoll_antisym lepoll_trans lesspoll_def)

lemma eq_lesspoll_trans [trans]: "\<lbrakk>X \<approx> Y; Y \<prec> Z\<rbrakk> \<Longrightarrow> X \<prec> Z"
  using eqpoll_imp_lepoll lesspoll_trans1 by blast

lemma lesspoll_eq_trans [trans]: "\<lbrakk>X \<prec> Y; Y \<approx> Z\<rbrakk> \<Longrightarrow> X \<prec> Z"
  using eqpoll_imp_lepoll lesspoll_trans2 by blast

lemma lesspoll_Pow_self: "A \<prec> Pow A"
  unfolding lesspoll_def bij_betw_def eqpoll_def
  by (meson lepoll_Pow_self Cantors_theorem)

lemma finite_lesspoll_infinite:
  assumes "infinite A" "finite B" shows "B \<prec> A"
  by (meson assms eqpoll_finite_iff finite_lepoll_infinite lesspoll_def)

subsection\<open>Mapping by an injection\<close>

lemma inj_on_image_eqpoll_self: "inj_on f A \<Longrightarrow> f ` A \<approx> A"
  by (meson bij_betw_def eqpoll_def eqpoll_sym)

lemma inj_on_image_lepoll_1 [simp]:
  assumes "inj_on f A" shows "f ` A \<lesssim> B \<longleftrightarrow> A \<lesssim> B"
  by (meson assms image_lepoll lepoll_def lepoll_trans order_refl)

lemma inj_on_image_lepoll_2 [simp]:
  assumes "inj_on f B" shows "A \<lesssim> f ` B \<longleftrightarrow> A \<lesssim> B"
  by (meson assms eq_iff image_lepoll lepoll_def lepoll_trans)

lemma inj_on_image_lesspoll_1 [simp]:
  assumes "inj_on f A" shows "f ` A \<prec> B \<longleftrightarrow> A \<prec> B"
  by (meson assms image_lepoll le_less lepoll_def lesspoll_trans1)

lemma inj_on_image_lesspoll_2 [simp]:
  assumes "inj_on f B" shows "A \<prec> f ` B \<longleftrightarrow> A \<prec> B"
  by (meson assms eqpoll_sym inj_on_image_eqpoll_self lesspoll_eq_trans)

lemma inj_on_image_eqpoll_1 [simp]:
  assumes "inj_on f A" shows "f ` A \<approx> B \<longleftrightarrow> A \<approx> B"
  by (metis assms eqpoll_trans inj_on_image_eqpoll_self eqpoll_sym)

lemma inj_on_image_eqpoll_2 [simp]:
  assumes "inj_on f B" shows "A \<approx> f ` B \<longleftrightarrow> A \<approx> B"
  by (metis assms inj_on_image_eqpoll_1 eqpoll_sym)

subsection \<open>Inserting elements into sets\<close>

lemma insert_lepoll_insertD:
  assumes "insert u A \<lesssim> insert v B" "u \<notin> A" "v \<notin> B" shows "A \<lesssim> B"
proof -
  obtain f where inj: "inj_on f (insert u A)" and fim: "f ` (insert u A) \<subseteq> insert v B"
    by (meson assms lepoll_def)
  show ?thesis
    unfolding lepoll_def
  proof (intro exI conjI)
    let ?g = "\<lambda>x\<in>A. if f x = v then f u else f x"
    show "inj_on ?g A"
      using inj \<open>u \<notin> A\<close> by (auto simp: inj_on_def)
    show "?g ` A \<subseteq> B"
      using fim \<open>u \<notin> A\<close> image_subset_iff inj inj_on_image_mem_iff by fastforce
  qed
qed

lemma insert_eqpoll_insertD: "\<lbrakk>insert u A \<approx> insert v B; u \<notin> A; v \<notin> B\<rbrakk> \<Longrightarrow> A \<approx> B"
  by (meson insert_lepoll_insertD eqpoll_imp_lepoll eqpoll_sym lepoll_antisym)

lemma insert_lepoll_cong:
  assumes "A \<lesssim> B" "b \<notin> B" shows "insert a A \<lesssim> insert b B"
proof -
  obtain f where f: "inj_on f A" "f ` A \<subseteq> B"
    by (meson assms lepoll_def)
  let ?f = "\<lambda>u \<in> insert a A. if u=a then b else f u"
  show ?thesis
    unfolding lepoll_def
  proof (intro exI conjI)
    show "inj_on ?f (insert a A)"
      using f \<open>b \<notin> B\<close> by (auto simp: inj_on_def)
    show "?f ` insert a A \<subseteq> insert b B"
      using f \<open>b \<notin> B\<close> by auto
  qed
qed

lemma insert_eqpoll_cong:
     "\<lbrakk>A \<approx> B; a \<notin> A; b \<notin> B\<rbrakk> \<Longrightarrow> insert a A \<approx> insert b B"
  apply (rule lepoll_antisym)
  apply (simp add: eqpoll_imp_lepoll insert_lepoll_cong)+
  by (meson eqpoll_imp_lepoll eqpoll_sym insert_lepoll_cong)

lemma insert_eqpoll_insert_iff:
     "\<lbrakk>a \<notin> A; b \<notin> B\<rbrakk> \<Longrightarrow> insert a A \<approx> insert b B  \<longleftrightarrow>  A \<approx> B"
  by (meson insert_eqpoll_insertD insert_eqpoll_cong)

lemma insert_lepoll_insert_iff:
     " \<lbrakk>a \<notin> A; b \<notin> B\<rbrakk> \<Longrightarrow> (insert a A \<lesssim> insert b B) \<longleftrightarrow> (A \<lesssim> B)"
  by (meson insert_lepoll_insertD insert_lepoll_cong)

lemma less_imp_insert_lepoll:
  assumes "A \<prec> B" shows "insert a A \<lesssim> B"
proof -
  obtain f where "inj_on f A" "f ` A \<subset> B"
    using assms by (metis bij_betw_def eqpoll_def lepoll_def lesspoll_def psubset_eq)
  then obtain b where b: "b \<in> B" "b \<notin> f ` A"
    by auto
  show ?thesis
    unfolding lepoll_def
  proof (intro exI conjI)
    show "inj_on (f(a:=b)) (insert a A)"
      using b \<open>inj_on f A\<close> by (auto simp: inj_on_def)
    show "(f(a:=b)) ` insert a A \<subseteq> B"
      using \<open>f ` A \<subset> B\<close>  by (auto simp: b)
  qed
qed

lemma finite_insert_lepoll: "finite A \<Longrightarrow> (insert a A \<lesssim> A) \<longleftrightarrow> (a \<in> A)"
proof (induction A rule: finite_induct)
  case (insert x A)
  then show ?case
    apply (auto simp: insert_absorb)
    by (metis insert_commute insert_iff insert_lepoll_insertD)
qed auto

subsection\<open>Binary sums and unions\<close>

lemma Un_lepoll_mono:
  assumes "A \<lesssim> C" "B \<lesssim> D" "disjnt C D" shows "A \<union> B \<lesssim> C \<union> D"
proof -
  obtain f g where inj: "inj_on f A" "inj_on g B" and fg: "f ` A \<subseteq> C" "g ` B \<subseteq> D"
    by (meson assms lepoll_def)
  have "inj_on (\<lambda>x. if x \<in> A then f x else g x) (A \<union> B)"
    using inj \<open>disjnt C D\<close> fg unfolding disjnt_iff
    by (fastforce intro: inj_onI dest: inj_on_contraD split: if_split_asm)
  with fg show ?thesis
    unfolding lepoll_def
    by (rule_tac x="\<lambda>x. if x \<in> A then f x else g x" in exI) auto
qed

lemma Un_eqpoll_cong: "\<lbrakk>A \<approx> C; B \<approx> D; disjnt A B; disjnt C D\<rbrakk> \<Longrightarrow> A \<union> B \<approx> C \<union> D"
  by (meson Un_lepoll_mono eqpoll_imp_lepoll eqpoll_sym lepoll_antisym)

lemma sum_lepoll_mono:
  assumes "A \<lesssim> C" "B \<lesssim> D" shows "A <+> B \<lesssim> C <+> D"
proof -
  obtain f g where "inj_on f A" "f ` A \<subseteq> C" "inj_on g B" "g ` B \<subseteq> D"
    by (meson assms lepoll_def)
  then show ?thesis
    unfolding lepoll_def
    by (rule_tac x="case_sum (Inl \<circ> f) (Inr \<circ> g)" in exI) (force simp: inj_on_def)
qed

lemma sum_eqpoll_cong: "\<lbrakk>A \<approx> C; B \<approx> D\<rbrakk> \<Longrightarrow> A <+> B \<approx> C <+> D"
  by (meson eqpoll_imp_lepoll eqpoll_sym lepoll_antisym sum_lepoll_mono)

subsection\<open>Binary Cartesian products\<close>

lemma times_square_lepoll: "A \<lesssim> A \<times> A"
  unfolding lepoll_def inj_def
proof (intro exI conjI)
  show "inj_on (\<lambda>x. (x,x)) A"
    by (auto simp: inj_on_def)
qed auto

lemma times_commute_eqpoll: "A \<times> B \<approx> B \<times> A"
  unfolding eqpoll_def
  by (force intro: bij_betw_byWitness [where f = "\<lambda>(x,y). (y,x)" and f' = "\<lambda>(x,y). (y,x)"])

lemma times_assoc_eqpoll: "(A \<times> B) \<times> C \<approx> A \<times> (B \<times> C)"
  unfolding eqpoll_def
  by (force intro: bij_betw_byWitness [where f = "\<lambda>((x,y),z). (x,(y,z))" and f' = "\<lambda>(x,(y,z)). ((x,y),z)"])

lemma times_singleton_eqpoll: "{a} \<times> A \<approx> A"
proof -
  have "{a} \<times> A = (\<lambda>x. (a,x)) ` A"
    by auto
  also have "\<dots>  \<approx> A"
    proof (rule inj_on_image_eqpoll_self)
      show "inj_on (Pair a) A"
        by (auto simp: inj_on_def)
    qed
    finally show ?thesis .
qed

lemma times_lepoll_mono:
  assumes "A \<lesssim> C" "B \<lesssim> D" shows "A \<times> B \<lesssim> C \<times> D"
proof -
  obtain f g where "inj_on f A" "f ` A \<subseteq> C" "inj_on g B" "g ` B \<subseteq> D"
    by (meson assms lepoll_def)
  then show ?thesis
    unfolding lepoll_def
    by (rule_tac x="\<lambda>(x,y). (f x, g y)" in exI) (auto simp: inj_on_def)
qed

lemma times_eqpoll_cong: "\<lbrakk>A \<approx> C; B \<approx> D\<rbrakk> \<Longrightarrow> A \<times> B \<approx> C \<times> D"
  by (metis eqpoll_imp_lepoll eqpoll_sym lepoll_antisym times_lepoll_mono)

lemma
  assumes "B \<noteq> {}" shows lepoll_times1: "A \<lesssim> A \<times> B" and lepoll_times2:  "A \<lesssim> B \<times> A"
  using assms lepoll_iff by fastforce+

lemma times_0_eqpoll: "{} \<times> A \<approx> {}"
  by (simp add: eqpoll_iff_bijections)

lemma Sigma_inj_lepoll_mono:
  assumes h: "inj_on h A" "h ` A \<subseteq> C" and "\<And>x. x \<in> A \<Longrightarrow> B x \<lesssim> D (h x)"
  shows "Sigma A B \<lesssim> Sigma C D"
proof -
  have "\<And>x. x \<in> A \<Longrightarrow> \<exists>f. inj_on f (B x) \<and> f ` (B x) \<subseteq> D (h x)"
    by (meson assms lepoll_def)
  then obtain f where  "\<And>x. x \<in> A \<Longrightarrow> inj_on (f x) (B x) \<and> f x ` B x \<subseteq> D (h x)"
    by metis
  with h show ?thesis
    unfolding lepoll_def inj_on_def
    by (rule_tac x="\<lambda>(x,y). (h x, f x y)" in exI) force
qed

lemma Sigma_lepoll_mono:
  assumes "A \<subseteq> C" "\<And>x. x \<in> A \<Longrightarrow> B x \<lesssim> D x" shows "Sigma A B \<lesssim> Sigma C D"
  using Sigma_inj_lepoll_mono [of id] assms by auto

lemma sum_times_distrib_eqpoll: "(A <+> B) \<times> C \<approx> (A \<times> C) <+> (B \<times> C)"
  unfolding eqpoll_def
proof
  show "bij_betw (\<lambda>(x,z). case_sum(\<lambda>y. Inl(y,z)) (\<lambda>y. Inr(y,z)) x) ((A <+> B) \<times> C) (A \<times> C <+> B \<times> C)"
    by (rule bij_betw_byWitness [where f' = "case_sum (\<lambda>(x,z). (Inl x, z)) (\<lambda>(y,z). (Inr y, z))"]) auto
qed

lemma Sigma_eqpoll_cong:
  assumes h: "bij_betw h A C"  and BD: "\<And>x. x \<in> A \<Longrightarrow> B x \<approx> D (h x)"
  shows "Sigma A B \<approx> Sigma C D"
proof (intro lepoll_antisym)
  show "Sigma A B \<lesssim> Sigma C D"
    by (metis Sigma_inj_lepoll_mono bij_betw_def eqpoll_imp_lepoll subset_refl assms)
  have "inj_on (inv_into A h) C \<and> inv_into A h ` C \<subseteq> A"
    by (metis bij_betw_def bij_betw_inv_into h set_eq_subset)
  then show "Sigma C D \<lesssim> Sigma A B"
    by (smt (verit, best) BD Sigma_inj_lepoll_mono bij_betw_inv_into_right eqpoll_sym h image_subset_iff lepoll_refl lepoll_trans2)
qed

lemma prod_insert_eqpoll:
  assumes "a \<notin> A" shows "insert a A \<times> B \<approx> B <+> A \<times> B"
  unfolding eqpoll_def
  proof
  show "bij_betw (\<lambda>(x,y). if x=a then Inl y else Inr (x,y)) (insert a A \<times> B) (B <+> A \<times> B)"
    by (rule bij_betw_byWitness [where f' = "case_sum (\<lambda>y. (a,y)) id"]) (auto simp: assms)
qed

subsection\<open>General Unions\<close>

lemma Union_eqpoll_Times:
  assumes B: "\<And>x. x \<in> A \<Longrightarrow> F x \<approx> B" and disj: "pairwise (\<lambda>x y. disjnt (F x) (F y)) A"
  shows "(\<Union>x\<in>A. F x) \<approx> A \<times> B"
proof (rule lepoll_antisym)
  obtain b where b: "\<And>x. x \<in> A \<Longrightarrow> bij_betw (b x) (F x) B"
    using B unfolding eqpoll_def by metis
  show "\<Union>(F ` A) \<lesssim> A \<times> B"
    unfolding lepoll_def
  proof (intro exI conjI)
    define \<chi> where "\<chi> \<equiv> \<lambda>z. THE x. x \<in> A \<and> z \<in> F x"
    have \<chi>: "\<chi> z = x" if "x \<in> A" "z \<in> F x" for x z
      unfolding \<chi>_def
      apply (rule the_equality)
      apply (simp add: that)
      by (metis disj disjnt_iff pairwiseD that)
    let ?f = "\<lambda>z. (\<chi> z, b (\<chi> z) z)"
    show "inj_on ?f (\<Union>(F ` A))"
      unfolding inj_on_def
      by clarify (metis \<chi> b bij_betw_inv_into_left)
    show "?f ` \<Union>(F ` A) \<subseteq> A \<times> B"
      using \<chi> b bij_betwE by blast
  qed
  show "A \<times> B \<lesssim> \<Union>(F ` A)"
    unfolding lepoll_def
  proof (intro exI conjI)
    let ?f = "\<lambda>(x,y). inv_into (F x) (b x) y"
    have *: "inv_into (F x) (b x) y \<in> F x" if "x \<in> A" "y \<in> B" for x y
      by (metis b bij_betw_imp_surj_on inv_into_into that)
    then show "inj_on ?f (A \<times> B)"
      unfolding inj_on_def
      by clarsimp (metis (mono_tags, lifting) b bij_betw_inv_into_right disj disjnt_iff pairwiseD)
    show "?f ` (A \<times> B) \<subseteq> \<Union> (F ` A)"
      by clarsimp (metis b bij_betw_imp_surj_on inv_into_into)
  qed
qed

lemma UN_lepoll_UN:
  assumes A: "\<And>x. x \<in> A \<Longrightarrow> B x \<lesssim> C x"
    and disj: "pairwise (\<lambda>x y. disjnt (C x) (C y)) A"
  shows "\<Union> (B`A) \<lesssim> \<Union> (C`A)"
proof -
  obtain f where f: "\<And>x. x \<in> A \<Longrightarrow> inj_on (f x) (B x) \<and> f x ` (B x) \<subseteq> (C x)"
    using A unfolding lepoll_def by metis
  show ?thesis
    unfolding lepoll_def
  proof (intro exI conjI)
    define \<chi> where "\<chi> \<equiv> \<lambda>z. @x. x \<in> A \<and> z \<in> B x"
    have \<chi>: "\<chi> z \<in> A \<and> z \<in> B (\<chi> z)" if "x \<in> A" "z \<in> B x" for x z
      unfolding \<chi>_def by (metis (mono_tags, lifting) someI_ex that)
    let ?f = "\<lambda>z. (f (\<chi> z) z)"
    show "inj_on ?f (\<Union>(B ` A))"
      using disj f unfolding inj_on_def disjnt_iff pairwise_def image_subset_iff
      by (metis UN_iff \<chi>)
    show "?f ` \<Union> (B ` A) \<subseteq> \<Union> (C ` A)"
      using \<chi> f unfolding image_subset_iff by blast
  qed
qed

lemma UN_eqpoll_UN:
  assumes A: "\<And>x. x \<in> A \<Longrightarrow> B x \<approx> C x"
    and B: "pairwise (\<lambda>x y. disjnt (B x) (B y)) A"
    and C: "pairwise (\<lambda>x y. disjnt (C x) (C y)) A"
  shows "(\<Union>x\<in>A. B x) \<approx> (\<Union>x\<in>A. C x)"
proof (rule lepoll_antisym)
  show "\<Union> (B ` A) \<lesssim> \<Union> (C ` A)"
    by (meson A C UN_lepoll_UN eqpoll_imp_lepoll)
  show "\<Union> (C ` A) \<lesssim> \<Union> (B ` A)"
    by (simp add: A B UN_lepoll_UN eqpoll_imp_lepoll eqpoll_sym)
qed

subsection\<open>General Cartesian products (Pi)\<close>

lemma PiE_sing_eqpoll_self: "({a} \<rightarrow>\<^sub>E B) \<approx> B"
proof -
  have 1: "x = y"
    if "x \<in> {a} \<rightarrow>\<^sub>E B" "y \<in> {a} \<rightarrow>\<^sub>E B" "x a = y a" for x y
    by (metis IntD2 PiE_def extensionalityI singletonD that)
  have 2: "x \<in> (\<lambda>h. h a) ` ({a} \<rightarrow>\<^sub>E B)" if "x \<in> B" for x
    using that by (rule_tac x="\<lambda>z\<in>{a}. x" in image_eqI) auto
  show ?thesis
  unfolding eqpoll_def bij_betw_def inj_on_def
  by (force intro: 1 2)
qed

lemma lepoll_funcset_right:
   "B \<lesssim> B' \<Longrightarrow> A \<rightarrow>\<^sub>E B \<lesssim> A \<rightarrow>\<^sub>E B'"
  apply (auto simp: lepoll_def inj_on_def)
  apply (rule_tac x = "\<lambda>g. \<lambda>z \<in> A. f(g z)" in exI)
  apply (auto simp: fun_eq_iff)
  apply (metis PiE_E)
  by blast

lemma lepoll_funcset_left:
  assumes "B \<noteq> {}" "A \<lesssim> A'"
  shows "A \<rightarrow>\<^sub>E B \<lesssim> A' \<rightarrow>\<^sub>E B"
proof -
  obtain b where "b \<in> B"
    using assms by blast
  obtain f where "inj_on f A" and fim: "f ` A \<subseteq> A'"
    using assms by (auto simp: lepoll_def)
  then obtain h where h: "\<And>x. x \<in> A \<Longrightarrow> h (f x) = x"
    using the_inv_into_f_f by fastforce
  let ?F = "\<lambda>g. \<lambda>u \<in> A'. if h u \<in> A then g(h u) else b"
  show ?thesis
    unfolding lepoll_def inj_on_def
  proof (intro exI conjI ballI impI ext)
    fix k l x
    assume k: "k \<in> A \<rightarrow>\<^sub>E B" and l: "l \<in> A \<rightarrow>\<^sub>E B" and "?F k = ?F l"
    then have "?F k (f x) = ?F l (f x)"
      by simp
    then show "k x = l x"
      apply (auto simp: h split: if_split_asm)
      apply (metis PiE_arb h k l)
      apply (metis (full_types) PiE_E h k l)
      using fim k l by fastforce
  next
    show "?F ` (A \<rightarrow>\<^sub>E B) \<subseteq> A' \<rightarrow>\<^sub>E B"
      using \<open>b \<in> B\<close> by force
  qed
qed

lemma lepoll_funcset:
   "\<lbrakk>B \<noteq> {}; A \<lesssim> A'; B \<lesssim> B'\<rbrakk> \<Longrightarrow> A \<rightarrow>\<^sub>E B \<lesssim> A' \<rightarrow>\<^sub>E B'"
  by (rule lepoll_trans [OF lepoll_funcset_right lepoll_funcset_left]) auto

lemma lepoll_PiE:
  assumes "\<And>i. i \<in> A \<Longrightarrow> B i \<lesssim> C i"
  shows "PiE A B \<lesssim> PiE A C"
proof -
  obtain f where f: "\<And>i. i \<in> A \<Longrightarrow> inj_on (f i) (B i) \<and> (f i) ` B i \<subseteq> C i"
    using assms unfolding lepoll_def by metis
  then show ?thesis
    unfolding lepoll_def
    apply (rule_tac x = "\<lambda>g. \<lambda>i \<in> A. f i (g i)" in exI)
    apply (auto simp: inj_on_def)
     apply (rule PiE_ext, auto)
     apply (metis (full_types) PiE_mem restrict_apply')
    by blast
qed

lemma card_le_PiE_subindex:
  assumes "A \<subseteq> A'" "Pi\<^sub>E A' B \<noteq> {}"
  shows "PiE A B \<lesssim> PiE A' B"
proof -
  have "\<And>x. x \<in> A' \<Longrightarrow> \<exists>y. y \<in> B x"
    using assms by blast
  then obtain g where g: "\<And>x. x \<in> A' \<Longrightarrow> g x \<in> B x"
    by metis
  let ?F = "\<lambda>f x. if x \<in> A then f x else if x \<in> A' then g x else undefined"
  have "Pi\<^sub>E A B \<subseteq> (\<lambda>f. restrict f A) ` Pi\<^sub>E A' B"
  proof
    show "f \<in> Pi\<^sub>E A B \<Longrightarrow> f \<in> (\<lambda>f. restrict f A) ` Pi\<^sub>E A' B" for f
      using \<open>A \<subseteq> A'\<close>
      by (rule_tac x="?F f" in image_eqI) (auto simp: g fun_eq_iff)
  qed
  then have "Pi\<^sub>E A B \<lesssim> (\<lambda>f. \<lambda>i \<in> A. f i) ` Pi\<^sub>E A' B"
    by (simp add: subset_imp_lepoll)
  also have "\<dots> \<lesssim> PiE A' B"
    by (rule image_lepoll)
  finally show ?thesis .
qed

lemma finite_restricted_funspace:
  assumes "finite A" "finite B"
  shows "finite {f. f ` A \<subseteq> B \<and> {x. f x \<noteq> k x} \<subseteq> A}" (is "finite ?F")
proof (rule finite_subset)
  show "finite ((\<lambda>U x. if \<exists>y. (x,y) \<in> U then @y. (x,y) \<in> U else k x) ` Pow(A \<times> B))" (is "finite ?G")
    using assms by auto
  show "?F \<subseteq> ?G"
  proof
    fix f
    assume "f \<in> ?F"
    then show "f \<in> ?G"
      by (rule_tac x="(\<lambda>x. (x,f x)) ` {x. f x \<noteq> k x}" in image_eqI) (auto simp: fun_eq_iff image_def)
  qed
qed

proposition finite_PiE_iff:
   "finite(PiE I S) \<longleftrightarrow> PiE I S = {} \<or> finite {i \<in> I. ~(\<exists>a. S i \<subseteq> {a})} \<and> (\<forall>i \<in> I. finite(S i))"
 (is "?lhs = ?rhs")
proof (cases "PiE I S = {}")
  case False
  define J where "J \<equiv> {i \<in> I. \<nexists>a. S i \<subseteq> {a}}"
  show ?thesis
  proof
    assume L: ?lhs
    have "infinite (Pi\<^sub>E I S)" if "infinite J"
    proof -
      have "(UNIV::nat set) \<lesssim> (UNIV::(nat\<Rightarrow>bool) set)"
      proof -
        have "\<forall>N::nat set. inj_on (=) N"
          by (simp add: inj_on_def)
        then show ?thesis
          by (meson infinite_iff_countable_subset infinite_le_lepoll top.extremum)
      qed
      also have "\<dots> = (UNIV::nat set) \<rightarrow>\<^sub>E (UNIV::bool set)"
        by auto
      also have "\<dots> \<lesssim> J \<rightarrow>\<^sub>E (UNIV::bool set)"
        apply (rule lepoll_funcset_left)
        using infinite_le_lepoll that by auto
      also have "\<dots> \<lesssim> Pi\<^sub>E J S"
      proof -
        have *: "(UNIV::bool set) \<lesssim> S i" if "i \<in> I" and "\<forall>a. \<not> S i \<subseteq> {a}" for i
        proof -
          obtain a b where "{a,b} \<subseteq> S i" "a \<noteq> b"
            by (metis \<open>\<forall>a. \<not> S i \<subseteq> {a}\<close> all_not_in_conv empty_subsetI insertCI insert_subset set_eq_subset subsetI)
          then show ?thesis
            apply (clarsimp simp: lepoll_def inj_on_def)
            apply (rule_tac x="\<lambda>x. if x then a else b" in exI, auto)
            done
        qed
        show ?thesis
          by (auto simp: * J_def intro: lepoll_PiE)
      qed
      also have "\<dots> \<lesssim> Pi\<^sub>E I S"
        using False by (auto simp: J_def intro: card_le_PiE_subindex)
      finally have "(UNIV::nat set) \<lesssim> Pi\<^sub>E I S" .
      then show ?thesis
        by (simp add: infinite_le_lepoll)
    qed
    moreover have "finite (S i)" if "i \<in> I" for i
    proof (rule finite_subset)
      obtain f where f: "f \<in> PiE I S"
        using False by blast
      show "S i \<subseteq> (\<lambda>f. f i) ` Pi\<^sub>E I S"
      proof
        show "s \<in> (\<lambda>f. f i) ` Pi\<^sub>E I S" if "s \<in> S i" for s
          using that f \<open>i \<in> I\<close>
          by (rule_tac x="\<lambda>j. if j = i then s else f j" in image_eqI) auto
      qed
    next
      show "finite ((\<lambda>x. x i) ` Pi\<^sub>E I S)"
        using L by blast
    qed
    ultimately show ?rhs
      using L
      by (auto simp: J_def False)
  next
    assume R: ?rhs
    have "\<forall>i \<in> I - J. \<exists>a. S i = {a}"
      using False J_def by blast
    then obtain a where a: "\<forall>i \<in> I - J. S i = {a i}"
      by metis
    let ?F = "{f. f ` J \<subseteq> (\<Union>i \<in> J. S i) \<and> {i. f i \<noteq> (if i \<in> I then a i else undefined)} \<subseteq> J}"
    have *: "finite (Pi\<^sub>E I S)"
      if "finite J" and "\<forall>i\<in>I. finite (S i)"
    proof (rule finite_subset)
      show "Pi\<^sub>E I S \<subseteq> ?F"
        apply safe
        using J_def apply blast
        by (metis DiffI PiE_E a singletonD)
      show "finite ?F"
      proof (rule finite_restricted_funspace [OF \<open>finite J\<close>])
        show "finite (\<Union> (S ` J))"
          using that J_def by blast
      qed
  qed
  show ?lhs
      using R by (auto simp: * J_def)
  qed
qed auto

corollary finite_funcset_iff:
  "finite(I \<rightarrow>\<^sub>E S) \<longleftrightarrow> (\<exists>a. S \<subseteq> {a}) \<or> I = {} \<or> finite I \<and> finite S"
  apply (auto simp: finite_PiE_iff PiE_eq_empty_iff dest: not_finite_existsD)
  using finite.simps by auto

lemma lists_lepoll_mono:
  assumes "A \<lesssim> B" shows "lists A \<lesssim> lists B"
proof -
  obtain f where f: "inj_on f A" "f ` A \<subseteq> B"
    by (meson assms lepoll_def)
  moreover have "inj_on (map f) (lists A)"
    using f unfolding inj_on_def
    by clarsimp (metis list.inj_map_strong)
  ultimately show ?thesis
    unfolding lepoll_def by force
qed

lemma lepoll_lists: "A \<lesssim> lists A"
  unfolding lepoll_def inj_on_def by(rule_tac x="\<lambda>x. [x]" in exI) auto

end


(*  Title:      HOL/NthRoot.thy
    Author:     Jacques D. Fleuriot, 1998
    Author:     Lawrence C Paulson, 2004
*)

section \<open>Nth Roots of Real Numbers\<close>

theory NthRoot
  imports Deriv
begin

subsection \<open>Existence of Nth Root\<close>

text \<open>Existence follows from the Intermediate Value Theorem\<close>

lemma realpow_pos_nth:
  fixes a :: real
  assumes n: "0 < n"
    and a: "0 < a"
  shows "\<exists>r>0. r ^ n = a"
proof -
  have "\<exists>r\<ge>0. r \<le> (max 1 a) \<and> r ^ n = a"
  proof (rule IVT)
    show "0 ^ n \<le> a"
      using n a by (simp add: power_0_left)
    show "0 \<le> max 1 a"
      by simp
    from n have n1: "1 \<le> n"
      by simp
    have "a \<le> max 1 a ^ 1"
      by simp
    also have "max 1 a ^ 1 \<le> max 1 a ^ n"
      using n1 by (rule power_increasing) simp
    finally show "a \<le> max 1 a ^ n" .
    show "\<forall>r. 0 \<le> r \<and> r \<le> max 1 a \<longrightarrow> isCont (\<lambda>x. x ^ n) r"
      by simp
  qed
  then obtain r where r: "0 \<le> r \<and> r ^ n = a"
    by fast
  with n a have "r \<noteq> 0"
    by (auto simp add: power_0_left)
  with r have "0 < r \<and> r ^ n = a"
    by simp
  then show ?thesis ..
qed

(* Used by Integration/RealRandVar.thy in AFP *)
lemma realpow_pos_nth2: "(0::real) < a \<Longrightarrow> \<exists>r>0. r ^ Suc n = a"
  by (blast intro: realpow_pos_nth)

text \<open>Uniqueness of nth positive root.\<close>
lemma realpow_pos_nth_unique: "0 < n \<Longrightarrow> 0 < a \<Longrightarrow> \<exists>!r. 0 < r \<and> r ^ n = a" for a :: real
  by (auto intro!: realpow_pos_nth simp: power_eq_iff_eq_base)

subsection \<open>Nth Root\<close>

text \<open>
  We define roots of negative reals such that \<open>root n (- x) = - root n x\<close>.
  This allows us to omit side conditions from many theorems.
\<close>

lemma inj_sgn_power:
  assumes "0 < n"
  shows "inj (\<lambda>y. sgn y * \<bar>y\<bar>^n :: real)"
    (is "inj ?f")
proof (rule injI)
  have x: "(0 < a \<and> b < 0) \<or> (a < 0 \<and> 0 < b) \<Longrightarrow> a \<noteq> b" for a b :: real
    by auto
  fix x y
  assume "?f x = ?f y"
  with power_eq_iff_eq_base[of n "\<bar>x\<bar>" "\<bar>y\<bar>"] \<open>0 < n\<close> show "x = y"
    by (cases rule: linorder_cases[of 0 x, case_product linorder_cases[of 0 y]])
       (simp_all add: x)
qed

lemma sgn_power_injE:
  "sgn a * \<bar>a\<bar> ^ n = x \<Longrightarrow> x = sgn b * \<bar>b\<bar> ^ n \<Longrightarrow> 0 < n \<Longrightarrow> a = b"
  for a b :: real
  using inj_sgn_power[THEN injD, of n a b] by simp

definition root :: "nat \<Rightarrow> real \<Rightarrow> real"
  where "root n x = (if n = 0 then 0 else the_inv (\<lambda>y. sgn y * \<bar>y\<bar>^n) x)"

lemma root_0 [simp]: "root 0 x = 0"
  by (simp add: root_def)

lemma root_sgn_power: "0 < n \<Longrightarrow> root n (sgn y * \<bar>y\<bar>^n) = y"
  using the_inv_f_f[OF inj_sgn_power] by (simp add: root_def)

lemma sgn_power_root:
  assumes "0 < n"
  shows "sgn (root n x) * \<bar>(root n x)\<bar>^n = x"
    (is "?f (root n x) = x")
proof (cases "x = 0")
  case True
  with assms root_sgn_power[of n 0] show ?thesis
    by simp
next
  case False
  with realpow_pos_nth[OF \<open>0 < n\<close>, of "\<bar>x\<bar>"]
  obtain r where "0 < r" "r ^ n = \<bar>x\<bar>"
    by auto
  with \<open>x \<noteq> 0\<close> have S: "x \<in> range ?f"
    by (intro image_eqI[of _ _ "sgn x * r"])
       (auto simp: abs_mult sgn_mult power_mult_distrib abs_sgn_eq mult_sgn_abs)
  from \<open>0 < n\<close> f_the_inv_into_f[OF inj_sgn_power[OF \<open>0 < n\<close>] this]  show ?thesis
    by (simp add: root_def)
qed

lemma split_root: "P (root n x) \<longleftrightarrow> (n = 0 \<longrightarrow> P 0) \<and> (0 < n \<longrightarrow> (\<forall>y. sgn y * \<bar>y\<bar>^n = x \<longrightarrow> P y))"
proof (cases "n = 0")
  case True
  then show ?thesis by simp
next
  case False
  then show ?thesis
    by simp (metis root_sgn_power sgn_power_root)
qed

lemma real_root_zero [simp]: "root n 0 = 0"
  by (simp split: split_root add: sgn_zero_iff)

lemma real_root_minus: "root n (- x) = - root n x"
  by (clarsimp split: split_root elim!: sgn_power_injE simp: sgn_minus)

lemma real_root_less_mono: "0 < n \<Longrightarrow> x < y \<Longrightarrow> root n x < root n y"
proof (clarsimp split: split_root)
  have *: "0 < b \<Longrightarrow> a < 0 \<Longrightarrow> \<not> a > b" for a b :: real
    by auto
  fix a b :: real
  assume "0 < n" "sgn a * \<bar>a\<bar> ^ n < sgn b * \<bar>b\<bar> ^ n"
  then show "a < b"
    using power_less_imp_less_base[of a n b]
      power_less_imp_less_base[of "- b" n "- a"]
    by (simp add: sgn_real_def * [of "a ^ n" "- ((- b) ^ n)"]
        split: if_split_asm)
qed

lemma real_root_gt_zero: "0 < n \<Longrightarrow> 0 < x \<Longrightarrow> 0 < root n x"
  using real_root_less_mono[of n 0 x] by simp

lemma real_root_ge_zero: "0 \<le> x \<Longrightarrow> 0 \<le> root n x"
  using real_root_gt_zero[of n x]
  by (cases "n = 0") (auto simp add: le_less)

lemma real_root_pow_pos: "0 < n \<Longrightarrow> 0 < x \<Longrightarrow> root n x ^ n = x"  (* TODO: rename *)
  using sgn_power_root[of n x] real_root_gt_zero[of n x] by simp

lemma real_root_pow_pos2 [simp]: "0 < n \<Longrightarrow> 0 \<le> x \<Longrightarrow> root n x ^ n = x"  (* TODO: rename *)
  by (auto simp add: order_le_less real_root_pow_pos)

lemma sgn_root: "0 < n \<Longrightarrow> sgn (root n x) = sgn x"
  by (auto split: split_root simp: sgn_real_def)

lemma odd_real_root_pow: "odd n \<Longrightarrow> root n x ^ n = x"
  using sgn_power_root[of n x]
  by (simp add: odd_pos sgn_real_def split: if_split_asm)

lemma real_root_power_cancel: "0 < n \<Longrightarrow> 0 \<le> x \<Longrightarrow> root n (x ^ n) = x"
  using root_sgn_power[of n x] by (auto simp add: le_less power_0_left)

lemma odd_real_root_power_cancel: "odd n \<Longrightarrow> root n (x ^ n) = x"
  using root_sgn_power[of n x]
  by (simp add: odd_pos sgn_real_def power_0_left split: if_split_asm)

lemma real_root_pos_unique: "0 < n \<Longrightarrow> 0 \<le> y \<Longrightarrow> y ^ n = x \<Longrightarrow> root n x = y"
  using root_sgn_power[of n y] by (auto simp add: le_less power_0_left)

lemma odd_real_root_unique: "odd n \<Longrightarrow> y ^ n = x \<Longrightarrow> root n x = y"
  by (erule subst, rule odd_real_root_power_cancel)

lemma real_root_one [simp]: "0 < n \<Longrightarrow> root n 1 = 1"
  by (simp add: real_root_pos_unique)

text \<open>Root function is strictly monotonic, hence injective.\<close>

lemma real_root_le_mono: "0 < n \<Longrightarrow> x \<le> y \<Longrightarrow> root n x \<le> root n y"
  by (auto simp add: order_le_less real_root_less_mono)

lemma real_root_less_iff [simp]: "0 < n \<Longrightarrow> root n x < root n y \<longleftrightarrow> x < y"
  by (cases "x < y") (simp_all add: real_root_less_mono linorder_not_less real_root_le_mono)

lemma real_root_le_iff [simp]: "0 < n \<Longrightarrow> root n x \<le> root n y \<longleftrightarrow> x \<le> y"
  by (cases "x \<le> y") (simp_all add: real_root_le_mono linorder_not_le real_root_less_mono)

lemma real_root_eq_iff [simp]: "0 < n \<Longrightarrow> root n x = root n y \<longleftrightarrow> x = y"
  by (simp add: order_eq_iff)

lemmas real_root_gt_0_iff [simp] = real_root_less_iff [where x=0, simplified]
lemmas real_root_lt_0_iff [simp] = real_root_less_iff [where y=0, simplified]
lemmas real_root_ge_0_iff [simp] = real_root_le_iff [where x=0, simplified]
lemmas real_root_le_0_iff [simp] = real_root_le_iff [where y=0, simplified]
lemmas real_root_eq_0_iff [simp] = real_root_eq_iff [where y=0, simplified]

lemma real_root_gt_1_iff [simp]: "0 < n \<Longrightarrow> 1 < root n y \<longleftrightarrow> 1 < y"
  using real_root_less_iff [where x=1] by simp

lemma real_root_lt_1_iff [simp]: "0 < n \<Longrightarrow> root n x < 1 \<longleftrightarrow> x < 1"
  using real_root_less_iff [where y=1] by simp

lemma real_root_ge_1_iff [simp]: "0 < n \<Longrightarrow> 1 \<le> root n y \<longleftrightarrow> 1 \<le> y"
  using real_root_le_iff [where x=1] by simp

lemma real_root_le_1_iff [simp]: "0 < n \<Longrightarrow> root n x \<le> 1 \<longleftrightarrow> x \<le> 1"
  using real_root_le_iff [where y=1] by simp

lemma real_root_eq_1_iff [simp]: "0 < n \<Longrightarrow> root n x = 1 \<longleftrightarrow> x = 1"
  using real_root_eq_iff [where y=1] by simp

text \<open>Roots of multiplication and division.\<close>

lemma real_root_mult: "root n (x * y) = root n x * root n y"
  by (auto split: split_root elim!: sgn_power_injE
      simp: sgn_mult abs_mult power_mult_distrib)

lemma real_root_inverse: "root n (inverse x) = inverse (root n x)"
  by (auto split: split_root elim!: sgn_power_injE
      simp: power_inverse)

lemma real_root_divide: "root n (x / y) = root n x / root n y"
  by (simp add: divide_inverse real_root_mult real_root_inverse)

lemma real_root_abs: "0 < n \<Longrightarrow> root n \<bar>x\<bar> = \<bar>root n x\<bar>"
  by (simp add: abs_if real_root_minus)

lemma root_abs_power: "n > 0 \<Longrightarrow> abs (root n (y ^n)) = abs y"
  using root_sgn_power [of n]
  by (metis abs_ge_zero power_abs real_root_abs real_root_power_cancel)

lemma real_root_power: "0 < n \<Longrightarrow> root n (x ^ k) = root n x ^ k"
  by (induct k) (simp_all add: real_root_mult)

text \<open>Roots of roots.\<close>

lemma real_root_Suc_0 [simp]: "root (Suc 0) x = x"
  by (simp add: odd_real_root_unique)

lemma real_root_mult_exp: "root (m * n) x = root m (root n x)"
  by (auto split: split_root elim!: sgn_power_injE
      simp: sgn_zero_iff sgn_mult power_mult[symmetric]
      abs_mult power_mult_distrib abs_sgn_eq)

lemma real_root_commute: "root m (root n x) = root n (root m x)"
  by (simp add: real_root_mult_exp [symmetric] mult.commute)

text \<open>Monotonicity in first argument.\<close>

lemma real_root_strict_decreasing:
  assumes "0 < n" "n < N" "1 < x"
  shows "root N x < root n x"
proof -
  from assms have "root n (root N x) ^ n < root N (root n x) ^ N"
    by (simp add: real_root_commute power_strict_increasing del: real_root_pow_pos2)
  with assms show ?thesis by simp
qed

lemma real_root_strict_increasing:
  assumes "0 < n" "n < N" "0 < x" "x < 1"
  shows "root n x < root N x"
proof -
  from assms have "root N (root n x) ^ N < root n (root N x) ^ n"
    by (simp add: real_root_commute power_strict_decreasing del: real_root_pow_pos2)
  with assms show ?thesis by simp
qed

lemma real_root_decreasing: "0 < n \<Longrightarrow> n \<le> N \<Longrightarrow> 1 \<le> x \<Longrightarrow> root N x \<le> root n x"
  by (auto simp add: order_le_less real_root_strict_decreasing)

lemma real_root_increasing: "0 < n \<Longrightarrow> n \<le> N \<Longrightarrow> 0 \<le> x \<Longrightarrow> x \<le> 1 \<Longrightarrow> root n x \<le> root N x"
  by (auto simp add: order_le_less real_root_strict_increasing)

text \<open>Continuity and derivatives.\<close>

lemma isCont_real_root: "isCont (root n) x"
proof (cases "n > 0")
  case True
  let ?f = "\<lambda>y::real. sgn y * \<bar>y\<bar>^n"
  have "continuous_on ({0..} \<union> {.. 0}) (\<lambda>x. if 0 < x then x ^ n else - ((-x) ^ n) :: real)"
    using True by (intro continuous_on_If continuous_intros) auto
  then have "continuous_on UNIV ?f"
    by (rule continuous_on_cong[THEN iffD1, rotated 2]) (auto simp: not_less le_less True)
  then have [simp]: "isCont ?f x" for x
    by (simp add: continuous_on_eq_continuous_at)
  have "isCont (root n) (?f (root n x))"
    by (rule isCont_inverse_function [where f="?f" and d=1]) (auto simp: root_sgn_power True)
  then show ?thesis
    by (simp add: sgn_power_root True)
next
  case False
  then show ?thesis
    by (simp add: root_def[abs_def])
qed

lemma tendsto_real_root [tendsto_intros]:
  "(f \<longlongrightarrow> x) F \<Longrightarrow> ((\<lambda>x. root n (f x)) \<longlongrightarrow> root n x) F"
  using isCont_tendsto_compose[OF isCont_real_root, of f x F] .

lemma continuous_real_root [continuous_intros]:
  "continuous F f \<Longrightarrow> continuous F (\<lambda>x. root n (f x))"
  unfolding continuous_def by (rule tendsto_real_root)

lemma continuous_on_real_root [continuous_intros]:
  "continuous_on s f \<Longrightarrow> continuous_on s (\<lambda>x. root n (f x))"
  unfolding continuous_on_def by (auto intro: tendsto_real_root)

lemma DERIV_real_root:
  assumes n: "0 < n"
    and x: "0 < x"
  shows "DERIV (root n) x :> inverse (real n * root n x ^ (n - Suc 0))"
proof (rule DERIV_inverse_function)
  show "0 < x"
    using x .
  show "x < x + 1"
    by simp
  show "DERIV (\<lambda>x. x ^ n) (root n x) :> real n * root n x ^ (n - Suc 0)"
    by (rule DERIV_pow)
  show "real n * root n x ^ (n - Suc 0) \<noteq> 0"
    using n x by simp
  show "isCont (root n) x"
    by (rule isCont_real_root)
qed (use n in auto)

lemma DERIV_odd_real_root:
  assumes n: "odd n"
    and x: "x \<noteq> 0"
  shows "DERIV (root n) x :> inverse (real n * root n x ^ (n - Suc 0))"
proof (rule DERIV_inverse_function)
  show "x - 1 < x" "x < x + 1"
    by auto
  show "DERIV (\<lambda>x. x ^ n) (root n x) :> real n * root n x ^ (n - Suc 0)"
    by (rule DERIV_pow)
  show "real n * root n x ^ (n - Suc 0) \<noteq> 0"
    using odd_pos [OF n] x by simp
  show "isCont (root n) x"
    by (rule isCont_real_root)
qed (use n odd_real_root_pow in auto)

lemma DERIV_even_real_root:
  assumes n: "0 < n"
    and "even n"
    and x: "x < 0"
  shows "DERIV (root n) x :> inverse (- real n * root n x ^ (n - Suc 0))"
proof (rule DERIV_inverse_function)
  show "x - 1 < x"
    by simp
  show "x < 0"
    using x .
  show "- (root n y ^ n) = y" if "x - 1 < y" and "y < 0" for y
  proof -
    have "root n (-y) ^ n = -y"
      using that \<open>0 < n\<close> by simp
    with real_root_minus and \<open>even n\<close>
    show "- (root n y ^ n) = y" by simp
  qed
  show "DERIV (\<lambda>x. - (x ^ n)) (root n x) :> - real n * root n x ^ (n - Suc 0)"
    by  (auto intro!: derivative_eq_intros)
  show "- real n * root n x ^ (n - Suc 0) \<noteq> 0"
    using n x by simp
  show "isCont (root n) x"
    by (rule isCont_real_root)
qed

lemma DERIV_real_root_generic:
  assumes "0 < n"
    and "x \<noteq> 0"
    and "even n \<Longrightarrow> 0 < x \<Longrightarrow> D = inverse (real n * root n x ^ (n - Suc 0))"
    and "even n \<Longrightarrow> x < 0 \<Longrightarrow> D = - inverse (real n * root n x ^ (n - Suc 0))"
    and "odd n \<Longrightarrow> D = inverse (real n * root n x ^ (n - Suc 0))"
  shows "DERIV (root n) x :> D"
  using assms
  by (cases "even n", cases "0 < x")
    (auto intro: DERIV_real_root[THEN DERIV_cong]
      DERIV_odd_real_root[THEN DERIV_cong]
      DERIV_even_real_root[THEN DERIV_cong])

lemma power_tendsto_0_iff [simp]:
  fixes f :: "'a \<Rightarrow> real"
  assumes "n > 0"
  shows "((\<lambda>x. f x ^ n) \<longlongrightarrow> 0) F \<longleftrightarrow> (f \<longlongrightarrow> 0) F"
proof -
  have "((\<lambda>x. \<bar>root n (f x ^ n)\<bar>) \<longlongrightarrow> 0) F \<Longrightarrow> (f \<longlongrightarrow> 0) F"
    by (auto simp: assms root_abs_power tendsto_rabs_zero_iff)
  then have "((\<lambda>x. f x ^ n) \<longlongrightarrow> 0) F \<Longrightarrow> (f \<longlongrightarrow> 0) F"
    by (metis tendsto_real_root abs_0 real_root_zero tendsto_rabs)
  with assms show ?thesis
    by (auto simp: tendsto_null_power)
qed

subsection \<open>Square Root\<close>

definition sqrt :: "real \<Rightarrow> real"
  where "sqrt = root 2"

lemma pos2: "0 < (2::nat)"
  by simp

lemma real_sqrt_unique: "y\<^sup>2 = x \<Longrightarrow> 0 \<le> y \<Longrightarrow> sqrt x = y"
  unfolding sqrt_def by (rule real_root_pos_unique [OF pos2])

lemma real_sqrt_abs [simp]: "sqrt (x\<^sup>2) = \<bar>x\<bar>"
  by (metis power2_abs abs_ge_zero real_sqrt_unique)

lemma real_sqrt_pow2 [simp]: "0 \<le> x \<Longrightarrow> (sqrt x)\<^sup>2 = x"
  unfolding sqrt_def by (rule real_root_pow_pos2 [OF pos2])

lemma real_sqrt_pow2_iff [simp]: "(sqrt x)\<^sup>2 = x \<longleftrightarrow> 0 \<le> x"
  by (metis real_sqrt_pow2 zero_le_power2)

lemma real_sqrt_zero [simp]: "sqrt 0 = 0"
  unfolding sqrt_def by (rule real_root_zero)

lemma real_sqrt_one [simp]: "sqrt 1 = 1"
  unfolding sqrt_def by (rule real_root_one [OF pos2])

lemma real_sqrt_four [simp]: "sqrt 4 = 2"
  using real_sqrt_abs[of 2] by simp

lemma real_sqrt_minus: "sqrt (- x) = - sqrt x"
  unfolding sqrt_def by (rule real_root_minus)

lemma real_sqrt_mult: "sqrt (x * y) = sqrt x * sqrt y"
  unfolding sqrt_def by (rule real_root_mult)

lemma real_sqrt_mult_self[simp]: "sqrt a * sqrt a = \<bar>a\<bar>"
  using real_sqrt_abs[of a] unfolding power2_eq_square real_sqrt_mult .

lemma real_sqrt_inverse: "sqrt (inverse x) = inverse (sqrt x)"
  unfolding sqrt_def by (rule real_root_inverse)

lemma real_sqrt_divide: "sqrt (x / y) = sqrt x / sqrt y"
  unfolding sqrt_def by (rule real_root_divide)

lemma real_sqrt_power: "sqrt (x ^ k) = sqrt x ^ k"
  unfolding sqrt_def by (rule real_root_power [OF pos2])

lemma real_sqrt_gt_zero: "0 < x \<Longrightarrow> 0 < sqrt x"
  unfolding sqrt_def by (rule real_root_gt_zero [OF pos2])

lemma real_sqrt_ge_zero: "0 \<le> x \<Longrightarrow> 0 \<le> sqrt x"
  unfolding sqrt_def by (rule real_root_ge_zero)

lemma real_sqrt_less_mono: "x < y \<Longrightarrow> sqrt x < sqrt y"
  unfolding sqrt_def by (rule real_root_less_mono [OF pos2])

lemma real_sqrt_le_mono: "x \<le> y \<Longrightarrow> sqrt x \<le> sqrt y"
  unfolding sqrt_def by (rule real_root_le_mono [OF pos2])

lemma real_sqrt_less_iff [simp]: "sqrt x < sqrt y \<longleftrightarrow> x < y"
  unfolding sqrt_def by (rule real_root_less_iff [OF pos2])

lemma real_sqrt_le_iff [simp]: "sqrt x \<le> sqrt y \<longleftrightarrow> x \<le> y"
  unfolding sqrt_def by (rule real_root_le_iff [OF pos2])

lemma real_sqrt_eq_iff [simp]: "sqrt x = sqrt y \<longleftrightarrow> x = y"
  unfolding sqrt_def by (rule real_root_eq_iff [OF pos2])

lemma real_less_lsqrt: "0 \<le> x \<Longrightarrow> 0 \<le> y \<Longrightarrow> x < y\<^sup>2 \<Longrightarrow> sqrt x < y"
  using real_sqrt_less_iff[of x "y\<^sup>2"] by simp

lemma real_le_lsqrt: "0 \<le> x \<Longrightarrow> 0 \<le> y \<Longrightarrow> x \<le> y\<^sup>2 \<Longrightarrow> sqrt x \<le> y"
  using real_sqrt_le_iff[of x "y\<^sup>2"] by simp

lemma real_le_rsqrt: "x\<^sup>2 \<le> y \<Longrightarrow> x \<le> sqrt y"
  using real_sqrt_le_mono[of "x\<^sup>2" y] by simp

lemma real_less_rsqrt: "x\<^sup>2 < y \<Longrightarrow> x < sqrt y"
  using real_sqrt_less_mono[of "x\<^sup>2" y] by simp

lemma real_sqrt_power_even:
  assumes "even n" "x \<ge> 0"
  shows   "sqrt x ^ n = x ^ (n div 2)"
proof -
  from assms obtain k where "n = 2*k" by (auto elim!: evenE)
  with assms show ?thesis by (simp add: power_mult)
qed

lemma sqrt_le_D: "sqrt x \<le> y \<Longrightarrow> x \<le> y\<^sup>2"
  by (meson not_le real_less_rsqrt)

lemma sqrt_ge_absD: "\<bar>x\<bar> \<le> sqrt y \<Longrightarrow> x\<^sup>2 \<le> y"
  using real_sqrt_le_iff[of "x\<^sup>2"] by simp

lemma sqrt_even_pow2:
  assumes n: "even n"
  shows "sqrt (2 ^ n) = 2 ^ (n div 2)"
proof -
  from n obtain m where m: "n = 2 * m" ..
  from m have "sqrt (2 ^ n) = sqrt ((2 ^ m)\<^sup>2)"
    by (simp only: power_mult[symmetric] mult.commute)
  then show ?thesis
    using m by simp
qed

lemmas real_sqrt_gt_0_iff [simp] = real_sqrt_less_iff [where x=0, unfolded real_sqrt_zero]
lemmas real_sqrt_lt_0_iff [simp] = real_sqrt_less_iff [where y=0, unfolded real_sqrt_zero]
lemmas real_sqrt_ge_0_iff [simp] = real_sqrt_le_iff [where x=0, unfolded real_sqrt_zero]
lemmas real_sqrt_le_0_iff [simp] = real_sqrt_le_iff [where y=0, unfolded real_sqrt_zero]
lemmas real_sqrt_eq_0_iff [simp] = real_sqrt_eq_iff [where y=0, unfolded real_sqrt_zero]

lemmas real_sqrt_gt_1_iff [simp] = real_sqrt_less_iff [where x=1, unfolded real_sqrt_one]
lemmas real_sqrt_lt_1_iff [simp] = real_sqrt_less_iff [where y=1, unfolded real_sqrt_one]
lemmas real_sqrt_ge_1_iff [simp] = real_sqrt_le_iff [where x=1, unfolded real_sqrt_one]
lemmas real_sqrt_le_1_iff [simp] = real_sqrt_le_iff [where y=1, unfolded real_sqrt_one]
lemmas real_sqrt_eq_1_iff [simp] = real_sqrt_eq_iff [where y=1, unfolded real_sqrt_one]

lemma sqrt_add_le_add_sqrt:
  assumes "0 \<le> x" "0 \<le> y"
  shows "sqrt (x + y) \<le> sqrt x + sqrt y"
  by (rule power2_le_imp_le) (simp_all add: power2_sum assms)

lemma isCont_real_sqrt: "isCont sqrt x"
  unfolding sqrt_def by (rule isCont_real_root)

lemma tendsto_real_sqrt [tendsto_intros]:
  "(f \<longlongrightarrow> x) F \<Longrightarrow> ((\<lambda>x. sqrt (f x)) \<longlongrightarrow> sqrt x) F"
  unfolding sqrt_def by (rule tendsto_real_root)

lemma continuous_real_sqrt [continuous_intros]:
  "continuous F f \<Longrightarrow> continuous F (\<lambda>x. sqrt (f x))"
  unfolding sqrt_def by (rule continuous_real_root)

lemma continuous_on_real_sqrt [continuous_intros]:
  "continuous_on s f \<Longrightarrow> continuous_on s (\<lambda>x. sqrt (f x))"
  unfolding sqrt_def by (rule continuous_on_real_root)

lemma DERIV_real_sqrt_generic:
  assumes "x \<noteq> 0"
    and "x > 0 \<Longrightarrow> D = inverse (sqrt x) / 2"
    and "x < 0 \<Longrightarrow> D = - inverse (sqrt x) / 2"
  shows "DERIV sqrt x :> D"
  using assms unfolding sqrt_def
  by (auto intro!: DERIV_real_root_generic)

lemma DERIV_real_sqrt: "0 < x \<Longrightarrow> DERIV sqrt x :> inverse (sqrt x) / 2"
  using DERIV_real_sqrt_generic by simp

declare
  DERIV_real_sqrt_generic[THEN DERIV_chain2, derivative_intros]
  DERIV_real_root_generic[THEN DERIV_chain2, derivative_intros]

lemmas has_derivative_real_sqrt[derivative_intros] = DERIV_real_sqrt[THEN DERIV_compose_FDERIV]

lemma not_real_square_gt_zero [simp]: "\<not> 0 < x * x \<longleftrightarrow> x = 0"
  for x :: real
  apply auto
  using linorder_less_linear [where x = x and y = 0]
  apply (simp add: zero_less_mult_iff)
  done

lemma real_sqrt_abs2 [simp]: "sqrt (x * x) = \<bar>x\<bar>"
  apply (subst power2_eq_square [symmetric])
  apply (rule real_sqrt_abs)
  done

lemma real_inv_sqrt_pow2: "0 < x \<Longrightarrow> (inverse (sqrt x))\<^sup>2 = inverse x"
  by (simp add: power_inverse)

lemma real_sqrt_eq_zero_cancel: "0 \<le> x \<Longrightarrow> sqrt x = 0 \<Longrightarrow> x = 0"
  by simp

lemma real_sqrt_ge_one: "1 \<le> x \<Longrightarrow> 1 \<le> sqrt x"
  by simp

lemma sqrt_divide_self_eq:
  assumes nneg: "0 \<le> x"
  shows "sqrt x / x = inverse (sqrt x)"
proof (cases "x = 0")
  case True
  then show ?thesis by simp
next
  case False
  then have pos: "0 < x"
    using nneg by arith
  show ?thesis
  proof (rule right_inverse_eq [THEN iffD1, symmetric])
    show "sqrt x / x \<noteq> 0"
      by (simp add: divide_inverse nneg False)
    show "inverse (sqrt x) / (sqrt x / x) = 1"
      by (simp add: divide_inverse mult.assoc [symmetric]
          power2_eq_square [symmetric] real_inv_sqrt_pow2 pos False)
  qed
qed

lemma real_div_sqrt: "0 \<le> x \<Longrightarrow> x / sqrt x = sqrt x"
  by (cases "x = 0") (simp_all add: sqrt_divide_self_eq [of x] field_simps)

lemma real_divide_square_eq [simp]: "(r * a) / (r * r) = a / r"
  for a r :: real
  by (cases "r = 0") (simp_all add: divide_inverse ac_simps)

lemma lemma_real_divide_sqrt_less: "0 < u \<Longrightarrow> u / sqrt 2 < u"
  by (simp add: divide_less_eq)

lemma four_x_squared: "4 * x\<^sup>2 = (2 * x)\<^sup>2"
  for x :: real
  by (simp add: power2_eq_square)

lemma sqrt_at_top: "LIM x at_top. sqrt x :: real :> at_top"
  by (rule filterlim_at_top_at_top[where Q="\<lambda>x. True" and P="\<lambda>x. 0 < x" and g="power2"])
     (auto intro: eventually_gt_at_top)

subsection \<open>Square Root of Sum of Squares\<close>

lemma sum_squares_bound: "2 * x * y \<le> x\<^sup>2 + y\<^sup>2"
  for x y :: "'a::linordered_field"
proof -
  have "(x - y)\<^sup>2 = x * x - 2 * x * y + y * y"
    by algebra
  then have "0 \<le> x\<^sup>2 - 2 * x * y + y\<^sup>2"
    by (metis sum_power2_ge_zero zero_le_double_add_iff_zero_le_single_add power2_eq_square)
  then show ?thesis
    by arith
qed

lemma arith_geo_mean:
  fixes u :: "'a::linordered_field"
  assumes "u\<^sup>2 = x * y" "x \<ge> 0" "y \<ge> 0"
  shows "u \<le> (x + y)/2"
  apply (rule power2_le_imp_le)
  using sum_squares_bound assms
  apply (auto simp: zero_le_mult_iff)
  apply (auto simp: algebra_simps power2_eq_square)
  done

lemma arith_geo_mean_sqrt:
  fixes x :: real
  assumes "x \<ge> 0" "y \<ge> 0"
  shows "sqrt (x * y) \<le> (x + y)/2"
  apply (rule arith_geo_mean)
  using assms
  apply (auto simp: zero_le_mult_iff)
  done

lemma real_sqrt_sum_squares_mult_ge_zero [simp]: "0 \<le> sqrt ((x\<^sup>2 + y\<^sup>2) * (xa\<^sup>2 + ya\<^sup>2))"
  by (metis real_sqrt_ge_0_iff split_mult_pos_le sum_power2_ge_zero)

lemma real_sqrt_sum_squares_mult_squared_eq [simp]:
  "(sqrt ((x\<^sup>2 + y\<^sup>2) * (xa\<^sup>2 + ya\<^sup>2)))\<^sup>2 = (x\<^sup>2 + y\<^sup>2) * (xa\<^sup>2 + ya\<^sup>2)"
  by (simp add: zero_le_mult_iff)

lemma real_sqrt_sum_squares_eq_cancel: "sqrt (x\<^sup>2 + y\<^sup>2) = x \<Longrightarrow> y = 0"
  by (drule arg_cong [where f = "\<lambda>x. x\<^sup>2"]) simp

lemma real_sqrt_sum_squares_eq_cancel2: "sqrt (x\<^sup>2 + y\<^sup>2) = y \<Longrightarrow> x = 0"
  by (drule arg_cong [where f = "\<lambda>x. x\<^sup>2"]) simp

lemma real_sqrt_sum_squares_ge1 [simp]: "x \<le> sqrt (x\<^sup>2 + y\<^sup>2)"
  by (rule power2_le_imp_le) simp_all

lemma real_sqrt_sum_squares_ge2 [simp]: "y \<le> sqrt (x\<^sup>2 + y\<^sup>2)"
  by (rule power2_le_imp_le) simp_all

lemma real_sqrt_ge_abs1 [simp]: "\<bar>x\<bar> \<le> sqrt (x\<^sup>2 + y\<^sup>2)"
  by (rule power2_le_imp_le) simp_all

lemma real_sqrt_ge_abs2 [simp]: "\<bar>y\<bar> \<le> sqrt (x\<^sup>2 + y\<^sup>2)"
  by (rule power2_le_imp_le) simp_all

lemma le_real_sqrt_sumsq [simp]: "x \<le> sqrt (x * x + y * y)"
  by (simp add: power2_eq_square [symmetric])

lemma sqrt_sum_squares_le_sum:
  "\<lbrakk>0 \<le> x; 0 \<le> y\<rbrakk> \<Longrightarrow> sqrt (x\<^sup>2 + y\<^sup>2) \<le> x + y"
  by (rule power2_le_imp_le) (simp_all add: power2_sum)

lemma L2_set_mult_ineq_lemma:
  fixes a b c d :: real
  shows "2 * (a * c) * (b * d) \<le> a\<^sup>2 * d\<^sup>2 + b\<^sup>2 * c\<^sup>2"
proof -
  have "0 \<le> (a * d - b * c)\<^sup>2" by simp
  also have "\<dots> = a\<^sup>2 * d\<^sup>2 + b\<^sup>2 * c\<^sup>2 - 2 * (a * d) * (b * c)"
    by (simp only: power2_diff power_mult_distrib)
  also have "\<dots> = a\<^sup>2 * d\<^sup>2 + b\<^sup>2 * c\<^sup>2 - 2 * (a * c) * (b * d)"
    by simp
  finally show "2 * (a * c) * (b * d) \<le> a\<^sup>2 * d\<^sup>2 + b\<^sup>2 * c\<^sup>2"
    by simp
qed

lemma sqrt_sum_squares_le_sum_abs: "sqrt (x\<^sup>2 + y\<^sup>2) \<le> \<bar>x\<bar> + \<bar>y\<bar>"
  by (rule power2_le_imp_le) (simp_all add: power2_sum)

lemma real_sqrt_sum_squares_triangle_ineq:
  "sqrt ((a + c)\<^sup>2 + (b + d)\<^sup>2) \<le> sqrt (a\<^sup>2 + b\<^sup>2) + sqrt (c\<^sup>2 + d\<^sup>2)"
proof -
  have "(a * c + b * d) \<le> (sqrt (a\<^sup>2 + b\<^sup>2) * sqrt (c\<^sup>2 + d\<^sup>2))"
    by (rule power2_le_imp_le) (simp_all add: power2_sum power_mult_distrib ring_distribs L2_set_mult_ineq_lemma add.commute)
  then have "(a + c)\<^sup>2 + (b + d)\<^sup>2 \<le> (sqrt (a\<^sup>2 + b\<^sup>2) + sqrt (c\<^sup>2 + d\<^sup>2))\<^sup>2"
    by (simp add: power2_sum)
  then show ?thesis
    by (auto intro: power2_le_imp_le)
qed

lemma real_sqrt_sum_squares_less: "\<bar>x\<bar> < u / sqrt 2 \<Longrightarrow> \<bar>y\<bar> < u / sqrt 2 \<Longrightarrow> sqrt (x\<^sup>2 + y\<^sup>2) < u"
  apply (rule power2_less_imp_less)
   apply simp
   apply (drule power_strict_mono [OF _ abs_ge_zero pos2])
   apply (drule power_strict_mono [OF _ abs_ge_zero pos2])
   apply (simp add: power_divide)
  apply (drule order_le_less_trans [OF abs_ge_zero])
  apply (simp add: zero_less_divide_iff)
  done

lemma sqrt2_less_2: "sqrt 2 < (2::real)"
  by (metis not_less not_less_iff_gr_or_eq numeral_less_iff real_sqrt_four
      real_sqrt_le_iff semiring_norm(75) semiring_norm(78) semiring_norm(85))

lemma sqrt_sum_squares_half_less:
  "x < u/2 \<Longrightarrow> y < u/2 \<Longrightarrow> 0 \<le> x \<Longrightarrow> 0 \<le> y \<Longrightarrow> sqrt (x\<^sup>2 + y\<^sup>2) < u"
  apply (rule real_sqrt_sum_squares_less)
   apply (auto simp add: abs_if field_simps)
   apply (rule le_less_trans [where y = "x*2"])
  using less_eq_real_def sqrt2_less_2 apply force
   apply assumption
  apply (rule le_less_trans [where y = "y*2"])
  using less_eq_real_def sqrt2_less_2 mult_le_cancel_left
   apply auto
  done

lemma LIMSEQ_root: "(\<lambda>n. root n n) \<longlonglongrightarrow> 1"
proof -
  define x where "x n = root n n - 1" for n
  have "x \<longlonglongrightarrow> sqrt 0"
  proof (rule tendsto_sandwich[OF _ _ tendsto_const])
    show "(\<lambda>x. sqrt (2 / x)) \<longlonglongrightarrow> sqrt 0"
      by (intro tendsto_intros tendsto_divide_0[OF tendsto_const] filterlim_mono[OF filterlim_real_sequentially])
         (simp_all add: at_infinity_eq_at_top_bot)
    have "x n \<le> sqrt (2 / real n)" if "2 < n" for n :: nat
    proof -
      have "1 + (real (n - 1) * n) / 2 * (x n)\<^sup>2 = 1 + of_nat (n choose 2) * (x n)\<^sup>2"
        by (auto simp add: choose_two field_char_0_class.of_nat_div mod_eq_0_iff_dvd)
      also have "\<dots> \<le> (\<Sum>k\<in>{0, 2}. of_nat (n choose k) * x n^k)"
        by (simp add: x_def)
      also have "\<dots> \<le> (\<Sum>k\<le>n. of_nat (n choose k) * x n^k)"
        using \<open>2 < n\<close>
        by (intro sum_mono2) (auto intro!: mult_nonneg_nonneg zero_le_power simp: x_def le_diff_eq)
      also have "\<dots> = (x n + 1) ^ n"
        by (simp add: binomial_ring)
      also have "\<dots> = n"
        using \<open>2 < n\<close> by (simp add: x_def)
      finally have "real (n - 1) * (real n / 2 * (x n)\<^sup>2) \<le> real (n - 1) * 1"
        by simp
      then have "(x n)\<^sup>2 \<le> 2 / real n"
        using \<open>2 < n\<close> unfolding mult_le_cancel_left by (simp add: field_simps)
      from real_sqrt_le_mono[OF this] show ?thesis
        by simp
    qed
    then show "eventually (\<lambda>n. x n \<le> sqrt (2 / real n)) sequentially"
      by (auto intro!: exI[of _ 3] simp: eventually_sequentially)
    show "eventually (\<lambda>n. sqrt 0 \<le> x n) sequentially"
      by (auto intro!: exI[of _ 1] simp: eventually_sequentially le_diff_eq x_def)
  qed
  from tendsto_add[OF this tendsto_const[of 1]] show ?thesis
    by (simp add: x_def)
qed

lemma LIMSEQ_root_const:
  assumes "0 < c"
  shows "(\<lambda>n. root n c) \<longlonglongrightarrow> 1"
proof -
  have ge_1: "(\<lambda>n. root n c) \<longlonglongrightarrow> 1" if "1 \<le> c" for c :: real
  proof -
    define x where "x n = root n c - 1" for n
    have "x \<longlonglongrightarrow> 0"
    proof (rule tendsto_sandwich[OF _ _ tendsto_const])
      show "(\<lambda>n. c / n) \<longlonglongrightarrow> 0"
        by (intro tendsto_divide_0[OF tendsto_const] filterlim_mono[OF filterlim_real_sequentially])
          (simp_all add: at_infinity_eq_at_top_bot)
      have "x n \<le> c / n" if "1 < n" for n :: nat
      proof -
        have "1 + x n * n = 1 + of_nat (n choose 1) * x n^1"
          by (simp add: choose_one)
        also have "\<dots> \<le> (\<Sum>k\<in>{0, 1}. of_nat (n choose k) * x n^k)"
          by (simp add: x_def)
        also have "\<dots> \<le> (\<Sum>k\<le>n. of_nat (n choose k) * x n^k)"
          using \<open>1 < n\<close> \<open>1 \<le> c\<close>
          by (intro sum_mono2)
            (auto intro!: mult_nonneg_nonneg zero_le_power simp: x_def le_diff_eq)
        also have "\<dots> = (x n + 1) ^ n"
          by (simp add: binomial_ring)
        also have "\<dots> = c"
          using \<open>1 < n\<close> \<open>1 \<le> c\<close> by (simp add: x_def)
        finally show ?thesis
          using \<open>1 \<le> c\<close> \<open>1 < n\<close> by (simp add: field_simps)
      qed
      then show "eventually (\<lambda>n. x n \<le> c / n) sequentially"
        by (auto intro!: exI[of _ 3] simp: eventually_sequentially)
      show "eventually (\<lambda>n. 0 \<le> x n) sequentially"
        using \<open>1 \<le> c\<close>
        by (auto intro!: exI[of _ 1] simp: eventually_sequentially le_diff_eq x_def)
    qed
    from tendsto_add[OF this tendsto_const[of 1]] show ?thesis
      by (simp add: x_def)
  qed
  show ?thesis
  proof (cases "1 \<le> c")
    case True
    with ge_1 show ?thesis by blast
  next
    case False
    with \<open>0 < c\<close> have "1 \<le> 1 / c"
      by simp
    then have "(\<lambda>n. 1 / root n (1 / c)) \<longlonglongrightarrow> 1 / 1"
      by (intro tendsto_divide tendsto_const ge_1 \<open>1 \<le> 1 / c\<close> one_neq_zero)
    then show ?thesis
      by (rule filterlim_cong[THEN iffD1, rotated 3])
        (auto intro!: exI[of _ 1] simp: eventually_sequentially real_root_divide)
  qed
qed

text "Legacy theorem names:"
lemmas real_root_pos2 = real_root_power_cancel
lemmas real_root_pos_pos = real_root_gt_zero [THEN order_less_imp_le]
lemmas real_root_pos_pos_le = real_root_ge_zero
lemmas real_sqrt_eq_zero_cancel_iff = real_sqrt_eq_0_iff

end


theory euclideanAlgorithm
  imports Complex_Main "HOL-Number_Theory.Number_Theory" GCD
begin

lemma gcd_mod:
  fixes a b :: nat
  shows "gcd a b = gcd b (a mod b)"
  by (metis gcd_red_nat)

lemma gcd_0:
  fixes a b :: nat
  shows "b = 0 ⟶ gcd a b = a" by auto

fun euclidean_algorithm :: "nat ⇒ nat ⇒ int * int" where
  "euclidean_algorithm x 0 = (x, 0)" |
  "euclidean_algorithm x y = euclidean_algorithm y (x mod y)"

lemma b_equal_at_0:
  fixes a b :: nat
  assumes "b = 0"
  shows "fst(euclidean_algorithm a b) = gcd a b"
proof -
    have "fst(euclidean_algorithm a b) = a" using assms by auto
    also have "gcd a b = a" using assms gcd_0 by auto
    thus "fst(euclidean_algorithm a b) = gcd a b"  by (simp add: calculation)
  qed

lemma a_equal_at_0:
  fixes a b :: nat
  assumes "a = 0"
  shows "fst(euclidean_algorithm a b) = gcd a b"
proof -
    have "euclidean_algorithm a b = euclidean_algorithm b 0"
      by (metis assms euclidean_algorithm.elims mod_0)
    also have "gcd a b = gcd b 0" using assms gcd_mod by auto
    thus "fst(euclidean_algorithm a b) = gcd a b"  by (simp add: calculation)
qed

theorem division_theorem:
  fixes a b :: nat
  assumes "(b ≠ 0)"
  shows "∃ (q :: nat) (r :: nat) . (a = q * b + r) ∧ (r < b)"
proof -
  have "a = nat(a div b) * b + a mod b" by auto
  thus ?thesis
    using assms mod_less_divisor by blast
qed

theorem euclidean_algorithm_validity:
  fixes a b :: nat
  assumes "a ≥ b ∧ a ≠ 0 ∧ b ≠ 0"
  shows "fst(euclidean_algorithm a b) = gcd a b"
proof (induct "a + b" arbitrary: a b rule: less_induct)
  fix a b :: nat
  case less
  then have IH: "∀ aa bb. aa + bb < a + b ⟶ fst(euclidean_algorithm aa bb) = gcd aa bb" by simp
  thus ?case
  proof cases
    assume nonZeros: "b ≠ 0 ∧ a ≠ 0"
    show ?thesis
    proof cases
      assume asm: "a ≥ b"
      have gcdRule: "gcd a b = gcd b (a mod b)" using gcd_mod by auto
      have euclidRule: "euclidean_algorithm a b = euclidean_algorithm b (a mod b)"
        by (metis euclidean_algorithm.elims mod_0 mod_by_0)
      have step1: "a ≥ b" using asm by auto
      have step2: "a mod b < b"
        using nonZeros by auto
      have lessThan: "b + (a mod b) < a + b" using step1 step2 by linarith
      thus ?thesis
        using IH euclidRule gcd_red_nat by auto
    next
      assume asm: "¬ a ≥ b"
      hence "a < b" by auto
      have gcdRule: "gcd b a = gcd a (b mod a)" using gcd_mod by auto
      have euclidRule: "euclidean_algorithm b a = euclidean_algorithm a (b mod a)"
        by (metis euclidean_algorithm.elims mod_0 mod_by_0)
      have step1: "b > a" using asm by auto
      have step2: "b mod a < a"
        using nonZeros by auto
      have lessThan: "a + (b mod a) < a + b" using step1 step2 by linarith
      thus ?thesis
        by (metis Divides.mod_less IH euclidRule euclidean_algorithm.elims gcd.commute gcdRule nonZeros step1)
    qed
  next
    assume "¬ (b ≠ 0 ∧ a ≠ 0)"
    hence "b = 0 ∨ a = 0" by auto
    thus ?thesis using a_equal_at_0 b_equal_at_0 by auto
  qed
qed

end


(*  Title: HOL/ex/Birthday_Paradox.thy
    Author: Lukas Bulwahn, TU Muenchen, 2007
*)

section \<open>A Formulation of the Birthday Paradox\<close>

theory Birthday_Paradox
imports Main "~~/src/HOL/Binomial" "~~/src/HOL/Library/FuncSet"
begin

section \<open>Cardinality\<close>

lemma card_product_dependent:
  assumes "finite S"
  assumes "\<forall>x \<in> S. finite (T x)"
  shows "card {(x, y). x \<in> S \<and> y \<in> T x} = (\<Sum>x \<in> S. card (T x))"
  using card_SigmaI[OF assms, symmetric] by (auto intro!: arg_cong[where f=card] simp add: Sigma_def)

lemma card_extensional_funcset_inj_on:
  assumes "finite S" "finite T" "card S \<le> card T"
  shows "card {f \<in> extensional_funcset S T. inj_on f S} = fact (card T) div (fact (card T - card S))"
using assms
proof (induct S arbitrary: T rule: finite_induct)
  case empty
  from this show ?case by (simp add: Collect_conv_if PiE_empty_domain)
next
  case (insert x S)
  { fix x
    from \<open>finite T\<close> have "finite (T - {x})" by auto
    from \<open>finite S\<close> this have "finite (extensional_funcset S (T - {x}))"
      by (rule finite_PiE)
    moreover
    have "{f : extensional_funcset S (T - {x}). inj_on f S} \<subseteq> (extensional_funcset S (T - {x}))" by auto
    ultimately have "finite {f : extensional_funcset S (T - {x}). inj_on f S}"
      by (auto intro: finite_subset)
  } note finite_delete = this
  from insert have hyps: "\<forall>y \<in> T. card ({g. g \<in> extensional_funcset S (T - {y}) \<and> inj_on g S}) = fact (card T - 1) div fact ((card T - 1) - card S)"(is "\<forall> _ \<in> T. _ = ?k") by auto
  from extensional_funcset_extend_domain_inj_on_eq[OF \<open>x \<notin> S\<close>]
  have "card {f. f : extensional_funcset (insert x S) T & inj_on f (insert x S)} =
    card ((%(y, g). g(x := y)) ` {(y, g). y : T & g : extensional_funcset S (T - {y}) & inj_on g S})"
    by metis
  also from extensional_funcset_extend_domain_inj_onI[OF \<open>x \<notin> S\<close>, of T] have "... =  card {(y, g). y : T & g : extensional_funcset S (T - {y}) & inj_on g S}"
    by (simp add: card_image)
  also have "card {(y, g). y \<in> T \<and> g \<in> extensional_funcset S (T - {y}) \<and> inj_on g S} =
    card {(y, g). y \<in> T \<and> g \<in> {f \<in> extensional_funcset S (T - {y}). inj_on f S}}" by auto
  also from \<open>finite T\<close> finite_delete have "... = (\<Sum>y \<in> T. card {g. g \<in> extensional_funcset S (T - {y}) \<and>  inj_on g S})"
    by (subst card_product_dependent) auto
  also from hyps have "... = (card T) * ?k"
    by auto
  also have "... = card T * fact (card T - 1) div fact (card T - card (insert x S))"
    using insert unfolding div_mult1_eq[of "card T" "fact (card T - 1)"]
    by (simp add: fact_mod)
  also have "... = fact (card T) div fact (card T - card (insert x S))"
    using insert by (simp add: fact_reduce[of "card T"])
  finally show ?case .
qed

lemma card_extensional_funcset_not_inj_on:
  assumes "finite S" "finite T" "card S \<le> card T"
  shows "card {f \<in> extensional_funcset S T. \<not> inj_on f S} = (card T) ^ (card S) - (fact (card T)) div (fact (card T - card S))"
proof -
  have subset: "{f : extensional_funcset S T. inj_on f S} <= extensional_funcset S T" by auto
  from finite_subset[OF subset] assms have finite: "finite {f : extensional_funcset S T. inj_on f S}"
    by (auto intro!: finite_PiE)
  have "{f \<in> extensional_funcset S T. \<not> inj_on f S} = extensional_funcset S T - {f \<in> extensional_funcset S T. inj_on f S}" by auto
  from assms this finite subset show ?thesis
    by (simp add: card_Diff_subset card_PiE card_extensional_funcset_inj_on prod_constant)
qed

lemma prod_upto_nat_unfold:
  "prod f {m..(n::nat)} = (if n < m then 1 else (if n = 0 then f 0 else f n * prod f {m..(n - 1)}))"
  by auto (auto simp add: gr0_conv_Suc atLeastAtMostSuc_conv)

section \<open>Birthday paradox\<close>

lemma birthday_paradox:
  assumes "card S = 23" "card T = 365"
  shows "2 * card {f \<in> extensional_funcset S T. \<not> inj_on f S} \<ge> card (extensional_funcset S T)"
proof -
  from \<open>card S = 23\<close> \<open>card T = 365\<close> have "finite S" "finite T" "card S <= card T" by (auto intro: card_ge_0_finite)
  from assms show ?thesis
    using card_PiE[OF \<open>finite S\<close>, of "\<lambda>i. T"] \<open>finite S\<close>
      card_extensional_funcset_not_inj_on[OF \<open>finite S\<close> \<open>finite T\<close> \<open>card S <= card T\<close>]
    by (simp add: fact_div_fact prod_upto_nat_unfold prod_constant)
qed

end


(*
    $Id: ex.thy,v 1.2 2004/11/23 15:14:34 webertj Exp $
    Author: Martin Strecker
*)

header {* Summation, Flattening *}

(*<*) theory ex imports Main begin (*>*)

text{* Define a function @{text sum}, which computes the sum of
elements of a list of natural numbers. *}

(*<*) consts (*>*)
  sum :: "nat list \<Rightarrow> nat"

text{* Then, define a function @{text flatten} which flattens a list
of lists by appending the member lists. *}

(*<*) consts (*>*)
  flatten :: "'a list list \<Rightarrow> 'a list"

text{* Test your functions by applying them to the following example lists: *}

lemma "sum [2::nat, 4, 8] = x"
(*<*) oops (*>*)

lemma "flatten [[2::nat, 3], [4, 5], [7, 9]] = x"
(*<*) oops (*>*)

text{* Prove the following statements, or give a counterexample: *}

lemma "length (flatten xs) = sum (map length xs)"
(*<*) oops (*>*)

lemma sum_append: "sum (xs @ ys) = sum xs + sum ys"
(*<*) oops (*>*)

lemma flatten_append: "flatten (xs @ ys) = flatten xs @ flatten ys"
(*<*) oops (*>*)

lemma "flatten (map rev (rev xs)) = rev (flatten xs)"
(*<*) oops (*>*)

lemma "flatten (rev (map rev xs)) = rev (flatten xs)"
(*<*) oops (*>*)

lemma "list_all (list_all P) xs = list_all P (flatten xs)"
(*<*) oops (*>*)

lemma "flatten (rev xs) = flatten xs"
(*<*) oops (*>*)

lemma "sum (rev xs) = sum xs"
(*<*) oops (*>*)

text{* Find a (non-trivial) predicate @{text P} which satisfies *}

lemma "list_all P xs \<longrightarrow> length xs \<le> sum xs"
(*<*) oops (*>*)

text{* Define, by means of primitive recursion, a function @{text
list_exists} which checks whether an element satisfying a given property
is contained in the list: *}

(*<*) consts (*>*)
  list_exists :: "('a \<Rightarrow> bool) \<Rightarrow> ('a list \<Rightarrow> bool)"

text{* Test your function on the following examples: *}

lemma "list_exists (\<lambda> n. n < 3) [4::nat, 3, 7] = b"
(*<*) oops (*>*)

lemma "list_exists (\<lambda> n. n < 4) [4::nat, 3, 7] = b"
(*<*) oops (*>*)

text{* Prove the following statements: *}

lemma list_exists_append:
  "list_exists P (xs @ ys) = (list_exists P xs \<or> list_exists P ys)"
(*<*) oops (*>*)

lemma "list_exists (list_exists P) xs = list_exists P (flatten xs)"
(*<*) oops (*>*)

text{* You could have defined @{text list_exists} only with the aid of
@{text list_all}.  Do this now, i.e. define a function @{text
list_exists2} and show that it is equivalent to @{text list_exists}. *}

(*<*) end (*>*)