(*  Title:      HOL/HOLCF/Library/List_Cpo.thy
    Author:     Brian Huffman
*)

section \<open>Lists as a complete partial order\<close>

theory List_Cpo
imports HOLCF
begin

subsection \<open>Lists are a partial order\<close>

instantiation list :: (po) po
begin

definition
  "xs \<sqsubseteq> ys \<longleftrightarrow> list_all2 (\<sqsubseteq>) xs ys"

instance proof
  fix xs :: "'a list"
  from below_refl show "xs \<sqsubseteq> xs"
    unfolding below_list_def
    by (rule list_all2_refl)
next
  fix xs ys zs :: "'a list"
  assume "xs \<sqsubseteq> ys" and "ys \<sqsubseteq> zs"
  with below_trans show "xs \<sqsubseteq> zs"
    unfolding below_list_def
    by (rule list_all2_trans)
next
  fix xs ys zs :: "'a list"
  assume "xs \<sqsubseteq> ys" and "ys \<sqsubseteq> xs"
  with below_antisym show "xs = ys"
    unfolding below_list_def
    by (rule list_all2_antisym)
qed

end

lemma below_list_simps [simp]:
  "[] \<sqsubseteq> []"
  "x # xs \<sqsubseteq> y # ys \<longleftrightarrow> x \<sqsubseteq> y \<and> xs \<sqsubseteq> ys"
  "\<not> [] \<sqsubseteq> y # ys"
  "\<not> x # xs \<sqsubseteq> []"
by (simp_all add: below_list_def)

lemma Nil_below_iff [simp]: "[] \<sqsubseteq> xs \<longleftrightarrow> xs = []"
by (cases xs, simp_all)

lemma below_Nil_iff [simp]: "xs \<sqsubseteq> [] \<longleftrightarrow> xs = []"
by (cases xs, simp_all)

lemma list_below_induct [consumes 1, case_names Nil Cons]:
  assumes "xs \<sqsubseteq> ys"
  assumes 1: "P [] []"
  assumes 2: "\<And>x y xs ys. \<lbrakk>x \<sqsubseteq> y; xs \<sqsubseteq> ys; P xs ys\<rbrakk> \<Longrightarrow> P (x # xs) (y # ys)"
  shows "P xs ys"
using \<open>xs \<sqsubseteq> ys\<close>
proof (induct xs arbitrary: ys)
  case Nil thus ?case by (simp add: 1)
next
  case (Cons x xs) thus ?case by (cases ys, simp_all add: 2)
qed

lemma list_below_cases:
  assumes "xs \<sqsubseteq> ys"
  obtains "xs = []" and "ys = []" |
    x y xs' ys' where "xs = x # xs'" and "ys = y # ys'"
using assms by (cases xs, simp, cases ys, auto)

text "Thanks to Joachim Breitner"

lemma list_Cons_below:
  assumes "a # as \<sqsubseteq> xs"
  obtains b and bs where "a \<sqsubseteq> b" and "as \<sqsubseteq> bs" and "xs = b # bs"
  using assms by (cases xs, auto)

lemma list_below_Cons:
  assumes "xs \<sqsubseteq> b # bs"
  obtains a and as where "a \<sqsubseteq> b" and "as \<sqsubseteq> bs" and "xs = a # as"
  using assms by (cases xs, auto)

lemma hd_mono: "xs \<sqsubseteq> ys \<Longrightarrow> hd xs \<sqsubseteq> hd ys"
by (cases xs, simp, cases ys, simp, simp)

lemma tl_mono: "xs \<sqsubseteq> ys \<Longrightarrow> tl xs \<sqsubseteq> tl ys"
by (cases xs, simp, cases ys, simp, simp)

lemma ch2ch_hd [simp]: "chain (\<lambda>i. S i) \<Longrightarrow> chain (\<lambda>i. hd (S i))"
by (rule chainI, rule hd_mono, erule chainE)

lemma ch2ch_tl [simp]: "chain (\<lambda>i. S i) \<Longrightarrow> chain (\<lambda>i. tl (S i))"
by (rule chainI, rule tl_mono, erule chainE)

lemma below_same_length: "xs \<sqsubseteq> ys \<Longrightarrow> length xs = length ys"
unfolding below_list_def by (rule list_all2_lengthD)

lemma list_chain_induct [consumes 1, case_names Nil Cons]:
  assumes "chain S"
  assumes 1: "P (\<lambda>i. [])"
  assumes 2: "\<And>A B. chain A \<Longrightarrow> chain B \<Longrightarrow> P B \<Longrightarrow> P (\<lambda>i. A i # B i)"
  shows "P S"
using \<open>chain S\<close>
proof (induct "S 0" arbitrary: S)
  case Nil
  have "\<forall>i. S 0 \<sqsubseteq> S i" by (simp add: chain_mono [OF \<open>chain S\<close>])
  with Nil have "\<forall>i. S i = []" by simp
  thus ?case by (simp add: 1)
next
  case (Cons x xs)
  have "\<forall>i. S 0 \<sqsubseteq> S i" by (simp add: chain_mono [OF \<open>chain S\<close>])
  hence *: "\<forall>i. S i \<noteq> []" by (rule all_forward, insert Cons) auto
  have "chain (\<lambda>i. hd (S i))" and "chain (\<lambda>i. tl (S i))"
    using \<open>chain S\<close> by simp_all
  moreover have "P (\<lambda>i. tl (S i))"
    using \<open>chain S\<close> and \<open>x # xs = S 0\<close> [symmetric]
    by (simp add: Cons(1))
  ultimately have "P (\<lambda>i. hd (S i) # tl (S i))"
    by (rule 2)
  thus "P S" by (simp add: *)
qed

lemma list_chain_cases:
  assumes S: "chain S"
  obtains "S = (\<lambda>i. [])" |
    A B where "chain A" and "chain B" and "S = (\<lambda>i. A i # B i)"
using S by (induct rule: list_chain_induct) simp_all

subsection \<open>Lists are a complete partial order\<close>

lemma is_lub_Cons:
  assumes A: "range A <<| x"
  assumes B: "range B <<| xs"
  shows "range (\<lambda>i. A i # B i) <<| x # xs"
using assms
unfolding is_lub_def is_ub_def
by (clarsimp, case_tac u, simp_all)

instance list :: (cpo) cpo
proof
  fix S :: "nat \<Rightarrow> 'a list"
  assume "chain S"
  then show "\<exists>x. range S <<| x"
  proof (induct rule: list_chain_induct)
    case Nil
    have "{[]} <<| []"
      by simp
    then obtain x :: "'a list" where "{[]} <<| x" ..
    then show ?case
      by auto
  next
    case (Cons A B) then show ?case
      by (auto intro: is_lub_Cons cpo_lubI)
  qed
qed

subsection \<open>Continuity of list operations\<close>

lemma cont2cont_Cons [simp, cont2cont]:
  assumes f: "cont (\<lambda>x. f x)"
  assumes g: "cont (\<lambda>x. g x)"
  shows "cont (\<lambda>x. f x # g x)"
apply (rule contI)
apply (rule is_lub_Cons)
apply (erule contE [OF f])
apply (erule contE [OF g])
done

lemma lub_Cons:
  fixes A :: "nat \<Rightarrow> 'a::cpo"
  assumes A: "chain A" and B: "chain B"
  shows "(\<Squnion>i. A i # B i) = (\<Squnion>i. A i) # (\<Squnion>i. B i)"
by (intro lub_eqI is_lub_Cons cpo_lubI A B)

lemma cont2cont_case_list:
  assumes f: "cont (\<lambda>x. f x)"
  assumes g: "cont (\<lambda>x. g x)"
  assumes h1: "\<And>y ys. cont (\<lambda>x. h x y ys)"
  assumes h2: "\<And>x ys. cont (\<lambda>y. h x y ys)"
  assumes h3: "\<And>x y. cont (\<lambda>ys. h x y ys)"
  shows "cont (\<lambda>x. case f x of [] \<Rightarrow> g x | y # ys \<Rightarrow> h x y ys)"
apply (rule cont_apply [OF f])
apply (rule contI)
apply (erule list_chain_cases)
apply (simp add: is_lub_const)
apply (simp add: lub_Cons)
apply (simp add: cont2contlubE [OF h2])
apply (simp add: cont2contlubE [OF h3])
apply (simp add: diag_lub ch2ch_cont [OF h2] ch2ch_cont [OF h3])
apply (rule cpo_lubI, rule chainI, rule below_trans)
apply (erule cont2monofunE [OF h2 chainE])
apply (erule cont2monofunE [OF h3 chainE])
apply (case_tac y, simp_all add: g h1)
done

lemma cont2cont_case_list' [simp, cont2cont]:
  assumes f: "cont (\<lambda>x. f x)"
  assumes g: "cont (\<lambda>x. g x)"
  assumes h: "cont (\<lambda>p. h (fst p) (fst (snd p)) (snd (snd p)))"
  shows "cont (\<lambda>x. case f x of [] \<Rightarrow> g x | y # ys \<Rightarrow> h x y ys)"
using assms by (simp add: cont2cont_case_list prod_cont_iff)

text \<open>The simple version (due to Joachim Breitner) is needed if the
  element type of the list is not a cpo.\<close>

lemma cont2cont_case_list_simple [simp, cont2cont]:
  assumes "cont (\<lambda>x. f1 x)"
  assumes "\<And>y ys. cont (\<lambda>x. f2 x y ys)"
  shows "cont (\<lambda>x. case l of [] \<Rightarrow> f1 x | y # ys \<Rightarrow> f2 x y ys)"
using assms by (cases l) auto

text \<open>Lemma for proving continuity of recursive list functions:\<close>

lemma list_contI:
  fixes f :: "'a::cpo list \<Rightarrow> 'b::cpo"
  assumes f: "\<And>x xs. f (x # xs) = g x xs (f xs)"
  assumes g1: "\<And>xs y. cont (\<lambda>x. g x xs y)"
  assumes g2: "\<And>x y. cont (\<lambda>xs. g x xs y)"
  assumes g3: "\<And>x xs. cont (\<lambda>y. g x xs y)"
  shows "cont f"
proof (rule contI2)
  obtain h where h: "\<And>x xs y. g x xs y = h\<cdot>x\<cdot>xs\<cdot>y"
  proof
    fix x xs y show "g x xs y = (\<Lambda> x xs y. g x xs y)\<cdot>x\<cdot>xs\<cdot>y"
    by (simp add: cont2cont_LAM g1 g2 g3)
  qed
  show mono: "monofun f"
    apply (rule monofunI)
    apply (erule list_below_induct)
    apply simp
    apply (simp add: f h monofun_cfun)
    done
  fix Y :: "nat \<Rightarrow> 'a list"
  assume "chain Y" thus "f (\<Squnion>i. Y i) \<sqsubseteq> (\<Squnion>i. f (Y i))"
    apply (induct rule: list_chain_induct)
    apply simp
    apply (simp add: lub_Cons f h)
    apply (simp add: lub_APP ch2ch_monofun [OF mono])
    apply (simp add: monofun_cfun)
    done
qed

text \<open>Continuity rule for map\<close>

lemma cont2cont_map [simp, cont2cont]:
  assumes f: "cont (\<lambda>(x, y). f x y)"
  assumes g: "cont (\<lambda>x. g x)"
  shows "cont (\<lambda>x. map (\<lambda>y. f x y) (g x))"
using f
apply (simp add: prod_cont_iff)
apply (rule cont_apply [OF g])
apply (rule list_contI, rule list.map, simp, simp, simp)
apply (induct_tac y, simp, simp)
done

text \<open>There are probably lots of other list operations that also
deserve to have continuity lemmas.  I'll add more as they are
needed.\<close>

subsection \<open>Lists are a discrete cpo\<close>

instance list :: (discrete_cpo) discrete_cpo
proof
  fix xs ys :: "'a list"
  show "xs \<sqsubseteq> ys \<longleftrightarrow> xs = ys"
    by (induct xs arbitrary: ys, case_tac [!] ys, simp_all)
qed

subsection \<open>Compactness and chain-finiteness\<close>

lemma compact_Nil [simp]: "compact []"
apply (rule compactI2)
apply (erule list_chain_cases)
apply simp
apply (simp add: lub_Cons)
done

lemma compact_Cons: "\<lbrakk>compact x; compact xs\<rbrakk> \<Longrightarrow> compact (x # xs)"
apply (rule compactI2)
apply (erule list_chain_cases)
apply (auto simp add: lub_Cons dest!: compactD2)
apply (rename_tac i j, rule_tac x="max i j" in exI)
apply (drule (1) below_trans [OF _ chain_mono [OF _ max.cobounded1]])
apply (drule (1) below_trans [OF _ chain_mono [OF _ max.cobounded2]])
apply (erule (1) conjI)
done

lemma compact_Cons_iff [simp]:
  "compact (x # xs) \<longleftrightarrow> compact x \<and> compact xs"
apply (safe intro!: compact_Cons)
apply (simp only: compact_def)
apply (subgoal_tac "cont (\<lambda>x. x # xs)")
apply (drule (1) adm_subst, simp, simp)
apply (simp only: compact_def)
apply (subgoal_tac "cont (\<lambda>xs. x # xs)")
apply (drule (1) adm_subst, simp, simp)
done

instance list :: (chfin) chfin
proof
  fix Y :: "nat \<Rightarrow> 'a list" assume "chain Y"
  moreover have "\<And>(xs::'a list). compact xs"
    by (induct_tac xs, simp_all)
  ultimately show "\<exists>i. max_in_chain i Y"
    by (rule compact_imp_max_in_chain)
qed

subsection \<open>Using lists with fixrec\<close>

definition
  match_Nil :: "'a::cpo list \<rightarrow> 'b match \<rightarrow> 'b match"
where
  "match_Nil = (\<Lambda> xs k. case xs of [] \<Rightarrow> k | y # ys \<Rightarrow> Fixrec.fail)"

definition
  match_Cons :: "'a::cpo list \<rightarrow> ('a \<rightarrow> 'a list \<rightarrow> 'b match) \<rightarrow> 'b match"
where
  "match_Cons = (\<Lambda> xs k. case xs of [] \<Rightarrow> Fixrec.fail | y # ys \<Rightarrow> k\<cdot>y\<cdot>ys)"

lemma match_Nil_simps [simp]:
  "match_Nil\<cdot>[]\<cdot>k = k"
  "match_Nil\<cdot>(x # xs)\<cdot>k = Fixrec.fail"
unfolding match_Nil_def by simp_all

lemma match_Cons_simps [simp]:
  "match_Cons\<cdot>[]\<cdot>k = Fixrec.fail"
  "match_Cons\<cdot>(x # xs)\<cdot>k = k\<cdot>x\<cdot>xs"
unfolding match_Cons_def by simp_all

setup \<open>
  Fixrec.add_matchers
    [ (\<^const_name>\<open>Nil\<close>, \<^const_name>\<open>match_Nil\<close>),
      (\<^const_name>\<open>Cons\<close>, \<^const_name>\<open>match_Cons\<close>) ]
\<close>

end


(*  Author:     Tobias Nipkow, 2007  *)

theory Cooper
imports PresArith
begin

subsection\<open>Cooper\<close>

text\<open>This section formalizes Cooper's algorithm~\cite{Cooper72}.\<close>

lemma set_atoms0_iff:
 "qfree \<phi> \<Longrightarrow> a \<in> set(Z.atoms\<^sub>0 \<phi>) \<longleftrightarrow> a \<in> atoms \<phi> \<and> hd_coeff a \<noteq> 0"
by(induct \<phi>) (auto split:if_split_asm)

