theory Demo07
imports Main
begin

section {* Introducing new types *}

-- {* a new "undefined" type: *}
typedecl name
consts blah :: name


-- {* simple type abbreviation: *}
types 'a rel = "'a \<Rightarrow> 'a \<Rightarrow> bool"
definition eq :: "'a rel"
  where "eq x y \<equiv> (x = y)"


-- {* type definiton: pairs *}

typedef (prod) 
  ('a, 'b) prod = "{f. \<exists>a b. f = (\<lambda>(x::'a) (y::'b). x=a \<and> y=b)}"
  by blast
  
print_theorems 

definition
  pair :: "'a \<Rightarrow> 'b \<Rightarrow> ('a,'b) prod"
  where "pair a b \<equiv> Abs_prod (\<lambda>x y. x = a \<and> y = b)"

definition
  fs :: "('a,'b) prod \<Rightarrow> 'a"
  where "fs x \<equiv> SOME a. \<exists>b. x = pair a b"

definition
  sn :: "('a,'b) prod \<Rightarrow> 'b"
  where "sn x \<equiv> SOME b. \<exists>a. x = pair a b"

lemma in_prod: "(\<lambda>x y. x = a \<and> y = b) \<in> prod"
  apply (unfold prod_def)
  apply blast
  done

lemma pair_inject:
  "pair a b = pair a' b' \<Longrightarrow> a=a' \<and> b=b'"
  apply (unfold pair_def)
  thm Abs_prod_inject
  apply (insert in_prod [of a b])
  apply (insert in_prod [of a' b'])
  apply (blast dest: Abs_prod_inject fun_cong)
  done

lemma pair_eq:
  "(pair a b = pair a' b') = (a=a' \<and> b=b')"
  by (blast dest: pair_inject)

lemma fs:
  "fs (pair a b) = a"
  apply (unfold fs_def)
  apply (blast dest: pair_inject)
  done

lemma sn:
  "sn (pair a b) = b"
  apply (unfold sn_def)
  apply (blast dest: pair_inject)
  done


-- -----------------------------------------------------------

-- {* a recursive data type: *}
datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

print_theorems

-- {* distincteness of constructors automatic: *}
lemma "Tip ~= Node l x r" by simp


-- {* case sytax, case distinction manual *}
lemma "(1::nat) \<le> (case t of Tip \<Rightarrow> 1 | Node l x r \<Rightarrow> x+1)"
  apply(case_tac t)
  apply auto
  done

-- {* infinitely branching: *}
datatype 'a inftree = Tp | Nd 'a "nat \<Rightarrow> 'a inftree"

-- {* mutually recursive *}
datatype 
  ty = Integer | Real | RefT ref and
  ref = Class | Array ty


-- -----------------------------------------------------------

-- {* Isar, case distinction *}

declare length_tl[simp del]

lemma "length(tl xs) = length xs - 1"
proof (cases xs)
  case Nil then show ?thesis by simp
next
  case Cons then show ?thesis by simp
qed


-- {* Structural induction *}

text {* @{typ nat} is a datatype:  @{text "Suc nat | 0"}. *}

lemma "2 * (\<Sum>i<n+1. i) = n*(n+1::nat)"
  by (induct n, simp_all)


lemma "2 * (\<Sum>i<n+1. i) = n*(n+1::nat)" (is "?P n")
proof (induct n)
  show "?P 0" by simp
next
  fix n assume "?P n"
  then show "?P (Suc n)" by simp
qed


lemma "2 * (\<Sum>i<n+1. i) = n*(n+1::nat)"
proof (induct n)
  case 0 show ?case by simp
next
  case (Suc i) then show ?case by simp
qed


lemma fixes n::nat shows "n < n*n + 1"
proof (induct n)
  case 0 show ?case by simp
next
  case (Suc i) then show "Suc i < Suc i * Suc i + 1" by simp
qed


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

lemma 
  assumes A: "(\<And>n. (\<And>m. m < n \<Longrightarrow> P m) \<Longrightarrow> P n)"
  shows "P (n::nat)"
proof (rule A)
  show "\<And>m. m < n \<Longrightarrow> P m"
  proof (induct n)
    case 0 then show ?case by simp
  next
    case (Suc n)  -- "old style, @{term m} not declared in text"
    show ?case
    proof cases
      assume eq: "m = n"
      from Suc and A have "P n" by blast
      with eq show "P m" by simp
    next
      assume "m \<noteq> n"
      with Suc have "m < n" by arith
      then show "P m" by(rule Suc)
    qed
  qed
