(*<*)
theory Lecture8
imports Main LaTeXsugar OptionalSugar
begin
(*>*)

section "Total recursive functions"

text{*

  Isabelle's \textbf{recdef} facility let you write
  functions without syntax restrictions on the
  recursion pattern (as with \textbf{primrec}).
  However, you must provide the termination measure.
  That is, you must provide a function that maps
  the input of your recursive function to an element of 
  a well-founded set, such as the natural numbers, and
  show that these elements decrease for each recursive call.
*}

subsection "The Fibonacci function"

text{*

  The following is a simple example of a recursive function,
  the Fibonacci function.

*}

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

lemma "fib (Suc (Suc (Suc (Suc 0)))) = 3" by simp

subsection "Case study: Euclid's Algorithm"

fun compute_gcd :: "nat \<Rightarrow> nat \<Rightarrow> nat"
where
"compute_gcd m n =
    (if n = 0 then m
     else (if m = 0 then n
	   else (if m < n then
		   compute_gcd m (n - m)
		 else
		   compute_gcd (m - n) n)))"

constdefs divisible_by :: "nat \<Rightarrow> nat \<Rightarrow> bool" ("_ | _" [80,80] 79)
  "divisible_by m n \<equiv> (\<exists> k. m = n * k)"
declare divisible_by_def[simp]

constdefs isGCD :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool"
  "isGCD k m n \<equiv> m|k \<and> n|k \<and> (\<forall> k'. m|k' \<and> n|k' \<longrightarrow> k|k')"
declare isGCD_def[simp]

lemma gcd_diff: 
  assumes MN: "m \<le> n"
  and G: "isGCD k m (n - m)"
  shows "isGCD k m n"
proof -
  from G have mk: "m|k" and nmk: "(n-m)|k" 
    and gk: "\<forall> k'. m|k' \<and> (n-m)|k' \<longrightarrow> k|k'" by auto
  from mk obtain k1 where mkk1: "m = k * k1" by auto 
  from nmk obtain k2 where nmkk2: "n-m = k * k2" by auto 
  from nmkk2 MN have "n = m + k * k2" by simp
  with mkk1 have "n = (k1 * k) + (k2 * k)" by simp
  hence "n = (k1 + k2) * k" using add_mult_distrib by simp
  hence nk: "n|k" by simp
  have kg_mn: "\<forall> k'. m|k' \<and> n|k' \<longrightarrow> k|k'"
  proof clarify
    fix k' assume mkp: "m|k'" and nkp: "n|k'"
    from nkp obtain k3 where nkpk3: "n = k' * k3" by auto 
    from mkp obtain k4 where mkpk3: "m = k' * k4" by auto 
    from nkpk3 mkpk3 have "n - m = (k' * k3) - (k' * k4)" by auto
    hence "n - m = (k3 * k') - (k4 * k')" 
      using nat_mult_commute[of k' k3] nat_mult_commute[of k' k4] by simp
    hence "n - m = (k3 - k4) * k'" using diff_mult_distrib by simp
    hence "(n - m)|k'" by simp
    with mkp gk show "k|k'" by simp
  qed
  from mk nk kg_mn show "isGCD k m n" by simp
qed

theorem "isGCD (compute_gcd m n) m n"
proof (induct rule: compute_gcd.induct)
  fix m::nat and n::nat
  assume IH1: "\<lbrakk>n \<noteq> 0; m \<noteq> 0; m < n\<rbrakk> \<Longrightarrow> isGCD (compute_gcd m (n - m)) m (n - m)"
    and IH2: "\<lbrakk>n \<noteq> 0; m \<noteq> 0; \<not> m < n\<rbrakk> \<Longrightarrow> isGCD (compute_gcd (m - n) n) (m - n) n"
  show "isGCD (compute_gcd m n) m n"
  proof (cases "n = 0")
    assume "n = 0" thus ?thesis by simp
  next
    assume N: "n \<noteq> 0"
    show "isGCD (compute_gcd m n) m n"
    proof (cases "m = 0")
      assume "m = 0" thus ?thesis by simp
    next
      assume M: "m \<noteq> 0"
      obtain k where K: "k = compute_gcd m n" by auto
      show "isGCD (compute_gcd m n) m n"
      proof (cases "m < n")
	assume MN: "m < n"
	from M N MN K have "k = compute_gcd m (n - m)" by simp
	with M N MN IH1 have G: "isGCD k m (n - m)" by simp
	from MN have "m \<le> n" by simp
	with G have "isGCD k m n" using gcd_diff by blast
	with K show "isGCD (compute_gcd m n) m n" by simp
      next
	assume MN: "\<not> m < n"
	from M N MN K have "k = compute_gcd (m - n) n" by simp
	with M N MN IH2 have G: "isGCD k n (m - n)" by simp
	from MN have "n \<le> m" by simp
	with G have "isGCD k n m" using gcd_diff by blast
	with K show ?thesis by simp
      qed
    qed
  qed
