section \<open> Expression Type Class Instantiations \<close>

theory utp_expr_insts
  imports utp_expr
begin

text \<open> It should be noted that instantiating the unary minus class, @{class uminus}, will also
  provide negation UTP predicates later. \<close>

instantiation uexpr :: (uminus, type) uminus
begin
  definition uminus_uexpr_def [uexpr_defs]: "- u = uop uminus u"
instance ..
end

instantiation uexpr :: (minus, type) minus
begin
  definition minus_uexpr_def [uexpr_defs]: "u - v = bop (-) u v"
instance ..
end

instantiation uexpr :: (times, type) times
begin
  definition times_uexpr_def [uexpr_defs]: "u * v = bop times u v"
instance ..
end

instance uexpr :: (Rings.dvd, type) Rings.dvd ..

instantiation uexpr :: (divide, type) divide
begin
  definition divide_uexpr :: "('a, 'b) uexpr \<Rightarrow> ('a, 'b) uexpr \<Rightarrow> ('a, 'b) uexpr" where
  [uexpr_defs]: "divide_uexpr u v = bop divide u v"
instance ..
end

instantiation uexpr :: (inverse, type) inverse
begin
  definition inverse_uexpr :: "('a, 'b) uexpr \<Rightarrow> ('a, 'b) uexpr"
  where [uexpr_defs]: "inverse_uexpr u = uop inverse u"
instance ..
end

instantiation uexpr :: (modulo, type) modulo
begin
  definition mod_uexpr_def [uexpr_defs]: "u mod v = bop (mod) u v"
instance ..
end

instantiation uexpr :: (sgn, type) sgn
begin
  definition sgn_uexpr_def [uexpr_defs]: "sgn u = uop sgn u"
instance ..
end

instantiation uexpr :: (abs, type) abs
begin
  definition abs_uexpr_def [uexpr_defs]: "abs u = uop abs u"
instance ..
end

text \<open> Once we've set up all the core constructs for arithmetic, we can also instantiate the
  type classes for various algebras, including groups and rings. The proofs are done by
  definitional expansion, the \emph{transfer} tactic, and then finally the theorems of the underlying
  HOL operators. This is mainly routine, so we don't comment further. \<close>

instance uexpr :: (semigroup_mult, type) semigroup_mult
  by (intro_classes) (simp add: times_uexpr_def one_uexpr_def, transfer, simp add: mult.assoc)+

instance uexpr :: (monoid_mult, type) monoid_mult
  by (intro_classes) (simp add: times_uexpr_def one_uexpr_def, transfer, simp)+

instance uexpr :: (monoid_add, type) monoid_add
  by (intro_classes) (simp add: plus_uexpr_def zero_uexpr_def, transfer, simp)+

instance uexpr :: (ab_semigroup_add, type) ab_semigroup_add
  by (intro_classes) (simp add: plus_uexpr_def, transfer, simp add: add.commute)+

instance uexpr :: (cancel_semigroup_add, type) cancel_semigroup_add
  by (intro_classes) (simp add: plus_uexpr_def, transfer, simp add: fun_eq_iff)+

instance uexpr :: (cancel_ab_semigroup_add, type) cancel_ab_semigroup_add
  by (intro_classes, (simp add: plus_uexpr_def minus_uexpr_def, transfer, simp add: fun_eq_iff add.commute cancel_ab_semigroup_add_class.diff_diff_add)+)

instance uexpr :: (group_add, type) group_add
  by (intro_classes)
     (simp add: plus_uexpr_def uminus_uexpr_def minus_uexpr_def zero_uexpr_def, transfer, simp)+

instance uexpr :: (ab_group_add, type) ab_group_add
  by (intro_classes)
     (simp add: plus_uexpr_def uminus_uexpr_def minus_uexpr_def zero_uexpr_def, transfer, simp)+

instance uexpr :: (semiring, type) semiring
  by (intro_classes) (simp add: plus_uexpr_def times_uexpr_def, transfer, simp add: fun_eq_iff add.commute semiring_class.distrib_right semiring_class.distrib_left)+

instance uexpr :: (ring_1, type) ring_1
  by (intro_classes) (simp add: plus_uexpr_def uminus_uexpr_def minus_uexpr_def times_uexpr_def zero_uexpr_def one_uexpr_def, transfer, simp add: fun_eq_iff)+

text \<open> We also lift the properties from certain ordered groups. \<close>

instance uexpr :: (ordered_ab_group_add, type) ordered_ab_group_add
  by (intro_classes) (simp add: plus_uexpr_def, transfer, simp)

instance uexpr :: (ordered_ab_group_add_abs, type) ordered_ab_group_add_abs
  apply (intro_classes)
      apply (simp add: abs_uexpr_def zero_uexpr_def plus_uexpr_def uminus_uexpr_def, transfer, simp add: abs_ge_self abs_le_iff abs_triangle_ineq)+
  apply (metis ab_group_add_class.ab_diff_conv_add_uminus abs_ge_minus_self abs_ge_self add_mono_thms_linordered_semiring(1))
  done

text \<open> The next theorem lifts powers. \<close>

lemma power_rep_eq [ueval]: "\<lbrakk>P ^ n\<rbrakk>\<^sub>e = (\<lambda> b. \<lbrakk>P\<rbrakk>\<^sub>e b ^ n)"
  by (induct n, simp_all add: lit.rep_eq one_uexpr_def bop.rep_eq times_uexpr_def)

lemma of_nat_uexpr_rep_eq [ueval]: "\<lbrakk>of_nat x\<rbrakk>\<^sub>e b = of_nat x"
  by (induct x, simp_all add: uexpr_defs ueval)

lemma lit_uminus [lit_simps]: "\<guillemotleft>- x\<guillemotright> = - \<guillemotleft>x\<guillemotright>" by (simp add: uexpr_defs, transfer, simp)
lemma lit_minus [lit_simps]: "\<guillemotleft>x - y\<guillemotright> = \<guillemotleft>x\<guillemotright> - \<guillemotleft>y\<guillemotright>" by (simp add: uexpr_defs, transfer, simp)
lemma lit_times [lit_simps]: "\<guillemotleft>x * y\<guillemotright> = \<guillemotleft>x\<guillemotright> * \<guillemotleft>y\<guillemotright>" by (simp add: uexpr_defs, transfer, simp)
lemma lit_divide [lit_simps]: "\<guillemotleft>x / y\<guillemotright> = \<guillemotleft>x\<guillemotright> / \<guillemotleft>y\<guillemotright>" by (simp add: uexpr_defs, transfer, simp)
lemma lit_div [lit_simps]: "\<guillemotleft>x div y\<guillemotright> = \<guillemotleft>x\<guillemotright> div \<guillemotleft>y\<guillemotright>" by (simp add: uexpr_defs, transfer, simp)
lemma lit_power [lit_simps]: "\<guillemotleft>x ^ n\<guillemotright> = \<guillemotleft>x\<guillemotright> ^ n" by (simp add: lit.rep_eq power_rep_eq uexpr_eq_iff)

subsection \<open> Expression construction from HOL terms \<close>

text \<open> Sometimes it is convenient to cast HOL terms to UTP expressions, and these simplifications
  automate this process. \<close>

named_theorems mkuexpr

lemma mkuexpr_lens_get [mkuexpr]: "mk\<^sub>e get\<^bsub>x\<^esub> = &x"
  by (transfer, simp add: pr_var_def)

lemma mkuexpr_zero [mkuexpr]: "mk\<^sub>e (\<lambda> s. 0) = 0"
  by (simp add: zero_uexpr_def, transfer, simp)

lemma mkuexpr_one [mkuexpr]: "mk\<^sub>e (\<lambda> s. 1) = 1"
  by (simp add: one_uexpr_def, transfer, simp)

lemma mkuexpr_numeral [mkuexpr]: "mk\<^sub>e (\<lambda> s. numeral n) = numeral n"
  using lit_numeral_2 by blast

lemma mkuexpr_lit [mkuexpr]: "mk\<^sub>e (\<lambda> s. k) = \<guillemotleft>k\<guillemotright>"
  by (transfer, simp)

lemma mkuexpr_pair [mkuexpr]: "mk\<^sub>e (\<lambda>s. (f s, g s)) = (mk\<^sub>e f, mk\<^sub>e g)\<^sub>u"
  by (transfer, simp)

lemma mkuexpr_plus [mkuexpr]: "mk\<^sub>e (\<lambda> s. f s + g s) = mk\<^sub>e f + mk\<^sub>e g"
  by (simp add: plus_uexpr_def, transfer, simp)

lemma mkuexpr_uminus [mkuexpr]: "mk\<^sub>e (\<lambda> s. - f s) = - mk\<^sub>e f"
  by (simp add: uminus_uexpr_def, transfer, simp)

lemma mkuexpr_minus [mkuexpr]: "mk\<^sub>e (\<lambda> s. f s - g s) = mk\<^sub>e f - mk\<^sub>e g"
  by (simp add: minus_uexpr_def, transfer, simp)

lemma mkuexpr_times [mkuexpr]: "mk\<^sub>e (\<lambda> s. f s * g s) = mk\<^sub>e f * mk\<^sub>e g"
  by (simp add: times_uexpr_def, transfer, simp)

lemma mkuexpr_divide [mkuexpr]: "mk\<^sub>e (\<lambda> s. f s / g s) = mk\<^sub>e f / mk\<^sub>e g"
  by (simp add: divide_uexpr_def, transfer, simp)

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_sort_SSortSorts
  imports "../../Test_Base"
begin

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

fun ssortminimum1 :: "int => int list => int" where
  "ssortminimum1 x (nil2) = x"
| "ssortminimum1 x (cons2 y1 ys1) =
     (if y1 <= x then ssortminimum1 y1 ys1 else ssortminimum1 x ys1)"

fun ordered :: "int list => bool" where
  "ordered (nil2) = True"
| "ordered (cons2 y (nil2)) = True"
| "ordered (cons2 y (cons2 y2 xs)) =
     ((y <= y2) & (ordered (cons2 y2 xs)))"

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 did not finish the proof*)
function ssort :: "int list => int list" where
  "ssort (nil2) = nil2"
| "ssort (cons2 y ys) =
     (let m :: int = ssortminimum1 y ys
     in cons2
          m
          (ssort
             (deleteBy
                (% (z :: int) => % (x2 :: int) => (z = x2)) m (cons2 y ys))))"
  by pat_completeness auto

theorem property0 :
  "ordered (ssort xs)"
  oops

end


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

section\<open>The Natural numbers As a Least Fixed Point\<close>

theory Nat imports OrdQuant Bool begin

definition
  nat :: i  where
    "nat \<equiv> lfp(Inf, \<lambda>X. {0} \<union> {succ(i). i \<in> X})"

definition
  quasinat :: "i \<Rightarrow> o"  where
    "quasinat(n) \<equiv> n=0 | (\<exists>m. n = succ(m))"

definition
  (*Has an unconditional succ case, which is used in "recursor" below.*)
  nat_case :: "[i, i\<Rightarrow>i, i]\<Rightarrow>i"  where
    "nat_case(a,b,k) \<equiv> THE y. k=0 \<and> y=a | (\<exists>x. k=succ(x) \<and> y=b(x))"

