theory PromiseCombinators imports Main Interleave SelfInv begin

datatype expr =
  Num nat |
  Tuple expr expr |
  Pending expr expr |
  PendingForever |
  Resolve expr |
  Reject expr |
  All2 expr |
  Race2 expr

datatype event =
  EventResolve expr |
  EventReject expr

text "Unfailable world"
inductive
  UF_small_step :: "expr \<times> event list \<Rightarrow> expr \<times> event list \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
where
  UF_NumNumI[intro]:                "(Num n, ev) \<Rightarrow> (Num n, ev)" |
  UF_PendingResolveI[intro]:        "(Pending a b, ev) \<Rightarrow> (Resolve a, ev@[EventResolve a])" |
  UF_PendingPendingForeverI[intro]: "(Pending a b, ev) \<Rightarrow> (PendingForever, ev)" |
  UF_PendingForeverPendingForeverI[intro]: "(PendingForever, ev) \<Rightarrow> (PendingForever, ev)" |
  UF_All2ResolveI[intro]:           "\<lbrakk> (All2 (Tuple a b), ev) \<Rightarrow> (All2 (Tuple (Resolve a') (Resolve b')), ev') \<rbrakk> \<Longrightarrow> (All2 (Tuple a b), ev) \<Rightarrow> (Resolve (Tuple a' b'), ev')" |
  UF_Race2ResolveI1[intro]:         "\<lbrakk> (Race2 (Tuple a b), ev) \<Rightarrow> (Race2 (Tuple (Resolve a') b'), ev') \<rbrakk> \<Longrightarrow> (Race2 (Tuple a b), ev) \<Rightarrow> (Resolve a', ev')" |
  UF_Race2ResolveI2[intro]:         "\<lbrakk> (Race2 (Tuple a b), ev) \<Rightarrow> (Race2 (Tuple a' (Resolve b')), ev') \<rbrakk> \<Longrightarrow> (Race2 (Tuple a b), ev) \<Rightarrow> (Resolve b', ev')" |

  UF_TupleTupleI[intro]:            "\<lbrakk> (a, ev) \<Rightarrow> (a', evA'); (b, ev) \<Rightarrow> (b', evB'); interleave evA' evB' ev' \<rbrakk> \<Longrightarrow> (Tuple a b, ev) \<Rightarrow> (Tuple a' b', ev')" |
  UF_PendingPendingI[intro]:        "\<lbrakk> (a, ev) \<Rightarrow> (a', evA'); (b, ev) \<Rightarrow> (b', evB'); interleave evA' evB' ev' \<rbrakk> \<Longrightarrow> (Pending a b, ev) \<Rightarrow> (Pending a' b', ev')" |
  UF_ResolveResolveI[intro]:        "\<lbrakk> (x, ev) \<Rightarrow> (x', ev') \<rbrakk> \<Longrightarrow> (Resolve x, ev) \<Rightarrow> (Resolve x', ev')" |
  UF_All2All2I[intro]:              "\<lbrakk> (Tuple a b, ev) \<Rightarrow> (Tuple a' b', ev') \<rbrakk> \<Longrightarrow> (All2 (Tuple a b), ev) \<Rightarrow> (All2 (Tuple a' b'), ev')" |
  UF_Race2Race2I[intro]:            "\<lbrakk> (Tuple a b, ev) \<Rightarrow> (Tuple a' b', ev') \<rbrakk> \<Longrightarrow> (Race2 (Tuple a b), ev) \<Rightarrow> (Race2 (Tuple a' b'), ev')"

inductive_cases UF_All2_ResolveE: "(All2 (Tuple a b), ev) \<Rightarrow> (Resolve (Tuple a' b'), ev')"
inductive_cases UF_All2_All2E: "(All2 (Tuple a b), ev) \<Rightarrow> (All2 (Tuple a' b'), ev')"
inductive_cases UF_Tuple_TupleE: "(Tuple a b, ev) \<Rightarrow> (Tuple a' b', ev')"
inductive_cases UF_Pending_ResolveE: "(Pending a b, ev) \<Rightarrow> (Resolve a', ev')"
inductive_cases UF_Race2_ResolveE: "(Race2 (Tuple a b), ev) \<Rightarrow> (Resolve a', ev')"
inductive_cases UF_Race2_Race2E: "(Race2 (Tuple a b), ev) \<Rightarrow> (Race2 (Tuple a' b'), ev')"
inductive_cases UF_PendingForever_FreeE: "(PendingForever, ev) \<Rightarrow> (x', ev')"

lemma "(Tuple (Num 0) (Num 1), []) \<Rightarrow> (Tuple (Num 0) (Num 1), [])"
  apply(subst (2) append.right_neutral[symmetric])
  apply(rule UF_TupleTupleI)
  apply(rule UF_NumNumI)
  apply(rule UF_NumNumI)
  apply(force)
  done

lemma "(Pending (Num 0) (Num 1), []) \<Rightarrow> (Resolve (Num 0), [EventResolve (Num 0)])"
  apply(subst (2) append.left_neutral[symmetric])
  apply(rule UF_PendingResolveI)
  done

lemma "(Race2 (Tuple (Pending (Num 0) (Num 1)) (Pending (Num 2) (Num 3))), []) \<Rightarrow> (Resolve (Num 0), [EventResolve (Num 0)])"
  apply(rule UF_Race2ResolveI1)
  apply(rule UF_Race2Race2I)
  apply(subst (2) append.right_neutral[symmetric])
  apply(rule UF_TupleTupleI)
  apply(rule UF_PendingResolveI)
  apply(rule UF_PendingPendingI)
  apply(rule UF_NumNumI)
  apply(rule UF_NumNumI)
  apply(rule interleave_Nil_NilI)
  apply(simp)
  apply(rule interleave_Cons_FreeI)
  apply(rule interleave_Nil_NilI)
  done

lemma "(Race2 (Tuple (Pending (Num 0) (Num 1)) (Pending (Num 2) (Num 3))), []) \<Rightarrow> (Resolve (Num 2), [EventResolve (Num 2)])"
  apply(rule UF_Race2ResolveI2)
  apply(rule UF_Race2Race2I)
  apply(subst (2) append.right_neutral[symmetric])
  apply(rule_tac ev="[]" in UF_TupleTupleI)
  apply(rule UF_PendingPendingI)
  apply(rule UF_NumNumI)
  apply(rule UF_NumNumI)
  apply(rule interleave_Nil_NilI)
  apply(rule UF_PendingResolveI)
  apply(simp)
  apply(rule interleave_Free_ConsI)
  apply(rule interleave_Nil_NilI)
  done

lemma "(All2 (Tuple (Pending (Num 0) (Num 1)) (Pending (Num 2) (Num 3))), []) \<Rightarrow> (Resolve (Tuple (Num 0) (Num 2)), [EventResolve (Num 0)]@[EventResolve (Num 2)])"
  apply(rule UF_All2ResolveI)
  apply(rule UF_All2All2I)
  apply(rule_tac ev="[]" in UF_TupleTupleI)
  apply(rule UF_PendingResolveI)
  apply(rule UF_PendingResolveI)
  apply(clarsimp)
  apply(auto)
  done

lemma "(All2 (Tuple (Pending (Num 0) (Num 1)) (Pending (Num 2) (Num 3))), []) \<Rightarrow> (Resolve (Tuple (Num 0) (Num 2)), [EventResolve (Num 2)]@[EventResolve (Num 0)])"
  apply(rule UF_All2ResolveI)
  apply(rule UF_All2All2I)
  apply(rule_tac ev="[]" in UF_TupleTupleI)
  apply(rule UF_PendingResolveI)
  apply(rule UF_PendingResolveI)
  apply(auto)
  done

fun
  flip :: "expr \<Rightarrow> expr"
where
  "flip (All2 a) = All2 (flip a)" |
  "flip (Race2 a) = Race2 (flip a)" |
  "flip (Tuple a b) = Tuple (flip b) (flip a)" |
  "flip (Pending a b) = Pending (flip a) (flip b)" |
  "flip (Resolve a) = Resolve (flip a)" |
  "flip (Reject a) = Reject (flip a)" |
  "flip (Num n) = Num n" |
  "flip PendingForever = PendingForever"

theorem flip_self_inv: "self_inv flip"
  apply(unfold self_inv_def)
  apply(clarify)
  apply(rule expr.induct)
  apply(auto)
  done

lemma flip_flip_ident: "flip (flip x) = x"
  apply(rule self_inv_self_inv_iff)
  apply(rule flip_self_inv)
  done

fun
  flip_ev1 :: "event \<Rightarrow> event"
where
  "flip_ev1 (EventResolve a) = EventResolve (flip a)" |
  "flip_ev1 (EventReject b) = EventReject (flip b)"

theorem flip_ev1_self_inv: "self_inv flip_ev1"
  apply(unfold self_inv_def)
  apply(clarify)
  apply(case_tac "x")
  apply(auto simp: self_inv_self_inv_iff flip_self_inv)
  done

definition
  flip_ev :: "event list \<Rightarrow> event list"
where
  "flip_ev \<equiv> map flip_ev1"

theorem flip_ev_self_inv: "self_inv flip_ev"
  apply(unfold flip_ev_def)
  apply(rule map_self_inv)
  apply(rule flip_ev1_self_inv)
  done

lemma flip_ev_Nil: "flip_ev [] = []"
  apply(unfold flip_ev_def)
  apply(auto)
  done

lemma flip_ev_flip_ev_ident: "flip_ev (flip_ev x) = x"
  apply(rule self_inv_self_inv_iff)
  apply(rule flip_ev_self_inv)
  done

lemma UF_flipI[rule_format]: "x \<Rightarrow> x' \<longrightarrow> (\<forall>e ev e' ev'. x = (e, ev) \<and> x' = (e', ev') \<longrightarrow> (flip e, flip_ev ev) \<Rightarrow> (flip e', flip_ev ev'))"
  apply(rule impI)
  apply(erule UF_small_step.induct)
  apply(auto simp: flip_ev_def)
  apply(rule UF_TupleTupleI)
  apply(auto intro: interleave_mapI)
  apply(rule UF_PendingPendingI)
  apply(auto intro: interleave_mapI simp add: interleave_flip)
  done

lemma UF_flipD[rule_format]: "(flip x, flip_ev ev) \<Rightarrow> (flip x', flip_ev ev') \<longrightarrow> (x, ev) \<Rightarrow> (x', ev')"
  apply(subgoal_tac "\<exists>y y' eev eev'. flip x = y \<and> flip x' = y' \<and> flip_ev ev = eev \<and> flip_ev ev' = eev' \<and> x = flip y \<and> x' = flip y' \<and> ev = flip_ev eev \<and> ev' = flip_ev eev'")
  apply(elim exE conjE)
  apply(erule ssubst)+
  apply(rule impI)
  apply(erule UF_flipI)
  apply(auto simp add: flip_self_inv flip_ev_self_inv self_inv_self_inv_iff)
  done

theorem UF_flip: "(flip x, flip_ev ev) \<Rightarrow> (flip x', flip_ev ev') \<longleftrightarrow> (x, ev) \<Rightarrow> (x', ev')"
  apply(rule iffI)
  apply(erule UF_flipD)
  apply(erule UF_flipI)
  apply(simp)
  done

theorem UF_arbitrariness: "\<exists>x0 x1 ev1 x2 ev2. (x0, []) \<Rightarrow> (x1, ev1) \<and> (x0, []) \<Rightarrow> (x2, ev2) \<and> x1 \<noteq> x2"
  apply(rule_tac x="Race2 (Tuple (Resolve (Num 1)) (Resolve (Num 2)))" in exI)
  apply(rule_tac x="Resolve (Num 1)" in exI)
  apply(rule_tac x="[]" in exI)
  apply(rule_tac x="Resolve (Num 2)" in exI)
  apply(rule_tac x="[]" in exI)
  apply(intro conjI)
  apply(subst (2) append.left_neutral[symmetric])
  apply(rule UF_Race2ResolveI1)
  apply(force)
  apply(subst (2) append.left_neutral[symmetric])
  apply(rule)+
  apply(auto)
  done

definition
  Tuple3 :: "expr \<Rightarrow> expr \<Rightarrow> expr \<Rightarrow> expr"
where
  "Tuple3 a b c \<equiv> Tuple a (Tuple b c)"

definition
  All3 :: "expr \<Rightarrow> expr \<Rightarrow> expr \<Rightarrow> expr"
where
  "All3 a b c \<equiv> All2 (Tuple a (All2 (Tuple b c)))"

theorem "\<exists>ev. (All3 (Pending (Num 3) (Num 0)) (Pending (Num 2) (Num 0)) (Pending (Num 1) (Num 0)), []) \<Rightarrow> (Resolve (Tuple3 (Num 3) (Num 2) (Num 1)), ev)"
  apply(rule_tac x="[EventResolve (Num 3)]@[EventResolve (Num 2)]@[EventResolve (Num 1)]" in exI)
  apply(unfold All3_def Tuple3_def)
  apply(subst append_assoc[symmetric])+
  apply(rule)+
  apply(force)
  apply(simp)
  apply(rule)+
  done

definition
  events :: "expr \<Rightarrow> expr \<Rightarrow> event list set"
where
  "events x x' \<equiv> { ev | ev. (x, []) \<Rightarrow> (x', ev) }"

lemma flip_Nil_flip_Free: "(flip x, []) \<Rightarrow> (flip x', ev) \<longleftrightarrow> (x, []) \<Rightarrow> (x', flip_ev ev)"
  apply(subgoal_tac "\<exists>ev'. ev = flip_ev ev' \<and> ev' = flip_ev ev \<and> [] = flip_ev []")
  apply(elim exE conjE)
  apply(erule ssubst)+
  apply(subst UF_flip)
  apply(subst flip_ev_flip_ev_ident)
  apply(subst flip_ev_Nil)
  apply(rule refl)
  apply(rule_tac x="flip_ev ev" in exI)
  apply(force simp add: flip_ev_flip_ev_ident flip_ev_Nil)
  done

lemma events_flip_flip1[rule_format]: "\<lbrakk> fev = flip_ev ` events (flip x) (flip x') \<rbrakk> \<Longrightarrow> fev \<subseteq> events x x'"
  apply(erule ssubst)
  apply(unfold events_def)
  apply(subst flip_Nil_flip_Free)
  apply(auto simp add: image_def)
  done

