(*<*)
theory Interval
  imports "HOL-Library.Product_Lexorder" Timestamp
begin
(*>*)

section \<open>Intervals\<close>

typedef (overloaded) ('a :: timestamp) \<I> = "{(i :: 'a, j :: 'a, lei :: bool, lej :: bool). 0 \<le> i \<and> i \<le> j \<and> i \<in> tfin \<and> \<not>(j = 0 \<and> \<not>lej)}"
  by (intro exI[of _ "(0, 0, True, True)"]) (auto intro: zero_tfin)

setup_lifting type_definition_\<I>

instantiation \<I> :: (timestamp) equal begin

lift_definition equal_\<I> :: "'a \<I> \<Rightarrow> 'a \<I> \<Rightarrow> bool" is "(=)" .

instance by standard (transfer, auto)

end

lift_definition right :: "'a :: timestamp \<I> \<Rightarrow> 'a" is "fst \<circ> snd" .

lift_definition memL :: "'a :: timestamp \<Rightarrow> 'a \<Rightarrow> 'a \<I> \<Rightarrow> bool" is
  "\<lambda>t t' (a, b, lei, lej). if lei then t + a \<le> t' else t + a < t'" .

lift_definition memR :: "'a :: timestamp \<Rightarrow> 'a \<Rightarrow> 'a \<I> \<Rightarrow> bool" is
  "\<lambda>t t' (a, b, lei, lej). if lej then t' \<le> t + b else t' < t + b" .

definition mem :: "'a :: timestamp \<Rightarrow> 'a \<Rightarrow> 'a \<I> \<Rightarrow> bool" where
  "mem t t' I \<longleftrightarrow> memL t t' I \<and> memR t t' I"

lemma memL_mono: "memL t t' I \<Longrightarrow> t'' \<le> t \<Longrightarrow> memL t'' t' I"
  by transfer (auto simp: add.commute order_le_less_subst2 order_subst2 add_mono split: if_splits)

lemma memL_mono': "memL t t' I \<Longrightarrow> t' \<le> t'' \<Longrightarrow> memL t t'' I"
  by transfer (auto split: if_splits)

lemma memR_mono: "memR t t' I \<Longrightarrow> t \<le> t'' \<Longrightarrow> memR t'' t' I"
  apply transfer
  apply (simp split: prod.splits)
  apply (meson add_mono_comm dual_order.trans order_less_le_trans)
  done

lemma memR_mono': "memR t t' I \<Longrightarrow> t'' \<le> t' \<Longrightarrow> memR t t'' I"
  by transfer (auto split: if_splits)

lemma memR_dest: "memR t t' I \<Longrightarrow> t' \<le> t + right I"
  by transfer (auto split: if_splits)

lemma memR_tfin_refl:
  assumes fin: "t \<in> tfin"
  shows "memR t t I"
  by (transfer fixing: t) (force split: if_splits intro: order_trans[OF _ add_mono, where ?x=t and ?a1=t and ?c1=0] add_pos[OF fin])

lemma right_I_add_mono:
  fixes x :: "'a :: timestamp"
  shows "x \<le> x + right I"
  by transfer (auto split: if_splits intro: order_trans[OF _ add_mono, of _ _ 0])

lift_definition interval :: "'a :: timestamp \<Rightarrow> 'a \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> 'a \<I>" is
  "\<lambda>i j lei lej. (if 0 \<le> i \<and> i \<le> j \<and> i \<in> tfin \<and> \<not>(j = 0 \<and> \<not>lej)then (i, j, lei, lej) else Code.abort (STR ''malformed interval'') (\<lambda>_. (0, 0, True, True)))"
  by (auto intro: zero_tfin)

lemma "Rep_\<I> I = (l, r, b1, b2) \<Longrightarrow> memL 0 0 I \<longleftrightarrow> l = 0 \<and> b1"
  by transfer auto

lift_definition dropL :: "'a :: timestamp \<I> \<Rightarrow> 'a \<I>" is
  "\<lambda>(l, r, b1, b2). (0, r, True, b2)"
  by (auto intro: zero_tfin)

lemma memL_dropL: "t \<le> t' \<Longrightarrow> memL t t' (dropL I)"
  by transfer auto

lemma memR_dropL: "memR t t' (dropL I) = memR t t' I"
  by transfer auto

lift_definition flipL :: "'a :: timestamp \<I> \<Rightarrow> 'a \<I>" is
  "\<lambda>(l, r, b1, b2). if \<not>(l = 0 \<and> b1) then (0, l, True, \<not>b1) else Code.abort (STR ''invalid flipL'') (\<lambda>_. (0, 0, True, True))"
  by (auto intro: zero_tfin split: if_splits)

lemma memL_flipL: "t \<le> t' \<Longrightarrow> memL t t' (flipL I)"
  by transfer (auto split: if_splits)

lemma memR_flipLD: "\<not>memL 0 0 I \<Longrightarrow> memR t t' (flipL I) \<Longrightarrow> \<not>memL t t' I"
  by transfer (auto split: if_splits)

lemma memR_flipLI:
  fixes t :: "'a :: timestamp"
  shows "(\<And>u v. (u :: 'a :: timestamp) \<le> v \<or> v \<le> u) \<Longrightarrow> \<not>memL t t' I \<Longrightarrow> memR t t' (flipL I)"
  by transfer (force split: if_splits)

lemma "t \<in> tfin \<Longrightarrow> memL 0 0 I \<longleftrightarrow> memL t t I"
  apply transfer
  apply (simp split: prod.splits)
  apply (metis add.right_neutral add_pos antisym_conv2 dual_order.eq_iff order_less_imp_not_less)
  done

definition "full (I :: ('a :: timestamp) \<I>) \<longleftrightarrow> (\<forall>t t'. 0 \<le> t \<and> t \<le> t' \<and> t \<in> tfin \<and> t' \<in> tfin \<longrightarrow> mem t t' I)"

lemma "memL 0 0 (I :: ('a :: timestamp_total) \<I>) \<Longrightarrow> right I \<notin> tfin \<Longrightarrow> full I"
  unfolding full_def mem_def
  by transfer (fastforce split: if_splits dest: add_not_tfin)

(*<*)
end
(*>*)


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

section\<open>Zorn's Lemma\<close>

theory Zorn imports OrderArith AC Inductive_ZF begin

text\<open>Based upon the unpublished article ``Towards the Mechanization of the
Proofs of Some Classical Theorems of Set Theory,'' by Abrial and Laffitte.\<close>

definition
  Subset_rel :: "i=>i"  where
   "Subset_rel(A) == {z \<in> A*A . \<exists>x y. z=<x,y> & x<=y & x\<noteq>y}"

definition
  chain      :: "i=>i"  where
   "chain(A)      == {F \<in> Pow(A). \<forall>X\<in>F. \<forall>Y\<in>F. X<=Y | Y<=X}"

definition
  super      :: "[i,i]=>i"  where
   "super(A,c)    == {d \<in> chain(A). c<=d & c\<noteq>d}"

definition
  maxchain   :: "i=>i"  where
   "maxchain(A)   == {c \<in> chain(A). super(A,c)=0}"

definition
  increasing :: "i=>i"  where
    "increasing(A) == {f \<in> Pow(A)->Pow(A). \<forall>x. x<=A \<longrightarrow> x<=f`x}"

text\<open>Lemma for the inductive definition below\<close>
lemma Union_in_Pow: "Y \<in> Pow(Pow(A)) ==> \<Union>(Y) \<in> Pow(A)"
by blast

text\<open>We could make the inductive definition conditional on
    @{term "next \<in> increasing(S)"}
    but instead we make this a side-condition of an introduction rule.  Thus
    the induction rule lets us assume that condition!  Many inductive proofs
    are therefore unconditional.\<close>
consts
  "TFin" :: "[i,i]=>i"

inductive
  domains       "TFin(S,next)" \<subseteq> "Pow(S)"
  intros
    nextI:       "[| x \<in> TFin(S,next);  next \<in> increasing(S) |]
                  ==> next`x \<in> TFin(S,next)"

    Pow_UnionI: "Y \<in> Pow(TFin(S,next)) ==> \<Union>(Y) \<in> TFin(S,next)"

  monos         Pow_mono
  con_defs      increasing_def
  type_intros   CollectD1 [THEN apply_funtype] Union_in_Pow

subsection\<open>Mathematical Preamble\<close>

lemma Union_lemma0: "(\<forall>x\<in>C. x<=A | B<=x) ==> \<Union>(C)<=A | B<=\<Union>(C)"
by blast

lemma Inter_lemma0:
     "[| c \<in> C; \<forall>x\<in>C. A<=x | x<=B |] ==> A \<subseteq> \<Inter>(C) | \<Inter>(C) \<subseteq> B"
by blast

subsection\<open>The Transfinite Construction\<close>

lemma increasingD1: "f \<in> increasing(A) ==> f \<in> Pow(A)->Pow(A)"
apply (unfold increasing_def)
apply (erule CollectD1)
done

lemma increasingD2: "[| f \<in> increasing(A); x<=A |] ==> x \<subseteq> f`x"
by (unfold increasing_def, blast)

lemmas TFin_UnionI = PowI [THEN TFin.Pow_UnionI]

lemmas TFin_is_subset = TFin.dom_subset [THEN subsetD, THEN PowD]

text\<open>Structural induction on @{term "TFin(S,next)"}\<close>
lemma TFin_induct:
  "[| n \<in> TFin(S,next);
      !!x. [| x \<in> TFin(S,next);  P(x);  next \<in> increasing(S) |] ==> P(next`x);
      !!Y. [| Y \<subseteq> TFin(S,next);  \<forall>y\<in>Y. P(y) |] ==> P(\<Union>(Y))
   |] ==> P(n)"
by (erule TFin.induct, blast+)

subsection\<open>Some Properties of the Transfinite Construction\<close>

lemmas increasing_trans = subset_trans [OF _ increasingD2,
                                        OF _ _ TFin_is_subset]

text\<open>Lemma 1 of section 3.1\<close>
lemma TFin_linear_lemma1:
     "[| n \<in> TFin(S,next);  m \<in> TFin(S,next);
         \<forall>x \<in> TFin(S,next) . x<=m \<longrightarrow> x=m | next`x<=m |]
      ==> n<=m | next`m<=n"
apply (erule TFin_induct)
apply (erule_tac [2] Union_lemma0) (*or just Blast_tac*)
(*downgrade subsetI from intro! to intro*)
apply (blast dest: increasing_trans)
done

text\<open>Lemma 2 of section 3.2.  Interesting in its own right!
  Requires @{term "next \<in> increasing(S)"} in the second induction step.\<close>
lemma TFin_linear_lemma2:
    "[| m \<in> TFin(S,next);  next \<in> increasing(S) |]
     ==> \<forall>n \<in> TFin(S,next). n<=m \<longrightarrow> n=m | next`n \<subseteq> m"
apply (erule TFin_induct)
apply (rule impI [THEN ballI])
txt\<open>case split using \<open>TFin_linear_lemma1\<close>\<close>
apply (rule_tac n1 = n and m1 = x in TFin_linear_lemma1 [THEN disjE],
       assumption+)
apply (blast del: subsetI
             intro: increasing_trans subsetI, blast)
txt\<open>second induction step\<close>
apply (rule impI [THEN ballI])
apply (rule Union_lemma0 [THEN disjE])
apply (erule_tac [3] disjI2)
prefer 2 apply blast
apply (rule ballI)
apply (drule bspec, assumption)
apply (drule subsetD, assumption)
apply (rule_tac n1 = n and m1 = x in TFin_linear_lemma1 [THEN disjE],
       assumption+, blast)
apply (erule increasingD2 [THEN subset_trans, THEN disjI1])
apply (blast dest: TFin_is_subset)+
done

text\<open>a more convenient form for Lemma 2\<close>
lemma TFin_subsetD:
     "[| n<=m;  m \<in> TFin(S,next);  n \<in> TFin(S,next);  next \<in> increasing(S) |]
      ==> n=m | next`n \<subseteq> m"
by (blast dest: TFin_linear_lemma2 [rule_format])

text\<open>Consequences from section 3.3 -- Property 3.2, the ordering is total\<close>
lemma TFin_subset_linear:
     "[| m \<in> TFin(S,next);  n \<in> TFin(S,next);  next \<in> increasing(S) |]
      ==> n \<subseteq> m | m<=n"
apply (rule disjE)
apply (rule TFin_linear_lemma1 [OF _ _TFin_linear_lemma2])
apply (assumption+, erule disjI2)
apply (blast del: subsetI
             intro: subsetI increasingD2 [THEN subset_trans] TFin_is_subset)
done

text\<open>Lemma 3 of section 3.3\<close>
lemma equal_next_upper:
     "[| n \<in> TFin(S,next);  m \<in> TFin(S,next);  m = next`m |] ==> n \<subseteq> m"
apply (erule TFin_induct)
apply (drule TFin_subsetD)
apply (assumption+, force, blast)
done

text\<open>Property 3.3 of section 3.3\<close>
lemma equal_next_Union:
     "[| m \<in> TFin(S,next);  next \<in> increasing(S) |]
      ==> m = next`m <-> m = \<Union>(TFin(S,next))"
apply (rule iffI)
apply (rule Union_upper [THEN equalityI])
apply (rule_tac [2] equal_next_upper [THEN Union_least])
apply (assumption+)
apply (erule ssubst)
apply (rule increasingD2 [THEN equalityI], assumption)
apply (blast del: subsetI
             intro: subsetI TFin_UnionI TFin.nextI TFin_is_subset)+
done

subsection\<open>Hausdorff's Theorem: Every Set Contains a Maximal Chain\<close>

text\<open>NOTE: We assume the partial ordering is \<open>\<subseteq>\<close>, the subset
relation!\<close>

text\<open>* Defining the "next" operation for Hausdorff's Theorem *\<close>

lemma chain_subset_Pow: "chain(A) \<subseteq> Pow(A)"
apply (unfold chain_def)
apply (rule Collect_subset)
done

lemma super_subset_chain: "super(A,c) \<subseteq> chain(A)"
apply (unfold super_def)
apply (rule Collect_subset)
done

lemma maxchain_subset_chain: "maxchain(A) \<subseteq> chain(A)"
apply (unfold maxchain_def)
apply (rule Collect_subset)
done

lemma choice_super:
     "[| ch \<in> (\<Prod>X \<in> Pow(chain(S)) - {0}. X); X \<in> chain(S);  X \<notin> maxchain(S) |]
      ==> ch ` super(S,X) \<in> super(S,X)"