qed
	  
subsection "Merge sort"

text{*

  The goal of merge sort, of course, is to
  produce a sorted list.

*}

consts sorted :: "nat list \<Rightarrow> bool"
primrec
  "sorted [] = True"
  "sorted (x#xs) = ((\<forall>y \<in> set xs. x \<le> y) \<and> sorted xs)"

text{*

  The merge sort function will use the following auxiliary
  function to merge already sorted sub-lists. When using
  the \textbf{recdef} facility, the recursive function
  must have a single parameter but that parameter
  may be a tuple.
  
*}

consts merge :: "nat list * nat list \<Rightarrow> nat list"
recdef merge "measure(\<lambda>(xs,ys). size xs + size ys)"
  "merge(x#xs, y#ys) =
     (if x \<le> y then x # merge(xs, y#ys) else y # merge(x#xs, ys))"
  "merge(xs,[]) = xs"
  "merge([],ys) = ys"

text{*

  Isabelle generates a special purpose induction
  rule for each recursive function. Compare the
  following rule to the definition of merge.

\begin{equation}\notag
  @{thm [mode=Rule] merge.induct [no_vars]}
\end{equation}

*}

lemma set_merge[simp]: "set(merge(xs,ys)) = set xs \<union> set ys"
  apply(induct xs ys rule: merge.induct)
  apply auto
  done

text{*

  If the inputs to merge are sorted, then so is the output
  (and vice-versa).

*}

lemma sorted_merge[simp]:
     "sorted (merge(xs,ys)) = (sorted xs \<and> sorted ys)"
  apply(induct xs ys rule: merge.induct)
  apply(simp_all add: ball_Un linorder_not_le order_less_le)
  apply(blast intro: order_trans)
  done

text{*
  Here's the definition of merge sort.
*}

consts msort :: "nat list \<Rightarrow> nat list"
recdef msort "measure size"
    "msort [] = []"
    "msort [x] = [x]"
    "msort xs = merge(msort(take (size xs div 2) xs),
		      msort(drop (size xs div 2) xs))"

text{*
  The induction rule for msort is

\begin{equation}\notag
  @{thm [mode=Rule] msort.induct [no_vars]}
\end{equation}

*}

theorem sorted_msort: "sorted (msort xs)"
  by (induct xs rule: msort.induct) simp_all



subsection "Substitution and strong induction"


text{*

  We define the explicitly $\alpha$-renaming
  version of substitution \'a la Curry~\cite{Curry:1958cr,barendregt84:_lambda_calculus}
  using the \textbf{recdef} facility. The proof of termination relies on a
  proof by strong induction, an extremely general and powerful induction principle.

*}

datatype expr
  = Var nat
  | Lam nat expr ("\<lambda> _. _" [53,53] 52)
  | App expr expr

text{*

  To be completely concrete (and computable), 
  we choose fresh variables by computing the largest variable in 
  the relevant terms and add 1, thereby guaranteeing that the new variable
  does not occur in these expressions.

*}


consts maxv :: "expr \<Rightarrow> nat"
primrec
  "maxv (Var x) = x"
  "maxv (\<lambda> x. e) = max (maxv e) x"
  "maxv (App e\<^isub>1 e\<^isub>2) = max (maxv e\<^isub>1) (maxv e\<^isub>2)"