lemma events_flip_flip2[rule_format]: "\<lbrakk> fev = flip_ev ` events (flip x) (flip x') \<rbrakk> \<Longrightarrow> events x x' \<subseteq> fev"
  apply(subgoal_tac "\<exists>y y'. x = flip y \<and> x' = flip y'")
  apply(elim exE conjE)
  apply(erule ssubst)+
  apply(simp only: flip_flip_ident)
  apply(rule_tac x="flip_ev ` events (flip y) (flip y')" in self_inv_image_subsetI)
  apply(rule flip_ev_self_inv)
  apply(rule events_flip_flip1)
  apply(rule refl)
  apply(force simp add: flip_ev_flip_ev_ident)
  apply(rule_tac x="flip x" in exI)
  apply(rule_tac x="flip x'" in exI)
  apply(force simp add: flip_flip_ident)
  done

lemma events_flip_flip: "flip_ev ` events (flip x) (flip x') = events x x'"
  apply(rule equalityI)
  apply(rule events_flip_flip1)
  apply(rule refl)
  apply(rule events_flip_flip2)
  apply(rule refl)
  done

fun
  to_appended_all :: "'a list \<Rightarrow> 'a list"
where
  "to_appended_all [] = []" |
  "to_appended_all [x] = [x]" |
  "to_appended_all (x1#x2#xs) = ([x1]@[x2])@(to_appended_all xs)"

definition
  appended_all :: "'a list \<Rightarrow> 'a list"
where
  "appended_all \<equiv> to_appended_all"

lemma appended_all_map: "appended_all (map f x) = map f (appended_all x)"
  apply(rule_tac P="\<lambda>x. appended_all (map f x) = map f (appended_all x)" in to_appended_all.induct)
  apply(unfold appended_all_def flip_ev_def)
  apply(auto)
  done

theorem All2_events: "
  events
    (All2 (Tuple (Pending (Num 1) (Num 0)) (Pending (Num 2) (Num 0))))
    (Resolve (Tuple (Num 1) (Num 2)))
  = {
    appended_all [EventResolve (Num 1), EventResolve (Num 2)],
    appended_all [EventResolve (Num 2), EventResolve (Num 1)]
  }"
  apply(unfold events_def)
  apply(intro equalityI subsetI)
  apply(clarsimp)
  apply(elim UF_All2_ResolveE UF_All2_All2E UF_Tuple_TupleE UF_Pending_ResolveE)
  apply(auto simp add: interleave_single_single)
  apply(unfold appended_all_def to_appended_all.simps)
  apply(force)
  apply(force)
  apply(rule)+
  apply(simp add: interleave_single_single)
  apply(rule)+
  apply(simp add: interleave_single_single)
  done

theorem Race2L_events: "
  events
    (Race2 (Tuple (Pending (Num 1) (Num 0)) PendingForever))
    (Resolve (Num 1))
  = { appended_all [EventResolve (Num 1)] }"
  apply(unfold events_def)
  apply(intro equalityI subsetI)
  apply(clarsimp)
  apply(elim UF_Race2_ResolveE UF_Race2_Race2E UF_Tuple_TupleE UF_PendingForever_FreeE)
  apply(clarsimp simp add: interleave_right_neutral)
  apply(elim UF_Pending_ResolveE)
  apply(force simp: appended_all_def)
  apply(force)
  apply(simp)
  apply(clarify)
  apply(unfold appended_all_def to_appended_all.simps append.right_neutral)
  apply(rule UF_Race2ResolveI1)
  apply(rule)+
  apply(simp add: interleave_right_neutral)
  done

theorem Race2R_events: "
  events
    (Race2 (Tuple PendingForever (Pending (Num 1) (Num 0))))
    (Resolve (Num 1))
  = { appended_all [EventResolve (Num 1)] }"
  apply(subst events_flip_flip[symmetric])
  apply(subst self_inv_flip [where f="image flip_ev"])
  apply(rule image_self_inv)
  apply(rule flip_ev_self_inv)
  apply(simp del: One_nat_def add: flip_ev_def appended_all_map[symmetric])
  apply(rule Race2L_events)
  done

theorem "(
  (Race2 (Tuple
    (All2 (Tuple (Pending (Num 1) (Num 0)) (Pending (Num 1) (Num 0))))
    (All2 (Tuple (Pending (Num 1) (Num 0)) (Pending (Num 2) (Num 0))))
  )), []) \<Rightarrow>
  (Resolve (Tuple (Num 1) (Num 1)), [EventResolve (Num 1)]@[EventResolve (Num 1)])
"
  apply(rule UF_Race2ResolveI1)
  apply(rule)+
  apply(simp add: interleave_single_single)
  apply(rule)+
  apply(simp add: interleave_right_neutral)
  done

theorem "(
  (Race2 (Tuple
    (All2 (Tuple (Pending (Num 1) (Num 0)) (Pending (Num 1) (Num 0))))
    (All2 (Tuple (Pending (Num 1) (Num 0)) (Pending (Num 2) (Num 0))))
  )), []) \<Rightarrow>
  (Resolve (Tuple (Num 1) (Num 2)), [EventResolve (Num 2)]@[EventResolve (Num 1)])
"
  apply(rule UF_Race2ResolveI2)
  apply(rule)+
  apply(simp add: interleave_left_neutral)
  apply(rule)+
  apply(auto)
  done

theorem "(
  (Race2 (Tuple
    (All2 (Tuple (Pending (Num 1) (Num 0)) (Pending (Num 1) (Num 0))))
    (All2 (Tuple (Pending (Num 1) (Num 0)) (Pending (Num 2) (Num 0))))
  )), []) \<Rightarrow>
  (Resolve (Tuple (Num 1) (Num 2)), [EventResolve (Num 1)]@[EventResolve (Num 2)])
"
  apply(rule UF_Race2ResolveI2)
  apply(rule)+
  apply(simp add: interleave_left_neutral)
  apply(rule interleave_Cons_FreeI)
  apply(rule interleave_Free_ConsI)
  apply(rule interleave_Nil_NilI)
  apply(auto)
  done
end


(* This file generalizes the previous univariate formalization of BKR
and Renegar (see https://www.isa-afp.org/entries/BenOr_Kozen_Reif.html)
so as not to use the Cauchy root bound, which is specific to univariate
polynomials and does not generalize to our multivariate setting.
 *)

theory Renegar_Modified

imports "BenOr_Kozen_Reif.Renegar_Decision"

begin

definition poly_f_nocrb :: "real poly list \<Rightarrow> real poly"
  where
    "poly_f_nocrb ps =
  (if (check_all_const_deg ps = True) then  [:0, 1:] else
  (pderiv (prod_list_var ps)) * (prod_list_var ps))"

lemma root_set_nocrb:
  assumes is_not_const: "check_all_const_deg qs = False"
  shows "{x. poly (poly_f qs) x = 0}
 = {x. poly (poly_f_nocrb qs) x = 0} \<union> {-(crb (prod_list_var qs)), (crb (prod_list_var qs))}"
proof -
  have "\<forall>x \<in> {x. poly (poly_f qs) x = 0}. poly (poly_f qs) x = 0" by auto
  then have all: "\<forall>x \<in> {x. poly (poly_f qs) x = 0}. poly ((pderiv (prod_list_var qs)) * (prod_list_var qs)* ([:-(crb (prod_list_var qs)),1:]) * ([:(crb (prod_list_var qs)),1:])) x = 0"
    unfolding poly_f_def using is_not_const by presburger
  have all1: "\<forall>x \<in> {x. poly (poly_f qs) x = 0}.
    ((poly ((pderiv (prod_list_var qs)) * (prod_list_var qs)) x = 0)
    \<or> (poly (([:-(crb (prod_list_var qs)),1:]) * ([:(crb (prod_list_var qs)),1:])) x = 0))"
  proof clarsimp
    fix x
    assume inset: "poly (poly_f qs) (real_of_int x) = 0 "
    assume "poly (pderiv (prod_list_var qs)) (real_of_int x) \<noteq> 0"
    assume "x * x \<noteq> crb (prod_list_var qs) * crb (prod_list_var qs)"
    have "poly ((pderiv (prod_list_var qs)) * (prod_list_var qs)* ([:-(crb (prod_list_var qs)),1:]) * ([:(crb (prod_list_var qs)),1:])) x = 0"
      using all inset by auto
    then show "poly (prod_list_var qs) (real_of_int x) = 0" using assms
      by (smt (verit, del_insts) \<open>poly (pderiv (prod_list_var qs)) (real_of_int x) \<noteq> 0\<close> \<open>x * x \<noteq> crb (prod_list_var qs) * crb (prod_list_var qs)\<close> mult.commute mult_eq_0_iff mult_minus_left of_int_eq_iff of_int_minus poly_mult poly_root_factor(3))
  qed
  have "\<forall>x. (poly (([:-(crb (prod_list_var qs)),1:]) * ([:(crb (prod_list_var qs)),1:])) x = 0 \<longrightarrow>
  (x = -(crb (prod_list_var qs)) \<or> x = (crb (prod_list_var qs))))"
    by (simp add: square_eq_iff)
  then have "\<forall>x \<in> {x. poly (poly_f qs) x = 0}.
    ((poly (poly_f_nocrb qs) x = 0)
    \<or> (x = -(crb (prod_list_var qs)) \<or> x = (crb (prod_list_var qs))))"
    using all1 unfolding poly_f_nocrb_def
    by (smt (verit, del_insts) all is_not_const of_int_minus poly_root_factor(2))
  then have subset1: "{x. poly (poly_f qs) x = 0}
 \<subseteq> {x. poly (poly_f_nocrb qs) x = 0} \<union> {-(crb (prod_list_var qs)), (crb (prod_list_var qs))}"
    using UnCI is_not_const mem_Collect_eq by fastforce
  have subset2: "{x. poly (poly_f_nocrb qs) x = 0} \<union> {-(crb (prod_list_var qs)), (crb (prod_list_var qs))} \<subseteq>
   {x. poly (poly_f qs) x = 0}"
    using Un_insert_right insert_iff is_not_const mem_Collect_eq of_int_minus poly_f_def poly_f_nocrb_def by auto
  then show ?thesis using subset1 subset2 by auto
qed

lemma nonzcrb_helper:
  assumes q_in: "q \<in> set qs"
  assumes qnonz: "q \<noteq> 0"
  assumes lengt: "length (sorted_list_of_set {(x::real). (\<exists>q \<in> set(qs). (q \<noteq> 0 \<and> poly q x = 0))} :: real list) > 0"
  shows " \<not>(\<exists>x \<ge> (real_of_int (crb (prod_list_var qs))). poly q x = 0)"
proof clarsimp
  fix x
  assume xgt: "real_of_int (crb (prod_list_var qs)) \<le> x"
  assume pqz: "poly q x = 0"
  let ?zer_list = "sorted_list_of_set {(x::real). (\<exists>q \<in> set(qs). (q \<noteq> 0 \<and> poly q x = 0))} :: real list"
  have strict_sorted_h: "sorted_wrt (<) ?zer_list" using sorted_sorted_list_of_set
      strict_sorted_iff by auto
  have finset: "finite  {x. \<exists>q\<in>set qs. q \<noteq> 0 \<and> poly q x = 0}"
  proof -
    have "\<forall>q \<in> set qs.  q\<noteq> 0 \<longrightarrow> finite {x. poly q x = 0} "
      using poly_roots_finite by auto
    then show ?thesis by auto
  qed
  have all_prop: "\<forall>x \<in> {x. \<exists>q\<in>set qs. q \<noteq> 0 \<and> poly q x = 0}. poly (prod_list_var qs) x = 0"
    using q_dvd_prod_list_var_prop
    by fastforce
  then have "poly (prod_list_var qs) (sorted_list_of_set {x. \<exists>q\<in>set qs. q \<noteq> 0 \<and> poly q x = 0} ! 0) = 0"
    using finset set_sorted_list_of_set
    by (metis (no_types, lifting) lengt nth_mem)
  then have crbgt: "crb (prod_list_var qs) > ?zer_list ! (length ?zer_list - 1)" using prod_list_var_nonzero crb_lem_pos[of "prod_list_var qs" "?zer_list ! (length ?zer_list - 1)"]
    by (metis (no_types, lifting) all_prop diff_less finset lengt less_numeral_extra(1) nth_mem set_sorted_list_of_set)
  have x_in: "x \<in> {x. \<exists>q\<in>set qs. q \<noteq> 0 \<and> poly q x = 0}"
    using pqz q_in qnonz
    by auto
  then have "x \<in> set ?zer_list"
    by (smt (verit, best) finset in_set_member mem_Collect_eq set_sorted_list_of_set)
  then have "x \<le> ?zer_list ! (length ?zer_list - 1)" using strict_sorted_h
    by (meson all_prop x_in crb_lem_pos not_less prod_list_var_nonzero xgt)
  then show "False" using xgt crbgt
    by auto
qed

lemma root_set_nocrb_var:
  assumes is_not_const: "check_all_const_deg qs = False"
  shows "({x. poly (poly_f qs) x = 0}::real set)
 = {x. poly (poly_f_nocrb qs) x = 0} \<union> (({-(crb (prod_list_var qs)), (crb (prod_list_var qs))})::real set)"
  using root_set_nocrb apply (auto)
     apply (smt (verit) of_int_minus poly_f_def poly_f_nocrb_def poly_root_factor(2))
    apply (simp add: is_not_const poly_f_def)
  using is_not_const apply blast
  by (metis (no_types, lifting) poly_f_def poly_f_nocrb_def poly_root_factor(2))

lemma nonzcrb:
  assumes q_in: "q \<in> set qs"
  assumes qnonz: "q \<noteq> 0"
  shows " \<not>(\<exists>x \<ge> (real_of_int (crb (prod_list_var qs))). poly q x = 0)"
proof -
  let ?zer_list = "(sorted_list_of_set {(x::real). (\<exists>q \<in> set(qs). (q \<noteq> 0 \<and> poly q x = 0))} :: real list)"
  have eo: "length ?zer_list = 0 \<or> length ?zer_list > 0"
    by auto
  have h1: "length ?zer_list = 0 \<longrightarrow> \<not>(\<exists>x \<ge> (real_of_int (crb (prod_list_var qs))). poly q x = 0)"
    by (metis crb_lem_pos dvdE linorder_not_less mult_zero_left poly_mult prod_list_var_nonzero q_dvd_prod_list_var_prop q_in qnonz)
  have h2: "length ?zer_list > 0 \<longrightarrow> \<not>(\<exists>x \<ge> (real_of_int (crb (prod_list_var qs))). poly q x = 0)"
    using nonzcrb_helper assms
    by blast
  show ?thesis using eo h1 h2
    by auto
