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


(* 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_assoc2
  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 (mul3 x1 x2 x3) x4 x5) = (mul3 x1 (mul3 x2 x3 x4) x5))"
  oops

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