text \<open>We specify the Paxos algorithm and prove it safe using a refinement mapping to a higher-level
specification (which we also prove safe)\<close>

theory Paxos
  imports Main "IOAutomata.Simulations" "HOL-Eisbach.Eisbach_Tools"
begin

text "The theory Simulations is part of the I/O-Automata formalization found at @{url \<open>https://github.com/nano-o/IO-Automata\<close>}"

section \<open>The Paxos I/O-Automaton\<close>

interpretation IOA .

datatype 'v paxos_action =
  Internal | Decision 'v

definition paxos_asig where
  "paxos_asig \<equiv> \<lparr> inputs = {}, outputs = {Decision v | v . True}, internals = {Internal} \<rparr>"

record ('v,'n) state =
  start_round_msg :: "nat set"
  join_ack_msg :: "('n \<times> nat \<times> nat \<times> 'v) set"
  propose_msg :: "(nat \<times> 'v) set"
  vote_msg :: "('n \<times> nat \<times> 'v) set"
  decision :: "(nat \<times> 'v) set"

locale paxos_ioa =
  fixes quorums::"'n set set"
    \<comment> \<open> We will make assumptions on quorums only in the correctness proof. \<close>
begin

definition start where
  \<comment> \<open>  The initial state  \<close>
  "start \<equiv> {\<lparr> start_round_msg = {}, join_ack_msg = {}, propose_msg = {},
    vote_msg = {}, decision = {} \<rparr>}"

definition start_round where
  "start_round r s s' \<equiv>
    r \<noteq> 0 \<and> s' = s\<lparr>start_round_msg := start_round_msg s \<union> {r}\<rparr>"