qed

definition sgn_pos_inf_rat_list:: "real poly list \<Rightarrow> int list"
  where "sgn_pos_inf_rat_list l = map (\<lambda>x.  (Sturm_Tarski.sign (sgn_pos_inf x))) l"

definition sgn_neg_inf_rat_list:: "real poly list \<Rightarrow> int list"
  where "sgn_neg_inf_rat_list l = map (\<lambda>x.  (Sturm_Tarski.sign (sgn_neg_inf x))) l"

definition sgn_neg_inf_rat_list2:: "real poly list \<Rightarrow> rat list"
  where "sgn_neg_inf_rat_list2 l = map (\<lambda>x.  ((rat_of_int \<circ> Sturm_Tarski.sign) (sgn_neg_inf x))) l"

definition sgn_pos_inf_rat_list2:: "real poly list \<Rightarrow> rat list"
  where "sgn_pos_inf_rat_list2 l = map (\<lambda>x.  ((rat_of_int \<circ> Sturm_Tarski.sign) (sgn_pos_inf x))) l"

lemma root_ub_restate:
  fixes p:: "real poly"
  assumes pnonz: "p \<noteq> 0"
  fixes z::"real"
  assumes zgt: "\<forall>x. poly p x=0 \<longrightarrow> x < z"
  shows "x\<ge>z \<Longrightarrow> sgn (poly p x) = Sturm_Tarski.sign (sgn_pos_inf p)"
proof -
  assume xgt: "x\<ge>z"
  have allx: "\<forall>x \<ge> z. sgn (poly p x) = sgn (poly p z)"
  proof clarsimp
    fix x
    assume zleq: "z \<le> x"
    then have xnonz: "sgn (poly p x) \<noteq> 0"
      using zgt unfolding sgn_def by auto
    have znonz: "sgn (poly p z) \<noteq> 0"
      using zgt unfolding sgn_def by auto
    have "Matrix_Equation_Construction.sgn (poly p x) \<noteq> Matrix_Equation_Construction.sgn (poly p z) \<Longrightarrow> False"
    proof -
      assume neq: "Matrix_Equation_Construction.sgn (poly p x) \<noteq> Matrix_Equation_Construction.sgn (poly p z)"
      then have z_lt: "z < x" using zleq
        using less_eq_real_def by force
      have h1: "z < x \<Longrightarrow>
        Matrix_Equation_Construction.sgn (poly p z) \<noteq> 0 \<Longrightarrow>
        Matrix_Equation_Construction.sgn (poly p x) \<noteq> 0 \<Longrightarrow>
        \<not> poly p x < 0 \<Longrightarrow> 0 < poly p x"
        using zgt by fastforce
      have h2: "z < x \<Longrightarrow>
        Matrix_Equation_Construction.sgn (poly p z) \<noteq> 0 \<Longrightarrow>
        Matrix_Equation_Construction.sgn (poly p x) \<noteq> 0 \<Longrightarrow>
        \<not> poly p x < 0 \<Longrightarrow> poly p z < 0"
        by (metis neq sgn_def)
      have h3: "z < x \<Longrightarrow>
        Matrix_Equation_Construction.sgn (poly p z) \<noteq> 0 \<Longrightarrow>
        Matrix_Equation_Construction.sgn (poly p x) \<noteq> 0 \<Longrightarrow>
        \<not> 0 < poly p z \<Longrightarrow> 0 < poly p x"
        by (metis neq sgn_def)
      have h4: "z < x \<Longrightarrow>
        Matrix_Equation_Construction.sgn (poly p z) \<noteq> 0 \<Longrightarrow>
        Matrix_Equation_Construction.sgn (poly p x) \<noteq> 0 \<Longrightarrow>
        \<not> 0 < poly p z \<Longrightarrow> poly p z < 0"
        using h2 h3 by linarith
       have "((poly p x) > 0 \<and> (poly p z) < 0) \<or> ((poly p x) < 0 \<and> (poly p z) > 0) "
         using z_lt znonz xnonz h1 h2 h3 h4
         by auto
      then have "\<exists>w. w > x \<and> w < z \<and> (poly p w = 0)"
        using poly_IVT_pos[of z x] poly_IVT_neg[of z x]
        by (metis \<open>z < x\<close> not_less_iff_gr_or_eq zgt)
      then show "False"
        using zgt
        using zleq by linarith
    qed
    then show "Matrix_Equation_Construction.sgn (poly p x) = Matrix_Equation_Construction.sgn (poly p z)"
      by auto
  qed
  have "(\<exists>ub.
          (\<forall>x\<ge>ub. sgn_class.sgn (poly p x) = sgn_pos_inf p))"
    using root_ub[of p] pnonz
    by meson
  then obtain ub where ub_prop: "(\<forall>x\<ge>ub. sgn_class.sgn (poly p x) = sgn_pos_inf p)"
    by auto
  let ?ub2 = "max ub (z+1)"
  have "(\<forall>x\<ge>?ub2. sgn_class.sgn (poly p x) = sgn_pos_inf p) \<and> (?ub2 > z)"
    using ub_prop by auto
  then have h1: "(Sturm_Tarski.sign(sgn_class.sgn (poly p ?ub2)::real)) = Sturm_Tarski.sign(sgn_pos_inf p) \<and> (?ub2 > z)"
    by auto
  have "(Sturm_Tarski.sign(sgn_class.sgn (poly p ?ub2)::real)) = (sgn (poly p ?ub2))"
    unfolding sign_def sgn_def by auto
  then have "(sgn (poly p ?ub2)) = (Sturm_Tarski.sign(sgn_pos_inf p)) \<and> (?ub2 > z)"
    using h1
    by metis
  then have "\<forall>x\<ge>z. sgn (poly p x) = Sturm_Tarski.sign (sgn_pos_inf p)"
    using allx
    by (metis dual_order.refl max.absorb3 max.bounded_iff)
  then show ?thesis using xgt
    by auto
qed

lemma limit_pos_infinity_helper1:
  assumes q_in: "q \<in> set qs"
  assumes qnonz: "q \<noteq> 0"
  assumes "x = (crb (prod_list_var qs))"
  shows "(if (poly q x > 0) then (1::int) else (if (poly q x = 0) then (0::rat) else (-1::rat)))
    = ((Sturm_Tarski.sign (sgn_pos_inf q))::int)"
  using poly_sgn_eventually_at_top[unfolded eventually_at_top_linorder]
proof -
  have "(\<exists>ub. (\<forall>x. poly q x = 0 \<longrightarrow> x < ub \<longrightarrow>
          (\<forall>x\<ge>ub. sgn_class.sgn (poly q x) = sgn_pos_inf q)))"
    using root_ub[of q] qnonz
    by meson
  then obtain ub where ub_prop: "(\<forall>x. poly q x = 0 \<longrightarrow> x < ub \<longrightarrow>
          (\<forall>x\<ge>ub. sgn_class.sgn (poly q x) = sgn_pos_inf q))"
    by auto
  show ?thesis
    proof -
    have "q \<in> set qs \<and> q \<noteq> 0"
      using q_in qnonz by blast
    then have f1: "\<forall>r. \<not> real_of_int (crb (prod_list_var qs)) \<le> r \<or> 0 \<noteq> poly q r"
      by (metis (no_types) nonzcrb[of q])
    have f2: "real_of_int (crb (prod_list_var qs)) \<le> real_of_int x"
      using assms(3) by force
    then have f3: "0 \<noteq> poly q (real_of_int x)"
      using f1 by blast
    have comb1: "\<And>z x. \<lbrakk>q \<noteq> 0; \<forall>x. poly q x = 0 \<longrightarrow> x < z; z \<le> x\<rbrakk> \<Longrightarrow> of_rat (Matrix_Equation_Construction.sgn (poly q x)) = complex_of_int (Sturm_Tarski.sign (sgn_pos_inf q))"
       using assms(2) root_ub_restate[of q] by auto
    obtain rr :: real where
      "q \<noteq> 0 \<and> (0 = poly q rr \<longrightarrow> rr < real_of_int (crb (prod_list_var qs))) \<and> real_of_int (crb (prod_list_var qs)) \<le> real_of_int x \<longrightarrow> Sturm_Tarski.sign (sgn_pos_inf q) = Matrix_Equation_Construction.sgn (poly q (real_of_int x))"
      by (metis comb1)
    then have f4: "Sturm_Tarski.sign (sgn_pos_inf q) = Matrix_Equation_Construction.sgn (poly q (real_of_int x))"
      using f2 f1 linorder_not_less qnonz by blast
    have "Matrix_Equation_Construction.sgn (poly q (real_of_int x)) = (if 0 < poly q (real_of_int x) then 1 else if poly q (real_of_int x) < 0 then - 1 else 0) \<and> (if 0 < poly q (real_of_int x) then (1::rat) = (if 0 < poly q (real_of_int x) then 1 else if poly q (real_of_int x) < 0 then - 1 else 0) else (if 0 < poly q (real_of_int x) then 1::rat else if poly q (real_of_int x) < 0 then - 1 else 0) = (if poly q (real_of_int x) < 0 then - 1 else 0)) \<and> (if poly q (real_of_int x) < 0 then - (1::rat) = (if poly q (real_of_int x) < 0 then - 1 else 0) else (0::rat) = (if poly q (real_of_int x) < 0 then - 1 else 0))"
      by (simp add: sgn_def)
    moreover
    { assume "- (1::int) \<noteq> (if poly q (real_of_int x) < 0 then - 1 else 0)"
      then have "0 < poly q (real_of_int x)"
        using f3 by (metis (no_types) not_less_iff_gr_or_eq) }
    ultimately show ?thesis
      by (smt (verit) Rat.of_rat_1 f4 of_int_hom.hom_one)
  qed
qed

lemma limit_pos_infinity_helper2:
  assumes q_in: "q \<in> set qs"
  assumes qnonz: "q = 0"
  assumes "x = (crb (prod_list_var qs))"
  shows "(if (poly q x > 0) then (1::rat) else (if (poly q x = 0) then (0::rat) else (-1::rat)))
    = ((Sturm_Tarski.sign (sgn_pos_inf q))::int)"
proof -
  have "0 = ((Sturm_Tarski.sign (sgn_pos_inf q)))"
    by (simp add: qnonz sgn_pos_inf_def)
  then show ?thesis using qnonz
    by auto
qed

lemma limit_pos_infinity_helper:
  assumes q_in: "q \<in> set qs"
  assumes "x = (crb (prod_list_var qs))"
  shows "(if (poly q x > 0) then (1::int) else (if (poly q x = 0) then 0 else -1))
    = ((Sturm_Tarski.sign (sgn_pos_inf q)))"
  using limit_pos_infinity_helper1 limit_pos_infinity_helper2 assms(2) q_in
  by (smt (verit) Rat.of_rat_1 Sturm_Tarski.sign_cases of_int_eq_iff of_int_hom.hom_one of_int_hom.hom_zero of_rat_0 of_rat_neg_one one_neq_neg_one zero_neq_neg_one)

lemma Sturm_Tarski_casting:
  shows "((Sturm_Tarski.sign x)) = rat_of_int (Sturm_Tarski.sign x)"
  by (simp add: Sturm_Tarski.sign_def)

lemma limit_pos_infinity:
  shows "consistent_sign_vec qs (crb (prod_list_var qs)) = sgn_pos_inf_rat_list qs"
  unfolding consistent_sign_vec_def sgn_pos_inf_rat_list_def
  using limit_pos_infinity_helper Sturm_Tarski_casting
  apply (auto)
    apply fastforce
   apply presburger
  by (metis of_int_hom.hom_one of_int_minus)

lemma nonzcrb_helper_neg:
  assumes q_in: "q \<in> set qs"
  assumes qnonz: "q \<noteq> 0"
  assumes lengt: "length (sorted_list_of_set {(x::real). (\<exists>q \<in> set(qs). (q \<noteq> 0 \<and> poly q x = 0))} :: real list) > 0"
  shows " \<not>(\<exists>x \<le> (real_of_int (-crb (prod_list_var qs))). poly q x = 0)"
proof clarsimp
  fix x
  assume xlt: "x \<le> - real_of_int (crb (prod_list_var qs))"
  assume pqz: "poly q x = 0"
  let ?zer_list = "sorted_list_of_set {(x::real). (\<exists>q \<in> set(qs). (q \<noteq> 0 \<and> poly q x = 0))} :: real list"
  have strict_sorted_h: "sorted_wrt (<) ?zer_list" using sorted_sorted_list_of_set
      strict_sorted_iff by auto
  have finset: "finite  {x. \<exists>q\<in>set qs. q \<noteq> 0 \<and> poly q x = 0}"
  proof -
    have all_q: "\<forall>q \<in> set qs.  q\<noteq> 0 \<longrightarrow> finite {x. poly q x = 0} "
      using poly_roots_finite by auto
    then show ?thesis by auto
  qed
  have all_x: "\<forall>x \<in> {x. \<exists>q\<in>set qs. q \<noteq> 0 \<and> poly q x = 0}. poly (prod_list_var qs) x = 0"
    using q_dvd_prod_list_var_prop
    by fastforce
  then have "poly (prod_list_var qs) (sorted_list_of_set {x. \<exists>q\<in>set qs. q \<noteq> 0 \<and> poly q x = 0} ! 0) = 0"
    using finset set_sorted_list_of_set
    by (metis (no_types, lifting) lengt nth_mem)
  then have crbgt: "-crb (prod_list_var qs) < ?zer_list ! 0" using prod_list_var_nonzero crb_lem_pos[of "prod_list_var qs" "?zer_list ! (length ?zer_list - 1)"]
    using crb_lem_neg by blast
  have x_in: "x \<in> {x. \<exists>q\<in>set qs. q \<noteq> 0 \<and> poly q x = 0}"
    using pqz q_in qnonz
    by auto
  then have "x \<in> set ?zer_list"
    by (smt (verit, best) finset in_set_member mem_Collect_eq set_sorted_list_of_set)
  then have "x \<ge> ?zer_list ! 0" using strict_sorted_h
    by (smt (verit) all_x x_in crb_lem_neg linorder_not_le of_int_hom.hom_uminus prod_list_var_nonzero xlt)
  then show "False" using xlt crbgt
    by auto
qed