constdefs fresh :: "nat \<Rightarrow> expr \<Rightarrow> expr \<Rightarrow> nat"
  "fresh x e e' \<equiv> (max (max (maxv e') x) (maxv e)) + 1"

text{*

  Here's the definition of substitution. We label
  each clause so that we can used them as simplification
  rules. 

*}

consts subst :: "(expr \<times> nat \<times> expr) \<Rightarrow> expr"
syntax subst :: "nat \<Rightarrow> expr \<Rightarrow> expr \<Rightarrow> expr" ("[_:=_]_" [100,100,100] 101)
translations "[x:=e']e" == "subst(e,x,e')"
recdef (permissive) subst "measure (\<lambda> p. size (fst p))"
  svar: "[x:=e](Var y) = (if y = x then e else Var y)"
  slam: "[x:=e](\<lambda> y. e') = (let z = fresh x e e' in \<lambda> z. [x:=e]([y:=Var z]e'))"
  sapp: "[x:=e](App e\<^isub>1 e\<^isub>2) = App ([x:=e]e\<^isub>1) ([x:=e]e\<^isub>2)"

text{*

  The use of \textbf{permissive} tells Isabelle not to immediately
  abort, but instead accept the \textit{subst} function conditionally.
  Isabelle accepts a modified form of the \textit{subst} function
  that includes extra 'if' statements to make sure that
  it terminates.
{\scriptsize
\begin{align}
  @{thm_style lhs subst.simps(1) [no_vars]} &=
      @{thm_style rhs subst.simps(1) [no_vars]} \notag \\
  @{thm_style lhs subst.simps(2) [no_vars]} &= 
      @{thm_style rhs subst.simps(2) [no_vars]}\notag\\
  @{thm_style lhs subst.simps(3) [no_vars]} &=
      @{thm_style rhs subst.simps(3) [no_vars]} \notag
\end{align}
}
  The *response* window tells us that Isabelle could not prove
  termination and where it got stuck. We then create a 
  lemma, slightly generalizing from the stuck proof state.
  The following lemma says that substituting a variable
  for a variable does not change the size of an expression.
  The proof cannot be done by structural induction on
  the expression because the nested substitution changes the
  expression, so the induction hypothesis is not applicable.
  Instead we use strong induction (aka course of values induction)
  on the size of expressions. With this style of induction, the
  induction hypothesis is applicable to any expression 
  smaller than the current one. The following is the rule
  for strong induction.

\begin{equation}
@{thm [mode=Rule] nat_less_induct [no_vars]} \notag
\end{equation}


*}

lemma alpha_subst_size[simp]: "\<forall> x w e. size e = n \<longrightarrow> size ([x:=Var w]e) = n"
proof (induct rule: nat_less_induct)
  fix n
  assume IH: "\<forall>m<n. \<forall>x w e. size e = m \<longrightarrow> size ([x:=Var w]e) = m"
  show "\<forall>x w e. size e = n \<longrightarrow> size ([x:=Var w]e) = n"
  proof ((rule allI)+, rule impI)
    fix x and w and e::expr assume se: "size e = n"
    show "size ([x:=Var w]e) = n"
    proof (cases e)
      fix y assume "e = Var y" thus "size ([x:=Var w]e) = n" using se by (simp add: svar)
    next
      fix x' \<tau> e'
      assume E: "e = \<lambda> x'. e'"
      let ?W = "(max (max (maxv e') x) w) + 1"
      from E se have "Suc (size e') = n" by simp
      with IH have EP: "Suc (size ([x':=Var ?W]e')) = n" by auto
      from se EP E have EP2: "size ([x':=Var ?W]e') < Suc (size e')" by auto 
      from EP IH have "Suc (size ([x:=Var w]([x':=Var ?W]e'))) = n" by auto
      with E EP2 show "size ([x:=Var w]e) = n" by (simp add: slam fresh_def)
    next
      fix e1 e2 assume AP: " e = App e1 e2"
      from AP se have "size e1 < n" by auto
      with IH have E1: "size ([x:=Var w]e1) = size e1" by auto
      from AP se have "size e2 < n" by auto
      with IH have E2: "size ([x:=Var w]e2) = size e2" by auto
      from AP E1 E2 have "size ([x:=Var w]e) = size e" by (simp add: sapp)
      with se show "size ([x:=Var w]e) = n" by simp
    qed
  qed
