(*<*)
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_mul3_rot
  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 add3 :: "Nat => Nat => Nat => Nat" where
  "add3 (Z) (Z) z = z"
| "add3 (Z) (S x3) z = plus (S Z) (add3 Z x3 z)"
| "add3 (S x2) y z = plus (S Z) (add3 x2 y z)"

fun mul3 :: "Nat => Nat => Nat => Nat" where
  "mul3 (Z) y z = Z"
| "mul3 (S x2) (Z) z = Z"
| "mul3 (S x2) (S x3) (Z) = Z"
| "mul3 (S x2) (S x3) (S x4) =
     (let fail :: Nat =
       plus
         (S Z)
         (add3
            (mul3 x2 x3 x4)
            (add3 (mul3 (S Z) x3 x4) (mul3 x2 (S Z) x4) (mul3 x2 x3 (S Z)))
            (add3 x2 x3 x4))
     in (if (x2 = Z) then
           (if (x3 = Z) then (if (x4 = Z) then S Z else fail) else fail)
           else
           fail))"

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

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