definition
  nat_rec :: "[i, i, [i,i]\<Rightarrow>i]\<Rightarrow>i"  where
    "nat_rec(k,a,b) \<equiv>
          wfrec(Memrel(nat), k, \<lambda>n f. nat_case(a, \<lambda>m. b(m, f`m), n))"

  (*Internalized relations on the naturals*)

definition
  Le :: i  where
    "Le \<equiv> {\<langle>x,y\<rangle>:nat*nat. x \<le> y}"

definition
  Lt :: i  where
    "Lt \<equiv> {\<langle>x, y\<rangle>:nat*nat. x < y}"

definition
  Ge :: i  where
    "Ge \<equiv> {\<langle>x,y\<rangle>:nat*nat. y \<le> x}"

definition
  Gt :: i  where
    "Gt \<equiv> {\<langle>x,y\<rangle>:nat*nat. y < x}"

definition
  greater_than :: "i\<Rightarrow>i"  where
    "greater_than(n) \<equiv> {i \<in> nat. n < i}"

text\<open>No need for a less-than operator: a natural number is its list of
predecessors!\<close>

lemma nat_bnd_mono: "bnd_mono(Inf, \<lambda>X. {0} \<union> {succ(i). i \<in> X})"
apply (rule bnd_monoI)
apply (cut_tac infinity, blast, blast)
done

(* @{term"nat = {0} \<union> {succ(x). x \<in> nat}"} *)
lemmas nat_unfold = nat_bnd_mono [THEN nat_def [THEN def_lfp_unfold]]

(** Type checking of 0 and successor **)

lemma nat_0I [iff,TC]: "0 \<in> nat"
apply (subst nat_unfold)
apply (rule singletonI [THEN UnI1])
done

lemma nat_succI [intro!,TC]: "n \<in> nat \<Longrightarrow> succ(n) \<in> nat"
apply (subst nat_unfold)
apply (erule RepFunI [THEN UnI2])
done

lemma nat_1I [iff,TC]: "1 \<in> nat"
by (rule nat_0I [THEN nat_succI])

lemma nat_2I [iff,TC]: "2 \<in> nat"
by (rule nat_1I [THEN nat_succI])

lemma bool_subset_nat: "bool \<subseteq> nat"
by (blast elim!: boolE)

lemmas bool_into_nat = bool_subset_nat [THEN subsetD]

subsection\<open>Injectivity Properties and Induction\<close>

(*Mathematical induction*)
lemma nat_induct [case_names 0 succ, induct set: nat]:
    "\<lbrakk>n \<in> nat;  P(0);  \<And>x. \<lbrakk>x \<in> nat;  P(x)\<rbrakk> \<Longrightarrow> P(succ(x))\<rbrakk> \<Longrightarrow> P(n)"
by (erule def_induct [OF nat_def nat_bnd_mono], blast)

lemma natE:
 assumes "n \<in> nat"
 obtains ("0") "n=0" | (succ) x where "x \<in> nat" "n=succ(x)"
using assms
by (rule nat_unfold [THEN equalityD1, THEN subsetD, THEN UnE]) auto

lemma nat_into_Ord [simp]: "n \<in> nat \<Longrightarrow> Ord(n)"
by (erule nat_induct, auto)

(* @{term"i \<in> nat \<Longrightarrow> 0 \<le> i"}; same thing as @{term"0<succ(i)"}  *)
lemmas nat_0_le = nat_into_Ord [THEN Ord_0_le]

(* @{term"i \<in> nat \<Longrightarrow> i \<le> i"}; same thing as @{term"i<succ(i)"}  *)
lemmas nat_le_refl = nat_into_Ord [THEN le_refl]

lemma Ord_nat [iff]: "Ord(nat)"
apply (rule OrdI)
apply (erule_tac [2] nat_into_Ord [THEN Ord_is_Transset])
  unfolding Transset_def
apply (rule ballI)
apply (erule nat_induct, auto)
done

lemma Limit_nat [iff]: "Limit(nat)"
  unfolding Limit_def
apply (safe intro!: ltI Ord_nat)
apply (erule ltD)
done

lemma naturals_not_limit: "a \<in> nat \<Longrightarrow> \<not> Limit(a)"
by (induct a rule: nat_induct, auto)

lemma succ_natD: "succ(i): nat \<Longrightarrow> i \<in> nat"
by (rule Ord_trans [OF succI1], auto)

lemma nat_succ_iff [iff]: "succ(n): nat \<longleftrightarrow> n \<in> nat"
by (blast dest!: succ_natD)

lemma nat_le_Limit: "Limit(i) \<Longrightarrow> nat \<le> i"
apply (rule subset_imp_le)
apply (simp_all add: Limit_is_Ord)
apply (rule subsetI)
apply (erule nat_induct)
 apply (erule Limit_has_0 [THEN ltD])
apply (blast intro: Limit_has_succ [THEN ltD] ltI Limit_is_Ord)
done

(* \<lbrakk>succ(i): k;  k \<in> nat\<rbrakk> \<Longrightarrow> i \<in> k *)
lemmas succ_in_naturalD = Ord_trans [OF succI1 _ nat_into_Ord]

lemma lt_nat_in_nat: "\<lbrakk>m<n;  n \<in> nat\<rbrakk> \<Longrightarrow> m \<in> nat"
apply (erule ltE)
apply (erule Ord_trans, assumption, simp)
done

lemma le_in_nat: "\<lbrakk>m \<le> n; n \<in> nat\<rbrakk> \<Longrightarrow> m \<in> nat"
by (blast dest!: lt_nat_in_nat)

subsection\<open>Variations on Mathematical Induction\<close>

(*complete induction*)

lemmas complete_induct = Ord_induct [OF _ Ord_nat, case_names less, consumes 1]

lemma complete_induct_rule [case_names less, consumes 1]:
  "i \<in> nat \<Longrightarrow> (\<And>x. x \<in> nat \<Longrightarrow> (\<And>y. y \<in> x \<Longrightarrow> P(y)) \<Longrightarrow> P(x)) \<Longrightarrow> P(i)"
  using complete_induct [of i P] by simp

(*Induction starting from m rather than 0*)
lemma nat_induct_from:
  assumes "m \<le> n" "m \<in> nat" "n \<in> nat"
    and "P(m)"
    and "\<And>x. \<lbrakk>x \<in> nat;  m \<le> x;  P(x)\<rbrakk> \<Longrightarrow> P(succ(x))"
  shows "P(n)"
proof -
  from assms(3) have "m \<le> n \<longrightarrow> P(m) \<longrightarrow> P(n)"
    by (rule nat_induct) (use assms(5) in \<open>simp_all add: distrib_simps le_succ_iff\<close>)
  with assms(1,2,4) show ?thesis by blast
qed

(*Induction suitable for subtraction and less-than*)
lemma diff_induct [case_names 0 0_succ succ_succ, consumes 2]:
    "\<lbrakk>m \<in> nat;  n \<in> nat;
        \<And>x. x \<in> nat \<Longrightarrow> P(x,0);
        \<And>y. y \<in> nat \<Longrightarrow> P(0,succ(y));
        \<And>x y. \<lbrakk>x \<in> nat;  y \<in> nat;  P(x,y)\<rbrakk> \<Longrightarrow> P(succ(x),succ(y))\<rbrakk>
     \<Longrightarrow> P(m,n)"
apply (erule_tac x = m in rev_bspec)
apply (erule nat_induct, simp)
apply (rule ballI)
apply (rename_tac i j)
apply (erule_tac n=j in nat_induct, auto)
done

(** Induction principle analogous to trancl_induct **)

lemma succ_lt_induct_lemma [rule_format]:
     "m \<in> nat \<Longrightarrow> P(m,succ(m)) \<longrightarrow> (\<forall>x\<in>nat. P(m,x) \<longrightarrow> P(m,succ(x))) \<longrightarrow>
                 (\<forall>n\<in>nat. m<n \<longrightarrow> P(m,n))"
apply (erule nat_induct)
 apply (intro impI, rule nat_induct [THEN ballI])
   prefer 4 apply (intro impI, rule nat_induct [THEN ballI])
apply (auto simp add: le_iff)
done

lemma succ_lt_induct:
    "\<lbrakk>m<n;  n \<in> nat;
        P(m,succ(m));
        \<And>x. \<lbrakk>x \<in> nat;  P(m,x)\<rbrakk> \<Longrightarrow> P(m,succ(x))\<rbrakk>
     \<Longrightarrow> P(m,n)"
by (blast intro: succ_lt_induct_lemma lt_nat_in_nat)

subsection\<open>quasinat: to allow a case-split rule for \<^term>\<open>nat_case\<close>\<close>

text\<open>True if the argument is zero or any successor\<close>

lemma [iff]: "quasinat(succ(x))"
by (simp add: quasinat_def)

lemma nat_imp_quasinat: "n \<in> nat \<Longrightarrow> quasinat(n)"
by (erule natE, simp_all)

lemma non_nat_case: "\<not> quasinat(x) \<Longrightarrow> nat_case(a,b,x) = 0"
by (simp add: quasinat_def nat_case_def)

lemma nat_cases_disj: "k=0 | (\<exists>y. k = succ(y)) | \<not> quasinat(k)"
apply (case_tac "k=0", simp)
apply (case_tac "\<exists>m. k = succ(m)")
apply (simp_all add: quasinat_def)
done

lemma nat_cases:
     "\<lbrakk>k=0 \<Longrightarrow> P;  \<And>y. k = succ(y) \<Longrightarrow> P; \<not> quasinat(k) \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
by (insert nat_cases_disj [of k], blast)

(** nat_case **)

lemma nat_case_0 [simp]: "nat_case(a,b,0) = a"
by (simp add: nat_case_def)

lemma nat_case_succ [simp]: "nat_case(a,b,succ(n)) = b(n)"
by (simp add: nat_case_def)

lemma nat_case_type [TC]:
    "\<lbrakk>n \<in> nat;  a \<in> C(0);  \<And>m. m \<in> nat \<Longrightarrow> b(m): C(succ(m))\<rbrakk>
     \<Longrightarrow> nat_case(a,b,n) \<in> C(n)"
by (erule nat_induct, auto)

lemma split_nat_case:
  "P(nat_case(a,b,k)) \<longleftrightarrow>
   ((k=0 \<longrightarrow> P(a)) \<and> (\<forall>x. k=succ(x) \<longrightarrow> P(b(x))) \<and> (\<not> quasinat(k) \<longrightarrow> P(0)))"
apply (rule nat_cases [of k])
apply (auto simp add: non_nat_case)
done

subsection\<open>Recursion on the Natural Numbers\<close>

(** nat_rec is used to define eclose and transrec, then becomes obsolete.
    The operator rec, from arith.thy, has fewer typing conditions **)

lemma nat_rec_0: "nat_rec(0,a,b) = a"
apply (rule nat_rec_def [THEN def_wfrec, THEN trans])
 apply (rule wf_Memrel)
apply (rule nat_case_0)
done

lemma nat_rec_succ: "m \<in> nat \<Longrightarrow> nat_rec(succ(m),a,b) = b(m, nat_rec(m,a,b))"
apply (rule nat_rec_def [THEN def_wfrec, THEN trans])
 apply (rule wf_Memrel)
apply (simp add: vimage_singleton_iff)
done

(** The union of two natural numbers is a natural number -- their maximum **)

lemma Un_nat_type [TC]: "\<lbrakk>i \<in> nat; j \<in> nat\<rbrakk> \<Longrightarrow> i \<union> j \<in> nat"
apply (rule Un_least_lt [THEN ltD])
apply (simp_all add: lt_def)
done

lemma Int_nat_type [TC]: "\<lbrakk>i \<in> nat; j \<in> nat\<rbrakk> \<Longrightarrow> i \<inter> j \<in> nat"
apply (rule Int_greatest_lt [THEN ltD])
apply (simp_all add: lt_def)
done

(*needed to simplify unions over nat*)
lemma nat_nonempty [simp]: "nat \<noteq> 0"
by blast

text\<open>A natural number is the set of its predecessors\<close>
lemma nat_eq_Collect_lt: "i \<in> nat \<Longrightarrow> {j\<in>nat. j<i} = i"
apply (rule equalityI)
apply (blast dest: ltD)
apply (auto simp add: Ord_mem_iff_lt)
apply (blast intro: lt_trans)
done

lemma Le_iff [iff]: "\<langle>x,y\<rangle> \<in> Le \<longleftrightarrow> x \<le> y \<and> x \<in> nat \<and> y \<in> nat"
by (force simp add: Le_def)

end


theory Exercise5
  imports Main
begin

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
refl: "star r x x" |
step: "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
refli: "iter r 0 x x" |
stepi: "r x y \<Longrightarrow> iter r n y z \<Longrightarrow> iter r (Suc n) x z"

theorem "iter r n x y \<Longrightarrow> star r x y"
proof (induction rule: iter.induct)
  case (refli x)
  thus ?case by (rule star.refl)
next
  case (stepi x y n z)
  thus ?case by (auto intro: star.step)
qed

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_38
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

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

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

fun x :: "bool => bool => bool" where
  "x True y2 = True"
| "x False y2 = y2"

fun elem :: "Nat => Nat list => bool" where
  "elem x2 (nil2) = False"
| "elem x2 (cons2 z2 xs) = x (y x2 z2) (elem x2 xs)"

theorem property0 :
  "((elem x2 y2) ==> ((elem x2 z2) ==> (elem x2 (z y2 z2))))"
  apply(induction y2, auto)
  apply(case_tac "y x2 x1", auto)
  done

end


theory Metric_Arith_Examples
imports "HOL-Analysis.Elementary_Metric_Spaces"
begin

text \<open>simple examples\<close>

lemma "\<exists>x::'a::metric_space. x=x"
  by metric
lemma "\<forall>(x::'a::metric_space). \<exists>y. x = y"
  by metric

text \<open>reasoning with "dist x y = 0 \<longleftrightarrow> x = y"\<close>

lemma "\<exists>x y. dist x y = 0"
  by metric

lemma "\<exists>y. dist x y = 0"
  by metric

lemma "0 = dist x y \<Longrightarrow> x = y"
  by metric

lemma "x \<noteq> y \<Longrightarrow> dist x y \<noteq> 0"
  by metric

lemma "\<exists>y. dist x y \<noteq> 1"
  by metric

lemma "x = y \<longleftrightarrow> dist x x = dist y x \<and> dist x y = dist y y"
  by metric

lemma "dist a b \<noteq> dist a c \<Longrightarrow> b \<noteq> c"
  by metric

text \<open>reasoning with positive semidefiniteness\<close>

lemma "dist y x + c \<ge> c"
  by metric

lemma "dist x y + dist x z \<ge> 0"
  by metric

lemma "dist x y \<ge> v \<Longrightarrow> dist x y + dist (a::'a) b \<ge> v" for x::"('a::metric_space)"
  by metric

lemma "dist x y < 0 \<longrightarrow> P"
  by metric

text \<open>reasoning with the triangle inequality\<close>

lemma "dist a d \<le> dist a b + dist b c + dist c d"
  by metric

lemma "dist a e \<le> dist a b + dist b c + dist c d + dist d e"
  by metric

lemma "max (dist x y) \<bar>dist x z - dist z y\<bar> = dist x y"
  by metric

lemma
  "dist w x < e/3 \<Longrightarrow> dist x y < e/3 \<Longrightarrow> dist y z < e/3 \<Longrightarrow> dist w x < e"
  by metric

lemma "dist w x < e/4 \<Longrightarrow> dist x y < e/4 \<Longrightarrow> dist y z < e/2 \<Longrightarrow> dist w z < e"
  by metric

text \<open>more complex examples\<close>

lemma "dist x y \<le> e \<Longrightarrow> dist x z \<le> e \<Longrightarrow> dist y z \<le> e
  \<Longrightarrow> p \<in> (cball x e \<union> cball y e \<union> cball z e) \<Longrightarrow> dist p x \<le> 2*e"
  by metric

lemma hol_light_example:
  "\<not> disjnt (ball x r) (ball y s) \<longrightarrow>
    (\<forall>p q. p \<in> ball x r \<union> ball y s \<and> q \<in> ball x r \<union> ball y s \<longrightarrow> dist p q < 2 * (r + s))"
  unfolding disjnt_iff
  by metric

lemma "dist x y \<le> e \<Longrightarrow> z \<in> ball x f \<Longrightarrow> dist z y < e + f"
  by metric

lemma "dist x y = r / 2 \<Longrightarrow> (\<forall>z. dist x z < r / 4 \<longrightarrow> dist y z \<le> 3 * r / 4)"
  by metric

lemma "s \<ge> 0 \<Longrightarrow> t \<ge> 0 \<Longrightarrow> z \<in> (ball x s) \<union> (ball y t) \<Longrightarrow> dist z y \<le> dist x y + s + t"
  by metric

lemma "0 < r \<Longrightarrow> ball x r \<subseteq> ball y s \<Longrightarrow> ball x r \<subseteq> ball z t \<Longrightarrow> dist y z \<le> s + t"
  by metric

text \<open>non-trivial quantifier structure\<close>

lemma "\<exists>x. \<forall>r\<le>0. \<exists>z. dist x z \<ge> r"
  by metric

lemma "\<And>a r x y. dist x a + dist a y = r \<Longrightarrow> \<forall>z. r \<le> dist x z + dist z y \<Longrightarrow> dist x y = r"
  by metric

end


theory ExF006
  imports Main
begin

lemma "(\<exists>x. \<forall>y. P x y) \<longrightarrow> (\<forall>y. \<exists>x. P x y)"
proof -
  {
    assume "\<exists>x. \<forall>y. P x y"
    {
      fix b
      {
        fix a
        assume "\<forall>y .P a y"
        hence "P a b" by (rule allE)
        hence "\<exists>x. P x b" by (rule exI)
      }
      with  \<open>\<exists>x. \<forall>y. P x y\<close> have "\<exists>x. P x b" by (rule exE)
    }
    hence "\<forall>y. \<exists>x. P x y" by (rule allI)
  }
  thus ?thesis by (rule impI)
qed


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
paragraph \<open>Antisymmetric\<close>
theory Binary_Relations_Antisymmetric
  imports
    Binary_Relation_Functions
    HOL_Syntax_Bundles_Lattices
begin

consts antisymmetric_on :: "'a \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> bool"

overloading
  antisymmetric_on_pred \<equiv> "antisymmetric_on :: ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
begin
  definition "antisymmetric_on_pred P R \<equiv> \<forall>x y. P x \<and> P y \<and> R x y \<and> R y x \<longrightarrow> x = y"
end

lemma antisymmetric_onI [intro]:
  assumes "\<And>x y. P x \<Longrightarrow> P y \<Longrightarrow> R x y \<Longrightarrow> R y x \<Longrightarrow> x = y"
  shows "antisymmetric_on P R"
  unfolding antisymmetric_on_pred_def using assms by blast

lemma antisymmetric_onD:
  assumes "antisymmetric_on P R"
  and "P x" "P y"
  and "R x y" "R y x"
  shows "x = y"
  using assms unfolding antisymmetric_on_pred_def by blast

definition "antisymmetric (R :: 'a \<Rightarrow> _) \<equiv> antisymmetric_on (\<top> :: 'a \<Rightarrow> bool) R"

lemma antisymmetric_eq_antisymmetric_on:
  "antisymmetric (R :: 'a \<Rightarrow> _) = antisymmetric_on (\<top> :: 'a \<Rightarrow> bool) R"
  unfolding antisymmetric_def ..

lemma antisymmetricI [intro]:
  assumes "\<And>x y. R x y \<Longrightarrow> R y x \<Longrightarrow> x = y"
  shows "antisymmetric R"
  unfolding antisymmetric_eq_antisymmetric_on using assms
  by (intro antisymmetric_onI)

lemma antisymmetricD:
  assumes "antisymmetric R"
  and "R x y" "R y x"
  shows "x = y"
  using assms unfolding antisymmetric_eq_antisymmetric_on
  by (auto dest: antisymmetric_onD)

lemma antisymmetric_on_if_antisymmetric:
  fixes P :: "'a \<Rightarrow> bool" and R :: "'a \<Rightarrow> _"
  assumes "antisymmetric R"
  shows "antisymmetric_on P R"
  using assms by (intro antisymmetric_onI) (blast dest: antisymmetricD)

lemma antisymmetric_if_antisymmetric_on_in_field:
  assumes "antisymmetric_on (in_field R) R"
  shows "antisymmetric R"
  using assms by (intro antisymmetricI) (blast dest: antisymmetric_onD)

corollary antisymmetric_on_in_field_iff_antisymmetric [simp]:
  "antisymmetric_on (in_field R) R \<longleftrightarrow> antisymmetric R"
  using antisymmetric_if_antisymmetric_on_in_field antisymmetric_on_if_antisymmetric
  by blast

end


section \<open>The Decomposition Theorem\<close>

text \<open>This theory contains a proof of the fact, that every polyhedron can be decomposed
  into a convex hull of a finite set of points + a finitely generated cone, including bounds
  on the numbers that are required in the decomposition.
  We further prove the inverse direction of this theorem (without bounds) and
  as a corollary, we derive that a polyhedron is bounded iff it is the convex hull
  of finitely many points, i.e., a polytope.\<close>

theory Decomposition_Theorem
  imports
    Farkas_Minkowsky_Weyl
    Convex_Hull
begin

context gram_schmidt
begin

definition "polytope P = (\<exists> V. V \<subseteq> carrier_vec n \<and> finite V \<and> P = convex_hull V)"

definition "polyhedron A b = {x \<in> carrier_vec n. A *\<^sub>v x \<le> b}"

lemma polyhedra_are_convex:
  assumes A: "A \<in> carrier_mat nr n"
    and b: "b \<in> carrier_vec nr"
    and P: "P = polyhedron A b"
  shows "convex P"
proof (intro convexI)
  show Pcarr: "P \<subseteq> carrier_vec n" using assms unfolding polyhedron_def by auto
  fix a :: 'a and x y
  assume xy: "x \<in> P" "y \<in> P" and a: "0 \<le> a" "a \<le> 1"
  from xy[unfolded P polyhedron_def]
  have x: "x \<in> carrier_vec n" and y: "y \<in> carrier_vec n" and le: "A *\<^sub>v x \<le> b" "A *\<^sub>v y \<le> b" by auto
  show "a \<cdot>\<^sub>v x + (1 - a) \<cdot>\<^sub>v y \<in> P" unfolding P polyhedron_def
  proof (intro CollectI conjI)
    from x have ax: "a \<cdot>\<^sub>v x \<in> carrier_vec n" by auto
    from y have ay: "(1 - a) \<cdot>\<^sub>v y \<in> carrier_vec n" by auto
    show "a \<cdot>\<^sub>v x + (1 - a) \<cdot>\<^sub>v y \<in> carrier_vec n" using ax ay by auto
    show "A *\<^sub>v (a \<cdot>\<^sub>v x + (1 - a) \<cdot>\<^sub>v y) \<le> b"
    proof (intro lesseq_vecI[OF _ b])
      show "A *\<^sub>v (a \<cdot>\<^sub>v x + (1 - a) \<cdot>\<^sub>v y) \<in> carrier_vec nr" using A x y by auto
      fix i
      assume i: "i < nr"
      from lesseq_vecD[OF b le(1) i] lesseq_vecD[OF b le(2) i]
      have le: "(A *\<^sub>v x) $ i \<le> b $ i" "(A *\<^sub>v y) $ i \<le> b $ i" by auto
      have "(A *\<^sub>v (a \<cdot>\<^sub>v x + (1 - a) \<cdot>\<^sub>v y)) $ i = a * (A *\<^sub>v x) $ i + (1 - a) * (A *\<^sub>v y) $ i"
        using A x y i by (auto simp: scalar_prod_add_distrib[of _ n])
      also have "\<dots> \<le> a * b $ i + (1 - a) * b $ i"
        by (rule add_mono; rule mult_left_mono, insert le a, auto)
      also have "\<dots> = b $ i" by (auto simp: field_simps)
      finally show "(A *\<^sub>v (a \<cdot>\<^sub>v x + (1 - a) \<cdot>\<^sub>v y)) $ i \<le> b $ i" .
    qed
  qed
qed

end

locale gram_schmidt_m = n: gram_schmidt n f_ty + m: gram_schmidt m f_ty
  for n m :: nat and f_ty
begin

lemma vec_first_lincomb_list:
  assumes Xs: "set Xs \<subseteq> carrier_vec n"
    and nm: "m \<le> n"
  shows "vec_first (n.lincomb_list c Xs) m =
       m.lincomb_list c (map (\<lambda> v. vec_first v m) Xs)"
  using Xs
proof (induction Xs arbitrary: c)
  case Nil
  show ?case by (simp add: nm)
next
  case (Cons x Xs)
  from Cons.prems have x: "x \<in> carrier_vec n" and Xs: "set Xs \<subseteq> carrier_vec n" by auto

  have "vec_first (n.lincomb_list c (x # Xs)) m =
          vec_first (c 0 \<cdot>\<^sub>v x + n.lincomb_list (c \<circ> Suc) Xs) m" by auto
  also have "\<dots> = vec_first (c 0 \<cdot>\<^sub>v x) m + vec_first (n.lincomb_list (c \<circ> Suc) Xs) m"
    using vec_first_add[of m "c 0 \<cdot>\<^sub>v x"] x n.lincomb_list_carrier[OF Xs, of "c \<circ> Suc"] nm
    by simp
  also have "vec_first (c 0 \<cdot>\<^sub>v x) m = c 0 \<cdot>\<^sub>v vec_first x m"
    using vec_first_smult[OF nm, of x "c 0"] Cons.prems by auto
  also have "vec_first (n.lincomb_list (c \<circ> Suc) Xs) m =
               m.lincomb_list (c \<circ> Suc) (map (\<lambda> v. vec_first v m) Xs)"
    using Cons by simp
  also have "c 0 \<cdot>\<^sub>v vec_first x m + \<dots> =
               m.lincomb_list c (map (\<lambda> v. vec_first v m) (x # Xs))"
    by simp
  finally show ?case by auto
qed

lemma convex_hull_next_dim:
  assumes "n = m + 1"
    and X: "X \<subseteq> carrier_vec n"
    and "finite X"
    and Xm1: "\<forall> y \<in> X. y $ m = 1"
    and y_dim: "y \<in> carrier_vec n"
    and y: "y $ m = 1"
  shows "(vec_first y m \<in> m.convex_hull {vec_first y m | y. y \<in> X}) = (y \<in> n.cone X)"
proof -
  from `finite X` obtain Xs where Xs: "X = set Xs" using finite_list by auto
  let ?Y = "{vec_first y m | y. y \<in> X}"
  let ?Ys = "map (\<lambda> y. vec_first y m) Xs"
  have Ys: "?Y = set ?Ys" using Xs by auto

  define x where "x = vec_first y m"
  {
    have "y = vec_first y m @\<^sub>v vec_last y 1"
      using `n = m + 1` vec_first_last_append y_dim by auto
    also have "vec_last y 1 = vec_of_scal (vec_last y 1 $ 0)"
      using vec_of_scal_dim_1[of "vec_last y 1"] by simp
    also have "vec_last y 1 $ 0 = y $ m"
      using y_dim `n = m + 1` vec_last_index[of y m 1 0] by auto
    finally have "y = x @\<^sub>v vec_of_scal 1" unfolding x_def using y by simp
  } note xy = this
  {
    assume "y \<in> n.cone X"
    then obtain c where x: "n.nonneg_lincomb c X y"
      using n.cone_iff_finite_cone[OF X] `finite X`
      unfolding n.finite_cone_def by auto

    have "1 = y $ m" by (simp add: y)
    also have "y = n.lincomb c X"
      using x unfolding n.nonneg_lincomb_def by simp
    also have "\<dots> $ m = (\<Sum>x\<in>X. c x * x $ m)"
      using n.lincomb_index[OF _ X] `n = m + 1` by simp
    also have "\<dots> = sum c X"
      by (rule n.R.finsum_restrict, auto, rule restrict_ext, simp add: Xm1)
    finally have "y \<in> n.convex_hull X"
      unfolding n.convex_hull_def n.convex_lincomb_def
      using `finite X` x by auto
  }
  moreover have "n.convex_hull X \<subseteq> n.cone X"
    unfolding n.convex_hull_def n.convex_lincomb_def n.finite_cone_def n.cone_def
    using `finite X` by auto
  moreover have "n.convex_hull X = n.convex_hull_list Xs"
    by (rule n.finite_convex_hull_iff_convex_hull_list[OF X Xs])
  moreover {
    assume "y \<in> n.convex_hull_list Xs"
    then obtain c where c: "n.lincomb_list c Xs = y"
      and c0: "\<forall> i < length Xs. c i \<ge> 0" and c1: "sum c {0..<length Xs} = 1"
      unfolding n.convex_hull_list_def n.convex_lincomb_list_def
        n.nonneg_lincomb_list_def by fast
    have "m.lincomb_list c ?Ys = vec_first y m"
      using c vec_first_lincomb_list[of Xs c] X Xs `n = m + 1` by simp
    hence "x \<in> m.convex_hull_list ?Ys"
      unfolding m.convex_hull_list_def m.convex_lincomb_list_def
        m.nonneg_lincomb_list_def
      using x_def c0 c1 x_def by auto
  } moreover {
    assume "x \<in> m.convex_hull_list ?Ys"
    then obtain c where x: "m.lincomb_list c ?Ys = x"
      and c0: "\<forall> i < length Xs. c i \<ge> 0"
      and c1: "sum c {0..<length Xs} = 1"
      unfolding m.convex_hull_list_def m.convex_lincomb_list_def
        m.nonneg_lincomb_list_def by auto

    have "n.lincomb_list c Xs $ m = (\<Sum>j = 0..<length Xs. c j * Xs ! j $ m)"
      using n.lincomb_list_index[of m Xs c] `n = m + 1` Xs X by fastforce
    also have "\<dots> = sum c {0..<length Xs}"
      apply(rule n.R.finsum_restrict, auto, rule restrict_ext)
      by (simp add: Xm1 Xs)
    also have "\<dots> = 1" by (rule c1)
    finally have "vec_last (n.lincomb_list c Xs) 1 $ 0 = 1"
      using vec_of_scal_dim_1 vec_last_index[of "n.lincomb_list c Xs" m 1 0]
        n.lincomb_list_carrier Xs X `n = m + 1` by simp
    hence "vec_last (n.lincomb_list c Xs) 1 = vec_of_scal 1"
      using vec_of_scal_dim_1 by auto

    moreover have "vec_first (n.lincomb_list c Xs) m = x"
      using vec_first_lincomb_list `n = m + 1` Xs X x by auto

    moreover have "n.lincomb_list c Xs =
                   vec_first (n.lincomb_list c Xs) m @\<^sub>v vec_last (n.lincomb_list c Xs) 1"
      using vec_first_last_append Xs X n.lincomb_list_carrier `n = m + 1` by auto

    ultimately have "n.lincomb_list c Xs = y" using xy by simp

    hence "y \<in> n.convex_hull_list Xs"
      unfolding n.convex_hull_list_def n.convex_lincomb_list_def
        n.nonneg_lincomb_list_def using c0 c1 by blast
  }
  moreover have "m.convex_hull ?Y = m.convex_hull_list ?Ys"
    using m.finite_convex_hull_iff_convex_hull_list[OF _ Ys] by fastforce
  ultimately show ?thesis unfolding x_def by blast
qed

lemma cone_next_dim:
  assumes "n = m + 1"
    and X: "X \<subseteq> carrier_vec n"
    and "finite X"
    and Xm0: "\<forall> y \<in> X. y $ m = 0"
    and y_dim: "y \<in> carrier_vec n"
    and y: "y $ m = 0"
  shows "(vec_first y m \<in> m.cone {vec_first y m | y. y \<in> X}) = (y \<in> n.cone X)"
proof -
  from `finite X` obtain Xs where Xs: "X = set Xs" using finite_list by auto
  let ?Y = "{vec_first y m | y. y \<in> X}"
  let ?Ys = "map (\<lambda> y. vec_first y m) Xs"
  have Ys: "?Y = set ?Ys" using Xs by auto

  define x where "x = vec_first y m"
  {
    have "y = vec_first y m @\<^sub>v vec_last y 1"
      using `n = m + 1` vec_first_last_append y_dim by auto
    also have "vec_last y 1 = vec_of_scal (vec_last y 1 $ 0)"
      using vec_of_scal_dim_1[of "vec_last y 1"] by simp
    also have "vec_last y 1 $ 0 = y $ m"
      using y_dim `n = m + 1` vec_last_index[of y m 1 0] by auto
    finally have "y = x @\<^sub>v vec_of_scal 0" unfolding x_def using y by simp
  } note xy = this

  have "n.cone X = n.cone_list Xs"
    using n.cone_iff_finite_cone[OF X `finite X`] n.finite_cone_iff_cone_list[OF X Xs]
    by simp
  moreover {
    assume "y \<in> n.cone_list Xs"
    then obtain c where y: "n.lincomb_list c Xs = y" and c: "\<forall> i < length Xs. c i \<ge> 0"
      unfolding n.cone_list_def n.nonneg_lincomb_list_def by blast
    from y have "m.lincomb_list c ?Ys = x"
      unfolding x_def
      using vec_first_lincomb_list Xs X `n = m + 1` by auto
    hence "x \<in> m.cone_list ?Ys" using c
      unfolding m.cone_list_def m.nonneg_lincomb_list_def by auto
  } moreover {
    assume "x \<in> m.cone_list ?Ys"
    then obtain c where x: "m.lincomb_list c ?Ys = x" and c: "\<forall> i < length Xs. c i \<ge> 0"
      unfolding m.cone_list_def m.nonneg_lincomb_list_def by auto

    have "vec_last (n.lincomb_list c Xs) 1 $ 0 = n.lincomb_list c Xs $ m"
      using `n = m + 1` n.lincomb_list_carrier X Xs vec_last_index[of _ m 1 0]
      by auto
    also have "\<dots> = 0"
      using n.lincomb_list_index[of m Xs c] Xs X `n = m + 1` Xm0 by simp
    also have "\<dots> = vec_last y 1 $ 0"
      using y y_dim `n = m + 1` vec_last_index[of y m 1 0] by auto
    finally have "vec_last (n.lincomb_list c Xs) 1 = vec_last y 1" by fastforce

    moreover have "vec_first (n.lincomb_list c Xs) m = x"
      using vec_first_lincomb_list[of Xs c] x X Xs `n = m + 1`
      unfolding x_def by simp

    ultimately have "n.lincomb_list c Xs = y" unfolding x_def
      using vec_first_last_append[of _ m 1] `n = m + 1` y_dim
        n.lincomb_list_carrier[of Xs c] Xs X
      by metis
    hence "y \<in> n.cone_list Xs"
      unfolding n.cone_list_def n.nonneg_lincomb_list_def using c by blast
  }
  moreover have "m.cone_list ?Ys = m.cone ?Y"
    using m.finite_cone_iff_cone_list[OF _ Ys] m.cone_iff_finite_cone[of ?Y]
      `finite X` by force
  ultimately show ?thesis unfolding x_def by blast
qed

end

context gram_schmidt
begin

lemma decomposition_theorem_polyhedra_1:
  assumes A: "A \<in> carrier_mat nr n"
    and b: "b \<in> carrier_vec nr"
    and P: "P = polyhedron A b"
  shows "\<exists> Q X. X \<subseteq> carrier_vec n \<and> finite X \<and>
    Q \<subseteq> carrier_vec n \<and> finite Q \<and>
    P = convex_hull Q + cone X \<and>
    (A \<in> \<int>\<^sub>m \<inter> Bounded_mat Bnd \<longrightarrow> b \<in> \<int>\<^sub>v \<inter> Bounded_vec Bnd \<longrightarrow>
      X \<subseteq> \<int>\<^sub>v \<inter> Bounded_vec (det_bound n (max 1 Bnd))
    \<and> Q \<subseteq> Bounded_vec (det_bound n (max 1 Bnd)))"
proof -
  interpret next_dim: gram_schmidt "n + 1" "TYPE ('a)".
  interpret gram_schmidt_m "n + 1" n "TYPE('a)".

  from P[unfolded polyhedron_def] have "P \<subseteq> carrier_vec n" by auto

  have mcb: "mat_of_col (-b) \<in> carrier_mat nr 1" using b by auto
  define M where "M = (A @\<^sub>c mat_of_col (-b)) @\<^sub>r (0\<^sub>m 1 n @\<^sub>c -1\<^sub>m 1)"
  have M_top: "A @\<^sub>c mat_of_col (- b) \<in> carrier_mat nr (n + 1)"
    by (rule carrier_append_cols[OF A mcb])
  have M_bottom: "(0\<^sub>m 1 n @\<^sub>c -1\<^sub>m 1) \<in> carrier_mat 1 (n + 1)"
    by (rule carrier_append_cols, auto)
  have M_dim: "M \<in> carrier_mat (nr + 1) (n + 1)"
    unfolding M_def
    by (rule carrier_append_rows[OF M_top M_bottom])

  {
    fix x :: "'a vec" fix t assume x: "x \<in> carrier_vec n"
    have "x @\<^sub>v vec_of_scal t \<in> next_dim.polyhedral_cone M =
          (A *\<^sub>v x - t \<cdot>\<^sub>v b \<le> 0\<^sub>v nr \<and> t \<ge> 0)"
    proof -
      let ?y = "x @\<^sub>v vec_of_scal t"
      have y: "?y \<in> carrier_vec (n + 1)" using x by(simp del: One_nat_def)
      have "?y \<in> next_dim.polyhedral_cone M =
            (M *\<^sub>v ?y \<le> 0\<^sub>v (nr + 1))"
        unfolding next_dim.polyhedral_cone_def using y M_dim by auto
      also have "0\<^sub>v (nr + 1) = 0\<^sub>v nr @\<^sub>v 0\<^sub>v 1" by auto
      also have "M *\<^sub>v ?y \<le> 0\<^sub>v nr @\<^sub>v 0\<^sub>v 1 =
                   ((A @\<^sub>c mat_of_col (-b)) *\<^sub>v ?y \<le> 0\<^sub>v nr \<and>
                   (0\<^sub>m 1 n @\<^sub>c -1\<^sub>m 1) *\<^sub>v ?y \<le> 0\<^sub>v 1)"
        unfolding M_def
        by (intro append_rows_le[OF M_top M_bottom _ y], auto)
      also have "(A @\<^sub>c mat_of_col(-b)) *\<^sub>v ?y =
                 A *\<^sub>v x + mat_of_col(-b) *\<^sub>v vec_of_scal t"
        by (rule mat_mult_append_cols[OF A _ x],
            auto simp add: b simp del: One_nat_def)
      also have "mat_of_col(-b) *\<^sub>v vec_of_scal t = t \<cdot>\<^sub>v (-b)"
        by(rule mult_mat_of_row_vec_of_scal)
      also have "A *\<^sub>v x + t \<cdot>\<^sub>v (-b) = A *\<^sub>v x - t \<cdot>\<^sub>v b" by auto
      also have "(0\<^sub>m 1 n @\<^sub>c - 1\<^sub>m 1) *\<^sub>v (x @\<^sub>v vec_of_scal t) =
                 0\<^sub>m 1 n *\<^sub>v x + - 1\<^sub>m 1 *\<^sub>v vec_of_scal t"
        by(rule mat_mult_append_cols, auto simp add: x simp del: One_nat_def)
      also have "\<dots> = - vec_of_scal t" using x by (auto simp del: One_nat_def)
      also have "(\<dots> \<le> 0\<^sub>v 1) = (t \<ge> 0)" unfolding less_eq_vec_def by auto
      finally show "(?y \<in> next_dim.polyhedral_cone M) =
                    (A *\<^sub>v x - t \<cdot>\<^sub>v b \<le> 0\<^sub>v nr \<and> t \<ge> 0)" by auto
    qed
  } note M_cone_car = this
  from next_dim.farkas_minkowsky_weyl_theorem_2[OF M_dim, of "max 1 Bnd"]
  obtain X where X: "next_dim.polyhedral_cone M = next_dim.cone X" and
    fin_X: "finite X" and X_carrier: "X \<subseteq> carrier_vec (n+1)"
    and Bnd: "M \<in> \<int>\<^sub>m \<inter> Bounded_mat (max 1 Bnd) \<Longrightarrow>
          X \<subseteq> \<int>\<^sub>v \<inter> Bounded_vec (det_bound n (max 1 Bnd))"
    by auto
  let ?f = "\<lambda> x. if x $ n = 0 then 1 else 1 / (x $ n)"
  define Y where "Y = {?f x \<cdot>\<^sub>v x | x. x \<in> X}"
  have "finite Y" unfolding Y_def using fin_X by auto
  have Y_carrier: "Y \<subseteq> carrier_vec (n+1)" unfolding Y_def using X_carrier by auto
  have "?f ` X \<subseteq> {y. y > 0}"
  proof
    fix y
    assume "y \<in> ?f ` X"
    then obtain x where x: "x \<in> X" and y: "y = ?f x" by auto
    show "y \<in> {y. y > 0}"
    proof cases
      assume "x $ n = 0"
      thus "y \<in> {y. y > 0}" using y by auto
    next
      assume P: "x $ n \<noteq> 0"
      have "x = vec_first x n @\<^sub>v vec_last x 1"
        using x X_carrier vec_first_last_append by auto
      also have "vec_last x 1 = vec_of_scal (vec_last x 1 $ 0)" by auto
      also have "vec_last x 1 $ 0 = x $ n"
        using x X_carrier unfolding vec_last_def by auto
      finally have "x = vec_first x n @\<^sub>v vec_of_scal (x $ n)" by auto
      moreover have "x \<in> next_dim.polyhedral_cone M"
        using x X X_carrier next_dim.set_in_cone by auto
      ultimately have "x $ n \<ge> 0" using M_cone_car vec_first_carrier by metis
      hence "x $ n > 0" using P by auto
      thus "y \<in> {y. y > 0}" using y by auto
    qed
  qed
  hence Y: "next_dim.cone Y = next_dim.polyhedral_cone M" unfolding Y_def
    using next_dim.cone_smult_basis[OF X_carrier] X by auto
  define Y0 where "Y0 = {v \<in> Y. v $ n = 0}"
  define Y1 where "Y1 = Y - Y0"
  have Y0_carrier: "Y0 \<subseteq> carrier_vec (n + 1)" and Y1_carrier: "Y1 \<subseteq> carrier_vec (n + 1)"
    unfolding Y0_def Y1_def using Y_carrier by auto
  have "finite Y0" and "finite Y1"
    unfolding Y0_def Y1_def using `finite Y` by auto

  have Y1: "\<And> y. y \<in> Y1 \<Longrightarrow> y $ n = 1"
  proof -
    fix y assume y: "y \<in> Y1"
    hence "y \<in> Y" unfolding Y1_def by auto
    then obtain x where "x \<in> X" and x: "y = ?f x \<cdot>\<^sub>v x" unfolding Y_def by auto
    then have "x $ n \<noteq> 0" using x y Y1_def Y0_def by auto
    then have "y = 1 / (x $ n) \<cdot>\<^sub>v x" using x by auto
    then have "y $ n = 1 / (x $ n) * x $ n" using X_carrier `x \<in> X` by auto
    thus "y $ n = 1" using `x $ n \<noteq> 0` by auto
  qed

  let ?Z0 = "{vec_first y n | y. y \<in> Y0}"
  let ?Z1 = "{vec_first y n | y. y \<in> Y1}"
  show ?thesis
  proof (intro exI conjI impI)
    show "?Z0 \<subseteq> carrier_vec n" by auto
    show "?Z1 \<subseteq> carrier_vec n" by auto
    show "finite ?Z0" using `finite Y0` by auto
    show "finite ?Z1" using `finite Y1` by auto
    show "P = convex_hull ?Z1 + cone ?Z0"
    proof -
      {
        fix x
        assume "x \<in> P"
        hence xn: "x \<in> carrier_vec n" and "A *\<^sub>v x \<le> b"
          using P unfolding polyhedron_def by auto
        hence "A *\<^sub>v x - 1 \<cdot>\<^sub>v b \<le> 0\<^sub>v nr"
          using vec_le_iff_diff_le_0 A b carrier_vecD mult_mat_vec_carrier one_smult_vec
          by metis
        hence "x @\<^sub>v vec_of_scal 1 \<in> next_dim.polyhedral_cone M"
          using M_cone_car[OF xn] by auto
        hence "x @\<^sub>v vec_of_scal 1 \<in> next_dim.cone Y" using Y by auto
        hence "x @\<^sub>v vec_of_scal 1 \<in> next_dim.finite_cone Y"
          using next_dim.cone_iff_finite_cone[OF Y_carrier `finite Y`] by auto
        then obtain c where c: "next_dim.nonneg_lincomb c Y (x @\<^sub>v vec_of_scal 1)"
          unfolding next_dim.finite_cone_def using `finite Y` by auto
        let ?y = "next_dim.lincomb c Y1"
        let ?z = "next_dim.lincomb c Y0"
        have y_dim: "?y \<in> carrier_vec (n + 1)" and z_dim: "?z \<in> carrier_vec (n + 1)"
          unfolding next_dim.nonneg_lincomb_def
          using Y0_carrier Y1_carrier next_dim.lincomb_closed by simp_all
        hence yz_dim: "?y + ?z \<in> carrier_vec (n + 1)" by auto
        have "x @\<^sub>v vec_of_scal 1 = next_dim.lincomb c Y"
          using c unfolding next_dim.nonneg_lincomb_def by auto
        also have "Y = Y1 \<union> Y0" unfolding Y1_def using Y0_def by blast
        also have "next_dim.lincomb c (Y1 \<union> Y0) = ?y + ?z"
          using next_dim.lincomb_union2[of Y1 Y0]
            `finite Y0` `finite Y` Y0_carrier Y_carrier
          unfolding Y1_def by fastforce
        also have "?y + ?z = vec_first (?y + ?z) n @\<^sub>v vec_last (?y + ?z) 1"
          using vec_first_last_append[of "?y + ?z" n 1] add_carrier_vec yz_dim
          by simp
        also have "vec_last (?y + ?z) 1 = vec_of_scal ((?y + ?z) $ n)"
          using vec_of_scal_dim_1 vec_last_index[OF yz_dim, of 0] by auto
        finally have "x @\<^sub>v vec_of_scal 1 =
                     vec_first (?y + ?z) n @\<^sub>v vec_of_scal ((?y + ?z) $ n)" by auto
        hence "x = vec_first (?y + ?z) n" and
          yz_last: "vec_of_scal 1 = vec_of_scal ((?y + ?z) $ n)"
          using append_vec_eq yz_dim xn by auto
        hence xyz: "x = vec_first ?y n + vec_first ?z n"
          using vec_first_add[of n ?y ?z] y_dim z_dim by simp

        have "1 = ((?y + ?z) $ n)" using yz_last index_vec_of_scal
          by (metis (no_types, lifting))
        hence "1 = ?y $ n + ?z $ n" using y_dim z_dim by auto
        moreover have zn0: "?z $ n = 0"
          using next_dim.lincomb_index[OF _ Y0_carrier] Y0_def by auto
        ultimately have yn1: "1 = ?y $ n" by auto
        have "next_dim.nonneg_lincomb c Y1 ?y"
          using c Y1_def
          unfolding next_dim.nonneg_lincomb_def by auto
        hence "?y \<in> next_dim.cone Y1"
          using next_dim.cone_iff_finite_cone[OF Y1_carrier] `finite Y1`
          unfolding next_dim.finite_cone_def by auto
        hence y: "vec_first ?y n \<in> convex_hull ?Z1"
          using convex_hull_next_dim[OF _ Y1_carrier `finite Y1` _ y_dim] Y1 yn1
          by simp

        have "next_dim.nonneg_lincomb c Y0 ?z" using c Y0_def
          unfolding next_dim.nonneg_lincomb_def by blast
        hence "?z \<in> next_dim.cone Y0"
          using `finite Y0` next_dim.cone_iff_finite_cone[OF Y0_carrier `finite Y0`]
          unfolding next_dim.finite_cone_def
          by fastforce
        hence z: "vec_first ?z n \<in> cone ?Z0"
          using cone_next_dim[OF _ Y0_carrier `finite Y0` _ _ zn0] Y0_def
            next_dim.lincomb_closed[OF Y0_carrier] by blast

        from xyz y z have "x \<in> convex_hull ?Z1 + cone ?Z0" by blast
      } moreover {
        fix x
        assume "x \<in> convex_hull ?Z1 + cone ?Z0"
        then obtain y z where "x = y + z" and y: "y \<in> convex_hull ?Z1"
          and z: "z \<in> cone ?Z0" by (auto elim: set_plus_elim)

        have yn: "y \<in> carrier_vec n"
          using y convex_hull_carrier[OF `?Z1 \<subseteq> carrier_vec n`] by blast
        hence "y @\<^sub>v vec_of_scal 1 \<in> carrier_vec (n + 1)"
          using vec_of_scal_dim(2) by fast
        moreover have "vec_first (y @\<^sub>v vec_of_scal 1) n \<in> convex_hull ?Z1"
          using vec_first_append[OF yn] y by auto
        moreover have "(y @\<^sub>v vec_of_scal 1) $ n = 1" using yn by simp
        ultimately have "y @\<^sub>v vec_of_scal 1 \<in> next_dim.cone Y1"
          using convex_hull_next_dim[OF _ Y1_carrier `finite Y1`] Y1 by blast
        hence y_cone: "y @\<^sub>v vec_of_scal 1 \<in> next_dim.cone Y"
          using next_dim.cone_mono[of Y1 Y] Y1_def by blast

        have zn: "z \<in> carrier_vec n" using z cone_carrier[of ?Z0] by fastforce
        hence "z @\<^sub>v vec_of_scal 0 \<in> carrier_vec (n + 1)"
          using vec_of_scal_dim(2) by fast
        moreover have "vec_first (z @\<^sub>v vec_of_scal 0) n \<in> cone ?Z0"
          using vec_first_append[OF zn] z by auto
        moreover have "(z @\<^sub>v vec_of_scal 0) $ n = 0" using zn by simp
        ultimately have "z @\<^sub>v vec_of_scal 0 \<in> next_dim.cone Y0"
          using cone_next_dim[OF _ Y0_carrier `finite Y0`] Y0_def by blast
        hence z_cone: "z @\<^sub>v vec_of_scal 0 \<in> next_dim.cone Y"
          using Y0_def next_dim.cone_mono[of Y0 Y] by blast

        have xn: "x \<in> carrier_vec n" using `x = y + z` yn zn by blast
        have "x @\<^sub>v vec_of_scal 1 = (y @\<^sub>v vec_of_scal 1) + (z @\<^sub>v vec_of_scal 0)"
          using `x = y + z` append_vec_add[OF yn zn]
          unfolding vec_of_scal_def by auto
        hence "x @\<^sub>v vec_of_scal 1 \<in> next_dim.cone Y"
          using next_dim.cone_elem_sum[OF Y_carrier y_cone z_cone] by simp
        hence "A *\<^sub>v x - b \<le> 0\<^sub>v nr" using M_cone_car[OF xn] Y by simp
        hence "A *\<^sub>v x \<le> b" using vec_le_iff_diff_le_0[of "A *\<^sub>v x" b]
            dim_mult_mat_vec[of A x] A by simp
        hence "x \<in> P" using P xn unfolding polyhedron_def by blast
      }
      ultimately show "P = convex_hull ?Z1 + cone ?Z0" by blast
    qed

    let ?Bnd = "det_bound n (max 1 Bnd)"
    assume "A \<in> \<int>\<^sub>m \<inter> Bounded_mat Bnd"
      "b \<in> \<int>\<^sub>v \<inter> Bounded_vec Bnd"
    hence *: "A \<in> \<int>\<^sub>m" "A \<in> Bounded_mat Bnd" "b \<in> \<int>\<^sub>v" "b \<in> Bounded_vec Bnd" by auto
    have "elements_mat M \<subseteq> elements_mat A \<union> vec_set (-b) \<union> {0,-1}"
      unfolding M_def
      unfolding elements_mat_append_rows[OF M_top M_bottom]
      unfolding elements_mat_append_cols[OF A mcb]
      by (subst elements_mat_append_cols, auto)
    also have "\<dots> \<subseteq> \<int> \<inter> ({x. abs x \<le> Bnd} \<union> {0,-1})"
      using *[unfolded Bounded_mat_elements_mat Ints_mat_elements_mat
          Bounded_vec_vec_set Ints_vec_vec_set] by auto
    also have "\<dots> \<subseteq> \<int> \<inter> ({x. abs x \<le> max 1 Bnd})" by auto
    finally have "M \<in> \<int>\<^sub>m" "M \<in> Bounded_mat (max 1 Bnd)"
      unfolding Bounded_mat_elements_mat Ints_mat_elements_mat by auto
    hence "M \<in> \<int>\<^sub>m \<inter> Bounded_mat (max 1 Bnd)" by blast
    from Bnd[OF this]
    have XBnd: "X \<subseteq> \<int>\<^sub>v \<inter> Bounded_vec ?Bnd" .
    {
      fix y
      assume y: "y \<in> Y"
      then obtain x where y: "y = ?f x \<cdot>\<^sub>v x" and xX: "x \<in> X" unfolding Y_def by auto
      with \<open>X \<subseteq> carrier_vec (n+1)\<close> have x: "x \<in> carrier_vec (n+1)" by auto
      from XBnd xX have xI: "x \<in> \<int>\<^sub>v" and xB: "x \<in> Bounded_vec ?Bnd" by auto
      {
        assume "y $ n = 0"
        hence "y = x" unfolding y using x by auto
        hence "y \<in> \<int>\<^sub>v \<inter> Bounded_vec ?Bnd" using xI xB by auto
      } note y0 = this
      {
        assume "y $ n \<noteq> 0"
        hence x0: "x $ n \<noteq> 0" using x unfolding y by auto
        from x xI have "x $ n \<in> \<int>" unfolding Ints_vec_def by auto
        with x0 have "abs (x $ n) \<ge> 1" by (meson Ints_nonzero_abs_ge1)
        hence abs: "abs (1 / (x $ n)) \<le> 1" by simp
        {
          fix a
          have "abs ((1 / (x $ n)) * a) = abs (1 / (x $ n)) * abs a"
            by simp
          also have "\<dots> \<le> 1 * abs a"
            by (rule mult_right_mono[OF abs], auto)
          finally have "abs ((1 / (x $ n)) * a) \<le> abs a" by auto
        } note abs = this
        from x0 have y: "y = (1 / (x $ n)) \<cdot>\<^sub>v x" unfolding y by auto
        have vy: "vec_set y = (\<lambda> a. (1 / (x $ n)) * a) ` vec_set x"
          unfolding y by (auto simp: vec_set_def)
        have "y \<in> Bounded_vec ?Bnd" using xB abs
          unfolding Bounded_vec_vec_set vy
          by (smt imageE max.absorb2 max.bounded_iff)
      } note yn0 = this
      note y0 yn0
    } note BndY = this
    from \<open>Y \<subseteq> carrier_vec (n+1)\<close>
    have setvY: "y \<in> Y \<Longrightarrow> set\<^sub>v (vec_first y n) \<subseteq> set\<^sub>v y" for y
      unfolding vec_first_def vec_set_def by auto
    from BndY(1) setvY
    show "?Z0 \<subseteq> \<int>\<^sub>v \<inter> Bounded_vec (det_bound n (max 1 Bnd))"
      by (force simp: Bounded_vec_vec_set Ints_vec_vec_set Y0_def)
    from BndY(2) setvY
    show "?Z1 \<subseteq> Bounded_vec (det_bound n (max 1 Bnd))"
      by (force simp: Bounded_vec_vec_set Ints_vec_vec_set Y0_def Y1_def)
  qed
qed

lemma decomposition_theorem_polyhedra_2:
  assumes Q: "Q \<subseteq> carrier_vec n" and fin_Q: "finite Q"
    and X: "X \<subseteq> carrier_vec n" and fin_X: "finite X"
    and P: "P = convex_hull Q + cone X"
  shows "\<exists>A b nr. A \<in> carrier_mat nr n \<and> b \<in> carrier_vec nr \<and> P = polyhedron A b"
proof -
  interpret next_dim: gram_schmidt "n + 1" "TYPE ('a)".
  interpret gram_schmidt_m "n + 1" n "TYPE('a)".

  from fin_Q obtain Qs where Qs: "Q = set Qs" using finite_list by auto
  from fin_X obtain Xs where Xs: "X = set Xs" using finite_list by auto
  define Y where "Y = {x @\<^sub>v vec_of_scal 1 | x. x \<in> Q}"
  define Z where "Z = {x @\<^sub>v vec_of_scal 0 | x. x \<in> X}"
  have fin_Y: "finite Y" unfolding Y_def using fin_Q by simp
  have fin_Z: "finite Z" unfolding Z_def using fin_X by simp
  have Y_dim: "Y \<subseteq> carrier_vec (n + 1)"
    unfolding Y_def using Q append_carrier_vec[OF _ vec_of_scal_dim(2)[of 1]]
    by blast
  have Z_dim: "Z \<subseteq> carrier_vec (n + 1)"
    unfolding Z_def using X append_carrier_vec[OF _ vec_of_scal_dim(2)[of 0]]
    by blast
  have Y_car: "Q = {vec_first x n | x. x \<in> Y}"
  proof (intro equalityI subsetI)
    fix x assume x: "x \<in> Q"
    hence "x @\<^sub>v vec_of_scal 1 \<in> Y" unfolding Y_def by blast
    thus "x \<in> {vec_first x n | x. x \<in> Y}"
      using Q vec_first_append[of x n "vec_of_scal 1"] x by force
  next
    fix x assume "x \<in> {vec_first x n | x. x \<in> Y}"
    then obtain y where "y \<in> Q" and "x = vec_first (y @\<^sub>v vec_of_scal 1) n"
      unfolding Y_def by blast
    thus "x \<in> Q" using Q vec_first_append[of y] by auto
  qed
  have Z_car: "X = {vec_first x n | x. x \<in> Z}"
  proof (intro equalityI subsetI)
    fix x assume x: "x \<in> X"
    hence "x @\<^sub>v vec_of_scal 0 \<in> Z" unfolding Z_def by blast
    thus "x \<in> {vec_first x n | x. x \<in> Z}"
      using X vec_first_append[of x n "vec_of_scal 0"] x by force
  next
    fix x assume "x \<in> {vec_first x n | x. x \<in> Z}"
    then obtain y where "y \<in> X" and "x = vec_first (y @\<^sub>v vec_of_scal 0) n"
      unfolding Z_def by blast
    thus "x \<in> X" using X vec_first_append[of y] by auto
  qed
  have Y_last: "\<forall> x \<in> Y. x $ n = 1" unfolding Y_def using Q by auto
  have Z_last: "\<forall> x \<in> Z. x $ n = 0" unfolding Z_def using X by auto

  have "finite (Y \<union> Z)" using fin_Y fin_Z by blast
  moreover have "Y \<union> Z \<subseteq> carrier_vec (n + 1)" using Y_dim Z_dim by blast
  ultimately obtain B nr
    where B: "next_dim.cone (Y \<union> Z) = next_dim.polyhedral_cone B"
      and B_carrier: "B \<in> carrier_mat nr (n + 1)"
    using next_dim.farkas_minkowsky_weyl_theorem[of "next_dim.cone (Y \<union> Z)"]
    by blast
  define A where "A = mat_col_first B n"
  define b where "b = col B n"
  have B_blocks: "B = A @\<^sub>c mat_of_col b"
    unfolding A_def b_def
    using mat_col_first_last_append[of B n 1] B_carrier
      mat_of_col_dim_col_1[of "mat_col_last B 1"] by auto
  have A_carrier: "A \<in> carrier_mat nr n" unfolding A_def using B_carrier by force
  have b_carrier: "b \<in> carrier_vec nr" unfolding b_def using B_carrier by force

  {
    fix x assume "x \<in> P"
    then obtain y z where x: "x = y + z" and y: "y \<in> convex_hull Q" and z: "z \<in> cone X"
      using P by (auto elim: set_plus_elim)

    have yn: "y \<in> carrier_vec n" using y convex_hull_carrier[OF Q] by blast
    moreover have zn: "z \<in> carrier_vec n" using z cone_carrier[OF X] by blast
    ultimately have xn: "x \<in> carrier_vec n" using x by blast

    have yn1: "y @\<^sub>v vec_of_scal 1 \<in> carrier_vec (n + 1)"
      using append_carrier_vec[OF yn] vec_of_scal_dim by fast
    have y_last: "(y @\<^sub>v vec_of_scal 1) $ n = 1" using yn by force
    have "vec_first (y @\<^sub>v vec_of_scal 1) n = y"
      using vec_first_append[OF yn] by simp
    hence "y @\<^sub>v vec_of_scal 1 \<in> next_dim.cone Y"
      using convex_hull_next_dim[OF _ Y_dim fin_Y Y_last yn1 y_last] Y_car y by argo
    hence y_cone: "y @\<^sub>v vec_of_scal 1 \<in> next_dim.cone (Y \<union> Z)"
      using next_dim.cone_mono[of Y "Y \<union> Z"] by blast

    have zn1: "z @\<^sub>v vec_of_scal 0 \<in> carrier_vec (n + 1)"
      using append_carrier_vec[OF zn] vec_of_scal_dim by fast
    have z_last: "(z @\<^sub>v vec_of_scal 0) $ n = 0" using zn by force
    have "vec_first (z @\<^sub>v vec_of_scal 0) n = z"
      using vec_first_append[OF zn] by simp
    hence "z @\<^sub>v vec_of_scal 0 \<in> next_dim.cone Z"
      using cone_next_dim[OF _ Z_dim fin_Z Z_last zn1 z_last] Z_car z by argo
    hence z_cone: "z @\<^sub>v vec_of_scal 0 \<in> next_dim.cone (Y \<union> Z)"
      using next_dim.cone_mono[of Z "Y \<union> Z"] by blast

    from `x = y + z`
    have "x @\<^sub>v vec_of_scal 1 = (y @\<^sub>v vec_of_scal 1) + (z @\<^sub>v vec_of_scal 0)"
      using append_vec_add[OF yn zn] vec_of_scal_dim_1
      unfolding vec_of_scal_def by auto
    hence "x @\<^sub>v vec_of_scal 1 \<in> next_dim.cone (Y \<union> Z) \<and> x \<in> carrier_vec n"
      using next_dim.cone_elem_sum[OF _ y_cone z_cone] Y_dim Z_dim xn by auto
  } moreover {
    fix x assume "x @\<^sub>v vec_of_scal 1 \<in> next_dim.cone (Y \<union> Z)"
    then obtain c where x: "next_dim.lincomb c (Y \<union> Z) = x @\<^sub>v vec_of_scal 1"
      and c: "c ` (Y \<union> Z) \<subseteq> {t. t \<ge> 0}"
      using next_dim.cone_iff_finite_cone Y_dim Z_dim fin_Y fin_Z
      unfolding next_dim.finite_cone_def next_dim.nonneg_lincomb_def by auto

    let ?y = "next_dim.lincomb c Y"
    let ?z = "next_dim.lincomb c Z"
    have xyz: "x @\<^sub>v vec_of_scal 1 = ?y + ?z"
      using x next_dim.lincomb_union[OF Y_dim Z_dim _ fin_Y fin_Z] Y_last Z_last
      by fastforce

    have y_dim: "?y \<in> carrier_vec (n + 1)" using next_dim.lincomb_closed[OF Y_dim]
      by blast
    have z_dim: "?z \<in> carrier_vec (n + 1)" using next_dim.lincomb_closed[OF Z_dim]
      by blast
    have "x @\<^sub>v vec_of_scal 1 \<in> carrier_vec (n + 1)"
      using xyz add_carrier_vec[OF y_dim z_dim] by argo
    hence x_dim: "x \<in> carrier_vec n"
      using carrier_dim_vec[of x n] carrier_dim_vec[of _ "n + 1"]
      by force

    have z_last: "?z $ n = 0" using Z_last next_dim.lincomb_index[OF _ Z_dim, of n]
      by force
    have "?y $ n + ?z $ n = (x @\<^sub>v vec_of_scal 1) $ n"
      using xyz index_add_vec(1) z_dim by simp
    also have "\<dots> = 1" using x_dim by auto
    finally have y_last: "?y $ n = 1" using z_last by algebra

    have "?y \<in> next_dim.cone Y"
      using next_dim.cone_iff_finite_cone[OF Y_dim] fin_Y c
      unfolding next_dim.finite_cone_def next_dim.nonneg_lincomb_def by auto
    hence y_cone: "vec_first ?y n \<in> convex_hull Q"
      using convex_hull_next_dim[OF _ Y_dim fin_Y Y_last y_dim y_last] Y_car
      by blast

    have "?z \<in> next_dim.cone Z"
      using next_dim.cone_iff_finite_cone[OF Z_dim] fin_Z c
      unfolding next_dim.finite_cone_def next_dim.nonneg_lincomb_def by auto
    hence z_cone: "vec_first ?z n \<in> cone X"
      using cone_next_dim[OF _ Z_dim fin_Z Z_last z_dim z_last] Z_car
      by blast

    have "x = vec_first (x @\<^sub>v vec_of_scal 1) n" using vec_first_append[OF x_dim] by simp
    also have "\<dots> = vec_first ?y n + vec_first ?z n"
      using xyz vec_first_add[of n ?y ?z] y_dim z_dim carrier_dim_vec by auto
    finally have "x \<in> P"
      using y_cone z_cone P by blast
  } moreover {
    fix x :: "'a vec"
    assume xn: "x \<in> carrier_vec n"
    hence "(x @\<^sub>v vec_of_scal 1 \<in> next_dim.polyhedral_cone B) =
          (B *\<^sub>v (x @\<^sub>v vec_of_scal 1) \<le> 0\<^sub>v nr)"
      unfolding next_dim.polyhedral_cone_def using B_carrier
      using append_carrier_vec[OF _ vec_of_scal_dim(2)[of 1]] by auto
    also have "\<dots> = ((A @\<^sub>c mat_of_col b) *\<^sub>v (x @\<^sub>v vec_of_scal 1) \<le> 0\<^sub>v nr)"
      using B_blocks by blast
    also have "(A @\<^sub>c mat_of_col b) *\<^sub>v (x @\<^sub>v vec_of_scal 1) =
               A *\<^sub>v x + mat_of_col b *\<^sub>v vec_of_scal 1"
      by (rule mat_mult_append_cols, insert A_carrier b_carrier xn, auto simp del: One_nat_def)
    also have "mat_of_col b *\<^sub>v vec_of_scal 1 = b"
      using mult_mat_of_row_vec_of_scal[of b 1] by simp
    also have "A *\<^sub>v x + b = A *\<^sub>v x - -b" by auto
    finally have "(x @\<^sub>v vec_of_scal 1 \<in> next_dim.polyhedral_cone B) = (A *\<^sub>v x \<le> -b)"
      using vec_le_iff_diff_le_0[of "A *\<^sub>v x" "-b"] A_carrier by simp
  }
  ultimately have "P = polyhedron A (-b)"
    unfolding polyhedron_def using B by blast
  moreover have "-b \<in> carrier_vec nr" using b_carrier by simp
  ultimately show ?thesis using A_carrier by blast
qed

lemma decomposition_theorem_polyhedra:
  "(\<exists> A b nr. A \<in> carrier_mat nr n \<and> b \<in> carrier_vec nr \<and> P = polyhedron A b) \<longleftrightarrow>
   (\<exists> Q X. Q \<union> X \<subseteq> carrier_vec n \<and> finite (Q \<union> X) \<and> P = convex_hull Q + cone X)" (is "?l = ?r")
proof
  assume ?l
  then obtain A b nr where A: "A \<in> carrier_mat nr n"
    and b: "b \<in> carrier_vec nr" and P: "P = polyhedron A b" by auto
  from decomposition_theorem_polyhedra_1[OF this] obtain Q X
    where *: "X \<subseteq> carrier_vec n" "finite X" "Q \<subseteq> carrier_vec n" "finite Q" "P = convex_hull Q + cone X"
    by meson
  show ?r
    by (rule exI[of _ Q], rule exI[of _ X], insert *, auto simp: polytope_def)
next
  assume ?r
  then obtain Q X where QX_carrier: "Q \<union> X \<subseteq> carrier_vec n"
    and QX_fin: "finite (Q \<union> X)"
    and P: "P = convex_hull Q + cone X" by blast
  from QX_carrier have Q: "Q \<subseteq> carrier_vec n" and X: "X \<subseteq> carrier_vec n" by simp_all
  from QX_fin have fin_Q: "finite Q" and fin_X: "finite X" by simp_all
  show ?l using decomposition_theorem_polyhedra_2[OF Q fin_Q X fin_X P] by blast
qed

lemma polytope_equiv_bounded_polyhedron:
  "polytope P \<longleftrightarrow>
  (\<exists>A b nr bnd. A \<in> carrier_mat nr n \<and> b \<in> carrier_vec nr \<and> P = polyhedron A b \<and> P \<subseteq> Bounded_vec bnd)"
proof
  assume polyP: "polytope P"
  from this obtain Q where Qcarr: "Q \<subseteq> carrier_vec n" and finQ: "finite Q"
    and PconvhQ: "P = convex_hull Q" unfolding polytope_def by auto
  let ?X = "{}"
  have "convex_hull Q + {0\<^sub>v n} = convex_hull Q" using Qcarr add_0_right_vecset[of "convex_hull Q"]
    by (simp add: convex_hull_carrier)
  hence "P = convex_hull Q + cone ?X" using PconvhQ by simp
  hence "Q \<union> ?X \<subseteq> carrier_vec n \<and> finite (Q \<union> ?X) \<and> P = convex_hull Q + cone ?X"
    using Qcarr finQ PconvhQ by simp
  hence "\<exists> A b nr. A \<in> carrier_mat nr n \<and> b \<in> carrier_vec nr \<and> P = polyhedron A b"
    using decomposition_theorem_polyhedra by blast
  hence Ppolyh: "\<exists>A b nr. A \<in> carrier_mat nr n \<and> b \<in> carrier_vec nr \<and> P = polyhedron A b" by blast
  from finite_Bounded_vec_Max[OF Qcarr finQ] obtain bnd where "Q \<subseteq> Bounded_vec bnd" by auto
  hence Pbnd: "P \<subseteq> Bounded_vec bnd" using convex_hull_bound PconvhQ Qcarr by auto
  from Ppolyh Pbnd show "\<exists>A b nr bnd. A \<in> carrier_mat nr n \<and> b \<in> carrier_vec nr
    \<and> P = polyhedron A b \<and> P \<subseteq> Bounded_vec bnd" by auto
next
  assume "\<exists>A b nr bnd. A \<in> carrier_mat nr n \<and> b \<in> carrier_vec nr \<and> P = polyhedron A b
    \<and> P \<subseteq> Bounded_vec bnd"
  from this obtain A b nr bnd where Adim: "A \<in> carrier_mat nr n" and bdim: "b \<in> carrier_vec nr"
    and Ppolyh: "P = polyhedron A b" and Pbnd: "P \<subseteq> Bounded_vec bnd" by auto
  have "\<exists> A b nr. A \<in> carrier_mat nr n \<and> b \<in> carrier_vec nr \<and> P = polyhedron A b"
    using Adim bdim Ppolyh by blast
  hence "\<exists> Q X. Q \<union> X \<subseteq> carrier_vec n \<and> finite (Q \<union> X) \<and> P = convex_hull Q + cone X"
    using decomposition_theorem_polyhedra by simp
  from this obtain Q X where QXcarr: "Q \<union> X \<subseteq> carrier_vec n"
    and finQX: "finite (Q \<union> X)" and Psum: "P = convex_hull Q + cone X" by auto
  from QXcarr have Qcarr: "convex_hull Q \<subseteq> carrier_vec n" by (simp add: convex_hull_carrier)
  from QXcarr have Xcarr: "cone X \<subseteq> carrier_vec n" by (simp add: gram_schmidt.cone_carrier)
  from Pbnd have Pcarr: "P \<subseteq> carrier_vec n" using Ppolyh unfolding polyhedron_def by simp
  have "P = convex_hull Q"
  proof(cases "Q = {}")
    case True
    then show "P = convex_hull Q" unfolding Psum by (auto simp: set_plus_def)
  next
    case False
    hence convnotempty: "convex_hull Q \<noteq> {}" using QXcarr by simp
    have Pbndex: "\<exists>bnd. P \<subseteq> Bounded_vec bnd" using Pbnd
      using QXcarr by auto
    from False have "(\<exists> bndc. cone X \<subseteq> Bounded_vec bndc)"
      using bounded_vecset_sum[OF Qcarr Xcarr Psum Pbndex] False convnotempty by blast
    hence "cone X = {0\<^sub>v n}" using bounded_cone_is_zero QXcarr by auto
    thus ?thesis unfolding Psum using Qcarr by (auto simp: add_0_right_vecset)
  qed
  thus "polytope P" using finQX QXcarr unfolding polytope_def by auto
qed
end

end


(* Authors:  René Neumann and Florian Haftmann, TU Muenchen *)

header {* Functional Binomial Queues *}

theory Binomial_Queue
imports PQ
begin

subsection {* Type definition and projections *}

datatype ('a, 'b) bintree = Node "'a" "'b" "('a, 'b) bintree list"

primrec priority :: "('a, 'b) bintree \<Rightarrow> 'a" where
  "priority (Node a _ _) = a"

primrec val :: "('a, 'b) bintree \<Rightarrow> 'b" where
  "val (Node _ v _) = v"

primrec children :: "('a, 'b) bintree \<Rightarrow> ('a, 'b) bintree list" where
  "children (Node _ _ ts) = ts"

type_synonym ('a, 'b) binqueue = "('a, 'b) bintree option list"

lemma binqueue_induct [case_names Empty None Some, induct type: binqueue]:
  assumes "P []"
  and "\<And>xs. P xs \<Longrightarrow> P (None # xs)"
  and "\<And>x xs. P xs \<Longrightarrow> P (Some x # xs)"
  shows "P xs"
using assms proof (induct xs)
  case (Cons x xs) thus ?case by (cases x) simp_all
qed simp

text {*
  \noindent Terminology:

  \begin{itemize}

    \item values @{text "v, w"} or @{text "v1, v2"}

    \item priorities @{text "a, b"} or @{text "a1, a2"}

    \item bintrees @{text "t, r"} or @{text "t1, t2"}

    \item bintree lists @{text "ts, rs"} or @{text "ts1, ts2"}

    \item binqueue element @{text "x, y"} or @{text "x1, x2"}

    \item binqueues = binqueue element lists @{text "xs, ys"} or @{text "xs1, xs2"}

    \item abstract priority queues @{text "q, p"} or @{text "q1, q2"}

  \end{itemize}
*}

subsection {* Binomial queue properties *}

subsubsection {* Binomial tree property *}

inductive is_bintree_list :: "nat \<Rightarrow> ('a, 'b) bintree list \<Rightarrow> bool" where
  is_bintree_list_Nil [simp]: "is_bintree_list 0 []"
| is_bintree_list_Cons: "is_bintree_list l ts \<Longrightarrow> is_bintree_list l (children t)
    \<Longrightarrow> is_bintree_list (Suc l) (t # ts)"

abbreviation (input) "is_bintree k t \<equiv> is_bintree_list k (children t)"

lemma is_bintree_list_triv [simp]:
  "is_bintree_list 0 ts \<longleftrightarrow> ts = []"
  "is_bintree_list l [] \<longleftrightarrow> l = 0"
  by (auto intro: is_bintree_list.intros elim: is_bintree_list.cases)

lemma is_bintree_list_simp [simp]:
  "is_bintree_list (Suc l) (t # ts) \<longleftrightarrow>
    is_bintree_list l (children t) \<and> is_bintree_list l ts"
  by (auto intro: is_bintree_list.intros elim: is_bintree_list.cases)

lemma is_bintree_list_length [simp]:
  "is_bintree_list l ts \<Longrightarrow> length ts = l"
  by (erule is_bintree_list.induct) simp_all

lemma is_bintree_list_children_last:
  assumes "is_bintree_list l ts" and "ts \<noteq> []"
  shows "children (last ts) = []"
  using assms by induct auto

lemma is_bintree_children_length_desc:
  assumes "is_bintree_list l ts"
  shows "map (length \<circ> children) ts = rev [0..<l]"
  using assms by (induct ts) simp_all

subsubsection {* Heap property *}

inductive is_heap_list :: "'a::linorder \<Rightarrow> ('a, 'b) bintree list \<Rightarrow> bool" where
  is_heap_list_Nil: "is_heap_list h []"
| is_heap_list_Cons: "is_heap_list h ts \<Longrightarrow> is_heap_list (priority t) (children t)
    \<Longrightarrow> (priority t) \<ge> h \<Longrightarrow> is_heap_list h (t # ts)"

abbreviation (input) "is_heap t \<equiv> is_heap_list (priority t) (children t)"

lemma is_heap_list_simps [simp]:
  "is_heap_list h [] \<longleftrightarrow> True"
  "is_heap_list h (t # ts) \<longleftrightarrow>
    is_heap_list h ts \<and> is_heap_list (priority t) (children t) \<and> priority t \<ge> h"
  by (auto intro: is_heap_list.intros elim: is_heap_list.cases)

lemma is_heap_list_append_dest [dest]:
  "is_heap_list l (ts@rs) \<Longrightarrow> is_heap_list l ts"
  "is_heap_list l (ts@rs) \<Longrightarrow> is_heap_list l rs"
  by (induct ts) (auto intro: is_heap_list.intros elim: is_heap_list.cases)

lemma is_heap_list_rev:
  "is_heap_list l ts \<Longrightarrow> is_heap_list l (rev ts)"
  by (induct ts rule: rev_induct) auto

lemma is_heap_children_larger:
  "is_heap t \<Longrightarrow> \<forall> x \<in> set (children t). priority x \<ge> priority t"
  by (erule is_heap_list.induct) simp_all

lemma is_heap_Min_children_larger:
  "is_heap t \<Longrightarrow> children t \<noteq> [] \<Longrightarrow>
   priority t \<le> Min (priority ` set (children t))"
  by (simp add: is_heap_children_larger)

subsubsection {* Combination of both: binqueue property *}

inductive is_binqueue :: "nat \<Rightarrow> ('a::linorder, 'b) binqueue \<Rightarrow> bool" where
  Empty: "is_binqueue l []"
| None: "is_binqueue (Suc l) xs \<Longrightarrow> is_binqueue l (None # xs)"
| Some: "is_binqueue (Suc l) xs \<Longrightarrow> is_bintree l t
    \<Longrightarrow> is_heap t \<Longrightarrow> is_binqueue l (Some t # xs)"

lemma is_binqueue_simp [simp]:
  "is_binqueue l [] \<longleftrightarrow> True"
  "is_binqueue l (Some t # xs) \<longleftrightarrow>
    is_bintree l t \<and> is_heap t \<and> is_binqueue (Suc l) xs"
  "is_binqueue l (None # xs) \<longleftrightarrow> is_binqueue (Suc l) xs"
  by (auto intro: is_binqueue.intros elim: is_binqueue.cases)

lemma is_binqueue_trans:
  "is_binqueue l (x#xs) \<Longrightarrow> is_binqueue (Suc l) xs"
  by (cases x) simp_all

lemma is_binqueue_head:
  "is_binqueue l (x#xs) \<Longrightarrow> is_binqueue l [x]"
  by (cases x) simp_all

lemma is_binqueue_append:
  "is_binqueue l xs \<Longrightarrow> is_binqueue (length xs + l) ys \<Longrightarrow> is_binqueue l (xs @ ys)"
  by (induct xs arbitrary: l) (auto intro: is_binqueue.intros elim: is_binqueue.cases)

lemma is_binqueue_append_dest [dest]:
  "is_binqueue l (xs @ ys) \<Longrightarrow> is_binqueue l xs"
  by (induct xs arbitrary: l) (auto intro: is_binqueue.intros elim: is_binqueue.cases)

lemma is_binqueue_children:
  assumes "is_bintree_list l ts"
  and "is_heap_list t ts"
  shows "is_binqueue 0 (map Some (rev ts))"
  using assms by (induct ts) (auto simp add: is_binqueue_append)

lemma is_binqueue_select:
  "is_binqueue l xs \<Longrightarrow> Some t \<in> set xs \<Longrightarrow> \<exists>k. is_bintree k t \<and> is_heap t"
  by (induct xs arbitrary: l) (auto intro: is_binqueue.intros elim: is_binqueue.cases)

subsubsection {* Normalized representation *}

inductive normalized :: "('a, 'b) binqueue \<Rightarrow> bool" where
  normalized_Nil: "normalized []"
| normalized_single: "normalized [Some t]"
| normalized_append: "xs \<noteq> [] \<Longrightarrow> normalized xs \<Longrightarrow> normalized (ys @ xs)"

lemma normalized_simps [simp]:
  "normalized [] \<longleftrightarrow> True"
  "normalized (Some t # xs) \<longleftrightarrow> normalized xs"
  "normalized (None # xs) \<longleftrightarrow> xs \<noteq> [] \<and> normalized xs"
  by (simp_all add: normalized_last_not_None)

lemma normalized_map_Some [simp]:
  "normalized (map Some xs)"
  by (induct xs) simp_all

lemma normalized_Cons:
  "normalized (x#xs) \<Longrightarrow> normalized xs"
  by (auto simp add: normalized_last_not_None)

lemma normalized_append:
  "normalized xs \<Longrightarrow> normalized ys \<Longrightarrow> normalized (xs@ys)"
  by (cases ys) (simp_all add: normalized_last_not_None)

lemma normalized_not_None:
  "normalized xs \<Longrightarrow> set xs \<noteq> {None}"
  by (induct xs) (auto simp add: normalized_Cons [of _ ts] dest: subset_singletonD)

primrec normalize' :: "('a, 'b) binqueue \<Rightarrow> ('a, 'b) binqueue" where
  "normalize' [] = []"
| "normalize' (x # xs) =
    (case x of None \<Rightarrow> normalize' xs | Some t \<Rightarrow> (x # xs))"

definition normalize :: "('a, 'b) binqueue \<Rightarrow> ('a, 'b) binqueue" where
  "normalize xs = rev (normalize' (rev xs))"

lemma normalized_normalize:
  "normalized (normalize xs)"
proof (induct xs rule: rev_induct)
  case (snoc y ys) then show ?case
    by (cases y) (simp_all add: normalized_last_not_None normalize_def)
qed (simp add: normalize_def)

lemma is_binqueue_normalize:
  "is_binqueue l xs \<Longrightarrow> is_binqueue l (normalize xs)"
  unfolding normalize_def
    by (induct xs arbitrary: l rule: rev_induct) (auto split: option.split)

subsection {* Operations *}

subsubsection {* Adding data *}

definition merge :: "('a::linorder, 'b) bintree \<Rightarrow> ('a, 'b) bintree \<Rightarrow> ('a, 'b) bintree" where
  "merge t1 t2 = (if priority t1 < priority t2
    then Node (priority t1) (val t1) (t2 # children t1)
    else Node (priority t2) (val t2) (t1 # children t2))"

lemma is_bintree_list_merge:
  assumes "is_bintree l t1" "is_bintree l t2"
  shows "is_bintree (Suc l) (merge t1 t2)"
  using assms by (simp add: merge_def)

lemma is_heap_merge:
  assumes "is_heap t1" "is_heap t2"
  shows "is_heap (merge t1 t2)"
  using assms by (auto simp add: merge_def)

fun
  add :: "('a::linorder, 'b) bintree option \<Rightarrow> ('a, 'b) binqueue \<Rightarrow> ('a, 'b) binqueue"
where
  "add None xs = xs"
| "add (Some t) [] = [Some t]"
| "add (Some t) (None # xs) = Some t # xs"
| "add (Some t) (Some r # xs) = None # add (Some (merge t r)) xs"

lemma add_Some_not_Nil [simp]:
  "add (Some t) xs \<noteq> []"
  by (induct "Some t" xs rule: add.induct) simp_all

lemma normalized_add:
  assumes "normalized xs"
  shows "normalized (add x xs)"
  using assms by (induct xs rule: add.induct) simp_all

lemma is_binqueue_add_None:
  assumes "is_binqueue l xs"
  shows "is_binqueue l (add None xs)"
  using assms by simp

lemma is_binqueue_add_Some:
  assumes "is_binqueue l xs"
  and     "is_bintree l t"
  and     "is_heap t"
  shows "is_binqueue l (add (Some t) xs)"
  using assms by (induct xs arbitrary: t) (simp_all add: is_bintree_list_merge is_heap_merge)

function
  meld :: "('a::linorder, 'b) binqueue \<Rightarrow> ('a, 'b) binqueue \<Rightarrow> ('a, 'b) binqueue"
where
  "meld [] ys = ys"
| "meld xs [] = xs"
| "meld (None # xs) (y # ys) = y # meld xs ys"
| "meld (x # xs) (None # ys) = x # meld xs ys"
| "meld (Some t # xs) (Some r # ys) =
    None # add (Some (merge t r)) (meld xs ys)"
  by pat_completeness auto termination by lexicographic_order

lemma meld_singleton_add [simp]:
  "meld [Some t] xs = add (Some t) xs"
  by (induct "Some t" xs rule: add.induct) simp_all

lemma nonempty_meld [simp]:
  "xs \<noteq> [] \<Longrightarrow> meld xs ys \<noteq> []"
  "ys \<noteq> [] \<Longrightarrow> meld xs ys \<noteq> []"
  by (induct xs ys rule: meld.induct) auto

lemma nonempty_meld_commute:
  "meld xs ys \<noteq> [] \<Longrightarrow> meld xs ys \<noteq> []"
  by (induct xs ys rule: meld.induct) auto

lemma is_binqueue_meld:
  assumes "is_binqueue l xs"
  and     "is_binqueue l ys"
  shows "is_binqueue l (meld xs ys)"
using assms
proof (induct xs ys arbitrary: l rule: meld.induct)
  fix xs ys :: "('a, 'b) binqueue"
  fix y :: "('a, 'b) bintree option"
  fix l :: nat
  assume "\<And> l. is_binqueue l xs \<Longrightarrow> is_binqueue l ys
      \<Longrightarrow> is_binqueue l (meld xs ys)"
    and "is_binqueue l (None # xs)"
    and "is_binqueue l (y # ys)"
  then show "is_binqueue l (meld (None # xs) (y # ys))" by (cases y) simp_all
next
  fix xs ys :: "('a, 'b) binqueue"
  fix x :: "('a, 'b) bintree option"
  fix l :: nat
  assume "\<And> l. is_binqueue l xs \<Longrightarrow> is_binqueue l ys
      \<Longrightarrow> is_binqueue l (meld xs ys)"
    and "is_binqueue l (x # xs)"
    and "is_binqueue l (None # ys)"
  then show "is_binqueue l (meld (x # xs) (None # ys))" by (cases x) simp_all
qed (simp_all add: is_bintree_list_merge is_heap_merge is_binqueue_add_Some)

lemma normalized_meld:
  assumes "normalized xs"
  and     "normalized ys"
  shows   "normalized (meld xs ys)"
using assms
proof (induct xs ys rule: meld.induct)
  fix xs ys :: "('a, 'b) binqueue"
  fix y :: "('a, 'b) bintree option"
  assume "normalized xs \<Longrightarrow> normalized ys \<Longrightarrow> normalized (meld xs ys)"
    and  "normalized (None # xs)"
    and  "normalized (y # ys)"
  then show "normalized (meld (None # xs) (y # ys))" by (cases y) simp_all
next
  fix xs ys :: "('a, 'b) binqueue"
  fix x :: "('a, 'b) bintree option"
  assume "normalized xs \<Longrightarrow> normalized ys \<Longrightarrow> normalized (meld xs ys)"
    and  "normalized (x # xs)"
    and  "normalized (None # ys)"
  then show "normalized (meld (x # xs) (None # ys))" by (cases x) simp_all
qed (simp_all add: normalized_add)

lemma normalized_meld_weak:
  assumes "normalized xs"
  and "length ys \<le> length xs"
  shows "normalized (meld xs ys)"
using assms
proof (induct xs ys rule: meld.induct)
  fix xs ys :: "('a, 'b) binqueue"
  fix y :: "('a, 'b) bintree option"
  assume "normalized xs \<Longrightarrow> length ys \<le> length xs \<Longrightarrow> normalized (meld xs ys)"
    and  "normalized (None # xs)"
    and  "length (y # ys) \<le> length (None # xs)"
  then show "normalized (meld (None # xs) (y # ys))" by (cases y) simp_all
next
  fix xs ys :: "('a, 'b) binqueue"
  fix x :: "('a, 'b) bintree option"
  assume "normalized xs \<Longrightarrow> length ys \<le> length xs \<Longrightarrow> normalized (meld xs ys)"
    and  "normalized (x # xs)"
    and  "length (None # ys) \<le> length (x # xs)"
  then show "normalized (meld (x # xs) (None # ys))" by (cases x) simp_all
qed (simp_all add: normalized_add)

definition least :: "'a::linorder option \<Rightarrow> 'a option \<Rightarrow> 'a option" where
  "least x y = (case x of
      None \<Rightarrow> y
    | Some x' \<Rightarrow> (case y of
           None \<Rightarrow> x
         | Some y' \<Rightarrow> if x' \<le> y' then x else y))"

lemma least_simps [simp, code]:
  "least None x = x"
  "least x None = x"
  "least (Some x') (Some y') = (if x' \<le> y' then Some x' else Some y')"
  unfolding least_def by (simp_all) (cases x, simp_all)

lemma least_split:
  assumes "least x y = Some z"
  shows "x = Some z \<or> y = Some z"
using assms proof (cases x)
  case (Some x') with assms show ?thesis by (cases y) (simp_all add: eq_commute)
qed simp

interpretation least!: semilattice least proof
qed (auto simp add: least_def split: option.split)

definition min :: "('a::linorder, 'b) binqueue \<Rightarrow> 'a option" where
  "min xs = fold least (map (map_option priority) xs) None"

lemma min_simps [simp]:
  "min [] = None"
  "min (None # xs) = min xs"
  "min (Some t # xs) = least (Some (priority t)) (min xs)"
  by (simp_all add: min_def fold_commute_apply [symmetric]
    fun_eq_iff least.left_commute del: least_simps)

lemma min_single:
  "min [x] = Some a \<Longrightarrow> priority (the x) = a"
  "min [x] = None \<Longrightarrow> x = None"
  by (auto simp add: min_def)

lemma min_Some_not_None:
  "min (Some t # xs) \<noteq> None"
  by (cases "min xs") simp_all

lemma min_None_trans:
  assumes "min (x#xs) = None"
  shows "min xs = None"
using assms proof (cases x)
  case None with assms show ?thesis by simp
next
  case (Some t) with assms show ?thesis by (simp only: min_Some_not_None)
qed

lemma min_None_None:
  "min xs = None \<longleftrightarrow> xs = [] \<or> set xs = {None}"
proof (rule iffI)
  have splitQ: "\<And> xs. xs \<subseteq> {None} \<Longrightarrow> xs = {} \<or> xs = {None}" by auto

  assume "min xs = None"
  then have "set xs \<subseteq> {None}"
  proof (induct xs)
    case (None ys) thus ?case using min_None_trans[of _ ys] by simp_all
  next
    case (Some t ys) thus ?case using min_Some_not_None[of t ys] by simp
  qed simp

  with splitQ show "xs = [] \<or> set xs = {None}" by auto
next
  show "xs = [] \<or> set xs = {None} \<Longrightarrow> min xs = None"
    by (induct xs) (auto dest: subset_singletonD)
qed

lemma normalized_min_not_None:
  "normalized xs \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> min xs \<noteq> None"
  by (simp add: min_None_None normalized_not_None)

lemma min_is_min:
  assumes "normalized xs"
  and "xs \<noteq> []"
  and "min xs = Some a"
  shows "\<forall>x \<in> set xs. x = None \<or> a \<le> priority (the x)"
using assms proof (induct xs arbitrary: a rule: binqueue_induct)
  case (Some t ys) thus ?case
  proof (cases "ys = []")
    case False
    with Some have N: "normalized ys" using normalized_Cons[of _ ys] by simp
    with `ys \<noteq> []` have "min ys \<noteq> None"
      by (simp add: normalized_min_not_None)
    then obtain a' where oa': "min ys = Some a'" by auto
    with Some N False
      have "\<forall>y \<in> set ys. y = None \<or> a' \<le> priority (the y)" by simp

    with Some oa' show ?thesis
      by (cases "a' \<le> priority t") (auto simp add: least.commute)
  qed simp
qed simp_all

lemma min_exists:
  assumes "min xs = Some a"
  shows "Some a \<in> map_option priority ` set xs"
proof (rule ccontr)
  assume "Some a \<notin> map_option priority ` set xs"
  then have "\<forall>x \<in> set xs. x = None \<or> priority (the x) \<noteq> a" by (induct xs) auto
  then have "min xs \<noteq> Some a"
  proof (induct xs arbitrary: a)
    case (Some t ys)
    hence "priority t \<noteq> a" and "min ys \<noteq> Some a" by simp_all
    show ?case
    proof (rule ccontr, simp)
      assume "least (Some (priority t)) (min ys) = Some a"
      hence "Some (priority t) = Some a \<or> min ys = Some a" by (rule least_split)
      with `min ys \<noteq> Some a` have "priority t = a" by simp
      with `priority t \<noteq> a` show False by simp
    qed
  qed simp_all
  with assms show False by simp
qed

primrec find :: "'a::linorder \<Rightarrow> ('a, 'b) binqueue \<Rightarrow> ('a, 'b) bintree option" where
  "find a [] = None"
| "find a (x#xs) = (case x of None \<Rightarrow> find a xs
    | Some t \<Rightarrow> if priority t = a then Some t else find a xs)"

declare find.simps [simp del]

lemma find_simps [simp, code]:
  "find a [] = None"
  "find a (None # xs) = find a xs"
  "find a (Some t # xs) = (if priority t = a then Some t else find a xs)"
  by (simp_all add: find_def)

lemma find_works:
  assumes "Some a \<in> set (map (map_option priority) xs)"
  shows "\<exists>t. find a xs = Some t \<and> priority t = a"
  using assms by (induct xs) auto

lemma find_works_not_None:
  "Some a \<in> set (map (map_option priority) xs) \<Longrightarrow> find a xs \<noteq> None"
  by (drule find_works) auto

lemma find_None:
  "find a xs = None \<Longrightarrow> Some a \<notin> set (map (map_option priority) xs)"
  by (auto simp add: find_works_not_None)

lemma find_exist:
  "find a xs = Some t \<Longrightarrow> Some t \<in> set xs"
  by (induct xs) (simp_all add: eq_commute)

definition find_min :: "('a::linorder, 'b) binqueue \<Rightarrow> ('a, 'b) bintree option" where
  "find_min xs = (case min xs of None \<Rightarrow> None | Some a \<Rightarrow> find a xs)"

lemma find_min_simps [simp]:
  "find_min [] = None"
  "find_min (None # xs) = find_min xs"
  by (auto simp add: find_min_def split: option.split)

lemma find_min_single:
  "find_min [x] = x"
  by (cases x) (auto simp add: find_min_def)

lemma min_eq_find_min_None:
  "min xs = None \<longleftrightarrow> find_min xs = None"
proof (rule iffI)
  show "min xs = None \<Longrightarrow> find_min xs = None"
    by (simp add: find_min_def)
next
  assume *: "find_min xs = None"
  show "min xs = None"
  proof (rule ccontr)
    assume "min xs \<noteq> None"

    then obtain a where "min xs = Some a" by auto
    hence "find_min xs \<noteq> None"
      by (simp add: find_min_def min_exists find_works_not_None)
    with * show False by simp
  qed
qed

lemma min_eq_find_min_Some:
  "min xs = Some a \<longleftrightarrow> (\<exists> t. find_min xs = Some t \<and> priority t = a)"
proof (rule iffI)
  show D1: "\<And>a. min xs = Some a
    \<Longrightarrow> (\<exists> t. find_min xs = Some t \<and> priority t = a)"
    by (simp add: find_min_def find_works min_exists)
  (* no 'next' here to keep D1 in scope as it is needed in the other part *)
  assume *: "\<exists> t. find_min xs = Some t \<and> priority t = a"
  show "min xs = Some a"
  proof (rule ccontr)
    assume "min xs \<noteq> Some a" thus False
    proof (cases "min xs")
      case None
      hence "find_min xs = None" by (simp only: min_eq_find_min_None)
      with * show False by simp
    next
      case (Some b)
      with `min xs \<noteq> Some a` have "a \<noteq> b" by simp
      with * Some show False using D1 by auto
    qed
  qed
qed

lemma find_min_exist:
  assumes "find_min xs = Some t"
  shows "Some t \<in> set xs"
proof -
  from assms have "min xs \<noteq> None" by (simp add: min_eq_find_min_None)
  with assms show ?thesis by (auto simp add: find_min_def find_exist)
qed

lemma find_min_is_min:
  assumes "normalized xs"
  and "xs \<noteq> []"
  and "find_min xs = Some t"
  shows "\<forall>x \<in> set xs. x = None \<or> (priority t) \<le> priority (the x)"
  using assms by (simp add: min_eq_find_min_Some min_is_min)

lemma normalized_find_min_exists:
  "normalized xs \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> \<exists>t. find_min xs = Some t"
by (drule normalized_min_not_None) (simp_all add: min_eq_find_min_None)

primrec
  match :: "'a::linorder \<Rightarrow> ('a, 'b) bintree option \<Rightarrow> ('a, 'b) bintree option"
where
  "match a None = None"
| "match a (Some t) = (if priority t = a then None else Some t)"

definition delete_min :: "('a::linorder, 'b) binqueue \<Rightarrow> ('a, 'b) binqueue" where
  "delete_min xs = (case find_min xs
    of Some (Node a v ts) \<Rightarrow>
         normalize (meld (map Some (rev ts)) (map (match a) xs))
     | None \<Rightarrow> [])"

lemma delete_min_empty [simp]:
  "delete_min [] = []"
  by (simp add: delete_min_def)

lemma delete_min_nonempty [simp]:
  "normalized xs \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> find_min xs = Some t
    \<Longrightarrow> delete_min xs = normalize
      (meld (map Some (rev (children t))) (map (match (priority t)) xs))"
  unfolding delete_min_def by (cases t) simp

lemma is_binqueue_delete_min:
  assumes "is_binqueue 0 xs"
  shows "is_binqueue 0 (delete_min xs)"
proof (cases "find_min xs")
  case (Some t)
  from assms have "is_binqueue 0 (map (match (priority t)) xs)"
    by (induct xs) simp_all

  moreover
  from Some have "Some t \<in> set xs" by (rule find_min_exist)
  with assms have "\<exists>l. is_bintree l t" and "is_heap t"
    using is_binqueue_select[of 0 xs t] by auto
  with assms have "is_binqueue 0 (map Some (rev (children t)))"
    by (auto simp add: is_binqueue_children)

  ultimately show ?thesis using Some
    by (auto simp add: is_binqueue_meld delete_min_def is_binqueue_normalize
      split: bintree.split)
qed (simp add: delete_min_def)

lemma normalized_delete_min:
  "normalized (delete_min xs)"
  by (cases "find_min xs")
    (auto simp add: delete_min_def normalized_normalize split: bintree.split)

subsubsection {* Dedicated grand unified operation for generated program *}

definition
  meld' :: "('a, 'b) bintree option \<Rightarrow> ('a::linorder, 'b) binqueue
    \<Rightarrow> ('a, 'b) binqueue \<Rightarrow> ('a, 'b) binqueue"
where
  "meld' z xs ys = add z (meld xs ys)"

lemma [code]:
  "add z xs = meld' z [] xs"
  "meld xs ys = meld' None xs ys"
  by (simp_all add: meld'_def)

lemma [code]:
  "meld' z (Some t # xs) (Some r # ys) =
    z # (meld' (Some (merge t r)) xs ys)"
  "meld' (Some t) (Some r # xs) (None # ys) =
    None # (meld' (Some (merge t r)) xs ys)"
  "meld' (Some t) (None # xs) (Some r # ys) =
    None # (meld' (Some (merge t r)) xs ys)"
  "meld' None (x # xs) (None # ys) = x # (meld' None xs ys)"
  "meld' None (None # xs) (y # ys) = y # (meld' None xs ys)"
  "meld' z (None # xs) (None # ys) = z # (meld' None xs ys)"
  "meld' z xs [] = meld' z [] xs"
  "meld' z [] (y # ys) = meld' None [z] (y # ys)"
  "meld' (Some t) [] ys = meld' None [Some t] ys"
  "meld' None [] ys = ys"
  by (simp add: meld'_def | cases z)+

subsubsection {* Interface operations *}

abbreviation (input) empty :: "('a,'b) binqueue" where
  "empty \<equiv> []"

definition
  insert :: "'a::linorder \<Rightarrow> 'b \<Rightarrow> ('a, 'b) binqueue \<Rightarrow> ('a, 'b) binqueue"
where
  "insert a v xs = add (Some (Node a v [])) xs"

lemma insert_simps [simp]:
  "insert a v [] = [Some (Node a v [])]"
  "insert a v (None # xs) = Some (Node a v []) # xs"
  "insert a v (Some t # xs) = None # add (Some (merge (Node a v []) t)) xs"
  by (simp_all add: insert_def)

lemma is_binqueue_insert:
  "is_binqueue 0 xs \<Longrightarrow> is_binqueue 0 (insert a v xs)"
  by (simp add: is_binqueue_add_Some insert_def)

lemma normalized_insert:
  "normalized xs \<Longrightarrow> normalized (insert a v xs)"
  by (simp add: normalized_add insert_def)

definition
  pop :: "('a::linorder, 'b) binqueue \<Rightarrow> (('b \<times> 'a) option \<times> ('a, 'b) binqueue)"
where
  "pop xs = (case find_min xs of
      None \<Rightarrow> (None, xs)
    | Some t  \<Rightarrow> (Some (val t, priority t), delete_min xs))"

lemma pop_empty [simp]:
  "pop empty = (None, empty)"
  by (simp add: pop_def empty_def)

lemma pop_nonempty [simp]:
  "normalized xs \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> find_min xs = Some t
    \<Longrightarrow> pop xs = (Some (val t, priority t), normalize
      (meld (map Some (rev (children t))) (map (match (priority t)) xs)))"
  by (simp add: pop_def)

lemma pop_code [code]:
  "pop xs = (case find_min xs of
      None \<Rightarrow> (None, xs)
    | Some t  \<Rightarrow> (Some (val t, priority t), normalize
       (meld (map Some (rev (children t))) (map (match (priority t)) xs))))"
  by (cases "find_min xs") (simp_all add: pop_def delete_min_def split: bintree.split)

end