(*  Title:      Separation-Logic-Formalization/Minterm.thy
    Author:     Nicolas Amat, Mnacho Echenim, Nicolas Peltier
*)

section \<open>Minterms\<close>

text \<open>This section contains the minterms definition and some propositions related to them.\<close>

theory Minterm
imports
  Test_Formulae
begin

subsection \<open>Minterms Definition\<close>

typedef ('var, 'k::finite) minterm
  = "{S. ((\<exists>!l\<in>S::('var, 'k::finite) literal set. \<exists>n.
          (to_sl_formula l) = (ext_card_heap_ge n))
        \<and> (\<exists>!l\<in>S::('var, 'k::finite) literal set. \<exists>n.
          (to_sl_formula l) = (sl_not (ext_card_heap_ge n)))
        \<and> finite S)}"
proof
  define l1::"('var, 'k::finite) sl_formula" where "l1 = ext_card_heap_ge 0"
  have "l1\<in> test_formulae" unfolding l1_def using test_formulae.simps by auto
  define x::"('var, 'k::finite) literal set"
    where "x = {to_literal l1, to_literal (sl_not l1)}"
  show "x \<in> {S. ((\<exists>!l\<in>S::('var, 'k::finite) literal set. \<exists>n.
            (to_sl_formula l) = (ext_card_heap_ge n))
          \<and> (\<exists>!l\<in>S::('var, 'k::finite) literal set. \<exists>n.
            (to_sl_formula l) = (sl_not (ext_card_heap_ge n)))
          \<and> finite S)}"
  proof (intro CollectI conjI ex1I)
    show "to_literal l1 \<in> x" by (simp add: l1_def x_def)
    show "\<exists>n. to_sl_formula (to_literal l1) = ext_card_heap_ge n"
    proof
      show "to_sl_formula (to_literal l1) = ext_card_heap_ge 0" using \<open>l1\<in> test_formulae\<close>
        unfolding l1_def by simp
    qed
    show "\<And>l. l \<in> x \<and> (\<exists>n. to_sl_formula l = ext_card_heap_ge n) \<Longrightarrow> l = to_literal l1"
    proof -
      fix l
      assume lprop: "l \<in> x \<and> (\<exists>n. to_sl_formula l = ext_card_heap_ge n)"
      hence "\<exists>n. to_sl_formula l = ext_card_heap_ge n" by simp
      from this obtain n where ndef: "to_sl_formula l = ext_card_heap_ge n" by auto
      have "l = to_literal l1 \<or> l = to_literal (sl_not l1)" using lprop unfolding x_def by simp
      moreover have "l\<noteq> to_literal (sl_not l1)"
      proof (rule ccontr)
        assume "\<not> l \<noteq> to_literal (sl_not l1)"
        hence "l = to_literal (sl_not l1)" by simp
        hence "to_sl_formula l = (sl_not l1)" by (simp add: \<open>l1 \<in> test_formulae\<close>)
        hence "((ext_card_heap_ge n)::('var, 'k::finite) sl_formula) = sl_not l1" using ndef by simp
        also have "... = ((sl_not (ext_card_heap_ge 0))::('var, 'k::finite) sl_formula)" using  l1_def by simp
        finally have "((ext_card_heap_ge n)::('var, 'k::finite) sl_formula) = sl_not (ext_card_heap_ge 0)" .
        thus False
        proof (cases "n = \<infinity>")
          case True
          hence "ext_card_heap_ge n = sl_false" by simp
          thus ?thesis using  sl_formula.distinct
          proof -
            show ?thesis
              using True \<open>ext_card_heap_ge n = sl_not l1\<close> by auto
          qed
        next
          case False
          show ?thesis
          proof (cases "n = 0")
            case True
            hence "ext_card_heap_ge n = sl_true"
              by (simp add: enat_defs(1))
            thus ?thesis
            proof -
              show ?thesis
                by (metis \<open>ext_card_heap_ge n = sl_not l1\<close> \<open>ext_card_heap_ge n = sl_true\<close> sl_formula.distinct(3))
            qed
          next
            case False
            hence "\<exists>m. n = Suc m" using \<open>n\<noteq> \<infinity>\<close> using list_decode.cases zero_enat_def by auto
            from this obtain m where "n = Suc m" by auto
            hence "ext_card_heap_ge (n::enat) = sl_conj (ext_card_heap_ge (m)) (sl_not sl_emp)"
              by simp
            thus ?thesis
            proof -
              show ?thesis
                by (metis \<open>ext_card_heap_ge n = sl_conj (ext_card_heap_ge (enat m)) (sl_not sl_emp)\<close>
                    \<open>ext_card_heap_ge n = sl_not (ext_card_heap_ge 0)\<close> sl_formula.distinct(45))
            qed
          qed
        qed
      qed
      ultimately show "l = to_literal l1" by simp
    qed
    show "to_literal (sl_not l1) \<in> x" by (simp add: l1_def x_def)
    show "\<exists>n. to_sl_formula (to_literal (sl_not l1)) = sl_not (ext_card_heap_ge n)"
    proof
      show "to_sl_formula (to_literal (sl_not l1)) = sl_not (ext_card_heap_ge 0)" using \<open>l1\<in> test_formulae\<close>
        unfolding l1_def by simp
    qed
    show "\<And>l. l \<in> x \<and> (\<exists>n. to_sl_formula l = sl_not (ext_card_heap_ge n)) \<Longrightarrow> l = to_literal (sl_not l1)"
    proof -
      fix l
      assume lprop: "l \<in> x \<and> (\<exists>n. to_sl_formula l = sl_not (ext_card_heap_ge n))"
      hence "\<exists>n. to_sl_formula l = sl_not (ext_card_heap_ge n)" by simp
      from this obtain n where ndef: "to_sl_formula l = sl_not (ext_card_heap_ge n)" by auto
      have "l = to_literal l1 \<or> l = to_literal (sl_not l1)" using lprop unfolding x_def by simp
      moreover have "l\<noteq> to_literal (l1)"
      proof (rule ccontr)
        assume "\<not> l \<noteq> to_literal (l1)"
        hence "l = to_literal (l1)" by simp
        hence "to_sl_formula l = (l1)" by (simp add: \<open>l1 \<in> test_formulae\<close>)
        hence "((sl_not (ext_card_heap_ge n))::('var, 'k::finite) sl_formula) = l1" using ndef by simp
        also have "... = (((ext_card_heap_ge 0))::('var, 'k::finite) sl_formula)" using  l1_def by simp
        also have "... = (sl_true::('var, 'k::finite) sl_formula)" by (simp add: enat_defs)
        finally have "((sl_not (ext_card_heap_ge n))::('var, 'k::finite) sl_formula) = (sl_true)" .
        thus False
        proof (cases "n = \<infinity>")
          case True
          hence "ext_card_heap_ge n = sl_false" by simp
          hence "sl_not (ext_card_heap_ge n) = sl_not sl_false" by simp
          thus ?thesis using  sl_formula.distinct \<open>sl_not (ext_card_heap_ge n) = sl_true\<close> by simp
        next
          case False
          show ?thesis
          proof (cases "n = 0")
            case True
            hence "ext_card_heap_ge n = sl_true"
              by (simp add: enat_defs(1))
            hence "sl_not (ext_card_heap_ge n) = sl_not sl_true" by simp
            thus ?thesis using sl_formula.distinct \<open>sl_not (ext_card_heap_ge n) = sl_true\<close> by simp
          next
            case False
            hence "\<exists>m. n = Suc m" using \<open>n\<noteq> \<infinity>\<close> using list_decode.cases zero_enat_def by auto
            from this obtain m where "n = Suc m" by auto
            hence "ext_card_heap_ge (n::enat) = sl_conj (ext_card_heap_ge (m)) (sl_not sl_emp)"
              by simp
            hence "sl_not (ext_card_heap_ge n) = sl_not (sl_conj (ext_card_heap_ge (m)) (sl_not sl_emp))" by simp
            thus ?thesis using sl_formula.distinct \<open>sl_not (ext_card_heap_ge n) = sl_true\<close> by simp
          qed
        qed
      qed
      ultimately show "l = to_literal (sl_not l1)" by simp
    qed
  next
    show "finite x"
      by (simp add: x_def)
  qed
qed

subsection \<open>Minterm Casts\<close>

definition to_literal_set :: "('var, 'k::finite) minterm \<Rightarrow> ('var, 'k) literal set"
  where "to_literal_set M = Rep_minterm M"

definition to_minterm :: "('var, 'k::finite) literal set \<Rightarrow> ('var, 'k) minterm"
  where "to_minterm S = Abs_minterm S"

definition to_sl_formula_set ::  "('var, 'k::finite) minterm \<Rightarrow> ('var, 'k) sl_formula set"
  where "to_sl_formula_set M =  {(to_sl_formula l)|l. l \<in> (to_literal_set M)}"

subsection \<open>Minterm Complement\<close>

definition minterm_complement :: "('var, 'k::finite) minterm \<Rightarrow> ('var, 'k) minterm"
  where "minterm_complement M = (to_minterm {(literal_complement l) | l. l\<in>(to_literal_set M)})"

subsection \<open>Minterm Var Set\<close>

definition minterm_var_set :: "('var, 'k::finite) minterm \<Rightarrow> 'var set"
  where "minterm_var_set M = {x. \<exists>l\<in>(to_literal_set M). x\<in>(literal_var_set l)}"

subsection \<open>Minterm Evaluation\<close>

definition minterm_evl :: "('var, 'addr, 'k::finite) interp \<Rightarrow> ('var, 'k) minterm \<Rightarrow> bool"
  where "minterm_evl I M = literal_set_evl I (to_literal_set M)"

subsection \<open>Sets Definitions\<close>

subsubsection \<open>Intersections Sets\<close>

definition e_literals :: "('var, 'k::finite) literal set"
  where "e_literals = {to_literal (sl_eq x y)|x y. True}
                    \<union> {to_literal (sl_not (sl_eq x y))|x y. True}"

definition a_literals :: "('var, 'k::finite) literal set"
  where "a_literals = {to_literal (alloc x)|x. True}
                    \<union> {to_literal (sl_not (alloc x))|x. True}"

definition p_literals :: "('var, 'k::finite) literal set"
  where "p_literals = {to_literal (points_to x y)|x y. True}
                    \<union> {to_literal (sl_not (points_to x y))|x y. True}"

definition h_literals :: "('var, 'k::finite) literal set"
  where "h_literals = {to_literal (ext_card_heap_ge n) |n. True}
                    \<union> {to_literal (sl_not (ext_card_heap_ge n)) |n. True}"

subsubsection \<open>Minterms Sets Composed by an Intersection\<close>

definition e_minterm :: "('var, 'k::finite) minterm \<Rightarrow> ('var, 'k) literal set"
  where "e_minterm M = to_literal_set M \<inter> e_literals"

definition a_minterm :: "('var, 'k::finite) minterm \<Rightarrow> ('var, 'k) literal set"
  where "a_minterm M = to_literal_set M \<inter> a_literals"

definition p_minterm :: "('var, 'k::finite) minterm \<Rightarrow> ('var, 'k) literal set"
  where "p_minterm M = to_literal_set M \<inter> p_literals"

