(*
    $Id: ex.thy,v 1.3 2008/07/04 15:37:41 nipkow Exp $
    Author: Stefan Berghofer, Tobias Nipkow
*)

header {* Representation of Propositional Formulae by Polynomials *}

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

text {*
Let the following data type for propositional formulae be given:
*}

datatype form = T | Var nat | And form form | Xor form form

text {*
Here @{term "T"} denotes a formula that is always true, @{term "Var n"} denotes
a propositional variable, its name given by a natural number, @{term "And f1
f2"} denotes the AND combination, and @{term "Xor f1 f2"} the XOR (exclusive or)
combination of two formulae.  A constructor @{term "F"} for a formula that is
always false is not necessary, since @{term "F"} can be expressed by @{term "Xor
T T"}.

{\bf Exercise 1:} Define a function
*}

(*<*)consts(*>*)  evalf :: "(nat \<Rightarrow> bool) \<Rightarrow> form \<Rightarrow> bool"

text {*
that evaluates a formula under a given variable assignment.
*}

text {*
Propositional formulae can be represented by so-called {\it polynomials}.  A
polynomial is a list of lists of propositional variables, i.e.\ an element of
type @{typ "nat list list"}.  The inner lists (the so-called {\it monomials})
are interpreted as conjunctive combination of variables, whereas the outer list
is interpreted as exclusive-or combination of the inner lists.

{\bf Exercise 2:} Define two functions
*}

(*<*)consts(*>*)
  evalm :: "(nat \<Rightarrow> bool) \<Rightarrow> nat list \<Rightarrow> bool"
  evalp :: "(nat \<Rightarrow> bool) \<Rightarrow> nat list list \<Rightarrow> bool"

text {*
for evaluation of monomials and polynomials under a given variable assignment.
In particular think about how empty lists have to be evaluated.
*}

text {*
{\bf Exercise 3:} Define a function
*}

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

text {*
that turns a formula into a polynomial.  You will need an auxiliary function
*}

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

text {*
to ``multiply'' two polynomials, i.e.\ to compute
\[
((v^1_1 \mathbin{\odot} \cdots \mathbin{\odot} v^1_{m_1}) \mathbin{\oplus} \cdots \mathbin{\oplus} (v^k_1 \mathbin{\odot} \cdots \mathbin{\odot} v^k_{m_k})) \mathbin{\odot}
((w^1_1 \mathbin{\odot} \cdots \mathbin{\odot} w^1_{n_1}) \mathbin{\oplus} \cdots \mathbin{\oplus} (w^l_1 \mathbin{\odot} \cdots \mathbin{\odot} w^l_{n_l}))
\]
where $\mathbin{\oplus}$ denotes ``exclusive or'', and $\mathbin{\odot}$ denotes
``and''.  This is done using the usual calculation rules for addition and
multiplication.
*}

text {*
{\bf Exercise 4:} Now show correctness of your function @{term "poly"}:
*}

theorem poly_correct: "evalf e f = evalp e (poly f)"
(*<*) oops (*>*)

text {*
It is useful to prove a similar correctness theorem for @{term "mulpp"} first.
*}

(*<*) end (*>*)


theory Naturales
imports Main
begin

section "Ejemplo de cálculo con los naturales"

value "Suc 0 + Suc (Suc 0)"
  (* da "Suc (Suc (Suc 0))" *)
value "Suc (Suc (Suc 0)) - Suc (Suc 0)"
  (* da "Suc 0" *)
value "Suc (Suc 0) - Suc (Suc (Suc 0))"
  (* da "0" *)
value "Suc (Suc 0) * Suc (Suc (Suc 0))"
  (* da "Suc (Suc (Suc (Suc (Suc (Suc 0)))))" *)
value "int (Suc (Suc 0) * Suc (Suc (Suc 0)))"
  (* da  "6" :: int *)
value "int (Suc (Suc 0) ^ Suc (Suc (Suc 0)))"
  (* da "8" *)
value "Suc (Suc (Suc (Suc (Suc (Suc 0))))) div Suc (Suc 0)"
  (* da "Suc (Suc (Suc 0))" *)
value "Suc (Suc (Suc (Suc (Suc 0)))) div Suc (Suc 0)"
  (* da "Suc (Suc 0)" *)
value "Suc (Suc (Suc (Suc (Suc 0)))) mod Suc (Suc 0)"
  (* da "Suc 0" *)
value "Suc 0 + Suc 0 < Suc (Suc (Suc 0))"
  (* da True *)
value "Suc 0 + Suc 0 < Suc (Suc 0)"
  (* da False *)
value "max (Suc 0 + Suc 0) (Suc (Suc (Suc 0)))"
  (* da "Suc (Suc (Suc 0))" *)
value "min (Suc 0 + Suc 0) (Suc (Suc (Suc 0)))"
  (* da "Suc (Suc 0)" *)

section "Ejemplo de definición recursiva sobre los naturales"

text {* (suma m n) es la suma de los números naturales m y n. Por
  ejemplo,
     suma (Suc (Suc 0)) (Suc (Suc (Suc 0)))
     = Suc (Suc (Suc (Suc (Suc 0))))
*}
fun suma :: "nat \<Rightarrow> nat \<Rightarrow> nat"
where
  "suma 0 n       = n"
| "suma (Suc m) n = Suc (suma m n)"

value "suma (Suc (Suc 0)) (Suc (Suc (Suc 0)))"
value "int (suma (Suc (Suc 0)) (Suc (Suc (Suc 0))))"
lemma "suma (Suc (Suc 0)) (Suc (Suc (Suc 0)))
       = Suc (Suc (Suc (Suc (Suc 0))))" by simp

section "Ejemplo de demostración pos inducción sobre los naturales"

text {* En esta sección se demuestra, por inducción sobre los naturales,
  que 0 es el neutro por la derecha de la suma. *}

text {* Demostración aplicativa *}
lemma suma_0:
  "suma m 0 = m"
apply (induction m)
apply auto
done

text {* Demostración estructurada *}
lemma suma_0':
  "suma m 0 = m"
by (induction m) auto

text {* Los lemas demostrado se pueden consultar son thm *}
thm suma_0
  (* da "suma ?m 0 = ?m" *)

text {*  Los lemas demostrado se pueden consultar son thm y no_vars *}
thm suma_0 [no_vars]
  (* da "suma m 0 = m" *)

end


(*  Title:  HOL/ex/NatSum.thy
    Author: Tobias Nipkow
*)

section {* Summing natural numbers *}

theory NatSum imports Main begin

text {*
  Summing natural numbers, squares, cubes, etc.

  Thanks to Sloane's On-Line Encyclopedia of Integer Sequences,
  @{url "http://www.research.att.com/~njas/sequences/"}.
*}

lemmas [simp] =
  ring_distribs
  diff_mult_distrib diff_mult_distrib2 --{*for type nat*}

text {*
  \medskip The sum of the first @{text n} odd numbers equals @{text n}
  squared.
*}

lemma sum_of_odds: "(\<Sum>i=0..<n. Suc (i + i)) = n * n"
  by (induct n) auto

text {*
  \medskip The sum of the first @{text n} odd squares.
*}

lemma sum_of_odd_squares:
  "3 * (\<Sum>i=0..<n. Suc(2*i) * Suc(2*i)) = n * (4 * n * n - 1)"
  by (induct n) auto

text {*
  \medskip The sum of the first @{text n} odd cubes
*}

lemma sum_of_odd_cubes:
  "(\<Sum>i=0..<n. Suc (2*i) * Suc (2*i) * Suc (2*i)) =
    n * n * (2 * n * n - 1)"
  by (induct n) auto

text {*
  \medskip The sum of the first @{text n} positive integers equals
  @{text "n (n + 1) / 2"}.*}

lemma sum_of_naturals:
    "2 * (\<Sum>i=0..n. i) = n * Suc n"
  by (induct n) auto

lemma sum_of_squares:
    "6 * (\<Sum>i=0..n. i * i) = n * Suc n * Suc (2 * n)"
  by (induct n) auto

lemma sum_of_cubes:
    "4 * (\<Sum>i=0..n. i * i * i) = n * n * Suc n * Suc n"
  by (induct n) auto

text{* \medskip A cute identity: *}

lemma sum_squared: "(\<Sum>i=0..n. i)^2 = (\<Sum>i=0..n::nat. i^3)"
proof(induct n)
  case 0 show ?case by simp
next
  case (Suc n)
  have "(\<Sum>i = 0..Suc n. i)^2 =
        (\<Sum>i = 0..n. i^3) + (2*(\<Sum>i = 0..n. i)*(n+1) + (n+1)^2)"
    (is "_ = ?A + ?B")
    using Suc by(simp add:eval_nat_numeral)
  also have "?B = (n+1)^3"
    using sum_of_naturals by(simp add:eval_nat_numeral)
  also have "?A + (n+1)^3 = (\<Sum>i=0..Suc n. i^3)" by simp
  finally show ?case .
qed

text {*
  \medskip Sum of fourth powers: three versions.
*}

lemma sum_of_fourth_powers:
  "30 * (\<Sum>i=0..n. i * i * i * i) =
    n * Suc n * Suc (2 * n) * (3 * n * n + 3 * n - 1)"
  apply (induct n)
   apply simp_all
  apply (case_tac n)  -- {* eliminates the subtraction *}
   apply (simp_all (no_asm_simp))
  done

text {*
  Two alternative proofs, with a change of variables and much more
  subtraction, performed using the integers. *}

lemma int_sum_of_fourth_powers:
  "30 * int (\<Sum>i=0..<m. i * i * i * i) =
    int m * (int m - 1) * (int(2 * m) - 1) *
    (int(3 * m * m) - int(3 * m) - 1)"
  by (induct m) (simp_all add: int_mult)

lemma of_nat_sum_of_fourth_powers:
  "30 * of_nat (\<Sum>i=0..<m. i * i * i * i) =
    of_nat m * (of_nat m - 1) * (of_nat (2 * m) - 1) *
    (of_nat (3 * m * m) - of_nat (3 * m) - (1::int))"
  by (induct m) (simp_all add: of_nat_mult)

text {*
  \medskip Sums of geometric series: @{text 2}, @{text 3} and the
  general case.
*}

lemma sum_of_2_powers: "(\<Sum>i=0..<n. 2^i) = 2^n - (1::nat)"
  by (induct n) (auto split: nat_diff_split)

lemma sum_of_3_powers: "2 * (\<Sum>i=0..<n. 3^i) = 3^n - (1::nat)"
  by (induct n) auto

lemma sum_of_powers: "0 < k ==> (k - 1) * (\<Sum>i=0..<n. k^i) = k^n - (1::nat)"
  by (induct n) auto

end


theory Girth_Independence imports Connectivity
begin

section \<open> Girth and Independence \<close>
text \<open> We translate and extend on a number of definitions and lemmas on girth and independence
from Noschinski's ugraph representation \<^cite>\<open>"noschinski_2012"\<close>. \<close>

context sgraph
begin

definition girth :: "enat" where
  "girth \<equiv> INF p\<in> cycles. enat (walk_length p)"

lemma girth_acyclic: "cycles = {} \<Longrightarrow> girth = \<infinity>"
  unfolding girth_def using top_enat_def by simp

lemma girth_lte: "c \<in> cycles \<Longrightarrow> girth \<le> walk_length c"
  using girth_def INF_lower by auto

lemma girth_obtains:
  assumes "girth \<noteq> top"
  obtains c where "c \<in> cycles" and "walk_length c = girth"
  using enat_in_INF girth_def assms by (metis (full_types) the_enat.simps)

lemma girthI:
  assumes "c' \<in> cycles"
  assumes "\<And> c . c \<in> cycles \<Longrightarrow> walk_length c' \<le> walk_length c"
  shows "girth = walk_length c'"
proof (rule ccontr)
  assume "girth \<noteq> walk_length c'"
  then have "girth < walk_length c'"
    using  assms girth_lte by fastforce
  then obtain c where "c \<in> cycles" and "walk_length c < walk_length c'"
    using girth_def by (metis enat_ord_simps(2) girth_obtains infinity_ilessE top_enat_def)
  thus False using assms(2) less_imp_le_nat le_antisym
    by fastforce
qed

lemma (in fin_sgraph) girth_min_alt:
  assumes "cycles \<noteq> {}"
  shows "girth = Min ((\<lambda> c . enat (walk_length c)) ` cycles)" (is "girth = Min ?A")
  unfolding girth_def using finite_cycles assms Min_Inf
  by (metis (full_types) INF_le_SUP bot_enat_def ccInf_empty ccSup_empty enat_ord_code(5) finite_imageI top_enat_def zero_enat_def)

definition is_independent_set :: "'a set \<Rightarrow> bool" where
"is_independent_set vs \<equiv> vs \<subseteq> V \<and> (all_edges vs) \<inter> E = {}"

text \<open> A More mathematical way of thinking about it \<close>
lemma is_independent_alt: "is_independent_set vs \<longleftrightarrow> vs \<subseteq> V \<and> (\<forall> v \<in> vs. \<forall> u \<in> vs. \<not> vert_adj v u)"
  unfolding is_independent_set_def
proof (auto)
  fix v u assume ss: "vs \<subseteq> V" and inter: "all_edges vs \<inter> E = {}" and vin: "v \<in> vs" and uin: "u \<in> vs" and adj: "vert_adj v u"
  then have inE: "{v, u} \<in> E" using vert_adj_def by simp
  then have imp: "{v, u} \<in> all_edges vs" using vin uin e_in_all_edges_ss vin uin
    by (simp add: ss)
  then show False
    using inE inter by blast
next
  fix x assume "vs \<subseteq> V" "\<forall>v\<in>vs. \<forall>u\<in>vs. \<not> vert_adj v u"  "x \<in> all_edges vs" "x \<in> E"
  then have "\<And> u v. {u, v} \<subseteq> vs \<Longrightarrow> {u, v} \<notin> E" by (simp add: vert_adj_def)
  then have "\<And> x . x \<subseteq> vs \<Longrightarrow> card x = 2 \<Longrightarrow> x \<notin> E" by (metis card_2_iff)
  then show False using all_edges_def
    by (metis (mono_tags, lifting) \<open>x \<in> E\<close> \<open>x \<in> all_edges vs\<close> mem_Collect_eq)
qed

lemma singleton_independent_set: "v \<in> V \<Longrightarrow> is_independent_set {v}"
  by (metis empty_subsetI insert_absorb2 insert_subset is_independent_alt
      singletonD singleton_not_edge vert_adj_def)

definition independent_sets :: "'a set set" where
  "independent_sets \<equiv> {vs. is_independent_set vs}"

definition independence_number :: "enat"  where
   "independence_number \<equiv> SUP vs \<in> independent_sets. enat (card vs)"

abbreviation "\<alpha> \<equiv> independence_number"

lemma independent_sets_mono:
  "vs \<in> independent_sets  \<Longrightarrow> us \<subseteq> vs \<Longrightarrow> us \<in> independent_sets "
  using Int_mono[OF all_edges_mono, of us vs "E" "E"]
  unfolding independent_sets_def is_independent_set_def by auto

lemma le_independence_iff:
  assumes "0 < k"
  shows "k \<le> \<alpha> \<longleftrightarrow> k \<in> card ` independent_sets " (is "?L \<longleftrightarrow> ?R")
proof
  assume ?L
  then obtain vs where "vs \<in> independent_sets " and klt: "k \<le> card vs"
    using assms unfolding independence_number_def enat_le_Sup_iff by auto
  moreover
  obtain us where "us \<subseteq> vs" and "k = card us"
    using card_Ex_subset  klt by auto
  ultimately
  have "us \<in> independent_sets "  by (auto intro: independent_sets_mono)
  then show ?R using \<open>k = card us\<close> by auto
qed (auto intro: SUP_upper simp: independence_number_def)

lemma zero_less_independence:
  assumes "V \<noteq> {}"
  shows "0 < \<alpha>"
proof -
  from assms obtain a where "a \<in> V" by auto
  then have "0 < enat (card {a})" "{a} \<in> independent_sets"
    using independent_sets_def is_independent_set_def all_edges_def singleton_independent_set by simp_all
  then show ?thesis unfolding independence_number_def less_SUP_iff ..
qed

end

context fin_sgraph
begin
lemma fin_independent_sets: "finite (independent_sets)"
  unfolding independent_sets_def is_independent_set_def using finV by auto

lemma independence_le_card:
  shows "\<alpha>  \<le> card V"
proof -
  { fix x assume "x \<in> independent_sets "
    then have "x \<subseteq> V" by (auto simp: independent_sets_def is_independent_set_def) }
  with finV show ?thesis unfolding independence_number_def
    by (intro SUP_least) (auto intro: card_mono)
qed

lemma independence_fin: "\<alpha> \<noteq> \<infinity>"
  using independence_le_card by (cases "\<alpha>") auto

lemma independence_max_alt: "V \<noteq> {} \<Longrightarrow> \<alpha> = Max ((\<lambda> vs . enat (card vs)) ` independent_sets)"
  unfolding independence_number_def using Sup_enat_def zero_less_independence
  by (metis i0_less independence_fin independence_number_def)

lemma independent_sets_ne:
  assumes "V \<noteq> {}"
  shows "independent_sets \<noteq> {}"
proof -
  from assms obtain a where "a \<in> V" by auto
  then have "{a} \<in> independent_sets" using independent_sets_def singleton_independent_set by simp
  thus ?thesis by blast
qed

lemma independence_obtains:
  assumes "V \<noteq> {}"
  obtains vs where "is_independent_set vs" and "card vs = \<alpha>"
proof -
  have "\<alpha> = Max ((\<lambda> vs . enat (card vs)) ` independent_sets)" using independence_max_alt assms by simp
  then obtain vs where "vs \<in> independent_sets" and "enat (card vs) = \<alpha>"
    using obtains_MIN[of "independent_sets" "\<lambda> vs . enat (card vs)"] assms fin_independent_sets independent_sets_ne
    by (metis (no_types, lifting) Max_in finite_imageI imageE image_is_empty)
  thus ?thesis using independent_sets_def that by simp
qed
end
end


(*
    $Id: sol.thy,v 1.5 2011/06/28 18:11:37 webertj Exp $
    Author: Gerwin Klein, Isar solution by Christian Sternagl
*)

header {* Merge Sort *}

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

subsection {* Sorting with lists *}

text {*
  For simplicity we sort natural numbers.

  Define a predicate @{term sorted} that checks if each element in the list is
  less or equal to the following ones; @{term "le n xs"} should be true iff
  @{term n} is less or equal to all elements of @{text xs}.
*}

primrec le :: "nat \<Rightarrow> nat list \<Rightarrow> bool" where
  "le a []     = True"
| "le a (x#xs) = (a <= x & le a xs)"

primrec sorted :: "nat list \<Rightarrow> bool" where
  "sorted []     = True"
| "sorted (x#xs) = (le x xs & sorted xs)"

text {*
  Define a function @{term "count xs x"} that counts how often @{term x} occurs
  in @{term xs}.
*}

primrec count :: "nat list => nat => nat" where
  "count []     y = 0"
| "count (x#xs) y = (if x=y then Suc(count xs y) else count xs y)"

subsection {* Merge sort *}

text {*
  Implement \emph{merge sort}: a list is sorted by splitting it into two lists,
  sorting them separately, and merging the results.

  Define the two functions @{term "merge :: nat list \<Rightarrow> nat list
  \<Rightarrow> nat list"} and @{term "msort :: nat list \<Rightarrow> nat
  list"} for merging and sorting, respectively.
*}

fun
 merge :: "nat list \<Rightarrow> nat list \<Rightarrow> nat list"
where
 "merge [] ys = ys" |
 "merge xs [] = xs" |
 "merge (x # xs) (y # ys) = (
   if x \<le> y
     then x # merge xs (y # ys)
     else y # merge (x # xs) ys
 )"

fun
 msort :: "nat list \<Rightarrow> nat list"
where
 "msort [] = []" |
 "msort [x] = [x]" |
 "msort xs = (
   let half = length xs div 2 in
   merge (msort (take half xs)) (msort (drop half xs))
 )"

lemma [simp]: "count (merge xs ys) x = count xs x + count ys x"
  apply(induct xs ys rule: merge.induct)
  apply auto
done

lemma [simp]: "le x (merge xs ys) = (le x xs \<and> le x ys)"
  apply (induct xs ys rule: merge.induct)
  apply auto
done

lemma [simp]: "sorted (merge xs ys) = (sorted xs \<and> sorted ys)"
  apply(induct xs ys rule: merge.induct)
  apply (auto simp add: linorder_not_le order_less_le)
done

lemma [simp]: "1 < x \<Longrightarrow> min x (x div 2::nat) < x"
  by (simp add: min_def linorder_not_le)

lemma [simp]: "1 < x \<Longrightarrow> x - x div (2::nat) < x"
  by arith

theorem "sorted (msort xs)"
  apply (induct_tac xs rule: msort.induct)
  apply auto
done

lemma count_append[simp]: "count (xs @ ys) x = count xs x + count ys x"
  apply (induct xs)
  apply auto
done

theorem "count (msort xs) x = count xs x"
  apply (induct xs rule: msort.induct)
      apply simp
    apply simp
  apply simp
  apply (simp del:count_append add:count_append[symmetric])
done

subsection {* An alternative solution in Isabelle/Isar *}

text {*
If some element @{term "x"} is less than or equal to all elements of the
lists @{term "ys"} and @{term zs}, then this also holds true for the merged
lists.
*}
lemma le_merge[simp]:
 assumes "le x ys" and "le x zs" shows "le x (merge ys zs)"
using assms by (induct ys zs rule: merge.induct) simp_all

lemma le_le_simps[simp]:
 "x \<le> y \<Longrightarrow> le y ys \<Longrightarrow> le x ys"
 "\<not> x \<le> y \<Longrightarrow> le x xs \<Longrightarrow> le y xs"
by (induct ys, simp_all) (induct xs, simp_all)

text {*
Merging lists preserves sortedness.
*}
lemma sorted_merge[simp]:
 assumes "sorted xs" and "sorted ys" shows "sorted (merge xs ys)"
using assms by (induct xs ys rule: merge.induct) simp_all

text {*
The result of @{term "msort xs"} is a sorted list.
*}
theorem "sorted (msort xs)" by (induct xs rule: msort.induct) simp_all

text {*
Merging does neither remove nor add elements.
*}
lemma count_merge: "count (merge xs ys) x = count xs x + count ys x"
by (induct xs ys rule: merge.induct) auto

lemma cnt_append: "count (xs @ ys) x = count xs x + count ys x"
by (induct xs) auto

lemma take_drop_count: "count (take n xs) x + count (drop n xs) x = count xs x"
unfolding count_append[symmetric] by simp

text {*
Sorting does neither remove nor add elements (important, since functions
like @{term "wrong_sort xs = []"} would also satisfy @{term "sorted
(wrong_sort xs)"}).
*}
theorem "count (msort xs) x = count xs x"
by (induct xs rule: msort.induct) (simp_all add: take_drop_count)

(*<*) end (*>*)


theory OptBoundTimeInterval
  imports SemanticsTypes
begin

chapter "Time Interval"
text
\<open>
A BEndpoint represents either an Unbounded (-\infty  or \infty) endpoint or a closed (inclusive) bounded
endpoint.
\<close>
datatype BEndpoint =
  Unbounded
  | Bounded POSIXTime

text
\<open>
An Optionally bounded TimeInterval, is a normal TimeInterval  that might be unbounded on the
left or right.
\<close>
type_synonym OptBoundTimeInterval = "BEndpoint \<times> BEndpoint"

text
\<open>
We can think of an \<^emph>\<open>OptBoundTimeInterval\<close> as sets with four possible options:
\<^item> Totally unbound: (-\infty, \infty)
\<^item> Left bound [low, \infty)
\<^item> Right bound (-\infty, high]
\<^item> Bound [low, high].
\<close>
fun bToSet :: "OptBoundTimeInterval => POSIXTime set" where
   "bToSet (Unbounded, Unbounded)   = {x. True}"
 | "bToSet (Bounded l, Unbounded)   = {l..}"
 | "bToSet (Unbounded, Bounded r) = {..r}"
 | "bToSet (Bounded l, Bounded r) = {l..r}"

section "Interval intesection"

text
\<open>
The interval intersection is achieved by calculating the maximum lower bound and the minimum
higher bound, favouring Bounded to Unbounded endpoits.
\<close>
fun maxLow :: "BEndpoint \<Rightarrow> BEndpoint \<Rightarrow> BEndpoint" where
  "maxLow Unbounded y = y"
| "maxLow x Unbounded = x"
| "maxLow (Bounded x) (Bounded y) = Bounded (max x y)"

fun minHigh :: "BEndpoint \<Rightarrow> BEndpoint \<Rightarrow> BEndpoint" where
  "minHigh Unbounded y = y"
| "minHigh x Unbounded = x"
| "minHigh (Bounded x) (Bounded y) = Bounded (min x y)"

fun intersectInterval :: "OptBoundTimeInterval \<Rightarrow> OptBoundTimeInterval \<Rightarrow> OptBoundTimeInterval"
where
 "intersectInterval (low1, high1) (low2, high2)
    = (maxLow low1 low2, minHigh high1 high2)"

subsection "Associativity"
text
\<open>
Every function related to Interval Intersection is associative
\<close>

lemma(*<*)maxLow_assoc [simp]:(*>*)
 "maxLow (maxLow a b) c = maxLow a (maxLow b c)"
(*<*)
  apply (cases a)
   apply simp
  apply (cases b)
   apply simp
  apply (cases c)
  by auto
(*>*)

lemma(*<*)minHigh_assoc [simp]:(*>*)
 "minHigh (minHigh a b) c = minHigh a (minHigh b c)"
(*<*)
  apply (cases a)
   apply simp
    apply (cases b)
   apply simp
  apply (cases c)
  by auto
(*>*)

interpretation semigroup "intersectInterval"
(*<*)
  apply (unfold_locales)
  subgoal for a b c
    by (metis OptBoundTimeInterval.intersectInterval.simps maxLow_assoc minHigh_assoc surj_pair)
  done
(*>*)

subsection "Commutative"
text
\<open>
Every function related to Interval Intersection is commutative
\<close>

lemma(*<*)maxLow_comm [simp]:(*>*)
 "maxLow a b = maxLow b a"
  (*<*)
  apply (cases a)
  apply (metis OptBoundTimeInterval.BEndpoint.exhaust OptBoundTimeInterval.maxLow.simps(1) OptBoundTimeInterval.maxLow.simps(2))
   apply auto
   apply (cases b)
  by auto
  (*>*)

lemma(*<*)minHigh_comm [simp]:(*>*)
 "minHigh a b = minHigh b a"
  (*<*)
  apply (cases a)
  apply (metis OptBoundTimeInterval.BEndpoint.distinct(1) OptBoundTimeInterval.minHigh.elims)
   apply auto
   apply (cases b)
  by auto
  (*>*)

interpretation abel_semigroup "intersectInterval"
  (*<*)
  apply unfold_locales
  subgoal for a b
    by (metis (no_types, opaque_lifting) OptBoundTimeInterval.intersectInterval.elims fst_conv maxLow_comm minHigh_comm snd_conv)
  done
  (*>*)

subsection "intersectInterval is set intersection"
text
\<open>
This section proves that the function \<^emph>\<open>intersectInterval\<close> behaves the same as set intersection. In order to
prove that theorem we have the following lemmas
\<close>
lemma (*<*)belongsToSubBelongsToSet_low_1:(*>*)
  "x \<in> bToSet (maxLow l1 l2, r) \<Longrightarrow> x \<in> bToSet (l1, r)"

(*<*)
  apply (cases l1)
   apply auto
   apply (metis BEndpoint.exhaust bToSet.simps(1) bToSet.simps(3) bToSet.simps(4) atLeastAtMost_iff atMost_iff mem_Collect_eq)
  apply (cases l2)
  apply auto
  by (metis Lattices.linorder_class.max.bounded_iff BEndpoint.exhaust bToSet.simps(2) bToSet.simps(4) atLeastAtMost_iff atLeast_iff)
(*>*)

lemma (*<*)belongsToSubBelongsToSet_low_2:(*>*)
  "x \<in> bToSet (maxLow l1 l2, r) \<Longrightarrow> x \<in> bToSet (l2, r)"

(*<*)
  apply (cases l1)
  by auto (smt (verit, best) BEndpoint.exhaust maxLow.simps(1) maxLow.simps(3) belongsToSubBelongsToSet_low_1)
(*>*)

lemma (*<*)belongsToSubBelongsToSet_high_1:(*>*)
  "x \<in> bToSet (l, minHigh r1 r2) \<Longrightarrow> x \<in> bToSet (l, r1)"

(*<*)
  apply (induction r1 arbitrary: l)
   apply auto
     apply (cases r2)
    apply auto
   apply (metis BEndpoint.exhaust bToSet.simps(1) bToSet.simps(2) bToSet.simps(4) UNIV_I UNIV_def atLeastAtMost_iff atLeast_iff)
  by (smt (verit, best) BEndpoint.distinct(1) BEndpoint.inject minHigh.elims bToSet.elims Pair_inject atLeastAtMost_iff atMost_iff)
(*>*)

lemma (*<*)belongsToSubBelongsToSet_high_2:(*>*)
  "x \<in> bToSet (l, minHigh r1 r2) \<Longrightarrow> x \<in> bToSet (l, r2)"

(*<*)
  apply (cases r1)
   apply auto
  by (smt (verit, best) BEndpoint.exhaust minHigh.simps(1) minHigh.simps(3) belongsToSubBelongsToSet_high_1)
(*>*)

lemma (*<*)belongsToSubSet_BelongsToMaxLowSet [simp]:(*>*)
  "x \<in> bToSet (l1, r) \<and> x \<in> bToSet (l2, r) \<Longrightarrow> x \<in> bToSet (maxLow l1 l2, r)"

(*<*)
  apply (cases l1)
   apply auto
  apply (cases l2)
   apply auto
  by linarith
(*>*)

lemma (*<*)belongsToSubSet_BelongsToMinHighSet [simp]:(*>*)
  "x \<in> bToSet (l, r1) \<and> x \<in> bToSet (l, r2) \<Longrightarrow> x \<in> bToSet (l, minHigh r1 r2)"

(*<*)
  apply (cases r1)
   apply auto
  apply (cases r2)
   apply auto
  by linarith
(*>*)

lemma (*<*)belongsToSubSet_BelongsToSet:(*>*)
"x \<in> bToSet (l1, r1) \<and> x \<in> bToSet (l2, r2) \<Longrightarrow> x \<in> bToSet (maxLow l1 l2, minHigh r1 r2)"

(*<*)
  apply (induction l1 arbitrary: r1)
   apply (auto)
   apply (metis BEndpoint.exhaust minHigh.simps(1) bToSet.simps(2) bToSet.simps(3) bToSet.simps(4) belongsToSubBelongsToSet_high_1 atLeastAtMost_iff atLeast_iff atMost_iff belongsToSubSet_BelongsToMinHighSet)
  apply (induction l2 arbitrary: r2)
   apply auto
  apply (metis BEndpoint.exhaust bToSet.simps(2) bToSet.simps(3) bToSet.simps(4) atLeastAtMost_iff atLeast_iff atMost_iff belongsToSubSet_BelongsToMinHighSet)
  by (metis Lattices.linorder_class.max.absorb_iff2 Lattices.linorder_class.max.commute BEndpoint.exhaust bToSet.simps(2) bToSet.simps(4) atLeastAtMost_iff atLeast_iff belongsToSubSet_BelongsToMinHighSet nle_le)
(*>*)

theorem (*<*)intersectIntervalIsIntersect:(*>*)
"bToSet (intersectInterval a b) = bToSet a \<inter> bToSet b"

(*<*)
  apply (cases a)
    apply (cases b)
  apply auto
  using belongsToSubBelongsToSet_low_1 belongsToSubBelongsToSet_high_1 apply blast
  using belongsToSubBelongsToSet_low_2 belongsToSubBelongsToSet_high_2 apply blast
  using belongsToSubSet_BelongsToSet by presburger
(*>*)

section "In Interval"

text \<open>
The inInterval function checks if a closed and bounded Time Interval is inside
an optional bounded closed time interval
\<close>
fun inInterval :: "TimeInterval \<Rightarrow> OptBoundTimeInterval \<Rightarrow> bool" where
"inInterval (min1, max1) (Unbounded, Unbounded) = True" |
"inInterval (_, max1) (Unbounded, Bounded max2) = (max1 \<le> max2)" |
"inInterval (min1, _) (Bounded min2, Unbounded) = (min1 \<ge> min2)" |
"inInterval (min1, max1) (Bounded min2, Bounded max2) = (min1 \<ge> min2 \<and> max1 \<le> max2)"

text
\<open>
We can think of a TimeInterval as the set of times included by the boundaries
\<close>
fun tToSet :: "TimeInterval \<Rightarrow> POSIXTime set" where
  "tToSet (l, r) = {l..r}"

subsubsection "In interval implies a subset"

text
\<open>
A Time Interval is valid only if the left bound is lower or equal than the higher bound.
\<close>

fun validTimeInterval :: "TimeInterval \<Rightarrow> bool" where
  "validTimeInterval (l, r) = (l \<le> r)"

text
\<open>
If the Time Interval is valid, then the \<^emph>\<open>inInterval\<close> function implies a subset.
\<close>
theorem inInterval_subset:
  "validTimeInterval a \<Longrightarrow> inInterval a b = (tToSet a \<subseteq> bToSet b)"

(*<*)
  apply (cases a)
  apply (cases b)
  apply auto
  using OptBoundTimeInterval.inInterval.elims(2) apply fastforce
  using OptBoundTimeInterval.inInterval.elims(3) by fastforce
(*>*)

end


theory Chap2
imports Main
begin
value "1 + (2::nat)"
value "1 + (2::int)"
value "1 - (2::nat)"
value "1 - (2::int)"

fun add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "add 0 n = n" |
  "add (Suc m) n = Suc ( add m n )"

lemma add_z [simp] : "add x 0 = x"
apply ( induction x )
apply ( auto )
done

lemma add_p [simp]: "add x (Suc y) = Suc ( add x y )"
apply ( induction x )
apply ( auto )
done

theorem add_com : "add x y = add y x"
apply ( induction y )
apply ( auto )
done

theorem add_ass : "add x ( add y z ) = add ( add x y ) z"
apply ( induction x )
apply ( auto )
done

fun double :: "nat \<Rightarrow> nat" where
  "double 0 = 0" |
  "double ( Suc x ) = Suc (  Suc ( double x )  )"

theorem double_add : "double x = add x x"
apply ( induction x )
apply ( auto )
done

fun count :: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
  "count e Nil = 0" |
  "(count e (x # xs)) = (
   if x=e then
      Suc ( count e xs )
    else
      count e xs )"

theorem count_lt_length : "count x xs \<le> length xs"
apply ( induction xs )
apply ( auto )
done

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

fun reverse :: "'a list \<Rightarrow> 'a list" where
  "reverse Nil = Nil" |
  "reverse ( x # xs ) = snoc ( reverse xs ) x"

lemma rev_snoc [simp] : "reverse ( snoc xs x ) = x # ( reverse xs )"
apply ( induction xs )
apply ( auto )
done

theorem rev_rev : "reverse ( reverse xs ) = xs"
apply ( induction xs )
apply ( auto )
done

fun sum :: "nat \<Rightarrow> nat" where
  "sum 0 = 0" |
  "sum ( Suc x ) = (Suc x) + (sum x)"

theorem sum_div : "sum x = ( x * (x+1) ) div 2"
  apply ( induction x )
  apply ( auto )
done

datatype 'a tree =
  Tip |
  Node  "'a tree"  'a  "'a tree"

fun contents :: "'a tree \<Rightarrow> 'a list" where
  "contents Tip = Nil" |
  "contents ( Node t0 x t1 ) = x # ( contents t0 ) @ ( contents t1 )"

fun treesum :: "nat tree \<Rightarrow> nat" where
  "treesum Tip = 0" |
  "treesum ( Node t0 x t1 ) = x + ( treesum t0 ) + ( treesum t1 )"

theorem treesum_listsum : "treesum t = listsum ( contents t )"
  apply ( induction t )
  apply ( auto )
done

datatype 'a tree2 =
  Leaf 'a |
  Node "'a tree2" 'a "'a tree2"

fun mirror :: "'a tree2 \<Rightarrow> 'a tree2" where
  "mirror ( Leaf x ) = Leaf x" |
  "mirror ( Node t0 x t1 ) = Node ( mirror t1 ) x ( mirror t0 )"

fun pre_order :: "'a tree2 \<Rightarrow> 'a list" where
  "pre_order ( Leaf x ) = x # Nil" |
  "pre_order ( Node t0 x t1 ) = x # ( pre_order t0 ) @ ( pre_order t1 )"

fun pos_order :: "'a tree2 \<Rightarrow> 'a list" where
  "pos_order ( Leaf x ) = x # Nil" |
  "pos_order ( Node t0 x t1 ) = ( pos_order t0 ) @ ( pos_order t1 ) @ x # Nil"

theorem pre_rev_pos : "pre_order ( mirror t ) = rev ( pos_order t )"
  apply ( induction t )
  apply ( auto )
done

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

theorem map_inter : "map f ( intersperse a xs ) = intersperse ( f a ) ( map f xs)"
apply ( induction a xs rule: intersperse.induct )
apply ( auto )
done

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

lemma [simp] : "itrev xs ys = ( rev xs ) @ ys"
  apply ( induction xs arbitrary: ys)
  apply ( auto )
done

lemma "itrev xs [] = rev xs"
  apply ( induction xs )
  apply ( auto )
done

fun itadd :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "itadd 0 n = n" |
  "itadd (Suc m) n = itadd m ( Suc n )"

lemma "itadd m n = add m n"
  apply ( induction m arbitrary: n )
  apply ( auto )
done

datatype tree0 =
  Tip |
  Node tree0 tree0

fun nodes :: "tree0 \<Rightarrow> nat" where
  "nodes Tip = 0" |
  "nodes ( Node t0 t1 ) = (nodes t0) + (nodes t1) + 1"

fun explode :: "nat \<Rightarrow> tree0 \<Rightarrow> tree0" where
  "explode 0 t = t" |
  "explode (Suc n) t = explode n (Node t t)"

lemma "( nodes ( explode n t ) )  =  ( 2 ^ n ) * ( nodes t ) + ( 2 ^ n ) - 1"
  apply ( induction n arbitrary: t )
  apply ( auto simp add:algebra_simps )
done

datatype exp =
  Var |
  Const int |
  Add exp exp |
  Mult exp exp

fun eval :: "exp \<Rightarrow> int \<Rightarrow> int" where
  "eval Var i = i" |
  "eval ( Const c ) i = c" |
  "eval ( Add e0 e1 ) i = ( eval e0 i ) + ( eval e1 i )" |
  "eval ( Mult e0 e1 ) i = ( eval e0 i ) * (eval e1 i )"

value "eval (Add (Mult (Const 2) Var ) (Const 3)) i"

fun evalp :: "int list \<Rightarrow> int \<Rightarrow> int" where
  "evalp [] i = 0" |
  "evalp ( c0 # cs ) i = c0 + i * ( evalp cs i )"

fun sump :: "int list \<Rightarrow> int list \<Rightarrow> int list" where
  "sump [] ys = ys" |
  "sump xs [] = xs" |
  "sump (x # xs) ( y # ys ) = ( x + y ) # ( sump xs ys )"

fun cmulp :: "int \<Rightarrow> int list \<Rightarrow> int list" where
  "cmulp c [] = []" |
  "cmulp c ( c0 # cs ) = (c * c0) # ( cmulp c cs )"

lemma [simp]: "evalp (cmulp c cs) x = c * evalp cs x"
  apply ( induction cs )
  apply ( auto simp add: algebra_simps )
done

fun mulp :: "int list \<Rightarrow> int list \<Rightarrow> int list" where
  "mulp [] _ = []" |
  "mulp (x # xs) ys = sump ( cmulp x ys ) ( 0 #  mulp xs ys )"

lemma [simp]: "evalp (mulp p1 p2) x = evalp p1 x * evalp p2 x"
  apply ( induction p1 )
  apply ( auto simp add: algebra_simps )
done

fun coeffs :: "exp \<Rightarrow> int list" where
  "coeffs Var = [ 0 , 1 ]" |
  "coeffs ( Const c ) = [ c ]" |
  "coeffs ( Add e0 e1 ) = sump ( coeffs e0 ) ( coeffs e1 )" |
  "coeffs ( Mult e0 e1 ) = mulp ( coeffs e0 ) ( coeffs e1 )"

theorem "evalp ( coeffs e ) x = eval e x"
  apply ( induction e arbitrary: x)
  apply ( auto simp add:algebra_simps )
done

end


section "Arithmetic and Boolean Expressions"

theory AMExp imports Main begin

  (* exercise 3.4 *)

subsection "Arithmetic Expressions"

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

datatype expr = N int | V vname | Plus expr expr | Times expr expr

fun eval :: "expr \<Rightarrow> state \<Rightarrow> val" where
  "eval (N n) s = n" |
  "eval (V x) s = s x" |
  "eval (Plus a\<^sub>1 a\<^sub>2) s = eval a\<^sub>1 s + eval a\<^sub>2 s"|
  "eval (Times a\<^sub>1 a\<^sub>2) s = eval a\<^sub>1 s * eval a\<^sub>2 s"

  value "eval (Plus (V ''x'') (N 5)) (\<lambda>x. if x = ''x'' then 7 else 0)"

value "eval (Plus (V ''x'') (N 5)) ((\<lambda>x. 0) (''x'':= 7))"

definition null_state ("<>") where
  "null_state \<equiv> \<lambda>x. 0"
syntax
  "_State" :: "updbinds => 'a" ("<_>")
translations
  "_State ms" == "_Update <> ms"
  "_State (_updbinds b bs)" <= "_Update (_State b) bs"

lemma "<a := 1, b := 2> = (<> (a := 1)) (b := (2::int))"
  by (rule refl)

value "eval (Plus (V ''x'') (N 5)) <''x'' := 7>"

value "eval (Plus (V ''x'') (N 5)) <''y'' := 7>"

subsection "Constant Folding"

fun plus :: "expr \<Rightarrow> expr \<Rightarrow> expr" where
  "plus (N i\<^sub>1) (N i\<^sub>2) = N(i\<^sub>1+i\<^sub>2)" |
  "plus (N i) a = (if i=0 then a else Plus (N i) a)" |
  "plus a (N i) = (if i=0 then a else Plus a (N i))" |
  "plus a\<^sub>1 a\<^sub>2 = Plus a\<^sub>1 a\<^sub>2"

lemma eval_plus[simp]:
  "eval (plus a1 a2) s = eval a1 s + eval a2 s"
  (* apply(induction a1 a2 rule: plus.induct) Original. The 'a1 a2' is extraneous. *)
  apply(induction rule: plus.induct)
    (* apply(induction a1) apply(induction a2)  Does not work*)
              apply simp_all (* just for a change from auto *)
  done

fun times :: "expr \<Rightarrow> expr \<Rightarrow> expr" where
  "times (N i\<^sub>1) (N i\<^sub>2) = N(i\<^sub>1 * i\<^sub>2)" |
  "times (N i) a = (if i=0
                    then (N 0)
                    else (if i=1
                      then a
                      else Times (N i) a))" |
  "times a (N i) = (if i=0
                    then (N 0)
                    else (if i=1
                      then a
                      else Times a (N i)))" |
  "times a\<^sub>1 a\<^sub>2 = Times a\<^sub>1 a\<^sub>2"

