(*  Title:      ZF/Induct/Mutil.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1996  University of Cambridge
*)

section {* The Mutilated Chess Board Problem, formalized inductively *}

theory Mutil imports Main begin

text {*
  Originator is Max Black, according to J A Robinson.  Popularized as
  the Mutilated Checkerboard Problem by J McCarthy.
*}

consts
  domino :: i
  tiling :: "i => i"

inductive
  domains "domino" \<subseteq> "Pow(nat \<times> nat)"
  intros
    horiz: "[| i \<in> nat;  j \<in> nat |] ==> {<i,j>, <i,succ(j)>} \<in> domino"
    vertl: "[| i \<in> nat;  j \<in> nat |] ==> {<i,j>, <succ(i),j>} \<in> domino"
  type_intros empty_subsetI cons_subsetI PowI SigmaI nat_succI

inductive
  domains "tiling(A)" \<subseteq> "Pow(\<Union>(A))"
  intros
    empty: "0 \<in> tiling(A)"
    Un: "[| a \<in> A;  t \<in> tiling(A);  a \<inter> t = 0 |] ==> a \<union> t \<in> tiling(A)"
  type_intros empty_subsetI Union_upper Un_least PowI
  type_elims PowD [elim_format]

definition
  evnodd :: "[i, i] => i"  where
  "evnodd(A,b) == {z \<in> A. \<exists>i j. z = <i,j> \<and> (i #+ j) mod 2 = b}"

subsection {* Basic properties of evnodd *}

lemma evnodd_iff: "<i,j>: evnodd(A,b) \<longleftrightarrow> <i,j>: A & (i#+j) mod 2 = b"
  by (unfold evnodd_def) blast

lemma evnodd_subset: "evnodd(A, b) \<subseteq> A"
  by (unfold evnodd_def) blast

lemma Finite_evnodd: "Finite(X) ==> Finite(evnodd(X,b))"
  by (rule lepoll_Finite, rule subset_imp_lepoll, rule evnodd_subset)

lemma evnodd_Un: "evnodd(A \<union> B, b) = evnodd(A,b) \<union> evnodd(B,b)"
  by (simp add: evnodd_def Collect_Un)

lemma evnodd_Diff: "evnodd(A - B, b) = evnodd(A,b) - evnodd(B,b)"
  by (simp add: evnodd_def Collect_Diff)