definition h_minterm :: "('var, 'k::finite) minterm \<Rightarrow> ('var, 'k) literal set"
  where "h_minterm M = to_literal_set M \<inter> h_literals"

subsection \<open>Completeness Definitions\<close>

subsubsection \<open>E-complete\<close>

definition E_complete :: "'var set \<Rightarrow> ('var, 'k::finite) minterm \<Rightarrow> bool"
  where "E_complete S M
  = (\<forall>x\<in>S. \<forall>y\<in>S.
    (to_literal (sl_eq x y)) \<in> (to_literal_set M)
  \<or> (to_literal (sl_not (sl_eq x y))) \<in> (to_literal_set M))"

subsubsection \<open>A-complete\<close>

definition A_complete :: "'var set \<Rightarrow> ('var, 'k::finite) minterm \<Rightarrow> bool"
  where "A_complete S M
  = (\<forall>x\<in>S.
    (to_literal (alloc x)) \<in> (to_literal_set M)
  \<or> (to_literal (sl_not (alloc x))) \<in> (to_literal_set M))"

subsubsection \<open>Satisfiability Condition\<close>

definition minterm_sat :: "('var, 'k::finite) minterm \<Rightarrow> bool"
  where "minterm_sat M = (\<forall>l\<in>(to_literal_set M). (literal_complement l) \<notin> (to_literal_set M))"

subsection \<open>Closures Definitions\<close>

subsubsection \<open>Complement Closure\<close>

definition cc :: "('var, 'k::finite) minterm \<Rightarrow> ('var, 'k) literal set"
  where "cc M = (to_literal_set M) \<union> {literal_complement l | l. l\<in>(to_literal_set M)}"

subsubsection \<open>Points-to Closure\<close>

definition pc :: "('var, 'k::finite) minterm \<Rightarrow> bool"
  where "pc M = (\<forall>x1. \<forall>y1. \<forall>x2. \<forall>y2.
                 (((to_literal (points_to x1 y1)) \<in> (to_literal_set M))
               \<and> ((to_literal (points_to x2 y2)) \<in> (to_literal_set M))
               \<and> ((to_literal (sl_eq x1 x2)) \<in> (to_literal_set M))
             \<longrightarrow> (\<forall>i::'k. (to_literal (sl_eq (y1 $ i) (y2 $ i))) \<in> (to_literal_set M))))"

subsubsection \<open>Domain Closure\<close>

definition dc :: "('var, 'k::finite) minterm \<Rightarrow> bool"
  where "dc M = (\<forall>n1 n2.
                ((to_literal (ext_card_heap_ge n1)) \<in> (to_literal_set M)
              \<and> (to_literal (sl_not (ext_card_heap_ge n2))) \<in> (to_literal_set M))
            \<longrightarrow> (n1 < n2))"

subsection \<open>Footprint-Consistency\<close>

definition footprint_consistent :: "('var, 'k::finite) minterm \<Rightarrow> bool"
  where "footprint_consistent M = (\<forall>x1 x2 y1 y2.
                                  (to_literal (sl_eq x1 x2) \<in> (to_literal_set M))
                                \<and> (\<forall>i::'k. to_literal (sl_eq (y1 $ i) (y2 $ i)) \<in> (to_literal_set M))
                                \<and> (to_literal (alloc x1) \<in> (to_literal_set M) \<longrightarrow> to_literal (sl_not (alloc x2)) \<notin> (to_literal_set M))
                                \<and> (to_literal (points_to x1 y1) \<in> (to_literal_set M) \<longrightarrow> (to_literal (sl_not (alloc x2)) \<notin> (to_literal_set M)
                                                                                \<and> to_literal (sl_not (points_to x2 y2)) \<notin> (to_literal_set M))))"

subsection \<open>Useful Results\<close>

subsubsection \<open>Minterms Definition\<close>

lemma minterm_have_ext_card_heap_ge:
  fixes M::"('var, 'k::finite) minterm"
  shows "\<exists>!l\<in>(to_literal_set M). \<exists>n. ((to_sl_formula l) = (ext_card_heap_ge n))"
proof -
  have "to_literal_set M \<in> {S. ((\<exists>!l\<in>S::('var, 'k::finite) literal set. \<exists>n.
                              (to_sl_formula l) = (ext_card_heap_ge n))
                          \<and> (\<exists>!l\<in>S::('var, 'k::finite) literal set. \<exists>n.
                              (to_sl_formula l) = (sl_not (ext_card_heap_ge n)))
                          \<and> finite S)}"
    by (metis (no_types) Rep_minterm to_literal_set_def)
  hence "(\<exists>!l\<in>(to_literal_set M). \<exists>n. (to_sl_formula l) = (ext_card_heap_ge n))
       \<and> (\<exists>!l\<in>(to_literal_set M). \<exists>n. (to_sl_formula l) = (sl_not (ext_card_heap_ge n)))"
    by simp
  thus ?thesis
    by simp
qed

lemma minterm_have_not_ext_card_heap_ge:
  fixes M::"('var, 'k::finite) minterm"
  shows "\<exists>!l\<in>(to_literal_set M). \<exists>n. ((to_sl_formula l) = (sl_not (ext_card_heap_ge n)))"
proof -
  have "to_literal_set M \<in> {S. ((\<exists>!l\<in>S::('var, 'k::finite) literal set. \<exists>n.
                              (to_sl_formula l) = (ext_card_heap_ge n))
                          \<and> (\<exists>!l\<in>S::('var, 'k::finite) literal set. \<exists>n.
                              (to_sl_formula l) = (sl_not (ext_card_heap_ge n)))
                          \<and> finite S)}"
    by (metis (no_types) Rep_minterm to_literal_set_def)
  hence "(\<exists>!l\<in>(to_literal_set M). \<exists>n. (to_sl_formula l) = (ext_card_heap_ge n))
       \<and> (\<exists>!l\<in>(to_literal_set M). \<exists>n. (to_sl_formula l) = (sl_not (ext_card_heap_ge n)))"
    by simp
  thus ?thesis
    by (simp add: to_literal_set_def)
qed

subsubsection \<open>Minterm Casts\<close>

lemma to_literal_set_composed_by_test_formula:
  "\<forall>l \<in> (to_literal_set M).
    (to_sl_formula (l::(('var, 'k::finite) literal)) \<in> test_formulae)
  \<or> (\<exists>l_prim. (l = to_literal (sl_not l_prim)) \<and> (l_prim \<in> test_formulae))"
  by (metis literal_atom_cases_tmp pos_literal_inv to_atom_is_test_formula)

subsubsection \<open>Minterm Var Set\<close>

lemma points_to_var_set:
  assumes "to_literal (points_to x y) \<in> to_literal_set M"
  shows "\<forall>i. (y $ i) \<in> (minterm_var_set M)"
proof
  fix i
  have "to_literal (sl_conj (sl_mapsto x y) sl_true) \<in> to_literal_set M"
    by (metis assms points_to_def)
  hence "literal_var_set  (to_literal (sl_conj (sl_mapsto x y) sl_true)) \<subseteq> (minterm_var_set M)"
    using minterm_var_set_def by fastforce
  hence "var_set (sl_mapsto x y) \<subseteq> (minterm_var_set M)"
    by (metis Un_subset_iff literal_var_set_def points_to_def pos_literal_inv test_formulae.intros(1) var_set.simps(9))
  hence "({x} \<union> {y $ i | i. True}) \<subseteq> (minterm_var_set M)"
    by auto
  thus "(y $ i) \<in> (minterm_var_set M)"
    by blast
qed

subsubsection \<open>Sets Definitions\<close>

lemma to_atom_charact:
  assumes "to_atom l \<in> test_formulae"
  shows "l \<in> a_literals \<union> e_literals \<union> p_literals \<union> h_literals"
proof -
  have atm: "to_atom l \<in> {(sl_eq x y)|x y. True} \<union> {(alloc x)|x. True}  \<union> {(points_to x y)|x y. True}
                 \<union> {ext_card_heap_ge n|n. True}" using test_formulae_charact assms by auto
  show ?thesis
  proof (cases "l = to_literal (to_atom l)")
    case True
    thus ?thesis using atm unfolding a_literals_def e_literals_def p_literals_def h_literals_def by force
  next
    case False
    hence "l = to_literal (sl_not (to_atom l))" using literal_atom_cases_tmp[of l] by simp
    thus ?thesis using atm unfolding a_literals_def e_literals_def p_literals_def h_literals_def by force
  qed
qed

lemma to_atom_minterms_sets:
  fixes M::"('var , 'k::finite) literal set"
  assumes "\<And>l::(('var, 'k) literal). ((l \<in> M) \<Longrightarrow> (to_sl_formula l) \<in> test_formulae) \<Longrightarrow> to_literal (sl_not (to_sl_formula l)) \<in> M"
    and "to_literal (to_atom l) \<in> M"
  shows "l \<in> M"
  by (metis assms(1) assms(2) literal_atom_cases_tmp pos_literal_inv to_atom_is_test_formula)

lemma from_to_atom_in_e_minterm:
  fixes M::"('var , 'k::finite) minterm"
  assumes "\<And>l::(('var, 'k) literal). (l \<in> (e_minterm M)) \<Longrightarrow> (to_sl_formula l) \<in> test_formulae \<Longrightarrow> to_literal (sl_not (to_sl_formula l)) \<in> (e_minterm M)"
    and "to_literal (to_atom l) \<in> (e_minterm M)"
  shows "l \<in> (e_minterm M)"
  by (metis assms(1) assms(2) literal_atom_cases_tmp pos_literal_inv to_atom_is_test_formula)

lemma from_to_atom_in_a_minterm:
  fixes M::"('var , 'k::finite) minterm"
  assumes "\<And>l::(('var, 'k) literal). (l \<in> (a_minterm M)) \<Longrightarrow> (to_sl_formula l) \<in> test_formulae \<Longrightarrow> to_literal (sl_not (to_sl_formula l)) \<in> (a_minterm M)"
    and "to_literal (to_atom l) \<in> (a_minterm M)"
  shows "l \<in> (a_minterm M)"
  by (metis assms(1) assms(2) literal_atom_cases_tmp pos_literal_inv to_atom_is_test_formula)

lemma from_to_atom_in_p_minterm:
  fixes M::"('var , 'k::finite) minterm"
  assumes "\<And>l::(('var, 'k) literal). (l \<in> (p_minterm M)) \<Longrightarrow> (to_sl_formula l) \<in> test_formulae \<Longrightarrow> to_literal (sl_not (to_sl_formula l)) \<in> (p_minterm M)"
    and "to_literal (to_atom l) \<in> (p_minterm M)"
  shows "l \<in> (p_minterm M)"
  by (metis assms(1) assms(2) literal_atom_cases_tmp pos_literal_inv to_atom_is_test_formula)

subsubsection \<open>Equality in Minterm\<close>

lemma eq_var_set:
  assumes "to_literal (sl_eq x y) \<in> to_literal_set M"
  shows "(x \<in> (minterm_var_set M)) \<and> (y \<in> (minterm_var_set M))"
proof -
  have "x \<in> var_set (sl_eq x y) \<and> y \<in> var_set (sl_eq x y)"
    by simp
  hence "x \<in> literal_var_set (to_literal (sl_eq x y)) \<and> y \<in> literal_var_set (to_literal (sl_eq x y))"
    by (simp add: literal_var_set_def test_formulae.intros(4))
  thus "x \<in> (minterm_var_set M) \<and> y \<in> (minterm_var_set M)"
    using assms minterm_var_set_def by fastforce