lemma eval_times[simp]:
  "eval (times a1 a2) s = eval a1 s * eval a2 s"
  (* apply(induction a1 a2 rule: times.induct) Original. The 'a1 a2' is extraneous. *)
  apply(induction rule: times.induct)
    apply simp_all
  done

fun asimp :: "expr \<Rightarrow> expr" where
  "asimp (N n) = N n" |
  "asimp (V x) = V x" |
  "asimp (Plus a\<^sub>1 a\<^sub>2) = plus (asimp a\<^sub>1) (asimp a\<^sub>2)" |
  "asimp (Times a\<^sub>1 a\<^sub>2) = times (asimp a\<^sub>1) (asimp a\<^sub>2)"

value "asimp (Plus (Plus (N 0) (N 0)) (Plus (V ''x'') (N 0)))"

theorem eval_asimp[simp]:
  "eval (asimp a) s = eval a s"
  apply(induction a)
  apply simp_all
  done

(* Define a substitution function
subst :: vname \<Rightarrow> expr \<Rightarrow> expr \<Rightarrow> expr
such that
subst x a e
is the result of replacing every
occurrence of variable x by a in e *)
fun subst :: "vname \<Rightarrow> expr \<Rightarrow> expr \<Rightarrow> expr" where
  "subst matchMe replaceWith (V vname) =
      (if matchMe = vname
      then replaceWith
      else V vname)"|
  "subst matchMe replaceWith (N n) = N n"|
  "subst matchMe replaceWith (Plus e\<^sub>1 e\<^sub>2) =
      Plus (subst matchMe replaceWith e\<^sub>1) (subst matchMe replaceWith e\<^sub>2)"|
  "subst matchMe replaceWith (Times e\<^sub>1 e\<^sub>2) =
      Times (subst matchMe replaceWith e\<^sub>1) (subst matchMe replaceWith e\<^sub>2)"

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