qed

text{*

  With the above lemma established, we can resolve the
  termination conditions and update the simplification
  rules for the \textit{subst} function.

*}
recdef_tc subst (1) by simp
lemmas subst_simps[simp] = subst.simps[simplified]

lemma subst_lam: "z = fresh x e e' \<Longrightarrow> [x:=e](\<lambda> y. e') = (\<lambda> z. [x:=e][y:=Var z]e')" 
  by (simp add: fresh_def)


subsection "Depth-First Search"

typedecl node 
types graph = "(node * node) list"

consts
  adj :: "[graph, node] => node list"
primrec
  "adj [] n = []"
  "adj (e#es) n = (if fst e = n then snd e # adj es n else adj es n)"

constdefs
  adjs :: "[graph, node list] => node set"
  "adjs g xs \<equiv> set g `` set xs"

lemma adj_set: "y \<in> set (adj g x) = ((x,y) \<in> set g)"
  by (induct g, auto)

lemma adjs_Cons: "adjs g (x#xs) = set (adj g x) \<union> adjs g xs" 
  by(unfold adjs_def,auto simp add:Image_def adj_set)

constdefs
  reachable :: "[graph, node list] \<Rightarrow> node set"
  "reachable g xs \<equiv> (set g)\<^sup>* `` set xs"

constdefs
  nodes_of :: "graph \<Rightarrow> node set" 
  "nodes_of g \<equiv> set (map fst g @ map snd g)"

lemma [rule_format, simp]: "x \<notin> nodes_of g \<longrightarrow> adj g x = []"
  by (induct g, auto simp add: nodes_of_def)

constdefs
  dfs_rel :: "((graph * node list * node list) * (graph * node list * node list)) set"
  "dfs_rel \<equiv> inv_image (finite_psubset <*lex*> less_than)  
                   (\<lambda>(g,xs,ys). (nodes_of g - set ys, size xs))"

lemma dfs_rel_wf: "wf dfs_rel"
  by (auto simp add: dfs_rel_def wf_finite_psubset)

lemma [simp]: "finite (nodes_of g - set ys)"  
proof(rule finite_subset)
  show "finite (nodes_of g)"
    by (auto simp add: nodes_of_def)
qed (auto)

consts 
  dfs :: "[graph * node list * node list] \<Rightarrow> node list"
recdef (permissive) dfs dfs_rel
  dfs_base[simp]: "dfs (g, [], ys) = ys"
  dfs_inductive: "dfs (g, x#xs, ys) = (if x mem ys then dfs (g, xs, ys) 
                        else dfs (g, adj g x@xs, x#ys))"
(hints recdef_simp add: dfs_rel_def finite_psubset_def recdef_wf add: dfs_rel_wf)


text {*
  \begin{itemize}
  \item The second argument of \isatext{\isastyle{dfs}} is a stack of nodes that will be
  visited.
  \item The third argument of \isatext{\isastyle{dfs}} is a list of nodes that have
  been visited already.
  \end{itemize}
*}

recdef_tc dfs_tc: dfs
proof (intro allI)
  fix g x ys
  show "\<not> x mem ys \<longrightarrow>
       nodes_of g - insert x (set ys) \<subset> nodes_of g - set ys \<or> 
       nodes_of g - insert x (set ys) = nodes_of g - set ys \<and> adj g x = []"
    by (cases  "x \<in> nodes_of g", auto simp add: mem_iff)
qed

lemmas dfs_induct = dfs.induct[OF dfs_tc]
lemmas dfs_inductive[simp] = dfs_inductive[OF dfs_tc]

text{*

  To do: proof of correctness.

*}

subsection "Notes"

text{*

  The material on merge sort is from the
  \texttt{HOL/ex/MergeSort.thy} example from the Isabelle distribution.

  The material on Depth-First Search is from~\cite{Nishihara:2004vn}.

*}

(*<*)
end
(*>*)