qed

lemma three_eq_sat:
  fixes M::"('var, 'k::finite) minterm"
    and I::"('var, 'addr, 'k) interp"
    and x1::'var
    and x2::'var
    and x3::'var
  assumes "to_literal (sl_eq x1 x2) \<in> (to_literal_set M)"
    and "to_literal (sl_eq x2 x3) \<in> (to_literal_set M)"
    and "minterm_evl I M"
    and "E_complete (minterm_var_set M) M"
  shows "to_literal (sl_eq x1 x3) \<in> (to_literal_set M)"
proof -
  have "x1 \<in> (minterm_var_set M)"
    by (meson assms(1) eq_var_set)
  moreover have "x2 \<in> (minterm_var_set M)"
    by (meson assms(1) eq_var_set)
  moreover have "E_complete (minterm_var_set M) M"
    by (simp add: assms(4))
  ultimately have "to_literal (sl_eq x1 x3) \<in> (to_literal_set M) \<or> to_literal (sl_not (sl_eq x1 x3)) \<in> (to_literal_set M)"
    by (meson E_complete_def assms(2) eq_var_set)
  moreover have "evaluation I (sl_eq x1 x3)"
    by (metis assms(1) assms(2) assms(3) evaluation.simps(6) literal_evl_def literal_set_evl_def
        minterm_evl_def pos_literal_inv test_formulae.intros(4))
  moreover have "minterm_evl I M"
    by (simp add: assms(3))
  ultimately show "to_literal (sl_eq x1 x3) \<in> (to_literal_set M)"
    by (metis evaluation.simps(3) literal_evl_def literal_set_evl_def minterm_evl_def
        neg_literal_inv test_formulae.intros(4))
qed

lemma eq_av:
  fixes M::"('var, 'k::finite) minterm"
    and I::"('var, 'addr, 'k) interp"
    and x1::'var
    and x2::'var
  assumes "to_literal (sl_eq x1 x2) \<in> (to_literal_set M)"
    and "x2 \<in> av (to_literal_set M)"
    and "minterm_evl I M"
    and "E_complete (minterm_var_set M) M"
  shows "x1 \<in> av (to_literal_set M)"
proof -
  have "x2 \<in> av (to_literal_set M)"
    by (simp add: assms(2))
  from this obtain x3
    where "to_literal (sl_eq x2 x3) \<in> (to_literal_set M)"
      and alloc_points_to_x3: "((to_literal_set M) \<inter> ({to_literal (alloc x3)}
                                                    \<union> {to_literal (points_to x3 y) | y. True})) \<noteq> {}"
    unfolding av_def
    by blast
  hence eq_x3: "to_literal (sl_eq x1 x3) \<in> (to_literal_set M)"
    by (meson assms(1) assms(3) assms(4) three_eq_sat)
  thus  "x1 \<in> av (to_literal_set M)" using av_def alloc_points_to_x3
    by force
qed

subsection \<open>Minterms Sets Equality\<close>

lemma minterms_sets_equality:
  fixes M::"('var, 'k::finite) minterm"
  shows  "to_literal_set M = e_minterm M \<union> a_minterm M \<union> p_minterm M \<union> h_minterm M"
proof
  define min_set::"('var, 'k::finite) literal set"
    where "min_set = e_minterm M \<union> a_minterm M \<union> p_minterm M \<union> h_minterm M"
  show "to_literal_set M \<subseteq> min_set"
  proof
    fix l
    assume asm:"l \<in> (to_literal_set M)"
    hence "to_atom l\<in> test_formulae" by (simp add: to_atom_is_test_formula)
    hence "l \<in> e_literals \<union> a_literals \<union> p_literals \<union> h_literals" using to_atom_charact by auto
    thus "l\<in> min_set" unfolding min_set_def using asm
      by (simp add: a_minterm_def e_minterm_def h_minterm_def p_minterm_def)
  qed
next
    show "e_minterm M \<union> a_minterm M \<union> p_minterm M \<union> h_minterm M \<subseteq> to_literal_set M"
      by (simp add: a_minterm_def e_minterm_def h_minterm_def p_minterm_def)
qed

subsection \<open>Proposition 5\<close>

lemma minterm_prop_5:
  fixes I_1::"('var, 'addr, 'k::finite) interp"
    and I_2::"('var, 'addr, 'k::finite) interp"
    and M::"('var, 'k) minterm"
  assumes "store I_1 = store I_2"
  shows "literal_set_evl I_1 (e_minterm M)
     \<Longrightarrow> literal_set_evl I_2 (e_minterm M)"
proof -
  assume asm: "literal_set_evl I_1 (e_minterm M)"
  show "literal_set_evl I_2 (e_minterm M)" unfolding literal_set_evl_def
  proof (intro ballI)
    fix l
    assume asm_l: "l \<in> (e_minterm M)"
    hence l_evl: "literal_evl I_1 l"
      using asm literal_set_evl_def by blast
    hence "l \<in> e_literals"
      using asm_l e_minterm_def by auto
    hence "\<exists>x y. l = to_literal (sl_eq x y) \<or> l = to_literal (sl_not (sl_eq x y))"
      using asm_l e_literals_def by force
    thus "literal_evl I_2 l"
      by (metis assms evaluation.simps(3) evaluation.simps(6) l_evl literal_evl_def neg_literal_inv
          pos_literal_inv test_formulae.intros(4))
  qed
qed

subsection \<open>Proposition 7\<close>

lemma minterm_prop_7_pc:
  fixes I::"('var, 'addr, 'k::finite) interp"
    and M::"('var, 'k) minterm"
  assumes "minterm_evl I M"
    and "E_complete (minterm_var_set M) M"
  shows "pc M" unfolding pc_def
proof (intro allI impI)
  fix x1 y1 x2 y2 i
  assume asm: "to_literal (points_to x1 y1) \<in> to_literal_set M
             \<and> to_literal (points_to x2 y2) \<in> to_literal_set M
             \<and> to_literal (sl_eq x1 x2) \<in> to_literal_set M"
  have "literal_evl I (to_literal (points_to x1 y1))"
    using asm assms(1) literal_set_evl_def minterm_evl_def by blast
  hence points_to_1: "(store_and_heap I x1) = Some (store_vector (store I) y1)"
    by (simp add: literal_evl_def test_formulae.intros(1) tf_prop_1_1)
  have "literal_evl I (to_literal (points_to x2 y2))"
    using asm assms(1) literal_set_evl_def minterm_evl_def by blast
  hence points_to_2: "(store_and_heap I x2) = Some (store_vector (store I) y2)"
    by (simp add: literal_evl_def test_formulae.intros(1) tf_prop_1_1)
  have equality_x: "store I x1 = store I x2"
    by (metis asm assms(1) evaluation.simps(6) literal_evl_def literal_set_evl_def
        minterm_evl_def pos_literal_inv test_formulae.intros(4))
  from points_to_1 and points_to_2 and equality_x have "(store_vector (store I) y1) = (store_vector (store I) y2)"
    by (simp add: store_and_heap_def)
  hence "(store I) (y1 $ i) = (store I) (y2 $ i)"
    using equality_store_vector by blast
  hence "\<not>(literal_evl I (to_literal (sl_not (sl_eq (y1 $ i) (y2 $ i)))))"
    by (simp add: literal_evl_def test_formulae.intros(4))
  moreover have "(y1 $ i) \<in> (minterm_var_set M)" using asm
    by (meson points_to_var_set)
  ultimately show "to_literal (sl_eq (y1 $ i) (y2 $ i)) \<in> to_literal_set M"
    by (meson E_complete_def asm assms(1) assms(2) literal_set_evl_def minterm_evl_def points_to_var_set)
qed

lemma minterm_prop_7_dc:
  fixes I::"('var, 'addr, 'k::finite) interp"
    and M::"('var, 'k) minterm"
  assumes "minterm_evl I M"
    and "E_complete (minterm_var_set M) M"
  shows "dc M"
proof -
  obtain l1 and n1 where l1_in_M :"l1 \<in> (to_literal_set M)"
                     and l1_def: "l1 = to_literal (ext_card_heap_ge n1)"
    by (metis Rep_literal_inverse minterm_have_ext_card_heap_ge to_literal_def to_sl_formula_def)
  obtain l2 and n2 where l2_in_M: "l2 \<in> (to_literal_set M)"
                     and l2_def: "l2 = to_literal (sl_not (ext_card_heap_ge n2))"
    by (metis literal_atom_cases_tmp minterm_have_not_ext_card_heap_ge neg_literal_inv pos_literal_inv to_atom_is_test_formula)
  have "literal_evl I l1"
    using assms(1) l1_in_M literal_set_evl_def minterm_evl_def by blast
  moreover have "literal_evl I l2"
    using assms(1) l2_in_M literal_set_evl_def minterm_evl_def by blast
  ultimately have "n1 < n2"
    by (simp add: card_heap_bounded l1_def l2_def literal_evl_def test_formulae.intros(3))
  thus "dc M"
    by (metis assms(1) card_heap_bounded dc_def literal_evl_def literal_set_evl_def minterm_evl_def
        neg_literal_inv pos_literal_inv test_formulae.intros(3))
qed

lemma minterm_prop7:
  fixes I::"('var, 'addr, 'k::finite) interp"
    and M::"('var, 'k) minterm"
  assumes "minterm_evl I M"
    and "E_complete (minterm_var_set M) M"
  shows "pc M \<and> dc M"
  using assms(1) assms(2) minterm_prop_7_dc minterm_prop_7_pc by blast

subsection \<open>Proposition 9\<close>

lemma minterm_prop_9_not_E_complete:
  fixes M::"('var, 'k::finite) minterm"
  assumes "footprint_consistent M"
  shows "nv (to_literal_set M) \<inter> av (to_literal_set M) = {}"
proof (rule ccontr)
  assume asm: "nv (to_literal_set M) \<inter> av (to_literal_set M) \<noteq> {}"
  from asm obtain x x1 where nv_1: "x \<in> (nv (to_literal_set M)) \<inter> av (to_literal_set M)"
                         and nv_2: "to_literal (sl_eq x x1) \<in> (to_literal_set M)"
                         and nv_3: "to_literal (sl_not (alloc x1)) \<in> (to_literal_set M)"
    unfolding nv_def
    by blast
  from asm and nv_1 and nv_2 and nv_3 obtain x2 where av_1: "to_literal (sl_eq x x2) \<in> (to_literal_set M)"
      and av_2:"(to_literal_set M)\<inter>({to_literal (alloc x2)} \<union> {to_literal (points_to x2 y) | y. True}) \<noteq> {}"
    unfolding av_def
    by auto
  hence "\<not>(footprint_consistent M)"
    using footprint_consistent_def nv_3 by fastforce
  thus False
    using assms by simp
qed

lemma minterm_prop_9_E_complete:
  fixes M::"('var, 'k::finite) minterm"
  assumes "footprint_consistent M"
    and "E_complete (minterm_var_set M) M"
    and "X \<inter> (av (to_literal_set M)) = {}"
    and "minterm_evl I M"
  shows "(store_set (store I) X) \<inter> (store_set (store I) (av (to_literal_set M))) = {}"