(*   Prove the so-called substitution lemma that says that we can either
substitute first and evaluate afterwards or evaluate with an updated state:
eval (subst x a e) s = eval e (s(x := eval a s)). As a consequence prove
eval a1 s = eval a2 s =\<Rightarrow> eval (subst x a1 e) s = eval (subst x a2 e) s. *)
lemma substitution:"eval (subst x a e) s = eval e (s(x := eval a s))"
  apply(induction e)
  by auto

theorem foo:
  "eval a\<^sub>1 s = eval a\<^sub>2 s
  \<Longrightarrow> eval (subst x a\<^sub>1 e) s = eval (subst x a\<^sub>2 e) s"
  apply(induction e)
  by auto

end


theory Folding
  imports Main
begin

subsubsection \<open> Some more list functions \<close>

text \<open> Recall the summation function \<close>

primrec sum :: "nat list \<Rightarrow> nat" where
  "sum [] = 0"
| "sum (x # xs) = x + sum xs"

text \<open> In the Isabelle library, you will find (in the theory {\tt List.thy})
the functions @{text foldr} and @{text foldl}, which allow you to define some
list functions, among them @{text sum} and @{text length}.  Show the following:
\<close>

lemma sum_foldr: "sum xs = foldr (+) xs 0"
  apply (induction xs) by auto