lemma nonzcrb_neg:
  assumes q_in: "q \<in> set qs"
  assumes qnonz: "q \<noteq> 0"
  shows " \<not>(\<exists>x \<le> (real_of_int (-crb (prod_list_var qs))). poly q x = 0)"
proof -
  let ?zer_list = "(sorted_list_of_set {(x::real). (\<exists>q \<in> set(qs). (q \<noteq> 0 \<and> poly q x = 0))} :: real list)"
  have eo: "length ?zer_list = 0 \<or> length ?zer_list > 0"
    by auto
  have h1: "length ?zer_list = 0 \<longrightarrow> \<not>(\<exists>x \<le> (real_of_int (-crb (prod_list_var qs))). poly q x = 0)"
    by (metis crb_lem_neg dvdE linorder_not_less mult_zero_left poly_mult prod_list_var_nonzero q_dvd_prod_list_var_prop q_in qnonz)
  have h2: "length ?zer_list > 0 \<longrightarrow> \<not>(\<exists>x \<le> (real_of_int (-crb (prod_list_var qs))). poly q x = 0)"
    using nonzcrb_helper_neg assms
    by blast
  show ?thesis using eo h1 h2
    by auto
qed

lemma root_lb_restate:
  fixes p:: "real poly"
  assumes pnonz: "p \<noteq> 0"
  fixes z::"real"
  assumes zgt: "\<forall>x. poly p x=0 \<longrightarrow> x > z"
  shows "x\<le>z \<Longrightarrow> sgn (poly p x) = Sturm_Tarski.sign (sgn_neg_inf p)"
proof -
  assume xlt: "x \<le> z"
  have allx: "\<forall>x \<le> z. sgn (poly p x) = sgn (poly p z)"
  proof clarsimp
    fix x
    assume zleq: "x \<le> z"
    then have xnonz: "sgn (poly p x) \<noteq> 0"
      using zgt unfolding sgn_def by auto
    have znonz: "sgn (poly p z) \<noteq> 0"
      using zgt unfolding sgn_def by auto
    have "Matrix_Equation_Construction.sgn (poly p x) \<noteq> Matrix_Equation_Construction.sgn (poly p z) \<Longrightarrow> False"
    proof -
      assume neq: "Matrix_Equation_Construction.sgn (poly p x) \<noteq> Matrix_Equation_Construction.sgn (poly p z)"
      then have "x < z" using zleq
        using less_eq_real_def by force
      then have "((poly p x) > 0 \<and> (poly p z) < 0) \<or> ((poly p x) < 0 \<and> (poly p z) > 0) "
        using znonz xnonz zgt neq sgn_def
        by metis
      then have "\<exists>w. w < x \<and> w > z \<and> (poly p w = 0)"
        using poly_IVT_pos[of x z] poly_IVT_neg[of x z]
        by (metis \<open>x < z\<close> not_less_iff_gr_or_eq zgt)
      then show "False"
        using zgt zleq
        by linarith
    qed
    then show "Matrix_Equation_Construction.sgn (poly p x) = Matrix_Equation_Construction.sgn (poly p z)"
      by auto
  qed
  have "(\<exists>ub. (\<forall>x\<le>ub. sgn_class.sgn (poly p x) = sgn_neg_inf p))"
    using root_lb[of p] pnonz
    by meson
  then obtain lb where ub_prop: "(\<forall>x\<le>lb. sgn_class.sgn (poly p x) = sgn_neg_inf p)"
    by auto
  let ?ub2 = "min lb (z-1)"
  have "(\<forall>x\<le>?ub2. sgn_class.sgn (poly p x) = sgn_neg_inf p) \<and> (?ub2 < z)"
    using ub_prop by auto
  then have h1: "(Sturm_Tarski.sign(sgn_class.sgn (poly p ?ub2)::real)) = Sturm_Tarski.sign(sgn_neg_inf p) \<and> (?ub2 < z)"
    by auto
  have "(Sturm_Tarski.sign(sgn_class.sgn (poly p ?ub2)::real)) = (sgn (poly p ?ub2))"
    unfolding sign_def sgn_def by auto
  then have "(sgn (poly p ?ub2)) = (Sturm_Tarski.sign(sgn_neg_inf p)) \<and> (?ub2 < z)"
    using h1 by metis
  then show ?thesis using allx xlt
    by (metis min.absorb3 min.cobounded2)
qed

lemma limit_neg_infinity_helper1:
  assumes q_in: "q \<in> set qs"
  assumes qnonz: "q \<noteq> 0"
  assumes "x = -(crb (prod_list_var qs))"
  shows "(if (poly q x > 0) then 1 else (if (poly q x = 0) then 0 else -1))
    = ((Sturm_Tarski.sign (sgn_neg_inf q)))"
proof -
  have "(\<exists>ub. (\<forall>x. poly q x = 0 \<longrightarrow> x < ub \<longrightarrow>
          (\<forall>x\<ge>ub. sgn_class.sgn (poly q x) = sgn_neg_inf q)))"
    using root_lb[of q] qnonz
    by (meson not_less_iff_gr_or_eq)
  then obtain ub where ub_prop: "(\<forall>x. poly q x = 0 \<longrightarrow> x < ub \<longrightarrow>
          (\<forall>x\<ge>ub. sgn_class.sgn (poly q x) = sgn_neg_inf q))"
    by auto
  show ?thesis
  proof -
    have "q \<in> set qs \<and> q \<noteq> 0"
      using \<open>q \<in> set qs\<close> \<open>q \<noteq> 0\<close> by blast
    then have f1: "\<forall>r. \<not> r \<le> real_of_int (- crb (prod_list_var qs)) \<or> 0 \<noteq> poly q r"
      using nonzcrb_neg[of q] by auto
    have f2: "real_of_int x \<le> real_of_int (- crb (prod_list_var qs))"
      using \<open>x = - crb (prod_list_var qs)\<close> by fastforce
    obtain rr :: real where
      f3: "q \<noteq> 0 \<and> (0 = poly q rr \<longrightarrow> real_of_int (- crb (prod_list_var qs)) < rr) \<and> real_of_int x \<le> real_of_int (- crb (prod_list_var qs)) \<longrightarrow> Sturm_Tarski.sign (sgn_neg_inf q) = Matrix_Equation_Construction.sgn (poly q (real_of_int x))"
      by (metis assms(2) root_lb_restate[of q])
    have "\<not> rr \<le> real_of_int (- crb (prod_list_var qs)) \<or> 0 \<noteq> poly q rr"
      using f1 by blast
    then have "Sturm_Tarski.sign (sgn_neg_inf q) = Matrix_Equation_Construction.sgn (poly q (real_of_int x))"
      using f3 f2 \<open>q \<noteq> 0\<close> by linarith
    then show ?thesis
      by (smt (verit, best) Sturm_Tarski.sign_def of_int_eq_iff of_int_hom.hom_one of_int_hom.hom_zero of_rat_hom.hom_0_iff of_rat_hom.hom_1_iff of_rat_neg_one sgn_def)
  qed
    (*  by (smt (verit, del_insts) linorder_not_less of_rat_hom.eq_iff of_rat_of_int_eq sgn_def)  *)
qed

lemma limit_neg_infinity_helper2:
  assumes q_in: "q \<in> set qs"
  assumes qnonz: "q = 0"
  assumes "x = (-crb (prod_list_var qs))"
  shows "(if (poly q x > 0) then 1 else (if (poly q x = 0) then 0 else -1))
    = Sturm_Tarski.sign (sgn_neg_inf q)"
proof -
  have " 0 = Sturm_Tarski.sign (sgn_neg_inf q)"
    by (simp add: qnonz sgn_neg_inf_def)
  then show ?thesis using qnonz
    by auto
qed

lemma limit_neg_infinity_helper_var:
  assumes q_in: "q \<in> set qs"
  assumes "x = (-crb (prod_list_var qs))"
  shows "(if (poly q x > 0) then 1 else (if (poly q x = 0) then 0 else -1))
    = Sturm_Tarski.sign (sgn_neg_inf q)"
  using limit_neg_infinity_helper1 limit_neg_infinity_helper2  assms(2) q_in
  by blast

lemma limit_neg_infinity_helper:
  assumes q_in: "q \<in> set qs"
  assumes "x = (-crb (prod_list_var qs))"
  shows "(if (poly q x > 0) then 1 else (if (poly q x = 0) then 0 else -1))
    = (Sturm_Tarski.sign (sgn_neg_inf q))"
  using limit_neg_infinity_helper_var Sturm_Tarski_casting[of "(sgn_neg_inf q)"]
  using assms(2) q_in by presburger

lemma limit_neg_infinity:
  shows "consistent_sign_vec qs (-(crb (prod_list_var qs))) = sgn_neg_inf_rat_list qs"
  using limit_neg_infinity_helper Sturm_Tarski_casting
    consistent_sign_vec_def sgn_neg_inf_rat_list_def
  apply (auto) apply fastforce apply presburger
  by (metis (mono_tags, opaque_lifting) of_int_eq_1_iff of_int_minus)

lemma csv_signs_at_same:
  shows "consistent_sign_vec qs x = signs_at qs x"
  unfolding consistent_sign_vec_def signs_at_def squash_def by auto

lemma complex_real_int_casting:
  fixes z:: "int"
  shows "(complex_of_real \<circ> real_of_int) z = complex_of_int z"
  by auto

lemma poly_f_ncrb_constant_connection:
  assumes is_const: "check_all_const_deg qs = True"
  shows "set (characterize_consistent_signs_at_roots (poly_f qs) qs)
    = set (characterize_consistent_signs_at_roots (poly_f_nocrb qs) qs) \<union> {sgn_neg_inf_rat_list qs, sgn_pos_inf_rat_list qs}"
proof -
  have h1: "(poly_f qs)  = [:0, 1:] "
    using assms unfolding poly_f_def by auto
  have h2: "(poly_f_nocrb qs)  = [:0, 1:] "
    using assms unfolding poly_f_nocrb_def by auto
  then have same_set1: "set (characterize_consistent_signs_at_roots (poly_f qs) qs)
    = set (characterize_consistent_signs_at_roots (poly_f_nocrb qs) qs)"
    using h1 h2
    by auto
  have "{x. poly (poly_f qs) x = 0} = {0}"
    using h1 by auto
  then have "(characterize_root_list_p (poly_f qs)) = [0]"
    using h1 unfolding characterize_root_list_p_def  by auto
  then have "(characterize_consistent_signs_at_roots (poly_f qs) qs)
    = (remdups (map (signs_at qs) [0]))"
    unfolding characterize_consistent_signs_at_roots_def by auto
  then have "(characterize_consistent_signs_at_roots (poly_f qs) qs) = [signs_at qs 0]"
    by auto
  then have same_set2: "set (characterize_consistent_signs_at_roots (poly_f_nocrb qs) qs) = {signs_at qs 0}"
    using same_set1
    by auto
  have same1: "sgn_neg_inf_rat_list qs = sgn_pos_inf_rat_list qs"
    using is_const unfolding sgn_neg_inf_rat_list_def sgn_pos_inf_rat_list_def
    unfolding sgn_neg_inf_def sgn_pos_inf_def
    using check_all_const_deg_prop by auto
  have "\<And>q. q \<in> set qs \<Longrightarrow> poly q 0 = lead_coeff q"
    using is_const check_all_const_deg_prop
    by (metis poly_0_coeff_0)
  then have same2_h: "map (\<lambda>x. rat_of_int (Sturm_Tarski.sign (sgn_class.sgn (lead_coeff x)))) qs =
    map ((\<lambda>x. if 0 < x then 1 else if x < 0 then - 1 else 0) \<circ> (\<lambda>q. poly q 0)) qs"
    by simp
  then have "map rat_of_int (sgn_pos_inf_rat_list qs) = (signs_at qs 0)"
    using is_const check_all_const_deg_prop
    unfolding sgn_pos_inf_rat_list_def sgn_pos_inf_def signs_at_def squash_def
    by auto
  then have " map real_of_rat (map rat_of_int (sgn_pos_inf_rat_list qs)) =
    map of_rat (signs_at qs 0)"
    by auto
  then have "map real_of_int (sgn_pos_inf_rat_list qs) = map of_rat (signs_at qs 0)"
    by auto
  then have "map complex_of_real (map real_of_int (sgn_pos_inf_rat_list qs)) = map of_rat (signs_at qs 0)"
    by auto
  then have same2: "(sgn_pos_inf_rat_list qs) = (signs_at qs 0)"
    using complex_real_int_casting
    by (metis list.map_comp map_eq_conv)
  show ?thesis
    using same_set1 same_set2 same1 same2
    by auto
qed

lemma poly_f_ncrb_nonconstant_connection:
  assumes is_not_const: "check_all_const_deg qs = False"
  shows "set (characterize_consistent_signs_at_roots (poly_f qs) qs)
    = set (characterize_consistent_signs_at_roots (poly_f_nocrb qs) qs) \<union> {sgn_neg_inf_rat_list qs, sgn_pos_inf_rat_list qs}"