lemma evnodd_cons [simp]:
  "evnodd(cons(<i,j>,C), b) =
    (if (i#+j) mod 2 = b then cons(<i,j>, evnodd(C,b)) else evnodd(C,b))"
  by (simp add: evnodd_def Collect_cons)

lemma evnodd_0 [simp]: "evnodd(0, b) = 0"
  by (simp add: evnodd_def)

subsection {* Dominoes *}

lemma domino_Finite: "d \<in> domino ==> Finite(d)"
  by (blast intro!: Finite_cons Finite_0 elim: domino.cases)

lemma domino_singleton:
    "[| d \<in> domino; b<2 |] ==> \<exists>i' j'. evnodd(d,b) = {<i',j'>}"
  apply (erule domino.cases)
   apply (rule_tac [2] k1 = "i#+j" in mod2_cases [THEN disjE])
     apply (rule_tac k1 = "i#+j" in mod2_cases [THEN disjE])
       apply (rule add_type | assumption)+
      (*Four similar cases: case (i#+j) mod 2 = b, 2#-b, ...*)
      apply (auto simp add: mod_succ succ_neq_self dest: ltD)
  done

subsection {* Tilings *}

text {* The union of two disjoint tilings is a tiling *}

lemma tiling_UnI:
    "t \<in> tiling(A) ==> u \<in> tiling(A) ==> t \<inter> u = 0 ==> t \<union> u \<in> tiling(A)"
  apply (induct set: tiling)
   apply (simp add: tiling.intros)
  apply (simp add: Un_assoc subset_empty_iff [THEN iff_sym])
  apply (blast intro: tiling.intros)
  done

lemma tiling_domino_Finite: "t \<in> tiling(domino) ==> Finite(t)"
  apply (induct set: tiling)
   apply (rule Finite_0)
  apply (blast intro!: Finite_Un intro: domino_Finite)
  done

lemma tiling_domino_0_1: "t \<in> tiling(domino) ==> |evnodd(t,0)| = |evnodd(t,1)|"
  apply (induct set: tiling)
   apply (simp add: evnodd_def)
  apply (rule_tac b1 = 0 in domino_singleton [THEN exE])
    prefer 2
    apply simp
   apply assumption
  apply (rule_tac b1 = 1 in domino_singleton [THEN exE])
    prefer 2
    apply simp
   apply assumption
  apply safe
  apply (subgoal_tac "\<forall>p b. p \<in> evnodd (a,b) \<longrightarrow> p\<notin>evnodd (t,b)")
   apply (simp add: evnodd_Un Un_cons tiling_domino_Finite
     evnodd_subset [THEN subset_Finite] Finite_imp_cardinal_cons)
  apply (blast dest!: evnodd_subset [THEN subsetD] elim: equalityE)
  done

lemma dominoes_tile_row:
    "[| i \<in> nat;  n \<in> nat |] ==> {i} * (n #+ n) \<in> tiling(domino)"
  apply (induct_tac n)
   apply (simp add: tiling.intros)
  apply (simp add: Un_assoc [symmetric] Sigma_succ2)
  apply (rule tiling.intros)
    prefer 2 apply assumption
   apply (rename_tac n')
   apply (subgoal_tac (*seems the easiest way of turning one to the other*)
     "{i}*{succ (n'#+n') } \<union> {i}*{n'#+n'} =
       {<i,n'#+n'>, <i,succ (n'#+n') >}")
    prefer 2 apply blast
  apply (simp add: domino.horiz)
  apply (blast elim: mem_irrefl mem_asym)
  done

lemma dominoes_tile_matrix:
    "[| m \<in> nat;  n \<in> nat |] ==> m * (n #+ n) \<in> tiling(domino)"
  apply (induct_tac m)
   apply (simp add: tiling.intros)
  apply (simp add: Sigma_succ1)
  apply (blast intro: tiling_UnI dominoes_tile_row elim: mem_irrefl)
  done

lemma eq_lt_E: "[| x=y; x<y |] ==> P"
  by auto

theorem mutil_not_tiling: "[| m \<in> nat;  n \<in> nat;
         t = (succ(m)#+succ(m))*(succ(n)#+succ(n));
         t' = t - {<0,0>} - {<succ(m#+m), succ(n#+n)>} |]
      ==> t' \<notin> tiling(domino)"
  apply (rule notI)
  apply (drule tiling_domino_0_1)
  apply (erule_tac x = "|?A|" in eq_lt_E)
  apply (subgoal_tac "t \<in> tiling (domino)")
   prefer 2 (*Requires a small simpset that won't move the succ applications*)
   apply (simp only: nat_succI add_type dominoes_tile_matrix)
  apply (simp add: evnodd_Diff mod2_add_self mod2_succ_succ
    tiling_domino_0_1 [symmetric])
  apply (rule lt_trans)
   apply (rule Finite_imp_cardinal_Diff,
     simp add: tiling_domino_Finite Finite_evnodd Finite_Diff,
     simp add: evnodd_iff nat_0_le [THEN ltD] mod2_add_self)+
  done

end


theory Reduction
imports "FreeGroupMain"  "HOL-Library.FuncSet" "HOL-Algebra.Group"
begin

(*Lemmas on reduction and reduced functions, and the reduction relation.*)
(*
lemma length_reduction:
 "length (reduction wrd) \<le> length wrd"
proof(induction wrd rule: reduction.induct)
case 1
  then show ?case by simp
next
case (2 x)
  then show ?case by simp
next
  case (3 g1 g2 wrd)
  then show ?case
  proof(cases "g1 = inverse g2")
    case True
    then show ?thesis using 3 by force
  next
    case False
    then show ?thesis using 3
    by auto
 qed
qed

lemma decreasing_length:
  assumes "reduction wrd \<noteq> wrd"
  shows "length (reduction wrd) < length wrd"
  using assms
proof(induction wrd rule: reduction.induct)
case 1
  then show ?case by simp
next
  case (2 x)
  then show ?case by simp
next
  case (3 g1 g2 wrd)
  then show ?case
  proof(cases "g1 = inverse g2")
    case True
    then have red_inv:"reduction (g1#g2#wrd) = reduction wrd" by auto
    then show ?thesis
    proof(cases "reduction wrd = wrd")
      case True
      then have "reduction (g1#g2#wrd) = wrd" using red_inv by auto
      then have "length (reduction (g1#g2#wrd)) = length wrd" by auto
      then show ?thesis
        by simp
    next
      case False
      then have "length (reduction wrd) < length wrd" using 3 True by argo
      then show ?thesis using red_inv by force
    qed
  next
    case False
    have prem:"reduction (g1#g2#wrd) \<noteq> (g1#g2#wrd)" using 3 by argo
    then have "reduction (g1#g2#wrd) = g1#reduction (g2#wrd)" using False by auto
    then have "reduction (g2#wrd) \<noteq> g2#wrd" using prem by fastforce
    then have "length (g2#wrd) > length (reduction (g2#wrd))" using 3 False by blast
    then have "length (g1#g2#wrd) > length (reduction (g1#g2#wrd))" using False by force
    then show ?thesis by fast
  qed
qed

lemma if_length_reduction_eq:
  assumes "length (reduction (wrd)) = length wrd"
  shows "reduction wrd = wrd"
  using assms
proof(induction wrd rule: reduction.induct)
case 1
  then show ?case
    by simp
next
  case (2 x)
  then show ?case by simp
next
case (3 g1 g2 wrd)
  then show ?case
  proof(cases "g1 = inverse g2")
    case True
    then have "reduction (g1#g2#wrd) = reduction (wrd)" by simp
    then have "length (reduction (g1#g2#wrd)) = length (reduction (wrd))" by auto
    moreover have "length (wrd) > length (reduction wrd)" using 3 by (metis \<open>reduction (g1 # g2 # wrd) = reduction wrd\<close> decreasing_length impossible_Cons le_cases)
    then show ?thesis using 3 by auto
  next
    case False
    then show ?thesis using "3.prems" decreasing_length nat_neq_iff by blast
  qed
qed

lemma reduction_fixpt:
  assumes "reduction wrd = wrd"
  shows "reduced wrd"
  using assms
proof(induction wrd rule:reduction.induct)
case 1
then show ?case by simp
next
case (2 x)
  then show ?case by simp
next
  case (3 g1 g2 wrd)
  then show ?case by (metis decreasing_length impossible_Cons length_Cons less_Suc_eq less_or_eq_imp_le list.inject reduced.simps(3) reduction.simps(3))
qed

lemma reduction_fixpt_conv:
  assumes "reduced wrd"
  shows "reduction wrd = wrd"
  using assms
proof(induction wrd rule: reduction.induct)
  case 1
  then show ?case by simp
next
  case (2 x)
  then show ?case by simp
next
  case (3 g1 g2 wrd)
  then show ?case
  proof(cases "g1 = inverse g2")
    case True
      then show ?thesis using 3
        by force
    next
    case False
    have "reduced (g2#wrd)" using False 3 by force
      then show ?thesis using False 3 by force
    qed
  qed
*)
lemma reduced_rightappend:
  assumes "reduced (xs@ys)"
  shows "reduced xs"
  using assms
proof (induction xs rule : reduced.induct)
case 1
then show ?case try
  by simp
next
  case (2 x)
  then show ?case try
    by simp
next
  case (3 g1 g2 wrd)
  then show ?case
  proof (cases "g1 =  inverse g2")
    case True
then show ?thesis
  using "3.prems" by force
next
  case False
  have "reduced ((g2 # wrd) @ ys)"
    by (metis "3.prems" append_Cons reduced.simps(3))
  then have "reduced (g2#wrd)"  by (simp add: "3.IH" False)
  then show ?thesis by (simp add: False)
qed
qed

lemma reduced_leftappend:
  assumes "reduced (xs@ys)"
  shows "reduced ys"
  using assms
proof(induction xs rule:reduced.induct)
  case (2 g)
  then show ?case using reduced.simps
    by (metis (mono_tags, hide_lams) append_Cons append_Nil reduced.elims(3))
next
  case (3 g h wrd)
  then show ?case
    by force
qed (simp)

lemma assumes "\<not>(reduced ys)"
  shows  "\<not>(reduced (xs@ys))"
proof-
  have 1: "reduced (xs@ys) \<longrightarrow> reduced ys" using reduced_leftappend[of xs ys] by simp
  then show ?thesis using not_mono [OF 1] assms by argo
qed

lemma inv_not_reduced:
  assumes "(i + 1) < length wrd"  "inverse (wrd ! i) = (wrd ! (i + 1))"
  shows "\<not>(reduced wrd)"
  using assms
proof-
  have "inverse (wrd ! i) = wrd ! (i + 1)" using assms by auto
  have "i + 1 < length wrd" using  assms by blast
  then have 1: "wrd = (take i wrd) @ ((wrd ! i)#(wrd !(i + 1))#(drop (i + 2) wrd))" by (metis Cons_nth_drop_Suc Suc_1 Suc_eq_plus1 add_Suc_right add_lessD1 append_take_drop_id)
  then have "\<not>(reduced ((wrd ! i)#(wrd ! (i + 1))#(drop (i + 2) wrd)))" using assms by (metis inverse_of_inverse reduced.simps(3))
  then have "reduced wrd = False" using "1" by (metis reduced_leftappend)
  then show ?thesis using assms by simp
qed

lemma reduced_no_inv:
  assumes "reduced wrd" "(i + 1) < length wrd"
  shows "\<not>(inverse (wrd ! i)) = (wrd ! (i + 1))"
proof-
  have 1: "((inverse (wrd ! i)) = (wrd ! (i + 1))) \<longrightarrow> (\<not>(reduced wrd))" using inv_not_reduced assms(2) by auto
  then show ?thesis using not_mono [OF 1] assms by argo
qed

lemma inv_emptylist:
  assumes "h = inverse g"
  shows "[g, h] ~ []"
  using assms reln.base inverse.simps by simp

lemma relation: "(xs@ys) ~ xs@[g,inverse g]@ys"
  using reln.base reln.refl reln.mult
proof-
  have "(xs@[g, inverse g]) ~ xs" using reln.base reln.mult reln.refl by fastforce
  then show ?thesis using mult[of "xs@[g, inverse g]" "xs" "ys" "ys"] reln.refl reln.sym
    by auto
qed
(*
lemma rel_to_reduction:"xs ~ reduction xs"
proof(induction xs rule:reduce.induct )
  case 1
  then show ?case
    using reln.refl by auto
next
  case (2 x)
  then show ?case using reln.refl by auto
next
  case (3 g1 g2 wrd)
  then show ?case
  proof(cases "g1 = inverse g2")
    case True
    have "[g1,  g2] ~ []" using reln.base[of "g1"] inverse_of_inverse[of "g1" "g2"] True
      by blast
    then have 1:"([g1,g2]@wrd) ~ wrd" using reln.mult refl by fastforce
    with 3(1) have 2:"reduction ([g1,g2]@wrd) ~ wrd" using reln.trans True
      using append_Cons append_Nil reduction.simps(3) reln.sym by auto
    then show ?thesis using 1 reln.sym reln.trans
      by (metis append_Cons append_Nil)
next
  case False
  then have "([g1]@(g2#wrd)) ~ ([g1] @(reduction (g2#wrd)))" using 3(2) reln.mult reln.refl
    by blast
  then have "([g1]@(g2#wrd)) ~ (reduction (g1#g2#wrd))" using False by simp
  then show ?thesis by simp
qed
qed
*)

end


theory Exercise5
  imports Main
begin

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

theorem sum_first_n [simp]: "sum n = (n * (n + 1)) div 2"
  apply (induction n)
  apply (auto)
done

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_prop_22
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 z xs) = S (length xs)"

fun even :: "Nat => bool" where
  "even (Z) = True"
| "even (S (Z)) = False"
| "even (S (S z2)) = even z2"

theorem property0 :
  "((even (length (x y z))) = (even (length (x z y))))"
  oops

end


theory P1
imports Main
begin
datatype nat = Zero | Suc nat
fun add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "add Zero n = n" |
  "add (Suc m) n = Suc (add m n)"

lemma add_02: "add m Zero = m"
  apply (induction m)
  apply (auto)
  done

lemma add_02_no_auto: "add m Zero = m"
proof (induct m)
  case Zero
  show "add Zero Zero = Zero"
    by simp
next
  fix m assume "add m Zero = m"
  thus "add (Suc m) Zero = Suc m" by simp
qed

end


theory Preprocess_Polys imports
  Complex_Main
  "HOL-Computational_Algebra.Computational_Algebra"
  "../Sturm_Tarski/Poly_Conversion"
begin

section \<open> @{typ "real poly"} to @{typ "int poly"} by clearing the denominators\<close>

definition is_rat::"real \<Rightarrow> bool" where
  "is_rat x = (x\<in>\<rat>)"

definition all_coeffs_rat::"real poly \<Rightarrow> bool" where
  "all_coeffs_rat p = list_all is_rat (coeffs p)"

definition rat_of_real::"real \<Rightarrow> rat" where
  "rat_of_real = inv of_rat"

lemma [code]:
    "rat_of_real (Ratreal r) = r"
  by (metis Ratreal_def f_inv_into_f of_rat_eq_iff rangeI rat_of_real_def)

lemma rat_of_real_id: "rat_of_real o of_rat = id" unfolding rat_of_real_def
  by (meson inj_onI inv_o_cancel of_rat_eq_iff)

lemma rat_of_real_0[simp]: "rat_of_real 0 = 0"
  by (metis f_inv_into_f of_rat_0 of_rat_eq_iff rangeI rat_of_real_def)

lemma rat_of_real_inv:"r\<in>\<rat> \<Longrightarrow> of_rat (rat_of_real r) = r"
unfolding rat_of_real_def
by (simp add: Rats_def f_inv_into_f)

lemma rat_of_real_0_iff:"x\<in>\<rat> \<Longrightarrow> rat_of_real x = 0 \<longleftrightarrow> x = 0"
using rat_of_real_inv by force

definition clear_de_real :: "real poly \<Rightarrow> int poly" where
  "clear_de_real p \<equiv> clear_de (map_poly rat_of_real p)"

abbreviation de_lcm_real :: "real poly \<Rightarrow> int" where
  "de_lcm_real p \<equiv> de_lcm (map_poly rat_of_real p)"

lemma clear_de_real:
  assumes "all_coeffs_rat p"
  shows "of_int_poly (clear_de_real p) = smult (de_lcm_real p) p"
proof -
  have "of_int_poly (clear_de (map_poly rat_of_real p)) =
      smult (rat_of_int (de_lcm_real p)) (map_poly rat_of_real p)"
    using clear_de[of "map_poly rat_of_real p"] .
  also have "map_poly real_of_rat ... =
        smult (real_of_int (de_lcm_real p)) (map_poly (real_of_rat \<circ> rat_of_real) p)"
    unfolding of_rat_hom.map_poly_hom_smult
    by (simp add:map_poly_map_poly)
  also have "... = smult (de_lcm_real p) (map_poly id p)"
  proof -
    have "map_poly (real_of_rat \<circ> rat_of_real) p = map_poly id p"
      apply (rule map_poly_cong)
      using assms rat_of_real_inv unfolding all_coeffs_rat_def is_rat_def
      by (simp add: list.pred_set)
    then show ?thesis by simp
  qed
  also have "... = smult (de_lcm_real p) p"
    by simp
  finally have "map_poly real_of_rat (of_int_poly (clear_de
      (map_poly rat_of_real p))) = smult (real_of_int (de_lcm_real p)) p" .
  then show ?thesis
    by (simp add:map_poly_map_poly comp_def clear_de_real_def)
qed

end


header{* Left Complemented Monoid *}

theory LeftComplementedMonoid
  imports Operations "../LatticeProperties/Lattice_Prop"
begin

class right_pordered_monoid_mult = order + monoid_mult +
  assumes mult_right_mono: "a \<le> b \<Longrightarrow> a * c \<le> b * c"

class one_greatest = one + ord +
  assumes one_greatest [simp]: "a \<le> 1"

class integral_right_pordered_monoid_mult = right_pordered_monoid_mult + one_greatest

class left_residuated = ord + times + left_imp +
  assumes left_residual: "(x * a \<le> b) = (x \<le> a l\<rightarrow> b)"

class left_residuated_pordered_monoid = integral_right_pordered_monoid_mult + left_residuated

class left_inf = inf + times + left_imp +
  assumes inf_l_def: "(a \<sqinter> b)  = (a l\<rightarrow> b) * a"

class left_complemented_monoid = left_residuated_pordered_monoid + left_inf +
  assumes right_divisibility: "(a \<le> b) = (\<exists> c . a = c * b)"
begin
lemma lcm_D: "a l\<rightarrow> a = 1"
  apply (rule antisym, simp)
  by (unfold left_residual [THEN sym], simp)

subclass semilattice_inf
    apply unfold_locales
    apply (metis inf_l_def right_divisibility)
    apply (metis inf_l_def left_residual order_refl)
    by (metis inf_l_def left_residual mult_right_mono right_divisibility)

  lemma left_one_inf [simp]: "1 \<sqinter> a = a"
    by (rule antisym, simp_all)

  lemma left_one_impl [simp]: "1 l\<rightarrow> a = a"
    (*by (metis inf_l_def left_one_inf mult.right_neutral)*)
    proof -
      have "1 l\<rightarrow> a = 1 \<sqinter> a" by (unfold inf_l_def, simp)
      also have "1 \<sqinter> a = a" by simp
      finally show ?thesis .
    qed

  lemma lcm_A: "(a l\<rightarrow> b) * a = (b l\<rightarrow> a) * b"
    apply (unfold inf_l_def [THEN sym])
    by (simp add: inf_commute)

  lemma lcm_B: "((a * b) l\<rightarrow> c) = (a l\<rightarrow> (b l\<rightarrow> c))"
    apply (rule antisym)
    apply (simp add: left_residual [THEN sym] mult.assoc)
    apply (simp add: left_residual)

    apply (simp add: left_residual [THEN sym])
    apply (rule_tac y="(b l\<rightarrow> c) * b" in order_trans)
    apply (simp add: mult.assoc [THEN sym])
    apply (rule mult_right_mono)
    by (simp_all add: left_residual)

  lemma lcm_C: "(a \<le> b) = ((a l\<rightarrow> b) = 1)"
    (*by (metis eq_iff left_residual mult.left_neutral one_greatest)*)
    proof -
      have "(a \<le> b) = (1 * a \<le> b)" by simp
      also have "\<dots> = (1 \<le> a l\<rightarrow> b)" by (unfold left_residual, simp)
      also have "\<dots> = (a l\<rightarrow> b = 1)" apply safe by(rule antisym, simp_all)
      finally show ?thesis .
    qed

  end

class less_def = ord +
  assumes less_def: "(a < b) = ((a \<le> b) \<and> \<not> (b \<le> a))"

class one_times = one + times +
  assumes one_left [simp]: "1 * a = a"
  and one_right [simp]: "a * 1 = a"

class left_complemented_monoid_algebra = left_imp + one_times + left_inf + less_def +
  assumes left_impl_one [simp]: "a l\<rightarrow> a = 1"
  and left_impl_times: "(a l\<rightarrow> b) * a = (b l\<rightarrow> a) * b"
  and left_impl_ded: "((a * b) l\<rightarrow> c) = (a l\<rightarrow> (b l\<rightarrow> c))"
  and left_lesseq: "(a \<le> b) = ((a l\<rightarrow> b) = 1)"
begin
  lemma A: "(1 l\<rightarrow> a) l\<rightarrow> 1 = 1"
    proof -
      have "(1 l\<rightarrow> a) l\<rightarrow> 1 = (1 l\<rightarrow> a) * 1 l\<rightarrow> 1" by simp
      also have "... = (a l\<rightarrow> 1) * a l\<rightarrow> 1" by (subst left_impl_times, simp)
      also have "... = 1" by (simp add: left_impl_ded)
      finally show ?thesis .
    qed

  subclass order
    proof
      fix x y show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)" by (unfold less_def, simp)
    next
      fix x show "x \<le> x" by (unfold left_lesseq, simp)
    next
      fix x y z assume a: "x \<le> y" assume b: "y \<le> z"
      have "x l\<rightarrow> z = 1 * x l\<rightarrow> z" by simp
      also have "... = (x l\<rightarrow> y) * x l\<rightarrow> z" by (cut_tac a, simp add: left_lesseq)
      also have "... = (y l\<rightarrow> x) * y l\<rightarrow> z" by (simp add: left_impl_times)
      also have "... = (y l\<rightarrow> x) l\<rightarrow> (y l\<rightarrow> z)" by (simp add: left_impl_ded)
      also have "... = (y l\<rightarrow> x) l\<rightarrow> 1" by (cut_tac b, simp add: left_lesseq)
      also have "... = (1 * y l\<rightarrow> x) l\<rightarrow> 1" by simp
      also have "... = (1 l\<rightarrow> (y l\<rightarrow> x)) l\<rightarrow> 1" by (subst left_impl_ded, simp)
      also have "... = 1" by (simp add: A)
      finally show "x \<le> z"  by (simp add: left_lesseq)
    next
      fix x y z assume a: "x \<le> y" assume b: "y \<le> x"
      have "x = (x l\<rightarrow> y) * x" by (cut_tac a, simp add: left_lesseq)
      also have "... = (y l\<rightarrow> x) * y" by (simp add: left_impl_times)
      also have "... = y" by (cut_tac b, simp add: left_lesseq)
      finally show "x = y" .
    qed

  lemma B: "(1 l\<rightarrow> a) \<le> 1"
    apply (unfold left_lesseq)
    by (rule A)

  lemma C: "a \<le> (1 l\<rightarrow> a)"
    by (simp add: left_lesseq left_impl_ded [THEN sym])

  lemma D: "a \<le> 1"
    apply (rule_tac y = "1 l\<rightarrow> a" in order_trans)
    by (simp_all add: C B)

  lemma less_eq: "(a \<le> b) = (\<exists> c . a = (c * b))"
    (*by (metis left_impl_ded left_impl_one left_impl_times left_lesseq one_left)*)
    apply safe
    apply (unfold left_lesseq)
    apply (rule_tac x = "b l\<rightarrow> a" in exI)
    apply (simp add: left_impl_times)
    apply (simp add: left_impl_ded)
    apply (case_tac "c \<le> 1")
    apply (simp add: left_lesseq)
    by (simp add: D)

  lemma F: "(a * b) * c l\<rightarrow> z = a * (b * c) l\<rightarrow> z"
    by (simp add: left_impl_ded)

  lemma associativity: "(a * b) * c = a * (b * c)"
    (*by (metis F left_impl_one left_impl_times one_left)*)
    apply (rule antisym)
    apply (unfold left_lesseq)
    apply (simp add: F)
    by (simp add: F [THEN sym])

  lemma H: "a * b \<le> b"
    apply (simp add: less_eq)
    by auto

  lemma I: "a * b l\<rightarrow> b = 1"
    apply (case_tac "a * b \<le> b")
    apply (simp add: left_lesseq)
    by (simp add: H)

  lemma L: "(x * a \<le> b) = (x \<le> a l\<rightarrow> b)"
    by (simp add: left_lesseq left_impl_ded)

  subclass left_complemented_monoid
    apply unfold_locales
    apply (simp_all add:  less_def D associativity K)
    apply (simp add: L)
    by (simp add: less_eq)
  end

lemma (in left_complemented_monoid) left_complemented_monoid:
    "class.left_complemented_monoid_algebra (op *) inf (op l\<rightarrow>) (op \<le>) (op <) 1"
  by (unfold_locales, simp_all add: less_le_not_le lcm_A lcm_B lcm_C lcm_D)

end


(* Title: Kleene Algebra
   Author: Georg Struth
*)

section \<open>Kleene Algebra\<close>

theory KA
  imports Main

begin

subsection \<open>Monoids\<close>

notation times (infixl "\<cdot>" 70)

class mult_monoid = times + one +
  assumes mult_assoc: "x \<cdot> (y \<cdot> z) = (x \<cdot> y) \<cdot> z"
  and mult_unitl: "1 \<cdot> x = x"
  and mult_unitr: "x \<cdot> 1 = x"

class add_monoid = plus + zero +
  assumes add_assoc: "x + (y + z) = (x + y) + z"
  and add_unitl: "0 + x = x"
  and add_unitr: "x + 0 = x"

class abelian_add_monoid = add_monoid +
  assumes add_comm: "x + y = y + x"

subsection \<open>Semilattices\<close>

class sup_semilattice = comm_monoid_add + ord +
  assumes add_idem: "x + x = x"
  and order_def: "x \<le> y \<longleftrightarrow> x + y = y"
  and strict_order_def: "x < y \<longleftrightarrow> x \<le> y \<and> x \<noteq> y"

begin

subclass order
  sorry

lemma zero_least: "0 \<le> x"
  sorry

lemma add_isor: "x \<le> y \<Longrightarrow> x + z \<le> y + z"
proof-
  assume "x \<le> y"
  hence a: "x + y = y"
    by (simp add: order_def)
  have "x + z + y + z = x + y + z"
    by (metis add_commute local.add_assoc local.add_idem)
  also have "\<dots> = y + z"
    by (simp add: a)
  finally have "x + z + y + z = y + z".
  thus "x + z \<le> y + z"
    by (simp add: add_assoc order_def)
qed

lemma add_isol: "x \<le> y \<Longrightarrow> z + x \<le> z + y"
  sorry

lemma add_iso: "x \<le> y \<Longrightarrow> x' \<le> y' \<Longrightarrow> x + x' \<le> y + y'"
  sorry

lemma add_ubl: "x \<le> x + y"
  sorry

lemma add_ubr: "y \<le> x + y"
  sorry

lemma add_least: "x \<le> z \<Longrightarrow> y \<le> z \<Longrightarrow> x + y \<le> z"
  sorry

lemma add_lub: "(x + y \<le> z) = (x \<le> z \<and> y \<le> z)"
  using add_least add_ubl add_ubr dual_order.trans by blast

end

subsection \<open>Semirings and Dioids\<close>

class semiring = comm_monoid_add + monoid_mult +
  assumes distl: "x \<cdot> (y + z) = x \<cdot> y + x \<cdot> z"
  and distr: "(x + y) \<cdot> z = x \<cdot> z + y \<cdot> z"
  and annil [simp]: "0 \<cdot> x = 0"
  and annir [simp]: "x \<cdot> 0 = 0"

class dioid = semiring + sup_semilattice

begin

lemma mult_isol: "x \<le> y \<Longrightarrow> z \<cdot> x \<le> z \<cdot> y"
  sorry

lemma mult_isor: "x \<le> y \<Longrightarrow> x \<cdot> z \<le> y \<cdot> z"
  sorry

lemma mult_iso: "x \<le> y \<Longrightarrow> x' \<le> y' \<Longrightarrow> x \<cdot> x' \<le> y \<cdot> y'"
  sorry

end

subsection \<open>Kleene Algebras\<close>

class star =
  fixes star :: "'a \<Rightarrow> 'a" ("_\<^sup>\<star>" [101] 100)

class kleene_algebra = dioid + star +
  assumes star_unfoldl: "1 + x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
  and star_unfoldr: "1 + x\<^sup>\<star> \<cdot> x \<le> x\<^sup>\<star>"
  and star_inductl: "z + x \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<cdot> z \<le> y"
  and star_inductr: "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x\<^sup>\<star> \<le> y"

begin

lemma one_le_star: "1 \<le> x\<^sup>\<star>"
proof-
  have "1 + x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
    by (simp add: star_unfoldl)
  thus "1 \<le> x\<^sup>\<star>"
    by (simp add: add_lub)
qed

lemma star_unfoldlr: "x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
  sorry

lemma star_unfoldrr: "x\<^sup>\<star> \<cdot> x \<le> x\<^sup>\<star>"
  sorry

lemma star_infl: "x \<le> x\<^sup>\<star>"
proof-
  have "x = x \<cdot> 1"
    by simp
  also have "\<dots> \<le> x \<cdot> x\<^sup>\<star>"
    using mult_isol one_le_star by force
  also have "\<dots> \<le> x\<^sup>\<star>"
    by (simp add: star_unfoldlr)
  finally show "x \<le> x\<^sup>\<star>".
qed

lemma star_power: "x ^ i \<le> x\<^sup>\<star>"
proof (induct i)
case 0
  show "x ^ 0 \<le> x\<^sup>\<star>"
    by (simp add: one_le_star)
next
  case (Suc i)
  assume "x ^ i \<le> x\<^sup>\<star>"
  have "x ^ Suc i = x \<cdot> x ^ i"
    by simp
  also have "\<dots> \<le> x \<cdot> x\<^sup>\<star>"
    by (simp add: Suc.hyps mult_isol)
  also have "\<dots>  \<le> x\<^sup>\<star>"
    by (simp add: star_unfoldlr)
  finally show "x ^ Suc i \<le> x\<^sup>\<star>".
qed

lemma star_trans [simp]: "x\<^sup>\<star> \<cdot> x\<^sup>\<star> = x\<^sup>\<star>"
proof (rule order.antisym)
  have "x\<^sup>\<star> + x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
    by (simp add: add_least star_unfoldlr)
  thus "x\<^sup>\<star> \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
    by (simp add: star_inductl)
  have "x\<^sup>\<star> = 1 \<cdot> x\<^sup>\<star>"
    by simp
  also have "\<dots> \<le> x\<^sup>\<star> \<cdot> x\<^sup>\<star>"
    using mult_isor one_le_star by force
  finally show "x\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> x\<^sup>\<star>".
qed

lemma star_idem [simp]: "(x\<^sup>\<star>)\<^sup>\<star> = x\<^sup>\<star>"
  sorry

lemma star_unfoldl_eq [simp]: "1 + x \<cdot> x\<^sup>\<star> = x\<^sup>\<star>"
  sorry

lemma star_unfoldr_eq [simp]: "1 + x\<^sup>\<star> \<cdot> x = x\<^sup>\<star>"
  sorry

lemma star_iso: "x \<le> y \<Longrightarrow> x\<^sup>\<star> \<le> y\<^sup>\<star>"
  sorry

lemma star_slide: "(x \<cdot> y)\<^sup>\<star> \<cdot> x = x \<cdot> (y \<cdot> x)\<^sup>\<star>"
  sorry

lemma star_denest: "(x + y)\<^sup>\<star> = x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star>"
proof (rule order.antisym)
  have a: "1 \<le> x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star>"
    by (metis mult_1_right mult_isol order_trans one_le_star)
  have b: "x \<cdot> x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star>"
    by (simp add: mult_isor star_unfoldlr)
  have "y \<cdot> x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star> \<le> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star>"
    by (simp add: star_unfoldlr)
  also have  "\<dots> = 1 \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star>"
    by simp
  also have "\<dots> \<le>  x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star>"
    using mult_isor one_le_star by blast
  finally have "y \<cdot> x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star>".
  hence "1 + (x + y) \<cdot> x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star>"
    by (simp add: a b add_lub distr)
  thus  "(x + y)\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star>"
    using mult_assoc star_inductl by fastforce
  have a: "x\<^sup>\<star> \<le> (x + y)\<^sup>\<star>"
    by (simp add: add_ubl star_iso)
  have "y \<le> (x + y)\<^sup>\<star>"
    using add_lub star_infl by blast
  hence "(y \<cdot> x\<^sup>\<star>)\<^sup>\<star> \<le> ((x + y)\<^sup>\<star> \<cdot> (x + y)\<^sup>\<star>)\<^sup>\<star>"
    using a mult_iso star_iso by blast
  also have "\<dots> = (x + y)\<^sup>\<star>"
    by simp
  finally have "(y \<cdot> x\<^sup>\<star>)\<^sup>\<star> \<le> (x + y)\<^sup>\<star>".
  hence "x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star> \<le> (x + y)\<^sup>\<star> \<cdot> (x + y)\<^sup>\<star>"
    using a mult_iso by blast
  also have "\<dots> \<le> (x + y)\<^sup>\<star>"
    by simp
  finally show "x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star> \<le> (x + y)\<^sup>\<star>".
qed

lemma star_subid: "x \<le> 1 \<Longrightarrow> x\<^sup>\<star> = 1"
  sorry

lemma star_subid_iff: "(x\<^sup>\<star> = 1) = (x \<le> 1)"
  sorry

lemma zero_star [simp]: "0\<^sup>\<star> = 1"
  sorry

lemma one_star [simp]: "1\<^sup>\<star> = 1"
  sorry

lemma star_sim1: "z \<cdot> x \<le> y \<cdot> z \<Longrightarrow> z \<cdot> x\<^sup>\<star> \<le> y\<^sup>\<star> \<cdot> z"
  sorry

lemma star_sim2: "x \<cdot> z \<le> z \<cdot> y \<Longrightarrow> x\<^sup>\<star> \<cdot> z  \<le> z \<cdot> y\<^sup>\<star>"
  sorry

lemma star_inductl_var: "x \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<cdot> y \<le> y"
  sorry

lemma star_inductr_var: "y \<cdot> x \<le> y \<Longrightarrow> y \<cdot> x\<^sup>\<star> \<le> y"
  sorry

lemma church_rosser: "y\<^sup>\<star> \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> y\<^sup>\<star> \<Longrightarrow> (x + y)\<^sup>\<star> = x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
  sorry

lemma power_sup: "((\<Sum>i=0..n. x^i) \<le> y) = (\<forall>i. 0 \<le> i \<and> i \<le> n \<longrightarrow> x^i \<le> y)"
  sorry

lemma power_dist: "(\<Sum>i=0..n. x ^ i) \<cdot> x = (\<Sum>i=0..n. x ^ Suc i)"
  sorry

lemma power_sum: "(\<Sum>i=0..n. x ^ Suc i) = (\<Sum>i=1..n. x ^ i) + x ^ Suc n"
  sorry

lemma sum_star: "x\<^sup>\<star> = (x ^ Suc n)\<^sup>\<star> \<cdot> (\<Sum>i=0..n. x ^ i)"
  sorry

lemma idem_prop: "x \<cdot> x = x \<Longrightarrow> (x \<cdot> y)\<^sup>\<star> \<cdot> x = (x \<cdot> y \<cdot> x)\<^sup>\<star> \<cdot> x"
  sorry

end

subsection \<open>Linking Algebras with Models by Instantiation and Interpretation\<close>

instantiation nat :: mult_monoid
begin

instance
proof
  fix x y z :: nat
  show "x \<cdot> (y \<cdot> z) = (x \<cdot> y) \<cdot> z"
    by simp
  show "1 \<cdot> x = x"
    by simp
  show "x \<cdot> 1 = x "
    by simp
qed

end

instantiation nat :: abelian_add_monoid
begin

instance
proof
  fix x y z :: nat
  show "x + (y + z) = (x + y) + z"
    by simp
  show "0 + x = x"
    by simp
  show "x + 0 = x "
    by simp
  show "x + y = y + x"
    by simp
qed

end

typedef 'a endo = "{f::'a \<Rightarrow> 'a . True}"
  by simp

setup_lifting type_definition_endo

instantiation endo :: (type) mult_monoid
begin

lift_definition one_endo :: "'a endo" is
  "Abs_endo id".

lift_definition times_endo :: "'a endo \<Rightarrow> 'a endo \<Rightarrow> 'a endo" is
  "\<lambda>x y. Abs_endo (Rep_endo x \<circ> Rep_endo y)".

instance
  sorry

end

instantiation set :: (type) sup_semilattice
begin

definition plus_set :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set" where
  "plus_set x y = x \<union> y"

definition zero_set :: "'a set" where
  "zero_set = {}"

instance
  sorry

end

interpretation inter_sl: sup_semilattice "(\<inter>)" UNIV "(\<supseteq>)" "(\<supset>)"
  sorry

context dioid
begin

lemma power_inductl: "z + x \<cdot> y \<le> y \<Longrightarrow> x ^ i \<cdot> z \<le> y"
  sorry

lemma power_inductr: "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x ^ i \<le> y"
  sorry

end

subsection \<open>Relational Model of Kleene algebra\<close>

notation relcomp (infixl ";" 70)

interpretation rel_d: dioid "(\<union>)" "{}" Id "(;)" "(\<subseteq>)" "(\<subset>)"
  sorry

lemma power_is_relpow: "rel_d.power R i = R ^^ i"
  by (induct i) (simp_all add: relpow_commute)

lemma rel_star_def: "R\<^sup>* = (\<Union>i. rel_d.power R i)"
  sorry

lemma rel_star_contl: "R ; S\<^sup>* = (\<Union>i. R ; rel_d.power S i)"
  sorry

lemma rel_star_contr: "R\<^sup>* ; S = (\<Union>i. (rel_d.power R i) ; S)"
  sorry

lemma rel_star_unfoldl: "Id \<union> R ; R\<^sup>* = R\<^sup>*"
  sorry

lemma rel_star_unfoldr: "Id \<union> R\<^sup>* ; R = R\<^sup>*"
  sorry

lemma rel_star_inductl:
  fixes R S T :: "'a rel"
  assumes "T \<union> R ; S \<subseteq> S"
  shows "R\<^sup>* ; T \<subseteq> S"
  sorry

lemma rel_star_inductr: "(T::'a rel) \<union> S ; R \<subseteq> S \<Longrightarrow> T ; R\<^sup>* \<subseteq> S"
  sorry

interpretation rel_ka: kleene_algebra "(\<union>)" "{}" Id "(;)" "(\<subseteq>)" "(\<subset>)" rtrancl
  sorry

subsection \<open>State Transformer Model of Kleene Algebra\<close>

type_synonym 'a sta = "'a \<Rightarrow> 'a set"

definition eta :: "'a sta" ("\<eta>") where
  "\<eta> x = {x}"

definition nsta :: "'a sta" ("\<nu>") where
  "\<nu> x = {}"

definition kcomp :: "'a sta \<Rightarrow> 'a sta \<Rightarrow> 'a sta" (infixl "\<circ>\<^sub>K" 75) where
  "(f \<circ>\<^sub>K g) x = \<Union>{g y |y. y \<in> f x}"

definition kadd :: "'a sta \<Rightarrow> 'a sta \<Rightarrow> 'a sta" (infixl "+\<^sub>K" 65) where
  "(f +\<^sub>K g) x = f x \<union> g x"

definition kleq :: "'a sta \<Rightarrow> 'a sta \<Rightarrow> bool" (infix "\<sqsubseteq>" 50) where
  "f \<sqsubseteq> g = (\<forall>x. f x \<subseteq> g x)"

definition kle :: "'a sta \<Rightarrow> 'a sta \<Rightarrow> bool" (infix "\<sqsubset>" 50) where
  "f \<sqsubset> g = (f \<sqsubseteq> g \<and> f \<noteq> g)"

lemma sta_iff: "((f::'a sta) = g) = (\<forall>x y. y \<in> f x \<longleftrightarrow> y \<in> g x)"
  sorry

lemma eta_iff: "y \<in> \<eta> x = (y = x)"
  sorry

lemma nsta_iff: "y \<notin> \<nu> x"
  sorry

lemma kcomp_iff: "y \<in> (f \<circ>\<^sub>K g) x = (\<exists>z. y \<in> g z \<and> z \<in> f x)"
  sorry

lemma kadd_iff: "y \<in> (f +\<^sub>K g) x = (y \<in> f x \<or> y \<in> g x)"
  sorry

lemma kleq_iff: "f \<sqsubseteq> g = (\<forall>x y. y \<in> f x \<longrightarrow> y \<in> g x)"
  sorry

lemma kcomp_assoc: "(f \<circ>\<^sub>K g) \<circ>\<^sub>K h = f \<circ>\<^sub>K (g \<circ>\<^sub>K h)"
proof-
  {fix x y
  have "y \<in> ((f \<circ>\<^sub>K g) \<circ>\<^sub>K h) x = (\<exists>v. y \<in> h v \<and> (\<exists>w. v \<in> g w \<and> w \<in> f x))"
    unfolding kcomp_iff by simp
  also have "\<dots> = (\<exists>w. (\<exists>v. y \<in> h v \<and> v \<in> g w) \<and> w \<in> f x)"
    by force
  also have "\<dots> = (y \<in> (f \<circ>\<^sub>K (g \<circ>\<^sub>K h)) x)"
    unfolding kcomp_iff by simp
  finally have "y \<in> ((f \<circ>\<^sub>K g) \<circ>\<^sub>K h) x = (y \<in> (f \<circ>\<^sub>K (g \<circ>\<^sub>K h)) x)".}
  thus ?thesis
    by force
qed

text \<open>The following two functors yield isomorphism between the relational and state transformer model\<close>

definition r2s :: "'a rel \<Rightarrow> 'a sta" ("\<S>") where
  "\<S> R = Image R \<circ> \<eta>"

definition s2r :: "'a sta \<Rightarrow> 'a rel" ("\<R>") where
  "\<R> f = {(x,y). y \<in> f x}"

lemma r2s_iff: "y \<in> \<S> R x \<longleftrightarrow> (x,y) \<in> R"
  by (simp add: r2s_def eta_def)

lemma s2r_iff: "(x,y) \<in> \<R> f \<longleftrightarrow> y \<in> f x"
  by (simp add: s2r_def)

lemma r2s2r_inv1 [simp]: "\<R> \<circ> \<S> = id"
  sorry

lemma s2r2s_inv2 [simp]: "\<S> \<circ> \<R> = id"
  sorry

lemma r2s2r_galois: "(\<R> f = R) = (\<S> R = f)"
  sorry

lemma r2s_inj: "inj \<S>"
  sorry

lemma s2r_inj: "inj \<R>"
  sorry

lemma r2s_surj: "surj \<S>"
  sorry

lemma s2r_surj: "surj \<R>"
  sorry

lemma r2s_bij: "bij \<S>"
  sorry

lemma s2r_bij: "bij \<R>"
  sorry

lemma r2s_comp: "\<R> (f \<circ>\<^sub>K g) = \<R> f ; \<R> g"
  sorry

lemma s2r_comp: "\<S> (R ; S) = \<S> R \<circ>\<^sub>K \<S> S"
  sorry

lemma r2s_id: "\<R> \<eta> = Id"
  sorry

lemma s2r_id: "\<S> Id = \<eta>"
  sorry

lemma r2s_zero: "\<R> \<nu> = {}"
  sorry

lemma s2r_zero: "\<S> {} = \<nu>"
  sorry

lemma s2r_add: "\<R> (f +\<^sub>K g) = \<R> f \<union> \<R> g"
  sorry

lemma r2s_add: "\<S> (R \<union> S) = \<S> R +\<^sub>K \<S> S"
  sorry

lemma type_definition_s2r_r2s: "type_definition \<R> \<S> UNIV"
  unfolding type_definition_def by (meson iso_tuple_UNIV_I r2s2r_galois)

definition "rel_s2r R f = (R = \<R> f)"

lemma bi_unique_rel_s2r [transfer_rule]: "bi_unique rel_s2r"
  sorry

lemma bi_total_rel_s2r [transfer_rule]: "bi_total rel_s2r"
  sorry

lemma Id_eta_transfer [transfer_rule]: "rel_s2r Id \<eta>"
  sorry

lemma emp_nsta_transfer [transfer_rule]: "rel_s2r {} \<nu>"
  sorry

lemma relcomp_kcomp_transfer [transfer_rule]: "rel_fun rel_s2r (rel_fun rel_s2r rel_s2r) (;) (\<circ>\<^sub>K)"
  sorry

lemma un_kadd_transfer [transfer_rule]: "rel_fun rel_s2r (rel_fun rel_s2r rel_s2r) (\<union>) (+\<^sub>K)"
  sorry

lemma leq_kleq_transfer [transfer_rule]: "rel_fun rel_s2r (rel_fun rel_s2r (=)) (\<subseteq>) (\<sqsubseteq>)"
  sorry

lemma le_kle_transfer [transfer_rule]: "rel_fun rel_s2r (rel_fun rel_s2r (=)) (\<subset>) (\<sqsubset>)"
  sorry

text \<open>Next we show that state transformers form dioids using this translation.\<close>

interpretation sta_monm: monoid_mult "\<eta>" "(\<circ>\<^sub>K)"
  sorry

interpretation sta_di: dioid "(+\<^sub>K)" "\<nu>" "\<eta>" "(\<circ>\<^sub>K)" "(\<sqsubseteq>)" "(\<sqsubset>)"
  sorry

text \<open>The monoid interpretation is helpful for defining the Kleene star.\<close>

abbreviation "kpow \<equiv> sta_monm.power"

definition kstar :: "'a sta \<Rightarrow> 'a sta" where
  "kstar f x = (\<Union>i. kpow f i x)"

text \<open>We can now extend the isomorphism from dioids to Kleene algebras.\<close>

lemma r2s_pow: "rel_d.power (\<R> f) i = \<R> (kpow f i)"
  sorry

lemma r2s_star: "\<R> (kstar f) = (\<R> f)\<^sup>*"
proof-
  {fix x y
    have "(x,y) \<in> \<R> (kstar f) = (\<exists>i. y \<in> kpow f i x)"
      by (simp add: kstar_def s2r_def)
    also have "\<dots> = ((x,y) \<in> (\<Union>i. \<R> (kpow f i)))"
      unfolding s2r_def by simp
    also have "\<dots> = ((x,y) \<in> (\<Union>i. rel_d.power (\<R> f) i))"
      using r2s_pow by fastforce
    finally have "(x,y) \<in> \<R> (kstar f) = ((x,y) \<in> (\<R> f)\<^sup>*)"
      using rel_star_def by blast}
  thus ?thesis
    by auto
qed

lemma s2r_pow: "\<S> (rel_d.power R i) = kpow (\<S> R) i"
  sorry

lemma s2r_star: "\<S> (R\<^sup>*) = kstar (\<S> R)"
  sorry

text \<open>Finally we prove that state transformers form Kleene algebras.\<close>

lemma rtrancl_kstar_transfer [transfer_rule]: "rel_fun rel_s2r rel_s2r rtrancl kstar"
  sorry

interpretation sta_ka: kleene_algebra "(+\<^sub>K)" "\<nu>" "\<eta>" "(\<circ>\<^sub>K)" "(\<sqsubseteq>)" "(\<sqsubset>)" kstar
  sorry

subsection \<open>Embedding Predicates into State Transformers and Relations\<close>

type_synonym 'a pred = "'a \<Rightarrow> bool"

text \<open>First we consider relations.\<close>

definition p2r :: "'a pred \<Rightarrow> 'a rel" ("\<lceil>_\<rceil>\<^sub>r") where
  "\<lceil>P\<rceil>\<^sub>r = {(s,s) |s. P s}"

definition r2p :: "'a rel \<Rightarrow> 'a pred" ("\<lfloor>_\<rfloor>\<^sub>r")where
  "\<lfloor>R\<rfloor>\<^sub>r \<equiv> (\<lambda>s. s \<in> Domain R)"

lemma r2p2r [simp]: "\<lfloor>\<lceil>P\<rceil>\<^sub>r\<rfloor>\<^sub>r = P"
  sorry

lemma p2r2p: "R \<subseteq> Id \<Longrightarrow> \<lceil>\<lfloor>R\<rfloor>\<^sub>r\<rceil>\<^sub>r = R"
  sorry

lemma p2r_r2p_galois: "R \<subseteq> Id \<Longrightarrow> (\<lfloor>R\<rfloor>\<^sub>r = P) = (R = \<lceil>P\<rceil>\<^sub>r)"
  sorry

lemma p2r_comp [simp]: "\<lceil>P\<rceil>\<^sub>r ; \<lceil>Q\<rceil>\<^sub>r = \<lceil>\<lambda>s. P s \<and> Q s\<rceil>\<^sub>r"
  sorry

lemma r2p_comp: "R \<subseteq> Id \<Longrightarrow> S \<subseteq> Id \<Longrightarrow> \<lfloor>R ; S\<rfloor>\<^sub>r = (\<lambda>s. \<lfloor>R\<rfloor>\<^sub>r s \<and> \<lfloor>S\<rfloor>\<^sub>r s)"
  sorry

lemma p2r_imp [simp]: "\<lceil>P\<rceil>\<^sub>r \<subseteq> \<lceil>Q\<rceil>\<^sub>r = (\<forall>s. P s \<longrightarrow> Q s)"
  sorry

text \<open>Next we repeat the development with state transformers.\<close>

definition p2s :: "'a pred \<Rightarrow> 'a sta" ("\<lceil>_\<rceil>\<^sub>s") where
  "\<lceil>P\<rceil>\<^sub>s x \<equiv> if P x then {x} else {}"

definition s2p :: "'a sta \<Rightarrow> 'a pred" ("\<lfloor>_\<rfloor>\<^sub>s")where
  "\<lfloor>f\<rfloor>\<^sub>s s \<equiv> (f s \<noteq> {})"

lemma s2p2s [simp]: "\<lfloor>\<lceil>P\<rceil>\<^sub>s\<rfloor>\<^sub>s = P"
  sorry

lemma p2s2p: "f \<sqsubseteq> \<eta> \<Longrightarrow> \<lceil>\<lfloor>f\<rfloor>\<^sub>s\<rceil>\<^sub>s = f"
  sorry

lemma p2s_s2p_galois: "f \<sqsubseteq> \<eta> \<Longrightarrow> (\<lfloor>f\<rfloor>\<^sub>s = P) = (f = \<lceil>P\<rceil>\<^sub>s)"
  sorry

lemma p2s_comp [simp]: "\<lceil>P\<rceil>\<^sub>s \<circ>\<^sub>K \<lceil>Q\<rceil>\<^sub>s = \<lceil>\<lambda>s. P s \<and> Q s\<rceil>\<^sub>s"
  sorry

lemma s2p_comp: "f \<sqsubseteq> \<eta> \<Longrightarrow> g \<sqsubseteq> \<eta> \<Longrightarrow> \<lfloor>f \<circ>\<^sub>K g\<rfloor>\<^sub>s = (\<lambda>s. \<lfloor>f\<rfloor>\<^sub>s s \<and> \<lfloor>g\<rfloor>\<^sub>s s)"
  sorry

lemma p2s_imp [simp]: "\<lceil>P\<rceil>\<^sub>s \<sqsubseteq> \<lceil>Q\<rceil>\<^sub>s = (\<forall>s. P s \<longrightarrow> Q s)"
  sorry

lemma p2r2s: "\<lceil>P\<rceil>\<^sub>s = \<S> \<lceil>P\<rceil>\<^sub>r"
  sorry

lemma p2s2r: "\<lceil>P\<rceil>\<^sub>r = \<R> \<lceil>P\<rceil>\<^sub>s"
  sorry

end


(*  Title:      ZF/Induct/Primrec.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section {* Primitive Recursive Functions: the inductive definition *}

theory Primrec imports Main begin

text {*
  Proof adopted from @{cite szasz93}.

  See also @{cite \<open>page 250, exercise 11\<close> mendelson}.
*}

subsection {* Basic definitions *}

definition
  SC :: "i"  where
  "SC == \<lambda>l \<in> list(nat). list_case(0, \<lambda>x xs. succ(x), l)"

definition
  CONSTANT :: "i=>i"  where
  "CONSTANT(k) == \<lambda>l \<in> list(nat). k"

definition
  PROJ :: "i=>i"  where
  "PROJ(i) == \<lambda>l \<in> list(nat). list_case(0, \<lambda>x xs. x, drop(i,l))"

definition
  COMP :: "[i,i]=>i"  where
  "COMP(g,fs) == \<lambda>l \<in> list(nat). g ` map(\<lambda>f. f`l, fs)"

definition
  PREC :: "[i,i]=>i"  where
  "PREC(f,g) ==
     \<lambda>l \<in> list(nat). list_case(0,
                      \<lambda>x xs. rec(x, f`xs, \<lambda>y r. g ` Cons(r, Cons(y, xs))), l)"
  -- {* Note that @{text g} is applied first to @{term "PREC(f,g)`y"} and then to @{text y}! *}

consts
  ACK :: "i=>i"
primrec
  "ACK(0) = SC"
  "ACK(succ(i)) = PREC (CONSTANT (ACK(i) ` [1]), COMP(ACK(i), [PROJ(0)]))"

abbreviation
  ack :: "[i,i]=>i" where
  "ack(x,y) == ACK(x) ` [y]"

text {*
  \medskip Useful special cases of evaluation.
*}

lemma SC: "[| x \<in> nat;  l \<in> list(nat) |] ==> SC ` (Cons(x,l)) = succ(x)"
  by (simp add: SC_def)

lemma CONSTANT: "l \<in> list(nat) ==> CONSTANT(k) ` l = k"
  by (simp add: CONSTANT_def)

lemma PROJ_0: "[| x \<in> nat;  l \<in> list(nat) |] ==> PROJ(0) ` (Cons(x,l)) = x"
  by (simp add: PROJ_def)

lemma COMP_1: "l \<in> list(nat) ==> COMP(g,[f]) ` l = g` [f`l]"
  by (simp add: COMP_def)

lemma PREC_0: "l \<in> list(nat) ==> PREC(f,g) ` (Cons(0,l)) = f`l"
  by (simp add: PREC_def)

lemma PREC_succ:
  "[| x \<in> nat;  l \<in> list(nat) |]
    ==> PREC(f,g) ` (Cons(succ(x),l)) =
      g ` Cons(PREC(f,g)`(Cons(x,l)), Cons(x,l))"
  by (simp add: PREC_def)

subsection {* Inductive definition of the PR functions *}

consts
  prim_rec :: i

inductive
  domains prim_rec \<subseteq> "list(nat)->nat"
  intros
    "SC \<in> prim_rec"
    "k \<in> nat ==> CONSTANT(k) \<in> prim_rec"
    "i \<in> nat ==> PROJ(i) \<in> prim_rec"
    "[| g \<in> prim_rec; fs\<in>list(prim_rec) |] ==> COMP(g,fs) \<in> prim_rec"
    "[| f \<in> prim_rec; g \<in> prim_rec |] ==> PREC(f,g) \<in> prim_rec"
  monos list_mono
  con_defs SC_def CONSTANT_def PROJ_def COMP_def PREC_def
  type_intros nat_typechecks list.intros
    lam_type list_case_type drop_type map_type
    apply_type rec_type

lemma prim_rec_into_fun [TC]: "c \<in> prim_rec ==> c \<in> list(nat) -> nat"
  by (erule subsetD [OF prim_rec.dom_subset])

lemmas [TC] = apply_type [OF prim_rec_into_fun]

declare prim_rec.intros [TC]
declare nat_into_Ord [TC]
declare rec_type [TC]

lemma ACK_in_prim_rec [TC]: "i \<in> nat ==> ACK(i) \<in> prim_rec"
  by (induct set: nat) simp_all

lemma ack_type [TC]: "[| i \<in> nat;  j \<in> nat |] ==>  ack(i,j) \<in> nat"
  by auto

subsection {* Ackermann's function cases *}

lemma ack_0: "j \<in> nat ==> ack(0,j) = succ(j)"
  -- {* PROPERTY A 1 *}
  by (simp add: SC)

lemma ack_succ_0: "ack(succ(i), 0) = ack(i,1)"
  -- {* PROPERTY A 2 *}
  by (simp add: CONSTANT PREC_0)

lemma ack_succ_succ:
  "[| i\<in>nat;  j\<in>nat |] ==> ack(succ(i), succ(j)) = ack(i, ack(succ(i), j))"
  -- {* PROPERTY A 3 *}
  by (simp add: CONSTANT PREC_succ COMP_1 PROJ_0)

lemmas [simp] = ack_0 ack_succ_0 ack_succ_succ ack_type
  and [simp del] = ACK.simps

lemma lt_ack2: "i \<in> nat ==> j \<in> nat ==> j < ack(i,j)"
  -- {* PROPERTY A 4 *}
  apply (induct i arbitrary: j set: nat)
   apply simp
  apply (induct_tac j)
   apply (erule_tac [2] succ_leI [THEN lt_trans1])
   apply (rule nat_0I [THEN nat_0_le, THEN lt_trans])
   apply auto
  done

lemma ack_lt_ack_succ2: "[|i\<in>nat; j\<in>nat|] ==> ack(i,j) < ack(i, succ(j))"
  -- {* PROPERTY A 5-, the single-step lemma *}
  by (induct set: nat) (simp_all add: lt_ack2)

lemma ack_lt_mono2: "[| j<k; i \<in> nat; k \<in> nat |] ==> ack(i,j) < ack(i,k)"
  -- {* PROPERTY A 5, monotonicity for @{text "<"} *}
  apply (frule lt_nat_in_nat, assumption)
  apply (erule succ_lt_induct)
    apply assumption
   apply (rule_tac [2] lt_trans)
    apply (auto intro: ack_lt_ack_succ2)
  done

lemma ack_le_mono2: "[|j\<le>k;  i\<in>nat;  k\<in>nat|] ==> ack(i,j) \<le> ack(i,k)"
  -- {* PROPERTY A 5', monotonicity for @{text \<le>} *}
  apply (rule_tac f = "\<lambda>j. ack (i,j) " in Ord_lt_mono_imp_le_mono)
     apply (assumption | rule ack_lt_mono2 ack_type [THEN nat_into_Ord])+
  done

lemma ack2_le_ack1:
  "[| i\<in>nat;  j\<in>nat |] ==> ack(i, succ(j)) \<le> ack(succ(i), j)"
  -- {* PROPERTY A 6 *}
  apply (induct_tac j)
   apply simp_all
  apply (rule ack_le_mono2)
    apply (rule lt_ack2 [THEN succ_leI, THEN le_trans])
      apply auto
  done

lemma ack_lt_ack_succ1: "[| i \<in> nat; j \<in> nat |] ==> ack(i,j) < ack(succ(i),j)"
  -- {* PROPERTY A 7-, the single-step lemma *}
  apply (rule ack_lt_mono2 [THEN lt_trans2])
     apply (rule_tac [4] ack2_le_ack1)
      apply auto
  done

lemma ack_lt_mono1: "[| i<j; j \<in> nat; k \<in> nat |] ==> ack(i,k) < ack(j,k)"
  -- {* PROPERTY A 7, monotonicity for @{text "<"} *}
  apply (frule lt_nat_in_nat, assumption)
  apply (erule succ_lt_induct)
    apply assumption
   apply (rule_tac [2] lt_trans)
    apply (auto intro: ack_lt_ack_succ1)
  done

lemma ack_le_mono1: "[| i\<le>j; j \<in> nat; k \<in> nat |] ==> ack(i,k) \<le> ack(j,k)"
  -- {* PROPERTY A 7', monotonicity for @{text \<le>} *}
  apply (rule_tac f = "\<lambda>j. ack (j,k) " in Ord_lt_mono_imp_le_mono)
     apply (assumption | rule ack_lt_mono1 ack_type [THEN nat_into_Ord])+
  done

lemma ack_1: "j \<in> nat ==> ack(1,j) = succ(succ(j))"
  -- {* PROPERTY A 8 *}
  by (induct set: nat) simp_all

lemma ack_2: "j \<in> nat ==> ack(succ(1),j) = succ(succ(succ(j#+j)))"
  -- {* PROPERTY A 9 *}
  by (induct set: nat) (simp_all add: ack_1)

lemma ack_nest_bound:
  "[| i1 \<in> nat; i2 \<in> nat; j \<in> nat |]
    ==> ack(i1, ack(i2,j)) < ack(succ(succ(i1#+i2)), j)"
  -- {* PROPERTY A 10 *}
  apply (rule lt_trans2 [OF _ ack2_le_ack1])
    apply simp
    apply (rule add_le_self [THEN ack_le_mono1, THEN lt_trans1])
       apply auto
  apply (force intro: add_le_self2 [THEN ack_lt_mono1, THEN ack_lt_mono2])
  done

lemma ack_add_bound:
  "[| i1 \<in> nat; i2 \<in> nat; j \<in> nat |]
    ==> ack(i1,j) #+ ack(i2,j) < ack(succ(succ(succ(succ(i1#+i2)))), j)"
  -- {* PROPERTY A 11 *}
  apply (rule_tac j = "ack (succ (1), ack (i1 #+ i2, j))" in lt_trans)
   apply (simp add: ack_2)
   apply (rule_tac [2] ack_nest_bound [THEN lt_trans2])
      apply (rule add_le_mono [THEN leI, THEN leI])
         apply (auto intro: add_le_self add_le_self2 ack_le_mono1)
  done

lemma ack_add_bound2:
     "[| i < ack(k,j);  j \<in> nat;  k \<in> nat |]
      ==> i#+j < ack(succ(succ(succ(succ(k)))), j)"
  -- {* PROPERTY A 12. *}
  -- {* Article uses existential quantifier but the ALF proof used @{term "k#+#4"}. *}
  -- {* Quantified version must be nested @{text "\<exists>k'. \<forall>i,j \<dots>"}. *}
  apply (rule_tac j = "ack (k,j) #+ ack (0,j) " in lt_trans)
   apply (rule_tac [2] ack_add_bound [THEN lt_trans2])
      apply (rule add_lt_mono)
         apply auto
  done

subsection {* Main result *}

declare list_add_type [simp]

lemma SC_case: "l \<in> list(nat) ==> SC ` l < ack(1, list_add(l))"
  apply (unfold SC_def)
  apply (erule list.cases)
   apply (simp add: succ_iff)
  apply (simp add: ack_1 add_le_self)
  done

lemma lt_ack1: "[| i \<in> nat; j \<in> nat |] ==> i < ack(i,j)"
  -- {* PROPERTY A 4'? Extra lemma needed for @{text CONSTANT} case, constant functions. *}
  apply (induct_tac i)
   apply (simp add: nat_0_le)
  apply (erule lt_trans1 [OF succ_leI ack_lt_ack_succ1])
   apply auto
  done

lemma CONSTANT_case:
    "[| l \<in> list(nat);  k \<in> nat |] ==> CONSTANT(k) ` l < ack(k, list_add(l))"
  by (simp add: CONSTANT_def lt_ack1)

lemma PROJ_case [rule_format]:
    "l \<in> list(nat) ==> \<forall>i \<in> nat. PROJ(i) ` l < ack(0, list_add(l))"
  apply (unfold PROJ_def)
  apply simp
  apply (erule list.induct)
   apply (simp add: nat_0_le)
  apply simp
  apply (rule ballI)
  apply (erule_tac n = i in natE)
   apply (simp add: add_le_self)
  apply simp
  apply (erule bspec [THEN lt_trans2])
   apply (rule_tac [2] add_le_self2 [THEN succ_leI])
   apply auto
  done

text {*
  \medskip @{text COMP} case.
*}

lemma COMP_map_lemma:
  "fs \<in> list({f \<in> prim_rec. \<exists>kf \<in> nat. \<forall>l \<in> list(nat). f`l < ack(kf, list_add(l))})
    ==> \<exists>k \<in> nat. \<forall>l \<in> list(nat).
      list_add(map(\<lambda>f. f ` l, fs)) < ack(k, list_add(l))"
  apply (induct set: list)
   apply (rule_tac x = 0 in bexI)
    apply (simp_all add: lt_ack1 nat_0_le)
  apply clarify
  apply (rule ballI [THEN bexI])
  apply (rule add_lt_mono [THEN lt_trans])
       apply (rule_tac [5] ack_add_bound)
         apply blast
        apply auto
  done

lemma COMP_case:
 "[| kg\<in>nat;
     \<forall>l \<in> list(nat). g`l < ack(kg, list_add(l));
     fs \<in> list({f \<in> prim_rec .
                 \<exists>kf \<in> nat. \<forall>l \<in> list(nat).
                        f`l < ack(kf, list_add(l))}) |]
   ==> \<exists>k \<in> nat. \<forall>l \<in> list(nat). COMP(g,fs)`l < ack(k, list_add(l))"
  apply (simp add: COMP_def)
  apply (frule list_CollectD)
  apply (erule COMP_map_lemma [THEN bexE])
  apply (rule ballI [THEN bexI])
   apply (erule bspec [THEN lt_trans])
    apply (rule_tac [2] lt_trans)
     apply (rule_tac [3] ack_nest_bound)
       apply (erule_tac [2] bspec [THEN ack_lt_mono2])
         apply auto
  done

text {*
  \medskip @{text PREC} case.
*}

lemma PREC_case_lemma:
 "[| \<forall>l \<in> list(nat). f`l #+ list_add(l) < ack(kf, list_add(l));
     \<forall>l \<in> list(nat). g`l #+ list_add(l) < ack(kg, list_add(l));
     f \<in> prim_rec;  kf\<in>nat;
     g \<in> prim_rec;  kg\<in>nat;
     l \<in> list(nat) |]
  ==> PREC(f,g)`l #+ list_add(l) < ack(succ(kf#+kg), list_add(l))"
  apply (unfold PREC_def)
  apply (erule list.cases)
   apply (simp add: lt_trans [OF nat_le_refl lt_ack2])
  apply simp
  apply (erule ssubst)  -- {* get rid of the needless assumption *}
  apply (induct_tac a)
   apply simp_all
   txt {* base case *}
   apply (rule lt_trans, erule bspec, assumption)
   apply (simp add: add_le_self [THEN ack_lt_mono1])
  txt {* ind step *}
  apply (rule succ_leI [THEN lt_trans1])
   apply (rule_tac j = "g ` ?ll #+ ?mm" in lt_trans1)
    apply (erule_tac [2] bspec)
    apply (rule nat_le_refl [THEN add_le_mono])
       apply typecheck
   apply (simp add: add_le_self2)
   txt {* final part of the simplification *}
  apply simp
  apply (rule add_le_self2 [THEN ack_le_mono1, THEN lt_trans1])
     apply (erule_tac [4] ack_lt_mono2)
      apply auto
  done

lemma PREC_case:
   "[| f \<in> prim_rec;  kf\<in>nat;
       g \<in> prim_rec;  kg\<in>nat;
       \<forall>l \<in> list(nat). f`l < ack(kf, list_add(l));
       \<forall>l \<in> list(nat). g`l < ack(kg, list_add(l)) |]
    ==> \<exists>k \<in> nat. \<forall>l \<in> list(nat). PREC(f,g)`l< ack(k, list_add(l))"
  apply (rule ballI [THEN bexI])
   apply (rule lt_trans1 [OF add_le_self PREC_case_lemma])
          apply typecheck
     apply (blast intro: ack_add_bound2 list_add_type)+
  done

lemma ack_bounds_prim_rec:
    "f \<in> prim_rec ==> \<exists>k \<in> nat. \<forall>l \<in> list(nat). f`l < ack(k, list_add(l))"
  apply (induct set: prim_rec)
  apply (auto intro: SC_case CONSTANT_case PROJ_case COMP_case PREC_case)
  done

theorem ack_not_prim_rec:
    "(\<lambda>l \<in> list(nat). list_case(0, \<lambda>x xs. ack(x,x), l)) \<notin> prim_rec"
  apply (rule notI)
  apply (drule ack_bounds_prim_rec)
  apply force
  done

end