lemma length_foldr: "length xs = foldr (\<lambda> x res. 1 + res) xs 0"
  apply (induction xs) by auto

text \<open> Repeated application of @{text foldr} and @{text map} has the
disadvantage that a list is traversed several times.  A single traversal is
sufficient, as illustrated by the following example: \<close>

lemma "sum (map (\<lambda> x. x + 3) xs) = foldr (\<lambda> x a. x + 3 + a) xs 0"
  apply (induction xs) by auto

text \<open> Find terms @{text h} and @{text b} which solve this equation. \<close>

text \<open> Generalize this result, i.e.\ show for appropriate @{text h} and @{text
b}: \<close>

lemma "foldr g (map f xs) a = foldr (g \<circ> f) xs a"
  apply (induction xs) by auto

text \<open> Hint: Isabelle can help you find the solution if you use the equalities
arising during a proof attempt. \<close>

text \<open> The following function @{text rev_acc} reverses a list in linear time:
\<close>

primrec rev_acc :: "['a list, 'a list] \<Rightarrow> 'a list" where
  "rev_acc [] ys = ys"
| "rev_acc (x#xs) ys = (rev_acc xs (x#ys))"

text \<open> Show that @{text rev_acc} can be defined by means of @{text foldl}. \<close>

lemma rev_acc_foldl: "rev_acc xs a = foldl (\<lambda> ys x. x # ys) a xs"
  apply (induction xs arbitrary: a) by auto