proof (rule ccontr)
  assume "(store_set (store I) X) \<inter> (store_set (store I) (av (to_literal_set M))) \<noteq> {}"
  from this obtain l where "l \<in> (store_set (store I) X)"
                       and "l \<in> (store_set (store I) (av (to_literal_set M)))"
    by blast
  from this obtain x1 x2 where x1_in: "x1 \<in> X"
                           and x2_in: "x2 \<in> (av (to_literal_set M))"
                           and x1_def: "store I x1 = l"
                           and x2_def: "store I x2 = l"
    by (metis antecedent_store_set)
  have e_com:"E_complete (minterm_var_set M) M"
    by (simp add: assms(2))
  hence cases: "to_literal (sl_eq x1 x2) \<in> (to_literal_set M) \<or> to_literal (sl_not (sl_eq x1 x2)) \<in> (to_literal_set M)"
    using assms(1) footprint_consistent_def by force
  from x2_in and e_com have case_1: "to_literal (sl_eq x1 x2) \<in> (to_literal_set M) \<longrightarrow> x1 \<in> (av (to_literal_set M))"
    by (meson assms(4) eq_av)
  have case_2: "to_literal (sl_not (sl_eq x1 x2)) \<in> (to_literal_set M) \<longrightarrow> \<not>(minterm_evl I M)"
    using assms(1) assms(3) case_1 disjoint_iff_not_equal footprint_consistent_def x1_in by fastforce
  from cases and case_1 and case_2 show False
    using assms(3) assms(4) x1_in by blast
qed

end


theory stack
  imports Main
begin

type_synonym 'a stack = "'a list"

definition push :: "'a \<Rightarrow> 'a stack \<Rightarrow> 'a stack"
where "push v s = v#s"

primrec pop :: "'a stack \<Rightarrow> ('a \<times> 'a stack)"
where "pop (x # xs) = (x, xs)"

(*definition empty :: "'a stack \<Rightarrow> 'a stack"
  where "empty s = []"*)

definition top :: "'a stack \<Rightarrow> 'a"
  where "top s \<equiv> hd s"

definition "emp s \<equiv> s = []"

lemma "top (push v s) = v"
  apply(induct s)
  by(simp add:top_def push_def)+

lemma "pop (push v s) = (v, s)"
  by (simp add:push_def)

lemma "\<forall>v s. pop (push v s) = (v, s)"
  by (simp add:push_def)

lemma "\<not> emp s \<Longrightarrow> top s = fst (pop s)"
  apply(induct s)
  by(simp add: emp_def top_def)+

lemma "\<not> emp s \<Longrightarrow> (v, s0) = pop s \<Longrightarrow> push v s0 = s"
  apply(simp add: emp_def push_def)
  apply(induct s) by auto

end


chapter \<open>Instantiating the Framework with a simple While-Language using procedures\<close>

section \<open>Commands\<close>

theory Com imports "../StaticInter/BasicDefs" begin

subsection \<open>Variables and Values\<close>

type_synonym vname = string \<comment> \<open>names for variables\<close>
type_synonym pname = string \<comment> \<open>names for procedures\<close>

datatype val
  = Bool bool      \<comment> \<open>Boolean value\<close>
  | Intg int       \<comment> \<open>integer value\<close>

abbreviation "true == Bool True"
abbreviation "false == Bool False"

subsection \<open>Expressions\<close>

datatype bop = Eq | And | Less | Add | Sub     \<comment> \<open>names of binary operations\<close>

datatype expr
  = Val val                                          \<comment> \<open>value\<close>
  | Var vname                                        \<comment> \<open>local variable\<close>
  | BinOp expr bop expr    ("_ \<guillemotleft>_\<guillemotright> _" [80,0,81] 80)  \<comment> \<open>binary operation\<close>

fun binop :: "bop \<Rightarrow> val \<Rightarrow> val \<Rightarrow> val option"
where "binop Eq v\<^sub>1 v\<^sub>2               = Some(Bool(v\<^sub>1 = v\<^sub>2))"
  | "binop And (Bool b\<^sub>1) (Bool b\<^sub>2)  = Some(Bool(b\<^sub>1 \<and> b\<^sub>2))"
  | "binop Less (Intg i\<^sub>1) (Intg i\<^sub>2) = Some(Bool(i\<^sub>1 < i\<^sub>2))"
  | "binop Add (Intg i\<^sub>1) (Intg i\<^sub>2)  = Some(Intg(i\<^sub>1 + i\<^sub>2))"
  | "binop Sub (Intg i\<^sub>1) (Intg i\<^sub>2)  = Some(Intg(i\<^sub>1 - i\<^sub>2))"
  | "binop bop v\<^sub>1 v\<^sub>2                = None"

subsection \<open>Commands\<close>

datatype cmd
  = Skip
  | LAss vname expr        ("_:=_" [70,70] 70)  \<comment> \<open>local assignment\<close>
  | Seq cmd cmd            ("_;;/ _" [60,61] 60)
  | Cond expr cmd cmd      ("if '(_') _/ else _" [80,79,79] 70)
  | While expr cmd         ("while '(_') _" [80,79] 70)
  | Call pname "expr list" "vname list"
    \<comment> \<open>Call needs procedure, actual parameters and variables for return values\<close>

fun num_inner_nodes :: "cmd \<Rightarrow> nat" ("#:_")
where "#:Skip              = 1"
  | "#:(V:=e)              = 2"       (* additional Skip node *)
  | "#:(c\<^sub>1;;c\<^sub>2)            = #:c\<^sub>1 + #:c\<^sub>2"
  | "#:(if (b) c\<^sub>1 else c\<^sub>2) = #:c\<^sub>1 + #:c\<^sub>2 + 1"
  | "#:(while (b) c)       = #:c + 2" (* additional Skip node *)
  | "#:(Call p es rets)    = 2"       (* additional Skip (=Return) node *)

lemma num_inner_nodes_gr_0 [simp]:"#:c > 0"
by(induct c) auto

lemma [dest]:"#:c = 0 \<Longrightarrow> False"
by(induct c) auto

end


(* Title:  Digraph_Component_Vwalk.thy
   Author: Lars Noschinski, TU München
*)

theory Digraph_Component_Vwalk
imports
  Digraph_Component
  Vertex_Walk
begin

section \<open>Lemmas for Vertex Walks\<close>

lemma vwalkI_subgraph:
  assumes "vwalk p H"
  assumes "subgraph H G"
  shows "vwalk p G"
proof
  show "set p \<subseteq> verts G" and "p \<noteq> []"
    using assms by (auto simp add: subgraph_def vwalk_def)

  have "set (vwalk_arcs p) \<subseteq> arcs_ends H"
    using assms by (simp add: vwalk_def)
  also have "\<dots> \<subseteq> arcs_ends G"
    using \<open>subgraph H G\<close> by (rule arcs_ends_mono)
  finally show "set (vwalk_arcs p) \<subseteq> arcs_ends G" .
qed

lemma vpathI_subgraph:
  assumes "vpath p G"
  assumes "subgraph G H"
  shows "vpath p H"
using assms by (auto intro: vwalkI_subgraph)

lemma (in loopfree_digraph) vpathI_arc:
  assumes "(a,b) \<in> arcs_ends G"
  shows "vpath [a,b] G"
using assms
by (intro vpathI vwalkI) (auto intro: adj_in_verts adj_not_same)

end


(*  Title:      HOL/ex/SOS.thy
    Author:     Amine Chaieb, University of Cambridge
    Author:     Philipp Meyer, TU Muenchen

Examples for Sum_of_Squares.
*)

theory SOS
imports "HOL-Library.Sum_of_Squares"
begin

lemma "(3::real) * x + 7 * a < 4 \<and> 3 < 2 * x \<Longrightarrow> a < 0"
  by sos

lemma "a1 \<ge> 0 \<and> a2 \<ge> 0 \<and> (a1 * a1 + a2 * a2 = b1 * b1 + b2 * b2 + 2) \<and> (a1 * b1 + a2 * b2 = 0) \<longrightarrow>
    a1 * a2 - b1 * b2 \<ge> (0::real)"
  by sos

lemma "(3::real) * x + 7 * a < 4 \<and> 3 < 2 * x \<longrightarrow> a < 0"
  by sos

lemma "(0::real) \<le> x \<and> x \<le> 1 \<and> 0 \<le> y \<and> y \<le> 1 \<longrightarrow>
    x\<^sup>2 + y\<^sup>2 < 1 \<or> (x - 1)\<^sup>2 + y\<^sup>2 < 1 \<or> x\<^sup>2 + (y - 1)\<^sup>2 < 1 \<or> (x - 1)\<^sup>2 + (y - 1)\<^sup>2 < 1"
  by sos

lemma "(0::real) \<le> x \<and> 0 \<le> y \<and> 0 \<le> z \<and> x + y + z \<le> 3 \<longrightarrow> x * y + x * z + y * z \<ge> 3 * x * y * z"
  by sos

lemma "(x::real)\<^sup>2 + y\<^sup>2 + z\<^sup>2 = 1 \<longrightarrow> (x + y + z)\<^sup>2 \<le> 3"
  by sos

lemma "w\<^sup>2 + x\<^sup>2 + y\<^sup>2 + z\<^sup>2 = 1 \<longrightarrow> (w + x + y + z)\<^sup>2 \<le> (4::real)"
  by sos

lemma "(x::real) \<ge> 1 \<and> y \<ge> 1 \<longrightarrow> x * y \<ge> x + y - 1"
  by sos

lemma "(x::real) > 1 \<and> y > 1 \<longrightarrow> x * y > x + y - 1"
  by sos

lemma "\<bar>x\<bar> \<le> 1 \<longrightarrow> \<bar>64 * x^7 - 112 * x^5 + 56 * x^3 - 7 * x\<bar> \<le> (1::real)"
  by sos

text \<open>One component of denominator in dodecahedral example.\<close>

lemma "2 \<le> x \<and> x \<le> 125841 / 50000 \<and> 2 \<le> y \<and> y \<le> 125841 / 50000 \<and> 2 \<le> z \<and> z \<le> 125841 / 50000 \<longrightarrow>
    2 * (x * z + x * y + y * z) - (x * x + y * y + z * z) \<ge> (0::real)"
  by sos

text \<open>Over a larger but simpler interval.\<close>

lemma "(2::real) \<le> x \<and> x \<le> 4 \<and> 2 \<le> y \<and> y \<le> 4 \<and> 2 \<le> z \<and> z \<le> 4 \<longrightarrow>
    0 \<le> 2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)"
  by sos

text \<open>We can do 12. I think 12 is a sharp bound; see PP's certificate.\<close>

lemma "2 \<le> (x::real) \<and> x \<le> 4 \<and> 2 \<le> y \<and> y \<le> 4 \<and> 2 \<le> z \<and> z \<le> 4 \<longrightarrow>
    12 \<le> 2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)"
  by sos

text \<open>Inequality from sci.math (see "Leon-Sotelo, por favor").\<close>

lemma "0 \<le> (x::real) \<and> 0 \<le> y \<and> x * y = 1 \<longrightarrow> x + y \<le> x\<^sup>2 + y\<^sup>2"
  by sos

