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

text{*
\section*{Chapter 3}

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

fun optimal :: "aexp \<Rightarrow> bool" where
"optimal (N i) = True" |
"optimal (V v) = True" |
"optimal (Plus (N i) (N j)) = False" |
"optimal (Plus a1 a2) = ((optimal a1) \<or> (optimal a2))"

value "optimal (N 0)"
value "optimal (Plus (N 0) (N 1))"

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

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

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

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

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

fun sumN :: "aexp \<Rightarrow> int" where
"sumN (N n) = n" |
"sumN (V x) = 0" |
"sumN (Plus a1 a2) = sumN a1 + sumN a2"

value "sumN (Plus (N 1) (Plus (V x) (N 2)))"

fun zeroN :: "aexp \<Rightarrow> aexp" where
"zeroN (N n) = (N 0)" |
"zeroN (V x) = (V x)" |
"zeroN (Plus a1 a2) = (Plus (zeroN a1) (zeroN a2))"

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

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

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

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

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

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

text{*
\endexercise

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

fun subst :: "vname \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"subst x a (N n) = N n" |
"subst x a (V y) = (if x = y then a else V y)" |
"subst x a (Plus a1 a2) = Plus (subst x a a1) (subst x a a2)"

value "subst ''x'' (N 3) (Plus (V ''x'' ) (V ''y''))"

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

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

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

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

text{*
\endexercise

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

text{*
\endexercise

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

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

text{*
\endexercise

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

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

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

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

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

definition Le :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"Le a1 a2 = Not (Less a2 a1)"

definition Eq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"Eq a1 a2 = And (Le a1 a2) (Le a2 a1)"

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

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

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

text{*
\endexercise

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

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

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

fun ifval :: "ifexp \<Rightarrow> state \<Rightarrow> bool" where
"ifval (Bc2 v) s = v" |
"ifval (If c b1 b2) s = (if (ifval c s) then (ifval b1 s) else (ifval b2 s))" |
"ifval (Less2 a1 a2) s = ((aval a1 s) < (aval a2 s))"

text{* Then define two translation functions *}

value "true"
value "True"

fun b2ifexp :: "bexp \<Rightarrow> ifexp" where
"b2ifexp (Bc v) = (Bc2 v)" |
"b2ifexp (Not b) = (If (b2ifexp b) (Bc2 False) (Bc2 True))" |
"b2ifexp (And b1 b2) = (If (b2ifexp b1) (b2ifexp b2) (Bc2 False))" |
"b2ifexp (Less a1 a2) = (Less2 a1 a2)"

fun if2bexp :: "ifexp \<Rightarrow> bexp" where
"if2bexp (Bc2 v) = (Bc v)" |
"if2bexp (If c b1 b2) = (Not (And (Not (And (if2bexp c) (if2bexp b1)))
                                  (Not (And (Not (if2bexp c)) (if2bexp b2)))))" |
"if2bexp (Less2 a1 a2) = (Less a1 a2)"

text{* and prove their correctness: *}

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{*
\endexercise

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

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

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

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

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

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

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

fun nnf :: "pbexp \<Rightarrow> pbexp" where
"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{*
Prove that @{const nnf} does what it is supposed to do:
*}

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{*
An expression is in DNF (disjunctive normal form) if it is in NNF
and if no @{const OR} occurs below an @{const AND}. Define a corresponding
test:
*}

fun no_or :: "pbexp \<Rightarrow> bool" where
"no_or (VAR x) = True" |
"no_or (NOT b) = no_or b" |
"no_or (OR b1 b2) = False" |
"no_or (AND b1 b2) = (no_or b1 \<and> no_or b2)"

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

lemma is_dnf_nnf: "is_dnf b1 \<Longrightarrow> is_nnf b1"
apply(induction b1 rule: is_dnf.induct)
apply(auto)
done

lemma is_dnf_not_no_or: "is_dnf (NOT v) \<Longrightarrow> no_or v"
apply(induction v rule: is_dnf.induct)
apply(auto)
done

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

fun dist_AND :: "pbexp \<Rightarrow> pbexp \<Rightarrow> pbexp" where
(*"dist_AND (OR a1 a2) (OR b1 b2) = (OR (OR (dist_AND a1 b1) (dist_AND a1 b2)) (OR (dist_AND a2 b1) (dist_AND a2 b2)))" |*)
"dist_AND a (OR b1 b2) = (OR (dist_AND a b1) (dist_AND a b2))" |
"dist_AND (OR a1 a2) b = (OR (dist_AND a1 b) (dist_AND a2 b))" |
"dist_AND b1 b2 = (AND b1 b2)"

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

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 [simp]:"is_dnf b2 \<Longrightarrow>
       is_nnf b1 \<Longrightarrow> no_or b1 \<Longrightarrow> is_nnf b2a \<Longrightarrow> no_or b2a \<Longrightarrow> is_dnf (dist_AND (AND b1 b2a) b2)"
apply(induction b2)
apply(auto simp add: is_dnf_nnf is_dnf_not_no_or)
done

lemma [simp]:"is_dnf (dist_AND b1 b2) \<Longrightarrow>
       is_dnf (dist_AND b2a b2) \<Longrightarrow>
       is_dnf b2 \<Longrightarrow> is_dnf b1 \<Longrightarrow> is_dnf b2a \<Longrightarrow> is_dnf (dist_AND (OR b1 b2a) b2)"
apply(induction b2)
apply(auto simp add: is_dnf_nnf is_dnf_not_no_or)
done

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

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

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

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

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

lemma not_is_dnf_if_nnf: "is_nnf (NOT b) \<Longrightarrow> is_dnf (NOT b)"
apply(induction 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 not_is_dnf_if_nnf)
done

text{*
\endexercise

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

text{*
\endexercise

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

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

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

type_synonym rstate = "reg \<Rightarrow> val"

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> rstate \<Rightarrow> rstate" where
"exec1 (LDI i r) s rs = rs(r := i)" |
"exec1 (LD x r) s rs = rs(r := s(x))" |
"exec1 (ADD r1 r2) s rs = rs(r1 := rs(r1) + rs(r2))"

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

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

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

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

fun comp :: "aexp \<Rightarrow> reg \<Rightarrow> instr list" where
"comp (N n) r = [LDI n r]" |
"comp (V v) r = [LD v r]" |
"comp (Plus a1 a2) r = (comp a1 r) @ (comp a2 (r + 1)) @ [ADD r (r + 1)]"

lemma exec_execn:"exec is1 s rs r = (let rs1 = execn is1 s rs in rs1(r))"
apply(induction is1 arbitrary: rs)
apply(auto)
done

lemma execn_dist_append:"(execn (is1 @ is2) s rs) = (execn is2 s (execn is1 s rs))"
apply(induction is1 arbitrary: rs)
apply(auto)
done

lemma execn_comp_append:"(execn ((comp a r) @ is2) s rs) = (execn is2 s (execn (comp a r) s rs))"
apply(auto simp add:execn_dist_append)
done

lemma comp_left_rs_not_changed:"r1 > r \<Longrightarrow> execn (comp a r1) s rs r = rs(r)"
apply(induction a arbitrary: r r1 rs)
apply(auto simp add:execn_dist_append)
done

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

text{*
\endexercise

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

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

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

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

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

fun comp0 :: "aexp \<Rightarrow> reg \<Rightarrow> instr0 list" where
"comp0 (N n) r = [LDI0 n, MV0 r]" |
"comp0 (V v) r = [LD0 v, MV0 r]" |
"comp0 (Plus a1 a2) r = (comp0 a1 (r + 1)) @ (comp0 a2 (r + 2)) @ [ADD0 (r + 1), MV0 r]"

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

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

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

lemma exec0_exec0n[simp]:"exec0 is1 s rs r = (let rs1 = exec0n is1 s rs in rs1(r))"
apply(induction is1 arbitrary: rs)
apply(auto)
done

lemma exec0n_dist_append:"(exec0n (is1 @ is2) s rs) = (exec0n is2 s (exec0n is1 s rs))"
apply(induction is1 arbitrary: rs)
apply(auto)
done

lemma exec0n_comp0_append:"(exec0n ((comp0 a r) @ is2) s rs) = (exec0n is2 s (exec0n (comp0 a r) s rs))"
apply(auto simp add:exec0n_dist_append)
done

lemma comp0_left_rs_not_changed:"r1 > r \<and> r > 0 \<Longrightarrow> exec0n (comp0 a r1) s rs r = rs(r)"
apply(induction a arbitrary: r r1 rs)
apply(auto simp add:exec0n_dist_append)
done

lemma exec0_comp0_rsr_is_equal_rs0:"exec0 (comp0 a r) s rs r = exec0 (comp0 a r) s rs 0"
apply(induction a arbitrary: r rs)
apply(auto simp add:exec0n_dist_append)
done

lemma exec0n_comp0_rs0_is_equal_rsr:"exec0n (comp0 a r) s rs 0 = exec0n (comp0 a r) s rs r"
apply(induction a arbitrary: r rs)
apply(auto simp add:exec0n_dist_append)
done

lemma exec0n_cond:"(exec0n (comp0 a2 r2) s (exec0n (comp0 a1 r1) s rs1) 0 = exec0n (comp0 a2 r2) s (exec0n (comp0 a1 r1) s rs2) 0) \<and>
       (exec0n (comp0 a1 r1) s rs1 r1 = exec0n (comp0 a1 r1) s rs2 r1) \<Longrightarrow>
       exec0n (comp0 a2 r2) s (exec0n (comp0 a1 r1) s rs1) 0 +
       exec0n (comp0 a1 r1) s rs1 r1 =
       exec0n (comp0 a2 r2) s (exec0n (comp0 a1 r1) s rs2) 0 +
       exec0n (comp0 a1 r1) s rs2 r1"
apply(auto)
done

lemma exec0n_rs1_arbitrary: "exec0n (comp0 a r) s rs1 r = exec0n (comp0 a r) s rs2 r"
apply(induction a arbitrary: r rs1 rs2)
apply(auto simp add:exec0n_dist_append exec0n_comp0_append comp0_left_rs_not_changed)
apply(subst exec0n_cond)
apply(auto simp add: exec0n_comp0_rs0_is_equal_rsr)
done

theorem "exec0 (comp0 a r) s rs 0 = aval a s"
apply(induction a arbitrary: r rs)
apply(auto simp add:exec0n_dist_append exec0n_comp0_append comp0_left_rs_not_changed)
apply(auto simp add:exec0n_comp0_rs0_is_equal_rsr)
done

text{*
\endexercise
*}

end


(*
  File:    Angles.thy
  Author:  Manuel Eberl <eberlm@in.tum.de>

  Definition of angles between vectors and between three points.
*)

section \<open>Definition of angles\<close>
theory Angles
imports
  "HOL-Analysis.Multivariate_Analysis"
begin

lemma collinear_translate_iff: "collinear (((+) a) ` A) \<longleftrightarrow> collinear A"
  by (auto simp: collinear_def)

definition vangle where
  "vangle u v = (if u = 0 \<or> v = 0 then pi / 2 else arccos (u \<bullet> v / (norm u * norm v)))"

definition angle where
  "angle a b c = vangle (a - b) (c - b)"

lemma angle_altdef: "angle a b c = arccos ((a - b) \<bullet> (c - b) / (dist a b * dist c b))"
  by (simp add: angle_def vangle_def dist_norm)

lemma vangle_0_left [simp]: "vangle 0 v = pi / 2"
  and vangle_0_right [simp]: "vangle u 0 = pi / 2"
  by (simp_all add: vangle_def)

lemma vangle_refl [simp]: "u \<noteq> 0 \<Longrightarrow> vangle u u = 0"
  by (simp add: vangle_def dot_square_norm power2_eq_square)

lemma angle_refl [simp]: "angle a a b = pi / 2" "angle a b b = pi / 2"
  by (simp_all add: angle_def)

lemma angle_refl_mid [simp]: "a \<noteq> b \<Longrightarrow> angle a b a = 0"
  by (simp add: angle_def)

lemma cos_vangle: "cos (vangle u v) = u \<bullet> v / (norm u * norm v)"
  unfolding vangle_def using Cauchy_Schwarz_ineq2[of u v] by (auto simp: field_simps)

lemma cos_angle: "cos (angle a b c) = (a - b) \<bullet> (c - b) / (dist a b * dist c b)"
  by (simp add: angle_def cos_vangle dist_norm)

lemma inner_conv_angle: "(a - b) \<bullet> (c - b) = dist a b * dist c b * cos (angle a b c)"
  by (simp add: cos_angle)

lemma vangle_commute: "vangle u v = vangle v u"
  by (simp add: vangle_def inner_commute mult.commute)

lemma vangle_nonneg: "vangle u v \<ge> 0" and vangle_le_pi: "vangle u v \<le> pi"
  using Cauchy_Schwarz_ineq2[of u v]
  by (auto simp: vangle_def field_simps intro!: arccos_lbound arccos_ubound)

lemmas vangle_bounds = vangle_nonneg vangle_le_pi

lemma angle_nonneg: "angle a b c \<ge> 0" and angle_le_pi: "angle a b c \<le> pi"
  using vangle_bounds unfolding angle_def by blast+

lemmas angle_bounds = angle_nonneg angle_le_pi

lemma sin_vangle_nonneg: "sin (vangle u v) \<ge> 0"
  using vangle_bounds by (rule sin_ge_zero)

lemma sin_angle_nonneg: "sin (angle a b c) \<ge> 0"
  using angle_bounds by (rule sin_ge_zero)

lemma vangle_eq_0D:
  assumes "vangle u v = 0"
  shows   "norm u *\<^sub>R v = norm v *\<^sub>R u"
proof -
  from assms have "u \<bullet> v = norm u * norm v"
    using arccos_eq_iff[of "(u \<bullet> v) / (norm u * norm v)" 1] Cauchy_Schwarz_ineq2[of u v]
    by (fastforce simp: vangle_def split: if_split_asm)
  thus ?thesis by (subst (asm) norm_cauchy_schwarz_eq) simp_all
qed

lemma vangle_eq_piD:
  assumes "vangle u v = pi"
  shows   "norm u *\<^sub>R v + norm v *\<^sub>R u = 0"
proof -
  from assms have "(-u) \<bullet> v = norm (-u) * norm v"
    using arccos_eq_iff[of "(u \<bullet> v) / (norm u * norm v)" "-1"] Cauchy_Schwarz_ineq2[of u v]
    by (simp add: field_simps vangle_def split: if_split_asm)
  thus ?thesis by (subst (asm) norm_cauchy_schwarz_eq) simp_all
qed

lemma dist_triangle_eq:
  fixes a b c :: "'a :: real_inner"
  shows "(dist a c = dist a b + dist b c) \<longleftrightarrow> dist a b *\<^sub>R (c - b) + dist b c *\<^sub>R (a - b) = 0"
  using norm_triangle_eq[of "b - a" "c - b"]
  by (simp add: dist_norm norm_minus_commute algebra_simps)

lemma angle_eq_pi_imp_dist_additive:
  assumes "angle a b c = pi"
  shows   "dist a c = dist a b + dist b c"
  using vangle_eq_piD[OF assms[unfolded angle_def]]
  by (subst dist_triangle_eq) (simp add: dist_norm norm_minus_commute)

lemma orthogonal_iff_vangle: "orthogonal u v \<longleftrightarrow> vangle u v = pi / 2"
  using arccos_eq_iff[of "u \<bullet> v / (norm u * norm v)" 0] Cauchy_Schwarz_ineq2[of u v]
  by (auto simp: vangle_def orthogonal_def)

lemma cos_minus1_imp_pi:
  assumes "cos x = -1" "x \<ge> 0" "x < 3 * pi"
  shows   "x = pi"
proof -
  have "cos (x - pi) = 1" by (simp add: assms)
  then obtain n :: int where n: "of_int n = (x / pi - 1) / 2"
    by (subst (asm) cos_one_2pi_int) (auto simp: field_simps)
  also from assms have "\<dots> \<in> {-1<..<1}" by (auto simp: field_simps)
  finally have "n = 0" by simp
  with n show ?thesis by simp
qed

lemma vangle_eqI:
  assumes "u \<noteq> 0" "v \<noteq> 0" "w \<noteq> 0" "x \<noteq> 0"
  assumes "(u \<bullet> v) * norm w * norm x = (w \<bullet> x) * norm u * norm v"
  shows   "vangle u v = vangle w x"
  using assms Cauchy_Schwarz_ineq2[of u v] Cauchy_Schwarz_ineq2[of w x]
  unfolding vangle_def by (auto simp: arccos_eq_iff field_simps)

lemma cos_vangle_eqD: "cos (vangle u v) = cos (vangle w x) \<Longrightarrow> vangle u v = vangle w x"
  by (rule cos_inj_pi) (simp_all add: vangle_bounds)

lemma cos_angle_eqD: "cos (angle a b c) = cos (angle d e f) \<Longrightarrow> angle a b c = angle d e f"
  unfolding angle_def by (rule cos_vangle_eqD)

lemma sin_vangle_zero_iff: "sin (vangle u v) = 0 \<longleftrightarrow> vangle u v \<in> {0, pi}"
proof
  assume "sin (vangle u v) = 0"
  then obtain n :: int where n: "of_int n = vangle u v / pi"
    by (subst (asm) sin_zero_iff_int2) auto
  also have "\<dots> \<in> {0..1}" using vangle_bounds by (auto simp: field_simps)
  finally have "n \<in> {0,1}" by auto
  thus "vangle u v \<in> {0,pi}" using n by (auto simp: field_simps)
qed auto

lemma sin_angle_zero_iff: "sin (angle a b c) = 0 \<longleftrightarrow> angle a b c \<in> {0, pi}"
  unfolding angle_def by (simp only: sin_vangle_zero_iff)

lemma vangle_collinear: "vangle u v \<in> {0, pi} \<Longrightarrow> collinear {0, u, v}"
apply (subst norm_cauchy_schwarz_equal [symmetric])
apply (subst norm_cauchy_schwarz_abs_eq)
apply (auto dest!: vangle_eq_0D vangle_eq_piD simp: eq_neg_iff_add_eq_0)
done

lemma angle_collinear: "angle a b c \<in> {0, pi} \<Longrightarrow> collinear {a, b, c}"
apply (unfold angle_def, drule vangle_collinear)
apply (subst collinear_translate_iff[symmetric, of _ "-b"])
apply (auto simp: insert_commute)
done

lemma not_collinear_vangle: "\<not>collinear {0,u,v} \<Longrightarrow> vangle u v \<in> {0<..<pi}"
  using vangle_bounds[of u v] vangle_collinear[of u v]
  by (cases "vangle u v = 0 \<or> vangle u v = pi") auto

lemma not_collinear_angle: "\<not>collinear {a,b,c} \<Longrightarrow> angle a b c \<in> {0<..<pi}"
  using angle_bounds[of a b c] angle_collinear[of a b c]
  by (cases "angle a b c = 0 \<or> angle a b c = pi") auto

subsection\<open>Contributions from Lukas Bulwahn\<close>

lemma vangle_scales:
  assumes "0 < c"
  shows "vangle (c *\<^sub>R v\<^sub>1) v\<^sub>2 = vangle v\<^sub>1 v\<^sub>2"
using assms unfolding vangle_def by auto

lemma vangle_inverse:
  "vangle (- v\<^sub>1) v\<^sub>2 = pi - vangle v\<^sub>1 v\<^sub>2"
proof -
  have "\<bar>v\<^sub>1 \<bullet> v\<^sub>2 / (norm v\<^sub>1 * norm v\<^sub>2)\<bar> \<le> 1"
  proof cases
    assume "v\<^sub>1 \<noteq> 0 \<and> v\<^sub>2 \<noteq> 0"
    from this show ?thesis by (simp add: Cauchy_Schwarz_ineq2)
  next
    assume "\<not> (v\<^sub>1 \<noteq> 0 \<and> v\<^sub>2 \<noteq> 0)"
    from this show ?thesis by auto
  qed
  from this show ?thesis
    unfolding vangle_def
    by (simp add: arccos_minus_abs)
qed

lemma orthogonal_iff_angle:
  shows "orthogonal (A - B) (C - B) \<longleftrightarrow> angle A B C = pi / 2"
unfolding angle_def by (auto simp only: orthogonal_iff_vangle)

lemma angle_inverse:
  assumes "between (A, C) B"
  assumes "A \<noteq> B" "B \<noteq> C"
  shows "angle A B D = pi - angle C B D"
proof -
  from \<open>between (A, C) B\<close> obtain u where u: "u \<ge> 0" "u \<le> 1"
    and X: "B = u *\<^sub>R A + (1 - u) *\<^sub>R C"
    by (metis add.commute betweenE between_commute)
  from \<open>A \<noteq> B\<close> \<open>B \<noteq> C\<close> X have "u \<noteq> 0" "u \<noteq> 1" by auto
  have "0 < ((1 - u) / u)"
    using \<open>u \<noteq> 0\<close> \<open>u \<noteq> 1\<close> \<open>u \<ge> 0\<close> \<open>u \<le> 1\<close> by simp
  from X have "A - B = - (1 - u) *\<^sub>R (C - A)"
    by (simp add: real_vector.scale_right_diff_distrib real_vector.scale_left_diff_distrib)
  moreover from X have "C - B = u *\<^sub>R (C - A)"
    by (simp add: scaleR_diff_left real_vector.scale_right_diff_distrib)
  ultimately have "A - B = - (((1 - u) / u) *\<^sub>R (C - B))"
    using \<open>u \<noteq> 0\<close> by simp (metis minus_diff_eq real_vector.scale_minus_left)
  from this have "vangle (A - B) (D - B) = pi - vangle (C - B) (D - B)"
    using \<open>0 < (1 - u) / u\<close> by (simp add: vangle_inverse vangle_scales)
  from this show ?thesis
    unfolding angle_def by simp
qed

lemma strictly_between_implies_angle_eq_pi:
  assumes "between (A, C) B"
  assumes "A \<noteq> B" "B \<noteq> C"
  shows "angle A B C = pi"
proof -
  from \<open>between (A, C) B\<close> obtain u where u: "u \<ge> 0" "u \<le> 1"
    and X: "B = u *\<^sub>R A + (1 - u) *\<^sub>R C"
    by (metis add.commute betweenE between_commute)
  from \<open>A \<noteq> B\<close> \<open>B \<noteq> C\<close> X have "u \<noteq> 0" "u \<noteq> 1" by auto
  from \<open>A \<noteq> B\<close> \<open>B \<noteq> C\<close> \<open>between (A, C) B\<close> have "A \<noteq> C" by auto
  from X have "A - B = - (1 - u) *\<^sub>R (C - A)"
    by (simp add: real_vector.scale_right_diff_distrib real_vector.scale_left_diff_distrib)
  moreover from this have "dist A B = norm ((1 - u) *\<^sub>R (C - A))"
    using \<open>u \<ge> 0\<close> \<open>u \<le> 1\<close> by (simp add: dist_norm)
  moreover from X have "C - B = u *\<^sub>R (C - A)"
    by (simp add: scaleR_diff_left real_vector.scale_right_diff_distrib)
  moreover from this have "dist C B = norm (u *\<^sub>R (C - A))"
    by (simp add: dist_norm)
  ultimately have "(A - B) \<bullet> (C - B) / (dist A B * dist C B) = u * (u - 1) / (\<bar>1 - u\<bar> * \<bar>u\<bar>)"
    using \<open>A \<noteq> C\<close> by (simp add: dot_square_norm power2_eq_square)
  also have "\<dots> = - 1"
    using \<open>u \<noteq> 0\<close> \<open>u \<noteq> 1\<close> \<open>u \<ge> 0\<close> \<open>u \<le> 1\<close> by (simp add: divide_eq_minus_1_iff)
  finally show ?thesis
    unfolding angle_altdef by simp
qed

end


(*
Auction Theory Toolbox (http://formare.github.io/auctions/)

Authors:
* Marco B. Caminati http://caminati.co.nr
* Manfred Kerber <mnfrd.krbr@gmail.com>
* Christoph Lange <math.semantic.web@gmail.com>
* Colin Rowat <c.rowat@bham.ac.uk>

Dually licenced under
* Creative Commons Attribution (CC-BY) 3.0
* ISC License (1-clause BSD License)
See LICENSE file for details
(Rationale for this dual licence: http://arxiv.org/abs/1107.3212)
*)

section \<open>Locus where a function or a list (of linord type) attains its maximum value\<close>

theory Argmax
imports Main

begin

text \<open>Structural induction is used in proofs on lists.\<close>
lemma structInduct: assumes "P []" and "\<forall>x xs. P (xs) \<longrightarrow> P (x#xs)"
                    shows "P l"
      using assms list_nonempty_induct by (metis)

text \<open>the subset of elements of a set where a function reaches its maximum\<close>
fun argmax :: "('a \<Rightarrow> 'b::linorder) \<Rightarrow> 'a set \<Rightarrow> 'a set"
    where "argmax f A = { x \<in> A . f x = Max (f ` A) }"

(* For reasons we do not understand we have to duplicate the definition as a lemma
   in order to prove lm16 in CombinatorialAuctions.thy. *)
lemma argmaxLemma: "argmax f A = { x \<in> A . f x = Max (f ` A) }"
  by simp

lemma maxLemma:
  assumes "x \<in> X" "finite X"
  shows "Max (f`X) >= f x"
  (is "?L >= ?R") using assms
  by (metis (hide_lams, no_types) Max.coboundedI finite_imageI image_eqI)

lemma lm01:
  "argmax f A = A \<inter> f -` {Max (f ` A)}"
  by force

lemma lm02:
  assumes "y \<in> f`A"
  shows "A \<inter> f -` {y} \<noteq> {}"
  using assms by blast

lemma argmaxEquivalence:
  assumes "\<forall>x\<in>X. f x = g x"
  shows "argmax f X = argmax g X"
  using assms argmaxLemma Collect_cong image_cong
  by (metis(no_types,lifting))

text \<open>The arg max of a function over a non-empty set is non-empty.\<close>
corollary argmax_non_empty_iff: assumes "finite X" "X \<noteq> {}"
                                shows "argmax f X \<noteq>{}"
                                using assms Max_in finite_imageI image_is_empty lm01 lm02
                                by (metis(no_types))

text \<open>The previous definition of argmax operates on sets. In the following we define a corresponding notion on lists. To this end, we start with defining a filter predicate and are looking for the elements of a list satisfying a given predicate;
but, rather than returning them directly, we return the (sorted) list of their indices.
This is done, in different ways, by @{term filterpositions} and @{term filterpositions2}.\<close>

(* Given a list l, filterpositions yields the indices of its elements which satisfy a given pred P*)
definition filterpositions :: "('a => bool) => 'a list => nat list"
           where "filterpositions P l = map snd (filter (P o fst) (zip l (upt 0 (size l))))"
(* That is, you take the list [a0, a1, ..., an] pair with the indices [0, 1, ..., n], i.e., you get
   [(a0,0), (a1,1), ..., (an,n)] look where the predicate (P o fst) holds and return the list of the
   corresponding snd elements. *)

(* Alternative definition, making use of list comprehension. In the next line the type info is
   commented out, since the type inference can be left to Isabelle. *)
definition filterpositions2 (*  :: "('a => bool) => 'a list => nat list" *)
           where "filterpositions2 P l = [n. n \<leftarrow> [0..<size l], P (l!n)]"

definition maxpositions (*:: "'a::linorder list => nat list"*)
           where "maxpositions l = filterpositions2 (%x . x \<ge> Max (set l)) l"

lemma lm03: "maxpositions l = [n. n\<leftarrow>[0..<size l], l!n \<ge> Max(set l)]"
      unfolding maxpositions_def filterpositions2_def by fastforce

(* argmaxList takes a function and a list as arguments and looks for the positions of the elements at which the function applied to the list element is maximal, e.g.,
for the list [9, 3, 5, 9, 13] and the function `modulo 8', the function applied to the list would give the list [1, 3, 5, 1, 5], that is, argmaxList will return [2, 4]. *)
definition argmaxList (*:: "('a => ('b::linorder)) => 'a list => 'a list"*)
           where "argmaxList f l = map (nth l) (maxpositions (map f l))"

(* The following lemmas state some relationships between different representation such as map and list comprehension *)
lemma lm04: "[n . n <- l, P n] = [n . n <- l, n \<in> set l, P n]"
proof -
(*sledgehammer-generated proof.
  Commented out the first three lines (they look quite useless), making it more readable.
  assume "\<forall>v0. SMT2.fun_app uu__ v0 = (if P v0 then [v0] else [])"
  assume "\<forall>v0. SMT2.fun_app uua__ v0 = (if v0 \<in> set l then if P v0 then [v0] else [] else [])"
  obtain v3_0 :: "('a \<Rightarrow> 'a list) \<Rightarrow> 'a list \<Rightarrow> ('a \<Rightarrow> 'a list) \<Rightarrow> 'a" where *)
  have "map (\<lambda>uu. if P uu then [uu] else []) l =
    map (\<lambda>uu. if uu \<in> set l then if P uu then [uu] else [] else []) l" by simp
  thus "concat (map (\<lambda>n. if P n then [n] else []) l) =
    concat (map (\<lambda>n. if n \<in> set l then if P n then [n] else [] else []) l)" by presburger
qed

lemma lm05: "[n . n <- [0..<m], P n] = [n . n <- [0..<m], n \<in> set [0..<m], P n]"
      using lm04 by fast
 (* sledgehammer suggested:  concat_map_singleton map_ident  map_ext by smt*)

lemma lm06: fixes f m P
            shows "(map f [n . n <- [0..<m], P n]) = [ f n . n <- [0..<m], P n]"
      by (induct m) auto

(* Base case stating the property for the empty list *)
lemma map_commutes_a: "[f n . n <- [], Q (f n)] = [x <- (map f []). Q x]"
      by simp

(* Step case where the element x is added to the list xs *)
lemma map_commutes_b: "\<forall> x xs. ([f n . n <- xs,     Q (f n)] = [x <- (map f xs).     Q x] \<longrightarrow>
                                [f n . n <- (x#xs), Q (f n)] = [x <- (map f (x#xs)). Q x])"
      by simp

(* General case comprising the two previous cases. *)
lemma map_commutes: fixes f::"'a => 'b" fixes Q::"'b => bool" fixes xs::"'a list"
                    shows "[f n . n <- xs, Q (f n)] = [x <- (map f xs). Q x]"
      using map_commutes_a map_commutes_b structInduct by fast

lemma lm07: fixes f l
            shows "maxpositions (map f l) =
                   [n . n <- [0..<size l], f (l!n) \<ge> Max (f`(set l))]"
            (is "maxpositions (?fl) = _") (* Pattern matching abbreviation ?fl corresponds to (map f l). Used in the proof, not part of lemma itself *)
proof -
  have "maxpositions ?fl =
  [n. n <- [0..<size ?fl], n\<in> set[0..<size ?fl], ?fl!n \<ge> Max (set ?fl)]"
  using lm04 unfolding filterpositions2_def maxpositions_def .
  also have "... =
  [n . n <- [0..<size l], (n<size l), (?fl!n  \<ge> Max (set ?fl))]" by simp
  also have "... =
  [n . n <- [0..<size l], (n<size l) \<and> (f (l!n)  \<ge> Max (set ?fl))]"
  using nth_map by (metis (poly_guards_query, hide_lams)) also have "... =
  [n . n <- [0..<size l], (n\<in> set [0..<size l]),(f (l!n)  \<ge> Max (set ?fl))]"
  using atLeastLessThan_iff le0 set_upt by (metis(no_types))
  also have "... =
  [n . n <- [0..<size l], f (l!n) \<ge> Max (set ?fl)]" using lm05 by presburger
  finally show ?thesis by auto
qed

lemma lm08: fixes f l
            shows "argmaxList f l =
                   [ l!n . n <- [0..<size l], f (l!n) \<ge> Max (f`(set l))]"
      unfolding lm07 argmaxList_def by (metis lm06)

text\<open>The theorem expresses that argmaxList is the list of arguments greater equal the Max of the list.\<close>

theorem argmaxadequacy: fixes f::"'a => ('b::linorder)" fixes l::"'a list"
                        shows "argmaxList f l = [ x <- l. f x \<ge> Max (f`(set l))]"
                        (is "?lh=_") (* pattern match ?lh abbreviates "argmaxList f l" *)
proof -
  let ?P="% y::('b::linorder) . y \<ge> Max (f`(set l))"
  let ?mh="[nth l n . n <- [0..<size l], ?P (f (nth l n))]"
  let ?rh="[ x <- (map (nth l) [0..<size l]). ?P (f x)]"
  have "?lh = ?mh" using lm08 by fast
  also have "... = ?rh" using map_commutes by fast
  also have "...= [x <- l. ?P (f x)]" using map_nth by metis
  finally show ?thesis by force
qed

end


(*
  File: Functions.thy
  Author: Bohua Zhan

  Basic results on (set-theoretic) functions.
*)

theory Functions
  imports Choice
begin

section \<open>Functions\<close>  (* Bourbaki II.3.4 -- II.3.6 *)

(* Image under a function *)
definition image_on :: "i \<Rightarrow> i \<Rightarrow> i" (infixl "``" 90) where [rewrite]:
  "f `` A = {y\<in>target(f). \<exists>x\<in>source(f). x\<in>A \<and> f`x=y}"

lemma image_onI [backward]: "is_function(f) \<Longrightarrow> x \<in> source(f) \<Longrightarrow> x \<in> A \<Longrightarrow> f ` x \<in> f `` A" by auto2
lemma image_onD [forward]: "is_function(f) \<Longrightarrow> y \<in> f `` A \<Longrightarrow> \<exists>x\<in>source(f). x \<in> A \<and> f`x = y" by auto2
setup {* del_prfstep_thm @{thm image_on_def} *}

lemma image_on_empty [rewrite]: "is_function(f) \<Longrightarrow> f `` \<emptyset> = \<emptyset>" by auto2
lemma image_on_mono [backward]: "is_function(f) \<Longrightarrow> A \<subseteq> B \<Longrightarrow> f `` A \<subseteq> f `` B" by auto2

lemma image_non_empty [backward]: "is_function(f) \<Longrightarrow> S \<subseteq> source(f) \<Longrightarrow> S \<noteq> \<emptyset> \<Longrightarrow> f `` S \<noteq> \<emptyset>"
@proof
  @obtain x where "x \<in> S"
  @have "f`x \<in> f``S"
@qed

definition image :: "i \<Rightarrow> i" where image_def [rewrite_bidir]:
  "image(f) = f `` source(f)"
lemma image_in_target: "is_function(f) \<Longrightarrow> image(f) \<subseteq> target(f)" by auto2
setup {* add_forward_prfstep_cond @{thm image_in_target} [with_term "image(?f)"] *}

lemma imageI: "is_function(f) \<Longrightarrow> x \<in> source(f) \<Longrightarrow> f`x \<in> image(f)" by auto2
setup {* add_forward_prfstep_cond @{thm imageI} [with_term "?f`?x", with_term "image(?f)"] *}

(* Inverse image under a function *)
definition fVImage :: "i \<Rightarrow> i \<Rightarrow> i"  (infixl "-``" 90) where [rewrite]:
  "fVImage(f,A) = {x\<in>source(f). f`x\<in>A}"

lemma fVImageI [typing2]: "is_function(f) \<Longrightarrow> x \<in> source(f) \<Longrightarrow> f ` x \<in> A \<Longrightarrow> x \<in> f -`` A" by auto2
lemma fVImage_iff [rewrite]: "is_function(f) \<Longrightarrow> x \<in> f -`` A \<longleftrightarrow> (x \<in> source(f) \<and> f ` x \<in> A)" by auto2
setup {* del_prfstep_thm @{thm fVImage_def} *}

lemma fVImage_empty [rewrite]: "is_function(f) \<Longrightarrow> f -`` \<emptyset> = \<emptyset>" by auto2
lemma fVImage_mono [backward]: "is_function(f) \<Longrightarrow> A \<subseteq> B \<Longrightarrow> f -`` A \<subseteq> f -`` B" by auto2
lemma fVImage_compl [rewrite]: "is_function(f) \<Longrightarrow> f -`` (target(f) \<midarrow> A) = source(f) \<midarrow> (f -`` A)" by auto2
lemma fVImage_union [rewrite]: "is_function(f) \<Longrightarrow> (f -`` A) \<union> (f -`` B) = f -`` (A \<union> B)" by auto2
lemma fVImage_target [rewrite]: "is_function(f) \<Longrightarrow> f -`` target(f) = source(f)" by auto2

lemma fVImage_subset [backward1]: "is_function(f) \<Longrightarrow> U \<subseteq> source(f) \<Longrightarrow> f `` U \<subseteq> V \<Longrightarrow> U \<subseteq> f -`` V"
@proof
  @have "\<forall>x'\<in>U. x'\<in>f-``V" @with
    @have "f`x' \<in> f``U" @have "f`x' \<in> V"
  @end
@qed

(* Here we characterize when a function space is empty. *)
lemma empty_fun_space [rewrite]: "A \<rightarrow> B = \<emptyset> \<longleftrightarrow> A \<noteq> \<emptyset> \<and> B = \<emptyset>"
@proof
  @case "A \<rightarrow> B = \<emptyset>" @with  (* Show A \<noteq> 0 and B = 0 *)
    @case "A = \<emptyset>" @with @have "Fun(A,B,\<lambda>_.\<emptyset>) \<in> A \<rightarrow> B" @end
    @case "B \<noteq> \<emptyset>" @with @obtain "b \<in> B" @have "Fun(A,B,\<lambda>_.b) \<in> A \<rightarrow> B" @end
  @end
  @case "A \<noteq> \<emptyset> \<and> B = \<emptyset>" @with
    @obtain "f \<in> A \<rightarrow> B" "a \<in> A" @have "f ` a \<in> B"
  @end
@qed

section \<open>Important examples of functions\<close>

(* Identity function *)
definition id_fun :: "i \<Rightarrow> i" where [rewrite]:
  "id_fun(A) = Fun(A,A, \<lambda>x. x)"

lemma id_fun_is_function [typing]: "id_fun(A) \<in> A \<rightarrow> A" by auto2
lemma id_fun_eval [rewrite]: "x \<in> source(id_fun(A)) \<Longrightarrow> id_fun(A) ` x = x" by auto2
setup {* del_prfstep_thm @{thm id_fun_def} *}

lemma id_fun_image [rewrite]: "S \<subseteq> A \<Longrightarrow> id_fun(A) `` S = S"
@proof @have "\<forall>x\<in>S. x \<in> id_fun(A)``S" @with @have "id_fun(A)`x = x" @end @qed

(* Constant function *)
definition const_fun :: "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "const_fun(A,B,y) = Fun(A,B, \<lambda>x. y)"
setup {* register_wellform_data ("const_fun(A,B,y)", ["y \<in> B"]) *}

lemma const_fun_is_function [typing]: "y \<in> B \<Longrightarrow> const_fun(A,B,y) \<in> A \<rightarrow> B" by auto2
lemma const_fun_eval [rewrite]: "y \<in> B \<Longrightarrow> x \<in> source(const_fun(A,B,y)) \<Longrightarrow> const_fun(A,B,y) ` x = y" by auto2
setup {* del_prfstep_thm @{thm const_fun_def} *}

(* Restriction of function to a set A *)
definition func_restrict :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "func_restrict(f,A) = Fun(A, target(f), \<lambda>x. f`x)"
setup {* register_wellform_data ("func_restrict(f,A)", ["A \<subseteq> source(f)"]) *}
setup {* add_prfstep_check_req ("func_restrict(f,A)", "A \<subseteq> source(f)") *}

lemma func_restrict_is_function [typing]:
  "is_function(f) \<Longrightarrow> A \<subseteq> source(f) \<Longrightarrow> func_restrict(f,A) \<in> A \<rightarrow> target(f)" by auto2

lemma func_restrict_eval [rewrite]:
  "is_function(f) \<Longrightarrow> A \<subseteq> source(f) \<Longrightarrow> x \<in> source(func_restrict(f,A)) \<Longrightarrow>
   func_restrict(f,A) ` x = f ` x" by auto2
setup {* del_prfstep_thm @{thm func_restrict_def} *}

lemma func_restrict_trans [rewrite]:
  "is_function(f) \<Longrightarrow> B \<subseteq> source(func_restrict(f,A)) \<Longrightarrow> A \<subseteq> source(f) \<Longrightarrow>
   func_restrict(func_restrict(f,A),B) = func_restrict(f,B)" by auto2

lemma func_restrict_fImage [rewrite]:
  "is_function(f) \<Longrightarrow> A \<subseteq> source(f) \<Longrightarrow> func_restrict(f,A) `` A = f `` A"
@proof
  @let "g = func_restrict(f,A)"
  @have "\<forall>x\<in>f``A. x \<in> g``A" @with
    @obtain y where "y \<in> A" "f`y = x"
    @have "g`y \<in> g``A"
  @end
@qed

definition func_coincide :: "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o" where [rewrite]:
  "func_coincide(f,g,E) \<longleftrightarrow> (E \<subseteq> source(f) \<and> E \<subseteq> source(g) \<and> (\<forall>x\<in>E. f`x = g`x))"

lemma func_coincideD1 [forward]:
  "func_coincide(f,g,E) \<Longrightarrow> E \<subseteq> source(f) \<and> E \<subseteq> source(g)" by auto2

lemma func_coincideD2 [rewrite_bidir]:
  "func_coincide(f,g,E) \<Longrightarrow> x \<in> E \<Longrightarrow> f`x = g`x" by auto2
setup {* del_prfstep_thm_eqforward @{thm func_coincide_def} *}

definition is_func_extension :: "i \<Rightarrow> i \<Rightarrow> o" where [rewrite]:
  "is_func_extension(f,g) \<longleftrightarrow> (source(g) \<subseteq> source(f) \<and> func_coincide(f,g,source(g)))"

lemma extension_of_restrict [backward]:
  "is_function(f) \<Longrightarrow> A \<subseteq> source(f) \<Longrightarrow> is_func_extension(f,func_restrict(f,A))" by auto2

(* Any function can be restricted to its image. *)
definition func_restrict_image :: "i \<Rightarrow> i" where [rewrite]:
  "func_restrict_image(f) = Fun(source(f),image(f), \<lambda>x. f`x)"

lemma func_restrict_image_is_fun [typing]:
  "is_function(f) \<Longrightarrow> func_restrict_image(f) \<in> source(f) \<rightarrow> image(f)" by auto2

lemma func_restrict_image_type [backward]:
  "is_function(f) \<Longrightarrow> f `` source(f) = C \<Longrightarrow> func_restrict_image(f) \<in> source(f) \<rightarrow> C" by auto2

lemma func_restrict_image_eval [rewrite]:
  "is_function(f) \<Longrightarrow> x \<in> source(func_restrict_image(f)) \<Longrightarrow> func_restrict_image(f)`x = f`x" by auto2
setup {* del_prfstep_thm @{thm func_restrict_image_def} *}

(* Projection functions *)
definition proj1_fun :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "proj1_fun(A,B) = Fun(A\<times>B, A, \<lambda>p. fst(p))"

lemma proj1_fun_is_function [typing]: "proj1_fun(A,B) \<in> A\<times>B \<rightarrow> A" by auto2
lemma proj1_eval [rewrite]: "p \<in> source(proj1_fun(A,B)) \<Longrightarrow> proj1_fun(A,B)`p = fst(p)" by auto2
setup {* del_prfstep_thm @{thm proj1_fun_def} *}

definition proj2_fun :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "proj2_fun(A,B) = Fun(A\<times>B, B, \<lambda>p. snd(p))"

lemma proj2_fun_is_function [typing]: "proj2_fun(A,B) \<in> A\<times>B \<rightarrow> B" by auto2
lemma proj2_fun_eval [rewrite]: "p \<in> source(proj2_fun(A,B)) \<Longrightarrow> proj2_fun(A,B)`p = snd(p)" by auto2
setup {* del_prfstep_thm @{thm proj2_fun_def} *}

section \<open>Composition of functions\<close>  (* Bourbaki II.3.7 *)

(* Composition of two functions. *)
definition fun_comp :: "i \<Rightarrow> i \<Rightarrow> i"  (infixr "\<circ>" 60) where [rewrite]:
  "f' \<circ> f = Fun(source(f), target(f'), \<lambda>x. f' ` (f ` x))"
setup {* register_wellform_data ("f' \<circ> f", ["func_form(f')", "func_form(f)", "target(f) = source(f')"]) *}
setup {* add_prfstep_check_req ("f' \<circ> f", "target(f) = source(f')") *}

lemma comp_is_function [typing]:
  "is_function(f) \<Longrightarrow> is_function(f') \<Longrightarrow> target(f) = source(f') \<Longrightarrow> f' \<circ> f \<in> source(f) \<rightarrow> target(f')" by auto2

lemma comp_eval [rewrite]:
  "is_function(f) \<Longrightarrow> is_function(f') \<Longrightarrow> target(f) = source(f') \<Longrightarrow>
   x \<in> source(f) \<Longrightarrow> (f' \<circ> f) ` x = f' ` (f ` x)" by auto2
setup {* add_rewrite_rule_back_cond @{thm comp_eval} [with_term "?f' \<circ> ?f"] *}
setup {* del_prfstep_thm @{thm fun_comp_def} *}

lemma comp_assoc_l:
  "func_form(x) \<Longrightarrow> func_form(y) \<Longrightarrow> func_form(z) \<Longrightarrow> target(z) = source(y) \<Longrightarrow>
   target(y \<circ> z) = source(x) \<Longrightarrow> x \<circ> (y \<circ> z) = (x \<circ> y) \<circ> z \<and>
   func_form(x \<circ> y) \<and> target(y) = source(x) \<and> target(z) = source(x \<circ> y)" by auto2
setup {* add_prfstep (FOL_Assoc.alg_assoc_prfstep (@{term fun_comp}, @{thm comp_assoc_l})) *}

lemma comp_id_left [rewrite]:
  "func_form(f) \<Longrightarrow> id_fun(target(f)) \<circ> f = f" by auto2

lemma comp_id_right [rewrite]:
  "func_form(f) \<Longrightarrow> f \<circ> id_fun(source(f)) = f" by auto2

lemma func_vImage_comp [rewrite]:
  "is_function(f) \<Longrightarrow> is_function(g) \<Longrightarrow> target(f) = source(g) \<Longrightarrow>
   (g \<circ> f) -`` V = f -`` (g -`` V)" by auto2
setup {* add_rewrite_rule_back_cond @{thm func_vImage_comp} [with_term "?g \<circ> ?f"] *}

section \<open>Injective, surjective, and bijective functions.\<close>

definition injective :: "i \<Rightarrow> o" where [rewrite]:
  "injective(f) \<longleftrightarrow> (is_function(f) \<and> (\<forall>x\<in>source(f). \<forall>y\<in>source(f). f`x = f`y \<longrightarrow> x=y))"

lemma injectiveI [backward]:
  "is_function(f) \<Longrightarrow> (\<forall>x\<in>source(f). \<forall>y\<in>source(f). f`x = f`y \<longrightarrow> x=y) \<Longrightarrow> injective(f)" by auto2

lemma injectiveD [forward]:
  "injective(f) \<Longrightarrow> is_function(f)"
  "injective(f) \<Longrightarrow> x \<in> source(f) \<Longrightarrow> y \<in> source(f) \<Longrightarrow> f`x = f`y \<Longrightarrow> x = y" by auto2+

definition surjective :: "i \<Rightarrow> o" where [rewrite]:
  "surjective(f) \<longleftrightarrow> (is_function(f) \<and> image(f) = target(f))"

lemma surjectiveD:
  "surjective(f) \<Longrightarrow> is_function(f)"
  "surjective(f) \<Longrightarrow> y \<in> target(f) \<Longrightarrow> \<exists>x\<in>source(f). f ` x = y"
  "surjective(f) \<Longrightarrow> image(f) = target(f)" by auto2+
setup {* add_forward_prfstep @{thm surjectiveD(1)} *}
setup {* add_backward_prfstep @{thm surjectiveD(2)} *}
setup {* add_rewrite_rule @{thm surjectiveD(3)} *}

lemma surjectiveI [backward]:
  "is_function(f) \<Longrightarrow> \<forall>y\<in>target(f). \<exists>x\<in>source(f). f`x = y \<Longrightarrow> surjective(f)" by auto2

lemma surjectiveI' [forward]:
  "is_function(f) \<Longrightarrow> image(f) = target(f) \<Longrightarrow> surjective(f)" by auto2

definition bijective :: "i \<Rightarrow> o" where [rewrite]:
  "bijective(f) \<longleftrightarrow> (injective(f) \<and> surjective(f))"

lemma bijectiveD [forward]:
  "bijective(f) \<Longrightarrow> injective(f)"
  "bijective(f) \<Longrightarrow> surjective(f)" by auto2+

lemma bijectiveI [backward]:
  "injective(f) \<and> surjective(f) \<Longrightarrow> bijective(f)" by auto2

setup {* fold del_prfstep_thm [@{thm injective_def}, @{thm surjective_def}, @{thm bijective_def}] *}

definition bijection_space :: "i \<Rightarrow> i \<Rightarrow> i"  (infix "\<cong>" 60) where [rewrite]:
  "A \<cong> B = {f \<in> A \<rightarrow> B. bijective(f)}"

lemma bijective_spaceD [forward]:
  "f \<in> A \<cong> B \<Longrightarrow> f \<in> A \<rightarrow> B \<and> bijective(f)" by auto2

lemma bijective_spaceI [backward]:
  "func_form(f) \<Longrightarrow> bijective(f) \<Longrightarrow> f \<in> source(f) \<cong> target(f)" by auto2
setup {* del_prfstep_thm @{thm bijection_space_def} *}

(* Some properties of surjective functions *)
lemma surjective_to_singleton [backward2]:
  "f \<in> A \<rightarrow> {x} \<Longrightarrow> A \<noteq> \<emptyset> \<Longrightarrow> surjective(f)" by auto2

lemma surj_source_nonempty [forward, backward]:
  "surjective(f) \<Longrightarrow> target(f) \<noteq> \<emptyset> \<Longrightarrow> source(f) \<noteq> \<emptyset>"
@proof
  @obtain b where "b \<in> target(f)"
  @obtain "a \<in> source(f)" where "f`a = b"
@qed

lemma surjective_inv_image [backward2]:
  "surjective(f) \<Longrightarrow> U \<subseteq> target(f) \<Longrightarrow> U \<noteq> \<emptyset> \<Longrightarrow> f -`` U \<noteq> \<emptyset>"
@proof
  @obtain u where "u \<in> U"
  @obtain "x \<in> source(f)" where "f`x = u"
@qed

(* Properties of bijective functions *)
lemma bijective_exist_unique [backward]:
  "bijective(f) \<Longrightarrow> y \<in> target(f) \<Longrightarrow> \<exists>!x. x\<in>source(f) \<and> f`x=y" by auto2

(* Restrictions of functions *)
lemma func_restrict_injective:
  "injective(f) \<Longrightarrow> A \<subseteq> source(f) \<Longrightarrow> injective(func_restrict(f,A))" by auto2
setup {* add_forward_prfstep_cond @{thm func_restrict_injective} [with_term "func_restrict(?f,?A)"] *}

lemma func_restrict_image_bij [forward]:
  "injective(f) \<Longrightarrow> bijective(func_restrict_image(f))" by auto2

(* Example: canonical injection. *)
definition inj_fun :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "inj_fun(A,B) = Fun(A,B, \<lambda>x. x)"
setup {* register_wellform_data ("inj_fun(A,B)", ["A \<subseteq> B"]) *}

lemma inj_fun_is_function [typing]: "A \<subseteq> B \<Longrightarrow> inj_fun(A,B) \<in> A \<rightarrow> B" by auto2
lemma inj_fun_eval [rewrite]: "A \<subseteq> B \<Longrightarrow> x \<in> source(inj_fun(A,B)) \<Longrightarrow> inj_fun(A,B) ` x = x" by auto2
setup {* del_prfstep_thm @{thm inj_fun_def} *}

lemma inj_fun_is_injection: "A \<subseteq> B \<Longrightarrow> injective(inj_fun(A,B))" by auto2

lemma func_factorize [rewrite_back]:
  "func_form(f) \<Longrightarrow> f = inj_fun(image(f),target(f)) \<circ> func_restrict_image(f)" by auto2

lemma inj_restrict_image_bij [typing]:
  "injective(f) \<Longrightarrow> func_restrict_image(f) \<in> source(f) \<cong> image(f)" by auto2

lemma inj_restrict_image_bij' [backward]:
  "injective(f) \<Longrightarrow> f `` source(f) = C \<Longrightarrow> func_restrict_image(f) \<in> source(f) \<cong> C" by auto2

(* Other examples. *)
lemma id_bij: "id_fun(A) \<in> A \<cong> A" by auto2
lemma proj1_surj: "B \<noteq> \<emptyset> \<Longrightarrow> surjective(proj1_fun(A,B))" by auto2
lemma proj2_surj: "A \<noteq> \<emptyset> \<Longrightarrow> surjective(proj2_fun(A,B))" by auto2
lemma swap_bij: "Fun(A\<times>B, B\<times>A, \<lambda>p. \<langle>snd(p),fst(p)\<rangle>) \<in> A\<times>B \<cong> B\<times>A" by auto2
lemma pair_bij: "Fun(A, A\<times>{b}, \<lambda>x. \<langle>x,b\<rangle>) \<in> A \<cong> A\<times>{b}" by auto2
lemma rpair_bij: "Fun(A, {b}\<times>A, \<lambda>x. \<langle>b,x\<rangle>) \<in> A \<cong> {b}\<times>A" by auto2

section \<open>Inverse function\<close>

definition inverse :: "i \<Rightarrow> i" where [rewrite]:
  "inverse(f) = Fun(target(f),source(f), \<lambda>y. THE x. x\<in>source(f) \<and> f`x=y)"
setup {* add_prfstep_check_req ("inverse(f)", "bijective(f)") *}

lemma has_inverse [typing]:
  "bijective(f) \<Longrightarrow> inverse(f) \<in> target(f) \<rightarrow> source(f)" by auto2

lemma inverse_eval1 [rewrite]:
  "bijective(f) \<Longrightarrow> x \<in> source(f) \<Longrightarrow> f ` x = y \<Longrightarrow> inverse(f) ` y = x" by auto2

lemma inverse_eval2 [rewrite]:
  "bijective(f) \<Longrightarrow> y \<in> source(inverse(f)) \<Longrightarrow> inverse(f) ` y = x \<Longrightarrow> f ` x = y" by auto2
setup {* del_prfstep_thm @{thm inverse_def} *}

lemma inv_bijective [typing]:
  "bijective(f) \<Longrightarrow> inverse(f) \<in> target(f) \<cong> source(f)"
@proof @have (@rule) "\<forall>x\<in>source(f). inverse(f)`(f`x) = x" @qed

lemma inverse_of_inj [rewrite]:
  "injective(f) \<Longrightarrow> X \<subseteq> source(f) \<Longrightarrow> f -`` (f `` X) = X" by auto2

lemma inverse_of_surj [rewrite]:
  "surjective(f) \<Longrightarrow> Y \<subseteq> target(f) \<Longrightarrow> f `` (f -`` Y) = Y"
@proof
  @have "\<forall>y\<in>Y. y \<in> f``(f-``Y)" @with
    @obtain "x\<in>source(f)" where "f`x = y"
  @end
@qed

lemma inverse_is_left_inv [rewrite]:
  "bijective(f) \<Longrightarrow> inverse(f) \<circ> f = id_fun(source(f))" by auto2

lemma inverse_is_right_inv [rewrite]:
  "bijective(f) \<Longrightarrow> f \<circ> inverse(f) = id_fun(target(f))" by auto2

section \<open>Left and right inverses\<close>  (* Bourbaki II.3.8 *)

(* Left and right inverses always exists, but that takes more work. *)
lemma has_left_inverse_inj [forward]:
  "is_function(f) \<Longrightarrow> is_function(r) \<Longrightarrow> target(f) = source(r) \<Longrightarrow>
   r \<circ> f = id_fun(source(f)) \<Longrightarrow> injective(f)"
@proof
  @have "\<forall>x\<in>source(f). \<forall>y\<in>source(f). f`x = f`y \<longrightarrow> x=y" @with @have "r`(f`x)=x" @end
@qed

lemma has_right_inverse_surj [forward]:
  "is_function(f) \<Longrightarrow> is_function(s) \<Longrightarrow> target(s) = source(f) \<Longrightarrow>
   f \<circ> s = id_fun(source(s)) \<Longrightarrow> surjective(f)"
@proof
  @have "\<forall>x\<in>target(f). x\<in>image(f)" @with @have "f`(s`x) = x" @end
@qed

lemma has_left_right_inverse_bij [forward]:
  "func_form(f) \<Longrightarrow> is_function(r) \<Longrightarrow> is_function(s) \<Longrightarrow> target(f) = source(r) \<Longrightarrow>
   target(s) = source(f) \<Longrightarrow> r \<circ> f = id_fun(A) \<Longrightarrow> f \<circ> s = id_fun(B) \<Longrightarrow> f \<in> A \<cong> B" by auto2

lemma right_inverse_unique:
  "is_function(f) \<Longrightarrow> f \<circ> s = id_fun(B) \<Longrightarrow> f \<circ> s' = id_fun(B) \<Longrightarrow>
   f \<in> A \<rightarrow> B \<Longrightarrow> s \<in> B \<rightarrow> A \<Longrightarrow> s' \<in> B \<rightarrow> A \<Longrightarrow> s `` B = s' `` B \<Longrightarrow> s = s'"
@proof
  @have "\<forall>x\<in>B. s`x = s'`x" @with @have "f`(s`x) = x" @end
@qed

(* Six parts of Theorem 1 in Bourbaki II.3.8. May be easier with existence
   of left/right-inverse, but not necessary. *)
lemma comp_is_inj:
  "injective(f) \<Longrightarrow> injective(f') \<Longrightarrow> target(f) = source(f') \<Longrightarrow> injective(f' \<circ> f)" by auto2
setup {* add_forward_prfstep_cond @{thm comp_is_inj} [with_term "?f' \<circ> ?f"] *}

lemma comp_is_surj:
  "surjective(f) \<Longrightarrow> surjective(f') \<Longrightarrow> target(f) = source(f') \<Longrightarrow> surjective(f' \<circ> f)"
@proof
  @have "\<forall>z\<in>target(f'). \<exists>x\<in>source(f). (f' \<circ> f) ` x = z" @with
    @obtain "y \<in> source(f')" where "f' ` y = z"
    @obtain "x \<in> source(f)" where "f ` x = y"
  @end
@qed
setup {* add_forward_prfstep_cond @{thm comp_is_surj} [with_term "?f' \<circ> ?f"] *}

lemma comp_is_inj_to_first_inj [forward]:
  "is_function(f) \<Longrightarrow> is_function(f') \<Longrightarrow> target(f) = source(f') \<Longrightarrow> injective(f' \<circ> f) \<Longrightarrow> injective(f)"
@proof
  @have "\<forall>x\<in>source(f). \<forall>y\<in>source(f). f`x = f`y \<longrightarrow> x=y" @with
    @have "(f' \<circ> f) ` x = (f' \<circ> f) ` y" @end
@qed

lemma comp_is_surj_to_second_surj [forward]:
  "is_function(f) \<Longrightarrow> is_function(f') \<Longrightarrow> target(f) = source(f') \<Longrightarrow> surjective(f' \<circ> f) \<Longrightarrow> surjective(f')"
@proof
  @have "\<forall>y\<in>target(f'). \<exists>x\<in>source(f'). f' ` x = y" @with
    @obtain "x \<in> source(f)" where "(f' \<circ> f) ` x = y"
  @end
@qed

lemma comp_is_surj_to_first_surj [forward]:
  "is_function(f) \<Longrightarrow> injective(f') \<Longrightarrow> target(f) = source(f') \<Longrightarrow> surjective(f' \<circ> f) \<Longrightarrow> surjective(f)"
@proof
  @have "\<forall>y\<in>target(f). \<exists>x\<in>source(f). f ` x = y" @with
    @obtain "x \<in> source(f)" where "(f' \<circ> f) ` x = f' ` y"
  @end
@qed

lemma comp_is_inj_to_second_inj [forward]:
  "surjective(f) \<Longrightarrow> func_form(f') \<Longrightarrow> target(f) = source(f') \<Longrightarrow> injective(f' \<circ> f) \<Longrightarrow> injective(f')"
@proof @have "f' = (f' \<circ> f) \<circ> inverse(f)" @qed

lemma inverse_unique [rewrite]:
  "bijective(f) \<Longrightarrow> func_form(g) \<Longrightarrow> target(f) = source(g) \<Longrightarrow>
   g \<circ> f = id_fun(source(f)) \<Longrightarrow> inverse(f) = g"
@proof
  @have "\<forall>x\<in>target(f). inverse(f)`x = g`x" @with
    @obtain "y\<in>source(f)" where "f`y = x"
  @end
@qed

lemma inverse_unique' [rewrite]:
  "bijective(f) \<Longrightarrow> func_form(g) \<Longrightarrow> target(g) = source(f) \<Longrightarrow>
   f \<circ> g = id_fun(target(f)) \<Longrightarrow> inverse(f) = g"
@proof
  @have "\<forall>x\<in>target(f). inverse(f)`x = g`x" @with
    @have "f ` (g ` x) = (f \<circ> g) ` x"
  @end
@qed

(* Now we construct the left and right inverses explicitly. *)
lemma exists_right_inverse [resolve]:
  "surjective(f) \<Longrightarrow> A = source(f) \<Longrightarrow> B = target(f) \<Longrightarrow> \<exists>s\<in>B\<rightarrow>A. f \<circ> s = id_fun(B)"
@proof @let "s = Fun(B,A, \<lambda>y. SOME x\<in>A. f`x=y)" @qed

definition right_inverse :: "i \<Rightarrow> i" where [rewrite]:
  "right_inverse(f) = (SOME s\<in>target(f)\<rightarrow>source(f). f \<circ> s = id_fun(target(f)))"

lemma right_inverse_prop:
  "surjective(f) \<Longrightarrow>
   right_inverse(f) \<in> target(f) \<rightarrow> source(f) \<and> f \<circ> right_inverse(f) = id_fun(target(f))" by auto2
setup {* add_forward_prfstep_cond @{thm right_inverse_prop} [with_term "right_inverse(?f)"] *}
setup {* del_prfstep_thm @{thm right_inverse_def} *}

lemma exists_left_inverse [backward]:
  "injective(f) \<Longrightarrow> A = source(f) \<Longrightarrow> B = target(f) \<Longrightarrow> A \<noteq> \<emptyset> \<Longrightarrow> \<exists>r\<in>B\<rightarrow>A. r \<circ> f = id_fun(A)"
@proof
  @obtain "a \<in> A"
  @let "r = Fun(B, A, \<lambda>y. if \<exists>x\<in>A. f`x=y then SOME x\<in>A. f`x=y else a)"
  @have (@rule) "\<forall>x\<in>A. r`(f`x) = x" @with @have "\<exists>x'\<in>A. f`x' = f`x" @end
@qed

definition left_inverse :: "i \<Rightarrow> i" where [rewrite]:
  "left_inverse(f) = (SOME r\<in>target(f)\<rightarrow>source(f). r \<circ> f = id_fun(source(f)))"
setup {* register_wellform_data ("left_inverse(f)", ["source(f) \<noteq> \<emptyset>"]) *}
setup {* add_prfstep_check_req ("left_inverse(f)", "source(f) \<noteq> \<emptyset>") *}

lemma left_inverse_prop:
  "injective(f) \<Longrightarrow> source(f) \<noteq> \<emptyset> \<Longrightarrow>
   left_inverse(f) \<in> target(f) \<rightarrow> source(f) \<and> left_inverse(f) \<circ> f = id_fun(source(f))" by auto2
setup {* add_forward_prfstep_cond @{thm left_inverse_prop} [with_term "left_inverse(?f)"] *}
setup {* del_prfstep_thm @{thm left_inverse_def} *}

(* Using left and right inverses to construct functions. *)
lemma exists_pullback_surj [backward1]:
  "surjective(g) \<Longrightarrow> g \<in> E \<rightarrow> F \<Longrightarrow> f \<in> E \<rightarrow> G \<Longrightarrow> \<forall>x\<in>E. \<forall>y\<in>E. g`x=g`y \<longrightarrow> f`x=f`y \<Longrightarrow>
   \<exists>!h. h\<in>F\<rightarrow>G \<and> f = h \<circ> g"
@proof
  @have "\<exists>h\<in>F\<rightarrow>G. f = h \<circ> g" @with
    @obtain "s \<in> F \<rightarrow> E" where "g \<circ> s = id_fun(F)"
    @obtain "h \<in> F \<rightarrow> G" where "h = f \<circ> s"
  @end
  @have "\<forall>h1 h2. h1 \<in> F \<rightarrow> G \<and> f = h1 \<circ> g \<longrightarrow> h2 \<in> F \<rightarrow> G \<and> f = h2 \<circ> g \<longrightarrow> h1 = h2" @with
    @have "\<forall>x\<in>F. h1`x = h2`x" @with
      @obtain "y\<in>E" where "g`y = x"
    @end
  @end
@qed

lemma exists_pullback_inj:
  "injective(g) \<Longrightarrow> g \<in> F \<rightarrow> E \<Longrightarrow> f \<in> G \<rightarrow> E \<Longrightarrow> F \<noteq> \<emptyset> \<Longrightarrow> image(f) \<subseteq> image(g) \<Longrightarrow>
   \<exists>!h. h\<in>G\<rightarrow>F \<and> f = g \<circ> h"
@proof
  @have "\<exists>h\<in>G\<rightarrow>F. f = g \<circ> h" @with
    @obtain "r \<in> E \<rightarrow> F" where "r \<circ> g = id_fun(F)"
    @obtain "h \<in> G \<rightarrow> F" where "h = r \<circ> f"
  @end
  @have "\<forall>h1 h2. h1 \<in> G \<rightarrow> F \<and> f = g \<circ> h1 \<longrightarrow> h2 \<in> G \<rightarrow> F \<and> f = g \<circ> h2 \<longrightarrow> h1 = h2" @with
    @have "\<forall>x\<in>G. h1`x = h2`x" @with
      @have "g`(h1`x) = g`(h2`x)"
    @end
  @end
@qed

section \<open>Inverse pair\<close>

(* Two functions are inverses of each other. This pattern occurs very frequently. *)
definition inverse_pair :: "i \<Rightarrow> i \<Rightarrow> o" where [rewrite]:
  "inverse_pair(f,g) \<longleftrightarrow> (is_function(f) \<and> is_function(g) \<and> source(f) = target(g) \<and> target(f) = source(g) \<and>
                          f \<circ> g = id_fun(source(g)) \<and> g \<circ> f = id_fun(source(f)))"

lemma inverse_pair_bijective [forward]:
  "inverse_pair(f,g) \<Longrightarrow> source(f) = target(g) \<and> source(g) = target(f) \<and> bijective(f) \<and> bijective(g)" by auto2

lemma inverse_pairI [backward]:
  "is_function(f) \<Longrightarrow> is_function(g) \<Longrightarrow> source(f) = target(g) \<Longrightarrow> source(g) = target(f) \<Longrightarrow>
   \<forall>x\<in>source(g). f`(g`x) = x \<Longrightarrow> \<forall>x\<in>source(f). g`(f`x) = x \<Longrightarrow> inverse_pair(f,g)" by auto2

lemma inverse_pairE [rewrite]:
  "inverse_pair(f,g) \<Longrightarrow> f \<circ> g = id_fun(source(g))"
  "inverse_pair(f,g) \<Longrightarrow> g \<circ> f = id_fun(source(f))" by auto2+
setup {* del_prfstep_thm @{thm inverse_pair_def} *}

lemma inverse_pair_inverse [rewrite]: "func_form(g) \<Longrightarrow> inverse_pair(f,g) \<Longrightarrow> inverse(f) = g"
@proof @have "g \<circ> f = id_fun(source(f))" @qed

lemma inverse_pair_inverse2 [rewrite]: "func_form(f) \<Longrightarrow> inverse_pair(f,g) \<Longrightarrow> inverse(g) = f"
@proof @have "g \<circ> f = id_fun(source(f))" @qed

section \<open>Function of two arguments\<close>  (* Bourbaki II.3.9 *)

(* We consider functions on product sets only. *)

(* Currying: given a function (A \<times> B) \<rightarrow> D, return a function A \<rightarrow> (B \<rightarrow> D). *)
definition curry :: "[i, i, i] \<Rightarrow> i" where [rewrite]:
  "curry(A,B,D) = Fun(A\<times>B\<rightarrow>D, A\<rightarrow>B\<rightarrow>D, \<lambda>f. Fun(A, B\<rightarrow>D, \<lambda>x. Fun(B, D, \<lambda>y. f`\<langle>x,y\<rangle>)))"

lemma curry_is_function [typing]:
  "curry(A,B,D) \<in> ((A \<times> B) \<rightarrow> D) \<rightarrow> (A \<rightarrow> (B \<rightarrow> D))" by auto2

lemma curry_eval [rewrite]:
  "f \<in> source(curry(A,B,D)) \<Longrightarrow> x \<in> source(curry(A,B,D)`f) \<Longrightarrow> y \<in> source(curry(A,B,D)`f`x) \<Longrightarrow>
   curry(A,B,D)`f`x`y = f`\<langle>x,y\<rangle>" by auto2
setup {* del_prfstep_thm @{thm curry_def} *}

(* Constant functions *)
definition is_const_fun :: "i \<Rightarrow> o" where [rewrite]:
  "is_const_fun(f) \<longleftrightarrow> (\<forall>x\<in>source(f). \<forall>y\<in>source(f). f`x = f`y)"

lemma is_const_funD [forward]:
  "is_const_fun(f) \<Longrightarrow> x \<in> source(f) \<Longrightarrow> y \<in> source(f) \<Longrightarrow> f`x = f`y" by auto2
setup {* del_prfstep_thm_eqforward @{thm is_const_fun_def} *}

(* Functions that do not depend on the second argument. *)
lemma exists_proj_fun:
  "B \<noteq> \<emptyset> \<Longrightarrow> f \<in> (A \<times> B) \<rightarrow> D \<Longrightarrow> \<forall>x\<in>A. is_const_fun(curry(A,B,D)`f`x) \<Longrightarrow>
   \<exists>g\<in>A\<rightarrow>D. \<forall>x\<in>A. \<forall>y\<in>B. f`\<langle>x,y\<rangle> = g`x"
@proof
  @obtain "y \<in> B" @let "g = Fun(A,D, \<lambda>x. f`\<langle>x,y\<rangle>)"
@qed

(* Product map *)
definition prod_map :: "i \<Rightarrow> i \<Rightarrow> i" (infixr "\<times>\<^sub>f" 80) where [rewrite]:
  "u \<times>\<^sub>f v = Fun(source(u)\<times>source(v), target(u)\<times>target(v), \<lambda>p. \<langle>u`fst(p), v`snd(p)\<rangle>)"

lemma prod_map_is_function [typing]:
  "is_function(u) \<Longrightarrow> is_function(v) \<Longrightarrow> u \<times>\<^sub>f v \<in> source(u)\<times>source(v) \<rightarrow> target(u)\<times>target(v)" by auto2

lemma prod_map_eval [rewrite]:
  "is_function(u) \<Longrightarrow> is_function(v) \<Longrightarrow> \<langle>x,y\<rangle> \<in> source(u \<times>\<^sub>f v) \<Longrightarrow> (u \<times>\<^sub>f v) ` \<langle>x,y\<rangle> = \<langle>u`x, v`y\<rangle>" by auto2
setup {* del_prfstep_thm @{thm prod_map_def} *}

lemma prod_map_inj [forward]:
  "injective(u) \<Longrightarrow> injective(v) \<Longrightarrow> injective(u \<times>\<^sub>f v)" by auto2

lemma prod_map_surj [forward]:
  "surjective(u) \<Longrightarrow> surjective(v) \<Longrightarrow> surjective(u \<times>\<^sub>f v)"
@proof
  @let "f = u \<times>\<^sub>f v"
  @have "\<forall>q\<in>target(f). \<exists>p\<in>source(f). f`p = q" @with
    @obtain "x\<in>source(u)" where "u`x = fst(q)"
    @obtain "y\<in>source(v)" where "v`y = snd(q)"
  @end
@qed

lemma prod_map_bij [forward]:
  "bijective(u) \<Longrightarrow> bijective(v) \<Longrightarrow> bijective(u \<times>\<^sub>f v)" by auto2

lemma prod_map_comp [resolve]:
  "is_function(u) \<Longrightarrow> is_function(u') \<Longrightarrow> is_function(v) \<Longrightarrow> is_function(v') \<Longrightarrow>
   target(u) = source(u') \<Longrightarrow> target(v) = source(v') \<Longrightarrow>
   (u' \<circ> u) \<times>\<^sub>f (v' \<circ> v) = (u' \<times>\<^sub>f v') \<circ> (u \<times>\<^sub>f v)" by auto2

lemma prod_map_id_fun [rewrite]:
  "id_fun(A) \<times>\<^sub>f id_fun(B) = id_fun(A\<times>B)" by auto2

lemma prod_inverse [resolve]:
  "bijective(u) \<Longrightarrow> bijective(v) \<Longrightarrow> inverse(u \<times>\<^sub>f v) = inverse(u) \<times>\<^sub>f inverse(v)"
@proof
  @have "inverse_pair(inverse(u) \<times>\<^sub>f inverse(v), u \<times>\<^sub>f v)"
@qed

section \<open>Extension of a function to Pow\<close>  (* Bourbaki II.5.1 *)

definition pow_ext :: "i \<Rightarrow> i" where [rewrite]:
  "pow_ext(f) = Fun(Pow(source(f)), Pow(target(f)), \<lambda>X. f `` X)"

lemma pow_ext_is_function [typing]:
  "is_function(f) \<Longrightarrow> pow_ext(f) \<in> Pow(source(f)) \<rightarrow> Pow(target(f))" by auto2

lemma pow_ext_eval [rewrite]:
  "is_function(f) \<Longrightarrow> X \<in> source(pow_ext(f)) \<Longrightarrow> pow_ext(f) ` X = f `` X" by auto2
setup {* del_prfstep_thm @{thm pow_ext_def} *}

lemma pow_ext_comp [rewrite]:
  "is_function(f) \<Longrightarrow> is_function(g) \<Longrightarrow> target(f) = source(g) \<Longrightarrow>
   pow_ext(g \<circ> f) = pow_ext(g) \<circ> pow_ext(f)" by auto2

lemma pow_ext_id [rewrite]:
  "pow_ext(id_fun(A)) = id_fun(Pow(A))" by auto2

lemma pow_ext_surj [forward]:
  "is_function(f) \<Longrightarrow> surjective(f) \<Longrightarrow> surjective(pow_ext(f))"
@proof
  @let "A = source(f)" "B = target(f)"
  @obtain "s \<in> B \<rightarrow> A" where "f \<circ> s = id_fun(target(f))"
  @have "pow_ext(f \<circ> s) = pow_ext(f) \<circ> pow_ext(s)"
@qed

lemma pow_ext_inj [forward]:
  "injective(f) \<Longrightarrow> injective(pow_ext(f))"
@proof
  @let "U = source(pow_ext(f))"
  @have (@rule) "\<forall>S\<in>U. \<forall>T\<in>U. f `` S = f `` T \<longrightarrow> S = T" @with
    @have "\<forall>x. x \<in> S \<longleftrightarrow> x \<in> T" @with
      @case "x \<in> S" @with @have "f`x \<in> f``S" @end
      @case "x \<in> T" @with @have "f`x \<in> f``T" @end
    @end
  @end
@qed

section \<open>Map on function spaces\<close>  (* Bourbaki II.5.2 *)

(* Define left and right composition separately. *)

definition left_comp :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "left_comp(u,E) = Fun(E\<rightarrow>source(u), E\<rightarrow>target(u), \<lambda>f. u \<circ> f)"

lemma left_comp_is_function [typing]:
  "is_function(u) \<Longrightarrow> left_comp(u,E) \<in> (E\<rightarrow>source(u)) \<rightarrow> (E\<rightarrow>target(u))" by auto2

lemma left_comp_eval [rewrite]:
  "is_function(u) \<Longrightarrow> f \<in> source(left_comp(u,E)) \<Longrightarrow> left_comp(u,E) ` f = u \<circ> f" by auto2
setup {* del_prfstep_thm @{thm left_comp_def} *}

lemma injective_left_comp [forward]:
  "injective(u) \<Longrightarrow> injective(left_comp(u,E))"
@proof
  @contradiction
  @obtain "r \<in> target(u) \<rightarrow> source(u)" where "r \<circ> u = id_fun(source(u))"
  @have "left_comp(r,E) \<circ> left_comp(u,E) = id_fun(E\<rightarrow>source(u))"
@qed

lemma surjective_left_comp [forward]:
  "surjective(u) \<Longrightarrow> surjective(left_comp(u,E))"
@proof
  @obtain "s \<in> target(u) \<rightarrow> source(u)" where "u \<circ> s = id_fun(target(u))"
  @have "left_comp(u,E) \<circ> left_comp(s,E) = id_fun(E\<rightarrow>target(u))"
@qed

lemma bijective_left_comp [forward]:
  "bijective(u) \<Longrightarrow> bijective(left_comp(u,E))" by auto2

definition right_comp :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "right_comp(E,u) = Fun(target(u)\<rightarrow>E, source(u)\<rightarrow>E, \<lambda>f. f \<circ> u)"

lemma right_comp_is_function [typing]:
  "is_function(u) \<Longrightarrow> right_comp(E,u) \<in> (target(u)\<rightarrow>E) \<rightarrow> (source(u)\<rightarrow>E)" by auto2

lemma right_comp_eval [rewrite]:
  "is_function(u) \<Longrightarrow> f \<in> source(right_comp(E,u)) \<Longrightarrow> right_comp(E,u) ` f = f \<circ> u" by auto2
setup {* del_prfstep_thm @{thm right_comp_def} *}

lemma injective_right_comp [forward]:
  "surjective(u) \<Longrightarrow> injective(right_comp(E,u))"
@proof
  @obtain "s \<in> target(u) \<rightarrow> source(u)" where "u \<circ> s = id_fun(target(u))"
  @have "right_comp(E,s) \<circ> right_comp(E,u) = id_fun(target(u)\<rightarrow>E)"
@qed

lemma surjective_right_comp [backward]:
  "injective(u) \<Longrightarrow> source(u) \<noteq> \<emptyset> \<Longrightarrow> surjective(right_comp(E,u))"
@proof
  @obtain "r \<in> target(u) \<rightarrow> source(u)" where "r \<circ> u = id_fun(source(u))"
  @have "right_comp(E,u) \<circ> right_comp(E,r) = id_fun(target(r)\<rightarrow>E)"
@qed

(* The requirement that source(u) \<noteq> \<emptyset> is necessary here, as the following example shows. *)
lemma injective_two_side_comp_counterexample:
  "u = const_fun(\<emptyset>,{\<emptyset>},\<emptyset>) \<Longrightarrow> injective(u) \<and> \<not>surjective(right_comp(\<emptyset>,u))"
@proof @have "target(u) \<rightarrow> \<emptyset> = \<emptyset>" @qed

(* Nevertheless, no condition is required when u is bijective. *)
lemma bijective_right_comp [forward]:
  "bijective(u) \<Longrightarrow> bijective(right_comp(E,u))" by auto2

(* Given a function A \<rightarrow> (B \<rightarrow> D), return a function (A \<times> B) \<rightarrow> D. *)
definition uncurry :: "[i, i, i] \<Rightarrow> i" where [rewrite]:
  "uncurry(A,B,D) = Fun(A\<rightarrow>B\<rightarrow>D, A\<times>B\<rightarrow>D, \<lambda>f. Fun(A\<times>B, D, \<lambda>x. f`fst(x)`snd(x)))"

lemma uncurry_is_function [typing]:
  "uncurry(A,B,D) \<in> (A \<rightarrow> B \<rightarrow> D) \<rightarrow> (A \<times> B \<rightarrow> D)" by auto2

lemma uncurry_eval [rewrite]:
  "f \<in> source(uncurry(A,B,D)) \<Longrightarrow> \<langle>x,y\<rangle>\<in>source(uncurry(A,B,D)`f) \<Longrightarrow> uncurry(A,B,D)`f`\<langle>x,y\<rangle> = f`x`y" by auto2
setup {* del_prfstep_thm @{thm uncurry_def} *}

lemma curry_bijective [forward]: "bijective(curry(A,B,D))"
@proof
  @have "inverse_pair(curry(A,B,D), uncurry(A,B,D))"
@qed

end


theory GabrielaLimonta
imports "~~/src/HOL/IMP/AExp"
begin

(* Homework 2.1 *)
datatype bst = Leaf | node int bst bst

fun \<alpha> :: "bst \<Rightarrow> (int) set" where
  "\<alpha> Leaf = {}"
| "\<alpha> (node e l r) = {e} \<union> \<alpha> l \<union> \<alpha> r"

value "\<alpha> (node 4 (node 2 (node 1 Leaf Leaf) (node 3 Leaf Leaf)) (node 5 Leaf Leaf))"

fun invar :: "bst \<Rightarrow> bool" where
  "invar Leaf = True"
| "invar (node e l r) = (invar l \<and> invar r \<and> (\<forall>x\<in>(\<alpha> l). e > x) \<and> (\<forall>x\<in>(\<alpha> r). e < x)) "

value "invar (node 4 (node 2 (node 1 Leaf Leaf) (node 3 Leaf Leaf)) (node 5 Leaf Leaf))"
value "invar (node 4 (node 1 (node 2 Leaf Leaf) (node 3 Leaf Leaf)) (node 5 Leaf Leaf))"

fun lookup :: "int \<Rightarrow> bst \<Rightarrow> bool" where
  "lookup e Leaf = False"
| "lookup e (node x l r) = (if e = x then True else (if e > x then lookup e r else lookup e l))"

value "lookup 1 Leaf"
value "lookup 1 (node 1 Leaf Leaf)"
value "lookup 1 (node 2 Leaf Leaf)"
value "lookup 1 (node 4 (node 2 (node 1 Leaf Leaf) (node 3 Leaf Leaf)) (node 5 Leaf Leaf))"
value "lookup 42 (node 4 (node 2 (node 1 Leaf Leaf) (node 3 Leaf Leaf)) (node 5 Leaf Leaf))"
value "lookup 2 (node 4 (node 1 (node 2 Leaf Leaf) (node 3 Leaf Leaf)) (node 5 Leaf Leaf))"

lemma "invar t \<Longrightarrow> lookup x t \<longleftrightarrow> x\<in>\<alpha> t"
  apply(induction t)
  apply(auto)
  done

fun ins :: "int \<Rightarrow> bst \<Rightarrow> bst" where
  "ins e Leaf = (node e Leaf Leaf)"
| "ins e (node x l r) = (if e = x then node x l r else (if e < x then node x (ins e l) r else node x l (ins e r)))"

value "ins -4(ins -9(ins 5(ins 6(ins 56(ins 9(ins 3(ins 1 Leaf)))))))"

lemma ins_correct1: "\<lbrakk>invar t\<rbrakk> \<Longrightarrow> \<alpha> (ins x t) = insert x (\<alpha> t)"
  apply(induction t)
  apply(auto)
  done

lemma ins_correct2: "invar t \<Longrightarrow> invar (ins x t)"
  apply(induction t)
  apply(auto simp add: ins_correct1)
  done

fun dell :: "int \<Rightarrow> bst \<Rightarrow> bst" where
  "dell _ Leaf = Leaf"
| "dell e (node x l r) = (if e = x then (node x Leaf r) else (if e < x then (node x (dell e l) r) else (dell e r)))"

value "dell 5 (node 4 (node 2 (node 1 Leaf Leaf) (node 3 Leaf Leaf)) (node 10 Leaf Leaf))"

lemma dell_correct1: "invar t \<Longrightarrow> \<alpha> (dell a t) = {x\<in>\<alpha> t. x\<ge>a}"
  apply(induction t)
  apply(auto)
  done

lemma dell_correct2: "invar t \<Longrightarrow> invar (dell a t)"
  apply(induction t)
  apply(auto simp add: dell_correct1)
  done

(* Homework 2.2 *)

type_synonym vname = string
type_synonym state = "string \<Rightarrow> int"
type_synonym val = "int"

declare algebra_simps[simp]

datatype aexp = N int | V vname | Plus aexp aexp | Mult int aexp

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n) s = n" |
"aval (V x) s = s x" |
"aval (Plus a1 a2) s = aval a1 s + aval a2 s" |
"aval (Mult i a) s = i * aval a s"

fun normal :: "aexp \<Rightarrow> bool" where
  "normal (N n) = True"
| "normal (V x) = True"
| "normal (Mult i a) = (
    case a of
      (N n) \<Rightarrow> False |
      (V x) \<Rightarrow> True |
      (Mult i a) \<Rightarrow> False |
      (Plus a1 a2) \<Rightarrow> False)"
| "normal (Plus a1 a2) = (normal a1 \<and> normal a2)"

value "normal (Plus (N 6) (Mult 4 (V x)))"
value "normal (Plus (N 6) (Mult 4 (Mult 3 (V y))))"

fun normalize :: "aexp \<Rightarrow> aexp" where
  "normalize (N n) = (N n)"
| "normalize (V x) = (V x)"
| "normalize (Plus a1 a2) = (Plus (normalize a1) (normalize a2))"
| "normalize (Mult i a) = (
    case a of
      (N n) \<Rightarrow> (N (i*n)) |
      (V x) \<Rightarrow> (Mult i (V x)) |
      (Mult x y) \<Rightarrow> normalize (Mult (i*x) y) |
      (Plus x y) \<Rightarrow> (Plus (normalize (Mult i x)) (normalize (Mult i y)))
)"

value "normalize (Plus (N 6) (Mult 4 (Mult 3 (V y))))"
value "normalize (Mult 2 (Plus (V x) (N 21)))"

lemma aux: "aval (normalize a) s = aval a s"
  apply(induction a rule: normalize.induct)
  apply(auto split: aexp.split)
  done

lemma "normal (normalize a)"
  apply(induction a rule: normalize.induct)
  apply(auto simp add: aux split: aexp.split)
  done

end