text \<open> Prove the following distributivity property for @{text sum}: \<close>

lemma sum_append [simp]: "sum (xs @ ys) = sum xs + sum ys"
  apply (induction xs) by auto

text \<open> Prove a similar property for @{text foldr}, i.e.\ something like @{text
"foldr f (xs @ ys) a = f (foldr f xs a) (foldr f ys a)"}.  However, you will
have to strengthen the premises by taking into account algebraic properties of
@{text f} and @{text a}. \<close>

lemma foldr_append: "\<lbrakk>\<forall> x. f a x = x; \<forall> x y z. f x (f y z) = f (f x y) z\<rbrakk> \<Longrightarrow>
                      foldr f (xs @ ys) a = f (foldr f xs a) (foldr f ys a)"
  apply (induction xs) by auto

text \<open> Now, define the function @{text prod}, which computes the product of
all list elements \<close>

definition prod :: "nat list \<Rightarrow> nat" where "prod xs = foldr (*) xs 1"

text \<open> directly with the aid of a fold and prove the following: \<close>

lemma "prod (xs @ ys) = prod xs * prod ys"
  apply (induction xs) by (auto simp add: prod_def)

subsubsection \<open> Functions on Trees \<close>

text \<open> Consider the following type of binary trees: \<close>

datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

text \<open> Define functions which convert a tree into a list by traversing it in
pre-, resp.\ postorder: \<close>

primrec preorder :: "'a tree \<Rightarrow> 'a list"
  where
"preorder Tip = []" |
"preorder (Node l x r) = x#preorder l @ preorder r"

primrec postorder :: "'a tree \<Rightarrow> 'a list"
  where
"postorder Tip = []" |
"postorder (Node l x r) = postorder l @ postorder r @ [x]"

text \<open> You have certainly realized that computation of postorder traversal can
be efficiently realized with an accumulator, in analogy to @{text rev_acc}: \<close>

primrec  postorder_acc :: "['a tree, 'a list] \<Rightarrow> 'a list"
  where
"postorder_acc Tip xs = xs" |
"postorder_acc (Node l x r) xs = postorder_acc l (postorder_acc r (x#xs))"

text \<open> Define this function and show: \<close>

lemma "postorder_acc t xs = (postorder t) @ xs"
  apply (induction t arbitrary: xs) by auto

text \<open> @{text postorder_acc} is the instance of a function @{text foldl_tree},
which is similar to @{text foldl}. \<close>

primrec  foldl_tree :: "('b => 'a => 'b) \<Rightarrow> 'b \<Rightarrow> 'a tree \<Rightarrow> 'b"
  where
"foldl_tree _ a Tip = a" |
"foldl_tree f a (Node l x r) = foldl_tree f (foldl_tree f (f a x) r) l"

text \<open> Show the following: \<close>

lemma "\<forall> a. postorder_acc t a = foldl_tree (\<lambda> xs x. Cons x xs) a t"
  apply (induction t) by auto

text \<open> Define a function @{text tree_sum} that computes the sum of the
elements of a tree of natural numbers: \<close>

primrec tree_sum :: "nat tree \<Rightarrow> nat"
  where
"tree_sum Tip = 0" |
"tree_sum (Node l x r) = x + tree_sum l + tree_sum r"

text \<open> and show that this function satisfies \<close>

lemma "tree_sum t = sum (preorder t)"
  apply (induction t) by auto

(*<*) end (*>*)


(*  Title:      HOL/Library/Nat_Bijection.thy
    Author:     Brian Huffman
    Author:     Florian Haftmann
    Author:     Stefan Richter
    Author:     Tobias Nipkow
    Author:     Alexander Krauss
*)

section {* Bijections between natural numbers and other types *}

theory Nat_Bijection
imports Main
begin

subsection {* Type @{typ "nat \<times> nat"} *}

text "Triangle numbers: 0, 1, 3, 6, 10, 15, ..."

definition
  triangle :: "nat \<Rightarrow> nat"
where
  "triangle n = n * Suc n div 2"

lemma triangle_0 [simp]: "triangle 0 = 0"
unfolding triangle_def by simp

lemma triangle_Suc [simp]: "triangle (Suc n) = triangle n + Suc n"
unfolding triangle_def by simp

definition
  prod_encode :: "nat \<times> nat \<Rightarrow> nat"
where
  "prod_encode = (\<lambda>(m, n). triangle (m + n) + m)"

text {* In this auxiliary function, @{term "triangle k + m"} is an invariant. *}

fun
  prod_decode_aux :: "nat \<Rightarrow> nat \<Rightarrow> nat \<times> nat"
where
  "prod_decode_aux k m =
    (if m \<le> k then (m, k - m) else prod_decode_aux (Suc k) (m - Suc k))"

declare prod_decode_aux.simps [simp del]

definition
  prod_decode :: "nat \<Rightarrow> nat \<times> nat"
where
  "prod_decode = prod_decode_aux 0"

lemma prod_encode_prod_decode_aux:
  "prod_encode (prod_decode_aux k m) = triangle k + m"
apply (induct k m rule: prod_decode_aux.induct)
apply (subst prod_decode_aux.simps)
apply (simp add: prod_encode_def)
done

lemma prod_decode_inverse [simp]: "prod_encode (prod_decode n) = n"
unfolding prod_decode_def by (simp add: prod_encode_prod_decode_aux)

lemma prod_decode_triangle_add:
  "prod_decode (triangle k + m) = prod_decode_aux k m"
apply (induct k arbitrary: m)
apply (simp add: prod_decode_def)
apply (simp only: triangle_Suc add.assoc)
apply (subst prod_decode_aux.simps, simp)
done

lemma prod_encode_inverse [simp]: "prod_decode (prod_encode x) = x"
unfolding prod_encode_def
apply (induct x)
apply (simp add: prod_decode_triangle_add)
apply (subst prod_decode_aux.simps, simp)
done

lemma inj_prod_encode: "inj_on prod_encode A"
by (rule inj_on_inverseI, rule prod_encode_inverse)

lemma inj_prod_decode: "inj_on prod_decode A"
by (rule inj_on_inverseI, rule prod_decode_inverse)

lemma surj_prod_encode: "surj prod_encode"
by (rule surjI, rule prod_decode_inverse)

lemma surj_prod_decode: "surj prod_decode"
by (rule surjI, rule prod_encode_inverse)

lemma bij_prod_encode: "bij prod_encode"
by (rule bijI [OF inj_prod_encode surj_prod_encode])

lemma bij_prod_decode: "bij prod_decode"
by (rule bijI [OF inj_prod_decode surj_prod_decode])

lemma prod_encode_eq: "prod_encode x = prod_encode y \<longleftrightarrow> x = y"
by (rule inj_prod_encode [THEN inj_eq])

lemma prod_decode_eq: "prod_decode x = prod_decode y \<longleftrightarrow> x = y"
by (rule inj_prod_decode [THEN inj_eq])

text {* Ordering properties *}

lemma le_prod_encode_1: "a \<le> prod_encode (a, b)"
unfolding prod_encode_def by simp

lemma le_prod_encode_2: "b \<le> prod_encode (a, b)"
unfolding prod_encode_def by (induct b, simp_all)

subsection {* Type @{typ "nat + nat"} *}

definition
  sum_encode  :: "nat + nat \<Rightarrow> nat"
where
  "sum_encode x = (case x of Inl a \<Rightarrow> 2 * a | Inr b \<Rightarrow> Suc (2 * b))"

definition
  sum_decode  :: "nat \<Rightarrow> nat + nat"
where
  "sum_decode n = (if even n then Inl (n div 2) else Inr (n div 2))"

lemma sum_encode_inverse [simp]: "sum_decode (sum_encode x) = x"
unfolding sum_decode_def sum_encode_def
by (induct x) simp_all

lemma sum_decode_inverse [simp]: "sum_encode (sum_decode n) = n"
  by (simp add: even_two_times_div_two sum_decode_def sum_encode_def)

lemma inj_sum_encode: "inj_on sum_encode A"
by (rule inj_on_inverseI, rule sum_encode_inverse)

lemma inj_sum_decode: "inj_on sum_decode A"
by (rule inj_on_inverseI, rule sum_decode_inverse)

lemma surj_sum_encode: "surj sum_encode"
by (rule surjI, rule sum_decode_inverse)

lemma surj_sum_decode: "surj sum_decode"
by (rule surjI, rule sum_encode_inverse)

lemma bij_sum_encode: "bij sum_encode"
by (rule bijI [OF inj_sum_encode surj_sum_encode])

lemma bij_sum_decode: "bij sum_decode"
by (rule bijI [OF inj_sum_decode surj_sum_decode])

lemma sum_encode_eq: "sum_encode x = sum_encode y \<longleftrightarrow> x = y"
by (rule inj_sum_encode [THEN inj_eq])

lemma sum_decode_eq: "sum_decode x = sum_decode y \<longleftrightarrow> x = y"
by (rule inj_sum_decode [THEN inj_eq])

subsection {* Type @{typ "int"} *}

definition
  int_encode :: "int \<Rightarrow> nat"
where
  "int_encode i = sum_encode (if 0 \<le> i then Inl (nat i) else Inr (nat (- i - 1)))"

definition
  int_decode :: "nat \<Rightarrow> int"
where
  "int_decode n = (case sum_decode n of Inl a \<Rightarrow> int a | Inr b \<Rightarrow> - int b - 1)"

lemma int_encode_inverse [simp]: "int_decode (int_encode x) = x"
unfolding int_decode_def int_encode_def by simp

lemma int_decode_inverse [simp]: "int_encode (int_decode n) = n"
unfolding int_decode_def int_encode_def using sum_decode_inverse [of n]
by (cases "sum_decode n", simp_all)

lemma inj_int_encode: "inj_on int_encode A"
by (rule inj_on_inverseI, rule int_encode_inverse)