definition
"hd_coeffs1 \<phi> =
 (let m = zlcms(map hd_coeff (Z.atoms\<^sub>0 \<phi>))
  in And (Atom(Dvd m 0 [1])) (map\<^sub>f\<^sub>m (hd_coeff1 m) \<phi>))"

lemma I_hd_coeffs1:
assumes "qfree \<phi>"
shows "(\<exists>x. Z.I (hd_coeffs1 \<phi>) (x#xs)) = (\<exists>x. Z.I \<phi> (x#xs))" (is "?L = ?R")
proof -
  let ?l = "zlcms(map hd_coeff (Z.atoms\<^sub>0 \<phi>))"
  have "?l>0" by(simp add: zlcms_pos set_atoms0_iff[OF \<open>qfree \<phi>\<close>])
  have "?L = (\<exists>x. ?l dvd x+0 \<and> Z.I (map\<^sub>f\<^sub>m (hd_coeff1 ?l) \<phi>) (x#xs))"
    by(simp add:hd_coeffs1_def)
  also have "\<dots> = (\<exists>x. Z.I (map\<^sub>f\<^sub>m (hd_coeff1 ?l) \<phi>) (?l*x#xs))"
    by(rule unity_coeff_ex[THEN meta_eq_to_obj_eq,symmetric])
  also have "\<dots> = ?R"
    by(simp add: I_hd_coeff1_mult[OF \<open>?l>0\<close> \<open>qfree \<phi>\<close>] dvd_zlcms)
  finally show ?thesis .
qed