apply (erule apply_type)
apply (unfold super_def maxchain_def, blast)
done

lemma choice_not_equals:
     "[| ch \<in> (\<Prod>X \<in> Pow(chain(S)) - {0}. X); X \<in> chain(S);  X \<notin> maxchain(S) |]
      ==> ch ` super(S,X) \<noteq> X"
apply (rule notI)
apply (drule choice_super, assumption, assumption)
apply (simp add: super_def)
done

text\<open>This justifies Definition 4.4\<close>
lemma Hausdorff_next_exists:
     "ch \<in> (\<Prod>X \<in> Pow(chain(S))-{0}. X) ==>
      \<exists>next \<in> increasing(S). \<forall>X \<in> Pow(S).
                   next`X = if(X \<in> chain(S)-maxchain(S), ch`super(S,X), X)"
apply (rule_tac x="\<lambda>X\<in>Pow(S).
                   if X \<in> chain(S) - maxchain(S) then ch ` super(S, X) else X"
       in bexI)
apply force
apply (unfold increasing_def)
apply (rule CollectI)
apply (rule lam_type)
apply (simp (no_asm_simp))
apply (blast dest: super_subset_chain [THEN subsetD]
                   chain_subset_Pow [THEN subsetD] choice_super)
txt\<open>Now, verify that it increases\<close>
apply (simp (no_asm_simp) add: Pow_iff subset_refl)
apply safe
apply (drule choice_super)
apply (assumption+)
apply (simp add: super_def, blast)
done

text\<open>Lemma 4\<close>
lemma TFin_chain_lemma4:
     "[| c \<in> TFin(S,next);
         ch \<in> (\<Prod>X \<in> Pow(chain(S))-{0}. X);
         next \<in> increasing(S);
         \<forall>X \<in> Pow(S). next`X =
                          if(X \<in> chain(S)-maxchain(S), ch`super(S,X), X) |]
     ==> c \<in> chain(S)"
apply (erule TFin_induct)
apply (simp (no_asm_simp) add: chain_subset_Pow [THEN subsetD, THEN PowD]
            choice_super [THEN super_subset_chain [THEN subsetD]])
apply (unfold chain_def)
apply (rule CollectI, blast, safe)
apply (rule_tac m1=B and n1=Ba in TFin_subset_linear [THEN disjE], fast+)
      txt\<open>\<open>Blast_tac's\<close> slow\<close>
done

theorem Hausdorff: "\<exists>c. c \<in> maxchain(S)"
apply (rule AC_Pi_Pow [THEN exE])
apply (rule Hausdorff_next_exists [THEN bexE], assumption)
apply (rename_tac ch "next")
apply (subgoal_tac "\<Union>(TFin (S,next)) \<in> chain (S) ")
prefer 2
 apply (blast intro!: TFin_chain_lemma4 subset_refl [THEN TFin_UnionI])
apply (rule_tac x = "\<Union>(TFin (S,next))" in exI)
apply (rule classical)
apply (subgoal_tac "next ` Union(TFin (S,next)) = \<Union>(TFin (S,next))")
apply (rule_tac [2] equal_next_Union [THEN iffD2, symmetric])
apply (rule_tac [2] subset_refl [THEN TFin_UnionI])
prefer 2 apply assumption
apply (rule_tac [2] refl)
apply (simp add: subset_refl [THEN TFin_UnionI,
                              THEN TFin.dom_subset [THEN subsetD, THEN PowD]])
apply (erule choice_not_equals [THEN notE])
apply (assumption+)
done

subsection\<open>Zorn's Lemma: If All Chains in S Have Upper Bounds In S,
       then S contains a Maximal Element\<close>

text\<open>Used in the proof of Zorn's Lemma\<close>
lemma chain_extend:
    "[| c \<in> chain(A);  z \<in> A;  \<forall>x \<in> c. x<=z |] ==> cons(z,c) \<in> chain(A)"
by (unfold chain_def, blast)

lemma Zorn: "\<forall>c \<in> chain(S). \<Union>(c) \<in> S ==> \<exists>y \<in> S. \<forall>z \<in> S. y<=z \<longrightarrow> y=z"
apply (rule Hausdorff [THEN exE])
apply (simp add: maxchain_def)
apply (rename_tac c)
apply (rule_tac x = "\<Union>(c)" in bexI)
prefer 2 apply blast
apply safe
apply (rename_tac z)
apply (rule classical)
apply (subgoal_tac "cons (z,c) \<in> super (S,c) ")
apply (blast elim: equalityE)
apply (unfold super_def, safe)
apply (fast elim: chain_extend)
apply (fast elim: equalityE)
done

text \<open>Alternative version of Zorn's Lemma\<close>

theorem Zorn2:
  "\<forall>c \<in> chain(S). \<exists>y \<in> S. \<forall>x \<in> c. x \<subseteq> y ==> \<exists>y \<in> S. \<forall>z \<in> S. y<=z \<longrightarrow> y=z"
apply (cut_tac Hausdorff maxchain_subset_chain)
apply (erule exE)
apply (drule subsetD, assumption)
apply (drule bspec, assumption, erule bexE)
apply (rule_tac x = y in bexI)
  prefer 2 apply assumption
apply clarify
apply rule apply assumption
apply rule
apply (rule ccontr)
apply (frule_tac z=z in chain_extend)
  apply (assumption, blast)
apply (unfold maxchain_def super_def)
apply (blast elim!: equalityCE)
done

subsection\<open>Zermelo's Theorem: Every Set can be Well-Ordered\<close>

text\<open>Lemma 5\<close>
lemma TFin_well_lemma5:
     "[| n \<in> TFin(S,next);  Z \<subseteq> TFin(S,next);  z:Z;  ~ \<Inter>(Z) \<in> Z |]
      ==> \<forall>m \<in> Z. n \<subseteq> m"
apply (erule TFin_induct)
prefer 2 apply blast txt\<open>second induction step is easy\<close>
apply (rule ballI)
apply (rule bspec [THEN TFin_subsetD, THEN disjE], auto)
apply (subgoal_tac "m = \<Inter>(Z) ")
apply blast+
done

text\<open>Well-ordering of @{term "TFin(S,next)"}\<close>
lemma well_ord_TFin_lemma: "[| Z \<subseteq> TFin(S,next);  z \<in> Z |] ==> \<Inter>(Z) \<in> Z"
apply (rule classical)
apply (subgoal_tac "Z = {\<Union>(TFin (S,next))}")
apply (simp (no_asm_simp) add: Inter_singleton)
apply (erule equal_singleton)
apply (rule Union_upper [THEN equalityI])
apply (rule_tac [2] subset_refl [THEN TFin_UnionI, THEN TFin_well_lemma5, THEN bspec], blast+)
done

text\<open>This theorem just packages the previous result\<close>
lemma well_ord_TFin:
     "next \<in> increasing(S)
      ==> well_ord(TFin(S,next), Subset_rel(TFin(S,next)))"
apply (rule well_ordI)
apply (unfold Subset_rel_def linear_def)
txt\<open>Prove the well-foundedness goal\<close>
apply (rule wf_onI)
apply (frule well_ord_TFin_lemma, assumption)
apply (drule_tac x = "\<Inter>(Z) " in bspec, assumption)
apply blast
txt\<open>Now prove the linearity goal\<close>
apply (intro ballI)
apply (case_tac "x=y")
 apply blast
txt\<open>The @{term "x\<noteq>y"} case remains\<close>
apply (rule_tac n1=x and m1=y in TFin_subset_linear [THEN disjE],
       assumption+, blast+)
done

text\<open>* Defining the "next" operation for Zermelo's Theorem *\<close>

lemma choice_Diff:
     "[| ch \<in> (\<Prod>X \<in> Pow(S) - {0}. X);  X \<subseteq> S;  X\<noteq>S |] ==> ch ` (S-X) \<in> S-X"
apply (erule apply_type)
apply (blast elim!: equalityE)
done

text\<open>This justifies Definition 6.1\<close>
lemma Zermelo_next_exists:
     "ch \<in> (\<Prod>X \<in> Pow(S)-{0}. X) ==>
           \<exists>next \<in> increasing(S). \<forall>X \<in> Pow(S).
                      next`X = (if X=S then S else cons(ch`(S-X), X))"
apply (rule_tac x="\<lambda>X\<in>Pow(S). if X=S then S else cons(ch`(S-X), X)"
       in bexI)
apply force
apply (unfold increasing_def)
apply (rule CollectI)
apply (rule lam_type)
txt\<open>Type checking is surprisingly hard!\<close>
apply (simp (no_asm_simp) add: Pow_iff cons_subset_iff subset_refl)
apply (blast intro!: choice_Diff [THEN DiffD1])
txt\<open>Verify that it increases\<close>
apply (intro allI impI)
apply (simp add: Pow_iff subset_consI subset_refl)
done

text\<open>The construction of the injection\<close>
lemma choice_imp_injection:
     "[| ch \<in> (\<Prod>X \<in> Pow(S)-{0}. X);
         next \<in> increasing(S);
         \<forall>X \<in> Pow(S). next`X = if(X=S, S, cons(ch`(S-X), X)) |]
      ==> (\<lambda> x \<in> S. \<Union>({y \<in> TFin(S,next). x \<notin> y}))
               \<in> inj(S, TFin(S,next) - {S})"
apply (rule_tac d = "%y. ch` (S-y) " in lam_injective)
apply (rule DiffI)
apply (rule Collect_subset [THEN TFin_UnionI])
apply (blast intro!: Collect_subset [THEN TFin_UnionI] elim: equalityE)
apply (subgoal_tac "x \<notin> \<Union>({y \<in> TFin (S,next) . x \<notin> y}) ")
prefer 2 apply (blast elim: equalityE)
apply (subgoal_tac "\<Union>({y \<in> TFin (S,next) . x \<notin> y}) \<noteq> S")
prefer 2 apply (blast elim: equalityE)
txt\<open>For proving \<open>x \<in> next`\<Union>(...)\<close>.
  Abrial and Laffitte's justification appears to be faulty.\<close>
apply (subgoal_tac "~ next ` Union({y \<in> TFin (S,next) . x \<notin> y})
                    \<subseteq> \<Union>({y \<in> TFin (S,next) . x \<notin> y}) ")
 prefer 2
 apply (simp del: Union_iff
             add: Collect_subset [THEN TFin_UnionI, THEN TFin_is_subset]
             Pow_iff cons_subset_iff subset_refl choice_Diff [THEN DiffD2])
apply (subgoal_tac "x \<in> next ` Union({y \<in> TFin (S,next) . x \<notin> y}) ")
 prefer 2
 apply (blast intro!: Collect_subset [THEN TFin_UnionI] TFin.nextI)
txt\<open>End of the lemmas!\<close>
apply (simp add: Collect_subset [THEN TFin_UnionI, THEN TFin_is_subset])
done

text\<open>The wellordering theorem\<close>
theorem AC_well_ord: "\<exists>r. well_ord(S,r)"
apply (rule AC_Pi_Pow [THEN exE])
apply (rule Zermelo_next_exists [THEN bexE], assumption)
apply (rule exI)
apply (rule well_ord_rvimage)
apply (erule_tac [2] well_ord_TFin)
apply (rule choice_imp_injection [THEN inj_weaken_type], blast+)
done

subsection \<open>Zorn's Lemma for Partial Orders\<close>

text \<open>Reimported from HOL by Clemens Ballarin.\<close>

definition Chain :: "i => i" where
  "Chain(r) = {A \<in> Pow(field(r)). \<forall>a\<in>A. \<forall>b\<in>A. <a, b> \<in> r | <b, a> \<in> r}"

lemma mono_Chain:
  "r \<subseteq> s ==> Chain(r) \<subseteq> Chain(s)"
  unfolding Chain_def
  by blast

theorem Zorn_po:
  assumes po: "Partial_order(r)"
    and u: "\<forall>C\<in>Chain(r). \<exists>u\<in>field(r). \<forall>a\<in>C. <a, u> \<in> r"
  shows "\<exists>m\<in>field(r). \<forall>a\<in>field(r). <m, a> \<in> r \<longrightarrow> a = m"