lemma inj_int_decode: "inj_on int_decode A"
by (rule inj_on_inverseI, rule int_decode_inverse)

lemma surj_int_encode: "surj int_encode"
by (rule surjI, rule int_decode_inverse)

lemma surj_int_decode: "surj int_decode"
by (rule surjI, rule int_encode_inverse)

lemma bij_int_encode: "bij int_encode"
by (rule bijI [OF inj_int_encode surj_int_encode])

lemma bij_int_decode: "bij int_decode"
by (rule bijI [OF inj_int_decode surj_int_decode])

lemma int_encode_eq: "int_encode x = int_encode y \<longleftrightarrow> x = y"
by (rule inj_int_encode [THEN inj_eq])

lemma int_decode_eq: "int_decode x = int_decode y \<longleftrightarrow> x = y"
by (rule inj_int_decode [THEN inj_eq])

subsection {* Type @{typ "nat list"} *}

fun
  list_encode :: "nat list \<Rightarrow> nat"
where
  "list_encode [] = 0"
| "list_encode (x # xs) = Suc (prod_encode (x, list_encode xs))"

function
  list_decode :: "nat \<Rightarrow> nat list"
where
  "list_decode 0 = []"
| "list_decode (Suc n) = (case prod_decode n of (x, y) \<Rightarrow> x # list_decode y)"
by pat_completeness auto

termination list_decode
apply (relation "measure id", simp_all)
apply (drule arg_cong [where f="prod_encode"])
apply (drule sym)
apply (simp add: le_imp_less_Suc le_prod_encode_2)
done

lemma list_encode_inverse [simp]: "list_decode (list_encode x) = x"
by (induct x rule: list_encode.induct) simp_all

lemma list_decode_inverse [simp]: "list_encode (list_decode n) = n"
apply (induct n rule: list_decode.induct, simp)
apply (simp split: prod.split)
apply (simp add: prod_decode_eq [symmetric])
done

lemma inj_list_encode: "inj_on list_encode A"
by (rule inj_on_inverseI, rule list_encode_inverse)

lemma inj_list_decode: "inj_on list_decode A"
by (rule inj_on_inverseI, rule list_decode_inverse)

lemma surj_list_encode: "surj list_encode"
by (rule surjI, rule list_decode_inverse)

lemma surj_list_decode: "surj list_decode"
by (rule surjI, rule list_encode_inverse)

lemma bij_list_encode: "bij list_encode"
by (rule bijI [OF inj_list_encode surj_list_encode])

lemma bij_list_decode: "bij list_decode"
by (rule bijI [OF inj_list_decode surj_list_decode])

lemma list_encode_eq: "list_encode x = list_encode y \<longleftrightarrow> x = y"
by (rule inj_list_encode [THEN inj_eq])

lemma list_decode_eq: "list_decode x = list_decode y \<longleftrightarrow> x = y"
by (rule inj_list_decode [THEN inj_eq])

subsection {* Finite sets of naturals *}

subsubsection {* Preliminaries *}

lemma finite_vimage_Suc_iff: "finite (Suc -` F) \<longleftrightarrow> finite F"
apply (safe intro!: finite_vimageI inj_Suc)
apply (rule finite_subset [where B="insert 0 (Suc ` Suc -` F)"])
apply (rule subsetI, case_tac x, simp, simp)
apply (rule finite_insert [THEN iffD2])
apply (erule finite_imageI)
done

lemma vimage_Suc_insert_0: "Suc -` insert 0 A = Suc -` A"
by auto

lemma vimage_Suc_insert_Suc:
  "Suc -` insert (Suc n) A = insert n (Suc -` A)"
by auto

lemma div2_even_ext_nat:
  fixes x y :: nat
  assumes "x div 2 = y div 2"
  and "even x \<longleftrightarrow> even y"
  shows "x = y"
proof -
  from `even x \<longleftrightarrow> even y` have "x mod 2 = y mod 2"
    by (simp only: even_iff_mod_2_eq_zero) auto
  with assms have "x div 2 * 2 + x mod 2 = y div 2 * 2 + y mod 2"
    by simp
  then show ?thesis
    by simp
qed

subsubsection {* From sets to naturals *}

definition
  set_encode :: "nat set \<Rightarrow> nat"
where
  "set_encode = setsum (op ^ 2)"

lemma set_encode_empty [simp]: "set_encode {} = 0"
by (simp add: set_encode_def)

lemma set_encode_insert [simp]:
  "\<lbrakk>finite A; n \<notin> A\<rbrakk> \<Longrightarrow> set_encode (insert n A) = 2^n + set_encode A"
by (simp add: set_encode_def)

lemma even_set_encode_iff: "finite A \<Longrightarrow> even (set_encode A) \<longleftrightarrow> 0 \<notin> A"
unfolding set_encode_def by (induct set: finite, auto)

lemma set_encode_vimage_Suc: "set_encode (Suc -` A) = set_encode A div 2"
apply (cases "finite A")
apply (erule finite_induct, simp)
apply (case_tac x)
apply (simp add: even_set_encode_iff vimage_Suc_insert_0)
apply (simp add: finite_vimageI add.commute vimage_Suc_insert_Suc)
apply (simp add: set_encode_def finite_vimage_Suc_iff)
done

lemmas set_encode_div_2 = set_encode_vimage_Suc [symmetric]

subsubsection {* From naturals to sets *}

definition
  set_decode :: "nat \<Rightarrow> nat set"
where
  "set_decode x = {n. odd (x div 2 ^ n)}"

lemma set_decode_0 [simp]: "0 \<in> set_decode x \<longleftrightarrow> odd x"
by (simp add: set_decode_def)

lemma set_decode_Suc [simp]:
  "Suc n \<in> set_decode x \<longleftrightarrow> n \<in> set_decode (x div 2)"
by (simp add: set_decode_def div_mult2_eq)

lemma set_decode_zero [simp]: "set_decode 0 = {}"
by (simp add: set_decode_def)

lemma set_decode_div_2: "set_decode (x div 2) = Suc -` set_decode x"
by auto

lemma set_decode_plus_power_2:
  "n \<notin> set_decode z \<Longrightarrow> set_decode (2 ^ n + z) = insert n (set_decode z)"
 apply (induct n arbitrary: z, simp_all)
  apply (rule set_eqI, induct_tac x, simp, simp)
 apply (rule set_eqI, induct_tac x, simp, simp add: add.commute)
done

lemma finite_set_decode [simp]: "finite (set_decode n)"
apply (induct n rule: nat_less_induct)
apply (case_tac "n = 0", simp)
apply (drule_tac x="n div 2" in spec, simp)
apply (simp add: set_decode_div_2)
apply (simp add: finite_vimage_Suc_iff)
done

subsubsection {* Proof of isomorphism *}

lemma set_decode_inverse [simp]: "set_encode (set_decode n) = n"
apply (induct n rule: nat_less_induct)
apply (case_tac "n = 0", simp)
apply (drule_tac x="n div 2" in spec, simp)
apply (simp add: set_decode_div_2 set_encode_vimage_Suc)
apply (erule div2_even_ext_nat)
apply (simp add: even_set_encode_iff)
done

lemma set_encode_inverse [simp]: "finite A \<Longrightarrow> set_decode (set_encode A) = A"
apply (erule finite_induct, simp_all)
apply (simp add: set_decode_plus_power_2)
done

lemma inj_on_set_encode: "inj_on set_encode (Collect finite)"
by (rule inj_on_inverseI [where g="set_decode"], simp)

lemma set_encode_eq:
  "\<lbrakk>finite A; finite B\<rbrakk> \<Longrightarrow> set_encode A = set_encode B \<longleftrightarrow> A = B"
by (rule iffI, simp add: inj_onD [OF inj_on_set_encode], simp)

lemma subset_decode_imp_le: assumes "set_decode m \<subseteq> set_decode n" shows "m \<le> n"
proof -
  have "n = m + set_encode (set_decode n - set_decode m)"
  proof -
    obtain A B where "m = set_encode A" "finite A"
                     "n = set_encode B" "finite B"
      by (metis finite_set_decode set_decode_inverse)
  thus ?thesis using assms
    apply auto
    apply (simp add: set_encode_def add.commute setsum.subset_diff)
    done
  qed
  thus ?thesis
    by (metis le_add1)
qed

end


theory Roy_Floyd_Warshall
imports Main
begin

section \<open>Transitive closure algorithm\<close>

text \<open>
  The Roy-Floyd-Warshall algorithm takes a finite relation as input and
  produces its transitive closure as output. It iterates over all elements of
  the field of the relation and maintains a cumulative approximation of the
  result: step \<open>0\<close> starts with the original relation, and step \<open>Suc n\<close>
  connects all paths over the intermediate element \<open>n\<close>. The final
  approximation coincides with the full transitive closure.

  This algorithm is often named after ``Floyd'', ``Warshall'', or
  ``Floyd-Warshall'', but the earliest known description is due to B. Roy
  \<^cite>\<open>"Roy:1959"\<close>.

  \<^medskip>
  Subsequently we use a direct mathematical model of the relation, bypassing
  matrices and arrays that are usually seen in the literature. This is more
  efficient for sparse relations: only the adjacency for immediate
  predecessors and successors needs to be maintained, not the square of all
  possible combinations. Moreover we do not have to worry about mutable data
  structures in a multi-threaded environment. See also the graph
  implementation in the Isabelle sources @{file
  \<open>$ISABELLE_HOME/src/Pure/General/graph.ML\<close>} and @{file
  \<open>$ISABELLE_HOME/src/Pure/General/graph.scala\<close>}.
\<close>

type_synonym relation = "(nat \<times> nat) set"

fun steps :: "relation \<Rightarrow> nat \<Rightarrow> relation"
where
  "steps rel 0 = rel"
| "steps rel (Suc n) =
    steps rel n \<union> {(x, y). (x, n) \<in> steps rel n \<and> (n, y) \<in> steps rel n}"

text \<open>Implementation view on the relation:\<close>

definition preds :: "relation \<Rightarrow> nat \<Rightarrow> nat set"
  where "preds rel y = {x. (x, y) \<in> rel}"

definition succs :: "relation \<Rightarrow> nat \<Rightarrow> nat set"
  where "succs rel x = {y. (x, y) \<in> rel}"

lemma
  "steps rel (Suc n) =
    steps rel n \<union> {(x, y). x \<in> preds (steps rel n) n \<and> y \<in> succs (steps rel n) n}"
  by (simp add: preds_def succs_def)

