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

section "Mutual recursion and induction" 

datatype 'a tree = EmptyT | NodeT "'a" "'a forest"
and      'a forest = NilF | ConsF "'a tree" "'a forest"

consts
  flatten_tree :: "'a tree \<Rightarrow> 'a list"
  flatten_forest :: "'a forest \<Rightarrow> 'a list"
primrec
  "flatten_tree EmptyT = []"
  "flatten_tree (NodeT x f) = x#(flatten_forest f)"

  "flatten_forest NilF = []"
  "flatten_forest (ConsF t f) = (flatten_tree t) @ (flatten_forest f)"

consts
  fastflatten_tree :: "'a tree \<Rightarrow> 'a list \<Rightarrow> 'a list"
  fastflatten_forest :: "'a forest \<Rightarrow> 'a list \<Rightarrow> 'a list"
primrec
  "fastflatten_tree EmptyT result = result"
  "fastflatten_tree (NodeT x f) result = x#(fastflatten_forest f result)"

  "fastflatten_forest NilF result = result"
  "fastflatten_forest (ConsF t f) result =
     (fastflatten_tree t (fastflatten_forest f result))"

thm tree_forest.induct

lemma fastflatten_correct:
  "(\<forall> rest. fastflatten_tree (t::'a tree) rest = (flatten_tree t) @ rest)
   \<and> (\<forall> rest. fastflatten_forest (f::'a forest) rest
     = (flatten_forest f) @ rest)"
  apply (induct_tac t and f)
  apply simp
  apply clarify apply simp
  apply simp
  apply simp
  done

consts
  map_tree :: "'a tree \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'b tree"
  map_forest :: "'a forest \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'b forest"
primrec
  "map_tree EmptyT h = EmptyT"
  "map_tree (NodeT x f) h = NodeT (h x) (map_forest f h)"

  "map_forest NilF h = NilF"
  "map_forest (ConsF t f) h = ConsF (map_tree t h) (map_forest f h)"

text{*

The following is the induction rule for trees and forests.

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

*}

thm tree_forest.induct

lemma "flatten_tree (map_tree t h) = map h (flatten_tree t)
     \<and> flatten_forest (map_forest f h) = map h (flatten_forest f)"
proof (induct_tac t and f)
  show "flatten_tree (map_tree EmptyT h) = map h (flatten_tree EmptyT)" 
    by simp
next
  fix a f
  assume IH: "flatten_forest (map_forest f h) = map h (flatten_forest f)"
  have "flatten_tree (map_tree (NodeT a f) h) 
        = flatten_tree (NodeT (h a) (map_forest f h))" by simp
  also have "\<dots> = (h a)#(flatten_forest (map_forest f h))" by simp
  also have "\<dots> = (h a)#(map h (flatten_forest f))" using IH by simp
  also have "\<dots> = map h (a#(flatten_forest f))" by simp
  also have "\<dots> = map h (flatten_tree (NodeT a f))" by simp
  finally show "flatten_tree (map_tree (NodeT a f) h)
                = map h (flatten_tree (NodeT a f))" .
next
  show "flatten_forest (map_forest NilF h) = map h (flatten_forest NilF)"
    by simp
next
  fix t f
  assume IH1: "flatten_tree (map_tree t h) = map h (flatten_tree t)"
    and IH2: "flatten_forest (map_forest f h) = map h (flatten_forest f)"
  from IH1 IH2
  show "flatten_forest (map_forest (ConsF t f) h) =
          map h (flatten_forest (ConsF t f))" by simp
qed


section "Case study: compiling to a stack machine"


types 'v binop = "'v \<Rightarrow> 'v \<Rightarrow> 'v"

text{*
  
  Isabelle does not have built-in support for LISP-style 'symbols',
  so the typically approach for representing variables is to use
  natural numbers.

*}

datatype 'v expr = 
    Const 'v
  | Var nat
  | App "'v binop" "'v expr" "'v expr" 

text{*
  The following \textit{eval} function is an interpreter for this simple language.
*}
consts eval :: "'v expr \<Rightarrow> (nat \<Rightarrow> 'v) \<Rightarrow> 'v"
primrec
  "eval (Const b) env = b"
  "eval (Var x) env = env x"
  "eval (App f e1 e2) env = (f (eval e1 env) (eval e2 env))"

constdefs add :: "nat \<Rightarrow> nat \<Rightarrow> nat"
  "add x y \<equiv> x + y"
declare add_def[simp]

lemma "eval (App add (Const 1) (Const 2)) (\<lambda> a. a) = 3" by simp

lemma "eval (App add (Var 2) (Const 1))
    (\<lambda> a. if a = 2 then 41 else undefined) = 42" by simp

text{*

  We compile this language to instructions for a stack machine.
  Here is the datatype for instructions. The ILoad instruction
  looks up a variable and puts it on the stack and the IApply
  instruction applies the binary operation to the top two 
  elements of the stack.

*}

datatype 'v instr = IConst 'v | ILoad nat | IApp "'v binop"

text{*

  The exec function implements the stack machine, executing a list of
  instructions.

*}

consts exec :: "'v instr list \<Rightarrow> (nat\<Rightarrow>'v) \<Rightarrow> 'v list \<Rightarrow> 'v list"
primrec
  "exec [] env vs = vs"
  "exec (i#is) env vs = 
     (case i of
        IConst v \<Rightarrow> exec is env (v#vs)
      | ILoad x \<Rightarrow> exec is env ((env x)#vs)
      | IApp f \<Rightarrow> exec is env ((f (hd vs) (hd (tl vs)))#(tl(tl vs))))"

text{*

  TODO: explain arbitrary stuff from partially defined functions, like
  hd of an empty list.

  The compiler translates an expression to a list of instructions.

*}

consts comp :: "'v expr \<Rightarrow> 'v instr list"
primrec
  "comp (Const v) = [IConst v]"
  "comp (Var x) = [ILoad x]"
  "comp (App f e1 e2) = (comp e2) @ (comp e1) @ [IApp f]"

text{*

  Exercise: rewrite the comp function so that it doesn't use append.

*}

subsection "The compiler is correct"

text{*

  To check that the compiler is correct, we prove that
  the result of compiling and then executing is the same
  as interpreting.

*}

theorem "hd (exec (comp e) env []) = eval e s" oops

text{*

  We're going to prove this by induction on 'e', but
  first need to generalize the theorem a bit.

*}

theorem "\<forall> vs. exec (comp e) env vs = (eval e env)#vs"
proof (induct e)
  fix v
  show "\<forall>vs. exec (comp (Const v)) env vs = (eval (Const v) env)#vs" 
    by simp
next
  fix x
  show "\<forall>vs. exec (comp (Var x)) env vs = eval (Var x) env # vs" by simp
next
  fix f e1 e2
  assume IH1: "\<forall>vs. exec (comp e1) env vs = eval e1 env # vs"
    and IH2: "\<forall>vs. exec (comp e2) env vs = eval e2 env # vs"
  show "\<forall>vs. exec (comp (App f e1 e2)) env vs = eval (App f e1 e2) env # vs"
  proof
    fix vs
    have A: "(comp (App f e1 e2)) = (comp e2) @ (comp e1) @ [IApp f]" 
      by simp

    have "eval (App f e1 e2) env = (f (eval e1 env) (eval e2 env))" 
      by simp

    have "(f (eval e1 env) (eval e2 env))#vs 
          = exec [IApp f] env ((eval e1 env) # (eval e2 env # vs))" 
      by simp
    also have "\<dots> = exec [IApp f] env (exec (comp e1) env (eval e2 env # vs))"
      using IH1 by simp
    also have "\<dots> = exec [IApp f] env (exec (comp e1) env (exec (comp e2) env vs))" 
      using IH2 by simp
    -- "At this point we need a lemma about exec and append"
    oops

lemma exec_append[rule_format]:
  "\<forall> vs. exec (xs@ys) env vs = exec ys env (exec xs env vs)"
  apply (induct xs) apply simp apply auto
  apply (case_tac a) apply auto done

theorem "\<forall> vs. exec (comp e) env vs = (eval e env)#vs"
proof (induct e)
  fix v
  show "\<forall>vs. exec (comp (Const v)) env vs = (eval (Const v) env)#vs" by simp
next
  fix x
  show "\<forall>vs. exec (comp (Var x)) env vs = eval (Var x) env # vs" by simp
next
  fix f e1 e2
  assume IH1: "\<forall>vs. exec (comp e1) env vs = eval e1 env # vs"
    and IH2: "\<forall>vs. exec (comp e2) env vs = eval e2 env # vs"
  show "\<forall>vs. exec (comp (App f e1 e2)) env vs = eval (App f e1 e2) env # vs"
  proof
    fix vs
    have "exec (comp (App f e1 e2)) env vs
          = exec ((comp e2) @ (comp e1) @ [IApp f]) env vs" by simp
    also have "\<dots> = exec ((comp e1) @ [IApp f]) env (exec (comp e2) env vs)"
      using exec_append by blast
    also have "\<dots> = exec [IApp f] env (exec (comp e1) env (exec (comp e2) env vs))" 
      using exec_append by blast
    also have "\<dots> =  exec [IApp f] env (exec (comp e1) env (eval e2 env # vs))"
      using IH2 by simp
    also have "\<dots> = exec [IApp f] env ((eval e1 env) # (eval e2 env # vs))"
      using IH1 by simp
    also have "\<dots> = (f (eval e1 env) (eval e2 env))#vs" by simp
    also have "\<dots> = eval (App f e1 e2) env # vs" by simp
    finally 
    show "exec (comp (App f e1 e2)) env vs = eval (App f e1 e2) env # vs" 
      by blast
  qed
qed

subsection "Notes"

text{*

This section is based on section 3.3 of the Isabelle/HOL tutorial

*}

(*<*)
end
(*>*)