qed

lemma 
  assumes A: "(\<And>n. (\<And>m. m < n \<Longrightarrow> P m) \<Longrightarrow> P n)"
  shows "P (n::nat)"
proof (rule A)
  fix m
  assume "m < n" then show "P m"
  proof (induct n arbitrary: m)
    case 0 then show ?case by simp
  next
    case (Suc n)
    show ?case
    proof cases
      assume eq: "m = n"
      from Suc and A have "P n" by blast
      with eq show "P m" by simp
    next
      assume "m \<noteq> n"
      with Suc have "m < n" by arith
      then show "P m" by(rule Suc)
    qed
  qed
qed


-- -----------------------------------------------------------------  

-- {* primitive recursion *}

consts
  app :: "'a list => 'a list => 'a list"
  rv :: "'a list => 'a list"

primrec
  "app Nil ys = ys"
  "app (Cons x xs) ys = Cons x (app xs ys)"

print_theorems

primrec
  "rv [] = []"
  "rv (x # xs) = app (rv xs) [x]"
  (* complete *)


-- {* on trees *}
consts
  mirror :: "'a tree => 'a tree"
primrec
  "mirror Tip = Tip"
  "mirror (Node l x r) = Node (mirror r) x (mirror l)"

print_theorems


-- {* mutual recursion *}
consts
  has_int :: "ty \<Rightarrow> bool"
  has_int_ref :: "ref \<Rightarrow> bool"

primrec
  "has_int Integer       = True"
  "has_int Real          = False"
  "has_int (RefT T)      = has_int_ref T"

  "has_int_ref Class     = False"
  "has_int_ref (Array T) = has_int T"



-- ------------------------------------------------------------------

-- {* structural induction on lists *}

-- {* finding lemmas *}

theorem rv_rv: "rv (rv xs) = xs"
  oops













-- {* solution *}

theorem app_right_empty: "app xs [] = xs"
proof (induct xs)
  case Nil show ?case by simp
next
  case Cons then show ?case by simp
qed

theorem app_assoc: "app (app xs ys) zs = app xs (app ys zs)"
proof (induct xs)
  case Nil show ?case by simp
next
  case Cons then show ?case by simp
qed

theorem rv_app: "rv (app xs ys) = app (rv ys) (rv xs)"
proof (induct xs)
  case Nil
  show ?case by (simp add: app_right_empty)
next
  case Cons
  then show ?case by (simp add: app_assoc)
qed

theorem rv_rv: "rv (rv xs) = xs"
proof (induct xs)
  case Nil
  show ?case by simp
next
  case Cons
  then show ?case by (simp add: rv_app)
qed


-- {* induction heuristics *}

consts 
  itrev :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
primrec
  "itrev [] ys = ys"
  "itrev (x#xs) ys = itrev xs (x#ys)"

lemma "itrev xs ys = rev xs @ ys"
  oops
















-- {* solution *}

lemma "\<And>ys. itrev xs ys = rev xs @ ys"
proof (induct xs)
  case Nil show ?case by simp
next
  case (Cons a xs ys)
  then show ?case by simp
qed


-- ------------------------------------------------------------------

section {* General Recursion *}

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"

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


-- ------------------------------------------------------------------

(*
fun quicksort :: "nat list \<Rightarrow> nat list"
  where
    "quicksort [] = []"
  | "quicksort (x#xs) =
      quicksort [y <- xs . y \<le> x] @ [x] @
      quicksort [y <- xs . x < y]"
*)

function (sequential) quicksort :: "nat list \<Rightarrow> nat list"
  where
    "quicksort [] = []"
  | "quicksort (x#xs) =
      quicksort [y <- xs . y \<le> x] @ [x] @ quicksort [y <- xs . x < y]"
  by pat_completeness auto

print_theorems

termination by (lexicographic_order simp: less_Suc_eq_le)

value "quicksort [0::nat, 8, 7, 5, 2]"


function sum :: "nat \<Rightarrow> nat \<Rightarrow> nat" 
  where 
    "sum i N = (if i > N then 0 else i + sum (Suc i) N)" 
by pat_completeness auto

(*
termination by (lexicographic_order)
*)

termination
proof (relation "measure (\<lambda>(i, N). N + 1 - i)")
  show "wf (measure (\<lambda>(i, N). N + 1 - i))" ..
next
  fix i N :: nat
  assume "\<not> N < i"
  then show "((Suc i, N), i, N) \<in> measure (\<lambda>(i, N). N + 1 - i)" by simp
qed

value "sum 0 5"

end