proof -
  let ?s1 = "{x. poly (poly_f qs) x = 0}"
  let ?s2 = "({x. poly (poly_f_nocrb qs) x = 0} \<union> ({-(crb (prod_list_var qs)), (crb (prod_list_var qs))}::real set))"
  have same_set: "?s1 = ?s2"
    using root_set_nocrb_var[of qs] is_not_const
    by auto
  then have same_map: "(\<lambda>x. (signs_at qs x)) ` ?s1 = (\<lambda>x. (signs_at qs x)) ` ?s2"
    by presburger
  have "set (characterize_consistent_signs_at_roots (poly_f qs) qs) =
  set (map (signs_at qs) (characterize_root_list_p (poly_f qs)))"
    using characterize_consistent_signs_at_roots_def by auto
  then have "set (characterize_consistent_signs_at_roots (poly_f qs) qs) =
  (\<lambda>x. (signs_at qs x)) ` {x. poly (poly_f qs) x = 0}"
    by (simp add: characterize_root_list_p_def poly_f_nonzero poly_roots_finite)
  then have "set (characterize_consistent_signs_at_roots (poly_f qs) qs) =
  (\<lambda>x. (signs_at qs x)) ` ({x. poly (poly_f_nocrb qs) x = 0} \<union> ({-(crb (prod_list_var qs)), (crb (prod_list_var qs))}::real set))"
    using  same_map by auto
  then have bigeq: "set (characterize_consistent_signs_at_roots (poly_f qs) qs) =
  (\<lambda>x. (signs_at qs x)) ` {x. poly (poly_f_nocrb qs) x = 0} \<union> (\<lambda>x. (signs_at qs x)) ` ({-(crb (prod_list_var qs)), (crb (prod_list_var qs))}::real set)"
    by (metis image_Un)
  have crb_seteq: "(\<lambda>x. (signs_at qs x)) ` ({-(crb (prod_list_var qs)), (crb (prod_list_var qs))}::real set) =
    (\<lambda>x. (signs_at qs x)) ` ({-(crb (prod_list_var qs))}::real set) \<union>
    (\<lambda>x. (signs_at qs x)) ` ({(crb (prod_list_var qs))}::real set)"
    by blast
  have neg: "(\<lambda>x. (signs_at qs x)) ` ({-(crb (prod_list_var qs))}::real set) ={sgn_neg_inf_rat_list qs}"
    using limit_neg_infinity[of qs] csv_signs_at_same by auto
  have pos: "(\<lambda>x. (signs_at qs x)) ` ({(crb (prod_list_var qs))}::real set) ={sgn_pos_inf_rat_list qs}"
    using limit_pos_infinity[of qs] csv_signs_at_same by auto
  have "(\<lambda>x. (signs_at qs x)) ` ({-(crb (prod_list_var qs)), (crb (prod_list_var qs))}::real set) = {sgn_neg_inf_rat_list qs} \<union> {sgn_pos_inf_rat_list qs}"
    using crb_seteq neg pos by auto
  then have "(\<lambda>x. (signs_at qs x)) ` ({-(crb (prod_list_var qs)), (crb (prod_list_var qs))}::real set)
    = {sgn_neg_inf_rat_list qs, sgn_pos_inf_rat_list qs}"
    by auto
  then have biggereq: "set (characterize_consistent_signs_at_roots (poly_f qs) qs) =
    signs_at qs ` {x. poly (poly_f_nocrb qs) x = 0} \<union>
    {sgn_neg_inf_rat_list qs, sgn_pos_inf_rat_list qs}"
    using bigeq by auto
  have key: "signs_at qs ` {x. poly (poly_f_nocrb qs) x = 0} = set (characterize_consistent_signs_at_roots (poly_f_nocrb qs) qs)"
    using characterize_consistent_signs_at_roots_def
      Groups.mult_ac(2) characterize_root_list_p_def is_not_const list.set_map mult_cancel_left mult_cancel_left1 poly_f_def poly_f_nocrb_def poly_f_nonzero poly_roots_finite set_remdups sorted_list_of_set(1)
  proof -
    have "poly_f_nocrb qs \<noteq> 0"
      by (metis mult_cancel_left1 poly_f_def poly_f_nocrb_def poly_f_nonzero)
    then have "set (remdups (map (signs_at qs) (sorted_list_of_set {r. poly (poly_f_nocrb qs) r = 0}))) = signs_at qs ` {r. poly (poly_f_nocrb qs) r = 0}"
      by (simp add: poly_roots_finite)
    then show ?thesis
      using characterize_consistent_signs_at_roots_def characterize_root_list_p_def by presburger
  qed
  then show ?thesis using biggereq
    by (metis image_image list.set_map)
qed

lemma poly_f_ncrb_connection:
  shows "set (characterize_consistent_signs_at_roots (poly_f qs) qs)
    = set (characterize_consistent_signs_at_roots (poly_f_nocrb qs) qs) \<union> {sgn_neg_inf_rat_list qs, sgn_pos_inf_rat_list qs}"
  using poly_f_ncrb_nonconstant_connection poly_f_ncrb_constant_connection
  by blast

end


theory Aabid_Relation
imports Main
begin

datatype ('a,'b) monoidgentype = C 'a  'b (infix "!" 63)

datatype ('a,'b) groupgentype = P "('a,'b) monoidgentype"
                               | N  "('a,'b) monoidgentype"

type_synonym ('a,'b) word = "(('a,'b) groupgentype) list"

primrec inverse::"('a,'b) groupgentype \<Rightarrow> ('a,'b) groupgentype"
  where
"inverse (P x) = (N x)"
|"inverse (N x) = (P x)"

primrec wordinverse::"('a,'b) word \<Rightarrow> ('a, 'b) word"
  where
"wordinverse [] = []"
|"wordinverse (x#xs) =  (wordinverse xs)@[inverse x]"

inductive_set spanset::"('a,'b) word set\<Rightarrow> ('a,'b) word set"
  for S::"('a,'b) word set"
  where
"x \<in> S \<Longrightarrow> x \<in> spanset S"
|"x \<in> inver ` S \<Longrightarrow> x \<in> spanset S"
|"x \<in> S \<Longrightarrow> y \<in> spanset S \<Longrightarrow> x@y \<in> spanset S"
|"x \<in> inver ` S \<Longrightarrow> ys \<in> spanset S \<Longrightarrow> x@y \<in> spanset S"

definition setlistcross::"'a set \<Rightarrow> 'a list \<Rightarrow> 'a list set"
 where
"setlistcross S xs = {[s]@xs | s. s \<in> S}"

value "setlistcross {(1::nat), 2, 3} [(4::nat), 5, 6]"

primrec lengthword::"nat \<Rightarrow> 'a set \<Rightarrow> 'a list set"
  where
"lengthword 0 S = {[s] | s. s \<in> S}"
|"lengthword (Suc n) S = \<Union> {setlistcross S xs | xs. xs \<in> (lengthword n S)}"

abbreviation "ngroupword \<equiv> \<lambda> n (S::('a,'b) word set). lengthword n (S \<union> (wordinverse ` S))"

inductive redrel :: "('a,'b) word \<Rightarrow> ('a,'b) word \<Rightarrow> bool" where
refl: "redrel a a"|
cancel: "redrel [x, inverse x] []"|
symm: "redrel a b \<Longrightarrow> redrel b a"|
welldefined: "redrel a b \<Longrightarrow> redrel c d \<Longrightarrow> redrel (a@c) (b@d)"|
trans: "redrel a b \<Longrightarrow> redrel b c \<Longrightarrow> redrel a c"

lemma reflp_redrel: "reflp (redrel)"
  unfolding reflp_def by (simp add: redrel.refl)

lemma symp_redrel: "symp (redrel)"
  unfolding symp_def by (simp add: redrel.symm)

lemma transp_redrel: "transp (redrel)"
  unfolding transp_def by (simp add: redrel.trans)

quotient_type ('a, 'b) wordclass = "('a, 'b) word"/"redrel"
  by(rule equivpI, simp add: reflp_redrel, simp add: symp_redrel, simp add: transp_redrel)

quotient_definition "liftappend :: ('a, 'b) wordclass \<Rightarrow> ('a, 'b) wordclass \<Rightarrow> ('a, 'b) wordclass"
  is
"append :: ('a, 'b) word  \<Rightarrow> ('a, 'b) word  \<Rightarrow> ('a, 'b) word"
  by (simp add: welldefined)

quotient_definition "NilLift :: ('a, 'b) wordclass"
  is
"Nil :: ('a, 'b) word"
  done

class semigroup =
  fixes S :: "'a set"
  and mult :: "'a \<Rightarrow> 'a  \<Rightarrow> 'a" (infixl "\<otimes>" 70)
  assumes assoc: "(x \<otimes> y) \<otimes> z = x \<otimes> (y \<otimes> z)"

class monoidl = semigroup +
  fixes neutral :: 'a ("e")
  assumes neutl: "e \<otimes> x = x"

class monoid = monoidl +
  assumes neutr: "x \<otimes> e = x"

class group = monoid +
fixes inverse ::"'a \<Rightarrow> 'a" ("inv")
assumes invl: "(inv x) \<otimes> x = e"

(*interpretation a: semigroup "?" "f"*)


theory Chisholm_E imports E                 (*Christoph Benzmüller & Xavier Parent, 2019*)

begin (* Chisholm Example *)
consts go::\<sigma> tell::\<sigma> kill::\<sigma>

  nitpick_params [user_axioms,expect=genuine,show_all,format=2] (*settings for the model finder*)

(*It ought to be that Jones goes to assist his neighbors.*)
  abbreviation  "D1 \<equiv> \<^bold>\<circle><go>"
(*It ought to be that if Jones goes, then he tells them he is coming.*)
  abbreviation  "D2w \<equiv> \<^bold>\<circle><go \<^bold>\<rightarrow> tell>"
  abbreviation  "D2n \<equiv> go \<^bold>\<rightarrow> \<^bold>\<circle><tell>"
