theory Demo12 = Main:

consts sep :: "'a \<times> 'a list \<Rightarrow> 'a list"
recdef sep "measure (\<lambda>(a, xs). size xs)"
  "sep (a, x # y # zs) = x # a # sep (a, y # zs)"
  "sep (a, xs) = xs"

lemma "sep (a, [x,y,z]) = bla" 
  apply simp
  oops

lemma "map f (sep (x,xs)) = sep (f x, map f xs)"
  apply (induct xs)
  















oops
-- solution

lemma "map f (sep (x,xs)) = sep (f x, map f xs)"
  apply (induct x xs rule: sep.induct)
  apply auto
  done


consts ack :: "nat \<times> nat \<Rightarrow> nat"
recdef ack "measure (\<lambda>m. m) <*lex*> measure (\<lambda>n. n)"
  "ack (0, n) = Suc n"
  "ack (Suc m, 0) = ack (m, 1)"
  "ack (Suc m, Suc n) = ack (m, ack (m+1, n))"

thm ack.induct


consts quicksort :: "nat list \<Rightarrow> nat list"
recdef (permissive) quicksort "measure length"
  "quicksort [] = []"
  "quicksort (x#xs) = quicksort [y \<in> xs. y \<le> x] @ [x] @ quicksort [y \<in> xs. x < y]"
(*
(hints recdef_simp: less_Suc_eq_le)
*)


consts quicksort2 :: "nat list \<Rightarrow> nat list"
recdef (permissive) quicksort2 "measure length"
  "quicksort2 [] = []"
  "quicksort2 (x#xs) = quicksort2 [y \<in> xs. y \<le> x] @ [x] @ quicksort2 [y \<in> xs. x < y]"

print_theorems

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

-- "wfrec"

thm wf_def

thm wfrecI
thm wfrec_def
thm cut_def

thm wfrec

consts f :: "nat \<Rightarrow> nat"
recdef f "measure id"
  "f 0 = 0"
  "f (Suc n) = f n + 1"

print_theorems

thm wf_measure
thm wf_less
thm wf_lex_prod
thm finite_acyclic_wf acyclic_def


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

-- "also/finally"

lemma right_inverse:
  fixes prod :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"    (infixl "\<cdot>" 70)
  fixes inv :: "'a \<Rightarrow> 'a"    ("(_\<^sup>-)" [1000] 999)
  fixes one :: 'a    ("\<one>")

  assumes assoc: "\<And>x y z. (x \<cdot> y) \<cdot> z = x \<cdot> (y \<cdot> z)"
  assumes left_inv: "\<And>x. x\<^sup>- \<cdot> x = \<one>"
  assumes left_one: "\<And>x. \<one> \<cdot> x = x"

  shows "x \<cdot> x\<^sup>- = \<one>"
proof -
  have "x \<cdot> x\<^sup>- = \<one> \<cdot> (x \<cdot> x\<^sup>-)" by (simp only: left_one)
  also have "\<dots> = \<one> \<cdot> x \<cdot> x\<^sup>-" by (simp only: assoc)
  also have "\<dots> = (x\<^sup>-)\<^sup>- \<cdot> x\<^sup>- \<cdot> x \<cdot> x\<^sup>-" by (simp only: left_inv)
  also have "\<dots> = (x\<^sup>-)\<^sup>- \<cdot> (x\<^sup>- \<cdot> x) \<cdot> x\<^sup>-" by (simp only: assoc)
  also have "\<dots> = (x\<^sup>-)\<^sup>- \<cdot> \<one> \<cdot> x\<^sup>-" by (simp only: left_inv)
  also have "\<dots> = (x\<^sup>-)\<^sup>- \<cdot> (\<one> \<cdot> x\<^sup>-)" by (simp only: assoc)
  also have "\<dots> = (x\<^sup>-)\<^sup>- \<cdot> x\<^sup>-" by (simp only: left_one)
  also have "\<dots> = \<one>" by (simp only: left_inv)
  finally show ?thesis .
qed


declare f.simps [simp del]
lemma "f (Suc n) = f n + 1"
proof -
  let ?R = "measure id"
  let ?F = "\<lambda>f. nat_case 0 (\<lambda>u. f u + 1)"  
  have wf: "wf ?R" by (rule wf_measure)

  have "f (Suc n) = wfrec ?R ?F (Suc n)" by (simp only: f_def)
  also













  from wf 
  have "\<dots> = ?F (cut (wfrec ?R ?F) ?R (Suc n)) (Suc n)" by (rule wfrec)
  also
  have "\<dots> = cut (wfrec ?R ?F) ?R (Suc n) n + 1" by simp
  also
  have "\<dots> = wfrec ?R ?F n + 1" by (simp add: cut_def measure_def inv_image_def)
  also
  have "\<dots> = f n + 1" by (simp only: f_def)
  finally 
  show ?thesis .
qed
  

-- "mixed operators"
lemma "1 < (5::nat)"
proof -
  have "1 < Suc 1" by simp
  also
  have "Suc 1 = 2" by simp
  also
  have "2 \<le> (5::nat)" by simp
  finally
  show ?thesis .
qed
  
-- "substitution"
lemma blah
proof -
  have "x + 2*y = (0::nat)" sorry
  also
  have "2*y = x" sorry
  also
  have "(0::nat) \<le> 2*c" sorry
  also
  have "c = d div 2" sorry
  also
  have "d = 2 * x" sorry  
  finally
  have "x + x \<le> 2 * x " by simp
oops
    
-- "antisymmetry"
lemma blub
proof -
  have "a < (b::nat)" sorry
  also
  have "b < a" sorry
  finally
  show blub .
qed


-- "notE as trans"

thm notE
declare notE [trans]

lemma blub
proof -
  have "\<not>P" sorry
  also
  have "P" sorry
  finally
  show blub .
qed


-- "monotonicity"

lemma "a+b \<le> 2*a + 2*(b::nat)" 
proof -
  have "a + b \<le> 2*a + b" by simp
  also
  have "b \<le> 2*b" by simp
  finally
  show "a+b \<le> 2*a + 2*(b::nat)" by simp
qed

lemma "a+b \<le> 2*a + 2*(b::nat)" 
proof -
  have "a + b \<le> 2*a + b" by simp
  also
  have "b \<le> 2*b" by simp
  also
  have "\<And>x y. x \<le> y \<Longrightarrow> 2 * a + x \<le> 2 * a + y" by simp
  ultimately
  show "a+b \<le> 2*a + 2*(b::nat)" .
qed
  

declare ring_eq_simps [simp] 
lemma "(a+b::int)\<twosuperior> \<le> 2*(a\<twosuperior> + b\<twosuperior>)"
proof -
       have "(a+b)\<twosuperior> \<le> (a+b)\<twosuperior> + (a-b)\<twosuperior>"  by simp
  also have "(a+b)\<twosuperior> \<le> a\<twosuperior> + b\<twosuperior> + 2*a*b"  by (simp add: numeral_2_eq_2)
  also have "(a-b)\<twosuperior> = a\<twosuperior> + b\<twosuperior> - 2*a*b"  by (simp add:numeral_2_eq_2)
  finally show ?thesis by simp
qed


end