lemma "0 \<le> (x::real) \<and> 0 \<le> y \<and> x * y = 1 \<longrightarrow> x * y * (x + y) \<le> x\<^sup>2 + y\<^sup>2"
  by sos

lemma "0 \<le> (x::real) \<and> 0 \<le> y \<longrightarrow> x * y * (x + y)\<^sup>2 \<le> (x\<^sup>2 + y\<^sup>2)\<^sup>2"
  by sos

lemma "(0::real) \<le> a \<and> 0 \<le> b \<and> 0 \<le> c \<and> c * (2 * a + b)^3 / 27 \<le> x \<longrightarrow> c * a\<^sup>2 * b \<le> x"
  by sos

lemma "(0::real) < x \<longrightarrow> 0 < 1 + x + x\<^sup>2"
  by sos

lemma "(0::real) \<le> x \<longrightarrow> 0 < 1 + x + x\<^sup>2"
  by sos

lemma "(0::real) < 1 + x\<^sup>2"
  by sos

lemma "(0::real) \<le> 1 + 2 * x + x\<^sup>2"
  by sos

lemma "(0::real) < 1 + \<bar>x\<bar>"
  by sos

lemma "(0::real) < 1 + (1 + x)\<^sup>2 * \<bar>x\<bar>"
  by sos

lemma "\<bar>(1::real) + x\<^sup>2\<bar> = (1::real) + x\<^sup>2"
  by sos

lemma "(3::real) * x + 7 * a < 4 \<and> 3 < 2 * x \<longrightarrow> a < 0"
  by sos

lemma "(0::real) < x \<longrightarrow> 1 < y \<longrightarrow> y * x \<le> z \<longrightarrow> x < z"
  by sos

lemma "(1::real) < x \<longrightarrow> x\<^sup>2 < y \<longrightarrow> 1 < y"
  by sos

lemma "(b::real)\<^sup>2 < 4 * a * c \<longrightarrow> a * x\<^sup>2 + b * x + c \<noteq> 0"
  by sos

lemma "(b::real)\<^sup>2 < 4 * a * c \<longrightarrow> a * x\<^sup>2 + b * x + c \<noteq> 0"
  by sos

lemma "(a::real) * x\<^sup>2 + b * x + c = 0 \<longrightarrow> b\<^sup>2 \<ge> 4 * a * c"
  by sos

lemma "(0::real) \<le> b \<and> 0 \<le> c \<and> 0 \<le> x \<and> 0 \<le> y \<and> x\<^sup>2 = c \<and> y\<^sup>2 = a\<^sup>2 * c + b \<longrightarrow> a * c \<le> y * x"
  by sos

lemma "\<bar>x - z\<bar> \<le> e \<and> \<bar>y - z\<bar> \<le> e \<and> 0 \<le> u \<and> 0 \<le> v \<and> u + v = 1 \<longrightarrow> \<bar>(u * x + v * y) - z\<bar> \<le> (e::real)"
  by sos

lemma "(x::real) - y - 2 * x^4 = 0 \<and> 0 \<le> x \<and> x \<le> 2 \<and> 0 \<le> y \<and> y \<le> 3 \<longrightarrow> y\<^sup>2 - 7 * y - 12 * x + 17 \<ge> 0"
  oops (*Too hard; left it running for 80 minutes -- LCP*)

lemma "(0::real) \<le> x \<longrightarrow> (1 + x + x\<^sup>2) / (1 + x\<^sup>2) \<le> 1 + x"
  by sos

lemma "(0::real) \<le> x \<longrightarrow> 1 - x \<le> 1 / (1 + x + x\<^sup>2)"
  by sos

lemma "(x::real) \<le> 1 / 2 \<longrightarrow> - x - 2 * x\<^sup>2 \<le> - x / (1 - x)"
  by sos

lemma "4 * r\<^sup>2 = p\<^sup>2 - 4 * q \<and> r \<ge> (0::real) \<and> x\<^sup>2 + p * x + q = 0 \<longrightarrow>
    2 * (x::real) = - p + 2 * r \<or> 2 * x = - p - 2 * r"
  by sos

end


(* 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.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_list_deleteAll_count
imports "../../Test_Base"
begin

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

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
"deleteBy x y (nil2) = nil2"
| "deleteBy x y (cons2 y2 ys) =
     (if (x y) y2 then ys else cons2 y2 (deleteBy x y ys))"

fun deleteAll :: "'a => 'a list => 'a list" where
"deleteAll x (nil2) = nil2"
| "deleteAll x (cons2 z ys) =
     (if (x = z) then deleteAll x ys else cons2 z (deleteAll x ys))"

fun count :: "'a => 'a list => int" where
"count x (nil2) = 0"
| "count x (cons2 z ys) =
     (if (x = z) then 1 + (count x ys) else count x ys)"

theorem property0 :
  "(((deleteAll x xs) =
       (deleteBy (% (y :: 'a) => % (z :: 'a) => (y = z)) x xs)) ==>
      ((count x xs) <= 1))"
  oops

end


header {* \isaheader{The type of associative lists} *}
theory Assoc_List
  imports
  "~~/src/HOL/Library/AList"
  "../Iterator/SetIteratorOperations"
begin

subsection {* Additional operations for associative lists *}

primrec update_with_aux :: "'val \<Rightarrow> 'key \<Rightarrow> ('val \<Rightarrow> 'val) \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
where
  "update_with_aux v k f [] = [(k, f v)]"
| "update_with_aux v k f (p # ps) = (if (fst p = k) then (k, f (snd p)) # ps else p # update_with_aux v k f ps)"

text {*
  Do not use @{term "AList.delete"} because this traverses all the list even if it has found the key.
  We do not have to keep going because we use the invariant that keys are distinct.
*}
fun delete_aux :: "'key \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
where
  "delete_aux k [] = []"
| "delete_aux k ((k', v) # xs) = (if k = k' then xs else (k', v) # delete_aux k xs)"

lemma map_of_update_with_aux':
  "map_of (update_with_aux v k f ps) k' = ((map_of ps)(k \<mapsto> (case map_of ps k of None \<Rightarrow> f v | Some v \<Rightarrow> f v))) k'"
by(induct ps) auto

lemma map_of_update_with_aux:
  "map_of (update_with_aux v k f ps) = (map_of ps)(k \<mapsto> (case map_of ps k of None \<Rightarrow> f v | Some v \<Rightarrow> f v))"
by(simp add: fun_eq_iff map_of_update_with_aux')

lemma dom_update_with_aux: "fst ` set (update_with_aux v k f ps) = {k} \<union> fst ` set ps"
  by (induct ps) auto

lemma distinct_update_with_aux [simp]:
  "distinct (map fst (update_with_aux v k f ps)) = distinct (map fst ps)"
by(induct ps)(auto simp add: dom_update_with_aux)

lemma set_update_with_aux:
  "distinct (map fst xs)
  \<Longrightarrow> set (update_with_aux v k f xs) = (set xs - {k} \<times> UNIV \<union> {(k, f (case map_of xs k of None \<Rightarrow> v | Some v \<Rightarrow> v))})"
by(induct xs)(auto intro: rev_image_eqI)

lemma set_delete_aux: "distinct (map fst xs) \<Longrightarrow> set (delete_aux k xs) = set xs - {k} \<times> UNIV"
apply(induct xs)
apply simp_all
apply clarsimp
apply(fastforce intro: rev_image_eqI)
done

lemma dom_delete_aux: "distinct (map fst ps) \<Longrightarrow> fst ` set (delete_aux k ps) = fst ` set ps - {k}"
by(auto simp add: set_delete_aux)

lemma distinct_delete_aux [simp]:
  "distinct (map fst ps) \<Longrightarrow> distinct (map fst (delete_aux k ps))"
proof(induct ps)
  case Nil thus ?case by simp
next
  case (Cons a ps)
  obtain k' v where a: "a = (k', v)" by(cases a)
  show ?case
  proof(cases "k' = k")
    case True with Cons a show ?thesis by simp
  next
    case False
    with Cons a have "k' \<notin> fst ` set ps" "distinct (map fst ps)" by simp_all
    with False a have "k' \<notin> fst ` set (delete_aux k ps)"
      by(auto dest!: dom_delete_aux[where k=k])
    with Cons a show ?thesis by simp
  qed
qed

lemma map_of_delete_aux':
  "distinct (map fst xs) \<Longrightarrow> map_of (delete_aux k xs) = (map_of xs)(k := None)"
  apply (induct xs)
  apply (fastforce intro: ext simp add: map_of_eq_None_iff fun_upd_twist)
  apply (auto intro!: ext simp del: map_upd_eq_restrict )
  apply (simp add: map_of_eq_None_iff)
  done

lemma map_of_delete_aux:
  "distinct (map fst xs) \<Longrightarrow> map_of (delete_aux k xs) k' = ((map_of xs)(k := None)) k'"