(*If Jones doesn't go, then he ought not tell them he is coming.*)
  abbreviation  "D3w \<equiv> \<^bold>\<circle><\<^bold>\<not>go \<^bold>\<rightarrow> \<^bold>\<not>tell>"
  abbreviation  "D3n \<equiv> \<^bold>\<not>go \<^bold>\<rightarrow> \<^bold>\<circle><\<^bold>\<not>tell>"
(*Jones doesn't go. (This is encoded as a locally valid statement.)*)
  abbreviation  "D4 \<equiv> \<^bold>\<not>go"

(*** Chisholm_A ***)
 (* All-wide scoping is not leading to a dependent set of the axioms.*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D2w \<^bold>\<and> D3w) \<^bold>\<rightarrow> D4\<rfloor>"   nitpick oops (*countermodel*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D2w \<^bold>\<and> D4)  \<^bold>\<rightarrow> D3w\<rfloor>"  by blast  (*proof*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D3w \<^bold>\<and> D4)  \<^bold>\<rightarrow> D2w\<rfloor>"  nitpick oops (*countermodel*)
 lemma "\<lfloor>(D2w \<^bold>\<and> D3w \<^bold>\<and> D4)  \<^bold>\<rightarrow> D1\<rfloor>"   nitpick oops (*countermodel*)
 (* Chisholm_A is thus an inadequate modeling. *)

 (* Consistency *)
 lemma "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" nitpick [satisfy] oops (*Consistent? Yes*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows False nitpick oops (*Inconsistent? No*)
 (* Queries *)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><\<^bold>\<not>tell>\<rfloor>\<^sub>l" nitpick oops (*Should James not tell? No*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><tell>\<rfloor>\<^sub>l"  using assms by auto (*Should James tell? Yes*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><kill>\<rfloor>\<^sub>l"  nitpick oops (*Should James kill? No*)

(*** Chisholm_B ***)
 (* All-narrow scoping is leading to a dependent set of the axioms.*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D2n \<^bold>\<and> D3n) \<^bold>\<rightarrow> D4\<rfloor>"   nitpick oops (*countermodel*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D2n \<^bold>\<and> D4)  \<^bold>\<rightarrow> D3n\<rfloor>"  nitpick oops  (*countermodel*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D3n \<^bold>\<and> D4)  \<^bold>\<rightarrow> D2n\<rfloor>"  by blast  (*proof*)
 lemma "\<lfloor>(D2n \<^bold>\<and> D3n \<^bold>\<and> D4)  \<^bold>\<rightarrow> D1\<rfloor>"   nitpick oops (*countermodel*)
 (* Chisholm_B is thus an inadequate modeling. *)

 (* Consistency *)
 lemma "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" nitpick [satisfy] oops (*Consistent? Yes*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows False nitpick oops (*Inconsistent? No*)
 (* Queries *)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><\<^bold>\<not>tell>\<rfloor>\<^sub>l" using assms by auto (*Should James not tell? Yes*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><tell>\<rfloor>\<^sub>l"  using assms by auto (*Should James tell? Yes*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><kill>\<rfloor>\<^sub>l"  using assms by smt (*Should James kill? Yes*)

(*** Chisholm_C ***)
 (* Wide-narrow scoping is leading to independence of the axioms.*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D2w \<^bold>\<and> D3n) \<^bold>\<rightarrow> D4\<rfloor>"   nitpick oops (*countermodel*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D2w \<^bold>\<and> D4)  \<^bold>\<rightarrow> D3n\<rfloor>"  nitpick oops (*countermodel*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D3n \<^bold>\<and> D4)  \<^bold>\<rightarrow> D2w\<rfloor>"  nitpick oops (*countermodel*)
 lemma "\<lfloor>(D2w \<^bold>\<and> D3n \<^bold>\<and> D4)  \<^bold>\<rightarrow> D1\<rfloor>"   nitpick oops (*countermodel*)
 (* Chisholm_C is thus fine from this perspective. *)

 (* Consistency *)
 lemma "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" nitpick [satisfy] oops (*Consistent? Yes*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows False nitpick oops (*Inconsistent? No*)
 (* Queries *)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><\<^bold>\<not>tell>\<rfloor>\<^sub>l" using assms by auto (*Should James not tell? Yes*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><tell>\<rfloor>\<^sub>l"  using assms by blast (*Should James tell? Yes*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2w \<^bold>\<and> D3n)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><kill>\<rfloor>\<^sub>l"  using assms by blast (*Should James kill? Yes*)

(*** Chisholm_D ***)
 (* Narrow-wide scoping is leading to a dependent set of the axioms.*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D2n \<^bold>\<and> D3w) \<^bold>\<rightarrow> D4\<rfloor>"   nitpick oops (*countermodel*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D2n \<^bold>\<and> D4)  \<^bold>\<rightarrow> D3w\<rfloor>"  by blast  (*proof*)
 lemma "\<lfloor>(D1  \<^bold>\<and> D3w \<^bold>\<and> D4)  \<^bold>\<rightarrow> D2n\<rfloor>"  by blast  (*proof*)
 lemma "\<lfloor>(D2n \<^bold>\<and> D3w \<^bold>\<and> D4)  \<^bold>\<rightarrow> D1\<rfloor>"   nitpick oops (*countermodel*)
 (* Chisholm_D is thus an inadequate modeling. *)

 (* Consistency *)
 lemma "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" nitpick [satisfy] oops (*Consistent? Yes*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows False nitpick oops (*Inconsistent? No*)
 (* Queries *)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><\<^bold>\<not>tell>\<rfloor>\<^sub>l" nitpick oops (*Should James not tell? No*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><tell>\<rfloor>\<^sub>l"  using assms by blast (*Should James tell? Yes*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2n \<^bold>\<and> D3w)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><kill>\<rfloor>\<^sub>l"  nitpick oops (*Should James kill? No*)

(* old stuff

(*** Chisholm_A ***)
 (* All-wide scoping is not leading to an independent set of the axioms.*)
 lemma assumes D1 and D2w and D3w        shows D4     nitpick oops (*countermodel*)
 lemma assumes D1 and D2w            and D4 shows D3w using assms(1) by auto
 lemma assumes D1            and D3w and D4 shows D2w nitpick  oops (*countermodel*)
 lemma assumes        D2w and D3w and D4 shows D1     nitpick  oops (*countermodel*)
 (* Chisholm_A is thus an inadequate modeling. *)

 (* Conistency *)
 lemma assumes D1 and D2w and D3w and D4 shows True nitpick [satisfy] oops (*Consistent? Yes*)
 lemma assumes D1 and D2w and D3w and D4 shows False nitpick oops (*Inconsistent? No*)
 (* Queries *)
 lemma assumes D1 and D2w and D3w and D4 shows "\<lfloor>\<^bold>\<circle><\<^bold>\<not>tell>\<rfloor>\<^sub>l" nitpick oops (*Should James not tell? No*)
 lemma assumes D1 and D2w and D3w and D4 shows "\<lfloor>\<^bold>\<circle><tell>\<rfloor>\<^sub>l"  using assms(1) assms(2) cjactual_def by blast (*Should James tell? Yes*)
 lemma assumes D1 and D2w and D3w and D4 shows "\<lfloor>\<^bold>\<circle><kill>\<rfloor>\<^sub>l"  nitpick oops (*Should James kill?     No*)

(*** Chisholm_B ***)
 (* All-narrow scoping is leading to an independent set of the axioms.*)
 lemma assumes D1 and D2n and D3n        shows D4     nitpick oops (*countermodel*)
 lemma assumes D1 and D2n            and D4 shows D3n nitpick oops (*countermodel*)
 lemma assumes D1            and D3n and D4 shows D2n nitpick oops (*countermodel*)
 lemma assumes        D2n and D3n and D4 shows D1     nitpick oops (*countermodel*)
 (* Chisholm_B is thus fine from this perspective. *)

 (* Conistency *)
 lemma assumes D1 and D2n and D3n and D4 shows True nitpick [satisfy] oops (*Consistent? Yes*)
 lemma assumes D1 and D2n and D3n and D4 shows False nitpick oops (*Inconsistent? No*)
 (* Queries *)
 lemma assumes D1 and D2n and D3n and D4 shows "\<lfloor>\<^bold>\<circle><\<^bold>\<not>tell>\<rfloor>\<^sub>l" using assms(3) assms(4) cjactual_def by auto (*Should James not tell? Yes*)
 lemma assumes D1 and D2n and D3n and D4 shows "\<lfloor>\<^bold>\<circle><tell>\<rfloor>\<^sub>l"  using assms(1) assms(2) cjactual_def by auto (*Should James tell? Yes*)
 lemma assumes D1 and D2n and D3n and D4 shows "\<lfloor>\<^bold>\<circle><kill>\<rfloor>\<^sub>l"  using assms(1) assms(2) assms(3) assms(4) cjactual_def by auto (*Should James kill? Yes*)

(*** Chisholm_C ***)
 (* Wide-narrow scoping is leading to independence of the axioms.*)
 lemma assumes D1 and D2w and D3n        shows D4     nitpick oops (*countermodel*)
 lemma assumes D1 and D2w            and D4 shows D3n nitpick oops (*countermodel*)
 lemma assumes D1            and D3n and D4 shows D2w nitpick oops (*countermodel*)
 lemma assumes        D2w and D3n and D4 shows D1     nitpick oops (*countermodel*)
 (* Chisholm_C is thus fine from this perspective. *)

 (* Conistency *)
 lemma assumes D1 and D2w and D3n and D4 shows True nitpick [satisfy] oops (*Consistent? Yes*)
 lemma assumes D1 and D2w and D3n and D4 shows False nitpick oops (*Inconsistent? No*)
 (* Queries *)
 lemma assumes D1 and D2w and D3n and D4 shows "\<lfloor>\<^bold>\<circle><\<^bold>\<not>tell>\<rfloor>\<^sub>l" using assms(3) assms(4) cjactual_def by auto (*Should James not tell? Yes*)
 lemma assumes D1 and D2w and D3n and D4 shows "\<lfloor>\<^bold>\<circle><tell>\<rfloor>\<^sub>l"  using assms(1) assms(2) cjactual_def by auto (*Should James tell? Yes*)
 lemma assumes D1 and D2w and D3n and D4 shows "\<lfloor>\<^bold>\<circle><kill>\<rfloor>\<^sub>l"  using assms(1) assms(2) assms(3) assms(4) cjactual_def by force (*Should James kill? Yes*)

(*** Chisholm_D ***)
 (* Narrow-wide scoping is not leading to independence of the axioms.*)
 lemma assumes D1 and D2n and D3w        shows D4     nitpick oops (*countermodel*)
 lemma assumes D1 and D2n            and D4 shows D3w using assms(1) by auto
 lemma assumes D1            and D3w and D4 shows D2n nitpick  oops (*countermodel*)
 lemma assumes        D2n and D3w and D4 shows D1     nitpick  oops (*countermodel*)
 (* Chisholm_D is thus an inadequate modeling. *)

 (* Consistency *)
 lemma assumes D1 and D2n and D3w and D4 shows True nitpick [satisfy] oops (*Consistent? Yes*)
 lemma assumes D1 and D2n and D3w and D4 shows False nitpick oops (*Inconsistent? No*)
 (* Queries *)
 lemma assumes D1 and D2n and D3w and D4 shows "\<lfloor>\<^bold>\<circle><\<^bold>\<not>tell>\<rfloor>\<^sub>l" nitpick oops (*Should James not tell? No*)
 lemma assumes D1 and D2n and D3w and D4 shows "\<lfloor>\<^bold>\<circle><tell>\<rfloor>\<^sub>l"  using assms(1) assms(2) cjactual_def by auto (*Should James tell? Yes*)
 lemma assumes D1 and D2n and D3w and D4 shows "\<lfloor>\<^bold>\<circle><kill>\<rfloor>\<^sub>l"  nitpick oops (*Should James kill? No*)

*)

end


(* Taken from HOL/IMP/Star *)
(*<*)
theory Star
  imports Main
begin

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

hide_fact (open) refl step  \<comment> \<open>names too generic\<close>

lemma star_trans:
  "star r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"
proof(induction rule: star.induct) \<^marker>\<open>tag invisible\<close>
  case refl thus ?case .
next
  case step thus ?case by (metis star.step)
qed

lemmas star_induct =
  star.induct[of "r:: 'a*'b \<Rightarrow> 'a*'b \<Rightarrow> bool", split_format(complete)]

declare star.refl[simp,intro]

lemma star_step1[simp, intro]: "r x y \<Longrightarrow> star r x y"
by(metis star.refl star.step)

code_pred [show_modes] star .

end
(*>*)


section {* Examples *}

theory RG_Examples
imports RG_Syntax
begin

lemmas definitions [simp]= stable_def Pre_def Rely_def Guar_def Post_def Com_def

subsection {* Set Elements of an Array to Zero *}

lemma le_less_trans2: "\<lbrakk>(j::nat)<k; i\<le> j\<rbrakk> \<Longrightarrow> i<k"
by simp

lemma add_le_less_mono: "\<lbrakk> (a::nat) < c; b\<le>d \<rbrakk> \<Longrightarrow> a + b < c + d"
by simp

record Example1 =
  A :: "nat list"

lemma Example1:
 "\<turnstile> COBEGIN
      SCHEME [0 \<le> i < n]
     (\<acute>A := \<acute>A [i := 0],
     \<lbrace> n < length \<acute>A \<rbrace>,
     \<lbrace> length \<ordmasculine>A = length \<ordfeminine>A \<and> \<ordmasculine>A ! i = \<ordfeminine>A ! i \<rbrace>,
     \<lbrace> length \<ordmasculine>A = length \<ordfeminine>A \<and> (\<forall>j<n. i \<noteq> j \<longrightarrow> \<ordmasculine>A ! j = \<ordfeminine>A ! j) \<rbrace>,
     \<lbrace> \<acute>A ! i = 0 \<rbrace>)
    COEND
 SAT [\<lbrace> n < length \<acute>A \<rbrace>, \<lbrace> \<ordmasculine>A = \<ordfeminine>A \<rbrace>, \<lbrace> True \<rbrace>, \<lbrace> \<forall>i < n. \<acute>A ! i = 0 \<rbrace>]"
apply(rule Parallel)
apply (auto intro!: Basic)
done

lemma Example1_parameterized:
"k < t \<Longrightarrow>
  \<turnstile> COBEGIN
    SCHEME [k*n\<le>i<(Suc k)*n] (\<acute>A:=\<acute>A[i:=0],
   \<lbrace>t*n < length \<acute>A\<rbrace>,
   \<lbrace>t*n < length \<ordmasculine>A \<and> length \<ordmasculine>A=length \<ordfeminine>A \<and> \<ordmasculine>A!i = \<ordfeminine>A!i\<rbrace>,
   \<lbrace>t*n < length \<ordmasculine>A \<and> length \<ordmasculine>A=length \<ordfeminine>A \<and> (\<forall>j<length \<ordmasculine>A . i\<noteq>j \<longrightarrow> \<ordmasculine>A!j = \<ordfeminine>A!j)\<rbrace>,
   \<lbrace>\<acute>A!i=0\<rbrace>)
   COEND
 SAT [\<lbrace>t*n < length \<acute>A\<rbrace>,
      \<lbrace>t*n < length \<ordmasculine>A \<and> length \<ordmasculine>A=length \<ordfeminine>A \<and> (\<forall>i<n. \<ordmasculine>A!(k*n+i)=\<ordfeminine>A!(k*n+i))\<rbrace>,
      \<lbrace>t*n < length \<ordmasculine>A \<and> length \<ordmasculine>A=length \<ordfeminine>A \<and>
      (\<forall>i<length \<ordmasculine>A . (i<k*n \<longrightarrow> \<ordmasculine>A!i = \<ordfeminine>A!i) \<and> ((Suc k)*n \<le> i\<longrightarrow> \<ordmasculine>A!i = \<ordfeminine>A!i))\<rbrace>,
      \<lbrace>\<forall>i<n. \<acute>A!(k*n+i) = 0\<rbrace>]"
apply(rule Parallel)
    apply auto
  apply(erule_tac x="k*n +i" in allE)
  apply(subgoal_tac "k*n+i <length (A b)")
   apply force
  apply(erule le_less_trans2)
  apply(case_tac t,simp+)
  apply (simp add:add.commute)
  apply(simp add: add_le_mono)
apply(rule Basic)
   apply simp
   apply clarify
   apply (subgoal_tac "k*n+i< length (A x)")
    apply simp
   apply(erule le_less_trans2)
   apply(case_tac t,simp+)
   apply (simp add:add.commute)
   apply(rule add_le_mono, auto)
done

subsection {* Increment a Variable in Parallel *}

subsubsection {* Two components *}

record Example2 =
  x  :: nat
  c_0 :: nat
  c_1 :: nat

lemma Example2:
 "\<turnstile>  COBEGIN
    (\<langle> \<acute>x:=\<acute>x+1;; \<acute>c_0:=\<acute>c_0 + 1 \<rangle>,
     \<lbrace>\<acute>x=\<acute>c_0 + \<acute>c_1  \<and> \<acute>c_0=0\<rbrace>,
     \<lbrace>\<ordmasculine>c_0 = \<ordfeminine>c_0 \<and>
        (\<ordmasculine>x=\<ordmasculine>c_0 + \<ordmasculine>c_1
        \<longrightarrow> \<ordfeminine>x = \<ordfeminine>c_0 + \<ordfeminine>c_1)\<rbrace>,
     \<lbrace>\<ordmasculine>c_1 = \<ordfeminine>c_1 \<and>
         (\<ordmasculine>x=\<ordmasculine>c_0 + \<ordmasculine>c_1
         \<longrightarrow> \<ordfeminine>x =\<ordfeminine>c_0 + \<ordfeminine>c_1)\<rbrace>,
     \<lbrace>\<acute>x=\<acute>c_0 + \<acute>c_1 \<and> \<acute>c_0=1 \<rbrace>)
  \<parallel>
      (\<langle> \<acute>x:=\<acute>x+1;; \<acute>c_1:=\<acute>c_1+1 \<rangle>,
     \<lbrace>\<acute>x=\<acute>c_0 + \<acute>c_1 \<and> \<acute>c_1=0 \<rbrace>,
     \<lbrace>\<ordmasculine>c_1 = \<ordfeminine>c_1 \<and>
        (\<ordmasculine>x=\<ordmasculine>c_0 + \<ordmasculine>c_1
        \<longrightarrow> \<ordfeminine>x = \<ordfeminine>c_0 + \<ordfeminine>c_1)\<rbrace>,
     \<lbrace>\<ordmasculine>c_0 = \<ordfeminine>c_0 \<and>
         (\<ordmasculine>x=\<ordmasculine>c_0 + \<ordmasculine>c_1
        \<longrightarrow> \<ordfeminine>x =\<ordfeminine>c_0 + \<ordfeminine>c_1)\<rbrace>,
     \<lbrace>\<acute>x=\<acute>c_0 + \<acute>c_1 \<and> \<acute>c_1=1\<rbrace>)
 COEND
 SAT [\<lbrace>\<acute>x=0 \<and> \<acute>c_0=0 \<and> \<acute>c_1=0\<rbrace>,
      \<lbrace>\<ordmasculine>x=\<ordfeminine>x \<and>  \<ordmasculine>c_0= \<ordfeminine>c_0 \<and> \<ordmasculine>c_1=\<ordfeminine>c_1\<rbrace>,
      \<lbrace>True\<rbrace>,
      \<lbrace>\<acute>x=2\<rbrace>]"
apply(rule Parallel)
   apply simp_all
   apply clarify
   apply(case_tac i)
    apply simp
    apply(rule conjI)
     apply clarify
     apply simp
    apply clarify
    apply simp
   apply simp
   apply(rule conjI)
    apply clarify
    apply simp
   apply clarify
   apply simp
   apply(subgoal_tac "xa=0")
    apply simp
   apply arith
  apply clarify
  apply(case_tac xaa, simp, simp)
 apply clarify
 apply simp
 apply(erule_tac x=0 in all_dupE)
 apply(erule_tac x=1 in allE,simp)
apply clarify
apply(case_tac i,simp)
 apply(rule Await)
  apply simp_all
 apply(clarify)
 apply(rule Seq)
  prefer 2
  apply(rule Basic)
   apply simp_all
  apply(rule subset_refl)
 apply(rule Basic)
 apply simp_all
 apply clarify
 apply simp
apply(rule Await)
 apply simp_all
apply(clarify)
apply(rule Seq)
 prefer 2
 apply(rule Basic)
  apply simp_all
 apply(rule subset_refl)
apply(auto intro!: Basic)
done

subsubsection {* Parameterized *}

lemma Example2_lemma2_aux: "j<n \<Longrightarrow>
 (\<Sum>i=0..<n. (b i::nat)) =
 (\<Sum>i=0..<j. b i) + b j + (\<Sum>i=0..<n-(Suc j) . b (Suc j + i))"
apply(induct n)
 apply simp_all
apply(simp add:less_Suc_eq)
 apply(auto)
apply(subgoal_tac "n - j = Suc(n- Suc j)")
  apply simp
apply arith
done

lemma Example2_lemma2_aux2:
  "j\<le> s \<Longrightarrow> (\<Sum>i::nat=0..<j. (b (s:=t)) i) = (\<Sum>i=0..<j. b i)"
  by (induct j) simp_all

lemma Example2_lemma2:
 "\<lbrakk>j<n; b j=0\<rbrakk> \<Longrightarrow> Suc (\<Sum>i::nat=0..<n. b i)=(\<Sum>i=0..<n. (b (j := Suc 0)) i)"
apply(frule_tac b="(b (j:=(Suc 0)))" in Example2_lemma2_aux)
apply(erule_tac  t="setsum (b(j := (Suc 0))) {0..<n}" in ssubst)
apply(frule_tac b=b in Example2_lemma2_aux)
apply(erule_tac  t="setsum b {0..<n}" in ssubst)
apply(subgoal_tac "Suc (setsum b {0..<j} + b j + (\<Sum>i=0..<n - Suc j. b (Suc j + i)))=(setsum b {0..<j} + Suc (b j) + (\<Sum>i=0..<n - Suc j. b (Suc j + i)))")
apply(rotate_tac -1)
apply(erule ssubst)
apply(subgoal_tac "j\<le>j")
 apply(drule_tac b="b" and t="(Suc 0)" in Example2_lemma2_aux2)
apply(rotate_tac -1)
apply(erule ssubst)
apply simp_all
done

lemma Example2_lemma2_Suc0: "\<lbrakk>j<n; b j=0\<rbrakk> \<Longrightarrow>
 Suc (\<Sum>i::nat=0..< n. b i)=(\<Sum>i=0..< n. (b (j:=Suc 0)) i)"
by(simp add:Example2_lemma2)

record Example2_parameterized =
  C :: "nat \<Rightarrow> nat"
  y  :: nat

lemma Example2_parameterized: "0<n \<Longrightarrow>
  \<turnstile> COBEGIN SCHEME  [0\<le>i<n]
     (\<langle> \<acute>y:=\<acute>y+1;; \<acute>C:=\<acute>C (i:=1) \<rangle>,
     \<lbrace>\<acute>y=(\<Sum>i=0..<n. \<acute>C i) \<and> \<acute>C i=0\<rbrace>,
     \<lbrace>\<ordmasculine>C i = \<ordfeminine>C i \<and>
      (\<ordmasculine>y=(\<Sum>i=0..<n. \<ordmasculine>C i) \<longrightarrow> \<ordfeminine>y =(\<Sum>i=0..<n. \<ordfeminine>C i))\<rbrace>,
     \<lbrace>(\<forall>j<n. i\<noteq>j \<longrightarrow> \<ordmasculine>C j = \<ordfeminine>C j) \<and>
       (\<ordmasculine>y=(\<Sum>i=0..<n. \<ordmasculine>C i) \<longrightarrow> \<ordfeminine>y =(\<Sum>i=0..<n. \<ordfeminine>C i))\<rbrace>,
     \<lbrace>\<acute>y=(\<Sum>i=0..<n. \<acute>C i) \<and> \<acute>C i=1\<rbrace>)
    COEND
 SAT [\<lbrace>\<acute>y=0 \<and> (\<Sum>i=0..<n. \<acute>C i)=0 \<rbrace>, \<lbrace>\<ordmasculine>C=\<ordfeminine>C \<and> \<ordmasculine>y=\<ordfeminine>y\<rbrace>, \<lbrace>True\<rbrace>, \<lbrace>\<acute>y=n\<rbrace>]"
apply(rule Parallel)
apply force
apply force
apply(force)
apply clarify
apply simp
apply simp
apply clarify
apply simp
apply(rule Await)
apply simp_all
apply clarify
apply(rule Seq)
prefer 2
apply(rule Basic)
apply(rule subset_refl)
apply simp+
apply(rule Basic)
apply simp
apply clarify
apply simp
apply(simp add:Example2_lemma2_Suc0 cong:if_cong)
apply simp_all
done

subsection {* Find Least Element *}

text {* A previous lemma: *}

lemma mod_aux :"\<lbrakk>i < (n::nat); a mod n = i;  j < a + n; j mod n = i; a < j\<rbrakk> \<Longrightarrow> False"
apply(subgoal_tac "a=a div n*n + a mod n" )
 prefer 2 apply (simp (no_asm_use))
apply(subgoal_tac "j=j div n*n + j mod n")
 prefer 2 apply (simp (no_asm_use))
apply simp
apply(subgoal_tac "a div n*n < j div n*n")
prefer 2 apply arith
apply(subgoal_tac "j div n*n < (a div n + 1)*n")
prefer 2 apply simp
apply (simp only:mult_less_cancel2)
apply arith
done

record Example3 =
  X :: "nat \<Rightarrow> nat"
  Y :: "nat \<Rightarrow> nat"

lemma Example3: "m mod n=0 \<Longrightarrow>
 \<turnstile> COBEGIN
 SCHEME [0\<le>i<n]
 (WHILE (\<forall>j<n. \<acute>X i < \<acute>Y j)  DO
   IF P(B!(\<acute>X i)) THEN \<acute>Y:=\<acute>Y (i:=\<acute>X i)
   ELSE \<acute>X:= \<acute>X (i:=(\<acute>X i)+ n) FI
  OD,
 \<lbrace>(\<acute>X i) mod n=i \<and> (\<forall>j<\<acute>X i. j mod n=i \<longrightarrow> \<not>P(B!j)) \<and> (\<acute>Y i<m \<longrightarrow> P(B!(\<acute>Y i)) \<and> \<acute>Y i\<le> m+i)\<rbrace>,
 \<lbrace>(\<forall>j<n. i\<noteq>j \<longrightarrow> \<ordfeminine>Y j \<le> \<ordmasculine>Y j) \<and> \<ordmasculine>X i = \<ordfeminine>X i \<and>
   \<ordmasculine>Y i = \<ordfeminine>Y i\<rbrace>,
 \<lbrace>(\<forall>j<n. i\<noteq>j \<longrightarrow> \<ordmasculine>X j = \<ordfeminine>X j \<and> \<ordmasculine>Y j = \<ordfeminine>Y j) \<and>
   \<ordfeminine>Y i \<le> \<ordmasculine>Y i\<rbrace>,
 \<lbrace>(\<acute>X i) mod n=i \<and> (\<forall>j<\<acute>X i. j mod n=i \<longrightarrow> \<not>P(B!j)) \<and> (\<acute>Y i<m \<longrightarrow> P(B!(\<acute>Y i)) \<and> \<acute>Y i\<le> m+i) \<and> (\<exists>j<n. \<acute>Y j \<le> \<acute>X i) \<rbrace>)
 COEND
 SAT [\<lbrace> \<forall>i<n. \<acute>X i=i \<and> \<acute>Y i=m+i \<rbrace>,\<lbrace>\<ordmasculine>X=\<ordfeminine>X \<and> \<ordmasculine>Y=\<ordfeminine>Y\<rbrace>,\<lbrace>True\<rbrace>,
  \<lbrace>\<forall>i<n. (\<acute>X i) mod n=i \<and> (\<forall>j<\<acute>X i. j mod n=i \<longrightarrow> \<not>P(B!j)) \<and>
    (\<acute>Y i<m \<longrightarrow> P(B!(\<acute>Y i)) \<and> \<acute>Y i\<le> m+i) \<and> (\<exists>j<n. \<acute>Y j \<le> \<acute>X i)\<rbrace>]"
apply(rule Parallel)
--{*5 subgoals left *}
apply force+
apply clarify
apply simp
apply(rule While)
    apply force
   apply force
  apply force
 apply(rule_tac pre'="\<lbrace> \<acute>X i mod n = i \<and> (\<forall>j. j<\<acute>X i \<longrightarrow> j mod n = i \<longrightarrow> \<not>P(B!j)) \<and> (\<acute>Y i < n * q \<longrightarrow> P (B!(\<acute>Y i))) \<and> \<acute>X i<\<acute>Y i\<rbrace>" in Conseq)
     apply force
    apply(rule subset_refl)+
 apply(rule Cond)
    apply force
   apply(rule Basic)
      apply force
     apply fastforce
    apply force
   apply force
  apply(rule Basic)
     apply simp
     apply clarify
     apply simp
     apply (case_tac "X x (j mod n) \<le> j")
     apply (drule le_imp_less_or_eq)
     apply (erule disjE)
     apply (drule_tac j=j and n=n and i="j mod n" and a="X x (j mod n)" in mod_aux)
     apply auto
done

text {* Same but with a list as auxiliary variable: *}

record Example3_list =
  X :: "nat list"
  Y :: "nat list"

lemma Example3_list: "m mod n=0 \<Longrightarrow> \<turnstile> (COBEGIN SCHEME [0\<le>i<n]
 (WHILE (\<forall>j<n. \<acute>X!i < \<acute>Y!j)  DO
     IF P(B!(\<acute>X!i)) THEN \<acute>Y:=\<acute>Y[i:=\<acute>X!i] ELSE \<acute>X:= \<acute>X[i:=(\<acute>X!i)+ n] FI
  OD,
 \<lbrace>n<length \<acute>X \<and> n<length \<acute>Y \<and> (\<acute>X!i) mod n=i \<and> (\<forall>j<\<acute>X!i. j mod n=i \<longrightarrow> \<not>P(B!j)) \<and> (\<acute>Y!i<m \<longrightarrow> P(B!(\<acute>Y!i)) \<and> \<acute>Y!i\<le> m+i)\<rbrace>,
 \<lbrace>(\<forall>j<n. i\<noteq>j \<longrightarrow> \<ordfeminine>Y!j \<le> \<ordmasculine>Y!j) \<and> \<ordmasculine>X!i = \<ordfeminine>X!i \<and>
   \<ordmasculine>Y!i = \<ordfeminine>Y!i \<and> length \<ordmasculine>X = length \<ordfeminine>X \<and> length \<ordmasculine>Y = length \<ordfeminine>Y\<rbrace>,
 \<lbrace>(\<forall>j<n. i\<noteq>j \<longrightarrow> \<ordmasculine>X!j = \<ordfeminine>X!j \<and> \<ordmasculine>Y!j = \<ordfeminine>Y!j) \<and>
   \<ordfeminine>Y!i \<le> \<ordmasculine>Y!i \<and> length \<ordmasculine>X = length \<ordfeminine>X \<and> length \<ordmasculine>Y = length \<ordfeminine>Y\<rbrace>,
 \<lbrace>(\<acute>X!i) mod n=i \<and> (\<forall>j<\<acute>X!i. j mod n=i \<longrightarrow> \<not>P(B!j)) \<and> (\<acute>Y!i<m \<longrightarrow> P(B!(\<acute>Y!i)) \<and> \<acute>Y!i\<le> m+i) \<and> (\<exists>j<n. \<acute>Y!j \<le> \<acute>X!i) \<rbrace>) COEND)
 SAT [\<lbrace>n<length \<acute>X \<and> n<length \<acute>Y \<and> (\<forall>i<n. \<acute>X!i=i \<and> \<acute>Y!i=m+i) \<rbrace>,
      \<lbrace>\<ordmasculine>X=\<ordfeminine>X \<and> \<ordmasculine>Y=\<ordfeminine>Y\<rbrace>,
      \<lbrace>True\<rbrace>,
      \<lbrace>\<forall>i<n. (\<acute>X!i) mod n=i \<and> (\<forall>j<\<acute>X!i. j mod n=i \<longrightarrow> \<not>P(B!j)) \<and>
        (\<acute>Y!i<m \<longrightarrow> P(B!(\<acute>Y!i)) \<and> \<acute>Y!i\<le> m+i) \<and> (\<exists>j<n. \<acute>Y!j \<le> \<acute>X!i)\<rbrace>]"
apply (rule Parallel)
apply (auto cong del: strong_INF_cong strong_SUP_cong)
apply force
apply (rule While)
    apply force
   apply force
  apply force
 apply(rule_tac pre'="\<lbrace>n<length \<acute>X \<and> n<length \<acute>Y \<and> \<acute>X ! i mod n = i \<and> (\<forall>j. j < \<acute>X ! i \<longrightarrow> j mod n = i \<longrightarrow> \<not> P (B ! j)) \<and> (\<acute>Y ! i < n * q \<longrightarrow> P (B ! (\<acute>Y ! i))) \<and> \<acute>X!i<\<acute>Y!i\<rbrace>" in Conseq)
     apply force
    apply(rule subset_refl)+
 apply(rule Cond)
    apply force
   apply(rule Basic)
      apply force
     apply force
    apply force
   apply force
  apply(rule Basic)
     apply simp
     apply clarify
     apply simp
     apply(rule allI)
     apply(rule impI)+
     apply(case_tac "X x ! i\<le> j")
      apply(drule le_imp_less_or_eq)
      apply(erule disjE)
       apply(drule_tac j=j and n=n and i=i and a="X x ! i" in mod_aux)
     apply auto
done

end


theory MachineCode
  imports Main
begin

datatype reg = R1 | R2 | R3 | R4 | R5

datatype mach =
  LDI reg nat   (* $R := k *)
  | LOD reg reg (* $R\<^sub>1 := M[$R\<^sub>2] *)
  | STO reg reg (* M[$R\<^sub>1] := $R\<^sub>2 *)
  | STI reg nat (* M[$R] := k *)
  | MOV reg reg (* $R\<^sub>1 := $R\<^sub>2 *)
  | MVP reg     (* $R := $PC *)
  | ADD reg nat (* $R := $R + k *)
  | SUB reg nat (* $R := $R - k *)
  | JMP reg     (* $PC := $R (indirect jump) *)

datatype mach_state = MS "reg \<Rightarrow> nat" "nat \<Rightarrow> nat" nat

inductive evalm :: "mach list \<Rightarrow> mach_state \<Rightarrow> mach_state \<Rightarrow> bool" (infix "\<tturnstile> _ \<leadsto>\<^sub>m" 50) where
  evm_ldi [simp]: "cd ! pc = LDI r k \<Longrightarrow>
    cd \<tturnstile> MS rs mem (Suc pc) \<leadsto>\<^sub>m MS (rs(r := k)) mem pc"
| evm_lod [simp]: "cd ! pc = LOD r ptr \<Longrightarrow>
    cd \<tturnstile> MS rs mem (Suc pc) \<leadsto>\<^sub>m MS (rs(r := mem (rs ptr))) mem pc"
| evm_sto [simp]: "cd ! pc = STO ptr r \<Longrightarrow>
    cd \<tturnstile> MS rs mem (Suc pc) \<leadsto>\<^sub>m MS rs (mem(rs ptr := rs r)) pc"
| evm_sti [simp]: "cd ! pc = STI ptr k \<Longrightarrow>
    cd \<tturnstile> MS rs mem (Suc pc) \<leadsto>\<^sub>m MS rs (mem(rs ptr := k)) pc"
| evm_mov [simp]: "cd ! pc = MOV r1 r2 \<Longrightarrow>
    cd \<tturnstile> MS rs mem (Suc pc) \<leadsto>\<^sub>m MS (rs(r1 := rs r2)) mem pc"
| evm_mvp [simp]: "cd ! pc = MVP r \<Longrightarrow>
    cd \<tturnstile> MS rs mem (Suc pc) \<leadsto>\<^sub>m MS (rs(r := pc)) mem pc"
| evm_add [simp]: "cd ! pc = ADD r k \<Longrightarrow>
    cd \<tturnstile> MS rs mem (Suc pc) \<leadsto>\<^sub>m MS (rs(r := rs r + k)) mem pc"
| evm_sub [simp]: "cd ! pc = SUB r k \<Longrightarrow>
    cd \<tturnstile> MS rs mem (Suc pc) \<leadsto>\<^sub>m MS (rs(r := rs r - k)) mem pc"
| evm_jmp [simp]: "cd ! pc = JMP r \<Longrightarrow>
    cd \<tturnstile> MS rs mem (Suc pc) \<leadsto>\<^sub>m MS (rs(r := 0)) mem (rs r)"

theorem determinismm: "cd \<tturnstile> \<Sigma> \<leadsto>\<^sub>m \<Sigma>' \<Longrightarrow> cd \<tturnstile> \<Sigma> \<leadsto>\<^sub>m \<Sigma>'' \<Longrightarrow> \<Sigma>' = \<Sigma>''"
proof (induction cd \<Sigma> \<Sigma>' rule: evalm.induct)
  case (evm_ldi cd pc r k rs mem)
  from evm_ldi(2, 1) show ?case
    by (induction cd "MS rs mem (Suc pc)" \<Sigma>'' rule: evalm.induct) simp_all
next
  case (evm_lod cd pc r ptr rs mem)
  from evm_lod(2, 1) show ?case
    by (induction cd "MS rs mem (Suc pc)" \<Sigma>'' rule: evalm.induct) simp_all
next
  case (evm_sto cd pc ptr r rs mem)
  from evm_sto(2, 1) show ?case
    by (induction cd "MS rs mem (Suc pc)" \<Sigma>'' rule: evalm.induct) simp_all
next
  case (evm_sti cd pc ptr k rs mem)
  from evm_sti(2, 1) show ?case
    by (induction cd "MS rs mem (Suc pc)" \<Sigma>'' rule: evalm.induct) simp_all
next
  case (evm_mov cd pc r1 r2 rs mem)
  from evm_mov(2, 1) show ?case
    by (induction cd "MS rs mem (Suc pc)" \<Sigma>'' rule: evalm.induct) simp_all
next
  case (evm_mvp cd pc r rs mem)
  from evm_mvp(2, 1) show ?case
    by (induction cd "MS rs mem (Suc pc)" \<Sigma>'' rule: evalm.induct) simp_all
next
  case (evm_add cd pc r k rs mem)
  from evm_add(2, 1) show ?case
    by (induction cd "MS rs mem (Suc pc)" \<Sigma>'' rule: evalm.induct) simp_all
next
  case (evm_sub cd pc r k rs mem)
  from evm_sub(2, 1) show ?case
    by (induction cd "MS rs mem (Suc pc)" \<Sigma>'' rule: evalm.induct) simp_all
next
  case (evm_jmp cd pc r rs mem)
  from evm_jmp(2, 1) show ?case
    by (induction cd "MS rs mem (Suc pc)" \<Sigma>'' rule: evalm.induct) simp_all
qed

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.*)
  theory TIP_sort_BubSortPermutes
  imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

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

fun elem :: "'a => 'a list => bool" where
  "elem x (nil2) = False"
| "elem x (cons2 z xs) = ((z = x) | (elem x xs))"

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

fun isPermutation :: "'a list => 'a list => bool" where
  "isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z x2) = False"
| "isPermutation (cons2 x3 xs) y =
     ((elem x3 y) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 y)))"

fun bubble :: "int list => (bool, (int list)) pair" where
  "bubble (nil2) = pair2 False (nil2)"
| "bubble (cons2 y (nil2)) = pair2 False (cons2 y (nil2))"
| "bubble (cons2 y (cons2 y2 xs)) =
     (if y <= y2 then
        (case bubble (cons2 y2 xs) of
           pair2 b22 ys22 => pair2 b22 (cons2 y ys22))
        else
        (case bubble (cons2 y xs) of
           pair2 b2 ys2 => pair2 True (cons2 y2 ys2)))"

(*fun did not finish the proof*)
function bubsort :: "int list => int list" where
  "bubsort x =
   (case bubble x of pair2 b1 ys => (if b1 then bubsort ys else x))"
  by pat_completeness auto

theorem property0 :
  "isPermutation (bubsort xs) xs"
  oops

end


(*<*)
theory HybridLogic
imports Main

begin
(*>*)

  text \<open>
  For the embedding of NHOML into HOL we can use mostly the same
  embedding as HOML to HOL. We introduce i for individuals, \<tau> for
  the worlds, that are points in time, and a new type \<eta> for nominals.

  We define an ordering relation <t for the worlds, that works
  as the accessibility relation and a relation for the nominals
  that associates nominals with points in time. As can be read in Blackburn
  the valuation maps a nominal to a singleton set taken from the powerset of the worlds.
\<close>
  typedecl i    \<comment> \<open>the type for indiviuals\<close>
  typedecl \<tau>    \<comment> \<open>the type for worlds\<close>
  typedecl \<eta>    \<comment> \<open>the type of nomimals\<close>

  consts order :: "\<tau> \<Rightarrow> \<tau> \<Rightarrow> bool" (infixl "t<" 70) \<comment> \<open>accessibility relation on worlds\<close>
  consts worldAt :: "\<eta> \<Rightarrow> \<tau> \<Rightarrow> bool" (infixl "@@" 70) \<comment> \<open>nominal - world - relation\<close>

  text \<open>
  We axiomatize the relation for the mapping of nominals to worlds
  as functions. Opposing to Blackburn we declare the mapping
  as surjective. Without surjectivity the lemmas L1x - L6x cannot
  be proven.
\<close>

  axiomatization where
    rightUnique: "\<forall>i. \<forall>t. \<forall>t'. i @@ t \<and> i @@ t' \<longrightarrow> t = t'" and
    leftTotal: "\<forall>i. \<exists>t. i @@ t" and
    surjective: "\<forall>t. \<exists>i. i @@ t"

  text \<open>
  Adopted from QML embedding by Benzmueller and Paleo
\<close>

  type_synonym \<sigma> = "(\<tau> \<Rightarrow> bool)"

  abbreviation tTop :: "\<sigma>" ("tT") where "tT \<equiv> (\<lambda>t. True)"
  abbreviation tnot :: "\<sigma> \<Rightarrow> \<sigma>" ("t\<not>") where "t\<not> \<phi> \<equiv> (\<lambda>t. \<not> \<phi> t)"
  abbreviation tand :: "\<sigma> \<Rightarrow> \<sigma> \<Rightarrow> \<sigma>" (infixr "t\<and>" 51) where "\<phi> t\<and> \<psi> \<equiv> (\<lambda>t. \<phi> t \<and> \<psi> t)"
  abbreviation tor :: "\<sigma> \<Rightarrow> \<sigma> \<Rightarrow> \<sigma>" (infixr "t\<or>" 50) where "\<phi> t\<or> \<psi> \<equiv> (\<lambda>t. \<phi> t \<or> \<psi> t)"
  abbreviation timplies :: "\<sigma> \<Rightarrow> \<sigma> \<Rightarrow> \<sigma>" (infixr "t\<rightarrow>" 49) where "\<phi> t\<rightarrow> \<psi> \<equiv> (\<lambda>t. \<phi> t \<longrightarrow> \<psi> t)"
  abbreviation tequiv:: "\<sigma> \<Rightarrow> \<sigma> \<Rightarrow> \<sigma>" (infixr "t\<equiv>" 48) where "\<phi> t\<equiv> \<psi> \<equiv> (\<lambda>t. \<phi> t \<longleftrightarrow> \<psi> t)"
  abbreviation tP :: "\<sigma> \<Rightarrow> \<sigma>" ("P") where "P \<phi> \<equiv> (\<lambda>t. \<exists>t'.  t' t< t  \<and> \<phi> t')"
  abbreviation tF :: "\<sigma> \<Rightarrow> \<sigma>" ("F") where "F \<phi> \<equiv> (\<lambda>t. \<exists>t'.  t  t< t' \<and> \<phi> t')"
  abbreviation tH :: "\<sigma> \<Rightarrow> \<sigma>" ("H") where "H \<phi> \<equiv> (\<lambda>t. \<forall>t'.  t' t< t  \<longrightarrow> \<phi> t')"
  abbreviation tG :: "\<sigma> \<Rightarrow> \<sigma>" ("G") where "G \<phi> \<equiv> (\<lambda>t. \<forall>t'.  t  t< t' \<longrightarrow> \<phi> t')"

  text \<open>
    The L operator as stated by Blackburn
\<close>
  abbreviation tL :: "\<sigma> \<Rightarrow> \<sigma>" ("L") where "L \<phi> \<equiv> (\<lambda>t. \<forall>t'.  \<phi> t')"

  (*<*) no_syntax "_list" :: "args \<Rightarrow> 'a list" ("[(_)]") (*>*)
  abbreviation valid :: "\<sigma> \<Rightarrow> bool" ("[_]") where "[p] \<equiv> \<forall>t. p t"

  text \<open>
    Similar to [_], we define a conversion from nominals to
    propositions by <_>.
\<close>
  abbreviation nom :: "\<eta> \<Rightarrow> \<sigma>" ("<_>") where "<i> \<equiv> \<lambda>t. i @@ t "

  lemma True nitpick [satisfy, user_axioms=true, expect = genuine] oops

  (* Lemma L1x: Irreflexivity *)
  lemma L1a:
    assumes "\<forall>i.[<i> t\<rightarrow> t\<not> (F <i>)]"
    shows "\<forall>x.\<not>(x t< x)"
  by (metis assms surjective)

  lemma L1b:
    assumes "\<forall>x.\<not>(x t< x)"
    shows "\<forall>i.[<i> t\<rightarrow> t\<not> (F <i>)]"
  by (metis assms rightUnique)

  (* Lemma L2x: Asymmetry *)
  lemma L2a:
   assumes "\<forall>i.[<i> t\<rightarrow> t\<not> (F (F <i>))]"
   shows "\<forall>x.\<forall>y. x t< y \<longrightarrow> \<not>(y t< x)"
  by (metis assms surjective)

  lemma L2b:
   assumes "\<forall>x.\<forall>y. x t< y \<longrightarrow> \<not>(y t< x)"
   shows "\<forall>i.[<i> t\<rightarrow> t\<not> (F (F <i>))]"
  by (metis assms rightUnique)

  (* Lemma L3x: Antisymmetry *)
  lemma L3a:
   assumes "\<forall>i.[<i> t\<rightarrow> G (F <i> t\<rightarrow> <i>)]"
   shows "\<forall>x.\<forall>y. (x t< y \<and> y t< x) \<longrightarrow> x = y"
  by (metis assms rightUnique surjective)

  lemma L3b:
   assumes "\<forall>x.\<forall>y. (x t< y \<and> y t< x) \<longrightarrow> x = y"
   shows "\<forall>i.[<i> t\<rightarrow> G (F <i> t\<rightarrow> <i>)]"
  by (metis assms rightUnique)

  (* Lemma L4x: Trichotomy (total relation) *)
  lemma L4a:
   assumes "\<forall>i.[(P <i>) t\<or> <i> t\<or> (F <i>)]"
   shows "\<forall>x.\<forall>y. ((x t< y) \<or> (x = y) \<or> (y t< x))"
  by (metis assms rightUnique surjective)

  lemma L4b:
   assumes "\<forall>x.\<forall>y. ((x t< y) \<or> (x = y) \<or> (y t< x))"
   shows "\<forall>i.[(P <i>) t\<or> <i> t\<or> (F <i>)]"
  by (metis assms leftTotal)

  (* Lemma L5x: right directed *)
  lemma L5a:
   assumes "\<forall>i.[F (P <i>)]"
   shows "\<forall>x.\<forall>y.\<exists>z. x t< z \<and> y t< z"
  by (metis assms rightUnique surjective)

  lemma L5b:
   assumes "\<forall>x.\<forall>y.\<exists>z. x t< z \<and> y t< z"
   shows "\<forall>i.[F (P <i>)]"
  by (metis assms leftTotal)

  (* Lemma L6x: right discrete *)
  lemma L6a:
   assumes "\<forall>i.[<i> t\<rightarrow> ((F tT) t\<rightarrow> F (H (H (t\<not> <i>))))]"
   shows "\<forall>x.\<forall>y. x t< y \<longrightarrow> (\<exists>z. x t< z \<and> \<not>(\<exists>w. x t< w \<and> w t< z))"
  by (metis assms surjective)

  lemma L6b:
   assumes "\<forall>x.\<forall>y. x t< y \<longrightarrow> (\<exists>z. x t< z \<and> \<not>(\<exists>w. x t< w \<and> w t< z))"
   shows "\<forall>i.[<i> t\<rightarrow> ((F tT) t\<rightarrow> F (H (H (t\<not> <i>))))]"
  by (metis assms rightUnique)
end