fun min_inf :: "atom fm \<Rightarrow> atom fm" ("inf\<^sub>-") where
"inf\<^sub>- (And \<phi>\<^sub>1 \<phi>\<^sub>2) = and (inf\<^sub>- \<phi>\<^sub>1) (inf\<^sub>- \<phi>\<^sub>2)" |
"inf\<^sub>- (Or \<phi>\<^sub>1 \<phi>\<^sub>2) = or (inf\<^sub>- \<phi>\<^sub>1) (inf\<^sub>- \<phi>\<^sub>2)" |
"inf\<^sub>- (Atom(Le i (k#ks))) =
  (if k<0 then TrueF else if k>0 then FalseF else Atom(Le i (0#ks)))" |
"inf\<^sub>- \<phi> = \<phi>"

definition
"qe_cooper\<^sub>1 \<phi> =
 (let as = Z.atoms\<^sub>0 \<phi>; d = zlcms(map divisor as); ls = lbounds as
  in or (Disj [0..d - 1] (\<lambda>n. subst n [] (inf\<^sub>- \<phi>)))
        (Disj ls (\<lambda>(i,ks).
           Disj [0..d - 1] (\<lambda>n. subst (i + n) (-ks) \<phi>))))"

lemma min_inf:
  "nqfree f \<Longrightarrow> \<forall>a\<in>set(Z.atoms\<^sub>0 f). hd_coeff_is1 a
   \<Longrightarrow> \<exists>x.\<forall>y<x. Z.I (inf\<^sub>- f) (y # xs) = Z.I f (y # xs)"
  (is "_ \<Longrightarrow> _ \<Longrightarrow> \<exists>x. ?P f x")
proof(induct f rule: min_inf.induct)
  case (3 i k ks)
  { assume "k=0" hence ?case using 3 by simp }
  moreover
  { assume "k= -1"
    hence "?P (Atom(Le i (k#ks))) (-i + \<langle>ks,xs\<rangle> - 1)" using 3 by auto
    hence ?case .. }
  moreover
  { assume "k=1"
    hence "?P (Atom(Le i (k#ks))) (i - \<langle>ks,xs\<rangle> - 1)" using 3 by auto
    hence ?case .. }
  ultimately show ?case using 3 by auto
next
  case (1 f1 f2)
  then obtain x1 x2 where "?P f1 x1" "?P f2 x2" by fastforce+
  hence "?P (And f1 f2) (min x1 x2)" by simp
  thus ?case ..
next
  case (2 f1 f2)
  then obtain x1 x2 where "?P f1 x1" "?P f2 x2" by fastforce+
  hence "?P (Or f1 f2) (min x1 x2)" by simp
  thus ?case ..
qed simp_all

lemma min_inf_repeats:
  "nqfree \<phi> \<Longrightarrow> \<forall>a\<in>set(Z.atoms\<^sub>0 \<phi>). divisor a dvd d \<Longrightarrow>
  Z.I (inf\<^sub>- \<phi>) ((x - k*d)#xs) = Z.I (inf\<^sub>- \<phi>) (x#xs)"
proof(induct \<phi> rule:min_inf.induct)
  case ("4_4" da i ks)
  show ?case
  proof (cases ks)
    case Nil thus ?thesis by simp
  next
    case (Cons j js)
    show ?thesis
    proof cases
      assume "j=0" thus ?thesis using Cons by simp
    next
      assume "j\<noteq>0"
      hence "da dvd d" using Cons "4_4" by simp
      hence "da dvd i + (j * x - j * (k * d) + \<langle>js,xs\<rangle>) \<longleftrightarrow>
             da dvd i + (j * x + \<langle>js,xs\<rangle>)"
      proof -
        have "da dvd i + (j * x - j * (k * d) + \<langle>js,xs\<rangle>) \<longleftrightarrow>
              da dvd (i + j*x + \<langle>js,xs\<rangle>) - (j*k)*d"
          by(simp add: algebra_simps)
        also have "\<dots> \<longleftrightarrow> da dvd i + j*x + \<langle>js,xs\<rangle>" using \<open>da dvd d\<close>
          by (metis dvd_diff zdvd_zdiffD dvd_mult mult.commute)
        also have "\<dots> \<longleftrightarrow> da dvd i + (j * x + \<langle>js,xs\<rangle>)"
          by(simp add: algebra_simps)
        finally show ?thesis .
      qed
      then show ?thesis using Cons by (simp add:ring_distribs)
    qed
  qed
next
  case ("4_5" da i ks)
  show ?case
  proof (cases ks)
    case Nil thus ?thesis by simp
  next
    case (Cons j js)
    show ?thesis
    proof cases
      assume "j=0" thus ?thesis using Cons by simp
    next
      assume "j\<noteq>0"
      hence "da dvd d" using Cons "4_5" by simp
      hence "da dvd i + (j * x - j * (k * d) + \<langle>js,xs\<rangle>) \<longleftrightarrow>
             da dvd i + (j * x + \<langle>js,xs\<rangle>)"
      proof -
        have "da dvd i + (j * x - j * (k * d) + \<langle>js,xs\<rangle>) \<longleftrightarrow>
              da dvd (i + j*x + \<langle>js,xs\<rangle>) - (j*k)*d"
          by(simp add: algebra_simps)
        also have "\<dots> \<longleftrightarrow> da dvd i + j*x + \<langle>js,xs\<rangle>" using \<open>da dvd d\<close>
          by (metis dvd_diff zdvd_zdiffD dvd_mult mult.commute)
        also have "\<dots> \<longleftrightarrow> da dvd i + (j * x + \<langle>js,xs\<rangle>)"
          by(simp add: algebra_simps)
        finally show ?thesis .
      qed
      then show ?thesis using Cons by (simp add:ring_distribs)
    qed
  qed
qed simp_all

lemma atoms_subset: "qfree f \<Longrightarrow> set(Z.atoms\<^sub>0(f::atom fm)) \<le> atoms f"
by (induct f) auto

(* copied from Amine *)
lemma \<beta>:
  "\<lbrakk> nqfree \<phi>;  \<forall>a\<in>set(Z.atoms\<^sub>0 \<phi>). hd_coeff_is1 a;
     \<forall>a\<in>set(Z.atoms\<^sub>0 \<phi>). divisor a dvd d; d > 0;
     \<not>(\<exists>j\<in>{0 .. d - 1}. \<exists>(i,ks) \<in> set(lbounds(Z.atoms\<^sub>0 \<phi>)).
         x = i - \<langle>ks,xs\<rangle> + j); Z.I \<phi> (x#xs) \<rbrakk>
  \<Longrightarrow> Z.I \<phi> ((x-d)#xs)"
proof(induct \<phi>)
  case (Atom a)
  show ?case
  proof (cases a)
    case (Le i js)
    show ?thesis
    proof (cases js)
      case Nil thus ?thesis using Le Atom by simp
    next
      case (Cons k ks) thus ?thesis using Le Atom
        by (auto simp:lbounds_def Ball_def split:if_split_asm) arith
    qed
  next
    case (Dvd m i js)
    show ?thesis
    proof (cases js)
      case Nil thus ?thesis using Dvd Atom by simp
    next
      case (Cons k ks)
      show ?thesis
      proof cases
        assume "k=0" thus ?thesis using Cons Dvd Atom by simp
      next
        assume "k\<noteq>0"
        hence "m dvd d" using Cons Dvd Atom by auto
        have "m dvd i + (x + \<langle>ks,xs\<rangle>) \<Longrightarrow> m dvd i + (x - d + \<langle>ks,xs\<rangle>)"
          (is "?L \<Longrightarrow> _")
        proof -
          assume ?L
          hence "m dvd i + (x + \<langle>ks,xs\<rangle>) - d"
            by (metis \<open>m dvd d\<close> dvd_diff)
          thus ?thesis by(simp add:algebra_simps)
        qed
        thus ?thesis using Atom Dvd Cons by(auto split:if_split_asm)
      qed
    qed
  next
    case (NDvd m i js)
    show ?thesis
    proof (cases js)
      case Nil thus ?thesis using NDvd Atom by simp
    next
      case (Cons k ks)
      show ?thesis
      proof cases
        assume "k=0" thus ?thesis using Cons NDvd Atom by simp
      next
        assume "k\<noteq>0"
        hence "m dvd d" using Cons NDvd Atom by auto
        have "m dvd i + (x - d + \<langle>ks,xs\<rangle>) \<Longrightarrow> m dvd i + (x + \<langle>ks,xs\<rangle>)"
          (is "?L \<Longrightarrow> _")
        proof -
          assume ?L
          hence "m dvd i + (x + \<langle>ks,xs\<rangle>) - d" by(simp add:algebra_simps)
          thus ?thesis by (metis \<open>m dvd d\<close> zdvd_zdiffD)
        qed
        thus ?thesis using Atom NDvd Cons by(auto split:if_split_asm)
      qed
    qed
  qed
qed force+

lemma periodic_finite_ex:
  assumes dpos: "(0::int) < d" and modd: "\<forall>x k. P x = P(x - k*d)"
  shows "(\<exists>x. P x) = (\<exists>j\<in>{0..d - 1}. P j)"
  (is "?LHS = ?RHS")
proof
  assume ?LHS
  then obtain x where P: "P x" ..
  have "x mod d = x - (x div d)*d"
    by(simp add:mult_div_mod_eq [symmetric] ac_simps eq_diff_eq)
  hence Pmod: "P x = P(x mod d)" using modd by simp
  have "P(x mod d)" using dpos P Pmod by simp
  moreover have "x mod d \<in> {0..d - 1}" using dpos by auto
  ultimately show ?RHS ..
qed auto

lemma cpmi_eq: "(0::int) < D \<Longrightarrow> (\<exists>z. \<forall>x. x < z \<longrightarrow> (P x = P1 x))
\<Longrightarrow> \<forall>x.\<not>(\<exists>j\<in>{0..D - 1}. \<exists>b\<in>B. P(b+j)) \<longrightarrow> P (x) \<longrightarrow> P (x - D)
\<Longrightarrow> \<forall>x. \<forall>k. P1 x = P1(x-k*D)
\<Longrightarrow> (\<exists>x. P(x)) = ((\<exists>j\<in>{0..D - 1}. P1(j)) \<or> (\<exists>j\<in>{0..D - 1}. \<exists>b\<in>B. P(b+j)))"
apply(rule iffI)
prefer 2
apply(drule minusinfinity)
apply assumption+
apply(fastforce)
apply clarsimp
apply(subgoal_tac "\<And>k. 0\<le>k \<Longrightarrow> \<forall>x. P x \<longrightarrow> P (x - k*D)")
apply(frule_tac x = x and z=z in decr_lemma)
apply(subgoal_tac "P1(x - (\<bar>x - z\<bar> + 1) * D)")
prefer 2
apply(subgoal_tac "0 \<le> (\<bar>x - z\<bar> + 1)")
prefer 2 apply arith
 apply fastforce
apply(drule (1)  periodic_finite_ex)
apply blast
apply(blast dest:decr_mult_lemma)
done

(* end of Amine *)

lemma qfree_min_inf[simp]: "qfree \<phi> \<Longrightarrow> qfree (inf\<^sub>- \<phi>)"
by (induct \<phi> rule:min_inf.induct) simp_all

lemma I_qe_cooper\<^sub>1:
assumes norm: "\<forall>a\<in>atoms \<phi>. divisor a \<noteq> 0"
and hd: "\<forall>a\<in>set(Z.atoms\<^sub>0 \<phi>). hd_coeff_is1 a" and "nqfree \<phi>"
shows "Z.I (qe_cooper\<^sub>1 \<phi>) xs = (\<exists>x. Z.I \<phi> (x#xs))"
proof -
  let ?as = "Z.atoms\<^sub>0 \<phi>"
  let ?d = "zlcms(map divisor ?as)"
  have "?d > 0" using norm atoms_subset[of \<phi>] \<open>nqfree \<phi>\<close>
    by(fastforce intro:zlcms_pos)
  have alld: "\<forall>a\<in>set(Z.atoms\<^sub>0 \<phi>). divisor a dvd ?d" by(simp add:dvd_zlcms)
  from cp_thm[OF \<open>nqfree \<phi>\<close> hd alld \<open>?d>0\<close>]
  show ?thesis using \<open>nqfree \<phi>\<close>
    by (simp add:qe_cooper\<^sub>1_def I_subst[symmetric] split_def algebra_simps) blast
qed

lemma divisor_hd_coeff1_neq0:
  "qfree \<phi> \<Longrightarrow> a \<in> atoms \<phi> \<Longrightarrow> divisor a \<noteq> 0 \<Longrightarrow>
   divisor (hd_coeff1 (zlcms (map hd_coeff (Z.atoms\<^sub>0 \<phi>))) a) \<noteq> 0"
apply (case_tac a)

apply simp
apply(rename_tac list) apply(case_tac list) apply simp apply(simp split:if_split_asm)

apply simp
apply(rename_tac list)apply(case_tac list) apply simp
apply(clarsimp split:if_split_asm)
apply(hypsubst_thin)
apply(subgoal_tac "a \<in> set(map hd_coeff (Z.atoms\<^sub>0 \<phi>))")
 apply(subgoal_tac "\<forall>i\<in>set(map hd_coeff (Z.atoms\<^sub>0 \<phi>)). i \<noteq> 0")
  apply (metis dvd_zlcms mult_eq_0_iff dvd_mult_div_cancel zlcms0_iff)
 apply (simp add:set_atoms0_iff)
apply(fastforce simp:image_def set_atoms0_iff Bex_def)

apply simp
apply(rename_tac list) apply(case_tac list) apply simp
apply(clarsimp split:if_split_asm)
apply(hypsubst_thin)
apply(subgoal_tac "a \<in> set(map hd_coeff (Z.atoms\<^sub>0 \<phi>))")
 apply(subgoal_tac "\<forall>i\<in>set(map hd_coeff (Z.atoms\<^sub>0 \<phi>)). i \<noteq> 0")
  apply (metis dvd_zlcms mult_eq_0_iff dvd_mult_div_cancel zlcms0_iff)
 apply (simp add:set_atoms0_iff)
apply(fastforce simp:image_def set_atoms0_iff Bex_def)
done

lemma hd_coeff_is1_hd_coeff1:
  "hd_coeff (hd_coeff1 m a) \<noteq> 0 \<longrightarrow> hd_coeff_is1 (hd_coeff1 m a)"
by (induct a rule: hd_coeff1.induct) (simp_all add:zsgn_def)

lemma I_cooper1_hd_coeffs1: "Z.normal \<phi> \<Longrightarrow> nqfree \<phi>
       \<Longrightarrow> Z.I (qe_cooper\<^sub>1(hd_coeffs1 \<phi>)) xs = (\<exists>x. Z.I \<phi> (x # xs))"
apply(simp add:Z.normal_def)
apply(subst I_qe_cooper\<^sub>1)
   apply(clarsimp simp:hd_coeffs1_def image_def set_atoms0_iff divisor_hd_coeff1_neq0)
  apply (clarsimp simp:hd_coeffs1_def qfree_map_fm set_atoms0_iff
                     hd_coeff_is1_hd_coeff1)
 apply(simp add:hd_coeffs1_def nqfree_map_fm)
apply(simp add: I_hd_coeffs1)
done

definition "qe_cooper = Z.lift_nnf_qe (qe_cooper\<^sub>1 \<circ> hd_coeffs1)"

lemma qfree_cooper1_hd_coeffs1: "qfree \<phi> \<Longrightarrow> qfree (qe_cooper\<^sub>1 (hd_coeffs1 \<phi>))"
by(auto simp:qe_cooper\<^sub>1_def hd_coeffs1_def qfree_map_fm
        intro!: qfree_or qfree_and qfree_list_disj qfree_min_inf)

lemma normal_min_inf: "Z.normal \<phi> \<Longrightarrow> Z.normal(inf\<^sub>- \<phi>)"
by(induct \<phi> rule:min_inf.induct) simp_all

lemma normal_cooper1: "Z.normal \<phi> \<Longrightarrow> Z.normal(qe_cooper\<^sub>1 \<phi>)"
by(simp add:qe_cooper\<^sub>1_def Logic.or_def Z.normal_map_fm normal_min_inf split_def)

lemma normal_hd_coeffs1: "qfree \<phi> \<Longrightarrow> Z.normal \<phi> \<Longrightarrow> Z.normal(hd_coeffs1 \<phi>)"
by(auto simp: hd_coeffs1_def image_def set_atoms0_iff
              divisor_hd_coeff1_neq0 Z.normal_def)

theorem I_cooper: "Z.normal \<phi> \<Longrightarrow>  Z.I (qe_cooper \<phi>) xs = Z.I \<phi> xs"
by(simp add:qe_cooper_def Z.I_lift_nnf_qe_normal qfree_cooper1_hd_coeffs1 I_cooper1_hd_coeffs1 normal_cooper1 normal_hd_coeffs1)

theorem qfree_cooper: "qfree (qe_cooper \<phi>)"
by(simp add:qe_cooper_def Z.qfree_lift_nnf_qe qfree_cooper1_hd_coeffs1)

end


header {* Syntax and proof rules for graphical diagrams *}

theory Ribbons_Graphical imports
  Ribbons_Interfaces
begin

text {* We introduce a graphical syntax for diagrams, describe how to extract
  commands and interfaces, and give proof rules for graphical diagrams. *}

subsection {* Syntax of graphical diagrams *}

text {* Fix a type for node identifiers *}
typedecl node

text {* Note that this datatype is necessarily an overapproximation of
  syntactically-wellformed diagrams, for the reason that we can't impose the
  well-formedness constraints while maintaining admissibility of the datatype
  declarations. So, we shall impose well-formedness in a separate definition.
  *}

datatype assertion_gadget =
  Rib "assertion"
| Exists_dia "string" "diagram"
and command_gadget =
  Com "command"
| Choose_dia "diagram" "diagram"
| Loop_dia "diagram"
and diagram = Graph
  "node fset"
  "node \<Rightarrow> assertion_gadget"
  "(node fset \<times> command_gadget \<times> node fset) list"
type_synonym labelling = "node \<Rightarrow> assertion_gadget"
type_synonym edge = "node fset \<times> command_gadget \<times> node fset"

text {* Projecting components from a graph *}

fun vertices :: "diagram \<Rightarrow> node fset" ("_^V" [1000] 1000)
where "(Graph V \<Lambda> E)^V = V"

term "this (is^V) = (a test)^V"

fun labelling :: "diagram \<Rightarrow> labelling" ("_^\<Lambda>" [1000] 1000)
where "(Graph V \<Lambda> E)^\<Lambda> = \<Lambda>"

fun edges :: "diagram \<Rightarrow> edge list" ("_^E" [1000] 1000)
where "(Graph V \<Lambda> E)^E = E"

subsection {* Well formedness of graphical diagrams *}

definition acyclicity :: "edge list \<Rightarrow> bool"
where
  "acyclicity E \<equiv> acyclic (\<Union>e \<in> set E. fset (fst3 e) \<times> fset (thd3 e))"

definition linearity :: "edge list \<Rightarrow> bool"
where
  "linearity E \<equiv>
    distinct E \<and> (\<forall>e \<in> set E. \<forall>f \<in> set E. e \<noteq> f \<longrightarrow>
    fst3 e |\<inter>| fst3 f = {||} \<and>
    thd3 e |\<inter>| thd3 f = {||})"

lemma linearityD:
  assumes "linearity E"
  shows "distinct E"
  and "\<And>e f. \<lbrakk> e \<in> set E ; f \<in> set E ; e \<noteq> f \<rbrakk> \<Longrightarrow>
    fst3 e |\<inter>| fst3 f = {||} \<and>
    thd3 e |\<inter>| thd3 f = {||}"
using assms unfolding linearity_def by auto

lemma linearityD2:
  "linearity E \<Longrightarrow> (\<forall>e f. e \<in> set E \<and> f \<in> set E \<and> e \<noteq> f \<longrightarrow>
    fst3 e |\<inter>| fst3 f = {||} \<and>
    thd3 e |\<inter>| thd3 f = {||})"
using assms unfolding linearity_def by auto

inductive
  wf_ass :: "assertion_gadget \<Rightarrow> bool" and
  wf_com :: "command_gadget \<Rightarrow> bool" and
  wf_dia :: "diagram \<Rightarrow> bool"
where
  wf_rib: "wf_ass (Rib p)"
| wf_exists: "wf_dia G \<Longrightarrow> wf_ass (Exists_dia x G)"
| wf_com: "wf_com (Com c)"
| wf_choice: "\<lbrakk> wf_dia G ; wf_dia H \<rbrakk> \<Longrightarrow> wf_com (Choose_dia G H)"
| wf_loop: "wf_dia G \<Longrightarrow> wf_com (Loop_dia G)"
| wf_dia: "\<lbrakk> \<forall>e \<in> set E. wf_com (snd3 e) ; \<forall>v \<in> fset V. wf_ass (\<Lambda> v) ;
  acyclicity E ; linearity E ; \<forall>e \<in> set E. fst3 e |\<union>| thd3 e |\<subseteq>| V \<rbrakk> \<Longrightarrow>
  wf_dia (Graph V \<Lambda> E)"

inductive_cases wf_dia_inv': "wf_dia (Graph V \<Lambda> E)"

lemma wf_dia_inv:
  assumes "wf_dia (Graph V \<Lambda> E)"
  shows "\<forall>v \<in> fset V. wf_ass (\<Lambda> v)"
    and "\<forall>e \<in> set E. wf_com (snd3 e)"
    and "acyclicity E"
    and "linearity E"
    and "\<forall>e \<in> set E. fst3 e |\<union>| thd3 e |\<subseteq>| V"
using assms
apply -  (* This acts as an intro rule for &&& *)
apply (elim wf_dia_inv', simp)+
done

subsection {* Initial and terminal nodes *}

definition
  initials :: "diagram \<Rightarrow> node fset"
where
  "initials G = ffilter (\<lambda>v. (\<forall>e \<in> set G^E. v |\<notin>| thd3 e)) G^V"

definition
   terminals :: "diagram \<Rightarrow> node fset"
where
  "terminals G = ffilter (\<lambda>v. (\<forall>e \<in> set G^E. v |\<notin>| fst3 e)) G^V"

lemma no_edges_imp_all_nodes_initial:
  "initials (Graph V \<Lambda> []) = V"
by (auto simp add: initials_def)

lemma no_edges_imp_all_nodes_terminal:
  "terminals (Graph V \<Lambda> []) = V"
by (auto simp add: terminals_def)

lemma initials_in_vertices:
   "initials G |\<subseteq>| G^V"
unfolding initials_def by auto

lemma terminals_in_vertices:
   "terminals G |\<subseteq>| G^V"
unfolding terminals_def by auto

subsection {* Top and bottom interfaces *}

primrec
  top_ass :: "assertion_gadget \<Rightarrow> interface" and
  top_dia :: "diagram \<Rightarrow> interface"
where
  "top_dia (Graph V \<Lambda> E) = (\<Otimes>v |\<in>| initials (Graph V \<Lambda> E). top_ass (\<Lambda> v))"
| "top_ass (Rib p) = Ribbon p"
| "top_ass (Exists_dia x G) = Exists_int x (top_dia G)"

primrec
  bot_ass :: "assertion_gadget \<Rightarrow> interface" and
  bot_dia :: "diagram \<Rightarrow> interface"
where
  "bot_dia (Graph V \<Lambda> E) = (\<Otimes>v |\<in>| terminals (Graph V \<Lambda> E). bot_ass (\<Lambda> v))"
| "bot_ass (Rib p) = Ribbon p"
| "bot_ass (Exists_dia x G) = Exists_int x (bot_dia G)"

subsection {* Proof rules for graphical diagrams *}

inductive
  prov_dia :: "[diagram, interface, interface] \<Rightarrow> bool" and
  prov_com :: "[command_gadget, interface, interface] \<Rightarrow> bool" and
  prov_ass :: "assertion_gadget \<Rightarrow> bool"
where
  Skip: "prov_ass (Rib p)"
| Exists: "prov_dia G _ _ \<Longrightarrow> prov_ass (Exists_dia x G)"
| Basic: "prov_triple (asn P, c, asn Q) \<Longrightarrow> prov_com (Com c) P Q"
| Choice: "\<lbrakk> prov_dia G P Q ; prov_dia H P Q \<rbrakk>
    \<Longrightarrow> prov_com (Choose_dia G H) P Q"
| Loop: "prov_dia G P P \<Longrightarrow> prov_com (Loop_dia G) P P"
| Main: "\<lbrakk> wf_dia G ; \<And>v. v \<in> fset G^V \<Longrightarrow> prov_ass (G^\<Lambda> v);
    \<And>e. e \<in> set G^E \<Longrightarrow> prov_com (snd3 e)
      (\<Otimes>v |\<in>| fst3 e. bot_ass (G^\<Lambda> v))
      (\<Otimes>v |\<in>| thd3 e. top_ass (G^\<Lambda> v))\<rbrakk>
    \<Longrightarrow> prov_dia G (top_dia G) (bot_dia G)"

inductive_cases main_inv: "prov_dia (Graph V \<Lambda> E) P Q"
inductive_cases loop_inv: "prov_com (Loop_dia G) P Q"
inductive_cases choice_inv: "prov_com (Choose_dia G H) P Q"
inductive_cases basic_inv: "prov_com (Com c) P Q"
inductive_cases exists_inv: "prov_ass (Exists_dia x G)"
inductive_cases skip_inv: "prov_ass (Rib p)"

subsection {* Extracting commands from diagrams *}

type_synonym lin = "(node + edge) list"

text {* A linear extension (lin) of a diagram is a list of its nodes and edges
  which respects the order of those nodes and edges. That is, if an edge
  @{term e} goes from node @{term v} to node @{term w}, then @{term v} and
  @{term e} and @{term w} must have strictly increasing positions in the list.
  *}

definition lins :: "diagram \<Rightarrow> lin set"
where
"lins G \<equiv> {\<pi> :: lin.
    (distinct \<pi>)
  \<and> (set \<pi> = (fset G^V) <+> (set G^E))
  \<and> (\<forall>i j v e. i < length \<pi> \<and> j < length \<pi> \<and> \<pi>!i = Inl v \<and> \<pi>!j = Inr e
    \<and> v |\<in>| fst3 e \<longrightarrow> i<j)
  \<and> (\<forall>j k w e. j < length \<pi> \<and> k < length \<pi> \<and> \<pi>!j = Inr e \<and> \<pi>!k = Inl w
    \<and> w |\<in>| thd3 e \<longrightarrow> j<k) }"

lemma linsD:
  assumes "\<pi> \<in> lins G"
  shows "(distinct \<pi>)"
    and "(set \<pi> = (fset G^V) <+> (set G^E))"
    and "(\<forall>i j v e. i < length \<pi> \<and> j < length \<pi>
     \<and> \<pi>!i = Inl v \<and> \<pi>!j = Inr e \<and> v |\<in>| fst3 e \<longrightarrow> i<j)"
    and "(\<forall>j k w e. j < length \<pi> \<and> k < length \<pi>
     \<and> \<pi>!j = Inr e \<and> \<pi>!k = Inl w \<and> w |\<in>| thd3 e \<longrightarrow> j<k)"
using assms
apply -
apply (unfold lins_def Collect_iff)
apply (elim conjE, assumption)+
done

text {* The following lemma enables the inductive definition below to be
  proved monotonic. It does this by showing how one of the premises of the
  @{term coms_main} rule can be rewritten in a form that is more verbose but
  easier to prove monotonic. *}

lemma coms_mono_helper:
  "(\<forall>i<length \<pi>. case_sum (coms_ass \<circ> \<Lambda>) (coms_com \<circ> snd3) (\<pi>!i) (cs!i))
  =
  ((\<forall>i. i<length \<pi> \<and> (\<exists>v. (\<pi>!i) = Inl v) \<longrightarrow>
    coms_ass (\<Lambda> (projl (\<pi>!i))) (cs!i)) \<and>
  (\<forall>i. i<length \<pi> \<and> (\<exists>e. (\<pi>!i) = Inr e) \<longrightarrow>
    coms_com (snd3 (projr (\<pi>!i))) (cs!i)))"
apply (intro iffI)
apply auto[1]
apply (intro allI impI, case_tac "\<pi>!i", auto)
done

text {* The @{term coms_dia} function extracts a set of commands from a
  diagram. Each command in @{term "coms_dia G"} is obtained by extracting a
  command from each of @{term G}'s nodes and edges (using @{term coms_ass} or
  @{term coms_com} respectively), then picking a linear extension @{term \<pi>} of
  these nodes and edges (using @{term lins}), and composing the extracted
  commands in accordance with @{term \<pi>}.
*}

inductive
  coms_dia :: "[diagram, command] \<Rightarrow> bool" and
  coms_ass :: "[assertion_gadget, command] \<Rightarrow> bool" and
  coms_com :: "[command_gadget, command] \<Rightarrow> bool"
where
  coms_skip: "coms_ass (Rib p) Skip"
| coms_exists: "coms_dia G c \<Longrightarrow> coms_ass (Exists_dia x G) c"
| coms_basic: "coms_com (Com c) c"
| coms_choice: "\<lbrakk> coms_dia G c; coms_dia H d \<rbrakk> \<Longrightarrow>
    coms_com (Choose_dia G H) (Choose c d)"
| coms_loop: "coms_dia G c \<Longrightarrow> coms_com (Loop_dia G) (Loop c)"
| coms_main: "\<lbrakk> \<pi> \<in> lins (Graph V \<Lambda> E); length cs = length \<pi>;
    \<forall>i<length \<pi>. case_sum (coms_ass \<circ> \<Lambda>) (coms_com \<circ> snd3) (\<pi>!i) (cs!i) \<rbrakk>
    \<Longrightarrow> coms_dia (Graph V \<Lambda> E) (foldr (op ;;) cs Skip)"
monos
  coms_mono_helper

inductive_cases coms_skip_inv: "coms_ass (Rib p) c"
inductive_cases coms_exists_inv: "coms_ass (Exists_dia x G) c"
inductive_cases coms_basic_inv: "coms_com (Com c') c"
inductive_cases coms_choice_inv: "coms_com (Choose_dia G H) c"
inductive_cases coms_loop_inv: "coms_com (Loop_dia G) c"
inductive_cases coms_main_inv: "coms_dia G c"

end


(*   This file is a part of IsarMathLib -
    a library of formalized mathematics for Isabelle/Isar.

    Copyright (C) 2005, 2006  Slawomir Kolodynski

    This program is free software; Redistribution and use in source and binary forms,
    with or without modification, are permitted provided that the following conditions are met:

   1. Redistributions of source code must retain the above copyright notice,
   this list of conditions and the following disclaimer.
   2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation and/or
   other materials provided with the distribution.
   3. The name of the author may not be used to endorse or promote products
   derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

*)

section \<open>Ordered fields\<close>

theory OrderedField_ZF imports OrderedRing_ZF Field_ZF

begin

text\<open>This theory covers basic facts about ordered fiels.\<close>

subsection\<open>Definition and basic properties\<close>

text\<open>Here we define ordered fields and proove their basic properties.\<close>

text\<open>Ordered field is a notrivial ordered ring such that all
  non-zero elements have an inverse. We define the notion of being a ordered
  field as
  a statement about four sets. The first set, denoted \<open>K\<close> is the
  carrier of the field. The second set, denoted \<open>A\<close> represents the
  additive operation on \<open>K\<close> (recall that in ZF set theory functions
  are sets). The third set \<open>M\<close> represents the multiplicative operation
  on \<open>K\<close>. The fourth set \<open>r\<close> is the order
  relation on \<open>K\<close>.\<close>

definition
  "IsAnOrdField(K,A,M,r) \<equiv> (IsAnOrdRing(K,A,M,r) \<and>
  (M {is commutative on} K) \<and>
  TheNeutralElement(K,A) \<noteq> TheNeutralElement(K,M) \<and>
  (\<forall>a\<in>K. a\<noteq>TheNeutralElement(K,A)\<longrightarrow>
  (\<exists>b\<in>K. M`\<langle>a,b\<rangle> = TheNeutralElement(K,M))))"

text\<open>The next context (locale) defines notation used for ordered fields.
  We do that by extending the notation defined in the
  \<open>ring1\<close> context that is used for oredered rings and
  adding some assumptions to make sure we are
  talking about ordered fields in this context.
  We should rename the carrier from $R$ used in the \<open>ring1\<close>
  context to $K$, more appriopriate for fields. Theoretically the Isar locale
  facility supports such renaming, but we experienced diffculties using
  some lemmas from \<open>ring1\<close> locale after renaming.
\<close>

locale field1 = ring1 +

  assumes mult_commute: "M {is commutative on} R"

  assumes not_triv: "\<zero> \<noteq> \<one>"

  assumes inv_exists: "\<forall>a\<in>R. a\<noteq>\<zero> \<longrightarrow> (\<exists>b\<in>R. a\<cdot>b = \<one>)"

  fixes non_zero ("R\<^sub>0")
  defines non_zero_def[simp]: "R\<^sub>0 \<equiv> R-{\<zero>}"

  fixes inv ("_\<inverse> " [96] 97)
  defines inv_def[simp]: "a\<inverse> \<equiv> GroupInv(R\<^sub>0,restrict(M,R\<^sub>0\<times>R\<^sub>0))`(a)"

text\<open>The next lemma assures us that we are talking fields
  in the \<open>field1\<close> context.\<close>

lemma (in field1) OrdField_ZF_1_L1: shows "IsAnOrdField(R,A,M,r)"
  using OrdRing_ZF_1_L1 mult_commute not_triv inv_exists IsAnOrdField_def
  by simp

text\<open>Ordered field is a field, of course.\<close>

lemma OrdField_ZF_1_L1A: assumes "IsAnOrdField(K,A,M,r)"
  shows "IsAfield(K,A,M)"
  using assms IsAnOrdField_def IsAnOrdRing_def IsAfield_def
  by simp

text\<open>Theorems proven in \<open>field0\<close> (about fields) context are valid
  in the \<open>field1\<close> context (about ordered fields).\<close>

lemma (in field1) OrdField_ZF_1_L1B: shows "field0(R,A,M)"
  using OrdField_ZF_1_L1 OrdField_ZF_1_L1A field_field0
  by simp

text\<open>We can use theorems proven in the \<open>field1\<close> context whenever we
  talk about an ordered field.\<close>

lemma OrdField_ZF_1_L2: assumes "IsAnOrdField(K,A,M,r)"
  shows "field1(K,A,M,r)"
  using assms IsAnOrdField_def OrdRing_ZF_1_L2 ring1_def
    IsAnOrdField_def field1_axioms_def field1_def
  by auto

text\<open>In ordered rings the existence of a right inverse for all positive
  elements implies the existence of an inverse for all non zero elements.\<close>

lemma (in ring1) OrdField_ZF_1_L3:
  assumes A1: "\<forall>a\<in>R\<^sub>+. \<exists>b\<in>R. a\<cdot>b = \<one>" and A2: "c\<in>R"  "c\<noteq>\<zero>"
  shows "\<exists>b\<in>R. c\<cdot>b = \<one>"
proof -
  { assume "c\<in>R\<^sub>+"
    with A1 have "\<exists>b\<in>R. c\<cdot>b = \<one>" by simp }
  moreover
  { assume "c\<notin>R\<^sub>+"
    with A2 have "(\<rm>c) \<in> R\<^sub>+"
      using OrdRing_ZF_3_L2A by simp
    with A1 obtain b where "b\<in>R" and "(\<rm>c)\<cdot>b = \<one>"
      by auto
    with A2 have "(\<rm>b) \<in> R"  "c\<cdot>(\<rm>b) = \<one>"
      using Ring_ZF_1_L3 Ring_ZF_1_L7 by auto
    then have "\<exists>b\<in>R. c\<cdot>b = \<one>" by auto }
  ultimately show ?thesis by blast
qed

text\<open>Ordered fields are easier to deal with, because it is sufficient
  to show the existence of an inverse for the set of positive elements.\<close>

lemma (in ring1) OrdField_ZF_1_L4:
  assumes "\<zero> \<noteq> \<one>" and "M {is commutative on} R"
  and "\<forall>a\<in>R\<^sub>+. \<exists>b\<in>R. a\<cdot>b = \<one>"
  shows "IsAnOrdField(R,A,M,r)"
  using assms OrdRing_ZF_1_L1 OrdField_ZF_1_L3 IsAnOrdField_def
  by simp

text\<open>The set of positive field elements is closed under multiplication.\<close>

lemma (in field1) OrdField_ZF_1_L5: shows "R\<^sub>+ {is closed under} M"
  using OrdField_ZF_1_L1B field0.field_has_no_zero_divs OrdRing_ZF_3_L3
  by simp

text\<open>The set of positive field elements is closed under multiplication:
  the explicit version.\<close>

lemma (in field1) pos_mul_closed:
  assumes A1: "\<zero> \<ls> a"  "\<zero> \<ls> b"
  shows "\<zero> \<ls> a\<cdot>b"
proof -
  from A1 have "a \<in> R\<^sub>+" and  "b \<in> R\<^sub>+"
    using OrdRing_ZF_3_L14 by auto
  then show "\<zero> \<ls> a\<cdot>b"
    using OrdField_ZF_1_L5 IsOpClosed_def PositiveSet_def
    by simp
qed

text\<open>In fields square of a nonzero element is positive.\<close>

lemma (in field1) OrdField_ZF_1_L6: assumes "a\<in>R"  "a\<noteq>\<zero>"
  shows "a\<^sup>2 \<in> R\<^sub>+"
  using assms OrdField_ZF_1_L1B field0.field_has_no_zero_divs
    OrdRing_ZF_3_L15 by simp

text\<open>The next lemma restates the fact \<open>Field_ZF\<close> that out notation
  for the field inverse means what it is supposed to mean.\<close>

lemma (in field1) OrdField_ZF_1_L7: assumes "a\<in>R"  "a\<noteq>\<zero>"
  shows "a\<cdot>(a\<inverse>) = \<one>"  "(a\<inverse>)\<cdot>a = \<one>"
  using assms OrdField_ZF_1_L1B field0.Field_ZF_1_L6
  by auto

text\<open>A simple lemma about multiplication and cancelling of a positive field
   element.\<close>

lemma (in field1) OrdField_ZF_1_L7A:
  assumes A1: "a\<in>R"  "b \<in> R\<^sub>+"
  shows
  "a\<cdot>b\<cdot>b\<inverse> = a"
  "a\<cdot>b\<inverse>\<cdot>b = a"
proof -
  from A1 have "b\<in>R"  "b\<noteq>\<zero>" using PositiveSet_def
    by auto
  with A1 show  "a\<cdot>b\<cdot>b\<inverse> = a" and "a\<cdot>b\<inverse>\<cdot>b = a"
    using OrdField_ZF_1_L1B field0.Field_ZF_1_L7
    by auto
qed

text\<open>Some properties of the inverse of a positive element.\<close>

lemma (in field1) OrdField_ZF_1_L8: assumes A1: "a \<in> R\<^sub>+"
  shows "a\<inverse> \<in> R\<^sub>+"  "a\<cdot>(a\<inverse>) = \<one>"  "(a\<inverse>)\<cdot>a = \<one>"
proof -
  from A1 have I: "a\<in>R"  "a\<noteq>\<zero>" using PositiveSet_def
    by auto
  with A1 have "a\<cdot>(a\<inverse>)\<^sup>2 \<in> R\<^sub>+"
    using OrdField_ZF_1_L1B field0.Field_ZF_1_L5 OrdField_ZF_1_L6
      OrdField_ZF_1_L5 IsOpClosed_def by simp
  with I show "a\<inverse> \<in> R\<^sub>+"
    using OrdField_ZF_1_L1B field0.Field_ZF_2_L1
    by simp
  from I show  "a\<cdot>(a\<inverse>) = \<one>"  "(a\<inverse>)\<cdot>a = \<one>"
    using OrdField_ZF_1_L7 by auto
qed

text\<open>If $a$ is smaller than $b$, then $(b-a)^{-1}$ is positive.\<close>

lemma (in field1) OrdField_ZF_1_L9: assumes "a\<ls>b"
  shows  "(b\<rs>a)\<inverse> \<in> R\<^sub>+"
  using assms OrdRing_ZF_1_L14 OrdField_ZF_1_L8
  by simp

text\<open>In ordered fields if at least one of $a,b$ is not zero, then
  $a^2+b^2 > 0$, in particular $a^2+b^2\neq 0$ and exists the
  (multiplicative) inverse of $a^2+b^2$.\<close>

lemma (in field1) OrdField_ZF_1_L10:
  assumes A1: "a\<in>R"  "b\<in>R" and A2: "a \<noteq> \<zero> \<or> b \<noteq> \<zero>"
  shows "\<zero> \<ls> a\<^sup>2 \<ra> b\<^sup>2"  and "\<exists>c\<in>R. (a\<^sup>2 \<ra> b\<^sup>2)\<cdot>c = \<one>"
proof -
  from A1 A2 show "\<zero> \<ls> a\<^sup>2 \<ra> b\<^sup>2"
    using OrdField_ZF_1_L1B field0.field_has_no_zero_divs
      OrdRing_ZF_3_L19 by simp
  then have
    "(a\<^sup>2 \<ra> b\<^sup>2)\<inverse> \<in> R" and "(a\<^sup>2 \<ra> b\<^sup>2)\<cdot>(a\<^sup>2 \<ra> b\<^sup>2)\<inverse> = \<one>"
    using OrdRing_ZF_1_L3 PositiveSet_def OrdField_ZF_1_L8
    by auto
  then show "\<exists>c\<in>R. (a\<^sup>2 \<ra> b\<^sup>2)\<cdot>c = \<one>" by auto
qed

subsection\<open>Inequalities\<close>

text\<open>In this section we develop tools to deal inequalities in fields.\<close>

text\<open>We can multiply strict inequality by a positive element.\<close>

lemma (in field1) OrdField_ZF_2_L1:
  assumes "a\<ls>b" and "c\<in>R\<^sub>+"
  shows "a\<cdot>c \<ls> b\<cdot>c"
  using assms OrdField_ZF_1_L1B field0.field_has_no_zero_divs
    OrdRing_ZF_3_L13
  by simp

text\<open>A special case of \<open>OrdField_ZF_2_L1\<close> when we multiply
  an inverse by an element.\<close>

lemma (in field1) OrdField_ZF_2_L2:
  assumes A1: "a\<in>R\<^sub>+" and A2: "a\<inverse> \<ls> b"
  shows "\<one> \<ls> b\<cdot>a"
proof -
  from A1 A2 have "(a\<inverse>)\<cdot>a \<ls> b\<cdot>a"
    using OrdField_ZF_2_L1 by simp
  with A1 show "\<one> \<ls> b\<cdot>a"
    using OrdField_ZF_1_L8 by simp
qed

text\<open>We can multiply an inequality by the inverse of a positive element.\<close>

lemma (in field1) OrdField_ZF_2_L3:
  assumes "a\<lsq>b"  and "c\<in>R\<^sub>+" shows "a\<cdot>(c\<inverse>) \<lsq> b\<cdot>(c\<inverse>)"
  using assms OrdField_ZF_1_L8 OrdRing_ZF_1_L9A
  by simp

text\<open>We can multiply a strict inequality by a  positive element
  or its inverse.\<close>

lemma (in field1) OrdField_ZF_2_L4:
  assumes "a\<ls>b" and "c\<in>R\<^sub>+"
  shows
  "a\<cdot>c \<ls> b\<cdot>c"
  "c\<cdot>a \<ls> c\<cdot>b"
  "a\<cdot>c\<inverse> \<ls> b\<cdot>c\<inverse>"
   using assms OrdField_ZF_1_L1B field0.field_has_no_zero_divs
    OrdField_ZF_1_L8 OrdRing_ZF_3_L13 by auto

text\<open>We can put a positive factor on the other side of an inequality,
  changing it to its inverse.\<close>

lemma (in field1) OrdField_ZF_2_L5:
  assumes A1: "a\<in>R"  "b\<in>R\<^sub>+" and A2: "a\<cdot>b \<lsq> c"
  shows "a \<lsq> c\<cdot>b\<inverse>"
proof -
  from A1 A2 have "a\<cdot>b\<cdot>b\<inverse> \<lsq> c\<cdot>b\<inverse>"
    using OrdField_ZF_2_L3 by simp
  with A1 show "a \<lsq> c\<cdot>b\<inverse>" using OrdField_ZF_1_L7A
    by simp
qed

text\<open>We can put a positive factor on the other side of an inequality,
  changing it to its inverse, version with a product initially on the
  right hand side.\<close>

lemma (in field1) OrdField_ZF_2_L5A:
  assumes A1: "b\<in>R"  "c\<in>R\<^sub>+" and A2: "a \<lsq> b\<cdot>c"
  shows "a\<cdot>c\<inverse> \<lsq> b"
proof -
  from A1 A2 have "a\<cdot>c\<inverse> \<lsq> b\<cdot>c\<cdot>c\<inverse>"
    using OrdField_ZF_2_L3 by simp
  with A1 show "a\<cdot>c\<inverse> \<lsq> b" using OrdField_ZF_1_L7A
    by simp
qed

text\<open>We can put a positive factor on the other side of a strict
  inequality, changing it to its inverse, version with a product
  initially on the left hand side.\<close>

lemma (in field1) OrdField_ZF_2_L6:
  assumes A1: "a\<in>R"  "b\<in>R\<^sub>+" and A2: "a\<cdot>b \<ls> c"
  shows "a \<ls> c\<cdot>b\<inverse>"
proof -
  from A1 A2 have "a\<cdot>b\<cdot>b\<inverse> \<ls> c\<cdot>b\<inverse>"
    using OrdField_ZF_2_L4 by simp
  with A1 show "a \<ls> c\<cdot>b\<inverse>" using OrdField_ZF_1_L7A
    by simp
qed

text\<open>We can put a positive factor on the other side of a strict
  inequality, changing it to its inverse, version with a product
  initially on the right hand side.\<close>

lemma (in field1) OrdField_ZF_2_L6A:
  assumes A1: "b\<in>R"  "c\<in>R\<^sub>+" and A2: "a \<ls> b\<cdot>c"
  shows "a\<cdot>c\<inverse> \<ls> b"
proof -
  from A1 A2 have "a\<cdot>c\<inverse> \<ls> b\<cdot>c\<cdot>c\<inverse>"
    using OrdField_ZF_2_L4 by simp
  with A1 show "a\<cdot>c\<inverse> \<ls> b" using OrdField_ZF_1_L7A
    by simp
qed

text\<open>Sometimes we can reverse an inequality by taking inverse
  on both sides.\<close>

lemma (in field1) OrdField_ZF_2_L7:
  assumes A1: "a\<in>R\<^sub>+" and A2: "a\<inverse> \<lsq> b"
  shows "b\<inverse> \<lsq> a"
proof -
  from A1 have "a\<inverse> \<in> R\<^sub>+" using OrdField_ZF_1_L8
    by simp
  with A2 have "b \<in> R\<^sub>+" using  OrdRing_ZF_3_L7
    by blast
  then have T: "b \<in> R\<^sub>+"  "b\<inverse> \<in> R\<^sub>+" using OrdField_ZF_1_L8
    by auto
  with A1 A2 have "b\<inverse>\<cdot>a\<inverse>\<cdot>a \<lsq> b\<inverse>\<cdot>b\<cdot>a"
    using OrdRing_ZF_1_L9A by simp
  moreover
  from A1 A2 T have
    "b\<inverse> \<in> R"  "a\<in>R" "a\<noteq>\<zero>"  "b\<in>R"  "b\<noteq>\<zero>"
    using PositiveSet_def OrdRing_ZF_1_L3 by auto
  then have "b\<inverse>\<cdot>a\<inverse>\<cdot>a = b\<inverse>" and  "b\<inverse>\<cdot>b\<cdot>a = a"
    using OrdField_ZF_1_L1B field0.Field_ZF_1_L7
      field0.Field_ZF_1_L6 Ring_ZF_1_L3
    by auto
  ultimately show "b\<inverse> \<lsq> a" by simp
qed

text\<open>Sometimes we can reverse a strict inequality by taking inverse
  on both sides.\<close>

lemma (in field1) OrdField_ZF_2_L8:
  assumes A1: "a\<in>R\<^sub>+" and A2: "a\<inverse> \<ls> b"
  shows "b\<inverse> \<ls> a"
proof -
  from A1 A2 have "a\<inverse> \<in> R\<^sub>+"  "a\<inverse> \<lsq>b"
    using OrdField_ZF_1_L8 by auto
  then have "b \<in> R\<^sub>+" using OrdRing_ZF_3_L7
    by blast
  then have "b\<in>R"  "b\<noteq>\<zero>" using PositiveSet_def by auto
  with A2 have "b\<inverse> \<noteq> a"
    using OrdField_ZF_1_L1B field0.Field_ZF_2_L4
    by simp
  with A1 A2 show "b\<inverse> \<ls> a"
    using OrdField_ZF_2_L7 by simp
qed

text\<open>A technical lemma about solving a strict inequality with three
  field elements and inverse of a difference.\<close>

lemma (in field1) OrdField_ZF_2_L9:
  assumes A1: "a\<ls>b" and A2: "(b\<rs>a)\<inverse> \<ls> c"
  shows "\<one> \<ra> a\<cdot>c \<ls> b\<cdot>c"
proof -
  from A1 A2 have "(b\<rs>a)\<inverse> \<in> R\<^sub>+"  "(b\<rs>a)\<inverse> \<lsq> c"
    using OrdField_ZF_1_L9 by auto
  then have T1: "c \<in> R\<^sub>+" using OrdRing_ZF_3_L7 by blast
  with A1 A2 have T2:
    "a\<in>R"  "b\<in>R"  "c\<in>R"  "c\<noteq>\<zero>"   "c\<inverse> \<in> R"
    using OrdRing_ZF_1_L3 OrdField_ZF_1_L8 PositiveSet_def
    by auto
  with A1 A2  have "c\<inverse> \<ra> a \<ls> b\<rs>a \<ra> a"
    using OrdRing_ZF_1_L14 OrdField_ZF_2_L8 ring_strict_ord_trans_inv
    by simp
  with T1 T2 have "(c\<inverse> \<ra> a)\<cdot>c \<ls> b\<cdot>c"
    using Ring_ZF_2_L1A OrdField_ZF_2_L1 by simp
  with T1 T2 show "\<one> \<ra> a\<cdot>c \<ls> b\<cdot>c"
    using ring_oper_distr OrdField_ZF_1_L8
    by simp
qed

subsection\<open>Definition of real numbers\<close>

text\<open>The only purpose of this section is to define what does it mean
  to be a model of real numbers.\<close>

text\<open>We define model of real numbers as any quadruple of sets $(K,A,M,r)$
  such that $(K,A,M,r)$ is an ordered field and the order relation $r$
  is complete, that is every set that is nonempty and bounded above in this
  relation has a supremum.\<close>

definition
  "IsAmodelOfReals(K,A,M,r) \<equiv> IsAnOrdField(K,A,M,r) \<and> (r {is complete})"

end


(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Jordan Normal Form -- Uniqueness\<close>

text \<open>We prove that the Jordan normal form of a matrix
  is unique up to permutations of the blocks. We do this
  via generalized eigenspaces, and an algorithm which
  computes for each potential jordan block (ev,n), how often
  it occurs in any Jordan normal form.\<close>

theory Jordan_Normal_Form_Uniqueness
imports
  Jordan_Normal_Form
  Matrix_Kernel
begin

lemma similar_mat_wit_char_matrix: assumes wit: "similar_mat_wit A B P Q"
  shows "similar_mat_wit (char_matrix A ev) (char_matrix B ev) P Q"
proof -
  define n where "n = dim_row A"
  let ?C = "carrier_mat n n"
  from similar_mat_witD[OF refl wit, folded n_def] have
    A: "A \<in> ?C" and B: "B \<in> ?C" and P: "P \<in> ?C" and Q: "Q \<in> ?C"
    and PQ: "P * Q = 1\<^sub>m n" and QP: "Q * P = 1\<^sub>m n"
    and AB: "A = P * B * Q"
    by auto
  have "char_matrix A ev = (P * B * Q + (-ev) \<cdot>\<^sub>m (P * Q))"
    unfolding char_matrix_def n_def[symmetric] unfolding AB PQ
    by (intro eq_matI, insert P B Q, auto)
  also have "(-ev) \<cdot>\<^sub>m (P * Q) = P * ((-ev) \<cdot>\<^sub>m 1\<^sub>m n) * Q" using P Q
    by (metis mult_smult_assoc_mat mult_smult_distrib one_carrier_mat right_mult_one_mat)
  also have "P * B * Q + \<dots> = (P * B + P * ((-ev) \<cdot>\<^sub>m 1\<^sub>m n)) * Q" using P B
    by (intro add_mult_distrib_mat[symmetric, OF _ _ Q, of _ n], auto)
  also have "P * B + P * ((-ev) \<cdot>\<^sub>m 1\<^sub>m n) = P * (B  + (-ev) \<cdot>\<^sub>m 1\<^sub>m n)"
    by (intro mult_add_distrib_mat[symmetric, OF P B], auto)
  also have "(B  + (-ev) \<cdot>\<^sub>m 1\<^sub>m n) = char_matrix B ev" unfolding char_matrix_def
    by (intro eq_matI, insert B, auto)
  finally have AB: "char_matrix A ev = P * char_matrix B ev * Q" .
  show "similar_mat_wit (char_matrix A ev) (char_matrix B ev) P Q"
    by (intro similar_mat_witI[OF PQ QP AB _ _ P Q], insert A B, auto)
qed

context fixes ty :: "'a :: field itself"
begin

lemma dim_kernel_non_zero_jordan_block_pow: assumes a: "a \<noteq> 0"
  shows "kernel.dim n (jordan_block n (a :: 'a) ^\<^sub>m k) = 0"
  by (rule kernel_upper_triangular[OF pow_carrier_mat[OF jordan_block_carrier]],
  unfold jordan_block_pow, insert a, auto simp: diag_mat_def)

lemma dim_kernel_zero_jordan_block_pow:
  "kernel.dim n ((jordan_block n (0 :: 'a)) ^\<^sub>m k) = min k n" (is "kernel.dim _ ?A = ?c")
proof -
  have A: "?A \<in> carrier_mat n n" by auto
  hence dim: "dim_row ?A = n" by simp
  let ?f = "\<lambda> i. min (k + i) n"
  have piv: "pivot_fun ?A ?f n" unfolding jordan_block_zero_pow
    by (intro pivot_funI, auto)
  hence row: "row_echelon_form ?A" unfolding row_echelon_form_def by auto
  from find_base_vectors(5-6)[OF row A]
  have "kernel.dim n ?A = n - length (map fst (pivot_positions ?A))" by auto
  also have "length (map fst (pivot_positions ?A)) = card (fst ` set (pivot_positions ?A))"
    by (subst distinct_card[OF pivot_positions(2)[OF A piv], symmetric], simp)
  also have "fst ` set (pivot_positions ?A) = { 0 ..< (n - ?c)}" unfolding pivot_positions(1)[OF A piv]
    by force
  also have "card \<dots> = n - ?c" by simp
  finally show ?thesis by simp
qed

definition dim_gen_eigenspace :: "'a mat \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> nat" where
  "dim_gen_eigenspace A ev k = kernel_dim ((char_matrix A ev) ^\<^sub>m k)"

lemma dim_gen_eigenspace_jordan_matrix:
  "dim_gen_eigenspace (jordan_matrix n_as) ev k
    = (\<Sum> n \<leftarrow> map fst [(n, e)\<leftarrow>n_as . e = ev]. min k n)"
proof -
  let ?JM = "\<lambda> n_as. jordan_matrix n_as"
  let ?CM = "\<lambda> n_as. char_matrix (?JM n_as) ev"
  let ?A = "\<lambda> n_as. (?CM n_as) ^\<^sub>m k"
  let ?n = "\<lambda> n_as. sum_list (map fst n_as)"
  let ?C = "\<lambda> n_as. carrier_mat (?n n_as) (?n n_as)"
  let ?sum = "\<lambda> n_as. \<Sum> n \<leftarrow> map fst [(n, e)\<leftarrow>n_as . e = ev]. min k n"
  let ?dim = "\<lambda> n_as. sum_list (map fst n_as)"
  let ?kdim = "\<lambda> n_as. kernel.dim (?dim n_as) (?A n_as)"
  have JM: "\<And> n_as. ?JM n_as \<in> ?C n_as" by auto
  have CM: "\<And> n_as. ?CM n_as \<in> ?C n_as" by auto
  have A: "\<And> n_as. ?A n_as \<in> ?C n_as" by auto
  have dimc: "dim_col (?JM n_as) = ?dim n_as" by simp
  interpret K: kernel "?dim n_as" "?dim n_as" "?A n_as"
    by (unfold_locales, rule A)
  show ?thesis unfolding dim_gen_eigenspace_def K.kernel_dim
  proof (induct n_as)
    case Nil
    have "?JM Nil = 1\<^sub>m 0" unfolding jordan_matrix_def
      by (intro eq_matI, auto)
    hence id: "?A Nil = 1\<^sub>m 0" unfolding char_matrix_def by auto
    show ?case unfolding id using kernel_one_mat[of 0] by auto
  next
    case (Cons ne n_as')
    let ?n_as = "Cons ne n_as'"
    let ?d = "?dim ?n_as"
    let ?d' = "?dim n_as'"
    obtain n e where ne: "ne = (n,e)" by force
    have dim: "?d = n + ?d'" unfolding ne by simp
    let ?jb = "jordan_block n e"
    let ?cm = "char_matrix ?jb ev"
    let ?a = "?cm ^\<^sub>m k"
    have a: "?a \<in> carrier_mat n n" by simp
    from JM[of n_as'] have dim_rec: "dim_row (?JM n_as') = ?d'" "dim_col (?JM n_as') = ?d'" by auto
    hence JM_id: "?JM ?n_as = four_block_mat ?jb (0\<^sub>m n ?d') (0\<^sub>m ?d' n) (?JM n_as')"
      unfolding ne jordan_matrix_def using JM[of n_as']
      by (simp add: Let_def)
    have CM_id: "?CM ?n_as = four_block_mat ?cm (0\<^sub>m n ?d') (0\<^sub>m ?d' n) (?CM n_as')"
      unfolding JM_id
      unfolding char_matrix_def
      by (intro eq_matI, auto)
    have A_id: "?A ?n_as = four_block_mat ?a (0\<^sub>m n ?d') (0\<^sub>m ?d' n) (?A n_as')"
      unfolding CM_id by (rule pow_four_block_mat[OF _ CM], auto)
    have kdim: "?kdim ?n_as = kernel.dim n ?a + ?kdim n_as'"
      unfolding dim A_id
      by (rule kernel_four_block_0_mat[OF refl a A])
    also have "?kdim n_as' = ?sum n_as'" by (rule Cons)
    also have "kernel.dim n ?a = (if e = ev then min k n else 0)"
      using dim_kernel_zero_jordan_block_pow[of n k]
        dim_kernel_non_zero_jordan_block_pow[of "e - ev" n k]
      unfolding char_matrix_jordan_block
      by (cases "e = ev", auto)
    also have "\<dots> + ?sum n_as' = ?sum ?n_as" unfolding ne by auto
    finally show ?case .
  qed
qed

lemma dim_gen_eigenspace_similar: assumes sim: "similar_mat A B"
  shows "dim_gen_eigenspace A = dim_gen_eigenspace B"
proof (intro ext)
  fix ev k
  define n where "n = dim_row A"
  from sim[unfolded similar_mat_def] obtain P Q where
    wit: "similar_mat_wit A B P Q" by auto
  let ?C = "carrier_mat n n"
  from similar_mat_witD[OF refl wit, folded n_def]
    have A: "A \<in> ?C" and B: "B \<in> ?C" and P: "P \<in> ?C" and Q: "Q \<in> ?C"
    and PQ: "P * Q = 1\<^sub>m n" and QP: "Q * P = 1\<^sub>m n"
    by auto
  from similar_mat_wit_pow[OF similar_mat_wit_char_matrix[OF wit, of ev], of k]
  have wit: "similar_mat_wit (char_matrix A ev ^\<^sub>m k) (char_matrix B ev ^\<^sub>m k) P Q" .
  from A B have cA: "char_matrix A ev ^\<^sub>m k \<in> carrier_mat n n"
    and cB: "char_matrix B ev ^\<^sub>m k \<in> carrier_mat n n" by auto
  hence dim: "dim_col (char_matrix A ev ^\<^sub>m k) = n" "dim_col (char_matrix B ev ^\<^sub>m k) = n" by auto
  have "dim_gen_eigenspace A ev k = kernel_dim (char_matrix A ev ^\<^sub>m k)"
    unfolding dim_gen_eigenspace_def using A by simp
  also have "\<dots> = kernel_dim (char_matrix B ev ^\<^sub>m k)" unfolding kernel_dim_def dim
    by (rule similar_mat_wit_kernel_dim[OF cA wit])
  also have "\<dots> = dim_gen_eigenspace B ev k"
    unfolding dim_gen_eigenspace_def using B by simp
  finally show "dim_gen_eigenspace A ev k = dim_gen_eigenspace B ev k" .
qed

lemma dim_gen_eigenspace: assumes "jordan_nf A n_as"
  shows "dim_gen_eigenspace A ev k
    = (\<Sum> n \<leftarrow> map fst [(n, e)\<leftarrow>n_as . e = ev]. min k n)"
proof -
  from assms[unfolded jordan_nf_def]
  have sim: "similar_mat A (jordan_matrix n_as)" by auto
  from dim_gen_eigenspace_jordan_matrix[of n_as, folded dim_gen_eigenspace_similar[OF this]]
  show ?thesis .
qed

definition compute_nr_of_jordan_blocks :: "'a mat \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> nat" where
  "compute_nr_of_jordan_blocks A ev k = 2 * dim_gen_eigenspace A ev k -
     dim_gen_eigenspace A ev (k - 1) - dim_gen_eigenspace A ev (Suc k)"

text \<open>This lemma finally shows uniqueness of JNFs. Take an arbitrary
  JNF of a matrix $A$, (encoded by the list of Jordan-blocks @{term n_as}),
  then then number of occurrences of each Jordan-Block in @{term n_as}
  is uniquely determined, namely by @{const compute_nr_of_jordan_blocks}.
  The condition @{term "k \<noteq> (0 :: nat)"}
  is to ensure that we do not count blocks of dimension 0.\<close>

lemma compute_nr_of_jordan_blocks: assumes jnf: "jordan_nf A n_as"
  and no_0: "k \<noteq> 0"
  shows "compute_nr_of_jordan_blocks A ev k = length (filter ((=) (k,ev)) n_as)"
proof -
  from no_0 obtain k1 where k: "k = Suc k1" by (cases k, auto)
  let ?k = "Suc k1" let ?k2 = "Suc ?k"
  let ?dim = "dim_gen_eigenspace A ev"
  let ?sizes = "map fst [(n, e)\<leftarrow>n_as . e = ev]"
  define sizes where "sizes = ?sizes"
  let ?two = "length (filter ((=) (k, ev)) n_as)"
  have "compute_nr_of_jordan_blocks A ev k =
    ?dim ?k + ?dim ?k - ?dim k1 - ?dim ?k2" unfolding compute_nr_of_jordan_blocks_def k by simp
  also have "\<dots> = length (filter ((=) k) ?sizes)"
    unfolding dim_gen_eigenspace[OF jnf] k sizes_def[symmetric]
  proof (rule sym, induct sizes)
    case (Cons s sizes)
    show ?case
    proof (cases "s = ?k")
      case True
      let ?sum = "\<lambda> k sizes. sum_list (map (min k) sizes)"
      let ?len = "\<lambda> sizes. length (filter ((=) ?k) sizes)"
      have len: "?len (s # sizes) = Suc (?len sizes)" unfolding True by simp
      have IH: "?len sizes = ?sum ?k sizes + ?sum ?k sizes -
        ?sum k1 sizes - ?sum ?k2 sizes" by (rule Cons)
      have "?sum ?k (s # sizes) + ?sum ?k (s # sizes) -
        ?sum k1 (s # sizes) - ?sum ?k2 (s # sizes)
        = Suc (?sum ?k sizes + ?sum ?k sizes) -
         (?sum k1 sizes + ?sum ?k2 sizes)"
        using True by simp
      also have "\<dots> = Suc (?sum ?k sizes + ?sum ?k sizes - (?sum k1 sizes + ?sum ?k2 sizes))"
        by (rule Suc_diff_le, induct sizes, auto)
      also have "\<dots> = ?len (s # sizes)" unfolding len IH by simp
      finally show ?thesis by simp
    qed (insert Cons, auto)
  qed simp
  also have "\<dots> = length (filter ((=) (k, ev)) n_as)" by (induct n_as, force+)
  finally show ?thesis .
qed

definition compute_set_of_jordan_blocks :: "'a mat \<Rightarrow> 'a \<Rightarrow> (nat \<times> 'a)list" where
  "compute_set_of_jordan_blocks A ev \<equiv> let
     k = Polynomial.order ev (char_poly A);
     as = map (dim_gen_eigenspace A ev) [0 ..< Suc (Suc k)];
     cards = map (\<lambda> k. (k, 2 * as ! k - as ! (k - 1) - as ! Suc k)) [1 ..< Suc k]
     in map (\<lambda> (k,c). (k,ev)) (filter (\<lambda> (k,c). c \<noteq> 0) cards)"

lemma compute_set_of_jordan_blocks: assumes jnf: "jordan_nf A n_as"
  shows "set (compute_set_of_jordan_blocks A ev) = set n_as \<inter> UNIV \<times> {ev}" (is "?C = ?N'")
proof -
  let ?N = "set n_as \<inter> UNIV \<times> {ev} - {0} \<times> UNIV"
  have N: "?N' = ?N" using jnf[unfolded jordan_nf_def] by force
  note cjb = compute_nr_of_jordan_blocks[OF jnf]
  note d = compute_set_of_jordan_blocks_def Let_def
  define kk where "kk = Polynomial.order ev (char_poly A)"
  define as where "as = map (dim_gen_eigenspace A ev) [0 ..< Suc (Suc kk)]"
  define cards where "cards = map (\<lambda> k. (k, 2 * as ! k - as ! (k - 1) - as ! Suc k)) [1 ..< Suc kk]"
  have C: "?C = set (map (\<lambda> (k,c). (k,ev)) (filter (\<lambda> (k,c). c \<noteq> 0) cards))"
    unfolding d as_def kk_def cards_def by (rule refl)
  {
    fix i
    assume "i < Suc (Suc kk)"
    hence "as ! i = dim_gen_eigenspace A ev i"
      unfolding as_def by (auto simp del: upt_Suc)
  } note as = this
  (* TODO: perhaps use special code equation, and use inefficient thing in definition *)
  have cards: "cards = map (\<lambda> k. (k, compute_nr_of_jordan_blocks A ev k)) [1 ..< Suc kk]"
    unfolding cards_def
    by (rule map_cong[OF refl], insert as, unfold compute_nr_of_jordan_blocks_def, auto)
  have C: "?C = { (k,ev) | k. compute_nr_of_jordan_blocks A ev k \<noteq> 0 \<and> k \<noteq> 0 \<and> k < Suc kk }"
    unfolding C cards by force
  {
    fix k
    have "(k,ev) \<in> ?C \<longleftrightarrow> (k,ev) \<in> ?N"
    proof (cases "k = 0")
      case True
      thus ?thesis unfolding C by auto
    next
      case False
      show ?thesis
      proof (cases "k < Suc kk")
        case True
        have "length (filter ((=) (k, ev)) n_as) \<noteq> 0 \<longleftrightarrow>
          set (filter ((=) (k, ev)) n_as) \<noteq> {}" by blast
        have "(k,ev) \<in> ?N \<longleftrightarrow>  set (filter ((=) (k, ev)) n_as) \<noteq> {}" using False by auto
        also have "\<dots> \<longleftrightarrow> length (filter ((=) (k, ev)) n_as) \<noteq> 0" by blast
        also have "\<dots> \<longleftrightarrow> compute_nr_of_jordan_blocks A ev k \<noteq> 0"
          unfolding compute_nr_of_jordan_blocks[OF jnf False] by simp
        also have "\<dots> \<longleftrightarrow> (k,ev) \<in> ?C" unfolding C using False True by auto
        finally show ?thesis by auto
      next
        case False
        hence "(k,ev) \<notin> ?C" unfolding C by auto
        moreover from False kk_def have k: "k > Polynomial.order ev (char_poly A)" by auto
        with jordan_nf_block_size_order_bound[OF jnf, of k ev]
        have "(k,ev) \<notin> ?N" by auto
        ultimately show ?thesis by simp
      qed
    qed
  }
  thus ?thesis unfolding C N[symmetric] by auto
qed

lemma jordan_nf_unique: assumes "jordan_nf (A :: 'a mat) n_as" and "jordan_nf A m_bs"
shows "set n_as = set m_bs"
proof -
  from compute_set_of_jordan_blocks[OF assms(1), unfolded compute_set_of_jordan_blocks[OF assms(2)]]
  show ?thesis by auto
qed

text \<open>One might get more fine-grained and prove the uniqueness lemma for multisets,
   so one takes multiplicities into account. For the moment we don't require this for
  complexity analysis, so it remains as future work.\<close>

end

end


theory Finiteness
  imports Main "HOL-Eisbach.Eisbach_Tools"
begin

section \<open>Two Eisbach proof methods for finiteness of sets\<close>

text \<open>This theory provides two proof methods for finiteness of sets together with usage examples.\<close>

subsection \<open>Auxiliary\<close>

lemma setcompr_eq_image2:
  "{f x y | x y. P x y} = (\<lambda>(x, y). f x y) ` {(x, y). P x y}"
  using setcompr_eq_image[where f = "(\<lambda>(x, y). f x y)" and P = "\<lambda>(x, y). P x y"] by simp

lemma setcompr_eq_image3:
  "{f x y z | x y z. P x y z} = (\<lambda>(x, y, z). f x y z) ` {(x, y, z). P x y z}"
  using setcompr_eq_image[where f = "(\<lambda>(x, y, z). f x y z)" and P = "\<lambda>(x, y, z). P x y z"] by simp

lemma setcompr_eq_image4:
  "{f a x y z | a x y z. P a x y z} = (\<lambda>(a, x, y, z). f a x y z) ` {(a, x, y, z). P a x y z}"
  using setcompr_eq_image[where f = "(\<lambda>(a, x, y, z). f a x y z)" and P = "\<lambda>(a, x, y, z). P a x y z"]
  by simp

lemma setcompr_eq_image5:
  "{f a b x y z | a b x y z. P a b x y z}
  = (\<lambda>(a, b, x, y, z). f a b x y z) ` {(a, b, x, y, z). P a b x y z}"
  using setcompr_eq_image[where
      f = "(\<lambda>(a, b, x, y, z). f a b x y z)" and P = "\<lambda>(a, b, x, y, z). P a b x y z"]
  by simp

lemmas setcompr_eq_image_all = setcompr_eq_image setcompr_eq_image2

subsection \<open>Proof Methods\<close>
text \<open>
  The first method is intended to act more conservatively (think \<open>safe\<close>), leaving subgoals
  for the user where it couldn't proceed any further.
  The second method is more powerful, acting more in a succeed-or-die manner,
  similarly to \<open>force\<close> and friends.
  The examples in the second section should give a good impression of where these methods
  can help.
\<close>

text \<open>This slot is intended to provide more \<open>intro\<close> theorems for finite sets.\<close>
named_theorems finite

(* Trick from Dan Matichuk on isabelle-users *)
method add_finite_Collect_simproc methods m =
  match termI in H[simproc add: finite_Collect]:_ \<Rightarrow> m

(* Trick from Dan Matichuk on isabelle-users.
   Turns a structured method into a simple one.
*)
method_setup simple_method =
  \<open>Method.text_closure >> (fn m => fn ctxt =>
   let
     val facts = Method.get_facts ctxt
     val insert' = Method.Basic (K (Method.insert facts))
     val m' = Method.Combinator (Method.no_combinator_info, Method.Then, [insert', m])
   in Method.evaluate m' ctxt end)\<close>

method finite_tup =
  match conclusion in
  "finite (_ \<times> _)" \<Rightarrow> \<open>rule finite_cartesian_product; finite_tup\<close> \<bar>
  "finite S" for S :: "(_ * _) set" \<Rightarrow>
  \<open>print_term S, (rule finite_subset[where A = S and B = "fst ` S \<times> snd ` S"]; finite_tup?
        | (rule finite_subset; assumption?; fastforce))\<close> \<bar>
  "finite X" for X \<Rightarrow>
  \<open>print_term X, (simp add: image_def, finite_tup?)?,
                (solves \<open>(rule finite_subset; assumption?; fastforce)\<close>)?\<close> \<bar>
  _ \<Rightarrow> \<open>fastforce simp: image_def\<close>

method finite_search =
  match conclusion in
  "finite (_ \<times> _)" \<Rightarrow> \<open>rule finite_cartesian_product; finite_search\<close> \<bar>
  "finite (_ ` _)" \<Rightarrow> \<open>simp; finite_search | rule finite_imageI; finite_search\<close> \<bar>
  "finite S" for S :: "(_ * _) set" \<Rightarrow>
  \<open>print_term S, (solves \<open>rule finite_subset; auto\<close>
        | rule finite_subset[where A = S and B = "fst ` S \<times> snd ` S"]; finite_tup?)\<close> \<bar>
  "finite (Collect f)" for f \<Rightarrow>
  \<open>print_term f, (add_finite_Collect_simproc \<open>simp add: setcompr_eq_image_all\<close>)?;
        (solves \<open>auto intro: finite\<close>
       | print_term v, simp?, rule finite; (assumption | finite_search)
       | rule finite_imageI; finite_search
       | rule finite_vimageI; finite_search
       | print_term x, rule finite_subset; assumption?; fastforce)\<close> \<bar>
  "finite X" for X \<Rightarrow>
  \<open>print_term X,
        (rule finite; (assumption | finite_search)
       |(simp add: image_def, finite_search?)?,
          (solves \<open>(rule finite_subset; assumption?; fastforce)\<close>)?)\<close> \<bar>
  _ \<Rightarrow> \<open>fastforce simp: image_def\<close>

method finite = simple_method finite_search

subsection \<open>Tests\<close>
subsubsection \<open>Working Examples\<close>

lemma
  assumes "finite A"
  shows "finite {x. x \<in> A \<and> P x}"
  using assms by finite_search

lemma collect_pair_finite'[finite]:
  assumes "finite {(x, y). P x y}"
  shows "finite {(x, y) . P x y \<and> R x y}"
  using assms by - finite

text \<open>This is what we actually need in this theory\<close>
lemma collect_pair_finite''[finite]:
  assumes "finite {(x, y). P x \<and> Q y}"
  shows "finite {(x, y) . P x \<and> Q y \<and> R x y}"
  using assms by - finite

lemma
  assumes "finite (A \<times> B)"
  shows "finite {(x, y) | x y. x \<in> A \<and> y \<in> B \<and> R x y}"
  using assms by - finite

lemma finite_imageI'':
  assumes "finite (A \<times> B)"
  shows "finite {f x y | x y. x \<in> A \<and> y \<in> B \<and> R x y}"
  using assms by - finite

text \<open>\<open>finite_Collect\<close> can also rewrite to \<open>vimage\<close>\<close>
lemma
  assumes "inj f" "finite S"
  shows "finite {y. \<exists> x \<in> S. x = f y}"
  using assms by - finite

lemma
  assumes "inj f" "finite S"
  shows "finite {y. \<exists> x \<in> S. f y = x}"
  using assms by - finite

lemma
  assumes "finite (A \<times> B)"
  shows "finite {f x y | x y. x \<in> A \<and> y \<in> B \<and> R x y \<and> Q x y \<and> T x \<and> TT y}" (is "finite ?S")
  using assms by - finite

lemma
  assumes "finite A" "finite B"
  shows "finite {(x, y) | x y. x \<in> A \<and> y \<in> B \<and> R y \<and> S x}"
  using assms by - finite

lemma
  fixes P Q R :: "'a \<Rightarrow> bool"
  assumes "finite {x. P x \<and> R x}"
  shows "finite {x. P x \<and> Q x \<and> R x}"
  using assms by - finite

lemma R:
  assumes "finite A" "A = B"
  shows "finite B"
  using assms by finite

lemma pairwise_finiteI:
  assumes "finite {b. \<exists>a. P a b}" (is "finite ?B")
  assumes "finite {a. \<exists>b. P a b}"
  shows "finite {(a,b). P a b}" (is "finite ?C")
  using assms by - finite

lemma pairwise_finiteI3:
  assumes "finite {b. \<exists>a c. P a b c}"
  assumes "finite {a. \<exists>b c. P a b c}"
  assumes "finite {c. \<exists>a b. P a b c}"
  shows "finite {(a,b,c). P a b c}" (is "finite ?C")
  using assms by - finite

lemma pairwise_finiteI4:
  assumes "finite {b. \<exists>a c d. P a b c d}"
  assumes "finite {a. \<exists>b c d. P a b c d}"
  assumes "finite {c. \<exists>a b d. P a b c d}"
  assumes "finite {d. \<exists>a b c. P a b c d}"
  shows "finite {(a,b,c,d). P a b c d}" (is "finite ?C")
  using assms by - finite

lemma finite_ex_and1:
  assumes "finite {b. \<exists>a. P a b}" (is "finite ?A")
  shows "finite {b. \<exists>a. P a b \<and> Q a b}" (is "finite ?B")
  using assms by - finite

lemma finite_ex_and2:
  assumes "finite {b. \<exists>a. Q a b}" (is "finite ?A")
  shows "finite {b. \<exists>a. P a b \<and> Q a b}" (is "finite ?B")
  using assms by - finite

subsubsection \<open>Counterexamples\<close>

lemma inj_finite_single:
  assumes "inj f"
  shows "finite {y. x = f y}"
  using assms Collect_mem_eq Collect_mono_iff infinite_iff_countable_subset inj_eq not_finite_existsD
    rangeI
  by fastforce

lemmas inj_finite_single[finite]

text \<open>It's hard to guess the right set\<close>
lemma inj_finite_single':
  assumes "inj f"
  shows "finite {z. f z = x}"
  apply (rule finite_subset[of _ "{z. x = f z}"])
   apply blast
  using assms by finite

(* Due to Lars Hupel *)
definition select :: "('a \<rightharpoonup> 'b) \<Rightarrow> 'a set \<Rightarrow> 'b set" where
  "select f S = {z | z. \<exists>x \<in> S. f x = Some z}"

lemma select_finite:
  assumes "finite S"
  shows "finite (select f S)"
  using assms unfolding select_def by finite

lemmas inj_finite_single'[finite]

subsubsection \<open>Counterexamples to be investigated\<close>

lemma finite_aux1[finite]:
  "finite {(x, y). x \<le> y \<and> y < (n :: nat)}"
  by (rule finite_subset[where B = "{(x, y). x < n \<and> y < (n :: nat)}"]) auto

lemma "finite {sum ((!) a) {i..j} |i j. i \<le> j \<and> j < n}"
  by finite
  (* or: by (subst setcompr_eq_image2, rule finite_imageI, rule finite_aux1) *)
  (* but this fails?? by (subst setcompr_eq_image2, rule finite_imageI, finite) *)

end


(*  Author:     Tobias Nipkow, 2007  *)

theory QEdlo_fr
imports DLO
begin

subsection "Interior Point Method"

text{* This section formalizes a new quantifier elimination procedure
based on the idea of Ferrante and Rackoff~\cite{FerranteR-SIAM75} (see
also \S\ref{sec:FRE}) of taking a point between each lower and upper
bound as a test point. For dense linear orders it is not obvious how
to realize this because we cannot name any intermediate point
directly. *}

fun asubst\<^sub>2 :: "nat \<Rightarrow> nat \<Rightarrow> atom \<Rightarrow> atom fm" where
"asubst\<^sub>2 l u (Less 0 0) = FalseF" |
"asubst\<^sub>2 l u (Less 0 (Suc j)) = Or (Atom(Less u j)) (Atom(Eq u j))" |
"asubst\<^sub>2 l u (Less (Suc i) 0) = Or (Atom(Less i l)) (Atom(Eq i l))" |
"asubst\<^sub>2 l u (Less (Suc i) (Suc j)) = Atom(Less i j)" |
"asubst\<^sub>2 l u (Eq 0 0) = TrueF" |
"asubst\<^sub>2 l u (Eq 0 _) = FalseF" |
"asubst\<^sub>2 l u (Eq _ 0) = FalseF" |
"asubst\<^sub>2 l u (Eq (Suc i) (Suc j)) = Atom(Eq i j)"

abbreviation "subst\<^sub>2 l u \<equiv> amap\<^bsub>fm\<^esub> (asubst\<^sub>2 l u)"

lemma I_subst\<^sub>21:
 "nqfree f \<Longrightarrow> xs!l < xs!u \<Longrightarrow> DLO.I (subst\<^sub>2 l u f) xs
 \<Longrightarrow> xs!l < x \<Longrightarrow> x < xs!u \<Longrightarrow> DLO.I f (x#xs)"
proof(induct f arbitrary: x)
  case (Atom a) thus ?case
    by (cases "(l,u,a)" rule: asubst\<^sub>2.cases) auto
qed auto

definition
"nolub f xs l x u \<longleftrightarrow> (\<forall>y\<in>{l<..<x}. y \<notin> LB f xs) \<and> (\<forall>y\<in>{x<..<u}. y \<notin> UB f xs)"

lemma nolub_And[simp]:
  "nolub (And f g) xs l x u = (nolub f xs l x u \<and> nolub g xs l x u)"
by(auto simp:nolub_def)

lemma nolub_Or[simp]:
  "nolub (Or f g) xs l x u = (nolub f xs l x u \<and> nolub g xs l x u)"
by(auto simp:nolub_def)

declare[[simp_depth_limit=3]]

lemma I_subst\<^sub>22:
 "nqfree f \<Longrightarrow> xs!l < x \<and> x < xs!u \<Longrightarrow> nolub f xs (xs!l) x (xs!u)
 \<Longrightarrow> \<forall>x\<in>{xs!l <..< xs!u}. DLO.I f (x#xs) \<and> x \<notin> EQ f xs
 \<Longrightarrow> DLO.I (subst\<^sub>2 l u f) xs"
proof (induct f)
  case (Atom a) show ?case
    apply (cases "(l,u,a)" rule: asubst\<^sub>2.cases)
    apply(insert Atom, auto simp: EQ_def nolub_def split:split_if_asm)
    done
next
  case Or thus ?case by (simp add: Ball_def)(metis innermost_intvl)
qed auto
declare[[simp_depth_limit=50]]

definition
"qe_interior\<^sub>1 \<phi> =
(let as = DLO.atoms\<^sub>0 \<phi>; lbs = lbounds as; ubs = ubounds as; ebs = ebounds as;
     intrs = [And (Atom(Less l u)) (subst\<^sub>2 l u \<phi>). l\<leftarrow>lbs, u\<leftarrow>ubs]
 in list_disj (inf\<^sub>- \<phi> # inf\<^sub>+ \<phi> # intrs @ map (subst \<phi>) ebs))"

theorem I_interior1:
assumes "nqfree \<phi>" shows "DLO.I (qe_interior\<^sub>1 \<phi>) xs = (EX x. DLO.I \<phi> (x#xs))"
  (is "?QE = ?EX")
proof
  assume ?QE
  { assume "DLO.I (inf\<^sub>- \<phi>) xs"
    hence ?EX using `?QE` min_inf[of \<phi> xs] `nqfree \<phi>`
      by(auto simp add:qe_interior\<^sub>1_def amap_fm_list_disj)
  } moreover
  { assume  "DLO.I (inf\<^sub>+ \<phi>) xs"
    hence ?EX using `?QE` plus_inf[of \<phi> xs] `nqfree \<phi>`
      by(auto simp add:qe_interior\<^sub>1_def amap_fm_list_disj)
  } moreover
  { assume "\<not>DLO.I (inf\<^sub>- \<phi>) xs \<and> \<not>DLO.I (inf\<^sub>+ \<phi>) xs \<and>
            (\<forall>x\<in>EQ \<phi> xs. \<not>DLO.I \<phi> (x#xs))"
    with `?QE` `nqfree \<phi>` obtain l u
      where "DLO.I (subst\<^sub>2 l u \<phi>) xs" and "xs!l < xs!u"
      by(fastforce simp: qe_interior\<^sub>1_def set_lbounds set_ubounds I_subst EQ_conv_set_ebounds)
    moreover then obtain x where "xs!l < x \<and> x < xs!u" by(metis dense)
    ultimately have "DLO.I \<phi> (x # xs)"
      using `nqfree \<phi>` I_subst\<^sub>21[OF `nqfree \<phi>` `xs!l < xs!u`] by simp
    hence ?EX .. }
  ultimately show ?EX by blast
next
  let ?as = "DLO.atoms\<^sub>0 \<phi>" let ?E = "set(ebounds ?as)"
  assume ?EX
  then obtain x where x: "DLO.I \<phi> (x#xs)" ..
  { assume "DLO.I (inf\<^sub>- \<phi>) xs \<or> DLO.I (inf\<^sub>+ \<phi>) xs"
    hence ?QE using `nqfree \<phi>` by(auto simp:qe_interior\<^sub>1_def)
  } moreover
  { assume "EX k : ?E. DLO.I (subst \<phi> k) xs"
    hence ?QE by(force simp:qe_interior\<^sub>1_def) } moreover
  { assume "\<not> DLO.I (inf\<^sub>- \<phi>) xs" and "\<not> DLO.I (inf\<^sub>+ \<phi>) xs"
    and "\<forall>k \<in> ?E. \<not> DLO.I (subst \<phi> k) xs"
    hence noE: "\<forall>e \<in> EQ \<phi> xs. \<not> DLO.I \<phi> (e#xs)"
      using `nqfree \<phi>` by (force simp:set_ebounds EQ_def I_subst)
    hence "x \<notin> EQ \<phi> xs" using x by fastforce
    obtain l where "l : LB \<phi> xs" "l < x"
      using LBex[OF `nqfree \<phi>` x `\<not> DLO.I(inf\<^sub>- \<phi>) xs` `x \<notin> EQ \<phi> xs`] ..
    obtain u where "u : UB \<phi> xs" "x < u"
      using UBex[OF `nqfree \<phi>` x `\<not> DLO.I(inf\<^sub>+ \<phi>) xs` `x \<notin> EQ \<phi> xs`] ..
    have "\<exists>l\<in>LB \<phi> xs. \<exists>u\<in>UB \<phi> xs. l<x \<and> x<u \<and> nolub \<phi> xs l x u \<and> (\<forall>y. l < y \<and> y < u \<longrightarrow> DLO.I \<phi> (y#xs))"
      using dense_interval[where P = "\<lambda>x. DLO.I \<phi> (x#xs)", OF finite_LB finite_UB `l:LB \<phi> xs` `u:UB \<phi> xs` `l<x` `x<u` x] x innermost_intvl[OF `nqfree \<phi>` _ _ _ `x \<notin> EQ \<phi> xs`]
      by (simp add:nolub_def)
    then obtain m n where
      "Less (Suc m) 0 : set ?as" "Less 0 (Suc n) : set ?as"
      "xs!m < x \<and> x < xs!n"
      "nolub \<phi> xs (xs!m) x (xs!n)"
      "\<forall>y. xs!m < y \<and> y < xs!n \<longrightarrow> DLO.I \<phi> (y#xs)"
      by blast
    moreover
    hence "DLO.I (subst\<^sub>2 m n \<phi>) xs" using noE
      by(force intro!: I_subst\<^sub>22[OF `nqfree \<phi>`])
    ultimately have ?QE
      by(fastforce simp add:qe_interior\<^sub>1_def bex_Un set_lbounds set_ubounds)
  } ultimately show ?QE by blast
qed

lemma qfree_asubst\<^sub>2: "qfree (asubst\<^sub>2 l u a)"
by(cases "(l,u,a)" rule:asubst\<^sub>2.cases) simp_all

lemma qfree_subst\<^sub>2: "nqfree \<phi> \<Longrightarrow> qfree (subst\<^sub>2 l u \<phi>)"
by(induct \<phi>) (simp_all add:qfree_asubst\<^sub>2)

lemma qfree_interior1: "nqfree \<phi> \<Longrightarrow> qfree(qe_interior\<^sub>1 \<phi>)"
apply(simp add:qe_interior\<^sub>1_def)
apply(rule qfree_list_disj)
apply (auto simp:qfree_min_inf qfree_plus_inf qfree_subst\<^sub>2 qfree_map_fm)
done

definition "qe_interior = DLO.lift_nnf_qe qe_interior\<^sub>1"

lemma qfree_qe_interior: "qfree(qe_interior \<phi>)"
by(simp add: qe_interior_def DLO.qfree_lift_nnf_qe qfree_interior1)

end


theory
  Refine_Hyperplane
imports
  Autoref_Misc
  Affine_Arithmetic.Print
  Ordinary_Differential_Equations.Reachability_Analysis
  Refine_Vector_List
begin

lemma convex_halfspace[simp]:
  "convex (below_halfspace sctn)"
  apply (auto simp: below_halfspace_def le_halfspace_def[abs_def])
  using convex_bound_le
  apply (auto intro!: convexI simp: algebra_simps)
  by blast

subsection \<open>Planes\<close>

definition "shows_sctn (sctn::real list sctn) =
  shows ''Sctn '' o shows_paren (shows_words (normal sctn)) o shows_space o
    shows_paren (shows (pstn sctn))"

lemma halfspaces_union:
  "sbelow_halfspaces (a \<union> b) = sbelow_halfspaces a \<inter> sbelow_halfspaces b"
  "below_halfspaces (a \<union> b) = below_halfspaces a \<inter> below_halfspaces b"
  by (auto simp: halfspace_simps)

lemma plane_of_subset_halfspace: "plane_of sctn \<subseteq> below_halfspace sctn"
  by (auto simp: plane_of_def below_halfspace_def le_halfspace_def)

lemma halfspace_subsets: "sbelow_halfspaces sctns \<subseteq> below_halfspaces sctns"
  and halfspace_subset: "sbelow_halfspace sctn \<subseteq> below_halfspace sctn"
  by (force simp: plane_of_def halfspace_simps)+

lemma sbelow_halfspaces_insert:
  "sbelow_halfspaces (insert x2 stop_sctns) = sbelow_halfspace x2 \<inter> sbelow_halfspaces stop_sctns"
  by (auto simp: sbelow_halfspaces_def)

lemma sbelow_halfspaces_antimono:
  assumes "A \<subseteq> B"
  shows "sbelow_halfspaces B \<subseteq> sbelow_halfspaces A"
  using assms
  by (auto simp: halfspace_simps)

lemma plane_in_halfspace[intro, simp]:
  "x \<in> plane_of sctn \<Longrightarrow> x \<in> below_halfspace sctn"
  "x \<in> plane_of sctn \<Longrightarrow> x \<in> above_halfspace sctn"
  by (auto simp: halfspace_simps plane_of_def)

lemma closure_shalfspace[intro, simp]:
  assumes "normal sctn \<noteq> 0"
  shows "closure (sbelow_halfspace sctn) = below_halfspace sctn"
    and "closure (sabove_halfspace sctn) = above_halfspace sctn"
  using closure_halfspace_lt[OF assms] closure_halfspace_gt[OF assms]
  by (auto simp: halfspace_simps inner_commute)

lemma closure_sbelow_halfspaces[intro, simp]:
  assumes "\<And>sctn. sctn \<in> sctns \<Longrightarrow> normal sctn \<noteq> 0"
  shows "closure (sbelow_halfspaces sctns) \<subseteq> below_halfspaces sctns"
proof -
  have *: "{closure S |S. S \<in> sbelow_halfspace ` sctns} = {S |S. S \<in> below_halfspace ` sctns}"
    by (auto simp: assms intro!: closure_shalfspace(1) [symmetric] exI)
  show ?thesis
    unfolding sbelow_halfspaces_def
    by (rule order_trans [OF closure_Int]) (auto simp: halfspace_simps * cong del: image_cong_simp)
qed

lemma halfspaces_empty[simp]: "sbelow_halfspaces {} = UNIV" "below_halfspaces {} = UNIV"
  by (auto simp: halfspace_simps)

lemma halfspaces_planeI:
  assumes "x \<in> below_halfspaces (s)"
  assumes "x \<notin> \<Union>(plane_of ` (s))"
  shows "x \<in> sbelow_halfspaces (s)"
  using assms
  by (force simp: halfspace_simps plane_of_def)

subsection \<open>Section\<close>

definition sctn_rel where sctn_rel_internal: "sctn_rel A = {(a, b). rel_sctn (in_rel A) a b}"
lemma sctn_rel_def: "\<langle>A\<rangle>sctn_rel = {(a, b). rel_sctn (in_rel A) a b}"
  by (auto simp: sctn_rel_internal relAPP_def)

lemma single_valued_sctn_rel[relator_props]: "single_valued A \<Longrightarrow> single_valued (\<langle>A\<rangle>sctn_rel)"
  using sctn.right_unique_rel[of "in_rel A"]
  by (auto simp: single_valued_def right_unique_def sctn_rel_def)

consts i_sctn :: "interface \<Rightarrow> interface" \<comment> \<open>section datatype\<close>

consts i_halfspace :: "interface \<Rightarrow> interface"

lemmas [autoref_rel_intf] = REL_INTFI[of sctn_rel i_sctn]

abbreviation "sctns_rel \<equiv> \<langle>\<langle>lv_rel\<rangle>sctn_rel\<rangle>list_set_rel"

definition plane_rel_internal: "plane_rel A = \<langle>A\<rangle>sctn_rel O br plane_of top"
lemma plane_rel_def: "\<langle>A\<rangle>plane_rel = \<langle>A\<rangle>sctn_rel O br plane_of top"
  by (simp add: plane_rel_internal relAPP_def)
consts i_plane::"interface\<Rightarrow>interface"
lemmas [autoref_rel_intf] = REL_INTFI[of plane_rel i_plane]

definition below_rel_internal: "below_rel A = \<langle>A\<rangle>sctn_rel O br below_halfspace top"
lemma below_rel_def: "\<langle>A\<rangle>below_rel = \<langle>A\<rangle>sctn_rel O br below_halfspace top"
  by (simp add: below_rel_internal relAPP_def)
consts i_below::"interface\<Rightarrow>interface"
lemmas [autoref_rel_intf] = REL_INTFI[of below_rel i_below]

definition sbelow_rel_internal: "sbelow_rel A = \<langle>A\<rangle>sctn_rel O br sbelow_halfspace top"
lemma sbelow_rel_def: "\<langle>A\<rangle>sbelow_rel = \<langle>A\<rangle>sctn_rel O br sbelow_halfspace top"
  by (simp add: sbelow_rel_internal relAPP_def)
consts i_sbelow::"interface\<Rightarrow>interface"
lemmas [autoref_rel_intf] = REL_INTFI[of sbelow_rel i_sbelow]

definition sbelows_rel_internal: "sbelows_rel A = \<langle>\<langle>A\<rangle>sctn_rel\<rangle>list_set_rel O br sbelow_halfspaces top"
lemma sbelows_rel_def: "\<langle>A\<rangle>sbelows_rel = \<langle>\<langle>A\<rangle>sctn_rel\<rangle>list_set_rel O br sbelow_halfspaces top"
  by (simp add: sbelows_rel_internal relAPP_def)
consts i_sbelows::"interface\<Rightarrow>interface"
lemmas [autoref_rel_intf] = REL_INTFI[of sbelows_rel i_sbelows]

context includes autoref_syntax begin

lemma plane_of_autoref[autoref_rules]:
  "(\<lambda>x. x, plane_of) \<in> \<langle>A\<rangle>sctn_rel \<rightarrow> \<langle>A\<rangle>plane_rel"
  by (auto simp: plane_rel_def intro!: brI)

lemma below_halfspace_autoref[autoref_rules]:
  "(\<lambda>x. x, below_halfspace) \<in> \<langle>A\<rangle>sctn_rel \<rightarrow> \<langle>A\<rangle>below_rel"
  by (auto simp: below_rel_def intro!: brI)

lemma sbelow_halfspace_autoref[autoref_rules]:
  "(\<lambda>x. x, sbelow_halfspace) \<in> \<langle>A\<rangle>sctn_rel \<rightarrow> \<langle>A\<rangle>sbelow_rel"
  by (auto simp: sbelow_rel_def intro!: brI)

lemma sbelow_halfspaces_autoref[autoref_rules]:
  "(\<lambda>x. x, sbelow_halfspaces) \<in> \<langle>\<langle>A\<rangle>sctn_rel\<rangle>list_set_rel \<rightarrow> \<langle>A\<rangle>sbelows_rel"
  by (auto simp: sbelows_rel_def intro!: brI)

end

context includes autoref_syntax begin
lemma [autoref_rules]:
  shows
  "(Sctn, Sctn) \<in> A \<rightarrow> rnv_rel \<rightarrow> \<langle>A\<rangle>sctn_rel"
  "(normal, normal) \<in> \<langle>A\<rangle>sctn_rel \<rightarrow> A"
  "(pstn, pstn) \<in> \<langle>A\<rangle>sctn_rel \<rightarrow> rnv_rel"
  by (auto simp: sctn_rel_def sctn.rel_sel)

lemma gen_eq_sctn[autoref_rules]:
  assumes "GEN_OP eq (=) (A \<rightarrow> A \<rightarrow> bool_rel)"
  shows "(\<lambda>sctn1 sctn2. eq (normal sctn1) (normal sctn2) \<and> pstn sctn1 = pstn sctn2, (=)) \<in> \<langle>A\<rangle>sctn_rel \<rightarrow> \<langle>A\<rangle>sctn_rel \<rightarrow> bool_rel"
  apply safe
  subgoal for a b c d
    using assms
    by (cases a; cases b; cases c; cases d) (auto simp: sctn_rel_def dest: fun_relD)
  subgoal for a b c d
    using assms
    by (cases a; cases b; cases c; cases d) (auto simp: sctn_rel_def dest: fun_relD)
  subgoal for a b c d
    using assms
    by (cases a; cases b; cases c; cases d) (auto simp: sctn_rel_def dest: fun_relD)
  done

lemma inter_sctn_specs_inter_sctn_spec:
  "(inter_sctn_specs d, inter_sctn_spec::'a::executable_euclidean_space set\<Rightarrow>_) \<in> \<langle>lv_rel\<rangle>set_rel \<rightarrow> \<langle>lv_rel\<rangle>sctn_rel \<rightarrow> \<langle>\<langle>lv_rel\<rangle>set_rel\<rangle>nres_rel"
  if "d = DIM('a)"
  apply (auto intro!: nres_relI RES_refine
      simp: inter_sctn_specs_def inter_sctn_spec_def set_rel_sv[OF lv_rel_sv] plane_ofs_def plane_of_def that)
  subgoal for a b c d e f
    apply (cases b; cases c)
    apply (rule ImageI, assumption)
    apply (auto simp: lv_rel_def br_def sctn_rel_def plane_of_def)
    apply (rule subsetD, assumption)
    apply auto
    subgoal for x1
      using lv_rel_inner[param_fo, OF lv_relI lv_relI, of f x1]
      by auto
    done
  subgoal for a b c d e f
    apply (cases b; cases c)
    apply (auto simp: sctn_rel_def lv_rel_def br_def)
    apply (drule rev_subsetD, assumption)
    subgoal for x1 x2
      using lv_rel_inner[where 'a = 'a, param_fo, OF lv_relI lv_relI, of f x1]
      by auto
    done
  by (auto simp: sctn_rel_def lv_rel_def br_def env_len_def)

lemma sctn_rel_comp: "\<langle>A\<rangle>sctn_rel O \<langle>B\<rangle>sctn_rel = \<langle>A O B\<rangle> sctn_rel"
  apply safe
  subgoal for a b c d e
    apply (cases c; cases d; cases d; cases e)
    by (auto simp: sctn_rel_def )
  subgoal for a b
    apply (cases a; cases b)
    apply (auto simp: sctn_rel_def )
    subgoal for c d e f
      apply (rule relcompI[where b="Sctn e c"])
       apply auto
      done
    done
  done

lemma sctn_rel: "\<langle>lv_rel\<rangle>sctn_rel \<subseteq> \<langle>\<langle>rnv_rel\<rangle>list_rel\<rangle>sctn_rel O \<langle>lv_rel\<rangle>sctn_rel"
  "\<langle>\<langle>rnv_rel\<rangle>list_rel\<rangle>sctn_rel O \<langle>lv_rel\<rangle>sctn_rel \<subseteq> \<langle>lv_rel\<rangle>sctn_rel"
  using sctn_rel_comp[of "\<langle>rnv_rel\<rangle>list_rel" lv_rel] by auto

definition halfspace_rel_internal: "halfspaces_rel R = \<langle>\<langle>R\<rangle>sctn_rel\<rangle>list_set_rel O br below_halfspaces top"
lemma halfspaces_rel_def: "\<langle>R\<rangle>halfspaces_rel = \<langle>\<langle>R\<rangle>sctn_rel\<rangle>list_set_rel O br below_halfspaces top"
  by (auto simp: relAPP_def halfspace_rel_internal)

lemmas [autoref_rel_intf] = REL_INTFI[of halfspaces_rel i_halfspace]

lemma below_halfspaces_autoref[autoref_rules]:
  "(\<lambda>x. x, below_halfspaces) \<in> \<langle>\<langle>R\<rangle>sctn_rel\<rangle>list_set_rel \<rightarrow> \<langle>R\<rangle>halfspaces_rel"
  by (auto simp: halfspaces_rel_def br_def)

end

lemma plane_rel_br: "\<langle>br a I\<rangle>plane_rel = br (plane_of o map_sctn a) (\<lambda>x. I (normal x))"
  apply (auto simp: plane_rel_def sctn_rel_def br_def)
  subgoal for x y z by (cases x; cases y) auto
  subgoal for x y z by (cases x; cases y) auto
  subgoal for x y by (cases x; cases y) auto
  subgoal for a by (cases a; force)
  done

lemma closed_subset_plane[intro]:
  "closed b \<Longrightarrow> closed {x \<in> b. x \<in> plane_of c}"
  "closed b \<Longrightarrow> closed {x \<in> b. x \<bullet> n = d}"
  by (auto simp: plane_of_def intro!: closed_levelset_within continuous_intros)

end


(* Author: Tobias Nipkow *)

theory Def_Init_Big
imports Def_Init_Exp Def_Init
begin

subsection "Initialization-Sensitive Big Step Semantics"

inductive
  big_step :: "(com \<times> state option) \<Rightarrow> state option \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
where
None: "(c,None) \<Rightarrow> None" |
Skip: "(SKIP,s) \<Rightarrow> s" |
AssignNone: "aval a s = None \<Longrightarrow> (x ::= a, Some s) \<Rightarrow> None" |
Assign: "aval a s = Some i \<Longrightarrow> (x ::= a, Some s) \<Rightarrow> Some(s(x := Some i))" |
Seq:    "(c\<^sub>1,s\<^sub>1) \<Rightarrow> s\<^sub>2 \<Longrightarrow> (c\<^sub>2,s\<^sub>2) \<Rightarrow> s\<^sub>3 \<Longrightarrow> (c\<^sub>1;;c\<^sub>2,s\<^sub>1) \<Rightarrow> s\<^sub>3" |

IfNone:  "bval b s = None \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2,Some s) \<Rightarrow> None" |
IfTrue:  "\<lbrakk> bval b s = Some True;  (c\<^sub>1,Some s) \<Rightarrow> s' \<rbrakk> \<Longrightarrow>
  (IF b THEN c\<^sub>1 ELSE c\<^sub>2,Some s) \<Rightarrow> s'" |
IfFalse: "\<lbrakk> bval b s = Some False;  (c\<^sub>2,Some s) \<Rightarrow> s' \<rbrakk> \<Longrightarrow>
  (IF b THEN c\<^sub>1 ELSE c\<^sub>2,Some s) \<Rightarrow> s'" |

WhileNone: "bval b s = None \<Longrightarrow> (WHILE b DO c,Some s) \<Rightarrow> None" |
WhileFalse: "bval b s = Some False \<Longrightarrow> (WHILE b DO c,Some s) \<Rightarrow> Some s" |
WhileTrue:
  "\<lbrakk> bval b s = Some True;  (c,Some s) \<Rightarrow> s';  (WHILE b DO c,s') \<Rightarrow> s'' \<rbrakk> \<Longrightarrow>
  (WHILE b DO c,Some s) \<Rightarrow> s''"

lemmas big_step_induct = big_step.induct[split_format(complete)]

subsection "Soundness wrt Big Steps"

text{* Note the special form of the induction because one of the arguments
of the inductive predicate is not a variable but the term @{term"Some s"}: *}

theorem Sound:
  "\<lbrakk> (c,Some s) \<Rightarrow> s';  D A c A';  A \<subseteq> dom s \<rbrakk>
  \<Longrightarrow> \<exists> t. s' = Some t \<and> A' \<subseteq> dom t"
proof (induction c "Some s" s' arbitrary: s A A' rule:big_step_induct)
  case AssignNone thus ?case
    by auto (metis aval_Some option.simps(3) subset_trans)
next
  case Seq thus ?case by auto metis
next
  case IfTrue thus ?case by auto blast
next
  case IfFalse thus ?case by auto blast
next
  case IfNone thus ?case
    by auto (metis bval_Some option.simps(3) order_trans)
next
  case WhileNone thus ?case
    by auto (metis bval_Some option.simps(3) order_trans)
next
  case (WhileTrue b s c s' s'')
  from `D A (WHILE b DO c) A'` obtain A' where "D A c A'" by blast
  then obtain t' where "s' = Some t'" "A \<subseteq> dom t'"
    by (metis D_incr WhileTrue(3,7) subset_trans)
  from WhileTrue(5)[OF this(1) WhileTrue(6) this(2)] show ?case .
qed auto

corollary sound: "\<lbrakk>  D (dom s) c A';  (c,Some s) \<Rightarrow> s' \<rbrakk> \<Longrightarrow> s' \<noteq> None"
by (metis Sound not_Some_eq subset_refl)

end