by(simp add: map_of_delete_aux')

lemma delete_aux_eq_Nil_conv: "delete_aux k ts = [] \<longleftrightarrow> ts = [] \<or> (\<exists>v. ts = [(k, v)])"
by(cases ts)(auto split: split_if_asm)

subsection {* Type @{text "('a, 'b) assoc_list" } *}

typedef ('k, 'v) assoc_list = "{xs :: ('k \<times> 'v) list. distinct (map fst xs)}"
morphisms impl_of Assoc_List
by(rule exI[where x="[]"]) simp

lemma assoc_list_ext: "impl_of xs = impl_of ys \<Longrightarrow> xs = ys"
by(simp add: impl_of_inject)

lemma expand_assoc_list_eq: "xs = ys \<longleftrightarrow> impl_of xs = impl_of ys"
by(simp add: impl_of_inject)

lemma impl_of_distinct [simp, intro]: "distinct (map fst (impl_of al))"
using impl_of[of al] by simp

lemma impl_of_distinct_full [simp, intro]: "distinct (impl_of al)"
using impl_of_distinct[of al]
unfolding distinct_map by simp

lemma Assoc_List_impl_of [code abstype]: "Assoc_List (impl_of al) = al"
by(rule impl_of_inverse)

subsection {* Primitive operations *}

definition empty :: "('k, 'v) assoc_list"
where [code del]: "empty = Assoc_List []"

definition lookup :: "('k, 'v) assoc_list \<Rightarrow> 'k \<Rightarrow> 'v option"
where [code]: "lookup al = map_of (impl_of al)"

definition update_with :: "'v \<Rightarrow> 'k \<Rightarrow> ('v \<Rightarrow> 'v) \<Rightarrow> ('k, 'v) assoc_list \<Rightarrow> ('k, 'v) assoc_list"
where [code del]: "update_with v k f al = Assoc_List (update_with_aux v k f (impl_of al))"

definition delete :: "'k \<Rightarrow> ('k, 'v) assoc_list \<Rightarrow> ('k, 'v) assoc_list"
where [code del]: "delete k al = Assoc_List (delete_aux k (impl_of al))"

definition iteratei :: "('k, 'v) assoc_list \<Rightarrow> ('s\<Rightarrow>bool) \<Rightarrow> ('k \<times> 'v \<Rightarrow> 's \<Rightarrow> 's) \<Rightarrow> 's \<Rightarrow> 's"
where [code]: "iteratei al c f = foldli (impl_of al) c f"

lemma impl_of_empty [code abstract]: "impl_of empty = []"
by(simp add: empty_def Assoc_List_inverse)

lemma impl_of_update_with [code abstract]:
  "impl_of (update_with v k f al) = update_with_aux v k f (impl_of al)"
by(simp add: update_with_def Assoc_List_inverse)

lemma impl_of_delete [code abstract]:
  "impl_of (delete k al) = delete_aux k (impl_of al)"
by(simp add: delete_def Assoc_List_inverse)

subsection {* Abstract operation properties *}

lemma lookup_empty [simp]: "lookup empty k = None"
by(simp add: empty_def lookup_def Assoc_List_inverse)

lemma lookup_empty': "lookup empty = Map.empty"
by(rule ext) simp

lemma lookup_update_with [simp]:
  "lookup (update_with v k f al) = (lookup al)(k \<mapsto> case lookup al k of None \<Rightarrow> f v | Some v \<Rightarrow> f v)"
by(simp add: lookup_def update_with_def Assoc_List_inverse map_of_update_with_aux)

lemma lookup_delete [simp]: "lookup (delete k al) = (lookup al)(k := None)"
by(simp add: lookup_def delete_def Assoc_List_inverse distinct_delete map_of_delete_aux')

lemma finite_dom_lookup [simp, intro!]: "finite (dom (lookup m))"
by(simp add: lookup_def finite_dom_map_of)

lemma iteratei_correct:
  "map_iterator (iteratei m) (lookup m)"
unfolding iteratei_def[abs_def] lookup_def map_to_set_def
by (simp add: set_iterator_foldli_correct)

subsection {* Derived operations *}

definition update :: "'key \<Rightarrow> 'val \<Rightarrow> ('key, 'val) assoc_list \<Rightarrow> ('key, 'val) assoc_list"
where "update k v = update_with v k (\<lambda>_. v)"

definition set :: "('key, 'val) assoc_list \<Rightarrow> ('key \<times> 'val) set"
where "set al = List.set (impl_of al)"

lemma lookup_update [simp]: "lookup (update k v al) = (lookup al)(k \<mapsto> v)"
by(simp add: update_def split: option.split)

lemma set_empty [simp]: "set empty = {}"
by(simp add: set_def empty_def Assoc_List_inverse)

lemma set_update_with:
  "set (update_with v k f al) =
  (set al - {k} \<times> UNIV \<union> {(k, f (case lookup al k of None \<Rightarrow> v | Some v \<Rightarrow> v))})"
by(simp add: set_def update_with_def Assoc_List_inverse set_update_with_aux lookup_def)

lemma set_update: "set (update k v al) = (set al - {k} \<times> UNIV \<union> {(k, v)})"
by(simp add: update_def set_update_with)

lemma set_delete: "set (delete k al) = set al - {k} \<times> UNIV"
by(simp add: set_def delete_def Assoc_List_inverse set_delete_aux)

subsection {* Type classes *}

instantiation assoc_list :: (equal, equal) equal begin

definition "equal_class.equal (al :: ('a, 'b) assoc_list) al' == impl_of al = impl_of al'"

instance
proof
qed (simp add: equal_assoc_list_def impl_of_inject)

end

instantiation assoc_list :: (type, type) size begin

definition "size (al :: ('a, 'b) assoc_list) = length (impl_of al)"

instance ..
end

hide_const (open) impl_of empty lookup update_with set update delete iteratei

subsection {* @{const map_ran} *}

text {* @{term map_ran} with more general type - lemmas replicated from AList in HOL/Library *}

hide_const (open) map_ran

primrec
  map_ran :: "('key \<Rightarrow> 'val \<Rightarrow> 'val') \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val') list"
where
    "map_ran f [] = []"
  | "map_ran f (p#ps) = (fst p, f (fst p) (snd p)) # map_ran f ps"

lemma map_ran_conv: "map_of (map_ran f al) k = map_option (f k) (map_of al k)"
  by (induct al) auto

lemma dom_map_ran: "fst ` set (map_ran f al) = fst ` set al"
  by (induct al) auto

lemma distinct_map_ran: "distinct (map fst al) \<Longrightarrow> distinct (map fst (map_ran f al))"
  by (induct al) (auto simp add: dom_map_ran)

lemma map_ran_filter: "map_ran f [(a, _)\<leftarrow>ps. fst p \<noteq> a] = [(a, _)\<leftarrow>map_ran f ps. fst p \<noteq> a]"
  by (induct ps) auto

lemma clearjunk_map_ran: "AList.clearjunk (map_ran f al)
  = map_ran f (AList.clearjunk al)"
  by (induct al rule: clearjunk.induct) (simp_all add: delete_eq map_ran_filter)

text {* new lemmas and definitions *}

lemma map_ran_cong [fundef_cong]:
  "\<lbrakk> al = al'; \<And>k v. (k, v) \<in> set al \<Longrightarrow> f k v = g k v \<rbrakk> \<Longrightarrow> map_ran f al = map_ran g al'"
by hypsubst_thin (induct al', auto)

lemma size_list_delete: "size_list f (AList.delete a al) \<le> size_list f al"
by(induct al) simp_all

lemma size_list_clearjunk: "size_list f (AList.clearjunk al) \<le> size_list f al"
by(induct al)(auto simp add: clearjunk_delete intro: le_trans[OF size_list_delete])

lemma set_delete_conv: "set (AList.delete a al) = set al - ({a} \<times> UNIV)"
proof(induct al)
  case (Cons kv al)
  thus ?case by(cases kv) auto
qed simp

lemma set_clearjunk_subset: "set (AList.clearjunk al) \<subseteq> set al"
by(induct al)(auto simp add: clearjunk_delete set_delete_conv)

lemma map_ran_conv_map:
  "map_ran f xs = map (\<lambda>(k, v). (k, f k v)) xs"
by(induct xs) auto

lemma card_dom_map_of: "distinct (map fst al) \<Longrightarrow> card (dom (map_of al)) = length al"
by(induct al)(auto simp add: card_insert_if finite_dom_map_of dom_map_of_conv_image_fst)

lemma map_of_map_inj_fst:
  assumes "inj f"
  shows "map_of (map (\<lambda>(k, v). (f k, v)) xs) (f x) = map_of xs x"
by(induct xs)(auto dest: injD[OF `inj f`])

lemma length_map_ran [simp]: "length (map_ran f xs) = length xs"
by(induct xs) simp_all

lemma length_update:
  "length (AList.update k v xs)
  = (if k \<in> fst ` set xs then length xs else Suc (length xs))"
by(induct xs) simp_all

lemma length_distinct:
  "distinct (map fst xs) \<Longrightarrow> length (AList.delete k xs)
  = (if k \<in> fst ` set xs then length xs - 1 else length xs)"
  by(induct xs)(auto split: split_if_asm simp add: in_set_conv_nth)

lemma finite_Assoc_List_set_image:
  assumes "finite (Assoc_List.set ` A)"
  shows "finite A"
proof -
  have "Assoc_List.set ` A = set ` Assoc_List.impl_of ` A"
    by (auto simp add: Assoc_List.set_def)
  with assms finite_set_image have "finite (Assoc_List.impl_of ` A)" by auto
  with assoc_list_ext show ?thesis by (metis inj_onI finite_imageD)
qed

end


(*
  File:     Build.thy
  Author:   Martin Rau, TU München
*)

section \<open>Building a balanced \<open>k\<close>-d Tree from a List of Points\<close>

theory Build
  imports
  KD_Tree
  Median_Of_Medians_Selection.Median_Of_Medians_Selection
  "Eval_Base.Eval_Base"
begin

text \<open>
  Build a balanced \<open>k\<close>-d Tree by recursively partition the points into two lists.
  The partitioning criteria will be the median at a particular axis \<open>k\<close>.
  The left list will contain all points \<open>p\<close> with @{term "p$k \<le> median"}.
  The right list will contain all points with median at axis @{term "median < p$k"}.
  The left and right list differ in length by one or none.
  The axis \<open>k\<close> will the widest spread axis.
\<close>

subsection "Auxiliary Lemmas"

lemma length_filter_mset_sorted_nth:
  assumes "distinct xs" "n < length xs" "sorted xs"
  shows "{# x \<in># mset xs. x \<le> xs ! n #} = mset (take (n + 1) xs)"
  using assms
proof2 (induction xs arbitrary: n rule: list.induct)
  case (Cons x xs)
  thus ?case
  proof (cases n)
    case 0
    thus ?thesis
      using Cons.prems(1,3) filter_mset_is_empty_iff by fastforce
  next
    case (Suc n')
    thus ?thesis
      using Cons by simp
  qed
qed auto

lemma length_filter_sort_nth:
  assumes "distinct xs" "n < length xs"
  shows "length (filter (\<lambda>x. x \<le> sort xs ! n) xs) = n + 1"
proof -
  have "length (filter (\<lambda>x. x \<le> sort xs ! n) xs) = length (filter (\<lambda>x. x \<le> sort xs ! n) (sort xs))"
    by (simp add: filter_sort)
  also have "... = size (mset (filter (\<lambda>x. x \<le> sort xs ! n) (sort xs)))"
    using size_mset by metis
  also have "... = size ({# x \<in># mset (sort xs). x \<le> sort xs ! n #})"
    using mset_filter by simp
  also have "... = size (mset (take (n + 1) (sort xs)))"
    using length_filter_mset_sorted_nth assms sorted_sort distinct_sort length_sort by metis
  finally show ?thesis
    using assms(2) by auto
qed

subsection \<open>Widest Spread Axis\<close>

definition calc_spread :: "('k::finite) \<Rightarrow> 'k point list \<Rightarrow> real" where
  "calc_spread k ps = (case ps of [] \<Rightarrow> 0 | ps \<Rightarrow>
    let ks = map (\<lambda>p. p$k) (tl ps) in
    fold max ks ((hd ps)$k) - fold min ks ((hd ps)$k)
  )"

fun widest_spread :: "('k::finite) list \<Rightarrow> 'k point list \<Rightarrow> 'k \<times> real" where
  "widest_spread [] _ = undefined"
| "widest_spread [k] ps = (k, calc_spread k ps)"
| "widest_spread (k # ks) ps = (
    let (k', s') = widest_spread ks ps in
    let s = calc_spread k ps in
    if s \<le> s' then (k', s') else (k, s)
  )"

lemma calc_spread_spec:
  "calc_spread k ps = spread k (set ps)"
  using Max.set_eq_fold[of "(hd ps)$k"] Min.set_eq_fold[of "(hd ps)$k"]
  by (auto simp: Let_def spread_def calc_spread_def split: list.splits, metis set_map)

lemma widest_spread_calc_spread:
  "ks \<noteq> [] \<Longrightarrow> (k, s) = widest_spread ks ps \<Longrightarrow> s = calc_spread k ps"
  apply2 (induction ks ps rule: widest_spread.induct) by (auto simp: Let_def split: prod.splits if_splits)

lemma widest_spread_axis_Un:
  shows "widest_spread_axis k K P \<Longrightarrow> spread k' P \<le> spread k P \<Longrightarrow> widest_spread_axis k (K \<union> { k' }) P"
    and "widest_spread_axis k K P \<Longrightarrow> spread k P \<le> spread k' P \<Longrightarrow> widest_spread_axis k' (K \<union> { k' }) P"
  unfolding widest_spread_axis_def by auto

lemma widest_spread_spec:
  "(k, s) = widest_spread ks ps \<Longrightarrow> widest_spread_axis k (set ks) (set ps)"
proof2 (induction ks ps arbitrary: k s rule: widest_spread.induct)
  case (3 k\<^sub>0 k\<^sub>1 ks ps)
  obtain K' S' where K'_def: "(K', S') = widest_spread (k\<^sub>1 # ks) ps"
    by (metis surj_pair)
  hence IH: "widest_spread_axis K' (set (k\<^sub>1 # ks)) (set ps)"
    using "3.IH" by blast
  hence 0: "S' = spread K' (set ps)"
    using K'_def widest_spread_calc_spread calc_spread_spec by blast
  define S where "S = calc_spread k\<^sub>0 ps"
  hence 1: "S = spread k\<^sub>0 (set ps)"
    using calc_spread_spec by blast
  show ?case
  proof (cases "S \<le> S'")
    case True
    hence "widest_spread_axis K' (set (k\<^sub>0 # k\<^sub>1 # ks)) (set ps)"
      using 0 1 widest_spread_axis_Un(1)[OF IH, of k\<^sub>0]  by auto
    thus ?thesis
      using True K'_def S_def "3.prems" by (auto split: prod.splits)
  next
    case False
    hence "widest_spread_axis k\<^sub>0 (set (k\<^sub>0 # k\<^sub>1 # ks)) (set ps)"
      using 0 1 widest_spread_axis_Un(2)[OF IH, of k\<^sub>0] "3.prems"(1) by auto
    thus ?thesis
      using False K'_def S_def "3.prems" by (auto split: prod.splits)
  qed
qed (auto simp: widest_spread_axis_def)

subsection \<open>Fast Axis Median\<close>

definition axis_median :: "('k::finite) \<Rightarrow> 'k point list \<Rightarrow> real" where
  "axis_median k ps = (let n = (length ps - 1) div 2 in fast_select n (map (\<lambda>p. p$k) ps))"

lemma length_filter_le_axis_median:
  assumes "0 < length ps" "\<forall>k. distinct (map (\<lambda>p. p$k) ps)"
  shows "length (filter (\<lambda>p. p$k \<le> axis_median k ps) ps) = (length ps - 1) div 2 + 1"
proof -
  let ?n = "(length ps - 1) div 2"
  let ?ps = "map (\<lambda>p. p$k) ps"
  let ?m = "fast_select ?n ?ps"
  have 0: "?n < length ?ps"
    using assms(1) by (auto, linarith)
  have 1: "distinct ?ps"
    using assms(2) by blast
  have "?m = select ?n ?ps"
    using fast_select_correct[OF 0] by blast
  hence "length (filter (\<lambda>p. p$k \<le> axis_median k ps) ps) =
        length (filter (\<lambda>p. p$k \<le> sort ?ps ! ?n) ps)"
    unfolding axis_median_def by (auto simp add: Let_def select_def simp del: fast_select.simps)
  also have "... = length (filter (\<lambda>v. v \<le> sort ?ps ! ?n) ?ps)"
    apply2 (induction ps) by (auto, metis comp_apply)
  also have "... = ?n + 1"
    using length_filter_sort_nth[OF 1 0] by blast
  finally show ?thesis .
qed

definition partition_by_median :: "('k::finite) \<Rightarrow> 'k point list \<Rightarrow> 'k point list \<times> real \<times> 'k point list" where
  "partition_by_median k ps = (
     let m = axis_median k ps in
     let (l, r) = partition (\<lambda>p. p$k \<le> m) ps in
     (l, m, r)
  )"

lemma set_partition_by_median:
  "(l, m, r) = partition_by_median k ps \<Longrightarrow> set ps = set l \<union> set r"
  unfolding partition_by_median_def by (auto simp: Let_def)

lemma filter_partition_by_median:
  assumes "(l, m, r) = partition_by_median k ps"
  shows "\<forall>p \<in> set l. p$k \<le> m"
    and "\<forall>p \<in> set r. \<not>p$k \<le> m"
  using assms unfolding partition_by_median_def by (auto simp: Let_def)

lemma sum_length_partition_by_median:
  assumes "(l, m, r) = partition_by_median k ps"
  shows "length ps = length l + length r"
  using assms sum_length_filter_compl[of "(\<lambda>p. p $ k \<le> axis_median k ps)"]
  unfolding partition_by_median_def by (simp add: Let_def o_def)

lemma length_l_partition_by_median:
  assumes "0 < length ps" "\<forall>k. distinct (map (\<lambda>p. p$k) ps)" "(l, m, r) = partition_by_median k ps"
  shows "length l = (length ps - 1) div 2 + 1"
  using assms unfolding partition_by_median_def by (auto simp: Let_def length_filter_le_axis_median)

corollary lengths_partition_by_median_1:
  assumes "0 < length ps"  "\<forall>k. distinct (map (\<lambda>p. p$k) ps)" "(l, m, r) = partition_by_median k ps"
  shows "length l - length r \<le> 1"
    and "length r \<le> length l"
    and "0 < length l"
    and "length r < length ps"
  using length_l_partition_by_median[OF assms] sum_length_partition_by_median[OF assms(3)] by auto

corollary lengths_partition_by_median_2:
  assumes "1 < length ps" "\<forall>k. distinct (map (\<lambda>p. p$k) ps)" "(l, m, r) = partition_by_median k ps"
  shows "0 < length r"
    and "length l < length ps"
proof -
  have *: "0 < length ps"
    using assms(1) by auto
  show "0 < length r" "length l < length ps"
    using length_l_partition_by_median[OF * assms(2,3)] sum_length_partition_by_median[OF assms(3)]
    using assms(1) by linarith+
qed

lemmas length_partition_by_median =
  sum_length_partition_by_median length_l_partition_by_median
  lengths_partition_by_median_1 lengths_partition_by_median_2

subsection \<open>Building the Tree\<close>

function (domintros, sequential) build :: "('k::finite) list \<Rightarrow> 'k point list \<Rightarrow> 'k kdt" where
  "build _ [] = undefined"
| "build _ [p] = Leaf p"
| "build ks ps = (
    let (k, _) = widest_spread ks ps in
    let (l, m, r) = partition_by_median k ps in
    Node k m (build ks l) (build ks r)
  )"
  by pat_completeness auto