proof -
  have "Preorder(r)" using po by (simp add: partial_order_on_def)
  \<comment>\<open>Mirror r in the set of subsets below (wrt r) elements of A (?).\<close>
  let ?B = "\<lambda>x\<in>field(r). r -`` {x}" let ?S = "?B `` field(r)"
  have "\<forall>C\<in>chain(?S). \<exists>U\<in>?S. \<forall>A\<in>C. A \<subseteq> U"
  proof (clarsimp simp: chain_def Subset_rel_def bex_image_simp)
    fix C
    assume 1: "C \<subseteq> ?S" and 2: "\<forall>A\<in>C. \<forall>B\<in>C. A \<subseteq> B | B \<subseteq> A"
    let ?A = "{x \<in> field(r). \<exists>M\<in>C. M = ?B`x}"
    have "C = ?B `` ?A" using 1
      apply (auto simp: image_def)
      apply rule
      apply rule
      apply (drule subsetD) apply assumption
      apply (erule CollectE)
      apply rule apply assumption
      apply (erule bexE)
      apply rule prefer 2 apply assumption
      apply rule
      apply (erule lamE) apply simp
      apply assumption

      apply (thin_tac "C \<subseteq> X" for X)
      apply (fast elim: lamE)
      done
    have "?A \<in> Chain(r)"
    proof (simp add: Chain_def subsetI, intro conjI ballI impI)
      fix a b
      assume "a \<in> field(r)" "r -`` {a} \<in> C" "b \<in> field(r)" "r -`` {b} \<in> C"
      hence "r -`` {a} \<subseteq> r -`` {b} | r -`` {b} \<subseteq> r -`` {a}" using 2 by auto
      then show "<a, b> \<in> r | <b, a> \<in> r"
        using \<open>Preorder(r)\<close> \<open>a \<in> field(r)\<close> \<open>b \<in> field(r)\<close>
        by (simp add: subset_vimage1_vimage1_iff)
    qed
    then obtain u where uA: "u \<in> field(r)" "\<forall>a\<in>?A. <a, u> \<in> r"
      using u
      apply auto
      apply (drule bspec) apply assumption
      apply auto
      done
    have "\<forall>A\<in>C. A \<subseteq> r -`` {u}"
    proof (auto intro!: vimageI)
      fix a B
      assume aB: "B \<in> C" "a \<in> B"
      with 1 obtain x where "x \<in> field(r)" "B = r -`` {x}"
        apply -
        apply (drule subsetD) apply assumption
        apply (erule imageE)
        apply (erule lamE)
        apply simp
        done
      then show "<a, u> \<in> r" using uA aB \<open>Preorder(r)\<close>
        by (auto simp: preorder_on_def refl_def) (blast dest: trans_onD)+
    qed
    then show "\<exists>U\<in>field(r). \<forall>A\<in>C. A \<subseteq> r -`` {U}"
      using \<open>u \<in> field(r)\<close> ..
  qed
  from Zorn2 [OF this]
  obtain m B where "m \<in> field(r)" "B = r -`` {m}"
    "\<forall>x\<in>field(r). B \<subseteq> r -`` {x} \<longrightarrow> B = r -`` {x}"
    by (auto elim!: lamE simp: ball_image_simp)
  then have "\<forall>a\<in>field(r). <m, a> \<in> r \<longrightarrow> a = m"
    using po \<open>Preorder(r)\<close> \<open>m \<in> field(r)\<close>
    by (auto simp: subset_vimage1_vimage1_iff Partial_order_eq_vimage1_vimage1_iff)
  then show ?thesis using \<open>m \<in> field(r)\<close> by blast
qed

end


theory Development
  imports
    Linear_Inequalities.Mixed_Integer_Solutions (* mixed integer bounds *)
    Simplex.Simplex_Incremental (* incremental simplex algorithm *)
    Farkas.Matrix_Farkas (* existing connection between simplex and matrices, perhaps needs generalization *)
    Simplex.Abstract_Linear_Poly
begin

