theory More_Advanced_Topics
imports Main "~~/src/HOL/Library/Monad_Syntax"
begin
(*or more accurately, topics which don't fit elsewhere*)
section\Choice principles\
(*HOL includes an axiomatisation of Hilbert's epsilon operator, which can be used to prove the
axiom of choice (as a theorem). in my opinion working with choice in Isabelle almost always
is an unpleasant experience, which is why it has been left to the very end of the course.
nevertheless, it exists, and can be used like so: *)
term "SOME (x::nat). x div 2 = 0"
term "SOME b. (b \ b) = False"
(*introduction rules*)
thm someI2
thm someI
(*an equivalence*)
thm some_equality
(*foo is some fixed but arbitrary natural number in the set {1,2,3}*)
definition foo :: "nat" where
"foo \ SOME x. x \ {1,2,3}"
(*show that foo is included in the set {1,2,3,4,5}:*)
lemma
shows "foo \ {1,2,3,4,5}"
unfolding foo_def
apply(rule someI2)
apply force
apply force
done
(*another example: the property above uniquely determines b*)
lemma
shows "(SOME b. (b \ b) = False) = False"
apply(rule someI2)
apply force+
done
(*and again...*)
lemma
shows "(SOME b::'a set. (\x::'a set. b \ x = x)) = UNIV"
apply(rule someI2[where a=UNIV])
apply force
apply blast
done
(*the "axiom" of choice is provided as a theorem in the Isabelle library*)
thm choice
(*see the contents of the Hilbert Choice theory for more related material*)
find_theorems name: "Hilbert_Choice"
section\Sledgehammer\
(*Isabelle has an interface to first-order theorem provers and SMT solvers called sledgehammer.
sledgehammer can often solve even moderately hard problems quite easily*)
lemma
assumes "y \ ({ x. P x } \ (Q \ { x. \ P x }))"
shows "y \ R"
(*sledgehammer*) (*invoke sledgehammer like this*)
sorry
lemma
shows "(SOME b. (b \ b) = False) = False"
(*sledgehammer*)
sorry
lemma
shows "[a] = [b] \ a = b"
(*sledgehammer*)
sorry
lemma
shows "y \ { x. P x \ Q x} \ y \ { x. P x } \ y \ { x. Q x}"
(*sledgehammer*)
sorry
lemma
shows "filter (\x. x \ { y. P y \ Q y}) (rev xs) = rev (filter (\x. if Q x then True else if \ P x then True else False) xs)"
by(smt filter_cong mem_Collect_eq rev_filter) (*found by sledgehammer*)
(*note that sledgehammer can find a number of different solutions to problems: sometimes there's a
solution using smt, there's a few using metis, and maybe there's one in isar. sometimes it's
preferable to not include smt and isar solutions. sledgehammer can be configured, like so:*)
(* sledgehammer[no_smt_proofs] *)
(* sledgehammer[no_isar_proofs] *)
(*by default Isabelle uses a number of different theorem provers and SMT solvers that come
prepackaged with the isabelle distribution when sledgehammer is invoked. you can select specific
theorem provers by invoking sledgehammer like so, instead:*)
(* sledgehammer[provers = remote_vampire spass e] *)
(*note that remove_vampire is a version of the vampire theorem prover installed on a server in
Miami, florida, which acts as a "theorem proving service". see the sledgehammer documentation
for a full list of supported theorem provers and smt solvers that you can invoke.*)
(*sledgehammer tends to work *much* better if you presimplify your goal before invoking it:*)
lemma
shows "filter (\x. x \ { y. P y \ Q y}) (rev xs) = rev (filter (\x. if Q x then True else if \ P x then True else False) xs)"
apply clarsimp
(*sledgehammer*)
sorry
section\(Axiomatic) type classes\
(*type classes are used in programming languages like Haskell to handle ad hoc overloading of
constants. Isabelle also has an implementation of type classes, but now one can associate laws
(or axioms) to the type-classes methods to ensure that instances behave in the expected way.*)
(*an additive monoid consists of an associative binary operation ("plus", or "add") with a left and
right identity ("zero"). this idea can be captured in an Isabelle type class, like so:*)
class monoid_add =
fixes add :: "'a \ 'a \ 'a"
and zero :: "'a"
assumes add_zero_ident1 [simp]: "add zero m = m"
and add_zero_ident2 [simp]: "add m zero = m"
and add_assoc [simp]: "add m (add n p) = add (add m n) p"
(*type classes can be thought of as an "interface". instances are an "implementation" of that
"interface". showing that the natural numbers implement the monoid_add interface is done as
follows:*)
instantiation nat :: monoid_add
begin
definition add_nat :: "nat \ nat \ nat" where
"add_nat m n \ m + n"
definition zero_nat :: "nat" where
"zero_nat \ 0"
instance
proof
fix m :: "nat"
show "add zero m = m"
by(auto simp add: add_nat_def zero_nat_def)
next
fix m :: "nat"
show "add m zero = m"
by(auto simp add: add_nat_def zero_nat_def)
next
fix m n p :: "nat"
show "add m (add n p) = add (add m n) p"
by(auto simp add: add_nat_def zero_nat_def)
qed
end
(*we can now evaluate add on natural number arguments, and Isabelle will automatically work out
which instance to use*)
value "add (3::nat) 5"
(*class hierarchies can be built by extending existing type classes, adding new fixed constants and
laws. for example, capturing the notion of a commutative additive monoid merely requires that
we extend the existing monoid type class with a new axiom, like so:*)
class comm_monoid_add = monoid_add +
assumes add_comm [simp]: "add m n = add n m"
(*Isabelle "remembers" that we have already shown that nat is an instance of monoid_add, so all that
is left to prove when showing that nat is also a comm_monoid_add is to demonstrate the
commutativity law:*)
instantiation nat :: comm_monoid_add
begin
instance
proof
fix m n :: "nat"
show "add m n = add n m"
by(auto simp add: add_nat_def)
qed
end
(*one can write functions generic in a type class, such as the following which makes use of the
zero and add constants of the monoid_add class. the 'a::{monoid_add} syntax is a sort constraint
which tells Isabelle to constrain the sort of the type-variable 'a to the monoid_add sort. this
is the mechnanism by which type classes are implemented in Isabelle*)
fun fold :: "'a::{monoid_add} list \ 'a" where
"fold [] = zero" |
"fold (x#xs) = add x (fold xs)"
value "fold [0,1,2,3,4,(5::nat)]"
(*lemmas can also be proved about these generic functions, using the axioms of the type class*)
lemma fold_append_add:
fixes xs :: "'a::{monoid_add} list"
shows "fold (xs@ys) = add (fold xs) (fold ys)"
by(induction xs, auto)
(*type-classes interact well with code generation, being mapped onto dictionary passing or type
classes in the case of Haskell*)
export_code fold in SML
export_code fold in Haskell
(*the Isabelle library has lots of pre-defined type classes*)
print_classes
section\Locales\
(*monoids, again*)
locale monoid_times =
fixes carrier :: "'a set" (*explicit carrier set this time*)
and times :: "'a \ 'a \ 'a"
and one :: "'a"
(*note laws now have closure side-conditions, and we have new closure laws for one and times*)
assumes times_assoc [simp]: "x \ carrier \ y \ carrier \ z \ carrier \ times x (times y z) = times (times x y) z"
and times_ident1 [simp]: "y \ carrier \ times one y = y"
and times_ident2 [simp]: "x \ carrier \ times x one = x"
and one_carrier [intro!, simp]: "one \ carrier"
and times_carrier_closed [intro!, simp]: "x \ carrier \ y \ carrier \ times x y \ carrier"
(*an example of a monoid_times: take the set of natural numbers as the carrier, the multiplication
operation as the times, and one as the unit:*)
interpretation nat_monoid_times: monoid_times "UNIV" "op *" "1::nat"
proof
fix x y z :: "nat"
show "x * (y * z) = x * y * z"
by auto
next
fix y :: "nat"
show "1 * y = y"
by auto
next
fix x :: "nat"
show "x * 1 = x"
by auto
next
show "1 \ UNIV"
by force
next
fix x y :: "nat"
show "x * y \ UNIV"
by force
qed
print_theorems
(*we can define functions and prove theorems "generic" in a monoid_times by using (in monoid_times)
after the definition, fun, lemma, or theorem keyword, like so:*)
fun (in monoid_times) pow :: "'a \ nat \ 'a" where
"pow x 0 = one" |
"pow x (Suc m) = times x (pow x m)"
lemma (in monoid_times) pow_one_m [simp]:
shows "pow one m = one"
by(induction m, auto)
(*alternatively, we can work in a context:*)
context
monoid_times
begin
lemma pow_carrier_closed [intro!]:
assumes "x \ carrier"
shows "pow x m \ carrier"
proof(induction m)
show "pow x 0 \ carrier"
by simp
next
fix m
assume "pow x m \ carrier"
hence "times x (pow x m) \ carrier"
using assms by auto
thus "pow x (Suc m) \ carrier"
by auto
qed
lemma pow_exp_plus [simp]:
assumes "x \ carrier"
shows "pow x (m + n) = times (pow x m) (pow x n)"
proof(induction m)
show "pow x (0 + n) = times (pow x 0) (pow x n)"
by(simp add: pow_carrier_closed assms)
next
fix m
assume "pow x (m + n) = times (pow x m) (pow x n)"
hence "times x (pow x (m + n)) = times x (times (pow x m) (pow x n))"
by auto
hence "pow x (Suc m + n) = times (times x (pow x m)) (pow x n)"
by(simp add: pow_carrier_closed assms)
thus "pow x (Suc m + n) = times (pow x (Suc m)) (pow x n)"
by clarsimp
qed
end
(*extending a locale with new laws:*)
locale comm_monoid_times = monoid_times +
assumes times_comm [simp]: "x \ carrier \ y \ carrier \ times x y = times y x"
(*note how we only have to prove that natural number multiplication commutes here: Isabelle
remembers we have already shown the rest of the monoid laws above for this particular example*)
interpretation comm_monoid_times "UNIV" "op *" "1::nat"
proof
fix x y :: "nat"
show "x * y = y * x"
by auto
qed
(*a lemma generic in commutative multiplicative monoids*)
context
comm_monoid_times
begin
lemma
assumes "x \ carrier"
shows "pow (pow x m) n = pow x (m * n)"
by(induction n, auto simp add: assms)
end
(*abstract theorems on monoid_times and comm_monoid_times are now applicable to concrete examples of
monoids that we have provided an interpretation for...*)
theorem
shows "nat_monoid_times.pow (5::nat) 2 = nat_monoid_times.pow 5 1 * nat_monoid_times.pow 5 1"
by (metis UNIV_I nat_monoid_times.pow_exp_plus one_add_one)
interpretation zero_one_comm_monoid_times: comm_monoid_times "{0::nat, 1}" "op *" "1"
by standard (linarith | force)+ (*a problem!*)
(*let's try to make our use of isabelle's locales a little more sophisticated, and draw a
distinction between the underlying tuple and the algebraic structure imposed on top of it...*)
(*first, we define a record that acts like the underlying tuple of a transition system*)
record ('a, 'b) transition_system =
states :: "'a set" ("\\") (*the \ symbol will be explained below*)
initial_states :: "'a set"
transition :: "'a \ 'a \ bool" (infix "\\" 50)
labels :: "'a \ 'b set" ("\\")
(*the locale fixes a transition_system record, tells isabelle it is the underlying structure for
this locale, and then adds two laws to form a right-serial transition system*)
locale transition_system =
fixes T :: "('a, 'b) transition_system" (structure)
assumes right_serial: "x \ \ \ \y\\. x \ y"
and initial_states_closed [intro!, simp]: "initial_states T \ \"
(*example definition generic in this locale*)
definition (in transition_system) successors :: "'a \ 'a set" where
"successors s \ { x\\. s \ x }"
(*example lemma generic in this locale*)
lemma (in transition_system) successors_not_empty:
assumes "s \ \"
shows "successors s \ {}"
using assms right_serial by(auto simp add: successors_def)
(*the following function unions two transition systems together. note how we can write \\<^bsub>T1\<^esub>,
\\<^bsub>T2\<^esub>, and so on, to refer to components of the transition_system record (where we wrote the \
symbol in the record definition)...*)
definition combine :: "('a, 'b) transition_system \ ('a, 'b) transition_system \ ('a, 'b) transition_system" where
"combine T1 T2 \
\ states = \\<^bsub>T1\<^esub> \ \\<^bsub>T2\<^esub>
, initial_states = initial_states T1 \ initial_states T2
, transition = \x y. (x \\<^bsub>T1\<^esub> y) \ (x \\<^bsub>T2\<^esub> y)
, labels = \x. \\<^bsub>T1\<^esub> x \ \\<^bsub>T2\<^esub> x
\"
(*the combine operation maps transition systems to transition systems*)
theorem
assumes "transition_system T1"
and "transition_system T2"
shows "transition_system (combine T1 T2)"
proof(rule transition_system.intro)
fix x
assume "x \ \\<^bsub>combine T1 T2\<^esub>"
thus "\y\\\<^bsub>combine T1 T2\<^esub>. x \\<^bsub>combine T1 T2\<^esub> y"
using assms transition_system.right_serial by(clarsimp simp add: combine_def) fast
next
show "initial_states (combine T1 T2) \ \\<^bsub>combine T1 T2\<^esub>"
using assms transition_system.initial_states_closed by(clarsimp simp add: combine_def) force
qed
(*isabelle has a lot of pre-defined locales and type classes already in its library...*)
print_locales
(*when to use type-classes, and when to use locales?
- type classes play better with code generation, and executable code
- locales are better when you need to reason about carrier sets, manipulate them, and so on,
- type-classes are limited to a single type-variable: if the domain you are modelling requires
multiple types (e.g. the transition_system example above) then use locales
*)
section\Code generation\
(*Isabelle has a powerful code-generation mechanism that is highly configurable. take a pair of
definitions like so:*)
definition goo :: "int \ int" where
"goo x \ 0 + x"
definition hoo :: "int \ int" where
"hoo x \ x + goo (1 + x)"
(*one can extract SML code easily from this definition*)
export_code hoo in SML
(*but note that "goo" is really the identity function: any argument passed to it is immediately
returned with 0 added to it. we can prove that this is the case, easily. we can also mark this
fact as a [code] equation to be used during code generation:*)
lemma [code]:
shows "goo x = x"
by(auto simp add: goo_def)
(*now compare how Isabelle has extracted goo here to how it extracted it above. Isabelle has now
made use of the above fact to transform the code being extracted using the code equation.*)
export_code hoo in SML
(*what about inductive predicates? can code generation be used for anything useful, there?*)
inductive yoo :: "nat \ nat \ bool" where
"yoo 0 1" |
"yoo m n \ yoo (Suc m) n"
(*note that trying to evaluate yoo on two arguments of the correct type does nothing: Isabelle does
not currently know how to simplify the following to obtain a truth value*)
value "yoo 5 6"
(*using the code_pred mechanism, we can ask Isabelle to extract some functions that will allow us
to programmatically test whether a pair of natural numbers are in the domain of yoo*)
code_pred yoo .
print_theorems
(*now evaluating whether 5 and 6 are in the domain of yoo is straightforward*)
value "yoo 5 6"
(*further, Isabelle has worked out that given just the first argument, it can tell you the possible
values of the second argument, for this particular inductive relation (it performs prolog-style
mode inference to do this). above we saw that Isabelle also extracted yoo_i_o which indicates
that this is a function which given an input will give you an output:*)
value "yoo_i_o 1"
(*extract the output using the following*)
value "Predicate.the (yoo_i_o 1)"
(*note that during code generation, Isabelle will also generate quite a bit of code originating from
the Isabelle library, in support of the functions being extracted. often we want to map some of
this code onto existing functionality of the programming language being targeted, for example
mapping Isabelle's integers onto SML's int datatype, and so on.
for common cases, Isabelle provides several theories that one can simply import into their theory
to affect this mapping. for example, importing
"~~/src/HOL/Library/Code_Target_Nat"
will map isabelle natural numbers onto the integer type of SML, Scala, Haskell or OCaml. several
similar theories (e.g. for strings, integers, and so on) exist in the isabelle library.
for more complex use-cases, however, isabelle provides the code_printing mechanism:*)
definition id :: "'a \ 'a" where
"id x \ x"
definition choo :: "nat" where
"choo \ id 4"
export_code choo in Haskell
code_printing
constant id \ (Haskell) "id"
export_code choo in Haskell
(*which allows one to explicitly tell isabelle to map a HOL constant or type constructor onto a
pre-existing constant or type-constructor in the target language*)
section\Manual termination proofs\
(*Isabelle requires that all recursive functions should be provably terminating, so as to preserve
consistency. what would happen if this were not the case? here's an example:*)
function unsound :: "int \ int" where (*function is similar to fun but requires the user do more*)
"unsound m = 1 + unsound m"
by pat_completeness auto (*prove that pattern matching is complete, and the function well-defined*)
termination unsound (*starts a termination proof for unsound which we will essentially axiomatise with sorry*)
sorry
(*using unsound, we now prove that 0=1, and then as a direct corollary of our proof of 0=1, we can
derive False*)
notepad
begin
have "(0::int) = 1" (*this doesn't seem like a good thing...*)
proof -
have "unsound 0 = 1 + unsound 0"
using unsound.simps by blast
hence "unsound 0 - unsound 0 = 1"
by linarith
thus "0 = 1"
by linarith
qed
hence "False" (*uh oh...*)
by simp
end
(*...and this is why Isabelle requires that recursive functions are provably terminating. in
previous lectures you should have seen that Isabelle is pretty good at spotting when functions
are terminating, and silently produces proofs of that fact behind the scenes.
sometimes, it needs a hand, however. here's how you manually prove termination:*)
(*as mentioned above, function is like fun, but it requires that the user manually prove that the
function definition in question is well-defined and that the function terminates. we can use
function then to show how to prove termination on some simple examples...*)
function eat :: "'a list \ 'a list" where
"eat [] = []" |
"eat [x] = [x]" |
"eat (x#y#xs) = eat xs"
by pat_completeness auto (*these discharge the well-definedness and pattern-match coverage proofs*)
(*note that psimps, pinduct, and so on are generated, but no simps or induct*)
print_theorems
(*start a termination proof with the termination keyword, followed by the name of the function to
prove terminating. isabelle then sets up a termination proof state*)
termination eat
apply(relation "measure (\x::'a list. length x)") (*an explicit measure: at each recursive call the length of the function decreases*)
apply force (*the measure is well-founded (usually very simple)*)
apply force (*the argument to the recursive call is smaller than the original call, per the measure*)
done
(*simplification rules are now generated*)
print_theorems
termination eat
apply lexicographic_order (*this is what isabelle invokes when trying to automatically prove
termination with the "fun" keyword*)
oops
termination eat
apply size_change (*this can solve some termination problems that lexicographic_order cannot, but
tends to be much slower, hence why it is not applied automatically by
isabelle*)
oops
(*one common cause of termination issues is recursion through another function. in this case,
Isabelle is not able to deduce that arguments to recursive calls are strictly smaller,
automatically. for example:*)
definition consume2 :: "'a list \ ('a \ 'a \ 'a list) option" where
"consume2 xs \
case xs of
x#y#xs \ Some (x, y, xs)
| _ \ None"
(*the following function definition fails the automatic termination check as Isabelle cannot see
that the output list of consume2 is strictly smaller than the input*)
(*
fun pairs :: "'a list \ ('a \ 'a) list" where
"pairs xs =
(case consume2 xs of
None \ []
| Some (x, y, xs) \ (x, y)#pairs xs)"
*)
(*instead, a manual termination proof can be used*)
function pairs :: "'a list \ ('a \ 'a) list" where
"pairs xs =
(case consume2 xs of
None \ []
| Some (x, y, xs) \ (x, y)#pairs xs)"
by pat_completeness auto
(*the termination proof requires that we show how the output of consume2 relates to its input*)
lemma consume2_Some:
assumes "consume2 xs = Some zs"
and "zs = (x, y, ys)"
shows "xs = x#y#ys"
using assms by(auto simp add: consume2_def split!: list.split_asm)
(*termination is then easily obtained...*)
termination pairs
apply(relation "measure length")
apply force
apply(drule consume2_Some)
apply force
apply auto
done
(*another, related issue that sometimes crops up:*)
(*a bit of setup, just a standard error monad...*)
datatype 'a error
= Fail "string"
| Success "'a"
definition error_fail :: "string \ 'a error" where
"error_fail \ Fail"
definition error_return :: "'a \ 'a error" where
"error_return = Success"
fun error_bind :: "'a error \ ('a \ 'b error) \ 'b error" where
"error_bind (Fail m) f = Fail m" |
"error_bind (Success s) f = f s"
adhoc_overloading Monad_Syntax.bind error_bind
(*the following function eats a single character from its input list and returns the (hd, tl) pair,
otherwise fails...*)
fun eat_list :: "'a list \ ('a \ 'a list) error" where
"eat_list xs =
(if xs = [] then
error_fail ''eat_list failed''
else
error_return (hd xs, tl xs))"
(*
(*this needs to be **before** the function definition that you are proving terminating:*)
lemma [fundef_cong]:
assumes "map_error f1 e1 = map_error f2 e2"
shows "error_bind e1 f1 = error_bind e2 f2"
sorry
*)
(*a function that converts a list into a list of singleton lists*)
(*fun*) function strange :: "'a list \ ('a list list) error" where
"strange xs =
(if length xs = 0 then
error_return []
else
do { (h, t1) \ eat_list xs
; t2 \ strange t1
; error_return ([h]#t2)
})"
by pat_completeness auto
(*the termination condition that isabelle generates is unproveable. what is going on? note that
the strange function above is recursing through the monadic bind. isabelle does not know what
this monadic bind does to its input: in fact, it could double it, and therefore the function would
not terminate at all. to fix the problem, you have to tell isabelle's termination prover how it
should reason about the monadic bind...*)
termination strange
apply(relation "measure (\l. length l)")
apply auto (* XXX *)
oops
(*once the fundef_cong attribute is added to the lemma above, the termination proof becomes
provable*)
section\Quotients\
(*let's construct the integers from scratch*)
(*a preint is a pair of natural numbers [m, n] which morally represents the integer m-n*)
type_synonym pinteger = "nat \ nat" (*type_synonym introduces a type synonym*)
(*for example, 0 is represented as [0, 0], or [1, 1], or [3, 3], etc. whilst -1 is represented as
[3, 4], or [8, 9], whilst 4 is represented as [8, 4], or [13, 9].
using preints therefore leads to multiple concrete representations (in terms of pairs of naturals)
of the same integer, which is clumsy and annoying. what we would like to do is identify when two
preints describe the same integer and declare them equivalent. once we have identified a suitable
equivalence relation, we can then quotient our preints by this relation to obtain the integers.*)
(*this relation captures when two preints describe the same integer:*)
definition preint_equiv :: "pinteger \ pinteger \ bool" (infix "\" 50) where
"p \ q \ fst p + snd q = fst q + snd p"
(*test it:*)
value "preint_equiv (0, 0) (5, 5)"
value "preint_equiv (3, 4) (8, 9)"
value "preint_equiv (8, 4) (13, 9)"
value "preint_equiv (9, 5) (13, 10)"
(*it seems to work...*)
(*we now quotient the preint type with our equivalence relation using the following quotient_type
command. this opens a new goal asking you to prove that preint_equiv is indeed an equivalence
relation*)
quotient_type integer = pinteger / preint_equiv
proof(rule equivpI)
show "reflp (op \)"
by(auto simp add: reflp_def preint_equiv_def)
next
show "symp (op \)"
by(auto simp add: symp_def preint_equiv_def)
next
show "transp (op \)"
by(auto simp add: transp_def preint_equiv_def)
qed
(*this produces a lot of stuff, too...*)
print_theorems
(*in particular, it produces an "abstraction" and a "representation" function that move between the
abstract type (integers) and the concrete representation (pairs of natural numbers):*)
term Abs_integer
term Rep_integer
(*these two constants are related by a pair of theorems:*)
thm Rep_integer_inverse
thm Abs_integer_inverse
(*let's now define some operations on integers. the easiest one is negation. if [m, n] represents
the integer j, then [n, m] represents the integer -j:*)
definition pinteger_negate :: "pinteger \ pinteger" where
"pinteger_negate p \ (snd p, fst p)"
(*we can lift this definition onto an operation on the integer type as follows:*)
lift_definition negate :: "integer \ integer" is pinteger_negate
proof -
fix p q
assume "p \ q"
hence "fst p + snd q = fst q + snd p"
by(auto simp add: preint_equiv_def)
hence "snd q + fst p = snd p + fst q"
by simp
thus "pinteger_negate p \ pinteger_negate q"
by(auto simp add: preint_equiv_def pinteger_negate_def)
qed
(*note that the lifting requires that we prove that pinteger_negate is well-defined with respect to
preint_equiv (i.e. that it maps equivalent inputs to equivalent outputs)*)
(*another useful definition:*)
lift_definition zero :: "integer" is "(0, 0)" (*note I don't have to introduce a concrete defn first*)
. (*the dot just closes the proof, could also have written "done"*)
(*let us now prove that negation is involutive:*)
lemma negate_invol:
shows "negate (negate i) = i"
proof(transfer) (*the transfer tactic "drops" our goal back to the concrete representation*)
fix p
show "pinteger_negate (pinteger_negate p) \ p"
by(auto simp add: pinteger_negate_def preint_equiv_def)
qed
(*again:*)
lemma negate_0:
shows "negate zero = zero"
proof(transfer)
show "pinteger_negate (0, 0) \ (0, 0)"
by(auto simp add: pinteger_negate_def preint_equiv_def)
qed
(*note in particular that the two lemmas above are now stated in terms of HOL equality, not an
equivalence relation. this means that they can be used for rewriting, automation, and so on just
as any other equality can in Isabelle:*)
lemma
shows "negate (negate (negate zero)) = zero"
by(auto simp add: negate_0 negate_invol)
(*exercise: define integer addition. show that the integers form a commutative monoid under
addition with identity element zero by instantiating the comm_monoid_add class.*)
lift_definition Pos :: "nat \ integer" is "\m. (m, 0)" .
lift_definition Neg :: "nat \ integer" is "\m. (0, Suc m)" .
(*the free_constructors command allows us to essentially treat the integer datatype as if it had
been defined as a sum-of-products type defined with the datatype command. we tell the
free_constructors command that we want to treat integer as if it had been defined with the Pos
and Neg "constructors". this requires that we show that the constructors are "free", that is, we
are required to show the following four things:*)
free_constructors integer for Neg | Pos
proof -
(*the constructors "cover" the type*)
fix P and y :: integer
assume "\x1. y = Neg x1 \ P" and "\x3. y = Pos x3 \ P"
thus "P"
by(transfer, clarsimp simp add: preint_equiv_def)
(metis add.commute add.left_neutral add_Suc less_imp_Suc_add linorder_neqE_nat)
(*sledgehammer to the rescue...*)
next
(*each constructor is injective*)
fix x1 y1
show "(Neg x1 = Neg y1) = (x1 = y1)"
by(transfer, auto simp add: preint_equiv_def)
next
(*each constructor is injective*)
fix x3 y3
show "(Pos x3 = Pos y3) = (x3 = y3)"
by(transfer, auto simp add: preint_equiv_def)
next
(*the constructors are disjoint*)
fix x1 x2
show "Neg x1 \ Pos x2"
by(transfer, auto simp add: preint_equiv_def)
qed
print_theorems
(*now we can define functions on integers as if integers were defined as a datatype:*)
fun abs :: "integer \ integer" where
"abs (Pos m) = Pos m" |
"abs (Neg m) = Pos (Suc m)"
(*and use the cases theorems derived from the free constructors to prove them*)
lemma abs_abs_invol [simp]:
shows "abs (abs i) = abs i"
by(cases i, auto)
(*no incompatibility with code generation, either! (in fact, code generation becomes a lot nicer)*)
export_code abs in OCaml
(*a (hopefully) familiar example*)
datatype ('a, 'b) pprsr =
PPrsr "'a list \ ('a list \ 'b) set"
definition run :: "('a, 'b) pprsr \ 'a list \ ('a list \ 'b) set" where
"run P xs \
case P of
PPrsr f \ f xs"
definition pprsr_equiv :: "('a, 'b) pprsr \ ('a, 'b) pprsr \ bool" where
"pprsr_equiv P Q \ \xs. run P xs = run Q xs"
theorem equivp_pprsr_equiv [intro!]:
shows "equivp pprsr_equiv"
by (rule equivpI) (auto simp add: pprsr_equiv_def reflp_def symp_def transp_def)
quotient_type ('a, 'b) prsr = "('a, 'b) pprsr" / pprsr_equiv
by auto
lift_definition fail :: "('a, 'b) prsr" is "PPrsr (\xs. {})"
.
lift_definition succeed :: "'b \ ('a, 'b) prsr" is "\x. PPrsr (\xs. {(xs, x)})"
.
lift_definition choice :: "('a, 'b) prsr \ ('a, 'b) prsr \ ('a, 'b) prsr" is "\P. \Q. PPrsr (\xs. run P xs \ run Q xs)"
by(auto simp add: pprsr_equiv_def)
lemma
shows "choice P fail = P"
and "choice fail Q = Q"
by (transfer, auto simp add: pprsr_equiv_def run_def)+
section\Typedef\
(*typedef: primitive type definition command that allows you to define a type as a non-empty subset
of an existing type*)
typedef 'a non_empty_list = "{ xs::'a list. length xs \ 0 }"
morphisms to_list of_list (*optional: names of functions that convert back and forth between list and non_empty_lists*)
by force
print_theorems
(*sets up the lifting machinery for use with non_empty_list*)
setup_lifting type_definition_non_empty_list
(*lift definitions into the new type using the same lifting mechanism as above...*)
lift_definition singleton :: "'a \ 'a non_empty_list" is "\x. [x]"
by force
lift_definition map :: "('a \ 'b) \ 'a non_empty_list \ 'b non_empty_list" is List.map
by force
lift_definition rev :: "'a non_empty_list \ 'a non_empty_list" is List.rev
by force
lift_definition append :: "'a non_empty_list \ 'a non_empty_list \ 'a non_empty_list" is List.append
by force
(*and prove properties using transfer*)
lemma rev_append [simp]:
fixes xs ys :: "'a non_empty_list"
shows "rev (append xs ys) = append (rev ys) (rev xs)"
apply transfer
apply force
done
lemma
fixes xs :: "'a non_empty_list"
shows "length (to_list xs) \ 0"
by(transfer, assumption)
lemma
assumes "length xs > 0"
shows "to_list (of_list xs) = xs"
using assms
apply -
apply(rule of_list_inverse) (*auto-generated theorem which connects of_list and to_list together*)
apply force
done
section\Codata (very briefly!)\
(*codata is the dual of data. whereas up until now we have been working with data, which is finite,
to obtain and reason about infinite data like streams, infinite trees, processes, and so on, we
need to consider codata. use the codatatype command to introduce a codatatype:*)
codatatype 'a stream
= Stream (head: 'a) (tail: "'a stream")
print_theorems
(*corecursion is the dual of recursion. use the primcorec command to introduce a primitively
corecursive function, like so:*)
primcorec ones :: "nat stream" where
"ones = Stream 1 ones"
(*note our conception of "termination" is now askew. codata and corecursion have an analogue of the
familiar notion of termination called "productivity"...*)
primcorec zeros :: "nat stream" where
"zeros = Stream 0 zeros"
primcorec zipwith :: "('a \ 'b \ 'c) \ 'a stream \ 'b stream \ 'c stream" where
"zipwith f ss ts = Stream (f (head ss) (head ts)) (zipwith f (tail ss) (tail ts))"
thm ones.simps
thm zipwith.simps
(*properties are proved about codata and corecursive functions using coinduction*)
(*coinduction requires that we prove the heads of the two streams are the same, and that the tails
are also the same*)
thm stream.coinduct
theorem
shows "zipwith (op +) ones zeros = ones"
apply(coinduction rule: stream.coinduct)
apply(intro conjI)
apply force+
done
section\Tips and tricks\
(*when introducing a new definition it's sometimes easier to also introduce an introduction and
destruction rules along with it:*)
definition monoidal :: "('a \ 'a \ 'a) \ 'a \ bool" where
"monoidal f e \
(\x. f x e = x) \
(\