lemma build_domintros3:
  assumes "(k, s) = widest_spread ks (x # y # zs)" "(l, m, r) = partition_by_median k (x # y # zs)"
  assumes "build_dom (ks, l)" "build_dom (ks, r)"
  shows "build_dom (ks, x # y # zs)"
proof -
  {
    fix k s l m r
    assume "(k, s) = widest_spread ks (x # y # zs)" "(l, m, r) = partition_by_median k (x # y # zs)"
    hence "build_dom (ks, l)" "build_dom (ks, r)"
      using assms by (metis Pair_inject)+
  }
  thus ?thesis
    by (simp add: build.domintros(3))
qed

lemma build_termination:
  assumes "\<forall>k. distinct (map (\<lambda>p. p$k) ps)"
  shows "build_dom (ks, ps)"
  using assms
proof2 (induction ps rule: length_induct)
  case (1 xs)
  consider (A) "xs = []" | (B) "\<exists>x. xs = [x]" | (C) "\<exists>x y zs. xs = x # y # zs"
    apply2 (induction xs rule: induct_list012) by auto
  then show ?case
  proof cases
    case C
    then obtain x y zs where xyzs_def: "xs = x # y # zs"
      by blast
    obtain k s where ks_def: "(k, s) = widest_spread ks xs"
      by (metis surj_pair)
    obtain l m r where lmr_def: "(l, m, r) = partition_by_median k xs"
      by (metis prod_cases3)
    note defs = xyzs_def ks_def lmr_def
    have "\<forall>k. distinct (map (\<lambda>p. p $ k) l)" "\<forall>k. distinct (map (\<lambda>p. p $ k) r)"
      using lmr_def unfolding partition_by_median_def
      by (auto simp: Let_def "1.prems" distinct_map_filter)
    moreover have "length l < length xs" "length r < length xs"
      using length_partition_by_median(8)[OF _ "1.prems"] length_partition_by_median(6)[OF _ "1.prems"]
      using defs by auto
    ultimately have "build_dom (ks, l)" "build_dom (ks, r)"
      using "1.IH" by blast+
    thus ?thesis
      using build_domintros3 defs by blast
  qed (auto intro: build.domintros)
qed

lemma build_psimp_1:
  "ps = [p] \<Longrightarrow> build k ps = Leaf p"
  by (simp add: build.domintros(2) build.psimps(2))

lemma build_psimp_2:
  assumes "(k, s) = widest_spread ks (x # y # zs)" "(l, m, r) = partition_by_median k (x # y # zs)"
  assumes "build_dom (ks, l)" "build_dom (ks, r)"
  shows "build ks (x # y # zs) = Node k m (build ks l) (build ks r)"
proof -
  have 0: "build_dom (ks, x # y # zs)"
    using assms build_domintros3 by blast
  thus ?thesis
    using build.psimps(3)[OF 0] assms(1,2) by (auto split: prod.splits)
qed

lemma length_xs_gt_1:
  "1 < length xs \<Longrightarrow> \<exists>x y ys. xs = x # y # ys"
  by (cases xs, auto simp: neq_Nil_conv)

lemma build_psimp_3:
  assumes "1 < length ps" "(k, s) = widest_spread ks ps" "(l, m, r) = partition_by_median k ps"
  assumes "build_dom (ks, l)" "build_dom (ks, r)"
  shows "build ks ps = Node k m (build ks l) (build ks r)"
  using build_psimp_2 length_xs_gt_1 assms by blast

lemmas build_psimps[simp] = build_psimp_1 build_psimp_3

subsection \<open>Main Theorems\<close>

theorem set_build:
  "0 < length ps \<Longrightarrow> \<forall>k. distinct (map (\<lambda>p. p$k) ps) \<Longrightarrow> set ps = set_kdt (build ks ps)"
proof2 (induction ps rule: length_induct)
  case (1 ps)
  show ?case
  proof (cases "1 < length ps")
    case True
    obtain k s where ks_def: "(k, s) = widest_spread ks ps"
      by (metis surj_pair)
    obtain l m r where lmr_def: "(l, m, r) = partition_by_median k ps"
      by (metis prod_cases3)
    have D: "\<forall>k. distinct (map (\<lambda>p. p$k) l)" "\<forall>k. distinct (map (\<lambda>p. p$k) r)"
      using lmr_def unfolding partition_by_median_def
      by (auto simp: "1.prems"(2) Let_def distinct_map_filter)
    moreover have "length l < length ps" "0 < length l"
                  "length r < length ps" "0 < length r"
      using length_partition_by_median(8)[OF True "1.prems"(2)]
            length_partition_by_median(5)[OF "1.prems"(1) "1.prems"(2)]
            length_partition_by_median(6)[OF "1.prems"(1) "1.prems"(2)]
            length_partition_by_median(7)[OF True "1.prems"(2)]
            lmr_def by blast+
    ultimately have "set l = set_kdt (build ks l)" "set r = set_kdt (build ks r)"
      using "1.IH" by blast+
    moreover have "set ps = set l \<union> set r"
      using lmr_def unfolding partition_by_median_def by (auto simp: Let_def)
    moreover have "build ks ps = Node k m (build ks l) (build ks r)"
      using build_psimp_3[OF True ks_def lmr_def] build_termination D by blast
    ultimately show ?thesis
      by simp
  next
    case False
    thus ?thesis
      using "1.prems" by (cases ps) auto
  qed