(* to be started with

isabelle jedit -d /path/to/afp-2019/thys -l Linear_Inequalities Development.thy

for Isabelle 2019 and corresponding AFP (afp-2019-06-21 from https://www.isa-afp.org or later)

*)

(* reenable Var without prefix *)
abbreviation Var where "Var \<equiv> Abstract_Linear_Poly.Var"
abbreviation max_var where "max_var \<equiv> Abstract_Linear_Poly.max_var"
abbreviation vars_list where "vars_list \<equiv> Abstract_Linear_Poly.vars_list"

fun satisfies_mixed_constraints (infixl "\<Turnstile>\<^sub>m\<^sub>c\<^sub>s" 100) where
"v \<Turnstile>\<^sub>m\<^sub>c\<^sub>s (cs, I) = (v \<Turnstile>\<^sub>c\<^sub>s cs \<and> (\<forall> i \<in> I. v i \<in> \<int>))"

(* For the moment, the type of branch_and_bound is sufficient to solve
  mixed-integer linear problems, but it should be updated afterwards by:
  - Taking into account indices
  - Returning an unsat core when the problem is infeasible instead of just
    returning `None`
Also, maybe the argument types could be changed to be more efficient, but it
is not the priority now.
*)

text \<open>We define the following measure on the arguments of the branch-and-bound
algorithm to prove its termination.
The idea is that at each recursive call ("branch operation"), if the branch
is performed on the variable x, then the quantity ub x - lb x strictly
decreases while the other ones are left unchanged.
Finally, if the sum of the ub x - lb x is nonpositive, then the problem
has an unique solution with integral values for the elements of Is, or is
infeasible.\<close>
fun bb_measure where
"bb_measure (_, Is, lb, ub) = nat (sum_list (map (\<lambda> x. ub x - lb x) Is))"

definition bounds_to_constraints where
  "bounds_to_constraints Is lb ub =
     map (\<lambda> x. GEQ (Var x) (of_int (lb x))) Is @
     map (\<lambda> x. LEQ (Var x) (of_int (ub x))) Is"

lemma bounds_to_constraints_sat:
  "v \<Turnstile>\<^sub>c\<^sub>s set (bounds_to_constraints Is lb ub) \<longleftrightarrow>
   (\<forall> i \<in> set Is. of_int (lb i) \<le> v i \<and> v i \<le> of_int (ub i))"
proof -
  {
    fix i
    assume v: "v \<Turnstile>\<^sub>c\<^sub>s set (bounds_to_constraints Is lb ub)"
    assume "i \<in> set Is"
    hence "GEQ (Var i) (of_int (lb i)) \<in> set (bounds_to_constraints Is lb ub)"
      and "LEQ (Var i) (of_int (ub i)) \<in> set (bounds_to_constraints Is lb ub)"
      unfolding bounds_to_constraints_def by auto
    hence "v \<Turnstile>\<^sub>c GEQ (Var i) (of_int (lb i)) \<and>
           v \<Turnstile>\<^sub>c LEQ (Var i) (of_int (ub i))" using v by blast
    hence  "of_int (lb i) \<le> v i \<and> v i \<le> of_int (ub i)"
      using valuate_Var[of i v] by auto
  }
  moreover
  {
    fix c
    assume bnd: "(\<forall> i \<in> set Is. of_int (lb i) \<le> v i \<and> v i \<le> of_int (ub i))"
    assume "c \<in> set (bounds_to_constraints Is lb ub)"
    then obtain i where i: "i \<in> set Is"
                  and "c = GEQ (Var i) (of_int (lb i)) \<or>
                       c = LEQ (Var i) (of_int (ub i))"
      unfolding bounds_to_constraints_def by auto
    hence "v \<Turnstile>\<^sub>c c" using i bnd valuate_Var[of i v] by fastforce
  }
  ultimately show ?thesis by blast
qed

lemma sat_impl_sum_diff_bounds_nonneg:
  assumes sat: "simplex (cs @ bounds_to_constraints Is lb ub) = Sat v"
  and J: "set J \<subseteq> set Is"
  shows "(\<Sum>x\<leftarrow>J. ub x - lb x) \<ge> 0"
proof (rule sum_list_nonneg)
  fix y assume "y \<in> set (map (\<lambda>x. ub x - lb x) J)"
  then obtain x where x: "x \<in> set J" and y: "y = ub x - lb x" by auto
  from sat have "\<langle>v\<rangle> \<Turnstile>\<^sub>c\<^sub>s set (bounds_to_constraints Is lb ub)"
    using simplex(3) by fastforce
  hence "\<langle>v\<rangle> \<Turnstile>\<^sub>c\<^sub>s set (bounds_to_constraints J lb ub)"
    unfolding bounds_to_constraints_def using J by auto
  hence "of_int (lb x) \<le> \<langle>v\<rangle> x \<and> \<langle>v\<rangle> x \<le> of_int (ub x)"
    using bounds_to_constraints_sat x by blast
  hence "ub x - lb x \<ge> 0" by linarith
  thus "y \<ge> 0" using y by blast
qed

lemma find_Some_set:
  assumes "find P xs = Some x"
  shows "x \<in> set xs \<and> P x"
proof -
  from assms obtain i where "x = xs ! i" and "i < length xs" and "P (xs ! i)"
    using find_Some_iff[of P xs x] by blast
  thus ?thesis by auto
qed

lemma nonnint_sat_pos_measure:
  assumes sat: "simplex (cs @ bounds_to_constraints Is lb ub) = Sat v"
  assumes find: "find (\<lambda>y. \<langle>v\<rangle> y \<notin> \<int>) Is = Some x"
  shows "0 < (\<Sum>x\<leftarrow>Is. ub x - lb x)"
proof -
  have x: "x \<in> set Is" and "\<langle>v\<rangle> x \<notin> \<int>" using find_Some_set[OF find] by auto
  from sat simplex(3) have "\<langle>v\<rangle> \<Turnstile>\<^sub>c\<^sub>s set (bounds_to_constraints Is lb ub)"
    by auto
  hence "of_int (lb x) \<le> \<langle>v\<rangle> x \<and> \<langle>v\<rangle> x \<le> of_int (ub x)"
    using bounds_to_constraints_sat x by blast
  (* I wonder why the automatic provers perform badly with `rat_of_int`.
     I have to add an intermediary step, and I also have to tell
     explicitely `metis` to use `Ints_of_int`. Even if I add explicitely this
     lemma, metis is the only prover that manages to use it. *)
  hence "rat_of_int (lb x) \<ge> rat_of_int (ub x) \<Longrightarrow> rat_of_int (lb x) = \<langle>v\<rangle> x"
    by linarith
  hence "\<not> (rat_of_int (lb x) \<ge> rat_of_int (ub x))"
    using `\<langle>v\<rangle> x \<notin> \<int>` Ints_of_int by metis

  hence "0 < ub x - lb x" by linarith
  moreover have "0 \<le> (\<Sum>i\<leftarrow>remove1 x Is. ub i - lb i)"
    using set_remove1_subset
    by (rule sat_impl_sum_diff_bounds_nonneg[OF sat])
  ultimately have "0 < (ub x - lb x) + (\<Sum>i\<leftarrow>remove1 x Is. ub i - lb i)"
    by linarith
  also have "\<dots> = (\<Sum>i\<leftarrow>Is. ub i - lb i)"
    using sum_list_map_remove1[OF x, of "\<lambda> i. ub i - lb i"] by auto
  finally show ?thesis by blast
qed

text \<open>The core of a branch-and-bound solver for mixed-integer linear problems.
It takes as arguments a constraint list, the list of integral variables, and
functions mapping integral variables to lower and upper-bounds\<close>
function branch_and_bound_core ::
  "constraint list \<Rightarrow> var list \<Rightarrow> (var \<Rightarrow> int) \<Rightarrow> (var \<Rightarrow> int)
     \<Rightarrow> rat valuation option" where
  "branch_and_bound_core cs Is lb ub =
    (case simplex (cs @ bounds_to_constraints Is lb ub) of
       Unsat _ \<Rightarrow> None
     | Sat r \<Rightarrow> (let v = \<langle>r\<rangle> in
         case find (\<lambda> x. v x \<notin> \<int>) Is of
           None \<Rightarrow> Some v
         | Some x \<Rightarrow> (let lb' = (\<lambda> y. if y = x then \<lceil>v x\<rceil> else lb y) in
            let ub' = (\<lambda> y. if y = x then \<lfloor>v x\<rfloor> else ub y) in
            let sol = branch_and_bound_core cs Is lb ub' in
            if sol \<noteq> None then sol else branch_and_bound_core cs Is lb' ub)))"
  by pat_completeness auto
termination
proof (relation "measure bb_measure", force, goal_cases)
  case (1 cs Is lb ub v vv x lb' ub')
  hence sat: "simplex (cs @ bounds_to_constraints Is lb ub) = Sat v"
   and x: "find (\<lambda>i. \<langle>v\<rangle> i \<notin> \<int>) Is = Some x" by auto
  let ?ub' = "\<lambda> i. (if i = x then  \<lfloor>\<langle>v\<rangle> x\<rfloor> else ub i)"
  from find_Some_set[OF x] have x: "x \<in> set Is" and "\<langle>v\<rangle> x \<notin> \<int>" by auto

  from sat simplex(3) have "\<langle>v\<rangle> \<Turnstile>\<^sub>c\<^sub>s set (bounds_to_constraints Is lb ub)"
    by auto
  hence "\<langle>v\<rangle> x \<le> of_int (ub x)" using bounds_to_constraints_sat x by blast
  hence ub'x: "\<lfloor>\<langle>v\<rangle> x\<rfloor> < ub x" using floor_less[OF \<open>\<langle>v\<rangle> x \<notin> \<int>\<close>] by linarith

  have "(\<Sum>i\<leftarrow>Is. ?ub' i - lb i) = ?ub' x - lb x +
                                   (\<Sum>i\<leftarrow>remove1 x Is. ?ub' i - lb i)"
    using sum_list_map_remove1[OF x] by blast
  moreover have "?ub' x - lb x < ub x - lb x" using ub'x by auto
  moreover have "(\<Sum>i\<leftarrow>remove1 x Is. ?ub' i - lb i) \<le>
                 (\<Sum>i\<leftarrow>remove1 x Is. ub i - lb i)"
    by(rule sum_list_mono, insert ub'x, simp)
  moreover have "(\<Sum>i\<leftarrow>Is. ub i - lb i) =
                 ub x - lb x + (\<Sum>i\<leftarrow>remove1 x Is. ub i - lb i)"
    using sum_list_map_remove1[OF x] by blast
  ultimately have "(\<Sum>i\<leftarrow>Is. ?ub' i - lb i) < (\<Sum>i\<leftarrow>Is. ub i - lb i)"
    by linarith
  thus ?case using nonnint_sat_pos_measure 1 by auto
next
  case (2 cs Is lb ub v vv x lb' ub' sol)
  hence sat: "simplex (cs @ bounds_to_constraints Is lb ub) = Sat v"
    and x: "find (\<lambda>i. \<langle>v\<rangle> i \<notin> \<int>) Is = Some x" by auto
  let ?lb' = "\<lambda> i. if i = x then \<lceil>\<langle>v\<rangle> x\<rceil> else lb i"
  from find_Some_set[OF x] have x: "x \<in> set Is" and "\<langle>v\<rangle> x \<notin> \<int>" by auto

  from sat simplex(3) have "\<langle>v\<rangle> \<Turnstile>\<^sub>c\<^sub>s set (bounds_to_constraints Is lb ub)"
    by auto
  hence "of_int (lb x) \<le> \<langle>v\<rangle> x" using bounds_to_constraints_sat x by blast
  hence lb'x: "lb x < \<lceil>\<langle>v\<rangle> x\<rceil>" using less_ceiling_iff[of "lb x" "\<langle>v\<rangle> x"]
    by (metis Ints_of_int \<open>\<langle>v\<rangle> x \<notin> \<int>\<close> order.not_eq_order_implies_strict)

  have "(\<Sum>i\<leftarrow>Is. ub i - ?lb' i) = ub x - ?lb' x +
                                   (\<Sum>i\<leftarrow>remove1 x Is. ub i - ?lb' i)"
    using sum_list_map_remove1[OF x] by blast
  moreover have "ub x - ?lb' x < ub x - lb x" using lb'x by auto
  moreover have "(\<Sum>i\<leftarrow>remove1 x Is. ub i - ?lb' i) \<le>
                 (\<Sum>i\<leftarrow>remove1 x Is. ub i - lb i)"
    by(rule sum_list_mono, insert lb'x, simp)
  moreover have "(\<Sum>i\<leftarrow>Is. ub i - lb i) =
                 ub x - lb x + (\<Sum>i\<leftarrow>remove1 x Is. ub i - lb i)"
    using sum_list_map_remove1[OF x] by blast
  ultimately have "(\<Sum>i\<leftarrow>Is. ub i - ?lb' i) < (\<Sum>i\<leftarrow>Is. ub i - lb i)"
    by linarith
  thus ?case using nonnint_sat_pos_measure 2 by auto
qed

(* as they make the simplifier non-terminate *)
declare branch_and_bound_core.simps[simp del]

lemma branch_and_bound_core_sat:
  "branch_and_bound_core cs Is lb ub = Some v \<Longrightarrow> v \<Turnstile>\<^sub>m\<^sub>c\<^sub>s (set cs, set Is)"
proof (induction rule: branch_and_bound_core.induct)
  case (1 cs Is lb ub)
  note [simp] = branch_and_bound_core.simps[of cs Is lb ub] (* activate simp-rules only for lb ub *)
  show ?case

  proof (cases "simplex (cs @ bounds_to_constraints Is lb ub)")
    case (Inr r)
    hence r: "\<langle>r\<rangle> \<Turnstile>\<^sub>c\<^sub>s set (cs @ bounds_to_constraints Is lb ub)"
      using simplex(3) by blast
    show ?thesis

    proof (cases "find (\<lambda> x. \<langle>r\<rangle> x \<notin> \<int>) Is")
      case None
      hence "\<forall> i \<in> set Is. \<langle>r\<rangle> i \<in> \<int>"
        using find_None_iff[of _ Is] by simp
      hence r: "\<langle>r\<rangle> \<Turnstile>\<^sub>m\<^sub>c\<^sub>s (set cs, set Is)" using r by auto
      have "branch_and_bound_core cs Is lb ub = Some \<langle>r\<rangle>"
        by (simp add: Inr None)
      hence "\<langle>r\<rangle> = v" using Inr 1(3) by auto
      thus ?thesis using r by blast

    next

      case (Some x)
      define lb' where "lb' = (\<lambda> y. if y = x then \<lceil>\<langle>r\<rangle> x\<rceil> else lb y)"
      define ub' where "ub' = (\<lambda> y. if y = x then \<lfloor>\<langle>r\<rangle> x\<rfloor> else ub y)"
      define sol where "sol = branch_and_bound_core cs Is lb ub'"
      show ?thesis
      proof (cases)
        assume sol: "sol = None"
        hence "branch_and_bound_core cs Is lb ub =
               branch_and_bound_core cs Is lb' ub"
          using Inr Some lb'_def ub'_def sol_def by simp
        hence "branch_and_bound_core cs Is lb' ub = Some v"
          using 1(3) by presburger
        thus ?thesis using sol 1(2)[OF Inr _ Some lb'_def ub'_def sol_def]
          by fast

      next

        assume sol: "sol \<noteq> None"
        hence "branch_and_bound_core cs Is lb ub = sol"
          using Inr Some unfolding sol_def ub'_def by force
        hence "sol = Some v" using 1(3) by blast
        thus ?thesis
          using 1(1)[OF Inr _ Some lb'_def ub'_def]
          unfolding sol_def by blast
      qed
    qed
  qed (insert 1, auto)
qed

lemma int_le_floor_iff:
  assumes "x \<in> \<int>"
  shows "x \<le> y \<longleftrightarrow> x \<le> of_int \<lfloor>y\<rfloor>"
proof
  assume "x \<le> y"
  thus "x \<le> of_int \<lfloor>y\<rfloor>"
    using le_floor_iff[of "\<lfloor>x\<rfloor>" "y"] floor_of_int_eq[OF assms] by auto
next
  assume "x \<le> of_int \<lfloor>y\<rfloor>"
  thus "x \<le> y"
    using le_floor_iff[of "\<lfloor>x\<rfloor>" "of_int \<lfloor>y\<rfloor>"] floor_of_int_eq[OF assms]
    by linarith
qed

lemma int_ge_ceiling_iff:
  assumes "x \<in> \<int>"
  shows "x \<ge> y \<longleftrightarrow> x \<ge> of_int \<lceil>y\<rceil>"
  unfolding ceiling_def
  using int_le_floor_iff[of "-x" "-y"] assms by fastforce

lemma branch_and_bound_core_unsat:
  "branch_and_bound_core c Is lb ub = None \<Longrightarrow>
   \<forall> i \<in> set Is. of_int (lb i) \<le> v i \<and> v i \<le> of_int (ub i) \<Longrightarrow>
   \<not> (v \<Turnstile>\<^sub>m\<^sub>c\<^sub>s (set c, set Is))"
proof (induction rule: branch_and_bound_core.induct)
  case (1 cs Is lb ub)
  note [simp] = branch_and_bound_core.simps[of cs Is lb ub] (* activate simp-rules only for lb ub *)
  show ?case
  proof (cases "simplex (cs @ bounds_to_constraints Is lb ub)")
    case Inl
    from bounds_to_constraints_sat[of Is lb ub v] 1(4)
    have "v \<Turnstile>\<^sub>c\<^sub>s set (bounds_to_constraints Is lb ub)" by blast
    hence "\<not> (v \<Turnstile>\<^sub>c\<^sub>s set cs)" using simplex(1)[OF Inl] by auto
    thus ?thesis by auto
  next
    case (Inr r)
    hence r: "\<langle>r\<rangle> \<Turnstile>\<^sub>c\<^sub>s set (cs @ bounds_to_constraints Is lb ub)"
      using simplex(3) by blast
    show ?thesis
    proof (cases "find (\<lambda> x. \<langle>r\<rangle> x \<notin> \<int>) Is")
      case None
      have "branch_and_bound_core cs Is lb ub = Some \<langle>r\<rangle>"
        by (simp add: Inr None)
      thus ?thesis using 1(3) by auto
    next

      case (Some x)
      hence x: "x \<in> set Is" and rx: "\<langle>r\<rangle> x \<notin> \<int>"
        using find_Some_set[of _ Is x] by (blast, blast)
      define lb' where "lb' = (\<lambda> y. if y = x then \<lceil>\<langle>r\<rangle> x\<rceil> else lb y)"
      define ub' where "ub' = (\<lambda> y. if y = x then \<lfloor>\<langle>r\<rangle> x\<rfloor> else ub y)"
      define sol where "sol = branch_and_bound_core cs Is lb ub'"
      show ?thesis
      proof (cases, standard)

        assume v: "v \<Turnstile>\<^sub>m\<^sub>c\<^sub>s (set cs, set Is)"
        assume sol: "sol = None"
        from v have "v x \<in> \<int>" using x by simp
        show False
        proof cases

          assume "v x \<le> \<langle>r\<rangle> x"
          hence "v x \<le> of_int \<lfloor>\<langle>r\<rangle> x\<rfloor>"
            using int_le_floor_iff[OF \<open>v x \<in> \<int>\<close>] by blast
          hence "\<forall>i\<in>set Is. of_int (lb i) \<le> v i \<and> v i \<le> of_int (ub' i)"
            using 1(4) unfolding ub'_def by auto
          thus False
            using 1(1)[OF Inr _ Some lb'_def ub'_def sol[unfolded sol_def]] v
            by blast

        next

          assume "~ (v x \<le> \<langle>r\<rangle> x)"
          hence "v x \<ge> \<langle>r\<rangle> x" by linarith
          hence "v x \<ge> of_int \<lceil>\<langle>r\<rangle> x\<rceil>"
            using int_ge_ceiling_iff[OF \<open>v x \<in> \<int>\<close>] by blast
          hence bnds: "\<forall>i\<in>set Is. of_int (lb' i) \<le> v i \<and> v i \<le> of_int (ub i)"
            using 1(4) unfolding lb'_def by auto

          from sol have "branch_and_bound_core cs Is lb ub =
                         branch_and_bound_core cs Is lb' ub"
            using Inr Some lb'_def ub'_def sol_def by simp
          hence sol_lb': "branch_and_bound_core cs Is lb' ub = None"
            using 1(3) by argo
          thus False
            using 1(2)[OF Inr _ Some lb'_def ub'_def sol_def _ sol_lb' bnds]
                  sol v by blast
        qed

      next
        assume sol: "sol \<noteq> None"
        hence "branch_and_bound_core cs Is lb ub = sol"
          using Inr Some unfolding sol_def ub'_def by force
        thus ?thesis using 1(3) sol by fast
      qed
    qed
  qed
qed

abbreviation (input) "Ltc \<equiv> Le_Constraint Lt_Rel"

(* There already exists a function `lec_of_constraint`, but it does not handle every
   cases. *)
primrec constraint_to_le_constraint where
  "constraint_to_le_constraint (LEQ l x) = [Leqc l x]"
| "constraint_to_le_constraint (GEQ l x) = [Leqc (-l) (-x)]"
| "constraint_to_le_constraint (LT l x) = [Ltc l x]"
| "constraint_to_le_constraint (GT l x) = [Ltc (-l) (-x)]"
| "constraint_to_le_constraint (EQ l x) = [Leqc l x, Leqc (-l) (-x)]"
| "constraint_to_le_constraint (LEQPP l0 l1) = [Leqc (l0 - l1) 0]"
| "constraint_to_le_constraint (GEQPP l0 l1) = [Leqc (l1 - l0) 0]"
| "constraint_to_le_constraint (LTPP l0 l1) = [Ltc (l0 - l1) 0]"
| "constraint_to_le_constraint (GTPP l0 l1) = [Ltc (l1 - l0) 0]"
| "constraint_to_le_constraint (EQPP l0 l1) = [Leqc (l0 - l1) 0, Leqc (l1 - l0) 0]"

lemma constraint_to_le_constraint:
  assumes "constraint_to_le_constraint c = cs"
  shows "v \<Turnstile>\<^sub>c c \<longleftrightarrow> (\<forall> c' \<in> set cs. v \<Turnstile>\<^sub>l\<^sub>e c')"
  by (insert assms, cases c, auto simp: valuate_minus valuate_uminus)

(* It could be interesting to re-index variables so that there are all consecutive
   in the normalization operation. *)
definition normalize where
  "normalize cs = concat (map constraint_to_le_constraint cs)"

lemma normalize_satisfies: "v \<Turnstile>\<^sub>c\<^sub>s set cs \<longleftrightarrow> (\<forall> c \<in> set (normalize cs). v \<Turnstile>\<^sub>l\<^sub>e c)"
  unfolding normalize_def using constraint_to_le_constraint by auto

definition integral_linear_poly where "integral_linear_poly l = (\<forall> x. coeff l x \<in> \<int>)"
abbreviation "integral_constraint c \<equiv>
              (integral_linear_poly (lec_poly c) \<and> lec_const c \<in> \<int>)"
definition integral_constraints where
"integral_constraints cs = (\<forall> c \<in> set cs. integral_constraint c)"

primrec max_coeff :: "rat le_constraint \<Rightarrow> rat" where
"max_coeff (Le_Constraint _ l c) = Max ({\<bar>c\<bar>} \<union> {\<bar>coeff l x\<bar> | x. x \<in> vars l})"

lemma max_coeff_const: "max_coeff (Le_Constraint r l c) \<ge> \<bar>c\<bar>"
  using finite_vars by auto

lemma max_coeff: "max_coeff (Le_Constraint r l c) \<ge> \<bar>coeff l x\<bar>"
proof cases
  assume "x \<in> vars l"
  hence "\<bar>coeff l x\<bar> \<in> {\<bar>c\<bar>} \<union> {\<bar>coeff l x\<bar> | x. x \<in> vars l}" by blast
  thus ?thesis using finite_vars by simp
next
  assume "x \<notin> vars l"
  hence "\<bar>coeff l x \<bar> = 0" using coeff_zero by auto
  also have "0 \<le> max_coeff (Le_Constraint r l c)"
    using max_coeff_const[of c r l] by linarith
  finally show ?thesis by blast
qed

lemma integral_max_coeff:
  assumes "integral_constraint c"
  shows "max_coeff c \<in> \<int>"
proof -
  obtain r l x where c: "c = Le_Constraint r l x"
    using le_constraint.collapse[of c] by metis

  have "max_coeff c \<in> {\<bar>x\<bar>} \<union> {\<bar>coeff l i\<bar> | i. i \<in> vars l}"
    unfolding c max_coeff.simps
    by (rule Max_in, insert finite_vars, simp_all)
  moreover have "{\<bar>x\<bar>} \<subseteq> \<int>" using assms unfolding c by auto
  moreover have "{\<bar>coeff l i\<bar> | i. i \<in> vars l} \<subseteq> \<int>"
    using assms unfolding c integral_linear_poly_def by auto
  ultimately show ?thesis by blast
qed

definition max_coeff_constraints where
"max_coeff_constraints cs = Max (set (0 # map max_coeff cs))"

lemma max_coeff_constraints_const:
  assumes "c \<in> set cs"
  shows "\<bar>lec_const c\<bar> \<le> max_coeff_constraints cs"
proof -
  have "\<bar>lec_const c\<bar> \<le> max_coeff c"
    using max_coeff_const le_constraint.collapse by metis
  moreover have "max_coeff c \<le> max_coeff_constraints cs"
    unfolding max_coeff_constraints_def using assms by auto
  ultimately show ?thesis by linarith
qed

lemma max_coeff_constraints:
  assumes "c \<in> set cs"
  shows "\<bar>coeff (lec_poly c) x\<bar> \<le> max_coeff_constraints cs"
proof -
  have "\<bar>coeff (lec_poly c) x\<bar> \<le> max_coeff c"
    using max_coeff le_constraint.collapse by metis
  moreover have "max_coeff c \<le> max_coeff_constraints cs"
    unfolding max_coeff_constraints_def using assms by auto
  ultimately show ?thesis by linarith
qed

definition constraints_to_pairs ::
  "rat le_constraint list \<Rightarrow> (linear_poly \<times> rat) list \<times> (linear_poly \<times> rat) list"
where "constraints_to_pairs cs =
  (let leq_cs = filter (\<lambda> c. lec_rel c = Leq_Rel) cs in
   let lt_cs = filter (\<lambda> c. lec_rel c = Lt_Rel) cs in
   (map (\<lambda> c. (lec_poly c, lec_const c)) leq_cs,
    map (\<lambda> c. (lec_poly c, lec_const c)) lt_cs))"

lemma constraints_to_pairs:
  assumes "constraints_to_pairs cs = (leq_pairs, lt_pairs)"
  shows "(\<forall> c \<in> set cs. v \<Turnstile>\<^sub>l\<^sub>e c) \<longleftrightarrow> ((\<forall> (l, x) \<in> set leq_pairs. (l \<lbrace> v \<rbrace>) \<le> x) \<and>
                                       (\<forall> (l, x) \<in> set lt_pairs. (l \<lbrace> v \<rbrace>) < x))"
    (is "?L \<longleftrightarrow> ?R")
  and "integral_constraints cs \<Longrightarrow>
      (l, x) \<in> set leq_pairs \<union> set lt_pairs \<Longrightarrow> integral_linear_poly l \<and> x \<in> \<int>"
    (is "?INT0 \<Longrightarrow> ?LX \<Longrightarrow> ?INT1")
  and "(l, x) \<in> set leq_pairs \<union> set lt_pairs \<Longrightarrow>
        \<bar>coeff l i\<bar> \<le> max_coeff_constraints cs \<and> \<bar>x\<bar> \<le> max_coeff_constraints cs"
    (is "?LX' \<Longrightarrow> ?BND")
proof -
  define leq_cs where "leq_cs = filter (\<lambda> c. lec_rel c = Leq_Rel) cs"
  define lt_cs where "lt_cs = filter (\<lambda> c. lec_rel c = Lt_Rel) cs"
  have "constraints_to_pairs cs = (map (\<lambda> c. (lec_poly c, lec_const c)) leq_cs,
                                   map (\<lambda> c. (lec_poly c, lec_const c)) lt_cs)"
    unfolding constraints_to_pairs_def leq_cs_def lt_cs_def
    by metis
  hence leq_pairs: "leq_pairs = map (\<lambda> c. (lec_poly c, lec_const c)) leq_cs"
     and lt_pairs: "lt_pairs = map (\<lambda> c. (lec_poly c, lec_const c)) lt_cs"
    using assms by auto

  have constructor: "\<And> c. c = Leq_Rel \<or> c = Lt_Rel"
  proof -
    fix c show "c = Leq_Rel \<or> c = Lt_Rel" by (cases c, simp_all)
  qed

  have "\<forall> c \<in> set leq_cs. lec_rel c = Leq_Rel" unfolding leq_cs_def by fastforce
  (* Why do automatic proving perform so bad on the following statement? Is there
     an infinite simplifications loop or something like that? *)
  hence leq_decomp: "\<forall> c \<in> set leq_cs. c = Le_Constraint Leq_Rel (lec_poly c) (lec_const c)"
    using leq_cs_def le_constraint.collapse by metis
  have "\<forall> c \<in> set lt_cs. lec_rel c = Lt_Rel" unfolding lt_cs_def by fastforce
  hence lt_decomp: "\<forall> c \<in> set lt_cs. c = Le_Constraint Lt_Rel (lec_poly c) (lec_const c)"
    using leq_cs_def le_constraint.collapse by metis

  have sets: "set cs = set leq_cs \<union> set lt_cs"
    unfolding leq_cs_def lt_cs_def using constructor by auto
  have "(\<forall> c \<in> set cs. v \<Turnstile>\<^sub>l\<^sub>e c) \<longleftrightarrow>
        (\<forall> c \<in> set leq_cs. v \<Turnstile>\<^sub>l\<^sub>e c) \<and> (\<forall> c \<in> set lt_cs. v \<Turnstile>\<^sub>l\<^sub>e c)"
    unfolding leq_cs_def lt_cs_def using constructor by auto
  also have "(\<forall> c \<in> set leq_cs. v \<Turnstile>\<^sub>l\<^sub>e c) \<longleftrightarrow>
             (\<forall> c \<in> set leq_cs. ((lec_poly c) \<lbrace> v \<rbrace>) \<le> (lec_const c))"
    using leq_decomp satisfiable_le_constraint.simps[of v] rel_of.simps(1) by metis
  also have "(\<forall> c \<in> set lt_cs. v \<Turnstile>\<^sub>l\<^sub>e c) \<longleftrightarrow>
             (\<forall> c \<in> set lt_cs. ((lec_poly c) \<lbrace> v \<rbrace>) < (lec_const c))"
    using lt_decomp satisfiable_le_constraint.simps[of v] rel_of.simps(2) by metis
  finally show "?L \<longleftrightarrow> ?R" unfolding leq_pairs lt_pairs by auto

  show "?INT0 \<Longrightarrow> ?LX \<Longrightarrow> ?INT1"
    unfolding integral_constraints_def leq_pairs lt_pairs sets
    by auto

  assume "?LX'"
  then obtain c where c: "c \<in> set cs"
                and l: "l = lec_poly c" and x: "x = lec_const c"
    unfolding leq_pairs lt_pairs sets by auto
  show ?BND
    unfolding l x
    using max_coeff_constraints[OF c, of i] max_coeff_constraints_const[OF c]
    by blast
qed

lift_definition vec_of_poly :: "linear_poly \<Rightarrow> nat \<Rightarrow> rat vec" is
  "\<lambda> l n. vec n l"
  .

lemma vec_of_poly_dim[simp]: "vec_of_poly v n \<in> carrier_vec n"
  by (transfer, auto)

lemma inverse_vec_of_poly:
  assumes "n > max_var l"
  shows "poly_of_vec (vec_of_poly l n) = l"
proof -
  have "\<forall> i \<ge> n. i \<notin> vars l" using assms max_var_max by fastforce
  thus ?thesis by (transfer, force)
qed

lemma dot_vec_of_poly:
  assumes v: "v \<in> carrier_vec n"
  assumes l: "n > Abstract_Linear_Poly.max_var l"
  shows "(vec_of_poly l n) \<bullet> v = (l \<lbrace> val_of_vec v \<rbrace>)"
  using valuate_poly_of_vec[OF v, of "vec_of_poly l n"]
        inverse_vec_of_poly[OF l] by simp

lemma integral_vec_of_poly:
  "integral_linear_poly l \<Longrightarrow> vec_of_poly l n \<in> \<int>\<^sub>v"
  unfolding integral_linear_poly_def
  by (transfer, auto simp: Ints_vec_def)

lemma vec_of_poly_bound:
  "\<forall> x. \<bar>coeff l x\<bar> \<le> Bnd \<Longrightarrow> vec_of_poly l n \<in> Bounded_vec Bnd"
  by (transfer, auto simp: Bounded_vec_def)

abbreviation "lec_max_var \<equiv> max_var \<circ> lec_poly"

definition constraints_max_var :: "rat le_constraint list \<Rightarrow> nat" where
"constraints_max_var cs = Max (set (0 # map lec_max_var cs))"

lemma constraints_max_var_to_pairs:
  assumes "constraints_to_pairs cs = (leq_pairs, lt_pairs)"
  assumes "(l, x) \<in> set leq_pairs \<union> set lt_pairs"
  shows "max_var l \<le> constraints_max_var cs"
proof -
  define leq_cs where "leq_cs = filter (\<lambda> c. lec_rel c = Leq_Rel) cs"
  define lt_cs where "lt_cs = filter (\<lambda> c. lec_rel c = Lt_Rel) cs"
  have "constraints_to_pairs cs = (map (\<lambda> c. (lec_poly c, lec_const c)) leq_cs,
                                   map (\<lambda> c. (lec_poly c, lec_const c)) lt_cs)"
    unfolding constraints_to_pairs_def leq_cs_def lt_cs_def
    by metis
  hence leq_pairs: "leq_pairs = map (\<lambda> c. (lec_poly c, lec_const c)) leq_cs"
     and lt_pairs: "lt_pairs = map (\<lambda> c. (lec_poly c, lec_const c)) lt_cs"
    using assms(1) by auto
  then obtain c where "c \<in> set cs" and "l = lec_poly c"
    using assms(2) unfolding leq_pairs lt_pairs leq_cs_def lt_cs_def by force
  moreover have "constraints_max_var cs = Max (set (0 # map lec_max_var cs))"
    unfolding constraints_max_var_def by presburger
  ultimately show ?thesis by simp
qed

definition mats_vecs_of_constraints ::
  "rat le_constraint list \<Rightarrow> rat mat \<times> rat vec \<times> rat mat \<times> rat vec" where
"mats_vecs_of_constraints cs = (
  let n = 1 + constraints_max_var cs in
  let (leq_pairs, lt_pairs) = constraints_to_pairs cs in
  let leq_polys = map fst leq_pairs in
  let leq_rows = map (\<lambda> l. vec_of_poly l n) leq_polys in
  let leq_bounds = map snd leq_pairs in
  let lt_polys = map fst lt_pairs in
  let lt_rows = map (\<lambda> l. vec_of_poly l n) lt_polys in
  let lt_bounds = map snd lt_pairs in
  (mat_of_rows n leq_rows, vec_of_list leq_bounds,
   mat_of_rows n lt_rows, vec_of_list lt_bounds))"

lemma satisfies_le_constraint_depend:
  assumes "n > lec_max_var c"
  and "\<forall> x < n. v0 x = v1 x"
shows "v0 \<Turnstile>\<^sub>l\<^sub>e c \<longleftrightarrow> v1 \<Turnstile>\<^sub>l\<^sub>e c"
proof -
  from assms have "\<forall> x \<in> vars (lec_poly c). v0 x = v1 x"
    using max_var_max[of _ "lec_poly c"] by force
  hence "((lec_poly c) \<lbrace> v0 \<rbrace>) = ((lec_poly c) \<lbrace> v1 \<rbrace>)"
    using valuate_depend by blast
  thus ?thesis
    using satisfiable_le_constraint.simps le_constraint.collapse by metis
qed

lemma satisfies_constraints_depend:
  assumes "n > constraints_max_var cs"
  and "\<forall> x < n. v0 x = v1 x"
shows "(\<forall> c \<in> set cs. v0 \<Turnstile>\<^sub>l\<^sub>e c) \<longleftrightarrow> (\<forall> c \<in> set cs. v1 \<Turnstile>\<^sub>l\<^sub>e c)"
proof -
  have "constraints_max_var cs =  Max (set (0 # map lec_max_var cs))"
    unfolding constraints_max_var_def by presburger
  hence "\<And> c. c \<in> set cs \<Longrightarrow> lec_max_var c < n" using assms(1) by fastforce
  thus ?thesis using satisfies_le_constraint_depend[OF _ assms(2)] by blast
qed

lemma mats_vecs_of_constraints:
  assumes "mats_vecs_of_constraints cs = (A, b, A', b')"
   and n: "n = 1 + constraints_max_var cs"
  shows "\<exists> nr nr'. A \<in> carrier_mat nr n \<and>
                   b \<in> carrier_vec nr \<and>
                   A' \<in> carrier_mat nr' n \<and>
                   b' \<in> carrier_vec nr'" (is ?DIM)
   and "(\<forall> c \<in> set cs. v \<Turnstile>\<^sub>l\<^sub>e c) \<longleftrightarrow> (A *\<^sub>v (vec n v) \<le> b \<and> A' *\<^sub>v (vec n v) <\<^sub>v b')"
     (is "?L \<longleftrightarrow> ?R")
   and "integral_constraints cs \<Longrightarrow> A \<in> \<int>\<^sub>m \<and> b \<in> \<int>\<^sub>v \<and> A' \<in> \<int>\<^sub>m \<and> b' \<in> \<int>\<^sub>v"
      (is "?INT0 \<Longrightarrow> ?INT1")
   and "A \<in> Bounded_mat (max_coeff_constraints cs) \<and>
        b \<in> Bounded_vec (max_coeff_constraints cs) \<and>
        A' \<in> Bounded_mat (max_coeff_constraints cs) \<and>
        b' \<in> Bounded_vec (max_coeff_constraints cs)" (is ?BNDS)
proof -
  obtain leq_pairs lt_pairs leq_polys lt_polys
         leq_rows leq_bounds lt_rows lt_bounds
         where
          pairs: "constraints_to_pairs cs = (leq_pairs, lt_pairs)" and
          leq_polys: "leq_polys = map fst leq_pairs" and
          leq_rows: "leq_rows = map (\<lambda> l. vec_of_poly l n) leq_polys" and
          leq_bounds: "leq_bounds = map snd leq_pairs" and
          lt_polys: "lt_polys = map fst lt_pairs" and
          lt_rows: "lt_rows = map (\<lambda> l. vec_of_poly l n) lt_polys" and
          lt_bounds: "lt_bounds = map snd lt_pairs" and
          res: "mats_vecs_of_constraints cs = (mat_of_rows n leq_rows,
                                               vec_of_list leq_bounds,
                                               mat_of_rows n lt_rows,
                                               vec_of_list lt_bounds)"
    unfolding mats_vecs_of_constraints_def
      apply(cases "constraints_to_pairs cs")
      apply(simp add: n del: vec_of_list_map)
      done
    from res assms(1) have A: "A = mat_of_rows n leq_rows" and
                           b: "b = vec_of_list leq_bounds" and
                           A': "A' = mat_of_rows n lt_rows" and
                           b': "b' = vec_of_list lt_bounds" by auto
  have A_carrier: "A \<in> carrier_mat (length leq_pairs) n" and
       b_carrier: "b \<in> carrier_vec (length leq_pairs)"
    using A b leq_rows leq_polys leq_bounds by (fastforce, fastforce)
  have A'_carrier: "A' \<in> carrier_mat (length lt_pairs) n" and
       b'_carrier: "b' \<in> carrier_vec (length lt_pairs)"
    using A' b' lt_rows lt_polys lt_bounds by (fastforce, fastforce)
  show ?DIM using A_carrier b_carrier A'_carrier b'_carrier by blast

  show "?L \<longleftrightarrow> ?R" proof(standard)
    assume v: ?L

    have "A *\<^sub>v (vec n v) \<le> b"
    proof (rule lesseq_vecI[OF _ b_carrier], insert A_carrier, simp)
      fix i
      assume i: "i < length leq_pairs"
      hence i': "i < dim_row A" using A leq_rows leq_polys by fastforce
      have pairs_i: "(leq_polys ! i, leq_bounds ! i) \<in> set leq_pairs"
        using i leq_polys leq_bounds by fastforce
      have max_var: "max_var (leq_polys ! i) < n" using n leq_polys
        using constraints_max_var_to_pairs[OF pairs, of "leq_polys ! i" "leq_bounds ! i"]
              pairs_i by force

      from v have "(\<forall> (l, x) \<in> set leq_pairs. (l \<lbrace> v \<rbrace>) \<le> x)"
        using constraints_to_pairs(1)[OF pairs] by blast
      hence "(leq_polys ! i) \<lbrace> v \<rbrace> \<le> leq_bounds ! i"
        using i leq_polys leq_bounds by auto
      also have "valuate (leq_polys ! i) v =
                 valuate (leq_polys ! i) (val_of_vec (vec n v))"
        unfolding val_of_vec_def
        apply(rule valuate_depend)
        apply(insert max_var max_var_max, force)
        done
      also have "\<dots> = vec_of_poly (leq_polys ! i) n \<bullet> (vec n v)"
        using dot_vec_of_poly[of "vec n v" n, OF _ max_var] by fastforce
      also have "vec_of_poly (leq_polys ! i) n = row A i"
        unfolding A leq_rows leq_polys
        using i length_map[of fst leq_pairs] by fastforce
      also have "row A i \<bullet> vec n v = (A *\<^sub>v (vec n v)) $ i"
        using index_mult_mat_vec[OF i'] by presburger
      also have "leq_bounds ! i = b $ i" unfolding b using i leq_bounds by fastforce
      finally show "(A *\<^sub>v (vec n v)) $ i \<le> b $ i" by blast
    qed

    moreover

    have "A' *\<^sub>v (vec n v) <\<^sub>v b'"
    proof (rule less_vecI[OF _ b'_carrier], insert A'_carrier, simp)
      fix i
      assume i: "i < length lt_pairs"
      hence i': "i < dim_row A'" using A' lt_rows lt_polys by force
      have pairs_i: "(lt_polys ! i, lt_bounds ! i) \<in> set lt_pairs"
        using i lt_polys lt_bounds by fastforce
      have max_var: "max_var (lt_polys ! i) < n" using n leq_polys
        using constraints_max_var_to_pairs[OF pairs] pairs_i by fastforce

      from v have "(\<forall> (l, x) \<in> set lt_pairs. (l \<lbrace> v \<rbrace>) < x)"
        using constraints_to_pairs(1)[OF pairs] by algebra
      hence "(lt_polys ! i) \<lbrace> v \<rbrace> < lt_bounds ! i"
        using i lt_polys lt_bounds by auto
      also have "valuate (lt_polys ! i) v =
                 valuate (lt_polys ! i) (val_of_vec (vec n v))"
        unfolding val_of_vec_def
        apply(rule valuate_depend)
        apply(insert max_var max_var_max, force)
        done
      also have "\<dots> = vec_of_poly (lt_polys ! i) n \<bullet> (vec n v)"
        using dot_vec_of_poly[of "vec n v" n, OF _ max_var] by fastforce
      also have "vec_of_poly (lt_polys ! i) n = row A' i"
        unfolding A' lt_rows lt_polys
        using i length_map[of fst lt_pairs] by fastforce
      also have "row A' i \<bullet> vec n v = (A' *\<^sub>v (vec n v)) $ i"
        using index_mult_mat_vec[OF i'] by presburger
      also have "lt_bounds ! i = b' $ i" unfolding b' using i lt_bounds by fastforce
      finally show "(A' *\<^sub>v (vec n v)) $ i < b' $ i" by blast
    qed
    ultimately show ?R by fastforce

  next
    assume R: ?R
    define x where "x = vec n v"
    have xn: "x \<in> carrier_vec n" and x0: "A *\<^sub>v x \<le> b" and x1: "A' *\<^sub>v x <\<^sub>v b'"
      using R unfolding x_def by auto
  {
    fix l t
    assume lt0: "(l, t) \<in> set leq_pairs"
    then obtain i where i: "i < length leq_pairs" and lt: "(l, t) = leq_pairs ! i"
      by (metis in_set_conv_nth)
    have max_var: "max_var l < n"
      using constraints_max_var_to_pairs[OF pairs, of l t] n lt0 by fastforce

    have "(A *\<^sub>v x) $ i \<le> b $ i" by (rule lesseq_vecD[OF b_carrier x0 i])
    also have "(A *\<^sub>v x) $ i = row A i \<bullet> x"
      by (rule index_mult_mat_vec, simp add: i A leq_rows leq_polys)
    also have "row A i = vec_of_poly l n"
      unfolding A leq_rows leq_polys
      using i length_map[of fst leq_pairs] lt fst_conv[of l t] by simp
    also have "vec_of_poly l n \<bullet> x = (l \<lbrace> val_of_vec x \<rbrace>)"
      by (rule dot_vec_of_poly[OF xn max_var])
    also have "b $ i = t" unfolding b leq_bounds using i lt
      using snd_conv[of l t] vec_of_list_index by simp
    finally have "(l \<lbrace> val_of_vec x \<rbrace>) \<le> t" by blast
  } moreover {
    fix l t
    assume lt0: "(l, t) \<in> set lt_pairs"
    then obtain i where i: "i < length lt_pairs" and lt: "(l, t) = lt_pairs ! i"
      by (metis in_set_conv_nth)
    have max_var: "max_var l < n"
      using constraints_max_var_to_pairs[OF pairs, of l t] n lt0 by fastforce

    have "(A' *\<^sub>v x) $ i < b' $ i"
      by (rule less_vecD[OF x1 b'_carrier i])
    also have "(A' *\<^sub>v x) $ i = row A' i \<bullet> x"
      by (rule index_mult_mat_vec, simp add: i A' lt_rows lt_polys)
    also have "row A' i = vec_of_poly l n"
      unfolding A' lt_rows lt_polys
      using i length_map[of fst lt_pairs] lt fst_conv[of l t] by simp
    also have "vec_of_poly l n \<bullet> x = (l \<lbrace> val_of_vec x \<rbrace>)"
      by (rule dot_vec_of_poly[OF xn max_var])
    also have "b' $ i = t" unfolding b' lt_bounds using i lt
      using snd_conv[of l t] vec_of_list_index by simp
    finally have "(l \<lbrace> val_of_vec x \<rbrace>) < t" by blast
  }
  ultimately have
    "(\<forall>(l, t)\<in>set leq_pairs. (l \<lbrace> val_of_vec x \<rbrace>) \<le> t) \<and>
     (\<forall>(l, t)\<in>set lt_pairs. (l \<lbrace> val_of_vec x \<rbrace>) < t)" by blast
  hence "\<forall> c \<in> set cs. val_of_vec x \<Turnstile>\<^sub>l\<^sub>e c"
    using constraints_to_pairs(1)[OF pairs] by presburger
  thus ?L  using satisfies_constraints_depend[of cs n v "val_of_vec x"] n
    unfolding x_def val_of_vec_def by fastforce
  qed

  have leq_rows_carrier: "set leq_rows \<subseteq> carrier_vec n" unfolding leq_rows by auto
  have lt_rows_carrier: "set lt_rows \<subseteq> carrier_vec n" unfolding lt_rows by auto

  let ?Bnd = "max_coeff_constraints cs"
  from constraints_to_pairs(3)[OF pairs]
  have polys: "\<forall> l \<in> set leq_polys \<union> set lt_polys. \<forall> i. \<bar>coeff l i\<bar> \<le> ?Bnd"
   and bounds: "\<forall> c \<in> set leq_bounds \<union> set lt_bounds. \<bar>c\<bar> \<le> ?Bnd"
    unfolding leq_polys lt_polys leq_bounds lt_bounds by (force, force)
  from polys have "set leq_rows \<union> set lt_rows \<subseteq> Bounded_vec ?Bnd"
    unfolding leq_rows lt_rows
    using vec_of_poly_bound[of _ _ n] by auto
  hence "A \<in> Bounded_mat ?Bnd \<and> A' \<in> Bounded_mat ?Bnd"
    using Bounded_vec_rows_Bounded_mat[of _ ?Bnd]
          rows_mat_of_rows[OF leq_rows_carrier]
          rows_mat_of_rows[OF lt_rows_carrier]
    unfolding A A' by fastforce
  moreover have "b \<in> Bounded_vec ?Bnd \<and> b' \<in> Bounded_vec ?Bnd"
    by(auto simp: b b' Bounded_vec_def bounds)
  ultimately show ?BNDS by blast

  assume int0: ?INT0
  from constraints_to_pairs(2)[OF pairs int0]
  have polys: "\<forall> l \<in> set leq_polys \<union> set lt_polys. integral_linear_poly l"
   and bounds: "set leq_bounds \<union> set lt_bounds \<subseteq> \<int>"
    unfolding leq_polys lt_polys leq_bounds lt_bounds
    by (force, force)

  from polys have "set leq_rows \<union> set lt_rows \<subseteq> \<int>\<^sub>v"
    unfolding leq_rows lt_rows using integral_vec_of_poly[of _ n] by auto
  hence "A \<in> \<int>\<^sub>m \<and> A' \<in> \<int>\<^sub>m" unfolding A A'
    using Ints_vec_rows_Ints_mat rows_mat_of_rows[OF leq_rows_carrier]
                                 rows_mat_of_rows[OF lt_rows_carrier] by fastforce
  moreover have "b \<in> \<int>\<^sub>v \<and> b' \<in> \<int>\<^sub>v" unfolding b b' Ints_vec_def
    using bounds by fastforce
  ultimately show ?INT1 by blast
qed

primrec mul_constraint where
"mul_constraint x (Le_Constraint r l c) = Le_Constraint r (x *R l) (x * c)"

lemma mul_constraint:
  assumes "x > 0"
  shows "v \<Turnstile>\<^sub>l\<^sub>e c \<longleftrightarrow> v \<Turnstile>\<^sub>l\<^sub>e mul_constraint x c"
proof -
  from le_constraint.collapse[of c] obtain r l y where
    decomp: "c = Le_Constraint r l y"
    by metis
  have "(l \<lbrace> v \<rbrace>) < y \<longleftrightarrow> ((x *R l) \<lbrace> v \<rbrace>) < x * y"
    using mult_less_cancel_left_pos[OF assms] valuate_scaleRat[of x l v]
    by force
  moreover have "(l \<lbrace> v \<rbrace>) \<le> y \<longleftrightarrow> ((x *R l) \<lbrace> v \<rbrace>) \<le> x * y"
    using mult_le_cancel_left_pos[OF assms] valuate_scaleRat[of x l v]
    by force
  ultimately show ?thesis unfolding decomp
    by (cases r, simp_all)
qed

primrec common_denominator where
"common_denominator (Le_Constraint _ l c) =
  (let coeffs_list = map (coeff l) (vars_list l) in
   let denominators = map (snd \<circ> quotient_of) (c # coeffs_list) in
   lcm_list denominators)"

lemma mult_denom_int:
  assumes "quotient_of x = (n, d)"
  and "d dvd d'"
  shows "of_int d' * x \<in> \<int>"
proof -
  from assms(2) obtain k where d': "d' = k * d" unfolding dvd_def by fastforce
  have "d \<noteq> 0" using assms quotient_of_nonzero(2)[of x] by auto
  hence "of_int n = of_int d * x" using quotient_of_div[OF assms(1)] by simp
  hence "of_int d * x \<in> \<int>" using Ints_of_int by metis
  hence "of_int k * (of_int d * x) \<in> \<int>" by simp
  hence "(of_int k * of_int d) * x \<in> \<int>" using mult.assoc by metis
  thus ?thesis unfolding d' by simp
qed

lemma common_denominator:
  shows "common_denominator c > 0" (is ?pos)
   and "of_int (common_denominator c) * lec_const c \<in> \<int>" (is ?const)
   and "of_int (common_denominator c) * (coeff (lec_poly c) i) \<in> \<int>"
     (is ?coeff)
proof -
  from le_constraint.collapse[of c] obtain r l x where
    decomp: "c = Le_Constraint r l x"
    by metis
  define coeffs_list where "coeffs_list = map (coeff l) (vars_list l)"
  define denominators where "denominators = map (snd \<circ> quotient_of) (x # coeffs_list)"
  have res: "common_denominator c = lcm_list denominators"
    unfolding decomp denominators_def coeffs_list_def common_denominator.simps
    by presburger

  have "0 \<notin> set denominators"
    unfolding denominators_def using quotient_of_nonzero(2) by fastforce
  thus ?pos using res list_lcm_pos(3) by presburger

  have "snd (quotient_of x) dvd common_denominator c"
    using list_lcm unfolding res denominators_def by auto
  thus ?const
    using mult_denom_int[OF surjective_pairing]
    unfolding decomp le_constraint.sel(3) by blast

  show ?coeff
  proof cases
    assume "i \<in> vars l"
    hence "coeff l i \<in> set coeffs_list"
      unfolding coeffs_list_def using set_vars_list by auto
    hence "snd (quotient_of (coeff l i)) dvd common_denominator c"
      using list_lcm unfolding res denominators_def by auto
    thus ?coeff
    using mult_denom_int[OF surjective_pairing]
    unfolding decomp le_constraint.sel(2) by blast
  next
    assume "i \<notin> vars l"
    hence "coeff l i = 0" using coeff_zero by fast
    thus ?coeff unfolding decomp le_constraint.sel(2) by auto
  qed
qed

definition
"constraint_to_ints c = mul_constraint (rat_of_int (common_denominator c)) c"

lemma constraint_to_ints: fixes c :: "rat le_constraint"
  shows "v \<Turnstile>\<^sub>l\<^sub>e c \<longleftrightarrow> v \<Turnstile>\<^sub>l\<^sub>e constraint_to_ints c" (is ?R0)
  and "integral_constraint (constraint_to_ints c)" (is ?R1)
proof -
  show ?R0
    using common_denominator(1) mul_constraint
    unfolding constraint_to_ints_def by presburger

  let ?x = "of_int (common_denominator c)"
  have "c = Le_Constraint (lec_rel c) (lec_poly c) (lec_const c)"
    using le_constraint.collapse by auto
  hence "mul_constraint ?x c =
         Le_Constraint (lec_rel c) (?x *R lec_poly c) (?x * lec_const c)"
    using mul_constraint.simps by metis
  hence "lec_poly (mul_constraint ?x c) = ?x *R lec_poly c"
   and "lec_const (mul_constraint ?x c) = ?x * lec_const c" by auto
  thus ?R1 using common_denominator(2-3) unfolding integral_linear_poly_def
unfolding constraint_to_ints_def
    by simp
qed

definition compute_bound :: "constraint list \<Rightarrow> int" where
"compute_bound cs =
  (let le_cs = normalize cs in
   let le_cs' = map constraint_to_ints le_cs in
   let max_coeff = max_coeff_constraints le_cs' in
   let n = 1 + constraints_max_var le_cs' in
   fact (n + 1) * (max 1 \<lfloor>max_coeff\<rfloor>) ^ n)"

lemma compute_bound:
  assumes "v \<Turnstile>\<^sub>m\<^sub>c\<^sub>s (set cs, I)"
  shows "\<exists> v. v \<Turnstile>\<^sub>m\<^sub>c\<^sub>s (set cs, I) \<and> (\<forall> i \<in> I. \<bar>v i\<bar> \<le> of_int (compute_bound cs))"
proof -
  define le_cs where "le_cs = normalize cs"
  define le_cs' where "le_cs' = map constraint_to_ints le_cs"
  define max_cf where "max_cf = max_coeff_constraints le_cs'"
  define n where "n = 1 + constraints_max_var le_cs'"
  define Bnd where "Bnd = fact (n + 1) * (max 1 \<lfloor>max_cf\<rfloor>) ^ n"
  have id: "compute_bound cs = Bnd"
    unfolding compute_bound_def le_cs_def le_cs'_def
              max_cf_def n_def Bnd_def by metis

  interpret gram_schmidt_floor n .

  have int: "integral_constraints le_cs'"
    unfolding le_cs'_def integral_constraints_def
    using constraint_to_ints(2) by auto
  hence "max_cf \<in> \<int>"
    unfolding max_cf_def integral_constraints_def
              max_coeff_constraints_def
    using integral_max_coeff Max_in[of "set (0 # map max_coeff le_cs')"]
    by fastforce
  hence "of_int \<lfloor>max_cf\<rfloor> = max_cf" using floor_of_int_eq by blast
  hence "of_int (max 1 \<lfloor>max_cf\<rfloor>) = max 1 max_cf" by linarith
  hence Bnd_rat: "of_int Bnd = fact (n + 1) * (max 1 max_cf) ^ n"
    unfolding Bnd_def by simp

  have "rat_of_int Bnd \<ge> 0" unfolding Bnd_def by fastforce

  obtain A b A' b' where matsvecs: "mats_vecs_of_constraints le_cs' = (A, b, A', b')"
    by (rule prod_cases4)
  obtain nr nr' where
    A_dim: "A \<in> carrier_mat nr n" and b_dim: "b \<in> carrier_vec nr" and
    A'_dim: "A' \<in> carrier_mat nr' n" and b'_dim: "b' \<in> carrier_vec nr'"
    using mats_vecs_of_constraints(1)[OF matsvecs n_def] by blast

  from mats_vecs_of_constraints(3-4)[OF matsvecs n_def] int
  have A: "A \<in> \<int>\<^sub>m \<inter> Bounded_mat max_cf"
   and A': "A' \<in> \<int>\<^sub>m \<inter> Bounded_mat max_cf"
   and b: "b \<in> \<int>\<^sub>v \<inter> Bounded_vec max_cf"
   and b': "b' \<in> \<int>\<^sub>v \<inter> Bounded_vec max_cf"
    unfolding max_cf_def by auto
  {
    fix v
    have "v \<Turnstile>\<^sub>c\<^sub>s set cs \<longleftrightarrow> (\<forall> c \<in> set le_cs. v \<Turnstile>\<^sub>l\<^sub>e c)"
      unfolding le_cs_def by (rule normalize_satisfies)
    also have "\<dots> \<longleftrightarrow> (\<forall> c \<in> set le_cs'. v \<Turnstile>\<^sub>l\<^sub>e c)"
      unfolding le_cs'_def using constraint_to_ints(1) by auto
    also have "\<dots> \<longleftrightarrow> (A *\<^sub>v vec n v \<le> b \<and> A' *\<^sub>v vec n v <\<^sub>v b')"
      by (rule mats_vecs_of_constraints(2)[OF matsvecs n_def])
    finally have "v \<Turnstile>\<^sub>c\<^sub>s set cs \<longleftrightarrow> (A *\<^sub>v vec n v \<le> b \<and> A' *\<^sub>v vec n v <\<^sub>v b')"
      by blast
  } note sat_cs = this
  hence Avb: "A *\<^sub>v vec n v \<le> b" and A'vb': "A' *\<^sub>v vec n v <\<^sub>v b'" using assms by auto
  from assms have "vec n v \<in> indexed_Ints_vec I"
    unfolding indexed_Ints_vec_def by auto
  then obtain x where xn: "x \<in> carrier_vec n" and xI: "x \<in> indexed_Ints_vec I"
                       and Axb: "A *\<^sub>v x \<le> b" and A'xb': "A' *\<^sub>v x <\<^sub>v b'"
                       and xBnd: "x \<in> Bounded_vec (of_int Bnd)"

    using small_mixed_integer_solution[OF A_dim A'_dim b_dim b'_dim
                                          A b A' b' _ _ Avb A'vb']
    unfolding Bnd_rat max_cf_def
    by auto

  define v' where "v' = (\<lambda> i. if i < n then x $ i else 0)"
  have "vec n v' = x" unfolding v'_def using xn by fastforce
  hence "v' \<Turnstile>\<^sub>c\<^sub>s set cs"
    using sat_cs Axb A'xb' by presburger
  moreover have "\<forall> i \<in> I. v' i \<in> \<int>"
    using xI xn unfolding v'_def indexed_Ints_vec_def by fastforce
  moreover have "\<forall> i. \<bar>v' i\<bar> \<le> of_int Bnd"
  proof (rule allI, cases)
    fix i assume "i < n"
    thus "\<bar>v' i\<bar> \<le> of_int Bnd"
      using xBnd xn unfolding v'_def Bounded_vec_def by fastforce
  next
    fix i assume "\<not> (i < n)"
    thus "\<bar>v' i\<bar> \<le> of_int Bnd" unfolding v'_def using `of_int Bnd \<ge> 0` by fastforce
  qed
  ultimately show ?thesis unfolding id by auto
qed

definition branch_and_bound :: "constraint list \<Rightarrow> var list \<Rightarrow> rat valuation option"
where "branch_and_bound cs Is = (
  let Bnd = compute_bound cs in
  branch_and_bound_core cs Is (\<lambda> _. -Bnd) (\<lambda> _. Bnd))"

lemma branch_and_bound_sat:
  "branch_and_bound cs Is = Some v \<Longrightarrow> v \<Turnstile>\<^sub>m\<^sub>c\<^sub>s (set cs, set Is)"
  unfolding branch_and_bound_def using branch_and_bound_core_sat by metis

lemma branch_and_bound_unsat:
  assumes "branch_and_bound cs Is = None"
  shows "\<not> v \<Turnstile>\<^sub>m\<^sub>c\<^sub>s (set cs, set Is)"
proof
  define Bnd where "Bnd = compute_bound cs"
  assume "v \<Turnstile>\<^sub>m\<^sub>c\<^sub>s (set cs, set Is)"
  then obtain v where v: "v \<Turnstile>\<^sub>m\<^sub>c\<^sub>s (set cs, set Is)"
                 and vBnd: "(\<forall> i \<in> set Is. \<bar>v i\<bar> \<le> of_int Bnd)"
    using compute_bound unfolding Bnd_def by blast

  from assms have "branch_and_bound_core cs Is (\<lambda> _. -Bnd) (\<lambda> _. Bnd) = None"
    unfolding branch_and_bound_def Bnd_def by meson
  moreover from vBnd have "(\<forall> i \<in> set Is. of_int (-Bnd) \<le> v i \<and> v i \<le> of_int Bnd)"
    by fastforce
  ultimately show False
    using branch_and_bound_core_unsat v by presburger
qed

hide_const (open) Var
hide_const (open) max_var
hide_const (open) vars_list

end


header {*  Well founded and transitive relations  *}

theory WellFoundedTransitive
imports Main
begin

class transitive = ord +
  assumes order_trans1: "x < y \<Longrightarrow> y < z \<Longrightarrow> x < z"
  and less_eq_def: "x \<le> y <-> x = y \<or> x < y"
begin

lemma eq_less_eq [simp]:
  "x = y \<Longrightarrow> x \<le> y"
  by (simp add: less_eq_def)

lemma order_trans2 [simp]:
  "x \<le> y \<Longrightarrow> y < z \<Longrightarrow> x < z"
  apply (simp add: less_eq_def)
  apply auto
  apply (erule less_eq_def order_trans1)
  by assumption

lemma order_trans3:
  "x < y \<Longrightarrow> y \<le> z \<Longrightarrow> x < z"
  apply (simp add: less_eq_def)
  apply auto
  apply (erule less_eq_def order_trans1)
  by assumption
end

class well_founded = ord +
  assumes less_induct1 [case_names less]: "(!!x . (!!y . y < x \<Longrightarrow> P y) \<Longrightarrow> P x) \<Longrightarrow> P a"

class well_founded_transitive = transitive + well_founded

instantiation prod:: (ord, ord) ord
begin

definition
  less_pair_def: "a < b <->  fst a  < fst b \<or> (fst a = fst b \<and> snd a < snd b)"

definition
  less_eq_pair_def: "(a::('a::ord * 'b::ord)) <= b <-> a = b \<or> a < b"
instance proof qed
end

instantiation prod:: (transitive, transitive) transitive
begin
instance proof
  fix x y z :: "('a::transitive * 'b::transitive)"
  assume "x < y" and "y < z" then  show  "x < z"
    apply (simp add: less_pair_def)
    apply auto
    apply (drule  order_trans1)
    apply auto
    apply (drule  order_trans1)
    apply auto
    apply (drule  order_trans1)
    apply auto
    done
next
  fix x y :: "'a * 'b"
  show  "x \<le> y <-> x = y \<or> x < y"
    by (simp add: less_eq_pair_def)
qed
end

instantiation prod:: (well_founded, well_founded) well_founded
begin
instance proof
  fix P::"('a * 'b) \<Rightarrow> bool"
  have a:  "!P . (!x::'a . (!y . y < x \<longrightarrow> P y) \<longrightarrow> P x) \<longrightarrow> (!a . P a)"
    apply safe
    apply (rule less_induct1)
    by blast
  have b:  "!P . (!x::'b . (!y . y < x \<longrightarrow> P y) \<longrightarrow> P x) \<longrightarrow> (!a . P a)"
    apply safe
    apply (rule less_induct1)
    by blast
  from a and b have c: "(!x . (!y . y < x \<longrightarrow> P y) \<longrightarrow> P x) \<longrightarrow> (!a . P a)"
    apply (unfold less_pair_def)
    apply (rule impI)
    apply (simp (no_asm_use) only: split_paired_All)
    apply (unfold fst_conv snd_conv)
    apply (drule spec)
    apply (erule mp)
    apply (rule allI)
    apply (rule impI)
    apply (drule spec)
    apply (erule mp)
    by blast
  assume A: "(!! x. (!! y. y < x \<Longrightarrow> P y) \<Longrightarrow> P x)"
  fix a
  from c A show "P a" by blast
qed
end

instantiation prod:: (well_founded_transitive, well_founded_transitive) well_founded_transitive
begin
instance proof qed
end

instantiation "nat" :: transitive
begin

instance proof
  fix x y z::nat
  assume "x < y" and "y < z" then show "x < z" by simp
  next
  fix x y::nat show "(x \<le> y) <-> (x = y \<or> x < y)"
    apply (unfold le_less)
    by safe
  qed
end

instantiation "nat":: well_founded
begin
instance proof
  fix P::"nat \<Rightarrow> bool"
  fix a
  assume A: "(!!x . (!!y . y < x \<Longrightarrow> P y) \<Longrightarrow> P x)"
  show "P a"
  by (rule less_induct, rule A, simp)
  qed
end

instantiation "nat":: well_founded_transitive
begin
instance proof qed
end

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_weird_nat_mul2_assoc
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun add3acc :: "Nat => Nat => Nat => Nat" where
"add3acc (Z) (Z) z = z"
| "add3acc (Z) (S x3) z = add3acc Z x3 (S z)"
| "add3acc (S x2) y z = add3acc x2 (S y) z"

fun mul2 :: "Nat => Nat => Nat" where
"mul2 (Z) y = Z"
| "mul2 (S z) (Z) = Z"
| "mul2 (S z) (S x2) = plus (S Z) (add3acc z x2 (mul2 z x2))"

theorem property0 :
  "((mul2 x (mul2 y z)) = (mul2 (mul2 x y) z))"
  oops

end


theory Chapter36_3_Evaluation
imports Chapter36_2_Typechecking
begin

primrec is_val :: "expr => bool"
    and is_val_cmd :: "cmnd => bool"
where "is_val (Var v) = False"
    | "is_val Zero = True"
    | "is_val (Suc e) = is_val e"
    | "is_val (IsZ et e0 es) = False"
    | "is_val (Lam t e) = True"
    | "is_val (Appl e1 e2) = False"
    | "is_val Triv = True"
    | "is_val (Pair e1 e2) = (is_val e1 & is_val e2)"
    | "is_val (ProjL e) = False"
    | "is_val (ProjR e) = False"
    | "is_val (Abort t e) = False"
    | "is_val (Case et el er) = False"
    | "is_val (InL t1 t2 e) = is_val e"
    | "is_val (InR t1 t2 e) = is_val e"
    | "is_val (Fix t e) = False"
    | "is_val (Cmd c) = True"
    | "is_val_cmd (Return e) = is_val e"
    | "is_val_cmd (Bind e c) = False"
    | "is_val_cmd (Declare e c) = False"
    | "is_val_cmd (Get v) = False"
    | "is_val_cmd (Set v e) = False"

lemma mobile_indep_sig: "typecheck gam sig e t ==> gam = empty_env ==> is_mobile t ==> is_val e ==>
      typecheck gam' sig' e t"
  and mobile_indep_sig_cmd: "typecheck_cmd gam sig c t ==> gam = empty_env ==> is_mobile t ==> is_val_cmd c ==>
      typecheck_cmd gam' sig' c t"
by (induction rule: typecheck_typecheck_cmd.inducts, simp_all)

definition conforms_to :: "expr env => type env => bool"
where "conforms_to = conform_envs (%e t. is_val e & is_mobile t & typecheck empty_env empty_env e t)"

inductive eval :: "expr => expr => bool"
      and eval_cmd :: "cmnd => expr env => cmnd => expr env => bool"
where eval_suc [simp]: "eval e e' ==> eval (Suc e) (Suc e')"
    | eval_isz_1 [simp]: "eval et et' ==> eval (IsZ et e0 es) (IsZ et' e0 es)"
    | eval_isz_2 [simp]: "eval (IsZ Zero e0 es) e0"
    | eval_isz_3 [simp]: "is_val et ==> eval (IsZ (Suc et) e0 es) (subst et es)"
    | eval_appl_1 [simp]: "eval e1 e1' ==> eval (Appl e1 e2) (Appl e1' e2)"
    | eval_appl_2 [simp]: "is_val e1 ==> eval e2 e2' ==> eval (Appl e1 e2) (Appl e1 e2')"
    | eval_appl_3 [simp]: "is_val e2 ==> eval (Appl (Lam t2 e1) e2) (subst e2 e1)"
    | eval_pair_1 [simp]: "eval e1 e1' ==> eval (Pair e1 e2) (Pair e1' e2)"
    | eval_pair_2 [simp]: "is_val e1 ==> eval e2 e2' ==> eval (Pair e1 e2) (Pair e1 e2')"
    | eval_projl_1 [simp]: "eval e e' ==> eval (ProjL e) (ProjL e')"
    | eval_projl_2 [simp]: "eval (ProjL (Pair e1 e2)) e1"
    | eval_projr_1 [simp]: "eval e e' ==> eval (ProjR e) (ProjR e')"
    | eval_projr_2 [simp]: "eval (ProjR (Pair e1 e2)) e2"
    | eval_abort [simp]: "eval e e' ==> eval (Abort t e) (Abort t e')"
    | eval_case_1 [simp]: "eval et et' ==> eval (Case et el er) (Case et' el er)"
    | eval_case_2 [simp]: "is_val e ==> eval (Case (InL t1 t2 e) el er) (subst e el)"
    | eval_case_3 [simp]: "is_val e ==> eval (Case (InR t1 t2 e) el er) (subst e er)"
    | eval_inl [simp]: "eval e e' ==> eval (InL t1 t2 e) (InL t1 t2 e')"
    | eval_inr [simp]: "eval e e' ==> eval (InR t1 t2 e) (InR t1 t2 e')"
    | eval_fix [simp]: "eval (Fix t e) (subst (Fix t e) e)"
    | eval_ret [simp]: "eval e e' ==> eval_cmd (Return e) s (Return e') s"
    | eval_bind_1 [simp]: "eval e e' ==> eval_cmd (Bind e c) s (Bind e' c) s"
    | eval_bind_2 [simp]: "eval_cmd c s c' s' ==> eval_cmd (Bind (Cmd c) c2) s (Bind (Cmd c') c2) s'"
    | eval_bind_3 [simp]: "is_val e ==> eval_cmd (Bind (Cmd (Return e)) c) s (subst_cmd e c) s"
    | eval_decl_1 [simp]: "eval e e' ==> eval_cmd (Declare e c) s (Declare e' c) s"
    | eval_decl_2 [simp]: "is_val e ==> eval_cmd c (extend s e) c' s' ==>
                eval_cmd (Declare e c) s (Declare e c') s'"
    | eval_decl_3 [simp]: "is_val e ==> is_val e2 ==>
                eval_cmd (Delcare e (Return e2)) s (Return e2) s'"
    | eval_get [simp]: "lookup s v = Some e ==> eval_cmd (Get v) s (Return e) s"
    | eval_set_1 [simp]: "eval e e' ==> eval_cmd (Set v e) s (Set v e') s"
    | eval_set_2 [simp]: "is_val e ==> eval_cmd (Set v e) s (Return e) (update s v e)"

lemma canonical_nat: "is_val e ==> typecheck gam sig e Nat ==>
          e = Zero | (EX e'. e = Suc e' & typecheck gam sig e' Nat)"
by (induction e, auto)

lemma canonical_nat_no_vars: "is_val e ==> typecheck gam sig e Nat ==> typecheck gam' sig e Nat"
by (induction e, auto)

lemma canonical_arrow: "is_val e ==> typecheck gam sig e (Arrow t1 t2) ==>
              EX e'. e = Lam t1 e' & typecheck (extend gam t1) sig e' t2"
by (induction e, auto)

lemma canonical_unit: "is_val e ==> typecheck gam sig e Unit ==> e = Triv"
by (induction e, auto)

lemma canonical_prod: "is_val e ==> typecheck gam sig e (Prod t1 t2) ==>
              EX e1 e2. e = Pair e1 e2 & typecheck gam sig e1 t1 & typecheck gam sig e2 t2"
by (induction e, auto)

lemma canonical_void: "is_val e ==> typecheck gam sig e Void ==> False"
by (induction e, auto)

lemma canonical_sum: "is_val e ==> typecheck gam sig e (Sum t1 t2) ==>
          (EX e'. e = InL t1 t2 e' & typecheck gam sig e' t1) |
          (EX e'. e = InR t1 t2 e' & typecheck gam sig e' t2)"
by (induction e, auto)

lemma canonical_command: "is_val e ==> typecheck gam sig e (Command t) ==>
          EX c. e = Cmd c & typecheck_cmd gam sig c t"
by (induction e, auto)

theorem preservation: "eval e e' ==> typecheck gam sig e t ==> typecheck gam sig e' t"
    and preservation_cmd: "eval_cmd c s c' s' ==> conforms_to s sig ==> typecheck_cmd gam sig c t ==>
              typecheck_cmd gam sig c' t & conforms_to s' sig"
proof (induction arbitrary: t and t rule: eval_eval_cmd.inducts)
case eval_suc
  thus ?case by fastforce
next case eval_isz_1
  thus ?case by fastforce
next case eval_isz_2
  thus ?case by fastforce
next case eval_isz_3
  thus ?case by fastforce
next case eval_appl_1
  thus ?case by fastforce
next case eval_appl_2
  thus ?case by fastforce
next case eval_appl_3
  thus ?case by fastforce
next case eval_pair_1
  thus ?case by fastforce
next case eval_pair_2
  thus ?case by fastforce
next case eval_projl_1
  thus ?case by fastforce
next case eval_projl_2
  thus ?case by fastforce
next case eval_projr_1
  thus ?case by fastforce
next case eval_projr_2
  thus ?case by fastforce
next case eval_abort
  thus ?case by fastforce
next case eval_case_1
  thus ?case by fastforce
next case eval_case_2
  thus ?case by fastforce
next case eval_case_3
  thus ?case by fastforce
next case eval_inl
  thus ?case by fastforce
next case eval_inr
  thus ?case by fastforce
next case eval_fix
  thus ?case by fastforce
next case eval_ret
  thus ?case by fastforce
next case eval_bind_1
  thus ?case by fastforce
next case (eval_bind_2 c s c' s' c2)
  then obtain tt where "typecheck_cmd gam sig c tt & typecheck_cmd (extend gam tt) sig c2 t"
  by force
  with eval_bind_2 show ?case by (metis tc_bind tc_cmd)
next case eval_bind_3
  thus ?case by fastforce
next case eval_decl_1
  thus ?case by fastforce
next case (eval_decl_2 e c s c' s')
  then obtain tt where "is_mobile tt & typecheck gam sig e tt &
          typecheck_cmd gam (extend sig tt) c t" by fast

  have "typecheck_cmd gam sig (Declare e c') t & conforms_to s' sig" by simp sorry
  thus ?case by simp
next case eval_decl_3
  thus ?case by simp sorry
next case (eval_get s v e)
  from eval_get have X: "lookup s v = Some e" by simp
  from eval_get have Y: "lookup sig v = Some t" by fast
  from eval_get have "conform_envs (%e t. is_val e & is_mobile t & typecheck empty_env empty_env e t) s sig" by (simp add: conforms_to_def)

  with X Y have "is_val e & is_mobile t & typecheck empty_env empty_env e t" by simp sorry
  with mobile_indep_sig have "is_mobile t & typecheck gam sig e t" by fast
  with eval_get show ?case by simp
next case eval_set_1
  thus ?case by fastforce
next case eval_set_2
  thus ?case by simp sorry
qed

theorem progress: "typecheck gam sig e t ==> gam = empty_env ==> is_val e | (EX e'. eval e e')"
    and progress_cmd: "typecheck_cmd gam sig c t ==> gam = empty_env ==> conforms_to s sig ==>
              is_val_cmd c | (EX c' s'. eval_cmd c s c' s')"
proof (induction rule: typecheck_typecheck_cmd.inducts)
case tc_var
  thus ?case by simp
next case tc_zero
  thus ?case by simp
next case tc_suc
  thus ?case by (metis eval_suc is_val_is_val_cmd.simps(3))
next case tc_isz
  thus ?case by (metis eval_isz_1 eval_isz_2 eval_isz_3 is_val_is_val_cmd.simps(3) canonical_nat)
next case tc_lam
  thus ?case by simp
next case tc_appl
  thus ?case by (metis eval_appl_1 eval_appl_2 eval_appl_3 canonical_arrow)
next case tc_triv
  thus ?case by simp
next case tc_pair
  thus ?case by (metis eval_pair_1 eval_pair_2 is_val_is_val_cmd.simps(8))
next case tc_projl
  thus ?case by (metis eval_projl_1 eval_projl_2 canonical_prod)
next case tc_projr
  thus ?case by (metis eval_projr_1 eval_projr_2 canonical_prod)
next case tc_abort
  thus ?case by (metis eval_abort canonical_void)
next case tc_case
  thus ?case
  by (metis eval_case_1 eval_case_2 eval_case_3 is_val_is_val_cmd.simps(13)
            is_val_is_val_cmd.simps(14) canonical_sum)
next case tc_inl
  thus ?case by (metis eval_inl is_val_is_val_cmd.simps(13))
next case tc_inr
  thus ?case by (metis eval_inr is_val_is_val_cmd.simps(14))
next case tc_fix
  thus ?case by (metis eval_fix)
next case tc_cmd
  thus ?case by simp
next case tc_retn
  thus ?case by (metis eval_ret is_val_is_val_cmd.simps(17))
next case (tc_bind gam sig e c)
  thus ?case by simp sorry
next case tc_decl
  thus ?case by simp sorry
next case (tc_get v sig gam)
  thus ?case by simp sorry
next case tc_set
  thus ?case by simp sorry
qed

end