text \<open>
  The main function requires an upper bound for the iteration, which is left
  unspecified here (via Hilbert's choice).
\<close>

definition is_bound :: "relation \<Rightarrow> nat \<Rightarrow> bool"
  where "is_bound rel n \<longleftrightarrow> (\<forall>m \<in> Field rel. m < n)"

definition "transitive_closure rel = steps rel (SOME n. is_bound rel n)"

section \<open>Correctness proof\<close>

subsection \<open>Miscellaneous lemmas\<close>

lemma finite_bound:
  assumes "finite rel"
  shows "\<exists>n. is_bound rel n"
  using assms
proof induct
  case empty
  then show ?case by (simp add: is_bound_def)
next
  case (insert p rel)
  then obtain n where n: "\<forall>m \<in> Field rel. m < n"
    unfolding is_bound_def by blast
  obtain x y where "p = (x, y)" by (cases p)
  then have "\<forall>m \<in> Field (insert p rel). m < max (Suc x) (max (Suc y) n)"
    using n by auto
  then show ?case
    unfolding is_bound_def by blast
qed

lemma steps_Suc: "(x, y) \<in> steps rel (Suc n) \<longleftrightarrow>
  (x, y) \<in> steps rel n \<or> (x, n) \<in> steps rel n \<and> (n, y) \<in> steps rel n"
  by auto

lemma steps_cases:
  assumes "(x, y) \<in> steps rel (Suc n)"
  obtains (copy) "(x, y) \<in> steps rel n"
    | (step) "(x, n) \<in> steps rel n" and "(n, y) \<in> steps rel n"
  using assms by auto

lemma steps_rel: "(x, y) \<in> rel \<Longrightarrow> (x, y) \<in> steps rel n"
  by (induct n) auto

subsection \<open>Bounded closure\<close>

text \<open>
  The bounded closure connects all transitive paths over elements below a
  given bound. For an upper bound of the relation, this coincides with the
  full transitive closure.
\<close>

inductive_set Clos :: "relation \<Rightarrow> nat \<Rightarrow> relation"
  for rel :: relation and n :: nat
where
  base: "(x, y) \<in> Clos rel n" if "(x, y) \<in> rel"
| step: "(x, y) \<in> Clos rel n" if "(x, z) \<in> Clos rel n" and "(z, y) \<in> Clos rel n" and "z < n"

theorem Clos_closure:
  assumes "is_bound rel n"
  shows "(x, y) \<in> Clos rel n \<longleftrightarrow> (x, y) \<in> rel\<^sup>+"
proof
  show "(x, y) \<in> rel\<^sup>+" if "(x, y) \<in> Clos rel n"
    using that by induct simp_all
  show "(x, y) \<in> Clos rel n" if "(x, y) \<in> rel\<^sup>+"
    using that
  proof (induct rule: trancl_induct)
    case (base y)
    then show ?case by (rule Clos.base)
  next
    case (step y z)
    from \<open>(y, z) \<in> rel\<close> have 1: "(y, z) \<in> Clos rel n" by (rule base)
    from \<open>(y, z) \<in> rel\<close> and \<open>is_bound rel n\<close> have 2: "y < n"
      unfolding is_bound_def Field_def by blast
    from step(3) 1 2 show ?case by (rule Clos.step)
  qed
qed

lemma Clos_Suc:
  assumes "(x, y) \<in> Clos rel n"
  shows "(x, y) \<in> Clos rel (Suc n)"
  using assms by induct (auto intro: Clos.intros)

text \<open>
  In each step of the algorithm the approximated relation is exactly the
  bounded closure.
\<close>

theorem steps_Clos_equiv: "(x, y) \<in> steps rel n \<longleftrightarrow> (x, y) \<in> Clos rel n"
proof (induct n arbitrary: x y)
  case 0
  show ?case
  proof
    show "(x, y) \<in> Clos rel 0" if "(x, y) \<in> steps rel 0"
    proof -
      from that have "(x, y) \<in> rel" by simp
      then show ?thesis by (rule Clos.base)
    qed
    show "(x, y) \<in> steps rel 0" if "(x, y) \<in> Clos rel 0"
      using that by cases simp_all
  qed
next
  case (Suc n)
  show ?case
  proof
    show "(x, y) \<in> Clos rel (Suc n)" if "(x, y) \<in> steps rel (Suc n)"
      using that
    proof (cases rule: steps_cases)
      case copy
      with Suc(1) have "(x, y) \<in> Clos rel n" ..
      then show ?thesis by (rule Clos_Suc)
    next
      case step
      with Suc have "(x, n) \<in> Clos rel n" and "(n, y) \<in> Clos rel n"
        by simp_all
      then have "(x, n) \<in> Clos rel (Suc n)" and "(n, y) \<in> Clos rel (Suc n)"
        by (simp_all add: Clos_Suc)
      then show ?thesis by (rule Clos.step) simp
    qed
    show "(x, y) \<in> steps rel (Suc n)" if "(x, y) \<in> Clos rel (Suc n)"
      using that
    proof induct
      case (base x y)
      then show ?case by (simp add: steps_rel)
    next
      case (step x z y)
      with Suc show ?case
        by (auto simp add: steps_Suc less_Suc_eq intro: Clos.step)
    qed
  qed
qed

subsection \<open>Main theorem\<close>

text \<open>
  The main theorem follows immediately from the key observations above. Note
  that the assumption of finiteness gives a bound for the iteration, although
  the details are left unspecified. A concrete implementation could choose the
  the maximum element + 1, or iterate directly over the data structures for
  the @{term preds} and @{term succs} implementation.
\<close>

theorem transitive_closure_correctness:
  assumes "finite rel"
  shows "transitive_closure rel = rel\<^sup>+"
proof -
  let ?N = "SOME n. is_bound rel n"
  have is_bound: "is_bound rel ?N"
    by (rule someI_ex) (rule finite_bound [OF \<open>finite rel\<close>])
  have "(x, y) \<in> steps rel ?N \<longleftrightarrow> (x, y) \<in> rel\<^sup>+" for x y
  proof -
    have "(x, y) \<in> steps rel ?N \<longleftrightarrow> (x, y) \<in> Clos rel ?N"
      by (rule steps_Clos_equiv)
    also have "\<dots> \<longleftrightarrow> (x, y) \<in> rel\<^sup>+"
      using is_bound by (rule Clos_closure)
    finally show ?thesis .
  qed
  then show ?thesis unfolding transitive_closure_def by auto
qed

section \<open>Alternative formulation\<close>

text \<open>
  The core of the algorithm may be expressed more declaratively as follows,
  using an inductive definition to imitate a logic-program. This is equivalent
  to the function specification @{term steps} from above.
\<close>

inductive Steps :: "relation \<Rightarrow> nat \<Rightarrow> nat \<times> nat \<Rightarrow> bool"
  for rel :: relation
where
  base: "Steps rel 0 (x, y)" if "(x, y) \<in> rel"
| copy: "Steps rel (Suc n) (x, y)" if "Steps rel n (x, y)"
| step: "Steps rel (Suc n) (x, y)" if "Steps rel n (x, n)" and "Steps rel n (n, y)"

lemma steps_equiv: "(x, y) \<in> steps rel n \<longleftrightarrow> Steps rel n (x, y)"
proof
  show "Steps rel n (x, y)" if "(x, y) \<in> steps rel n"
    using that
  proof (induct n arbitrary: x y)
    case 0
    then have "(x, y) \<in> rel" by simp
    then show ?case by (rule base)
  next
    case (Suc n)
    from Suc(2) show ?case
    proof (cases rule: steps_cases)
      case copy
      with Suc(1) have "Steps rel n (x, y)" .
      then show ?thesis by (rule Steps.copy)
    next
      case step
      with Suc(1) have "Steps rel n (x, n)" and "Steps rel n (n, y)"
        by simp_all
      then show ?thesis by (rule Steps.step)
    qed
  qed
  show "(x, y) \<in> steps rel n" if "Steps rel n (x, y)"
    using that by induct simp_all
qed

end


theory 2
  imports Main
begin

  (* The long arrow (\<Longrightarrow>) separates assumptions (on the left) from the conclusion. *)

value "1+2::nat"
value "1+2::int"
value "1-2::nat" (* NB: 0, not -1 *)
value "1-2::int"

  (* exercise 2.2 *)
datatype nat = Zero | Suc nat

fun add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "add Zero n = n"
| "add (Suc l) r = Suc(add l r)"

lemma add_Zero_is_id[simp]: "add l Zero = l"
  apply(induction l)
   apply(auto)
  done

theorem add_is_associative: "add (add x y) z = add x (add y z)"
  apply(induction x)
   apply(auto)
  done

    (* the '[simp]' is required, otherwise this lemma is not used by 'auto' in the theorem below
If you ask sledgehammer, it will tell you:
  by (simp add: add_in_reverse)
 *)
lemma add_in_reverse[simp]: "Suc (add y x) = add y (Suc x)"
  apply(induction y)
   apply(auto)
  done

theorem add_is_commutative: "add x y = add y x"
  apply(induction x)
   apply(auto)
  done

fun double :: "nat \<Rightarrow> nat" where
  "double Zero = Zero"
| "double (Suc x) = Suc (Suc (double x))"

lemma double_is_add_to_self: "double x = add x x"
  apply(induction x)
   apply(auto)
  done

    (* exercise 2.3 *)

fun count :: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
  "count v Nil = Zero"
| "count v (Cons x xs) = (if v=x then Suc (count v xs) else count v xs)"

value "count (1::int) [1, 2, 1]"
value "count (2::int) [1, 2, 1]"

lemma count_leq_length: "count a xs \<le> length xs"

end


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

text {*
Read the chapter about total recursive functions in the ``Tutorial on
Isabelle/HOL'' (@{text fun}, Chapter 3.5).
*}

text {*
In this exercise you will define a function @{text Zip} that merges two lists
by interleaving.
 Examples:
@{text "Zip [a1, a2, a3]  [b1, b2, b3] = [a1, b1, a2, b2, a3, b3]"}
 and
@{text "Zip [a1] [b1, b2, b3] = [a1, b1, b2, b3]"}.

Use three different approaches to define @{text Zip}:
\begin{enumerate}
\item by primitive recursion on the first list,
\item by primitive recursion on the second list,
\item by total recursion (using @{text fun}).
\end{enumerate}
*}

primrec zip1 :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where "zip1 [] x =x"
  |"zip1 (x#xs) ys = (case ys of [] \<Rightarrow> x#xs | y#ys \<Rightarrow> (x#y#(zip1 xs ys)))"
primrec zip2 :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where " zip2 x [] = x"
  | "zip2 x (y#ys) = (case x of [] \<Rightarrow> y#ys|x#xs \<Rightarrow>(x#y#(zip2 xs ys)))"
fun zipr :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "zipr [] ys = ys"
| "zipr xs [] = xs"
| "zipr (x#xs) (y#ys) = x # y # zipr xs ys"

text {*
Show that all three versions of @{text Zip} are equivalent.
*}
lemma "zip1 x y = zip2 x y"
  apply(induct x arbitrary :y)
   apply (case_tac y)
    apply auto
  apply(case_tac y)
   apply auto
  done

lemma "zip1 x y = zipr x y"
  apply (induct x arbitrary:y)
  apply (case_tac y)
    apply auto
  apply (case_tac y)
   apply auto
  done

lemma "zip2 x y = zipr x y"
  apply (induct x arbitrary:y)
  apply (case_tac y)
    apply auto
  apply (case_tac y)
   apply auto
  done

text {*
Show that @{text zipr} distributes over @{text append}.
*}

lemma "\<lbrakk>length p = length u; length q = length v\<rbrakk> \<Longrightarrow>
  zipr (p@q) (u@v) = zipr p u @ zipr q v"
  apply(induct p arbitrary:q u v)
   apply auto
  apply(case_tac u)
   apply auto
  done

text {*
{\bf Note:} For @{text fun}, the order of your equations is relevant.
If equations overlap, they will be disambiguated before they are added
to the logic.  You can have a look at these equations using @{text
"thm zipr.simps"}.
*}

(*<*) end (*>*)


theory Isar_Induction_Demo
imports Main
begin

section{*Case distinction and induction*}

subsection{*Case distinction*}

text{* Explicit: *}

lemma "length(tl xs) = length xs - 1"
proof (cases xs)
  assume "xs = []" thus ?thesis by simp
next
  fix y ys assume "xs = y#ys"
  thus ?thesis by simp
qed

text{* Implicit: *}

lemma "length(tl xs) = length xs - 1"
proof (cases xs)
print_cases
  case Nil
  thm Nil
  thus ?thesis by simp
next
  case (Cons y ys)
  thm Cons
  thus ?thesis by simp
qed

subsection{*Structural induction for nat*}

text{* Explicit: *}

lemma "\<Sum>{0..n::nat} = n*(n+1) div 2" (is "?P n")
proof (induction n)
  show "?P 0" by simp
next
  fix n assume "?P n"
  thus "?P(Suc n)" by simp
qed

text{* Implicit: *}

lemma "\<Sum>{0..n::nat} = n*(n+1) div 2"
proof (induction n)
print_cases
  case 0
  show ?case by simp
next
  case (Suc n)
  thm Suc
  thus ?case by simp
qed

text \<open> Induction with long-goal format \<close>

lemma split_list:
  assumes "x \<in> set xs"
  shows "\<exists>ys zs. xs = ys @ x # zs"
  using assms -- \<open>Give assumptions to induction method. Required if they contain induction/arbitrary variables! \<close>
proof (induction xs)
  case Nil thus ?case by simp
next
  case (Cons a xs)
  thm Cons.IH --"Induction hypothesis"
  thm Cons.prems --"Premises of the step case"
  thm Cons

  thm assms -- \<open>Also available, but makes no sense here, as it refers to different variables!\<close>

  from Cons.prems have "x = a \<or> x : set xs" by simp
  thus ?case
  proof
    assume "x = a"
    hence "a#xs = [] @ x # xs" by simp
    thus ?thesis by blast
  next
    assume "x : set xs"
    then obtain ys zs where "xs = ys @ x # zs" using Cons.IH by auto
    hence "a#xs = (a#ys) @ x # zs" by simp
    thus ?thesis by blast
  qed
qed

text{* Induction with @{text "\<Longrightarrow>"} *}

lemma "x \<in> set xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs"
proof (induction xs)
  case Nil thus ?case by simp
next
  case (Cons a xs)
  thm Cons.IH --"Induction hypothesis"
  thm Cons.prems --"Premises of the step case"
  thm Cons
  from Cons.prems have "x = a \<or> x : set xs" by simp
  thus ?case
  proof
    assume "x = a"
    hence "a#xs = [] @ x # xs" by simp
    thus ?thesis by blast
  next
    assume "x : set xs"
    then obtain ys zs where "xs = ys @ x # zs" using Cons.IH by auto
    hence "a#xs = (a#ys) @ x # zs" by simp
    thus ?thesis by blast
  qed
qed

subsection{*Computation induction*}

fun div2 :: "nat \<Rightarrow> nat" where
"div2 0 = 0" |
"div2 (Suc 0) = 0" |
"div2 (Suc(Suc n)) = div2 n + 1"

lemma "2 * div2 n \<le> n"
proof(induction n rule: div2.induct)
  case 1
  show ?case by simp
next
  case 2
  show ?case by simp
next
  case (3 n)
  have "2 * div2 (Suc(Suc n)) = 2 * div2 n + 2" by simp
  with "3.IH" show ?case by auto
qed

text{* Note that \<open>3.IH\<close> is not a valid name, it needs double quotes: \<open>"3.IH"\<close>. *}

fun sep :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"sep a (x # y # zs) = x # a # sep a (y # zs)" |
"sep a xs = xs"

thm sep.simps

lemma "map f (sep a xs) = sep (f a) (map f xs)"
proof (induction a xs rule: sep.induct)
print_cases
  case (1 a x y zs)
  thus ?case by simp
next
  case ("2_1" a)
  show ?case by simp
next
  case ("2_2" a v)
  show ?case by simp
qed

subsection{*Rule induction*}

inductive ev :: "nat => bool" where
ev0:  "ev 0" |
evSS:  "ev n \<Longrightarrow> ev(Suc(Suc n))"

declare ev.intros [simp]

lemma "ev n \<Longrightarrow> \<exists>k. n = 2*k"
proof (induction rule: ev.induct)
  case ev0 show ?case by simp
next
  case evSS thus ?case by arith
qed

lemma "ev n \<Longrightarrow> \<exists>k. n = 2*k"
proof (induction rule: ev.induct)
  case ev0 show ?case by simp
next
  case (evSS m)
  thm evSS
  thm evSS.IH
  thm evSS.hyps

  -- \<open>Note, name evSS for the intro-rule is hidden by case-name! Use ev.evSS or ev.intros(1) instead. \<close>
  thm ev.evSS
  thm ev.intros

  from evSS.IH obtain k where "m = 2*k" by blast
  hence "Suc(Suc m) = 2*(k+1)" by simp
  thus "\<exists>k. Suc(Suc m) = 2*k" by blast
qed

subsection{*Inductive definition of the reflexive transitive closure *}

consts step :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<rightarrow>" 55)

inductive steps :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<rightarrow>*" 55) where
refl: "x \<rightarrow>* x" |
step: "\<lbrakk> x \<rightarrow> y; y \<rightarrow>* z \<rbrakk> \<Longrightarrow> x \<rightarrow>* z"

declare refl[simp, intro]

text{* Explicit and by hand: *}

lemma "x \<rightarrow>* y  \<Longrightarrow>  y \<rightarrow>* z \<Longrightarrow> x \<rightarrow>* z"
proof(induction rule: steps.induct)
  fix x assume "x \<rightarrow>* z"
  thus "x \<rightarrow>* z" . --"by assumption"
next
  fix x' x y :: 'a
  assume "x' \<rightarrow> x" and "x \<rightarrow>* y"
  assume IH: "y \<rightarrow>* z \<Longrightarrow> x \<rightarrow>* z"
  assume "y \<rightarrow>* z"
  show "x' \<rightarrow>* z" by(rule step[OF `x' \<rightarrow> x` IH[OF `y\<rightarrow>*z`]])
qed

text{* Implicit and automatic: *}

lemma "x \<rightarrow>* y  \<Longrightarrow>  y \<rightarrow>* z \<Longrightarrow> x \<rightarrow>* z"
proof(induction rule: steps.induct)
  case refl thus ?case .
next
  case (step x' x y)
  --"x' x y not used in proof text, just for demo"
thm step
thm step.IH
thm step.hyps
thm step.prems
  show ?case
    by (metis step.hyps(1) step.IH step.prems steps.step)
qed

subsection{*Rule inversion*}

lemma assumes "ev n" shows "ev(n - 2)"
proof-
  from `ev n` show "ev(n - 2)"
  proof cases
    case ev0
thm ev0
    then show ?thesis by simp
  next
    case (evSS k)
thm evSS
    then show ?thesis by simp
  qed
qed

text{* Impossible cases are proved automatically: *}

lemma "\<not> ev(Suc 0)"
proof
  assume "ev(Suc 0)"
  then show False
  proof cases
  qed
qed

end


(*<*)
theory sol04
imports "~~/src/HOL/IMP/BExp" "~~/src/HOL/IMP/ASM"
begin
(*>*)
text {* \ExerciseSheet{4}{4.~11.~2014} *}

text {* \Exercise{Reflexive Transitive Closure}
A binary relation is expressed by a predicate of type
  @{text "R :: 's \<Rightarrow> 's \<Rightarrow> bool"}. Intuitively, @{text "R s t"} represents
  a single step from state @{text "s"} to state @{text "t"}.

The reflexive, transitive closure @{text "R\<^sup>*"} of @{text "R"} is the relation
  that contains a step @{text "R\<^sup>* s t"}, iff @{text "R"} can step
  from @{text "s"} to @{text "t"} in any number of steps (including zero steps).

Formalize the reflexive transitive closure as inductive predicate:
*}

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

text {* When doing so, you have the choice to append or prepend a step.
  In any case, the following two lemmas should hold for your definition: *}

lemma star_prepend: "\<lbrakk>r x y; star r y z\<rbrakk> \<Longrightarrow> star r x z"
(*<*)
  by (rule step)
(*>*)

lemma star_append: "\<lbrakk> star r x y; r y z \<rbrakk> \<Longrightarrow> star r x z"
(*<*)
  by (induct rule: star.induct) (auto intro: star.intros)
(*>*)

text {* Now, formalize the star predicate again, this time the other way
  round: *}
inductive star' :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
(*<*)
  for r where
  refl': "star' r x x" |
  step': "\<lbrakk>star' r x y; r y z\<rbrakk> \<Longrightarrow> star' r x z"
(*>*)

(*<*)
lemma star'_prepend:
  "\<lbrakk>star' r y z; r x y\<rbrakk> \<Longrightarrow> star' r x z"
  apply (induction rule: star'.induct)
  apply (auto intro: star'.intros)
  done
(*>*)

text {* Prove the equivalence of your two formalizations *}
lemma "star r x y = star' r x y"
(*<*)
proof
  assume "star r x y"
  thus "star' r x y"
    by induct (auto intro: star'.intros star'_prepend)
next
  assume "star' r x y"
  thus "star r x y"
    by induct (auto intro: star.intros star_append)
qed
(*>*)

text {*
  Hint: The induction method expects the assumption about the inductive
  predicate to be first.
*}

text {*\Exercise{Elements of a List} *}
text {* {\bf Give all your proofs in Isar, not apply style}*}

text {*

Define a recursive function @{text "elems"} returning the set of elements of a list:

*}

fun elems :: "'a list \<Rightarrow> 'a set"
(*<*)
where
  "elems [] = {}"
| "elems (x#xs) = {x} \<union> elems xs"
(*>*)

text {* To test your definition, prove: *}
lemma "elems [1,2,3,(4::nat)] = {1,2,3,4}" (*<*)by auto(*>*)

text {*

Now prove for each element @{term x} in a list @{term xs} that we can split @{term xs} in a prefix
not containing @{term x}, @{term x} itself and a rest:

*}

lemma "x \<in> elems xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> elems ys"
(*<*)
proof (induction xs)
  case Nil
  then show ?case
    by simp
next
  case (Cons y xs)
  show ?case
  proof cases
    assume eq: "x = y"
    show ?thesis
    proof (* \<exists>-introduction *)
      show "\<exists>zs. y # xs = [] @ x # zs \<and> x \<notin> elems []"
        using eq by simp
    qed
  next
    assume neq: "x \<noteq> y"
    with Cons obtain ys zs where ys: "xs = ys @ x # zs" "x \<notin> elems ys"
      by auto
    show ?thesis
    proof (* \<exists>-introduction *)
      show "\<exists>zs. y # xs = (y # ys) @ x # zs \<and> x \<notin> elems (y # ys)"
        using ys neq by simp
    qed
  qed
qed
(*>*)

text {* \Exercise{Rule Inversion}
Recall the evenness predicate @{text "ev"} from the lecture: *}

inductive ev :: "nat \<Rightarrow> bool" where
  ev0: "ev 0" |
  evSS: "ev n \<Longrightarrow> ev (Suc (Suc n))"

text {* Prove the converse of rule @{text "evSS"} using rule
inversion. Hint: There are two ways to proceed. First, you can write a
structured Isar-style proof using the @{text "cases"} method: *}

lemma "ev (Suc (Suc n)) \<Longrightarrow> ev n"
proof -
  assume "ev (Suc (Suc n))" then show "ev n" by cases
qed

text {* Alternatively, you can write a more automated proof by using
the elimination rules.
These rules can then be used with ``@{text "auto elim:"}''. (If given
the @{text "[elim]"} attribute, @{text "auto"} will use them by
default.) *}

(*<*)
lemma "ev (Suc (Suc n)) \<Longrightarrow> ev n" by (auto elim: ev.cases)
(*>*)

text {* Next, prove that the natural number three (@{text "Suc (Suc
(Suc 0))"}) is not even. Hint: You may proceed either with a
structured proof, or with an automatic one. An automatic proof may
require additional elimination rules from \textbf{inductive\_cases}.
*}

lemma "\<not> ev (Suc (Suc (Suc 0)))"
(*<*)
proof
  assume "ev (Suc (Suc (Suc 0)))" then show "False"
  proof (cases)
    assume "ev (Suc 0)" then show "False"
    proof (cases)
    qed
  qed
qed
lemma "\<not> ev (Suc (Suc (Suc 0)))"
  by (auto elim: ev.cases)
(*>*)

(*<*)
end
(*>*)