qed

theorem invar_build:
  "0 < length ps \<Longrightarrow> \<forall>k. distinct (map (\<lambda>p. p$k) ps) \<Longrightarrow> set ks = UNIV \<Longrightarrow> invar (build ks ps)"
proof2 (induction ps rule: length_induct)
  case (1 ps)
  show ?case
  proof (cases "1 < length ps")
    case True
    obtain k s where ks_def: "(k, s) = widest_spread ks ps"
      by (metis surj_pair)
    obtain l m r where lmr_def: "(l, m, r) = partition_by_median k ps"
      by (metis prod_cases3)
    have D: "\<forall>k. distinct (map (\<lambda>p. p$k) l)" "\<forall>k. distinct (map (\<lambda>p. p$k) r)"
      using lmr_def unfolding partition_by_median_def
      by (auto simp: "1.prems"(2) Let_def distinct_map_filter)
    moreover have "length l < length ps" "0 < length l"
                  "length r < length ps" "0 < length r"
      using length_partition_by_median(8)[OF True "1.prems"(2)]
            length_partition_by_median(5)[OF "1.prems"(1) "1.prems"(2)]
            length_partition_by_median(6)[OF "1.prems"(1) "1.prems"(2)]
            length_partition_by_median(7)[OF True "1.prems"(2)]
            lmr_def by blast+
    ultimately have "invar (build ks l)" "invar (build ks r)"
      using "1.IH" "1.prems"(3) by blast+
    moreover have "\<forall>p \<in> set l. p$k \<le> m" "\<forall>p \<in> set r. m < p$k"
      using filter_partition_by_median(1)[OF lmr_def]
            filter_partition_by_median(2)[OF lmr_def] by auto
    moreover have "widest_spread_axis k UNIV (set l \<union> set r)"
      using widest_spread_spec[OF ks_def] "1.prems"(3) set_partition_by_median[OF lmr_def] by simp
    moreover have "build ks ps = Node k m (build ks l) (build ks r)"
      using build_psimp_3[OF True ks_def lmr_def] build_termination D by blast
    ultimately show ?thesis
      using set_build[OF \<open>0 < length l\<close> D(1)] set_build[OF \<open>0 < length r\<close> D(2)] by simp
  next
    case False
    thus ?thesis
      using "1.prems" by (cases ps) auto
  qed
qed

theorem size_build:
  "0 < length ps \<Longrightarrow> \<forall>k. distinct (map (\<lambda>p. p$k) ps) \<Longrightarrow> size_kdt (build ks ps) = length ps"
proof2 (induction ps rule: length_induct)
  case (1 ps)
  show ?case
  proof (cases "1 < length ps")
    case True
    obtain k s where ks_def: "(k, s) = widest_spread ks ps"
      by (metis surj_pair)
    obtain l m r where lmr_def: "(l, m, r) = partition_by_median k ps"
      by (metis prod_cases3)
    have D: "\<forall>k. distinct (map (\<lambda>p. p$k) l)" "\<forall>k. distinct (map (\<lambda>p. p$k) r)"
      using lmr_def unfolding partition_by_median_def
      by (auto simp: "1.prems"(2) Let_def distinct_map_filter)
    moreover have "length l < length ps" "0 < length l"
                  "length r < length ps" "0 < length r"
      using length_partition_by_median(8)[OF True "1.prems"(2)]
            length_partition_by_median(5)[OF "1.prems"(1) "1.prems"(2)]
            length_partition_by_median(6)[OF "1.prems"(1) "1.prems"(2)]
            length_partition_by_median(7)[OF True "1.prems"(2)]
            lmr_def by blast+
    ultimately have "size_kdt (build ks l) = length l" "size_kdt (build ks r) = length r"
      using "1.IH" by blast+
    moreover have "build ks ps = Node k m (build ks l) (build ks r)"
      using build_psimp_3[OF True ks_def lmr_def] build_termination D by blast
    ultimately show ?thesis
      using length_partition_by_median(1)[OF lmr_def] by simp
  next
    case False
    thus ?thesis
      using "1.prems" by (cases ps) auto
  qed
qed

theorem balanced_build:
  "0 < length ps \<Longrightarrow> \<forall>k. distinct (map (\<lambda>p. p$k) ps) \<Longrightarrow> balanced (build ks ps)"
proof2 (induction ps rule: length_induct)
  case (1 ps)
  show ?case
  proof (cases "1 < length ps")
    case True
    obtain k s where ks_def: "(k, s) = widest_spread ks ps"
      by (metis surj_pair)
    obtain l m r where lmr_def: "(l, m, r) = partition_by_median k ps"
      by (metis prod_cases3)
    have D: "\<forall>k. distinct (map (\<lambda>p. p$k) l)" "\<forall>k. distinct (map (\<lambda>p. p$k) r)"
      using lmr_def unfolding partition_by_median_def
      by (auto simp: "1.prems"(2) Let_def distinct_map_filter)
    moreover have "length l < length ps" "0 < length l"
                  "length r < length ps" "0 < length r"
      using length_partition_by_median(8)[OF True "1.prems"(2)]
            length_partition_by_median(5)[OF "1.prems"(1) "1.prems"(2)]
            length_partition_by_median(6)[OF "1.prems"(1) "1.prems"(2)]
            length_partition_by_median(7)[OF True "1.prems"(2)]
            lmr_def by blast+
    ultimately have IH: "balanced (build ks l)" "balanced (build ks r)"
      using "1.IH" by blast+
    have "build ks ps = Node k m (build ks l) (build ks r)"
      using build_psimp_3[OF True ks_def lmr_def] build_termination D by blast
    moreover have "length r + 1 = length l \<or> length r = length l"
      using length_partition_by_median(1)[OF lmr_def]
            length_partition_by_median(3)[OF "1.prems"(1) "1.prems"(2) lmr_def]
            length_partition_by_median(4)[OF "1.prems"(1) "1.prems"(2) lmr_def]
      by linarith
    ultimately show ?thesis
      using balanced_Node_if_wbal1[OF IH] balanced_Node_if_wbal2[OF IH]
            size_build[OF \<open>0 < length l\<close> D(1)] size_build[OF \<open>0 < length r\<close> D(2)]
      by auto
  next
    case False
    thus ?thesis
      using "1.prems" by (cases ps) (auto simp: balanced_def)
  qed
qed

lemma complete_if_balanced_size_2powh:
  assumes "balanced kdt" "size_kdt kdt = 2 ^ h"
  shows "complete kdt"
proof (rule ccontr)
  assume "\<not> complete kdt"
  hence "2 ^ (min_height kdt) < size_kdt kdt" "size_kdt kdt < 2 ^ height kdt"
    by (simp_all add: min_height_size_if_incomplete size_height_if_incomplete)
  hence "height kdt - min_height kdt > 1"
    using assms(2) by simp
  hence "\<not> balanced kdt"
    using balanced_def by force
  thus "False"
    using assms(1) by simp
qed

theorem complete_build:
  "length ps = 2 ^ h \<Longrightarrow> \<forall>k. distinct (map (\<lambda>p. p$k) ps) \<Longrightarrow> complete (build k ps)"
  by (simp add: balanced_build complete_if_balanced_size_2powh size_build)

corollary height_build:
  assumes "length ps = 2 ^ h" "\<forall>k. distinct (map (\<lambda>p. p$k) ps)"
  shows "h = height (build k ps)"
  using complete_build[OF assms] size_build[OF _ assms(2)] by (simp add: assms(1) complete_iff_size)

end


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

section \<open>Primitive Recursive Functions: the inductive definition\<close>

theory Primrec imports ZF begin

text \<open>
  Proof adopted from @{cite szasz93}.

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

subsection \<open>Basic definitions\<close>

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)"
  \<comment> \<open>Note that \<open>g\<close> is applied first to \<^term>\<open>PREC(f,g)`y\<close> and then to \<open>y\<close>!\<close>

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 \<open>
  \medskip Useful special cases of evaluation.
\<close>

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 \<open>Inductive definition of the PR functions\<close>

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 \<open>Ackermann's function cases\<close>

lemma ack_0: "j \<in> nat ==> ack(0,j) = succ(j)"
  \<comment> \<open>PROPERTY A 1\<close>
  by (simp add: SC)

lemma ack_succ_0: "ack(succ(i), 0) = ack(i,1)"
  \<comment> \<open>PROPERTY A 2\<close>
  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))"
  \<comment> \<open>PROPERTY A 3\<close>
  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)"
  \<comment> \<open>PROPERTY A 4\<close>
  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))"
  \<comment> \<open>PROPERTY A 5-, the single-step lemma\<close>
  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)"
  \<comment> \<open>PROPERTY A 5, monotonicity for \<open><\<close>\<close>
  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)"
  \<comment> \<open>PROPERTY A 5', monotonicity for \<open>\<le>\<close>\<close>
  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)"
  \<comment> \<open>PROPERTY A 6\<close>
  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)"
  \<comment> \<open>PROPERTY A 7-, the single-step lemma\<close>
  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)"
  \<comment> \<open>PROPERTY A 7, monotonicity for \<open><\<close>\<close>
  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)"
  \<comment> \<open>PROPERTY A 7', monotonicity for \<open>\<le>\<close>\<close>
  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))"
  \<comment> \<open>PROPERTY A 8\<close>
  by (induct set: nat) simp_all

lemma ack_2: "j \<in> nat ==> ack(succ(1),j) = succ(succ(succ(j#+j)))"
  \<comment> \<open>PROPERTY A 9\<close>
  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)"
  \<comment> \<open>PROPERTY A 10\<close>
  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)"
  \<comment> \<open>PROPERTY A 11\<close>
  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)"
  \<comment> \<open>PROPERTY A 12.\<close>
  \<comment> \<open>Article uses existential quantifier but the ALF proof used \<^term>\<open>k#+#4\<close>.\<close>
  \<comment> \<open>Quantified version must be nested \<open>\<exists>k'. \<forall>i,j \<dots>\<close>.\<close>
  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 \<open>Main result\<close>

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)"
  \<comment> \<open>PROPERTY A 4'? Extra lemma needed for \<open>CONSTANT\<close> case, constant functions.\<close>
  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 \<open>
  \medskip \<open>COMP\<close> case.
\<close>

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 \<open>
  \medskip \<open>PREC\<close> case.
\<close>

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)  \<comment> \<open>get rid of the needless assumption\<close>
  apply (induct_tac a)
   apply simp_all
   txt \<open>base case\<close>
   apply (rule lt_trans, erule bspec, assumption)
   apply (simp add: add_le_self [THEN ack_lt_mono1])
  txt \<open>ind step\<close>
  apply (rule succ_leI [THEN lt_trans1])
   apply (rule_tac j = "g ` ll #+ mm" for 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 \<open>final part of the simplification\<close>
  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