definition join_round where
  "join_round n r maxr maxv s s' \<equiv>
    r \<noteq> 0 \<and> r \<in> start_round_msg s \<and>
    (\<forall> r' \<ge> r . \<forall> r'' v . (n, r', r'', v) \<notin> join_ack_msg s) \<and>
    ((maxr = 0 \<and> (\<forall> r' v . r' < r \<longrightarrow> (n, r', v) \<notin> vote_msg s)) \<or>
        (maxr \<noteq> 0 \<and> maxr < r \<and> (n, maxr, maxv) \<in> vote_msg s
        \<and> (\<forall> r' v . r' < r \<and> (n, r', v) \<in> vote_msg s \<longrightarrow> r' \<le> maxr))) \<and>
    s' = s\<lparr>join_ack_msg := join_ack_msg s \<union> {(n, r, maxr, maxv)}\<rparr>"

definition propose where
  "propose r q v s s' \<equiv>
    r \<noteq> 0 \<and> (\<forall> v . (r, v) \<notin> propose_msg s) \<and> q \<in> quorums \<and>
    (\<forall> n \<in> q . \<exists> maxr maxv . (n, r, maxr, maxv) \<in> join_ack_msg s) \<and>
    (\<exists> n maxr maxv . (n, r, maxr, maxv) \<in> join_ack_msg s \<and>
      (\<forall> n' r maxr' maxv' . n' \<in> q \<and> (n', r, maxr', maxv') \<in> join_ack_msg s \<longrightarrow> maxr' \<le> maxr) \<and>
      (maxr = 0 \<or> v = maxv) \<and>
      s' = s\<lparr>propose_msg := propose_msg s \<union> {(r, v)}\<rparr>)"

definition vote where
  "vote n r v s s' \<equiv>
    r \<noteq> 0 \<and> (r, v) \<in> propose_msg s \<and>
    (\<forall> r' maxr maxv . r' > r \<longrightarrow> (n, r', maxr, maxv) \<notin> join_ack_msg s) \<and>
    (\<exists> maxr maxv . (n,r,maxr,maxv) \<in> join_ack_msg s) \<and>
    s' = s\<lparr>vote_msg := vote_msg s \<union> {(n, r, v)}\<rparr>"

definition decide where
  "decide r v q s s' \<equiv>
    r \<noteq> 0 \<and> q \<in> quorums \<and> (\<forall> n \<in> q . (n, r, v) \<in> vote_msg s) \<and>
    s' = s\<lparr>decision := decision s \<union> {(r, v)}\<rparr>"

fun trans_rel :: "('v, 'n) state \<Rightarrow> 'v paxos_action \<Rightarrow> ('v, 'n) state \<Rightarrow> bool" where
  "trans_rel s Internal s' = (
    (\<exists> r . start_round r s s') \<or>
    (\<exists> n r maxr maxv . join_round n r maxr maxv s s') \<or>
    (\<exists> r q v . propose r q v s s') \<or>
    (\<exists> n r v . vote n r v s s') )" |
  "trans_rel s (Decision v) s' =  (\<exists> r q . decide r v q s s')"

definition trans where
  "trans \<equiv> { (s,a,s') . trans_rel s a s'}"

definition paxos_ioa where
  "paxos_ioa \<equiv> \<lparr>ioa.asig = paxos_asig, start = start, trans = trans\<rparr>"

lemmas simps = paxos_ioa_def paxos_asig_def start_def start_round_def trans_def propose_def join_round_def
  vote_def decide_def

end

section " The Abstract Paxos I/O-automaton "

record ('v,'n) abstract_state =
  votes :: "('n \<times> nat \<times> 'v) set"
  joined_round :: "('n \<times> nat) set"
  proposal :: "(nat \<times> 'v) set"
  decision :: "(nat \<times> 'v) set"

locale abstract_paxos_ioa =
  fixes quorums::"'n set set"
begin

definition start where
  \<comment> \<open> The initial state \<close>
  "start \<equiv> {\<lparr> votes = {}, joined_round = {}, proposal = {}, decision = {} \<rparr>}"

definition vote where
  "vote n r v s s' \<equiv>
    r \<noteq> 0 \<and> (r, v) \<in> proposal s \<and> (\<forall> r' > r . (n, r') \<notin> joined_round s) \<and>
    (n, r) \<in> joined_round s \<and> s' = s\<lparr>votes := (votes s) \<union> {(n, r, v)}\<rparr>"

definition join_round where
  "join_round n r s s' \<equiv>
    (\<forall> r' \<ge> r . (n, r') \<notin> joined_round s) \<and> s' = s\<lparr>joined_round := (joined_round s) \<union> {(n, r)}\<rparr>"

definition propose where
  "propose r q v s s' \<equiv>
    r \<noteq> 0 \<and> q \<in> quorums \<and>
    (\<forall> v . (r, v) \<notin> proposal s) \<and>
    (\<forall> n \<in> q . (n, r) \<in> joined_round s) \<and>
    (\<exists> maxr maxn . maxr < r \<and>
      ((maxr = 0 \<and> (\<forall> n \<in> q . \<forall> r' < r . \<forall> v . (n, r', v) \<notin> votes s)) \<or>
        (maxr \<noteq> 0 \<and> (maxn, maxr, v) \<in> votes s \<and> (\<forall> n \<in> q . \<forall> r' < r . \<forall> v .
          (n, r', v) \<in> votes s \<longrightarrow> r' \<le> maxr)))) \<and>
      s' = s\<lparr>proposal := (proposal s) \<union> {(r,v)}\<rparr>"

definition decide where
  "decide r v s s' \<equiv>
    r \<noteq> 0 \<and> (\<exists> q \<in> quorums . \<forall> n \<in> q . (n, r, v) \<in> votes s) \<and>
    s' = s\<lparr>decision := decision s \<union> {(r, v)}\<rparr>"

fun trans_rel :: "('v, 'n) abstract_state \<Rightarrow> 'v paxos_action \<Rightarrow> ('v, 'n) abstract_state \<Rightarrow> bool" where
  "trans_rel s Internal s' = (
    (\<exists> n r . join_round n r s s') \<or>
    (\<exists> r q v . propose r q v s s') \<or>
    (\<exists> n r v . vote n r v s s'))" |
  "trans_rel s (Decision v) s' =  (\<exists> r . decide r v s s')"

definition trans where
  "trans \<equiv> { (s,a,s') . trans_rel s a s'}"

definition abstract_paxos_ioa :: "(('v, 'n) abstract_state, 'v paxos_action) ioa" where
  "abstract_paxos_ioa \<equiv> \<lparr>ioa.asig = paxos_asig, start = start, trans = trans\<rparr>"

end

section " Proof Automation setup "

text " A very simple verification-condition generator for proving invariants, that unfolds definitions and
  inserts proved invariants as premises. "

named_theorems invs named_theorems inv_defs named_theorems ioa_defs

method rm_reachable = (match premises in R[thin]:"reachable ?ioa ?s" \<Rightarrow> \<open>-\<close>)

lemma reach_and_inv_imp_p:"\<lbrakk>reachable ioa s; invariant ioa i\<rbrakk> \<Longrightarrow> i s"
  by (auto simp add:invariant_def)

method instantiate_invs declares invs =
  (match premises in I[thin]:"invariant ?ioa ?inv" and R:"reachable ?ioa ?s" \<Rightarrow> \<open>
    print_fact I, insert reach_and_inv_imp_p[OF R I]\<close>)+

method inv_vcg declares invs ioa_defs inv_defs = (
  rule invariantI,
  force simp add:ioa_defs inv_defs,
  (insert invs, instantiate_invs)?, rm_reachable, simp add:ioa_defs)

locale paxos_proof = abs:abstract_paxos_ioa quorums + paxos_ioa quorums
    for quorums :: "'n set set" +
    fixes abs_ioa  :: "(('v, 'n) abstract_state, 'v paxos_action) ioa"
      and con_ioa :: "(('v, 'n) state, 'v paxos_action) ioa"
    defines "abs_ioa \<equiv> abs.abstract_paxos_ioa" and "con_ioa \<equiv> paxos_ioa"
    assumes "\<And> q1 q2 . \<lbrakk>q1 \<in> quorums; q2 \<in> quorums\<rbrakk> \<Longrightarrow> q1 \<inter> q2 \<noteq> {}"
    and "quorums \<noteq> {}" and "\<And> q . q \<in> quorums \<Longrightarrow> finite q"
    and "finite quorums"
begin

lemma quorum_inter_witness[elim]:
  assumes "q1 \<in> quorums" and "q2 \<in> quorums"
  obtains a where "a \<in> q1" and "a \<in> q2"
  using assms paxos_proof_axioms
  by (metis disjoint_iff_not_equal paxos_proof_def)

lemmas asig_simps =  externals_def abs.abstract_paxos_ioa_def paxos_asig_def con_ioa_def abs_ioa_def paxos_ioa_def
lemmas trans_simps = con_ioa_def paxos_ioa_def start_def abs_ioa_def abs.abstract_paxos_ioa_def abs.start_def
  is_trans_def trans_def abs.trans_def
lemmas act_defs =  abs.propose_def abs.join_round_def abs.vote_def abs.decide_def
  vote_def start_round_def join_round_def decide_def propose_def

declare trans_simps[ioa_defs]

section " Proof of Abstract Paxos "

definition safety where safety_def[inv_defs]:
  "safety s \<equiv> \<forall> v v' r r' . (r,v) \<in> decision s \<and> (r',v') \<in> decision s \<longrightarrow> v = v'"

definition invariant_1 where invariant_1_def[inv_defs]:
  "invariant_1 s \<equiv> (\<forall> n r v . (n, r, v) \<in> votes s \<longrightarrow> (r, v) \<in> proposal s)
    \<and> (\<forall> r v v' . (r, v) \<in> proposal s \<and> (r, v') \<in> proposal s \<longrightarrow> v = v')"

definition choosable where
  "choosable s r v \<equiv> \<exists> q \<in> quorums . \<forall> n \<in> q .
    (\<exists> r' > r . (n, r') \<in> joined_round s) \<longrightarrow> (n, r, v) \<in> votes s"

definition invariant_2 where invariant_2_def[inv_defs]:
  "invariant_2 s \<equiv> \<forall> r r' v v' . r' < r \<and> (r, v) \<in> proposal s \<and>
    choosable s r' v' \<longrightarrow> v = v'"

definition invariant_3 where invariant_3_def[inv_defs]:
  "invariant_3 s \<equiv> \<forall> v r . (r,v) \<in> decision s \<longrightarrow> (\<exists> q \<in> quorums . \<forall> n \<in> q . (n, r, v) \<in> votes s)"

declare act_defs[simp]

lemma abs_trans_cases:
  \<comment> \<open>A case split rule for analyzing the transition relation by cases\<close>
  assumes "abs.trans_rel s a s'"
  obtains
  (abs_join_round) n r where "abs.join_round n r s s'"  and "a = Internal" |
  (abs_propose) r q v where "abs.propose r q v s s'"  and "a = Internal"|
  (abs_vote) n r v where "abs.vote n r v s s'"  and "a = Internal"|
  (abs_decide) r v where "abs.decide r v s s'" and "a = Decision v"
  by (meson abstract_paxos_ioa.trans_rel.elims(2) assms)

lemma invariant_1:
  "invariant abs_ioa invariant_1"
  apply (inv_vcg, elim abs_trans_cases)
  apply (auto simp add:inv_defs)
  done
declare invariant_1[invs]

lemma invariant_2:
  "invariant abs_ioa invariant_2"
  apply (inv_vcg)
  subgoal premises prems for s s' a using prems(2)
  proof (cases rule:abs_trans_cases)
    case (abs_join_round n r)
    have "votes s' = votes s"
      and "\<And> n r . (n, r) \<in> joined_round s \<Longrightarrow> (n,r) \<in> joined_round s'"
      and "proposal s' = proposal s" using abs_join_round by simp_all
    thus ?thesis using prems(1) apply (auto simp add:invariant_2_def choosable_def)
      by meson
  next
    case (abs_propose r q v)
    have "votes s' = votes s" and "joined_round s' = joined_round s"
      and "proposal s' = (proposal s) \<union> {(r,v)}"
      using abs_propose by auto
    moreover
    have "v' = v" if "r' < r" and "choosable s r' v'" for v' r'
    proof -
      have q_joined:"\<forall> n \<in> q . (n,r) \<in> joined_round s" and "q \<in> quorums" using abs_propose
        by simp_all
      obtain rmax n where "q \<in> quorums" and "rmax < r"
        "(rmax = 0 \<and> (\<forall> n \<in> q . \<forall> r' < r . \<forall> v . (n, r', v) \<notin> votes s))
         \<or> (rmax \<noteq> 0 \<and> (n, rmax, v) \<in> votes s
            \<and> (\<forall> n' \<in> q . \<forall> r' < r . \<forall> v . (n', r', v) \<in> votes s \<longrightarrow> r' \<le> rmax))"
        using abs_propose by auto
      with this consider
        (no_votes) "rmax = 0" and "\<forall> n \<in> q . \<forall> r' < r . \<forall> v . (n, r', v) \<notin> votes s" |
        (votes) "rmax \<noteq> 0" and "(n, rmax, v) \<in> votes s"
          and "\<forall> n' \<in> q . \<forall> r' < r .  \<forall> v . (n', r', v) \<in> votes s \<longrightarrow> r' \<le> rmax" by auto
      thus ?thesis
      proof (cases)
        case no_votes
        hence False using q_joined that \<open>q \<in> quorums\<close> apply (auto simp add:choosable_def)
          by (meson quorum_inter_witness)
        thus ?thesis by auto
      next
        case votes
        from `choosable s r' v'` obtain n' where "(n', r', v') \<in> votes s"
          using \<open>q \<in> quorums\<close> \<open>r' < r\<close> q_joined by (force simp add:choosable_def)
        consider (a) "r' < rmax" | (b) "r' = rmax" | (c) "r' > rmax"
          using nat_neq_iff by blast
        then show ?thesis
        proof (cases)
          case a
          with prems(1,3) votes(2) that(2) `rmax < r` show ?thesis
            by (auto simp add:invariant_2_def invariant_1_def, blast)
        next
          case b
          from `choosable s r' v'` obtain n' where "( n', r', v') \<in> votes s"
            using \<open>q \<in> quorums\<close> \<open>r' < r\<close> q_joined by (force simp add:choosable_def)
          with prems(3) votes(2) b show ?thesis by (force simp add:invariant_1_def split:option.splits)
        next
          case c
          hence "\<forall> v . (n, r', v) \<notin> votes s" if "n \<in> q" for n
            using votes(3) that `r' < r` by force
          with \<open>choosable s r' v'\<close> \<open>q \<in> quorums\<close> q_joined `r' < r` have False by (force simp add:choosable_def)
          thus ?thesis by auto
        qed
      qed
    qed
    ultimately show ?thesis using prems(1) apply (auto simp add:invariant_2_def choosable_def)
      by (blast, meson)
  next
    case (abs_vote n r v)
    have "joined_round s' = joined_round s" and "proposal s' = proposal s"
      and "\<And> n r v . (n, r, v) \<in> votes s' \<and> (n, r, v) \<notin> votes s \<longrightarrow>
        ((n, r) \<in> joined_round s \<and> (\<forall> r' > r . (n, r') \<notin> joined_round s))" using abs_vote by auto
    thus ?thesis using prems(1) prems(2) apply (auto simp add:invariant_2_def invariant_1_def choosable_def)
        by meson
  next
    case (abs_decide r v)
    then show ?thesis using prems(1) by (auto simp add:invariant_2_def choosable_def)
  qed
  done
declare invariant_2[invs]

lemma invariant_3:
  "invariant abs_ioa invariant_3"
  apply (inv_vcg, elim abs_trans_cases)
     apply (simp_all add:inv_defs)
  apply metis
  done
declare invariant_3[invs]

theorem safety:
  "invariant abs_ioa safety"
proof -
  have "safety s" if "invariant_3 s" and "invariant_2 s" and "invariant_1 s" for s using that
    apply (auto simp add:inv_defs choosable_def)
    by (metis not_less_iff_gr_or_eq quorum_inter_witness)
  thus ?thesis
    using IOA.invariant_def invariant_1 invariant_2 invariant_3 by blast
qed

declare invariant_1[invs del] invariant_2[invs del] invariant_3[invs del]

section " Proof of Paxos by refinement to abstract paxos. "

definition invariant_4 where invariant_4_def[inv_defs]:
  "invariant_4 s \<equiv> \<forall> n r maxr maxv . (n, r, maxr, maxv) \<in> join_ack_msg s \<and> maxr \<noteq> 0
    \<longrightarrow> (maxr < r \<and> (n, maxr, maxv) \<in> vote_msg s \<and> (\<forall> r' < r . \<forall> v . (n, r', v) \<in> vote_msg s \<longrightarrow> r' \<le> maxr))"

definition invariant_5 where invariant_5_def[inv_defs]:
  "invariant_5 s \<equiv> \<forall> n r maxr maxv . (n, r, maxr, maxv) \<in> join_ack_msg s \<and> maxr = 0
    \<longrightarrow> (\<forall> r' v . r' < r \<longrightarrow> (n, r', v) \<notin> vote_msg s)"

lemma trans_cases:
  \<comment> \<open>A case split rule for analyzing the transition relation by cases\<close>
  assumes "trans_rel s a s'"
  obtains
  (start_round) r where "start_round r s s'" and "a = Internal" |
  (join_round) n r maxr maxv where "join_round n r maxr maxv s s'" and "a = Internal" |
  (propose) r q v where "propose r q v s s'"  and "a = Internal"|
  (vote) n r v where "vote n r v s s'"  and "a = Internal"|
  (decide) r v q where "decide r v q s s'" and "a = Decision v"
  by (meson assms trans_rel.elims(2))

lemma invariant_4:
  "invariant con_ioa invariant_4"
  apply (inv_vcg, elim trans_cases)
      apply (force simp add:inv_defs)
     apply (simp add:inv_defs) apply blast
    apply (simp add:inv_defs) apply force
   apply (simp add:inv_defs) apply blast
  apply (simp add:inv_defs)
  done
declare invariant_4[invs]

lemma invariant_5:
  "invariant con_ioa invariant_5"
  apply (inv_vcg, elim trans_cases)
      apply (force simp add:inv_defs) defer
     apply (simp add:inv_defs)
     apply (metis state.select_convs(2) state.select_convs(4) state.surjective state.update_convs(3))
    apply (force simp add:inv_defs)
   apply (force simp add:inv_defs)
  apply (simp add:inv_defs) apply blast
  done
declare invariant_5[invs]

declare act_defs[simp del]

definition ref_map where
  "ref_map s \<equiv> \<lparr>votes = vote_msg s, joined_round = {(n,r) . \<exists> r' v . (n,r,r',v) \<in> join_ack_msg s},
    proposal = propose_msg s, decision = state.decision s\<rparr>"

lemmas ref_proof_simps = ref_map_def asig_simps trans_simps trace_def schedule_def filter_act_def

lemma refinement:
  shows "is_ref_map ref_map con_ioa abs_ioa"
  apply (auto simp add:is_ref_map_def)
   apply (simp add:ref_map_def ioa_defs)
  apply (insert invs)
  apply (instantiate_invs)
  apply (simp add:trans_simps refines_def trace_match_def)
  subgoal premises prems for s t a using prems(2)
  proof (cases rule:trans_cases)
    case (start_round r)
    then show ?thesis
      apply (intro exI[where x="[]"])
      apply (auto simp add:ref_proof_simps start_round_def)
      done
  next
    case (join_round n r maxr maxv)
    let ?s' = "ref_map s"
    let ?t' = "(ref_map s)\<lparr>joined_round := joined_round (ref_map s) \<union> {(n,r)}\<rparr>"
    have "abs.join_round n r ?s' ?t'" using join_round(1)
      by (auto simp add:join_round_def abs.join_round_def ref_map_def)
    moreover
    have "ref_map t = ?t'" using join_round(1) by (auto simp add:join_round_def ref_map_def)
    ultimately show ?thesis using join_round(2)
      apply (intro exI[where x="[(Internal, ?t')]"])
      apply (auto simp add:ref_proof_simps)
      done
  next
    case (propose r q v)
    let ?s' = "ref_map s"
    let ?t' = "(ref_map s)\<lparr>proposal := proposal (ref_map s) \<union> {(r,v)}\<rparr>"
    have "abs.propose r q v ?s' ?t'"
    proof -
      obtain n maxr maxv where con_pre:"r \<noteq> 0 \<and> (\<forall> v . (r, v) \<notin> propose_msg s) \<and> q \<in> quorums \<and>
          (\<forall> n' \<in> q . \<exists> maxr maxv . (n',r,maxr,maxv) \<in> join_ack_msg s)
          \<and> (n, r, maxr, maxv) \<in> join_ack_msg s \<and>
          (\<forall> n' r maxr' maxv' . n' \<in> q \<and> (n', r, maxr', maxv') \<in> join_ack_msg s \<longrightarrow> maxr' \<le> maxr) \<and>
          (maxr = 0 \<or> v = maxv)" using propose(1) by (auto simp add:propose_def)
      have "r \<noteq> 0 \<and> q \<in> quorums \<and> (\<forall> v . (r, v) \<notin> proposal ?s') \<and>
        (\<forall> n \<in> q . (n, r) \<in> joined_round ?s')" using con_pre by (auto simp add:ref_map_def)
      moreover have
        "maxr < r \<and> ((maxr = 0 \<and> (\<forall> n \<in> q . \<forall> r' < r . \<forall> v . (n, r', v) \<notin> votes ?s')) \<or>
          (maxr \<noteq> 0 \<and> (n, maxr, v) \<in> votes ?s' \<and> (\<forall> n \<in> q . \<forall> r' < r . \<forall> v .
            (n, r', v) \<in> votes ?s' \<longrightarrow> r' \<le> maxr)))"
      proof -
        show ?thesis
        proof (cases "maxr = 0")
          case True
          hence "\<forall> n \<in> q . \<forall> r' < r . \<forall> v . (n, r', v) \<notin> votes ?s'" and "r>0" using prems(4) con_pre
            apply (simp_all add:ref_map_def invariant_5_def) by blast
          thus ?thesis using True by auto
        next
          case False
          then show ?thesis using prems(3,4) con_pre
            apply (auto simp add:ref_map_def invariant_5_def invariant_4_def)
            by (smt (verit) bot_nat_0.extremum_strict dual_order.trans linorder_neqE)
        qed
      qed
      moreover have "?t' = ?s'\<lparr>proposal := (proposal ?s') \<union> {(r,v)}\<rparr>"
        by (auto simp add:ref_map_def)
      ultimately  show ?thesis by (auto simp add:abs.propose_def)
    qed
    moreover
    have "ref_map t = ?t'" using propose(1) by (auto simp add:propose_def ref_map_def)
    ultimately show ?thesis using propose(2)
      apply (intro exI[where x="[(Internal, ?t')]"])
      apply (auto simp add: ref_proof_simps)
      done
  next
    case (vote n r v)
    let ?s' = "ref_map s"
    let ?t' = "(ref_map s)\<lparr>votes := votes (ref_map s) \<union> {(n,r,v)}\<rparr>"
    have "abs.vote n r v ?s' ?t'"
    proof -
      from vote(1) have "r \<noteq> 0 \<and> (r, v) \<in> proposal ?s' \<and> (\<forall> r' > r . (n, r') \<notin> joined_round ?s') \<and>
      (n, r) \<in> joined_round ?s'"
        by (auto simp add:vote_def ref_map_def)
      moreover
      from vote(1) have "?t' = ?s'\<lparr>votes := (votes ?s') \<union> {(n, r, v)}\<rparr>"
        by (auto simp add:vote_def ref_map_def)
      ultimately show ?thesis by (auto simp add:abs.vote_def)
    qed
    moreover have "ref_map t = ?t'" using vote(1) by (auto simp add:vote_def ref_map_def)
    ultimately show ?thesis using vote(2)
      apply (intro exI[where x="[(Internal,
        (ref_map s)\<lparr>votes := votes (ref_map s) \<union> {(n,r,v)}\<rparr>)]"])
      apply (auto simp add:ref_proof_simps)
      done
  next
    case (decide r v q)
    then show ?thesis
      apply (intro exI[where x="[(Decision v,
        (ref_map s)\<lparr>decision := decision (ref_map s) \<union> {(r,v)}\<rparr>)]"])
      apply (auto simp add:ref_proof_simps act_defs)
      done
  qed
  done

theorem trace_inclusion:
  "traces con_ioa \<subseteq> traces abs_ioa"
proof -
  have "externals (ioa.asig con_ioa) = externals (ioa.asig abs_ioa)"
    by (simp add:asig_simps)
  thus ?thesis using refinement ref_map_soundness
    by blast
qed

end

end


(*  Title:
    Author:
    Maintainer:
*)

section \<open> Examples \<close>

text \<open> We prove partial correctness specifications of some hybrid systems with our
verification components.\<close>

theory Real_Arith_Solutions
  imports "HOL-Analysis.Analysis"

begin

subsection \<open> Basic \<close>

lemma abs_le_eq:
  shows "(r::real) > 0 \<Longrightarrow> (\<bar>x\<bar> < r) = (-r < x \<and> x < r)"
    and "(r::real) > 0 \<Longrightarrow> (\<bar>x\<bar> \<le> r) = (-r \<le> x \<and> x \<le> r)"
  by linarith+

lemma is_interval_real_nonneg[simp]: "is_interval (Collect ((\<le>) (0::real)))"
  by (auto simp: is_interval_def)

lemma norm_rotate_eq[simp]:
  fixes x :: "'a:: {banach,real_normed_field}"
  shows "(x * cos t - y * sin t)\<^sup>2 + (x * sin t + y * cos t)\<^sup>2 = x\<^sup>2 + y\<^sup>2"
    and "(x * cos t + y * sin t)\<^sup>2 + (y * cos t - x * sin t)\<^sup>2 = x\<^sup>2 + y\<^sup>2"
proof-
  have "(x * cos t - y * sin t)\<^sup>2 = x\<^sup>2 * (cos t)\<^sup>2 + y\<^sup>2 * (sin t)\<^sup>2 - 2 * (x * cos t) * (y * sin t)"
    by(simp add: power2_diff power_mult_distrib)
  also have "(x * sin t + y * cos t)\<^sup>2 = y\<^sup>2 * (cos t)\<^sup>2 + x\<^sup>2 * (sin t)\<^sup>2 + 2 * (x * cos t) * (y * sin t)"
    by(simp add: power2_sum power_mult_distrib)
  ultimately show "(x * cos t - y * sin t)\<^sup>2 + (x * sin t + y * cos t)\<^sup>2 = x\<^sup>2 + y\<^sup>2"
    by (simp add: Groups.mult_ac(2) Groups.mult_ac(3) right_diff_distrib sin_squared_eq)
  thus "(x * cos t + y * sin t)\<^sup>2 + (y * cos t - x * sin t)\<^sup>2 = x\<^sup>2 + y\<^sup>2"
    by (simp add: add.commute add.left_commute power2_diff power2_sum)
qed

lemma mult_abs_right_mono: "a < b \<Longrightarrow> a * \<bar>c\<bar> \<le> b * \<bar>c\<bar>" for c::real
  by (simp add: mult_right_mono)

lemma dyn_cons_qty_arith: "(36::real) * (x1\<^sup>2 * (x1 * x2 ^ 3)) -
  (- (24 * (x1\<^sup>2 * x2) * x1 ^ 3 * (x2)\<^sup>2) - 12 * (x1\<^sup>2 * x2) * x1 * x2 ^ 4) -
  36 * (x1\<^sup>2 * (x2 * x1)) * (x2)\<^sup>2 - 12 * (x1\<^sup>2 * (x1 * x2 ^ 5)) = 24 * (x1 ^ 5 * x2 ^ 3)"
  (is "?t1 - (- ?t2 - ?t3) - ?t4 - ?t5 = ?t6")
proof-
  have eq1: "?t1 = ?t4"
    by (simp add: power2_eq_square power3_eq_cube)
  have eq2: "- (- ?t2 - ?t3) = (?t6 + ?t3)"
    by (auto simp: field_simps semiring_normalization_rules(27))
  have eq3: "?t3 = ?t5"
    by (auto simp: field_simps semiring_normalization_rules(27))
  show "?t1 - (- ?t2 - ?t3) - ?t4 - ?t5 = ?t6"
    unfolding eq1 eq2 eq3 by (simp add: field_simps semiring_normalization_rules(27))
qed

lemma local_lipschitz_first_order_linear:
  fixes c::"real \<Rightarrow> real"
  assumes "continuous_on T c"
  shows "local_lipschitz T UNIV (\<lambda>t. (*) (c t))"
proof(unfold local_lipschitz_def lipschitz_on_def, clarsimp simp: dist_norm)
  fix x t::real assume "t \<in> T"
  then obtain \<delta> where d_hyp: "\<delta> > 0 \<and> (\<forall>\<tau>\<in>T. \<bar>\<tau> - t\<bar> < \<delta> \<longrightarrow> \<bar>c \<tau> - c t\<bar> < max 1 \<bar>c t\<bar>)"
    using assms unfolding continuous_on_iff
    apply(erule_tac x=t in ballE, erule_tac x="max 1 (\<bar>c t\<bar>)" in allE; clarsimp)
    by (metis dist_norm less_max_iff_disj real_norm_def zero_less_one)
  {fix \<tau> x\<^sub>1 x\<^sub>2
    assume "\<tau> \<in> cball t (\<delta>/2) \<inter> T" "x\<^sub>1 \<in> cball x (\<delta>/2)" "x\<^sub>2 \<in> cball x (\<delta>/2)"
    hence "\<bar>\<tau> - t\<bar> < \<delta>" "\<tau> \<in> T"
      by (auto simp: dist_norm, smt d_hyp)
    hence "\<bar>c \<tau> - c t\<bar> < max 1 \<bar>c t\<bar>"
      using d_hyp by auto
    hence "- (max 1 \<bar>c t\<bar> + \<bar>c t\<bar>) < c \<tau> \<and> c \<tau> < max 1 \<bar>c t\<bar> + \<bar>c t\<bar>"
      by (auto simp: abs_le_eq)
    hence obs: "\<bar>c \<tau>\<bar> < max 1 \<bar>c t\<bar> + \<bar>c t\<bar>"
      by (simp add: abs_le_eq)
    have "\<bar>c \<tau> * x\<^sub>1 - c \<tau> * x\<^sub>2\<bar> = \<bar>c \<tau>\<bar> * \<bar>x\<^sub>1 - x\<^sub>2\<bar>"
      by (metis abs_mult left_diff_distrib mult.commute)
    also have "... \<le> (max 1 \<bar>c t\<bar> + \<bar>c t\<bar>) * \<bar>x\<^sub>1 - x\<^sub>2\<bar>"
      using mult_abs_right_mono[OF obs] by blast
    finally have "\<bar>c \<tau> * x\<^sub>1 - c \<tau> * x\<^sub>2\<bar> \<le> (max 1 \<bar>c t\<bar> + \<bar>c t\<bar>) * \<bar>x\<^sub>1 - x\<^sub>2\<bar>" .}
  hence "\<exists>L. \<forall>t\<in>cball t (\<delta>/2) \<inter> T. 0 \<le> L \<and>
    (\<forall>x\<^sub>1\<in>cball x (\<delta>/2). \<forall>x\<^sub>2\<in>cball x (\<delta>/2). \<bar>c t * x\<^sub>1 - c t * x\<^sub>2\<bar> \<le> L * \<bar>x\<^sub>1 - x\<^sub>2\<bar>)"
    by (rule_tac x="max 1 \<bar>c t\<bar> + \<bar>c t\<bar>" in exI, clarsimp simp: dist_norm)
  thus "\<exists>u>0. \<exists>L. \<forall>t\<in>cball t u \<inter> T. 0 \<le> L \<and>
    (\<forall>xa\<in>cball x u. \<forall>y\<in>cball x u. \<bar>c t * xa - c t * y\<bar> \<le> L * \<bar>xa - y\<bar>)"
    apply(rule_tac x="\<delta>/2" in exI)
    using d_hyp by auto
qed

lemma darboux_ineq_arith:
  assumes "0 \<le> s\<^sub>1 + s\<^sub>2" and "0 \<le> (t::real)" and "t * s\<^sub>1 < 1"
  shows "0 \<le> s\<^sub>1 / (1 - t * s\<^sub>1) + (s\<^sub>2 - s\<^sub>1 * ln (1 - t * s\<^sub>1)) / (1 - t * s\<^sub>1)"
proof-
  have "s\<^sub>1 * ln (1 - t * s\<^sub>1) \<le> 0"
  proof(cases "s\<^sub>1 \<le> 0")
    case True
    hence "1 - t * s\<^sub>1 \<ge> 1"
      using \<open>0 \<le> t\<close> by (simp add: mult_le_0_iff)
    thus ?thesis
      using True ln_ge_zero mult_nonneg_nonpos2 by blast
  next
    case False
    hence "1 - t * s\<^sub>1 \<le> 1"
      using \<open>0 \<le> t\<close> by auto
    thus ?thesis
      by (metis (mono_tags, hide_lams) False add.left_neutral antisym_conv assms(3)
          diff_le_eq ln_ge_zero_iff ln_one mult_zero_right not_le order_refl zero_le_mult_iff)
  qed
  hence "s\<^sub>1 + s\<^sub>2 - s\<^sub>1 * ln (1 - t * s\<^sub>1) \<ge> s\<^sub>1 + s\<^sub>2"
    by linarith
  hence "(s\<^sub>1 + s\<^sub>2 - s\<^sub>1 * ln (1 - t * s\<^sub>1))/(1 - t * s\<^sub>1) \<ge> (s\<^sub>1 + s\<^sub>2)/(1 - t * s\<^sub>1)"
    using \<open>t * s\<^sub>1 < 1\<close> by (simp add: \<open>0 \<le> s\<^sub>1 + s\<^sub>2\<close> divide_right_mono)
  also have "(s\<^sub>1 + s\<^sub>2)/(1 - t * s\<^sub>1) \<ge> 0"
    using \<open>t * s\<^sub>1 < 1\<close> by (simp add: \<open>0 \<le> s\<^sub>1 + s\<^sub>2\<close>)
  ultimately show ?thesis
    by (metis (full_types) add_diff_eq add_divide_distrib order_trans)
qed

lemma picard_lindeloef_dyn_bif: "continuous_on T g \<Longrightarrow> t\<^sub>0 \<in> T \<Longrightarrow> is_interval T \<Longrightarrow>
  open T \<Longrightarrow> (t::real) \<in> T \<Longrightarrow> \<exists>u>0. (\<exists>ta. \<bar>t - ta\<bar> \<le> u \<and> ta \<in> T) \<longrightarrow>
  (\<exists>L\<ge>0. \<forall>xa\<in>cball (x::real) u. \<forall>y\<in>cball x u. \<bar>xa\<^sup>2 - y\<^sup>2\<bar> \<le> L * \<bar>xa - y\<bar>)"
proof-
  {fix x1 and x2
    assume "x1 \<in>cball x 1" and "x2 \<in>cball x 1"
    hence leq: "\<bar>x - x1\<bar> \<le> 1" "\<bar>x - x2\<bar> \<le> 1"
      by (auto simp: dist_norm)
    have "\<bar>x1 + x2\<bar> = \<bar>x1 - x + x2 - x + 2 * x\<bar>"
      by simp
    also have "... \<le> \<bar>x1 - x\<bar> + \<bar>x2 - x\<bar> + 2 * \<bar>x\<bar>"
      using abs_triangle_ineq by auto
    also have "... \<le> 2 * (1 + \<bar>x\<bar>)"
      using leq by auto
    finally have obs: "\<bar>x1 + x2\<bar> \<le> 2 * (1 + \<bar>x\<bar>)" .
    also have "\<bar>x1\<^sup>2 - x2\<^sup>2\<bar> = \<bar>x1 + x2\<bar>*\<bar>x1 - x2\<bar>"
      by (metis abs_mult power2_eq_square square_diff_square_factored)
    ultimately have "\<bar>x1\<^sup>2 - x2\<^sup>2\<bar> \<le> (2 * (1 + \<bar>x\<bar>)) * \<bar>x1 - x2\<bar>"
      by (metis abs_ge_zero mult_right_mono)}
  thus "\<exists>u>0. (\<exists>\<tau>. \<bar>t - \<tau>\<bar> \<le> u \<and> \<tau> \<in> T) \<longrightarrow>
  (\<exists>L\<ge>0. \<forall>xa\<in>cball x u. \<forall>y\<in>cball x u. \<bar>xa\<^sup>2 - y\<^sup>2\<bar> \<le> L * \<bar>xa - y\<bar>)"
    by (rule_tac x=1 in exI, clarsimp, rule_tac x="2 * (1 + \<bar>x\<bar>)" in exI, auto)
qed

lemma STTexample3a_arith:
  assumes "0 < (B::real)" "0 \<le> t" "0 \<le> x2" and key: "x1 + x2\<^sup>2 / (2 * B) \<le> S"
  shows "x2 * t - B * t\<^sup>2 / 2 + x1 + (x2 - B * t)\<^sup>2 / (2 * B) \<le> S" (is "?lhs \<le> S")
proof-
  have "?lhs = 2 * B * x2 * t/(2*B) - B^2 * t\<^sup>2 / (2*B) + (2 * B * x1)/(2*B) + (x2 - B * t)\<^sup>2 / (2 * B)"
    using \<open>0 < B\<close> by (auto simp: power2_eq_square)
  also have "(x2 - B * t)\<^sup>2 / (2 * B) = x2^2/(2*B) + B^2 * t^2/(2*B) - 2*x2*B*t/(2*B)"
    using \<open>0 < B\<close> by (auto simp: power2_diff field_simps)
  ultimately have "?lhs = x1 + x2\<^sup>2 / (2 * B)"
    using \<open>0 < B\<close> by auto
  thus "?lhs \<le> S"
    using key by simp
qed

lemma STTexample5_arith:
  assumes "0 < A" "0 < B" "0 < \<epsilon>" "0 \<le> x2" "0 \<le> (t::real)"
    and key: "x1 + x2\<^sup>2 / (2 * B) + (A * (A * \<epsilon>\<^sup>2 / 2 + \<epsilon> * x2) / B + (A * \<epsilon>\<^sup>2 / 2 + \<epsilon> * x2)) \<le> S" (is "?k3 \<le> S")
    and ghyp: "\<forall>\<tau>. 0 \<le> \<tau> \<and> \<tau> \<le> t \<longrightarrow> \<tau> \<le> \<epsilon>"
  shows "A * t\<^sup>2 / 2 + x2 * t + x1 + (A * t + x2)\<^sup>2 / (2 * B) \<le> S" (is "?k0 \<le> S")
proof-
  have "t \<le> \<epsilon>"
    using ghyp \<open>0 \<le> t\<close> by auto
  hence "A*t^2/2 + t*x2 \<le> A*\<epsilon>^2/2 + \<epsilon>*x2"
    using \<open>0 \<le> t\<close> \<open>0 < A\<close> \<open>0 \<le> x2\<close>
    by (smt (verit, ccfv_SIG) divide_right_mono mult_less_cancel_left mult_right_mono power_less_imp_less_base)
  hence "((A + B)/B) * (A*t^2/2 + t*x2) + x1 + x2\<^sup>2 / (2 * B) \<le>
    x1 + x2\<^sup>2 / (2 * B) + ((A + B)/B) * (A*\<epsilon>^2/2 + \<epsilon>*x2)" (is "?k1 \<le> ?k2")
    using \<open>0 < B\<close> \<open>0 < A\<close> by (smt (verit, ccfv_SIG) divide_pos_pos mult_less_cancel_left)
  moreover have "?k0 = ?k1"
    using \<open>0 < B\<close> \<open>0 < A\<close> by (auto simp: field_simps power2_sum power2_eq_square)
  moreover have "?k2 = ?k3"
    using \<open>0 < B\<close> \<open>0 < A\<close> by (auto simp: field_simps power2_sum power2_eq_square)
  ultimately show "?k0 \<le> S"
    using key by linarith
qed

lemma STTexample6_arith:
  assumes "0 < A" "0 < B" "0 < \<epsilon>" "0 \<le> x2" "0 \<le> (t::real)" "- B \<le> k" "k \<le> A"
    and key: "x1 + x2\<^sup>2 / (2 * B) + (A * (A * \<epsilon>\<^sup>2 / 2 + \<epsilon> * x2) / B + (A * \<epsilon>\<^sup>2 / 2 + \<epsilon> * x2)) \<le> S" (is "?k3 \<le> S")
    and ghyp: "\<forall>\<tau>. 0 \<le> \<tau> \<and> \<tau> \<le> t \<longrightarrow> 0 \<le> k * \<tau> + x2 \<and> \<tau> \<le> \<epsilon>"
  shows "k * t\<^sup>2 / 2 + x2 * t + x1 + (k * t + x2)\<^sup>2 / (2 * B) \<le> S" (is "?k0 \<le> S")
proof-
  have "0 \<le> k * t + x2 + x2"
    using ghyp \<open>0 \<le> x2\<close> \<open>0 \<le> t\<close> by force
  hence "0 \<le> (k * t + 2 * x2) * t/2"
    by (metis assms(5) divide_nonneg_pos is_num_normalize(1) mult_2 mult_sign_intros(1) rel_simps(51))
  hence f1: "0 \<le> k*t^2/2 + t*x2"
    by (auto simp: field_simps power2_eq_square)
  have f2: "0 \<le> (k + B) / B" "(k + B) / B \<le> (A + B) / B"
    using \<open>0 < A\<close> \<open>0 < B\<close> \<open>- B \<le> k\<close> \<open>k \<le> A\<close> divide_le_cancel by (auto, fastforce)
  have "t \<le> \<epsilon>"
    using ghyp \<open>0 \<le> t\<close> by auto
  hence "k*t^2/2 + t*x2 \<le> A*t^2/2 + t*x2"
    using \<open>k \<le> A\<close> by (auto simp: mult_right_mono)
  also have f3: "... \<le> A*\<epsilon>^2/2 + \<epsilon>*x2"
    using \<open>0 \<le> t\<close> \<open>0 < A\<close> \<open>0 \<le> x2\<close> \<open>t \<le> \<epsilon>\<close>
    by (smt field_sum_of_halves mult_right_mono power_less_imp_less_base mult_less_cancel_left)
  finally have "k*t^2/2 + t*x2 \<le> A*\<epsilon>^2/2 + \<epsilon>*x2" .
  hence "((k + B)/B) * (k*t^2/2 + t*x2) \<le> ((A + B)/B) * (A*\<epsilon>^2/2 + \<epsilon>*x2)"
    using f1 f2 \<open>k \<le> A\<close> apply(rule_tac b="((A + B)/B) * (A*t^2/2 + t*x2)" in order.trans)
     apply (rule mult_mono', simp, simp, simp add: mult_right_mono, simp, simp)
    by (metis f3 add_sign_intros(4) assms(1,2) less_eq_real_def mult_zero_left
        mult_less_cancel_left zero_compare_simps(5))
  hence "((k + B)/B) * (k*t^2/2 + t*x2) + x1 + x2\<^sup>2 / (2 * B) \<le>
    x1 + x2\<^sup>2 / (2 * B) + ((A + B)/B) * (A*\<epsilon>^2/2 + \<epsilon>*x2)" (is "?k1 \<le> ?k2")
    using \<open>0 < B\<close> \<open>0 < A\<close> by (smt mult_less_cancel_left zero_compare_simps(9))
  moreover have "?k0 = ?k1"
    using \<open>0 < B\<close> \<open>0 < A\<close> by (auto simp: field_simps power2_sum power2_eq_square)
  moreover have "?k2 = ?k3"
    using \<open>0 < B\<close> \<open>0 < A\<close> by (auto simp: field_simps power2_sum power2_eq_square)
  ultimately show "?k0 \<le> S"
    using key by linarith
qed

lemma STTexample7_arith1:
  assumes "(0::real) < A" "0 < b" "0 < \<epsilon>" "0 \<le> v" "0 \<le> t" "k \<le> A"
    and "x + v\<^sup>2 / (2 * b) + (A * (A * \<epsilon>\<^sup>2 / 2 + \<epsilon> * v) / b + (A * \<epsilon>\<^sup>2 / 2 + \<epsilon> * v)) \<le> S" (is "?expr1 \<le> S")
    and guard: "\<forall>\<tau>. 0 \<le> \<tau> \<and> \<tau> \<le> t \<longrightarrow> 0 \<le> k * \<tau> + v \<and> \<tau> \<le> \<epsilon>"
  shows "k * t\<^sup>2 / 2 + v * t + x + (k * t + v)\<^sup>2 / (2 * b) \<le> S" (is "?lhs \<le> S")
proof-
  have obs1: "?lhs*(2*b) = k*t\<^sup>2*b + 2 * v * t*b + 2*x*b + (k*t+v)\<^sup>2" (is "_ = ?expr2 k t")
    using \<open>0 < b\<close> by (simp add: field_simps)
  have "?expr2 A \<epsilon> = ?expr1*(2*b)"
    using \<open>0 < b\<close> by (simp add: field_simps power2_eq_square)
  also have "... \<le> S*(2*b)"
    using \<open>?expr1 \<le> S\<close> \<open>0 < b\<close> by force
  finally have obs2: "?expr2 A \<epsilon> \<le> S*(2*b)" .
  have "t \<le> \<epsilon>"
    using guard \<open>0 \<le> t\<close> by auto
  hence "t\<^sup>2 \<le> \<epsilon>\<^sup>2" "k * t + v \<le> A * \<epsilon> + v"
    using \<open>k \<le> A\<close> \<open>0 < A\<close> power_mono[OF \<open>t \<le> \<epsilon>\<close> \<open>0 \<le> t\<close>, of 2]
    by auto (meson \<open>0 \<le> t\<close> less_eq_real_def mult_mono)
  hence "k * t\<^sup>2 * b \<le> A * \<epsilon>\<^sup>2 * b" "2 * v * t * b \<le> 2 * v * \<epsilon> * b"
    using \<open>t \<le> \<epsilon>\<close> \<open>0 < b\<close> \<open>k \<le> A\<close> \<open>0 \<le> v\<close>
    by (auto simp: mult_left_mono) (meson \<open>0 < A\<close> less_eq_real_def mult_mono zero_compare_simps(12))
  hence "?expr2 k t \<le> ?expr2 A \<epsilon>"
    by (smt \<open>k * t + v \<le> A * \<epsilon> + v\<close> ends_in_segment(2) \<open>0 \<le> t\<close> guard power_mono)
  hence "?lhs*(2*b) \<le> S*(2*b)"
    using obs1 obs2 by simp
  thus "?lhs \<le> S"
    using \<open>0 < b\<close> by force
qed

lemma STTexample7_arith2:
  assumes "(0::real) < b" "0 \<le> v" "0 \<le> t" "k \<le> - b"
    and key: "x + v\<^sup>2 / (2 * b) \<le> S"
    and guard: "\<forall>\<tau>. 0 \<le> \<tau> \<and> \<tau> \<le> t \<longrightarrow> 0 \<le> k * \<tau> + v \<and> \<tau> \<le> \<epsilon>"
  shows "k * t\<^sup>2 / 2 + v * t + x + (k * t + v)\<^sup>2 / (2 * b) \<le> S" (is "?lhs \<le> S")
proof-
  have obs: "1 + k/b \<le> 0" "k * t + v \<ge> 0"
    using \<open>k \<le> - b\<close> \<open>0 < b\<close> guard \<open>0 \<le> t\<close> by (auto simp: mult_imp_div_pos_le real_add_le_0_iff)
  have "?lhs = (k * t + v + v)*t/2 * (1 + k/b) + x + v\<^sup>2 / (2 * b)"
    using \<open>0 < b\<close> by (auto simp: field_simps power2_eq_square)
  also have "... \<le> x + v\<^sup>2 / (2 * b)"
    using obs \<open>0 \<le> t\<close> \<open>0 \<le> v\<close>
    by (smt mult_nonneg_nonneg zero_compare_simps(11) zero_compare_simps(6))
  also have "... \<le> S"
    using key .
  finally show ?thesis .
qed

lemma STTexample9a_arith:
  "(10*x-10*r) * v/4 + v\<^sup>2/2 + (x-r)*(2*r-2*x-3 * v)/2 + v * (2*r-2*x-3 * v)/2 \<le> (0::real)"
  (is "?t1 + ?t2 + ?t3 + ?t4 \<le> 0")
proof-
  have "?t1 = 5 * (x-r) * v/2"
    by auto
  moreover have "?t3 = -((x - r)^2) - 3 * v * (x-r)/2"
    by (auto simp: field_simps power2_diff power2_eq_square)
  moreover have "?t4 = - 2 * (x - r) * v/2 - 3 * v^2/2"
    by (auto simp: field_simps power2_diff power2_eq_square)
  ultimately have "?t1 + ?t3 + ?t4 = -((x - r)^2) - 3 * v^2/2"
    by (auto simp: field_simps)
  hence "?t1 + ?t2 + ?t3 + ?t4 = -((x - r)^2) - v^2"
    by auto
  also have "... \<le> 0"
    by auto
  finally show ?thesis .
qed

lemma LICSexample4a_arith:
  assumes "(0::real) \<le> A" "0 < b" "v\<^sup>2 \<le> 2 * b * (m - x)" "0 \<le> t"
      and guard: "\<forall>\<tau>. 0 \<le> \<tau> \<and> \<tau> \<le> t \<longrightarrow> 0 \<le> A * \<tau> + v \<and> \<tau> \<le> \<epsilon>"
      and key: "v\<^sup>2 + (A * (A * \<epsilon>\<^sup>2 + 2 * \<epsilon> * v) + b * (A * \<epsilon>\<^sup>2 + 2 * \<epsilon> * v)) \<le> 2 * b * (m - x)" (is "?expr1 \<le> _")
    shows "(A * t + v)\<^sup>2 \<le> 2 * b * (m - (A * t\<^sup>2 / 2 + v * t + x))"
proof-
  have "t \<le> \<epsilon>" "0 \<le> v"
    using guard \<open>0 \<le> t\<close> by (force, erule_tac x=0 in allE, auto)
  hence "A * t\<^sup>2 + 2 * t * v \<le> A * \<epsilon>\<^sup>2 + 2 * \<epsilon> * v"
    using \<open>0 \<le> A\<close> \<open>0 \<le> t\<close>
    by (smt mult_less_cancel_left_disj mult_right_mono power_less_imp_less_base)
  hence "v\<^sup>2 + (A + b) * (A * t\<^sup>2 + 2 * t * v) \<le> v\<^sup>2 + (A + b) * (A * \<epsilon>\<^sup>2 + 2 * \<epsilon> * v)"
    using \<open>0 \<le> A\<close> \<open>0 < b\<close> by (smt mult_left_mono)
  also have "... = ?expr1"
    by (auto simp: field_simps)
  finally have "v\<^sup>2 + (A + b) * (A * t\<^sup>2 + 2 * t * v) \<le> 2 * b * (m - x)"
    using key by auto
  thus ?thesis
    by (auto simp: field_simps power2_eq_square)
qed

lemma LICSexample4c_arith1:
  assumes "v\<^sup>2 \<le> 2 * b * (m - x)" "0 \<le> t" "A \<ge> 0" "b > 0"
    and key: "v\<^sup>2 + (A * (A * \<epsilon>\<^sup>2 + 2 * \<epsilon> * v) + b * (A * \<epsilon>\<^sup>2 + 2 * \<epsilon> * v)) \<le> 2 * b * (m - x)"
    and guard: "\<forall>\<tau>. 0 \<le> \<tau> \<and> \<tau> \<le> t \<longrightarrow> (0::real) \<le> A * \<tau> + v \<and> \<tau> \<le> \<epsilon>"
  shows "(A * t + v)\<^sup>2 \<le> 2 * b * (m - (A * t\<^sup>2 / 2 + v * t + x))" (is "_ \<le> ?rhs")
proof-
  have "t \<le> \<epsilon>" "0 \<le> \<epsilon>" "0 \<le> v"
    using guard \<open>0 \<le> t\<close> by (force, erule_tac x=0 in allE, simp, erule_tac x=0 in allE, simp)
  hence obs1: "A * t\<^sup>2 + 2 * t * v \<le> A * \<epsilon>\<^sup>2 + 2 * \<epsilon> * v"
    using \<open>A \<ge> 0\<close> \<open>0 \<le> t\<close> \<open>t \<le> \<epsilon>\<close> by (smt mult_mono power_mono zero_compare_simps(12))
  have obs2:"?rhs + A * b * t^2 + 2 * b * v * t = 2 * b * (m - x)"
    by (simp add: field_simps)
  have "(A * t + v)\<^sup>2 + A * b * t^2 + 2 * b * v * t = v\<^sup>2 + (A * (A * t\<^sup>2 + 2 * t * v) + b * (A * t\<^sup>2 + 2 * t * v))"
    by (simp add: field_simps power2_eq_square)
  also have "... \<le> v\<^sup>2 + (A * (A * \<epsilon>\<^sup>2 + 2 * \<epsilon> * v) + b * (A * \<epsilon>\<^sup>2 + 2 * \<epsilon> * v))"
    using obs1 \<open>A \<ge> 0\<close> \<open>b > 0\<close> by (smt mult_less_cancel_left)
  also have "... \<le> 2 * b * (m - x)"
    using key .
  finally show ?thesis
    using obs2 by auto
qed

lemma LICSexample5_arith1:
  assumes "(0::real) < b" "0 \<le> t"
    and key: "v\<^sup>2 \<le> 2 * b * (m - x)"
  shows "v * t - b * t\<^sup>2 / 2 + x \<le> m"
proof-
  have "v\<^sup>2 \<le> 2 * b * (m - x) + (b * t - v)^2"
    using key by (simp add: add_increasing2)
  hence "b^2 * t^2 - 2 * b * v * t \<ge> 2 * b * x - 2 * b * m"
    by (auto simp: field_simps power2_diff)
  hence "(b^2/b) * t^2 - 2 * (b/b) * v * t \<ge> 2 * (b/b) * x - 2 * (b/b) * m"
    using \<open>b > 0\<close> by (auto simp: field_simps)
  thus ?thesis
    using \<open>b > 0\<close> by (simp add: power2_eq_square)
qed

lemma LICSexample5_arith2:
  assumes "(0::real) < b" "0 \<le> v" "\<forall>t\<in>{0..}. v * t - b * t\<^sup>2 / 2 + x \<le> m"
  shows "v\<^sup>2 \<le> 2 * b * (m - x)"
proof(cases "v = 0")
  case True
  have "m - x \<ge> 0"
    using assms by (erule_tac x=0 in ballE, auto)
  thus ?thesis
    using assms True by auto
next
  case False
  hence obs: "v > 0 \<and> (\<exists>k. k > 0 \<and> v = b * k)"
    using assms(1,2) by (metis (no_types, hide_lams) divide_pos_pos divide_self_if
        less_eq_real_def linorder_not_le mult_1_right mult_1s(1) times_divide_eq_left)
  {fix t::real assume "t \<ge> 0"
    hence "v * t - b * t\<^sup>2 / 2 + x \<le> m"
      using assms by auto
    hence "2 * b * v * t - b * b * t\<^sup>2 + 2 * b * x \<le> 2 * b * m"
      using \<open>b > 0\<close> by (simp add: field_simps) (metis distrib_left mult_le_cancel_left_pos)
    hence "- b\<^sup>2 * t\<^sup>2 + 2 * b * v * t \<le> 2 * b * m - 2 * b * x"
      using \<open>b > 0\<close> by (simp add: power2_eq_square)
    hence "v^2 \<le> 2 * b * (m - x) + (b^2 * t^2 + v^2 - 2 * b * v * t)"
      by (simp add: field_simps)
    also have "... = 2 * b * (m - x) + (b * t - v)^2"
      by (simp add: power2_diff power_mult_distrib)
    finally have "v^2 \<le> 2 * b * (m - x) + (b * t - v)^2" .}
  hence "\<forall>t\<ge>0. v\<^sup>2 \<le> 2 * b * (m - x) + (b * t - v)\<^sup>2"
    by blast
  then obtain k where "v\<^sup>2 \<le> 2 * b * (m - x) + (b * k - v)\<^sup>2 \<and> k > 0 \<and> v = b * k"
    using obs by fastforce
  then show ?thesis
    by auto
qed

lemma LICSexample6_arith1:
  assumes "0 \<le> v" "0 < b" "0 \<le> A" "0 \<le> \<epsilon>" and guard: "\<forall>t\<in>{0..}. (\<forall>\<tau>. 0 \<le> \<tau> \<and> \<tau> \<le> t \<longrightarrow> \<tau> \<le> \<epsilon>) \<longrightarrow> (\<forall>\<tau>\<in>{0..}.
  A * t * \<tau> + v * \<tau> - b * \<tau>\<^sup>2 / 2 + (A * t\<^sup>2 / 2 + v * t + x) \<le> (m::real))"
  shows "v\<^sup>2 + (A * (A * \<epsilon>\<^sup>2 + 2 * \<epsilon> * v) + b * (A * \<epsilon>\<^sup>2 + 2 * \<epsilon> * v)) \<le> 2 * b * (m - x)"
proof-
  {fix \<tau>::real
    assume "\<tau> \<ge> 0"
    hence "A * \<epsilon> * \<tau> + v * \<tau> - b * \<tau>\<^sup>2 / 2 + (A * \<epsilon>\<^sup>2 / 2 + v * \<epsilon> + x) \<le> m"
      using guard \<open>0 \<le> \<epsilon>\<close> apply(erule_tac x=\<epsilon> in ballE)
      by (erule impE, auto simp: closed_segment_eq_real_ivl)
    hence "2 * (A * \<epsilon> * \<tau> + v * \<tau> - b * \<tau>\<^sup>2 / 2 + (A * \<epsilon>\<^sup>2 / 2 + v * \<epsilon> + x)) * b \<le> 2 * m * b"
      using \<open>0 < b\<close> by (meson less_eq_real_def mult_left_mono mult_right_mono rel_simps(51))
    hence "2 * A * \<epsilon> * \<tau> * b + 2 * v * \<tau> * b - b^2 * \<tau>\<^sup>2 + b * (A * \<epsilon>\<^sup>2 + 2 * v * \<epsilon>) \<le> 2 * b * (m - x)"
      using \<open>0 < b\<close> apply(simp add: algebra_simps(17,18,19,20) add.assoc[symmetric]
          power2_eq_square[symmetric] mult.assoc[symmetric])
      by (simp add: mult.commute mult.left_commute power2_eq_square)}
  hence "\<forall>\<tau>\<ge>0. 2 * A * \<epsilon> * \<tau> * b + 2 * v * \<tau> * b - b^2 * \<tau>\<^sup>2 + b * (A * \<epsilon>\<^sup>2 + 2 * v * \<epsilon>) \<le> 2 * b * (m - x)"
    by blast
  moreover have "2 * A * \<epsilon> * ((A*\<epsilon> + v)/b) * b + 2 * v * ((A*\<epsilon> + v)/b) * b - b^2 * ((A*\<epsilon> + v)/b)\<^sup>2 =
    2 * A * \<epsilon> * (A*\<epsilon> + v) + 2 * v * (A*\<epsilon> + v) - (A*\<epsilon> + v)\<^sup>2"
    using \<open>0 < b\<close> by (simp add: field_simps)
  moreover have "... = v\<^sup>2 + A * (A * \<epsilon>\<^sup>2 + 2 * \<epsilon> * v)"
    using \<open>0 < b\<close> by (simp add: field_simps power2_eq_square)
  moreover have "(A*\<epsilon> + v)/b \<ge> 0"
    using assms by auto
  ultimately have "v\<^sup>2 + A * (A * \<epsilon>\<^sup>2 + 2 * \<epsilon> * v) + b * (A * \<epsilon>\<^sup>2 + 2 * v * \<epsilon>) \<le> 2 * b * (m - x)"
    using assms by (erule_tac x="(A*\<epsilon> + v)/b" in allE, auto)
  thus ?thesis
    by argo
qed

lemma ETCS_arith1:
  assumes "0 < b" "0 \<le> A" "0 \<le> v" "0 \<le> t"
    and "v\<^sup>2 / (2 * b) + (A * (A * \<epsilon>\<^sup>2 / 2 + \<epsilon> * v)/ b + (A * \<epsilon>\<^sup>2 / 2 + \<epsilon> * v)) \<le> m - x" (is "?expr1 \<le> m - x")
    and guard: "\<forall>\<tau>. 0 \<le> \<tau> \<and> \<tau> \<le> t \<longrightarrow> \<tau> \<le> \<epsilon>"
  shows "(A * t + v)\<^sup>2/(2 * b) \<le> (m::real) - (A * t\<^sup>2/2 + v * t + x)" (is "?lhs \<le> ?rhs")
proof-
  have "2*b*(v\<^sup>2/(2*b) + (A*(A*\<epsilon>\<^sup>2/2+\<epsilon>* v)/b + (A*\<epsilon>\<^sup>2/2+\<epsilon>* v))) \<le> 2*b*(m-x)" (is "?expr2 \<le> 2*b*(m-x)")
    using \<open>0 < b\<close> mult_left_mono[OF \<open>?expr1 \<le> m - x\<close>, of "2 * b"] by auto
  also have "?expr2 = v\<^sup>2 +  2 * A * (A * \<epsilon>\<^sup>2 / 2 + \<epsilon> * v) + b * A * \<epsilon>\<^sup>2 + 2 * b * \<epsilon> * v"
    using \<open>0 < b\<close> by (auto simp: field_simps)
  also have "... = v\<^sup>2 +  A^2 * \<epsilon>\<^sup>2 + 2 * A * \<epsilon> * v + b * A * \<epsilon>\<^sup>2 + 2 * b * \<epsilon> * v"
    by (auto simp: field_simps power2_eq_square)
  finally have obs: "v\<^sup>2 +  A\<^sup>2*\<epsilon>\<^sup>2 + 2*A*\<epsilon>* v + b*A*\<epsilon>\<^sup>2 + 2*b*\<epsilon>* v \<le> 2*b*(m-x)" (is "?expr3 \<epsilon> \<le> 2*b*(m-x)") .
  have "t \<le> \<epsilon>"
    using guard \<open>0 \<le> t\<close> by auto
  hence "v\<^sup>2 + A\<^sup>2 * t\<^sup>2 + b * A * t\<^sup>2 \<le> v\<^sup>2 + A\<^sup>2 * \<epsilon>\<^sup>2 + b * A * \<epsilon>\<^sup>2"
    using power_mono[OF \<open>t \<le> \<epsilon>\<close> \<open>0 \<le> t\<close>, of 2]
    by (smt assms(1,2) mult_less_cancel_left zero_compare_simps(4) zero_le_power)
  hence "v\<^sup>2 + A\<^sup>2 * t\<^sup>2 + 2 * A * t * v + b * A * t\<^sup>2 \<le> v\<^sup>2 + A\<^sup>2 * \<epsilon>\<^sup>2 + 2 * A * \<epsilon> * v + b * A * \<epsilon>\<^sup>2"
    using assms(1,2,3,4) \<open>t \<le> \<epsilon>\<close> by (smt mult_left_mono mult_right_mono)
  hence "?expr3 t \<le> 2 * b * (m - x)"
    using assms(1,2,3,4) \<open>t \<le> \<epsilon>\<close> obs
    by (smt (z3) mult_less_cancel_left mult_minus_right mult_right_mono_neg)
  hence "A\<^sup>2 * t\<^sup>2 + v\<^sup>2 + 2 * A * t * v \<le> 2 * b * m - b * A * t\<^sup>2 - 2 * b * t * v - 2 * b * x"
    by (simp add: right_diff_distrib)
  hence "(A * t + v)\<^sup>2 \<le> 2 * b * m - b * A * t\<^sup>2 - 2 * b * t * v - 2 * b * x"
    unfolding cross3_simps(29)[of A t 2] power2_sum[of "A*t" v] by (simp add: mult.assoc)
  hence "?lhs \<le> (2 * b * m - b * A * t\<^sup>2 - 2 * b * t * v - 2 * b * x)/(2 * b)" (is "_ \<le> ?expr4")
    using \<open>0 < b\<close> divide_right_mono by fastforce
  also have "?expr4 = ?rhs"
    using \<open>0 < b\<close> by (auto simp: field_simps)
  finally show "?lhs \<le> ?rhs" .
qed

lemma ETCS_Prop1_arith2:
  assumes "0 \<le> v" "0 \<le> \<delta>" "0 < b" "x \<le> m" "0 \<le> (t::real)"
      and key: "v\<^sup>2 - \<delta>\<^sup>2 \<le> 2 * b * (m - x)" "m \<le> v * t - b * t\<^sup>2 / 2 + x"
      and guard: "\<forall>\<tau>\<in>{0--t}. b * \<tau> \<le> v"
    shows "v - b * t \<le> \<delta>"
proof-
  have "2 * b * (m - x) \<le> 2 * b * (v * t - b * t\<^sup>2 / 2) - v\<^sup>2 + v\<^sup>2"
    using key(2) \<open>0 < b\<close> by simp
  also have "... = v\<^sup>2 - (v - b * t)\<^sup>2"
    using \<open>0 < b\<close> by (simp add: power2_diff field_simps power2_eq_square)
  finally have "(v - b * t)\<^sup>2 \<le> \<delta>\<^sup>2"
    using key(1) by simp
  thus "v - b * t \<le> \<delta>"
    using guard \<open>0 \<le> t\<close> \<open>0 \<le> \<delta>\<close> by auto
qed

subsection \<open> Advanced \<close>

lemma has_vderiv_mono_test:
  assumes T_hyp: "is_interval T"
    and d_hyp: "D f = f' on T"
    and xy_hyp: "x\<in>T" "y\<in>T" "x \<le> y"
  shows "\<forall>x\<in>T. (0::real) \<le> f' x \<Longrightarrow> f x \<le> f y"
    and "\<forall>x\<in>T. f' x \<le> 0 \<Longrightarrow> f x \<ge> f y"
proof-
  have "{x..y} \<subseteq> T"
    using T_hyp xy_hyp by (meson atLeastAtMost_iff mem_is_interval_1_I subsetI)
  hence "D f = f' on {x..y}"
    using has_vderiv_on_subset[OF d_hyp(1)] by blast
  hence "(\<And>t. x \<le> t \<Longrightarrow> t \<le> y \<Longrightarrow> D f \<mapsto> (\<lambda>\<tau>. \<tau> *\<^sub>R f' t) at t within {x..y})"
    unfolding has_vderiv_on_def has_vector_derivative_def by auto
  then obtain c where c_hyp: "c \<in> {x..y} \<and> f y - f x = (y - x) *\<^sub>R f' c"
    using mvt_very_simple[OF xy_hyp(3), of f "(\<lambda>t \<tau>. \<tau> *\<^sub>R f' t)"] by blast
  hence mvt_hyp: "f x = f y - f' c * (y - x)"
    by (simp add: mult.commute)
  also have "\<forall>x\<in>T. 0 \<le> f' x \<Longrightarrow> ... \<le> f y"
    using xy_hyp d_hyp c_hyp \<open>{x..y} \<subseteq> T\<close> by auto
  finally show "\<forall>x\<in>T. 0 \<le> f' x \<Longrightarrow> f x \<le> f y" .
  have "\<forall>x\<in>T. f' x \<le> 0 \<Longrightarrow> f y - f' c * (y - x) \<ge> f y"
    using xy_hyp d_hyp c_hyp \<open>{x..y} \<subseteq> T\<close> by (auto simp: mult_le_0_iff)
  thus "\<forall>x\<in>T. f' x \<le> 0 \<Longrightarrow> f x \<ge> f y"
    using mvt_hyp by auto
qed

lemma continuous_on_ge_ball_ge:
  "continuous_on T f \<Longrightarrow> x \<in> T \<Longrightarrow> f x > (k::real) \<Longrightarrow> \<exists>\<epsilon>>0. \<forall>y\<in>ball x \<epsilon> \<inter> T. f y > k"
  unfolding continuous_on_iff apply(erule_tac x=x in ballE; clarsimp?)
  apply(erule_tac x="f x - k" in allE, clarsimp simp: dist_norm)
  apply(rename_tac \<delta>, rule_tac x=\<delta> in exI, clarsimp)
  apply(erule_tac x=y in ballE; clarsimp?)
  by (subst (asm) abs_le_eq, simp_all add: dist_commute)

lemma current_vderiv_ge_always_ge:
  fixes c::real
  assumes init: "c < x t\<^sub>0" and ode: "D x = x' on {t\<^sub>0..}"
    and dhyp: "x' = (\<lambda>t. g (x t))" "\<forall>x\<ge>c. g x \<ge> 0"
  shows "\<forall>t\<ge>t\<^sub>0. x t > c"
proof-
  have cont: "continuous_on {t\<^sub>0..} x"
    using vderiv_on_continuous_on[OF ode] .
  {assume "\<exists>t\<ge>t\<^sub>0. x t \<le> c"
    hence inf: "{t. t > t\<^sub>0 \<and> x t \<le> c} \<noteq> {}" "bdd_below {t. t > t\<^sub>0 \<and> x t \<le> c}"
      using init less_eq_real_def unfolding bdd_below_def by force (rule_tac x=t\<^sub>0 in exI, simp)
    define t\<^sub>1 where t1_hyp: "t\<^sub>1 = Inf {t. t > t\<^sub>0 \<and> x t \<le> c}"
    hence "t\<^sub>0 \<le> t\<^sub>1"
      using le_cInf_iff[OF inf, of t\<^sub>0] by auto
    have "x t\<^sub>1 \<ge> c"
    proof-
      {assume "x t\<^sub>1 < c"
        hence obs: "x t\<^sub>1 \<le> c" "x t\<^sub>0 \<ge> c" "t\<^sub>1 \<noteq> t\<^sub>0"
          using init by auto
        hence "t\<^sub>1 > t\<^sub>0"
          using \<open>t\<^sub>0 \<le> t\<^sub>1\<close> by auto
        then obtain k where k2_hyp: "k \<ge> t\<^sub>0 \<and> k \<le> t\<^sub>1 \<and> x k = c"
          using IVT2'[of "\<lambda>t. x t", OF obs(1,2) _ continuous_on_subset[OF cont]] by auto
        hence "t\<^sub>0 < k" "k < t\<^sub>1"
          using \<open>x t\<^sub>1 < c\<close> less_eq_real_def init by auto
        also have "t\<^sub>1 \<le> k"
          using cInf_lower[OF _ inf(2)] k2_hyp calculation unfolding t1_hyp by auto
        ultimately have False
          by simp}
      thus "x t\<^sub>1 \<ge> c"
        by fastforce
    qed
    hence obs: "\<forall>t\<in>{t\<^sub>0..<t\<^sub>1}. x t > c"
    proof-
      {assume "\<exists>t\<in>{t\<^sub>0..<t\<^sub>1}. x t \<le> c"
        then obtain k where k2_hyp: "k \<ge> t\<^sub>0 \<and> k < t\<^sub>1 \<and> x k \<le> c"
          by auto
        hence "k > t\<^sub>0"
          using \<open>x t\<^sub>0 > c\<close> less_eq_real_def by auto
        hence "t\<^sub>1 \<le> k"
          using cInf_lower[OF _ inf(2)] k2_hyp unfolding t1_hyp by auto
        hence "False"
          using k2_hyp by auto}
      thus "\<forall>t\<in>{t\<^sub>0..<t\<^sub>1}. x t > c"
        by force
    qed
    hence "\<forall>t\<in>{t\<^sub>0..t\<^sub>1}. x' t \<ge> 0"
      using \<open>x t\<^sub>1 \<ge> c\<close> dhyp(2) less_eq_real_def
      unfolding dhyp by (metis atLeastAtMost_iff atLeastLessThan_iff)
    hence "x t\<^sub>0 \<le> x t\<^sub>1"
      apply(rule_tac f="\<lambda>t. x t" and T="{t\<^sub>0..t\<^sub>1}" in has_vderiv_mono_test(1); clarsimp)
      using has_vderiv_on_subset[OF ode] apply force
      using \<open>t\<^sub>0  \<le> t\<^sub>1\<close>  by (auto simp: less_eq_real_def)
    hence "c < x t\<^sub>1"
      using \<open>x t\<^sub>1 \<ge> c\<close> init by auto
    then obtain \<epsilon> where eps_hyp: "\<epsilon> > 0 \<and> (\<forall>t\<in>ball t\<^sub>1 \<epsilon> \<inter> {t\<^sub>0..}. c < x t)"
      using continuous_on_ge_ball_ge[of _ "\<lambda>t. x t", OF cont _ \<open>c < x t\<^sub>1\<close>] \<open>t\<^sub>0  \<le> t\<^sub>1\<close> by auto
    hence "\<forall>t\<in>{t\<^sub>0..<t\<^sub>1+\<epsilon>}. c < x t"
      using obs \<open>t\<^sub>0 \<le> t\<^sub>1\<close> ball_eq_greaterThanLessThan by auto
    hence "\<forall>t\<in>{t. t > t\<^sub>0 \<and> x t \<le> c}. t\<^sub>1+\<epsilon> \<le> t"
      by (metis (mono_tags, lifting) atLeastLessThan_iff less_eq_real_def mem_Collect_eq not_le)
    hence "t\<^sub>1+\<epsilon> \<le> t\<^sub>1"
      using le_cInf_iff[OF inf] unfolding t1_hyp by simp
    hence False
      using eps_hyp by auto}
  thus "\<forall>t\<ge>t\<^sub>0. c < x t"
    by fastforce
qed

lemma LICSexample6_arith2:
  assumes "0 \<le> v" "0 < b" "0 \<le> A" "0 \<le> t" "0 \<le> \<tau>" "t \<le> \<epsilon>"
    and "v\<^sup>2 + (A * (A * \<epsilon>\<^sup>2 + 2 * \<epsilon> * v) + b * (A * \<epsilon>\<^sup>2 + 2 * \<epsilon> * v)) \<le> 2 * b * (m - x)"
  shows "A * \<epsilon> * \<tau> + s $ 2 * \<tau> - b * \<tau>\<^sup>2 / 2 + (A * \<epsilon>\<^sup>2 / 2 + s $ 2 * \<epsilon> + s $ 1) \<le> m"
  (* Need to show that function (\<lambda>\<tau>. A * \<epsilon> * \<tau> + s $ 2 * \<tau> - b * \<tau>\<^sup>2 / 2) attains maximum at \<tau> = (A*\<epsilon> + v)/b *)
  oops

lemma ETCS_Prop1_arith1:
  assumes "0 \<le> v" "0 \<le> \<delta>" "0 < b" "x \<le> m"
    and "\<forall>t\<in>{0..}. (\<forall>\<tau>\<in>{0--t}. b * \<tau> \<le> v) \<longrightarrow>
       m \<le> v * t - b * t\<^sup>2 / 2 + x \<longrightarrow> v - b * t \<le> \<delta>"
  shows "v\<^sup>2 - \<delta>\<^sup>2 \<le> 2 * b * (m - x)"
    (* solve arithmetic *)
  sorry

end


(*  Title:       Safe OCL
    Author:      Denis Nikiforov, March 2019
    Maintainer:  Denis Nikiforov <denis.nikif at gmail.com>
    License:     LGPL
*)
(* TODO: There are a lot of similar lemmas in the theory.
         They should be generalized *)
section \<open>Tuples\<close>
theory Tuple
  imports Finite_Map_Ext Transitive_Closure_Ext
begin

subsection \<open>Definitions\<close>

abbreviation "subtuple f xm ym \<equiv> fmrel_on_fset (fmdom ym) f xm ym"

abbreviation "strict_subtuple f xm ym \<equiv> subtuple f xm ym \<and> xm \<noteq> ym"

(*** Helper Lemmas **********************************************************)

subsection \<open>Helper Lemmas\<close>

lemma fmrel_to_subtuple:
  "fmrel R xm ym \<Longrightarrow> subtuple R xm ym"
  unfolding fmrel_on_fset_fmrel_restrict by blast

lemma subtuple_eq_fmrel_fmrestrict_fset:
  "subtuple R xm ym = fmrel R (fmrestrict_fset (fmdom ym) xm) ym"
  by (simp add: fmrel_on_fset_fmrel_restrict)

lemma subtuple_fmdom:
  "subtuple R xm ym \<Longrightarrow>
   subtuple S ym xm \<Longrightarrow>
   fmdom xm = fmdom ym"
  by (meson fmrel_on_fset_fmdom fset_eqI)

(*** Basic Properties *******************************************************)

subsection \<open>Basic Properties\<close>

lemma subtuple_refl [intro!]:
  "reflp R \<Longrightarrow> subtuple R xm xm"
  by (simp add: fmrel_on_fsetI option.rel_reflp reflpD)

lemma not_subtuple_elim [elim!]:
  "\<not> subtuple R xm xm \<Longrightarrow> (\<not> reflp R \<Longrightarrow> P) \<Longrightarrow> P"
  using subtuple_refl by auto

lemma subtuple_mono [mono]:
  "(\<And>x y. x \<in> fmran' xm \<Longrightarrow> y \<in> fmran' ym \<Longrightarrow> R x y \<longrightarrow> S x y) \<Longrightarrow>
   subtuple R xm ym \<longrightarrow> subtuple S xm ym"
  apply (auto)
  apply (rule fmrel_on_fsetI)
  apply (drule_tac ?P="R" and ?m="xm" and ?n="ym" in fmrel_on_fsetD, simp)
  apply (erule option.rel_cases, simp)
  by (auto simp add: option.rel_sel fmran'I)

lemma strict_subtuple_mono [mono]:
  "(\<And>x y. x \<in> fmran' xm \<Longrightarrow> y \<in> fmran' ym \<Longrightarrow> R x y \<longrightarrow> S x y) \<Longrightarrow>
   strict_subtuple R xm ym \<longrightarrow> strict_subtuple S xm ym"
  using subtuple_mono by blast

lemma subtuple_antisym:
  assumes "subtuple (\<lambda>x y. R x y \<or> x = y) xm ym"
  assumes "subtuple (\<lambda>x y. R x y \<and> \<not> R y x \<or> x = y) ym xm"
  shows "xm = ym"
proof (rule fmap_ext)
  fix x
  from assms have "fmdom xm = fmdom ym"
    using subtuple_fmdom by blast
  with assms have "fmrel (\<lambda>x y. R x y \<or> x = y) xm ym"
      and "fmrel (\<lambda>x y. R x y \<and> \<not> R y x \<or> x = y) ym xm"
    by (metis (mono_tags, lifting) fmrel_code fmrel_on_fset_alt_def)+
  thus "fmlookup xm x = fmlookup ym x"
    apply (erule_tac ?x="x" in fmrel_cases)
    by (erule_tac ?x="x" in fmrel_cases, auto)+
qed

lemma strict_subtuple_antisym:
  "strict_subtuple (\<lambda>x y. R x y \<or> x = y) xm ym \<Longrightarrow>
   strict_subtuple (\<lambda>x y. R x y \<and> \<not> R y x \<or> x = y) ym xm \<Longrightarrow> False"
  by (auto simp add: subtuple_antisym)

lemma subtuple_acyclic:
  assumes "acyclicP_on (fmran' xm) R"
  assumes "subtuple (\<lambda>x y. R x y \<or> x = y)\<^sup>+\<^sup>+ xm ym"
  assumes "subtuple (\<lambda>x y. R x y \<or> x = y) ym xm"
  shows "xm = ym"
proof (rule fmap_ext)
  fix x
  from assms have fmdom_eq: "fmdom xm = fmdom ym"
    using subtuple_fmdom by blast
  have "\<And>x a b. acyclicP_on (fmran' xm) R \<Longrightarrow>
     fmlookup xm x = Some a \<Longrightarrow>
     fmlookup ym x = Some b \<Longrightarrow>
    R\<^sup>*\<^sup>* a b \<Longrightarrow> R b a \<or> a = b \<Longrightarrow> a = b"
    by (meson Nitpick.tranclp_unfold fmran'I rtranclp_into_tranclp1)
  moreover from fmdom_eq assms(2) have "fmrel R\<^sup>*\<^sup>* xm ym"
    unfolding fmrel_on_fset_fmrel_restrict apply simp
    by (metis fmrestrict_fset_dom)
  moreover from fmdom_eq assms(3) have "fmrel (\<lambda>x y. R x y \<or> x = y) ym xm"
    unfolding fmrel_on_fset_fmrel_restrict apply simp
    by (metis fmrestrict_fset_dom)
  ultimately show "fmlookup xm x = fmlookup ym x"
    apply (erule_tac ?x="x" in fmrel_cases)
    apply (erule_tac ?x="x" in fmrel_cases, simp_all)+
    using assms(1) by blast
qed

lemma subtuple_acyclic':
  assumes "acyclicP_on (fmran' ym) R"
  assumes "subtuple (\<lambda>x y. R x y \<or> x = y)\<^sup>+\<^sup>+ xm ym"
  assumes "subtuple (\<lambda>x y. R x y \<or> x = y) ym xm"
  shows "xm = ym"
proof (rule fmap_ext)
  fix x
  from assms have fmdom_eq: "fmdom xm = fmdom ym"
    using subtuple_fmdom by blast
  have "\<And>x a b. acyclicP_on (fmran' ym) R \<Longrightarrow>
     fmlookup xm x = Some a \<Longrightarrow>
     fmlookup ym x = Some b \<Longrightarrow>
    R\<^sup>*\<^sup>* a b \<Longrightarrow> R b a \<or> a = b \<Longrightarrow> a = b"
    by (meson Nitpick.tranclp_unfold fmran'I rtranclp_into_tranclp2)
  moreover from fmdom_eq assms(2) have "fmrel R\<^sup>*\<^sup>* xm ym"
    unfolding fmrel_on_fset_fmrel_restrict apply simp
    by (metis fmrestrict_fset_dom)
  moreover from fmdom_eq assms(3) have "fmrel (\<lambda>x y. R x y \<or> x = y) ym xm"
    unfolding fmrel_on_fset_fmrel_restrict apply simp
    by (metis fmrestrict_fset_dom)
  ultimately show "fmlookup xm x = fmlookup ym x"
    apply (erule_tac ?x="x" in fmrel_cases)
    apply (erule_tac ?x="x" in fmrel_cases, simp_all)+
    using assms(1) by blast
qed

lemma subtuple_acyclic'':
  "acyclicP_on (fmran' ym) R \<Longrightarrow>
   subtuple R\<^sup>*\<^sup>* xm ym \<Longrightarrow>
   subtuple R ym xm \<Longrightarrow>
   xm = ym"
  by (metis (no_types, lifting) subtuple_acyclic' subtuple_mono tranclp_eq_rtranclp)

lemma strict_subtuple_trans [trans]:
  assumes "strict_subtuple (\<lambda>x y. R x y \<or> x = y)\<^sup>+\<^sup>+ xm ym"
      and "strict_subtuple (\<lambda>x y. R x y \<or> x = y) ym zm"
      and "acyclicP_on (fmran' xm) R"
    shows "strict_subtuple (\<lambda>x y. R x y \<or> x = y)\<^sup>+\<^sup>+ xm zm"
proof -
  from assms(1) have
    "subtuple R\<^sup>*\<^sup>* xm ym" by simp
  also from assms(2) have
    "subtuple (\<lambda>x y. R x y \<or> x = y) ym zm" by simp
  finally have
    "subtuple R\<^sup>*\<^sup>* xm zm" by (metis rtranclp.simps)
  moreover from assms(2) have
    "acyclicP_on (fmran' zm) R \<Longrightarrow> subtuple R\<^sup>*\<^sup>* zm ym \<Longrightarrow> ym = zm"
    by (drule_tac ?ym="ym" in subtuple_acyclic; auto)
  ultimately show ?thesis using assms by auto
qed

lemma strict_subtuple_trans' [trans]:
  assumes "strict_subtuple (\<lambda>x y. R x y \<or> x = y) xm ym"
      and "strict_subtuple (\<lambda>x y. R x y \<or> x = y)\<^sup>+\<^sup>+ ym zm"
      and "acyclicP_on (fmran' zm) R"
    shows "strict_subtuple (\<lambda>x y. R x y \<or> x = y)\<^sup>+\<^sup>+ xm zm"
proof -
  from assms(1) have
    "subtuple (\<lambda>x y. R x y \<or> x = y) xm ym" by simp
  also from assms(2) have
    "subtuple R\<^sup>*\<^sup>* ym zm" by simp
  finally have
    "subtuple R\<^sup>*\<^sup>* xm zm"
    by (metis converse_rtranclp_into_rtranclp)
  moreover from assms(2) have
    "acyclicP_on (fmran' zm) R \<Longrightarrow>
     subtuple (\<lambda>x y. R x y \<or> x = y) zm ym \<Longrightarrow> ym = zm"
    by (drule_tac ?ym="zm" in subtuple_acyclic'; auto)
  ultimately show ?thesis using assms by auto
qed

lemma strict_subtuple_trans'' [trans]:
  assumes "strict_subtuple R xm ym"
      and "strict_subtuple R\<^sup>*\<^sup>* ym zm"
      and "acyclicP_on (fmran' zm) R"
    shows "strict_subtuple R\<^sup>*\<^sup>* xm zm"
proof -
  from assms(1) have
    "subtuple R xm ym" by simp
  also from assms(2) have
    "subtuple R\<^sup>*\<^sup>* ym zm" by simp
  finally have
    "subtuple R\<^sup>*\<^sup>* xm zm" by simp
  moreover from assms(2) have
    "acyclicP_on (fmran' zm) R \<Longrightarrow> subtuple R zm ym \<Longrightarrow> ym = zm"
    using subtuple_acyclic'' by auto
  ultimately show ?thesis using assms by auto
qed

lemma strict_subtuple_trans''' [trans]:
  assumes "strict_subtuple (\<lambda>x y. R x y \<or> x = y) xm ym"
      and "strict_subtuple (\<lambda>x y. R x y \<or> x = y)\<^sup>*\<^sup>* ym zm"
      and "acyclicP_on (fmran' zm) R"
    shows "strict_subtuple (\<lambda>x y. R x y \<or> x = y)\<^sup>*\<^sup>* xm zm"
proof -
  from assms(1) have
    "subtuple (\<lambda>x y. R x y \<or> x = y) xm ym" by simp
  also from assms(2) have
    "subtuple R\<^sup>*\<^sup>* ym zm" by simp
  finally have
    "subtuple R\<^sup>*\<^sup>* xm zm" by (metis converse_rtranclp_into_rtranclp)
  moreover from assms(2) have
    "acyclicP_on (fmran' zm) R \<Longrightarrow>
     subtuple (\<lambda>x y. R x y \<or> x = y) zm ym \<Longrightarrow> ym = zm"
    by (drule_tac ?xm="ym" in subtuple_acyclic'; auto)
  ultimately show ?thesis using assms by auto
qed

lemma subtuple_fmmerge2 [intro]:
  "(\<And>x y. x \<in> fmran' xm \<Longrightarrow> R x (f x y)) \<Longrightarrow>
   subtuple R xm (fmmerge f xm ym)"
  by (rule_tac ?S="fmdom ym" in fmrel_on_fsubset; auto)

(*** Transitive Closures ****************************************************)

subsection \<open>Transitive Closures\<close>

lemma trancl_to_subtuple:
  "(subtuple R)\<^sup>+\<^sup>+ xm ym \<Longrightarrow>
   subtuple R\<^sup>+\<^sup>+ xm ym"
proof (induct rule: tranclp_induct)
  case (base y) thus ?case
    by (metis subtuple_mono tranclp.r_into_trancl)
next
  case (step y z)
  from step.hyps(3) have "subtuple R\<^sup>+\<^sup>+ xm y" by simp
  also from step.hyps(2) have "subtuple R y z" by simp
  finally show ?case by simp
qed

lemma rtrancl_to_subtuple:
  "(subtuple R)\<^sup>*\<^sup>* xm ym \<Longrightarrow>
   subtuple R\<^sup>*\<^sup>* xm ym"
proof (induct rule: rtranclp_induct)
  case base show ?case
    by (simp add: fmrel_on_fset_refl_strong)
next
  case (step y z)
  from step.hyps(3) have "subtuple R\<^sup>*\<^sup>* xm y" by simp
  also from step.hyps(2) have "subtuple R y z" by simp
  finally show ?case by simp
qed

lemma fmrel_to_subtuple_trancl:
  "reflp R \<Longrightarrow>
   (fmrel R)\<^sup>+\<^sup>+ (fmrestrict_fset (fmdom ym) xm) ym \<Longrightarrow>
   (subtuple R)\<^sup>+\<^sup>+ xm ym"
  apply (frule trancl_to_fmrel)
  apply (rule_tac ?R="R" in fmrel_tranclp_induct, auto)
  apply (metis (no_types, lifting) fmrel_fmdom_eq
          subtuple_eq_fmrel_fmrestrict_fset tranclp.r_into_trancl)
  by (meson fmrel_to_subtuple tranclp.simps)

lemma subtuple_to_trancl:
  "reflp R \<Longrightarrow>
   subtuple R\<^sup>+\<^sup>+ xm ym \<Longrightarrow>
   (subtuple R)\<^sup>+\<^sup>+ xm ym"
  apply (rule fmrel_to_subtuple_trancl)
  unfolding fmrel_on_fset_fmrel_restrict
  by (simp_all add: fmrel_to_trancl)

lemma trancl_to_strict_subtuple:
  "acyclicP_on (fmran' ym) R \<Longrightarrow>
   (strict_subtuple R)\<^sup>+\<^sup>+ xm ym \<Longrightarrow>
   strict_subtuple R\<^sup>*\<^sup>* xm ym"
  apply (erule converse_tranclp_induct)
  apply (metis r_into_rtranclp strict_subtuple_mono)
  using strict_subtuple_trans'' by blast

lemma trancl_to_strict_subtuple':
  "acyclicP_on (fmran' ym) R \<Longrightarrow>
   (strict_subtuple (\<lambda>x y. R x y \<or> x = y))\<^sup>+\<^sup>+ xm ym \<Longrightarrow>
   strict_subtuple (\<lambda>x y. R x y \<or> x = y)\<^sup>*\<^sup>* xm ym"
  apply (erule converse_tranclp_induct)
  apply (metis (no_types, lifting) r_into_rtranclp strict_subtuple_mono)
  using strict_subtuple_trans''' by blast

lemma subtuple_rtranclp_intro:
  assumes "\<And>xm ym. R (f xm) (f ym) \<Longrightarrow> subtuple S xm ym"
      and "bij_on_trancl R f"
      and "R\<^sup>*\<^sup>* (f xm) (f ym)"
    shows "subtuple S\<^sup>*\<^sup>* xm ym"
proof -
  have "(\<lambda>xm ym. R (f xm) (f ym))\<^sup>*\<^sup>* xm ym"
    apply (insert assms(2) assms(3))
    by (rule reflect_rtranclp; auto)
  with assms(1) have "(subtuple S)\<^sup>*\<^sup>* xm ym"
    by (metis (mono_tags, lifting) mono_rtranclp)
  hence "subtuple S\<^sup>*\<^sup>* xm ym"
    by (rule rtrancl_to_subtuple)
  thus ?thesis by simp
qed

lemma strict_subtuple_rtranclp_intro:
  assumes "\<And>xm ym. R (f xm) (f ym) \<Longrightarrow>
           strict_subtuple (\<lambda>x y. S x y \<or> x = y) xm ym"
      and "bij_on_trancl R f"
      and "acyclicP_on (fmran' ym) S"
      and "R\<^sup>+\<^sup>+ (f xm) (f ym)"
    shows "strict_subtuple S\<^sup>*\<^sup>* xm ym"
proof -
  have "(\<lambda>xm ym. R (f xm) (f ym))\<^sup>+\<^sup>+ xm ym"
    apply (insert assms(1) assms(2) assms(4))
    by (rule reflect_tranclp; auto)
  hence "(strict_subtuple (\<lambda>x y. S x y \<or> x = y))\<^sup>+\<^sup>+ xm ym"
    by (rule tranclp_trans_induct;
        auto simp add: assms(1) tranclp.r_into_trancl)
  with assms(3) have "strict_subtuple (\<lambda>x y. S x y \<or> x = y)\<^sup>*\<^sup>* xm ym"
    by (rule trancl_to_strict_subtuple')
  thus ?thesis by simp
qed

(*** Code Setup *************************************************************)

subsection \<open>Code Setup\<close>

abbreviation "subtuple_fun R xm ym \<equiv>
  fBall (fmdom ym) (\<lambda>x. rel_option R (fmlookup xm x) (fmlookup ym x))"

abbreviation "strict_subtuple_fun R xm ym \<equiv>
  subtuple_fun R xm ym \<and> xm \<noteq> ym"

lemma subtuple_fun_simp [code_abbrev, simp]:
  "subtuple_fun R xm ym = subtuple R xm ym"
  by (simp add: fmrel_on_fset_alt_def)

lemma strict_subtuple_fun_simp [code_abbrev, simp]:
  "strict_subtuple_fun R xm ym = strict_subtuple R xm ym"
  by simp

end


(*  Title:      ZF/IMP/Equiv.thy
    Author:     Heiko Loetzbeyer and Robert Sandner, TU München
*)

section \<open>Equivalence\<close>

theory Equiv imports Denotation Com begin

lemma aexp_iff [rule_format]:
  "[| a \<in> aexp; sigma: loc -> nat |]
    ==> \<forall>n. <a,sigma> -a-> n \<longleftrightarrow> A(a,sigma) = n"
  apply (erule aexp.induct)
     apply (force intro!: evala.intros)+
  done

declare aexp_iff [THEN iffD1, simp]
        aexp_iff [THEN iffD2, intro!]

inductive_cases [elim!]:
  "<true,sigma> -b-> x"
  "<false,sigma> -b-> x"
  "<ROp(f,a0,a1),sigma> -b-> x"
  "<noti(b),sigma> -b-> x"
  "<b0 andi b1,sigma> -b-> x"
  "<b0 ori b1,sigma> -b-> x"

lemma bexp_iff [rule_format]:
  "[| b \<in> bexp; sigma: loc -> nat |]
    ==> \<forall>w. <b,sigma> -b-> w \<longleftrightarrow> B(b,sigma) = w"
  apply (erule bexp.induct)
  apply (auto intro!: evalb.intros)
  done

declare bexp_iff [THEN iffD1, simp]
        bexp_iff [THEN iffD2, intro!]

lemma com1: "<c,sigma> -c-> sigma' ==> <sigma,sigma'> \<in> C(c)"
  apply (erule evalc.induct)
        apply (simp_all (no_asm_simp))
     txt \<open>\<open>assign\<close>\<close>
     apply (simp add: update_type)
    txt \<open>\<open>comp\<close>\<close>
    apply fast
   txt \<open>\<open>while\<close>\<close>
   apply (erule Gamma_bnd_mono [THEN lfp_unfold, THEN ssubst, OF C_subset])
   apply (simp add: Gamma_def)
  txt \<open>recursive case of \<open>while\<close>\<close>
  apply (erule Gamma_bnd_mono [THEN lfp_unfold, THEN ssubst, OF C_subset])
  apply (auto simp add: Gamma_def)
  done

declare B_type [intro!] A_type [intro!]
declare evalc.intros [intro]

lemma com2 [rule_format]: "c \<in> com ==> \<forall>x \<in> C(c). <c,fst(x)> -c-> snd(x)"
  apply (erule com.induct)
      txt \<open>\<open>skip\<close>\<close>
      apply force
     txt \<open>\<open>assign\<close>\<close>
     apply force
    txt \<open>\<open>comp\<close>\<close>
    apply force
   txt \<open>\<open>while\<close>\<close>
   apply safe
   apply simp_all
   apply (frule Gamma_bnd_mono [OF C_subset], erule Fixedpt.induct, assumption)
   apply (unfold Gamma_def)
   apply force
  txt \<open>\<open>if\<close>\<close>
  apply auto
  done

subsection \<open>Main theorem\<close>

theorem com_equivalence:
    "c \<in> com ==> C(c) = {io \<in> (loc->nat) \<times> (loc->nat). <c,fst(io)> -c-> snd(io)}"
  by (force intro: C_subset [THEN subsetD] elim: com2 dest: com1)

end


(*  Title:       Ground Unordered Resolution Calculus
    Author:      Jasmin Blanchette <j.c.blanchette at vu.nl>, 2014, 2017
    Author:      Dmitriy Traytel <traytel at inf.ethz.ch>, 2014
    Author:      Anders Schlichtkrull <andschl at dtu.dk>, 2017
    Maintainer:  Anders Schlichtkrull <andschl at dtu.dk>
*)

section \<open>Ground Unordered Resolution Calculus\<close>

theory Unordered_Ground_Resolution
  imports Inference_System Ground_Resolution_Model
begin

text \<open>
Unordered ground resolution is one of the two inference systems studied in Section 3 (``Standard
Resolution'') of Bachmair and Ganzinger's chapter.
\<close>

subsection \<open>Inference Rule\<close>

text \<open>
Unordered ground resolution consists of a single rule, called \<open>unord_resolve\<close> below, which is
sound and counterexample-reducing.
\<close>

locale ground_resolution_without_selection
begin

sublocale ground_resolution_with_selection where S = "\<lambda>_. {#}"
  by unfold_locales auto

inductive unord_resolve :: "'a clause \<Rightarrow> 'a clause \<Rightarrow> 'a clause \<Rightarrow> bool" where
  "unord_resolve (C + replicate_mset (Suc n) (Pos A)) (add_mset (Neg A) D) (C + D)"

lemma unord_resolve_sound: "unord_resolve C D E \<Longrightarrow> I \<Turnstile> C \<Longrightarrow> I \<Turnstile> D \<Longrightarrow> I \<Turnstile> E"
  using unord_resolve.cases by fastforce

text \<open>
The following result corresponds to Theorem 3.8, except that the conclusion is strengthened slightly
to make it fit better with the counterexample-reducing inference system framework.
\<close>

theorem unord_resolve_counterex_reducing:
  assumes
    ec_ni_n: "{#} \<notin> N" and
    c_in_n: "C \<in> N" and
    c_cex: "\<not> INTERP N \<Turnstile> C" and
    c_min: "\<And>D. D \<in> N \<Longrightarrow> \<not> INTERP N \<Turnstile> D \<Longrightarrow> C \<le> D"
  obtains D E where
    "D \<in> N"
    "INTERP N \<Turnstile> D"
    "productive N D"
    "unord_resolve D C E"
    "\<not> INTERP N \<Turnstile> E"
    "E < C"
proof -
  have c_ne: "C \<noteq> {#}"
    using c_in_n ec_ni_n by blast
  have "\<exists>A. A \<in> atms_of C \<and> A = Max (atms_of C)"
    using c_ne by (blast intro: Max_in_lits atm_of_Max_lit atm_of_lit_in_atms_of)
  then have "\<exists>A. Neg A \<in># C"
    using c_ne c_in_n c_cex c_min Max_in_lits Max_lit_eq_pos_or_neg_Max_atm  max_pos_imp_Interp
      Interp_imp_INTERP by metis
  then obtain A where neg_a_in_c: "Neg A \<in># C"
    by blast
  then obtain C' where c: "C = add_mset (Neg A) C'"
    using insert_DiffM by metis
  have "A \<in> INTERP N"
    using neg_a_in_c c_cex[unfolded true_cls_def] by fast
  then obtain D where d0: "produces N D A"
    unfolding INTERP_def by (metis UN_E not_produces_imp_notin_production)
  have prod_d: "productive N D"
    unfolding d0 by simp
  then have d_in_n: "D \<in> N"
    using productive_in_N by fast
  have d_true: "INTERP N \<Turnstile> D"
    using prod_d productive_imp_INTERP by blast

  obtain D' AAA where
    d: "D = D' + AAA" and
    d': "D' = {#L \<in># D. L \<noteq> Pos A#}" and
    aa: "AAA = {#L \<in># D. L = Pos A#}"
    using multiset_partition union_commute by metis
  have d'_subs: "set_mset D' \<subseteq> set_mset D"
    unfolding d' by auto
  have "\<not> Neg A \<in># D"
    using d0 by (blast dest: produces_imp_neg_notin_lits)
  then have neg_a_ni_d': "\<not> Neg A \<in># D'"
    using d'_subs by auto
  have a_ni_d': "A \<notin> atms_of D'"
    using d' neg_a_ni_d' by (auto dest: atm_imp_pos_or_neg_lit)
  have "\<exists>n. AAA = replicate_mset (Suc n) (Pos A)"
    using aa d0 not0_implies_Suc produces_imp_Pos_in_lits[of N]
    by (simp add: filter_eq_replicate_mset del: replicate_mset_Suc)
  then have res_e: "unord_resolve D C (D' + C')"
    unfolding c d by (fastforce intro: unord_resolve.intros)

  have d'_le_d: "D' \<le> D"
    unfolding d by simp
  have a_max_d: "A = Max (atms_of D)"
    using d0 productive_imp_produces_Max_atom by auto
  then have "D' \<noteq> {#} \<Longrightarrow> Max (atms_of D') \<le> A"
    using d'_le_d by (blast intro: less_eq_Max_atms_of)
  moreover have "D' \<noteq> {#} \<Longrightarrow> Max (atms_of D') \<noteq> A"
    using a_ni_d' Max_in by (blast intro: atms_empty_iff_empty[THEN iffD1])
  ultimately have max_d'_lt_a: "D' \<noteq> {#} \<Longrightarrow> Max (atms_of D') < A"
    using dual_order.strict_iff_order by blast

  have "\<not> interp N D \<Turnstile> D"
    using d0 productive_imp_not_interp by blast
  then have "\<not> Interp N D \<Turnstile> D'"
    unfolding d0 d' Interp_def true_cls_def by (auto simp: true_lit_def simp del: not_gr_zero)
  then have "\<not> INTERP N \<Turnstile> D'"
    using a_max_d d'_le_d max_d'_lt_a not_Interp_imp_not_INTERP by blast
  moreover have "\<not> INTERP N \<Turnstile> C'"
    using c_cex unfolding c by simp
  ultimately have e_cex: "\<not> INTERP N \<Turnstile> D' + C'"
    by simp

  have "\<And>B. B \<in> atms_of D' \<Longrightarrow> B \<le> A"
    using d0 d'_subs contra_subsetD lits_subseteq_imp_atms_subseteq produces_imp_atms_leq by metis
  then have "\<And>L. L \<in># D' \<Longrightarrow> L < Neg A"
    using neg_a_ni_d' antisym_conv1 atms_less_eq_imp_lit_less_eq_neg by metis
  then have lt_cex: "D' + C' < C"
    by (force intro: add.commute simp: c less_multiset\<^sub>D\<^sub>M intro: exI[of _ "{#Neg A#}"])

  from d_in_n d_true prod_d res_e e_cex lt_cex show ?thesis ..
qed

subsection \<open>Inference System\<close>

text \<open>
Theorem 3.9 and Corollary 3.10 are subsumed in the counterexample-reducing inference system
framework, which is instantiated below.
\<close>

definition unord_\<Gamma> :: "'a inference set" where
  "unord_\<Gamma> = {Infer {#C#} D E | C D E. unord_resolve C D E}"

sublocale unord_\<Gamma>_sound_counterex_reducing?:
  sound_counterex_reducing_inference_system unord_\<Gamma> INTERP
proof unfold_locales
  fix D E and N :: "('b :: wellorder) clause set"
  assume "{#} \<notin> N" and "D \<in> N" and "\<not> INTERP N \<Turnstile> D" and "\<And>C. C \<in> N \<Longrightarrow> \<not> INTERP N \<Turnstile> C \<Longrightarrow> D \<le> C"
  then obtain C E where
    c_in_n: "C \<in> N" and
    c_true: "INTERP N \<Turnstile> C" and
    res_e: "unord_resolve C D E" and
    e_cex: "\<not> INTERP N \<Turnstile> E" and
    e_lt_d: "E < D"
    using unord_resolve_counterex_reducing by (metis (no_types))
  from c_in_n have "set_mset {#C#} \<subseteq> N"
    by auto
  moreover have "Infer {#C#} D E \<in> unord_\<Gamma>"
    unfolding unord_\<Gamma>_def using res_e by blast
  ultimately show
    "\<exists>CC E. set_mset CC \<subseteq> N \<and> INTERP N \<Turnstile>m CC \<and> Infer CC D E \<in> unord_\<Gamma> \<and> \<not> INTERP N \<Turnstile> E \<and> E < D"
    using c_in_n c_true e_cex e_lt_d by blast
next
  fix CC D E and I :: "'b interp"
  assume "Infer CC D E \<in> unord_\<Gamma>" and "I \<Turnstile>m CC" and "I \<Turnstile> D"
  then show "I \<Turnstile> E"
    by (clarsimp simp: unord_\<Gamma>_def true_cls_mset_def) (erule unord_resolve_sound, auto)
qed

lemmas clausal_logic_compact = unord_\<Gamma>_sound_counterex_reducing.clausal_logic_compact

end

text \<open>
Theorem 3.12, compactness of clausal logic, has finally been derived for a concrete inference
system:
\<close>

lemmas clausal_logic_compact = ground_resolution_without_selection.clausal_logic_compact

end