section \<open> Units \<close>

theory ISQ_Units
  imports ISQ_Proof
begin

text \<open> Parallel to the base quantities, there are base units. In the implementation of
  the SI unit system, we fix these to be precisely those quantities that have a base dimension
  and a magnitude of \<^term>\<open>1\<close>. Consequently, a base unit corresponds to a unit in the algebraic
  sense. \<close>

lift_definition is_base_unit :: "'a::one['d::dim_type, 's::unit_system] \<Rightarrow> bool"
  is "\<lambda> x. mag x = 1 \<and> is_BaseDim (dim x)" .

definition mk_base_unit :: "'u itself \<Rightarrow> 's itself \<Rightarrow> ('a::one)['u::basedim_type, 's::unit_system]"
  where "mk_base_unit t s = 1"

syntax "_mk_base_unit" :: "type \<Rightarrow> type \<Rightarrow> logic" ("BUNIT'(_, _')")
translations "BUNIT('a, 's)" == "CONST mk_base_unit TYPE('a) TYPE('s)"

lemma mk_base_unit: "is_base_unit (mk_base_unit a s)"
  by (simp add: mk_base_unit_def si_eq, transfer, simp add: is_BaseDim)

lemma magQ_mk [si_eq]: "\<lbrakk>BUNIT('u::basedim_type, 's::unit_system)\<rbrakk>\<^sub>Q = 1"
  by (simp add: mk_base_unit_def magQ_def si_eq, transfer, simp)

end


(*  Title:       AWN_Invariants.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

header "Generic invariants on sequential AWN processes"

theory AWN_Invariants
imports Invariants AWN_SOS AWN_Labels
begin

subsection "Invariants via labelled control terms"

text \<open>
  Used to state that the initial control-state of an automaton appears within a process
  specification @{text \<Gamma>}, meaning that its transitions, and those of its subterms, are
  subsumed by those of @{text \<Gamma>}.
\<close>

definition
  control_within :: "('s, 'm, 'p, 'l) seqp_env \<Rightarrow> ('z \<times> ('s, 'm, 'p, 'l) seqp) set \<Rightarrow> bool"
where
  "control_within \<Gamma> \<sigma> \<equiv> \<forall>(\<xi>, p)\<in>\<sigma>. \<exists>pn. p \<in> subterms (\<Gamma> pn)"

lemma control_withinI [intro]:
  assumes "\<And>p. p \<in> Range \<sigma> \<Longrightarrow> \<exists>pn. p \<in> subterms (\<Gamma> pn)"
    shows "control_within \<Gamma> \<sigma>"
  using assms unfolding control_within_def by auto

lemma control_withinD [dest]:
  assumes "control_within \<Gamma> \<sigma>"
      and "(\<xi>, p) \<in> \<sigma>"
    shows "\<exists>pn. p \<in> subterms (\<Gamma> pn)"
  using assms unfolding control_within_def by blast

lemma control_within_topI [intro]:
  assumes "\<And>p. p \<in> Range \<sigma> \<Longrightarrow> \<exists>pn. p = \<Gamma> pn"
    shows "control_within \<Gamma> \<sigma>"
  using assms unfolding control_within_def
  by clarsimp (metis Range.RangeI subterms_refl)

lemma seqp_sos_subterms:
  assumes "wellformed \<Gamma>"
      and "\<exists>pn. p \<in> subterms (\<Gamma> pn)"
      and "((\<xi>, p), a, (\<xi>', p')) \<in> seqp_sos \<Gamma>"
    shows "\<exists>pn. p' \<in> subterms (\<Gamma> pn)"
  using assms
  proof (induct p)
    fix p1 p2
    assume IH1: "\<exists>pn. p1 \<in> subterms (\<Gamma> pn) \<Longrightarrow>
                      ((\<xi>, p1), a, (\<xi>', p')) \<in> seqp_sos \<Gamma> \<Longrightarrow>
                      \<exists>pn. p' \<in> subterms (\<Gamma> pn)"
       and IH2: "\<exists>pn. p2 \<in> subterms (\<Gamma> pn) \<Longrightarrow>
                      ((\<xi>, p2), a, (\<xi>', p')) \<in> seqp_sos \<Gamma> \<Longrightarrow>
                      \<exists>pn. p' \<in> subterms (\<Gamma> pn)"
       and "\<exists>pn. p1 \<oplus> p2 \<in> subterms (\<Gamma> pn)"
       and "((\<xi>, p1 \<oplus> p2), a, (\<xi>', p')) \<in> seqp_sos \<Gamma>"
    from \<open>\<exists>pn. p1 \<oplus> p2 \<in> subterms (\<Gamma> pn)\<close> obtain pn
                                            where "p1 \<in> subterms (\<Gamma> pn)"
                                              and "p2 \<in> subterms (\<Gamma> pn)" by auto
    from \<open>((\<xi>, p1 \<oplus> p2), a, (\<xi>', p')) \<in> seqp_sos \<Gamma>\<close>
      have "((\<xi>, p1), a, (\<xi>', p')) \<in> seqp_sos \<Gamma>
            \<or> ((\<xi>, p2), a, (\<xi>', p')) \<in> seqp_sos \<Gamma>" by auto
    thus "\<exists>pn. p' \<in> subterms (\<Gamma> pn)"
    proof
      assume "((\<xi>, p1), a, (\<xi>', p')) \<in> seqp_sos \<Gamma>"
      with \<open>p1 \<in> subterms (\<Gamma> pn)\<close> show ?thesis by (auto intro: IH1)
    next
      assume "((\<xi>, p2), a, (\<xi>', p')) \<in> seqp_sos \<Gamma>"
      with \<open>p2 \<in> subterms (\<Gamma> pn)\<close> show ?thesis by (auto intro: IH2)
    qed
  qed auto

lemma reachable_subterms:
  assumes "wellformed \<Gamma>"
      and "control_within \<Gamma> (init A)"
      and "trans A = seqp_sos \<Gamma>"
      and "(\<xi>, p) \<in> reachable A I"
    shows "\<exists>pn. p \<in> subterms (\<Gamma> pn)"
  using assms(4)
  proof (induct rule: reachable_pair_induct)
    fix \<xi> p
    assume "(\<xi>, p) \<in> init A"
    with \<open>control_within \<Gamma> (init A)\<close> show "\<exists>pn. p \<in> subterms (\<Gamma> pn)" ..
  next
    fix \<xi> p a \<xi>' p'
    assume "(\<xi>, p) \<in> reachable A I"
       and "\<exists>pn. p \<in> subterms (\<Gamma> pn)"
       and "((\<xi>, p), a, (\<xi>', p')) \<in> trans A"
       and "I a"
    moreover from this(3) and assms(3) have "((\<xi>, p), a, (\<xi>', p')) \<in> seqp_sos \<Gamma>" by simp
    ultimately show "\<exists>pn. p' \<in> subterms (\<Gamma> pn)"
    using \<open>wellformed \<Gamma>\<close>
      by (auto elim: seqp_sos_subterms)
  qed

definition
  onl :: "('s, 'm, 'p, 'l) seqp_env
           \<Rightarrow> ('z \<times> 'l \<Rightarrow> bool)
           \<Rightarrow> 'z \<times> ('s, 'm, 'p, 'l) seqp
           \<Rightarrow> bool"
where
  "onl \<Gamma> P \<equiv> (\<lambda>(\<xi>, p). \<forall>l\<in>labels \<Gamma> p. P (\<xi>, l))"

lemma onlI [intro]:
  assumes "\<And>l. l\<in>labels \<Gamma> p \<Longrightarrow> P (\<xi>, l)"
    shows "onl \<Gamma> P (\<xi>, p)"
  using assms unfolding onl_def by simp

lemmas onlI' [intro] = onlI [simplified atomize_ball]

lemma onlD [dest]:
  assumes "onl \<Gamma> P (\<xi>, p)"
    shows "\<forall>l\<in>labels \<Gamma> p. P (\<xi>, l)"
  using assms unfolding onl_def by simp

lemma onl_invariantI [intro]:
  assumes init: "\<And>\<xi> p l. \<lbrakk> (\<xi>, p) \<in> init A; l \<in> labels \<Gamma> p \<rbrakk> \<Longrightarrow> P (\<xi>, l)"
      and step: "\<And>\<xi> p a \<xi>' p' l'.
                   \<lbrakk> (\<xi>, p) \<in> reachable A I;
                     \<forall>l\<in>labels \<Gamma> p. P (\<xi>, l);
                     ((\<xi>, p), a, (\<xi>', p')) \<in> trans A;
                     l' \<in> labels \<Gamma> p';
                     I a \<rbrakk> \<Longrightarrow> P (\<xi>', l')"
    shows "A \<TTurnstile> (I \<rightarrow>) onl \<Gamma> P"
  proof (rule invariant_pairI)
    fix \<xi> p
    assume "(\<xi>, p) \<in> init A"
    hence "\<forall>l\<in>labels \<Gamma> p. P (\<xi>, l)" using init by simp
    thus "onl \<Gamma> P (\<xi>, p)" ..
  next
    fix \<xi> p a \<xi>' p'
    assume rp: "(\<xi>, p) \<in> reachable A I"
       and "onl \<Gamma> P (\<xi>, p)"
       and tr: "((\<xi>, p), a, (\<xi>', p')) \<in> trans A"
       and "I a"
    from \<open>onl \<Gamma> P (\<xi>, p)\<close> have "\<forall>l\<in>labels \<Gamma> p. P (\<xi>, l)" ..
    with rp tr \<open>I a\<close> have "\<forall>l'\<in>labels \<Gamma> p'. P (\<xi>', l')" by (auto elim: step)
    thus "onl \<Gamma> P (\<xi>', p')" ..
  qed

lemma onl_invariantD [dest]:
  assumes "A \<TTurnstile> (I \<rightarrow>) onl \<Gamma> P"
      and "(\<xi>, p) \<in> reachable A I"
      and "l \<in> labels \<Gamma> p"
    shows "P (\<xi>, l)"
  using assms unfolding onl_def by auto

lemma onl_invariant_initD [dest]:
  assumes invP: "A \<TTurnstile> (I \<rightarrow>) onl \<Gamma> P"
      and init: "(\<xi>, p) \<in> init A"
      and pnl:  "l \<in> labels \<Gamma> p"
    shows "P (\<xi>, l)"
  proof -
    from init have "(\<xi>, p) \<in> reachable A I" ..
    with invP show ?thesis using pnl ..
  qed

lemma onl_invariant_sterms:
  assumes wf: "wellformed \<Gamma>"
      and il: "A \<TTurnstile> (I \<rightarrow>) onl \<Gamma> P"
      and rp: "(\<xi>, p) \<in> reachable A I"
      and "p'\<in>sterms \<Gamma> p"
      and "l\<in>labels \<Gamma> p'"
    shows "P (\<xi>, l)"
  proof -
    from wf \<open>p'\<in>sterms \<Gamma> p\<close> \<open>l\<in>labels \<Gamma> p'\<close> have "l\<in>labels \<Gamma> p"
      by (rule labels_sterms_labels)
    with il rp show "P (\<xi>, l)" ..
  qed

lemma onl_invariant_sterms_weaken:
  assumes wf: "wellformed \<Gamma>"
      and il: "A \<TTurnstile> (I \<rightarrow>) onl \<Gamma> P"
      and rp: "(\<xi>, p) \<in> reachable A I'"
      and "p'\<in>sterms \<Gamma> p"
      and "l\<in>labels \<Gamma> p'"
      and weaken: "\<And>a. I' a \<Longrightarrow> I a"
    shows "P (\<xi>, l)"
  proof -
    from \<open>(\<xi>, p) \<in> reachable A I'\<close> have "(\<xi>, p) \<in> reachable A I"
      by (rule reachable_weakenE)
         (erule weaken)
    with assms(1-2) show ?thesis using assms(4-5) by (rule onl_invariant_sterms)
  qed

lemma onl_invariant_sterms_TT:
  assumes wf: "wellformed \<Gamma>"
      and il: "A \<TTurnstile> onl \<Gamma> P"
      and rp: "(\<xi>, p) \<in> reachable A I"
      and "p'\<in>sterms \<Gamma> p"
      and "l\<in>labels \<Gamma> p'"
    shows "P (\<xi>, l)"
  using assms by (rule onl_invariant_sterms_weaken) simp

lemma trans_from_sterms:
  assumes "((\<xi>, p), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>"
      and "wellformed \<Gamma>"
    shows "\<exists>p'\<in>sterms \<Gamma> p. ((\<xi>, p'), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>"
  using assms by (induction p rule: sterms_pinduct [OF \<open>wellformed \<Gamma>\<close>]) auto

lemma trans_from_sterms':
  assumes "((\<xi>, p'), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>"
      and "wellformed \<Gamma>"
      and "p' \<in> sterms \<Gamma> p"
    shows "((\<xi>, p), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>"
  using assms by (induction p rule: sterms_pinduct [OF \<open>wellformed \<Gamma>\<close>]) auto

lemma trans_to_dterms:
  assumes "((\<xi>, p), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>"
      and "wellformed \<Gamma>"
   shows "\<forall>r\<in>sterms \<Gamma> q. r \<in> dterms \<Gamma> p"
  using assms by (induction q) auto

theorem cterms_includes_sterms_of_seq_reachable:
  assumes "wellformed \<Gamma>"
      and "control_within \<Gamma> (init A)"
      and "trans A = seqp_sos \<Gamma>"
    shows "\<Union>(sterms \<Gamma> ` snd ` reachable A I) \<subseteq> cterms \<Gamma>"
  proof
    fix qs
    assume "qs \<in> \<Union>(sterms \<Gamma> ` snd ` reachable A I)"
    then obtain \<xi> and q where  *: "(\<xi>, q) \<in> reachable A I"
                          and **: "qs \<in> sterms \<Gamma> q" by auto
    from * have "\<And>x. x \<in> sterms \<Gamma> q \<Longrightarrow> x \<in> cterms \<Gamma>"
    proof (induction rule: reachable_pair_induct)
      fix \<xi> p q
      assume "(\<xi>, p) \<in> init A"
         and "q \<in> sterms \<Gamma> p"
      from \<open>control_within \<Gamma> (init A)\<close> and \<open>(\<xi>, p) \<in> init A\<close>
        obtain pn where "p \<in> subterms (\<Gamma> pn)" by auto
      with \<open>wellformed \<Gamma>\<close> show "q \<in> cterms \<Gamma>" using \<open>q\<in>sterms \<Gamma> p\<close>
        by (rule subterms_sterms_in_cterms)
    next
      fix p \<xi> a \<xi>' q x
      assume "(\<xi>, p) \<in> reachable A I"
         and IH: "\<And>x. x \<in> sterms \<Gamma> p \<Longrightarrow> x \<in> cterms \<Gamma>"
         and "((\<xi>, p), a, (\<xi>', q)) \<in> trans A"
         and "x \<in> sterms \<Gamma> q"
      from this(3) and \<open>trans A = seqp_sos \<Gamma>\<close> have "((\<xi>, p), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>" by simp
      from this and \<open>wellformed \<Gamma>\<close> obtain ps
        where ps: "ps \<in> sterms \<Gamma> p"
          and step: "((\<xi>, ps), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>"
        by (rule trans_from_sterms [THEN bexE])
      from ps have "ps \<in> cterms \<Gamma>" by (rule IH)
      moreover from step \<open>wellformed \<Gamma>\<close> \<open>x \<in> sterms \<Gamma> q\<close> have "x \<in> dterms \<Gamma> ps"
        by (rule trans_to_dterms [rule_format])
      ultimately show "x \<in> cterms \<Gamma>" by (rule ctermsDI)
    qed
    thus "qs \<in> cterms \<Gamma>" using ** .
  qed

corollary seq_reachable_in_cterms:
  assumes "wellformed \<Gamma>"
      and "control_within \<Gamma> (init A)"
      and "trans A = seqp_sos \<Gamma>"
      and "(\<xi>, p) \<in> reachable A I"
      and "p' \<in> sterms \<Gamma> p"
    shows "p' \<in> cterms \<Gamma>"
  using assms(1-3)
  proof (rule cterms_includes_sterms_of_seq_reachable [THEN set_mp])
    from assms(4-5) show "p' \<in> \<Union>(sterms \<Gamma> ` snd ` reachable A I)"
      by (auto elim!: rev_bexI)
  qed

lemma seq_invariant_ctermI:
  assumes wf: "wellformed \<Gamma>"
      and cw: "control_within \<Gamma> (init A)"
      and sl: "simple_labels \<Gamma>"
      and sp: "trans A = seqp_sos \<Gamma>"
      and init: "\<And>\<xi> p l. \<lbrakk>
                   (\<xi>, p) \<in> init A;
                   l\<in>labels \<Gamma> p
                 \<rbrakk> \<Longrightarrow> P (\<xi>, l)"
      and step: "\<And>p l \<xi> a q l' \<xi>' pp. \<lbrakk>
                 p\<in>cterms \<Gamma>;
                 l\<in>labels \<Gamma> p;
                 P (\<xi>, l);
                 ((\<xi>, p), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>;
                 ((\<xi>, p), a, (\<xi>', q)) \<in> trans A;
                 l'\<in>labels \<Gamma> q;
                 (\<xi>, pp)\<in>reachable A I;
                 p\<in>sterms \<Gamma> pp;
                 (\<xi>', q)\<in>reachable A I;
                 I a
               \<rbrakk> \<Longrightarrow> P (\<xi>', l')"
    shows "A \<TTurnstile> (I \<rightarrow>) onl \<Gamma> P"
  proof
       fix \<xi> p l
    assume "(\<xi>, p) \<in> init A"
       and *: "l \<in> labels \<Gamma> p"
      with init show "P (\<xi>, l)" by auto
  next
       fix \<xi> p a \<xi>' q l'
    assume sr: "(\<xi>, p) \<in> reachable A I"
       and pl: "\<forall>l\<in>labels \<Gamma> p. P (\<xi>, l)"
       and tr: "((\<xi>, p), a, (\<xi>', q)) \<in> trans A"
       and A6: "l' \<in> labels \<Gamma> q"
       and "I a"
     from this(3) and \<open>trans A = seqp_sos \<Gamma>\<close> have tr': "((\<xi>, p), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>" by simp
     show "P (\<xi>', l')"
    proof -
      from sr and tr and \<open>I a\<close> have A7: "(\<xi>', q) \<in> reachable A I" ..
      from tr' obtain p' where "p' \<in> sterms \<Gamma> p"
                           and "((\<xi>, p'), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>"
        by (blast dest: trans_from_sterms [OF _ wf])
      from wf cw sp sr this(1) have A1: "p'\<in>cterms \<Gamma>"
        by (rule seq_reachable_in_cterms)
      from labels_not_empty [OF wf] obtain ll where A2: "ll\<in>labels \<Gamma> p'"
          by blast
      with \<open>p'\<in>sterms \<Gamma> p\<close> have "ll\<in>labels \<Gamma> p"
        by (rule labels_sterms_labels [OF wf])
      with pl have A3: "P (\<xi>, ll)" by simp
      from \<open>((\<xi>, p'), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>\<close> and sp
        have A5: "((\<xi>, p'), a, (\<xi>', q)) \<in> trans A" by simp
      with sp have A4: "((\<xi>, p'), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>" by simp
      from sr \<open>p'\<in>sterms \<Gamma> p\<close>
        obtain pp where A7: "(\<xi>, pp)\<in>reachable A I"
                    and A8: "p'\<in>sterms \<Gamma> pp"
        by auto
      from sr tr \<open>I a\<close> have A9: "(\<xi>', q) \<in> reachable A I" ..
      from A1 A2 A3 A4 A5 A6 A7 A8 A9 \<open>I a\<close> show ?thesis by (rule step)
    qed
  qed

lemma seq_invariant_ctermsI:
  assumes wf: "wellformed \<Gamma>"
      and "control_within \<Gamma> (init A)"
      and "simple_labels \<Gamma>"
      and "trans A = seqp_sos \<Gamma>"
      and init: "\<And>\<xi> p l. \<lbrakk>
                   (\<xi>, p) \<in> init A;
                   l\<in>labels \<Gamma> p
                 \<rbrakk> \<Longrightarrow> P (\<xi>, l)"
      and step: "\<And>p l \<xi> a q l' \<xi>' pp pn. \<lbrakk>
                 wellformed \<Gamma>;
                 p\<in>ctermsl (\<Gamma> pn);
                 not_call p;
                 l\<in>labels \<Gamma> p;
                 P (\<xi>, l);
                 ((\<xi>, p), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>;
                 ((\<xi>, p), a, (\<xi>', q)) \<in> trans A;
                 l'\<in>labels \<Gamma> q;
                 (\<xi>, pp)\<in>reachable A I;
                 p\<in>sterms \<Gamma> pp;
                 (\<xi>', q)\<in>reachable A I;
                 I a
               \<rbrakk> \<Longrightarrow> P (\<xi>', l')"
    shows "A \<TTurnstile> (I \<rightarrow>) onl \<Gamma> P"
  using assms(1-4) proof (rule seq_invariant_ctermI)
    fix \<xi> p l
    assume "(\<xi>, p) \<in> init A"
       and "l \<in> labels \<Gamma> p"
    thus "P (\<xi>, l)" by (rule init)
  next
    fix p l \<xi> a q l' \<xi>' pp
    assume "p \<in> cterms \<Gamma>"
       and otherassms: "l \<in> labels \<Gamma> p"
           "P (\<xi>, l)"
           "((\<xi>, p), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>"
           "((\<xi>, p), a, (\<xi>', q)) \<in> trans A"
           "l' \<in> labels \<Gamma> q"
           "(\<xi>, pp) \<in> reachable A I"
           "p \<in> sterms \<Gamma> pp"
           "(\<xi>', q) \<in> reachable A I"
           "I a"
    from this(1) obtain pn where "p \<in> ctermsl(\<Gamma> pn)"
                             and "not_call p"
      unfolding cterms_def' [OF wf] by auto
    with wf show "P (\<xi>', l')"
      using otherassms by (rule step)
  qed

subsection "Step invariants via labelled control terms"

definition
  onll :: "('s, 'm, 'p, 'l) seqp_env
           \<Rightarrow> (('z \<times> 'l, 'a) transition \<Rightarrow> bool)
           \<Rightarrow> ('z \<times> ('s, 'm, 'p, 'l) seqp, 'a) transition \<Rightarrow> bool"
where
  "onll \<Gamma> P \<equiv> (\<lambda>((\<xi>, p), a, (\<xi>', p')). \<forall>l\<in>labels \<Gamma> p. \<forall>l'\<in>labels \<Gamma> p'. P ((\<xi>, l), a, (\<xi>', l')))"

lemma onllI [intro]:
  assumes "\<And>l l'. \<lbrakk> l\<in>labels \<Gamma> p; l'\<in>labels \<Gamma> p' \<rbrakk> \<Longrightarrow> P ((\<xi>, l), a, (\<xi>', l'))"
    shows "onll \<Gamma> P ((\<xi>, p), a, (\<xi>', p'))"
  using assms unfolding onll_def by simp

lemma onllIl [intro]:
  assumes "\<forall>l\<in>labels \<Gamma> p. \<forall>l'\<in>labels \<Gamma> p'. P ((\<xi>, l), a, (\<xi>', l'))"
    shows "onll \<Gamma> P ((\<xi>, p), a, (\<xi>', p'))"
  using assms by auto

lemma onl_weaken [elim!]: "\<And>\<Gamma> P Q s. \<lbrakk> onl \<Gamma> P s; \<And>s. P s \<Longrightarrow> Q s \<rbrakk> \<Longrightarrow> onl \<Gamma> Q s"
  by (clarsimp dest!: onlD intro!: onlI)

lemma onll_weaken [elim!]: "\<And>\<Gamma> P Q s. \<lbrakk> onll \<Gamma> P s; \<And>s. P s \<Longrightarrow> Q s \<rbrakk> \<Longrightarrow> onll \<Gamma> Q s"
  by (clarsimp dest!: onllD intro!: onllI)

lemma onll_weaken' [elim!]: "\<And>\<Gamma> P Q s. \<lbrakk> onll \<Gamma> P ((\<xi>, p), a, (\<xi>', p'));
                                        \<And>l l'. P ((\<xi>, l), a, (\<xi>', l')) \<Longrightarrow> Q ((\<xi>, l), a, (\<xi>', l')) \<rbrakk>
                                      \<Longrightarrow> onll \<Gamma> Q ((\<xi>, p), a, (\<xi>', p'))"
  by (clarsimp dest!: onllD intro!: onllI)

lemma onll_step_invariantI [intro]:
  assumes *: "\<And>\<xi> p l a \<xi>' p' l'. \<lbrakk> (\<xi>, p)\<in>reachable A I;
                                   ((\<xi>, p), a, (\<xi>', p')) \<in> trans A;
                                   I a;
                                   l \<in>labels \<Gamma> p;
                                   l'\<in>labels \<Gamma> p' \<rbrakk>
                                 \<Longrightarrow> P ((\<xi>, l), a, (\<xi>', l'))"
    shows "A \<TTurnstile>\<^sub>A (I \<rightarrow>) onll \<Gamma> P"
  proof
    fix \<xi> p \<xi>' p' a
    assume "(\<xi>, p) \<in> reachable A I"
       and "((\<xi>, p), a, (\<xi>', p')) \<in> trans A"
       and "I a"
    hence "\<forall>l\<in>labels \<Gamma> p. \<forall>l'\<in>labels \<Gamma> p'. P ((\<xi>, l), a, (\<xi>', l'))" by (auto elim!: *)
    thus "onll \<Gamma> P ((\<xi>, p), a, (\<xi>', p'))" ..
  qed

lemma onll_step_invariantE [elim]:
  assumes "A \<TTurnstile>\<^sub>A (I \<rightarrow>) onll \<Gamma> P"
      and "(\<xi>, p) \<in> reachable A I"
      and "((\<xi>, p), a, (\<xi>', p')) \<in> trans A"
      and "I a"
      and lp:  "l \<in>labels \<Gamma> p"
      and lp': "l'\<in>labels \<Gamma> p'"
    shows "P ((\<xi>, l), a, (\<xi>', l'))"
  proof -
    from assms(1-4) have "onll \<Gamma> P ((\<xi>, p), a, (\<xi>', p'))" ..
    with lp lp' show "P ((\<xi>, l), a, (\<xi>', l'))" by auto
  qed

lemma onll_step_invariantD [dest]:
  assumes "A \<TTurnstile>\<^sub>A (I \<rightarrow>) onll \<Gamma> P"
      and "(\<xi>, p) \<in> reachable A I"
      and "((\<xi>, p), a, (\<xi>', p')) \<in> trans A"
      and "I a"
    shows "\<forall>l\<in>labels \<Gamma> p. \<forall>l'\<in>labels \<Gamma> p'. P ((\<xi>, l), a, (\<xi>', l'))"
  using assms by auto

lemma seq_step_invariant_sterms:
  assumes inv: "A \<TTurnstile>\<^sub>A (I \<rightarrow>) onll \<Gamma> P"
      and wf: "wellformed \<Gamma>"
      and sp: "trans A = seqp_sos \<Gamma>"
      and "l'\<in>labels \<Gamma> q"
      and sr: "(\<xi>, p) \<in> reachable A I"
      and tr: "((\<xi>, p'), a, (\<xi>', q)) \<in> trans A"
      and "I a"
      and "p'\<in>sterms \<Gamma> p"
    shows "\<forall>l\<in>labels \<Gamma> p'. P ((\<xi>, l), a, (\<xi>', l'))"
  proof
    from tr and sp have "((\<xi>, p'), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>" by simp
    hence "((\<xi>, p), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>"
      using wf \<open>p'\<in>sterms \<Gamma> p\<close> by  (rule trans_from_sterms')
    with sp have trp: "((\<xi>, p), a, (\<xi>', q)) \<in> trans A" by simp
    fix l assume "l \<in> labels \<Gamma> p'"
    with wf inv sr trp \<open>I a\<close> \<open>l'\<in>labels \<Gamma> q\<close> \<open>p'\<in>sterms \<Gamma> p\<close>
      show "P ((\<xi>, l), a, (\<xi>', l'))" by (rule onll_step_invariant_sterms)
  qed

lemma seq_step_invariant_sterms_weaken:
  assumes "A \<TTurnstile>\<^sub>A (I \<rightarrow>) onll \<Gamma> P"
      and "wellformed \<Gamma>"
      and "trans A = seqp_sos \<Gamma>"
      and "l'\<in>labels \<Gamma> q"
      and "(\<xi>, p) \<in> reachable A I'"
      and "((\<xi>, p'), a, (\<xi>', q)) \<in> trans A"
      and "I' a"
      and "p'\<in>sterms \<Gamma> p"
      and weaken: "\<And>a. I' a \<Longrightarrow> I a"
    shows "\<forall>l\<in>labels \<Gamma> p'. P ((\<xi>, l), a, (\<xi>', l'))"
  proof -
    from \<open>I' a\<close> have "I a" by (rule weaken)
    from \<open>(\<xi>, p) \<in> reachable A I'\<close> have Ir: "(\<xi>, p) \<in> reachable A I"
        by (rule reachable_weakenE) (erule weaken)
    with assms(1-4) show ?thesis
      using \<open>((\<xi>, p'), a, (\<xi>', q)) \<in> trans A\<close> \<open>I a\<close> and \<open>p'\<in>sterms \<Gamma> p\<close>
      by (rule seq_step_invariant_sterms)
  qed

lemma seq_step_invariant_sterms_TT:
  assumes "A \<TTurnstile>\<^sub>A onll \<Gamma> P"
      and "wellformed \<Gamma>"
      and "trans A = seqp_sos \<Gamma>"
      and "l'\<in>labels \<Gamma> q"
      and "(\<xi>, p) \<in> reachable A I"
      and "((\<xi>, p'), a, (\<xi>', q)) \<in> trans A"
      and "I a"
      and "p'\<in>sterms \<Gamma> p"
    shows "\<forall>l\<in>labels \<Gamma> p'. P ((\<xi>, l), a, (\<xi>', l'))"
  using assms by (rule seq_step_invariant_sterms_weaken) simp

lemma onll_step_invariant_any_sterms:
  assumes "wellformed \<Gamma>"
      and "A \<TTurnstile>\<^sub>A (I \<rightarrow>) onll \<Gamma> P"
      and "(\<xi>, p) \<in> reachable A I"
      and "((\<xi>, p), a, (\<xi>', q)) \<in> trans A"
      and "I a"
      and "l'\<in>labels \<Gamma> q"
    shows "\<forall>p'\<in>sterms \<Gamma> p. \<forall>l\<in>labels \<Gamma> p'. P ((\<xi>, l), a, (\<xi>', l'))"
  by (intro ballI) (rule onll_step_invariant_sterms [OF assms])

lemma seq_step_invariant_ctermsI [intro]:
  assumes wf: "wellformed \<Gamma>"
      and cw: "control_within \<Gamma> (init A)"
      and sl: "simple_labels \<Gamma>"
      and sp: "trans A = seqp_sos \<Gamma>"
      and step: "\<And>p l \<xi> a q l' \<xi>' pp pn. \<lbrakk>
                 wellformed \<Gamma>;
                 p\<in>ctermsl (\<Gamma> pn);
                 not_call p;
                 l\<in>labels \<Gamma> p;
                 ((\<xi>, p), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>;
                 ((\<xi>, p), a, (\<xi>', q)) \<in> trans A;
                 l'\<in>labels \<Gamma> q;
                 (\<xi>, pp) \<in> reachable A I;
                 p\<in>sterms \<Gamma> pp;
                 (\<xi>', q) \<in> reachable A I;
                 I a
               \<rbrakk> \<Longrightarrow> P ((\<xi>, l), a, (\<xi>', l'))"
    shows "A \<TTurnstile>\<^sub>A (I \<rightarrow>) onll \<Gamma> P"
  using assms(1-4) proof (rule seq_step_invariant_ctermI)
    fix p pp l \<xi> a q l' \<xi>'
    assume "p \<in> cterms \<Gamma>"
       and otherassms: "l \<in> labels \<Gamma> p"
           "((\<xi>, p), a, (\<xi>', q)) \<in> seqp_sos \<Gamma>"
           "((\<xi>, p), a, (\<xi>', q)) \<in> trans A"
           "l' \<in> labels \<Gamma> q"
           "(\<xi>, pp) \<in> reachable A I"
           "p \<in> sterms \<Gamma> pp"
           "(\<xi>', q) \<in> reachable A I"
           "I a"
    from this(1) obtain pn where "p \<in> ctermsl(\<Gamma> pn)"
                             and "not_call p"
      unfolding cterms_def' [OF wf] by auto
    with wf show "P ((\<xi>, l), a, (\<xi>', l'))"
      using otherassms by (rule step)
  qed

end


(* Title:      HOL/Presburger.thy
   Author:     Amine Chaieb, TU Muenchen
*)

section \<open>Decision Procedure for Presburger Arithmetic\<close>

theory Presburger
imports Groebner_Basis Set_Interval
keywords "try0" :: diag
begin

ML_file \<open>Tools/Qelim/qelim.ML\<close>
ML_file \<open>Tools/Qelim/cooper_procedure.ML\<close>

subsection\<open>The \<open>-\<infinity>\<close> and \<open>+\<infinity>\<close> Properties\<close>

lemma minf:
  "\<lbrakk>\<exists>(z ::'a::linorder).\<forall>x<z. P x = P' x; \<exists>z.\<forall>x<z. Q x = Q' x\<rbrakk>
     \<Longrightarrow> \<exists>z.\<forall>x<z. (P x \<and> Q x) = (P' x \<and> Q' x)"
  "\<lbrakk>\<exists>(z ::'a::linorder).\<forall>x<z. P x = P' x; \<exists>z.\<forall>x<z. Q x = Q' x\<rbrakk>
     \<Longrightarrow> \<exists>z.\<forall>x<z. (P x \<or> Q x) = (P' x \<or> Q' x)"
  "\<exists>(z ::'a::{linorder}).\<forall>x<z.(x = t) = False"
  "\<exists>(z ::'a::{linorder}).\<forall>x<z.(x \<noteq> t) = True"
  "\<exists>(z ::'a::{linorder}).\<forall>x<z.(x < t) = True"
  "\<exists>(z ::'a::{linorder}).\<forall>x<z.(x \<le> t) = True"
  "\<exists>(z ::'a::{linorder}).\<forall>x<z.(x > t) = False"
  "\<exists>(z ::'a::{linorder}).\<forall>x<z.(x \<ge> t) = False"
  "\<exists>z.\<forall>(x::'b::{linorder,plus,Rings.dvd})<z. (d dvd x + s) = (d dvd x + s)"
  "\<exists>z.\<forall>(x::'b::{linorder,plus,Rings.dvd})<z. (\<not> d dvd x + s) = (\<not> d dvd x + s)"
  "\<exists>z.\<forall>x<z. F = F"
  by ((erule exE, erule exE,rule_tac x="min z za" in exI,simp)+, (rule_tac x="t" in exI,fastforce)+) simp_all

lemma pinf:
  "\<lbrakk>\<exists>(z ::'a::linorder).\<forall>x>z. P x = P' x; \<exists>z.\<forall>x>z. Q x = Q' x\<rbrakk>
     \<Longrightarrow> \<exists>z.\<forall>x>z. (P x \<and> Q x) = (P' x \<and> Q' x)"
  "\<lbrakk>\<exists>(z ::'a::linorder).\<forall>x>z. P x = P' x; \<exists>z.\<forall>x>z. Q x = Q' x\<rbrakk>
     \<Longrightarrow> \<exists>z.\<forall>x>z. (P x \<or> Q x) = (P' x \<or> Q' x)"
  "\<exists>(z ::'a::{linorder}).\<forall>x>z.(x = t) = False"
  "\<exists>(z ::'a::{linorder}).\<forall>x>z.(x \<noteq> t) = True"
  "\<exists>(z ::'a::{linorder}).\<forall>x>z.(x < t) = False"
  "\<exists>(z ::'a::{linorder}).\<forall>x>z.(x \<le> t) = False"
  "\<exists>(z ::'a::{linorder}).\<forall>x>z.(x > t) = True"
  "\<exists>(z ::'a::{linorder}).\<forall>x>z.(x \<ge> t) = True"
  "\<exists>z.\<forall>(x::'b::{linorder,plus,Rings.dvd})>z. (d dvd x + s) = (d dvd x + s)"
  "\<exists>z.\<forall>(x::'b::{linorder,plus,Rings.dvd})>z. (\<not> d dvd x + s) = (\<not> d dvd x + s)"
  "\<exists>z.\<forall>x>z. F = F"
  by ((erule exE, erule exE,rule_tac x="max z za" in exI,simp)+,(rule_tac x="t" in exI,fastforce)+) simp_all

lemma inf_period:
  "\<lbrakk>\<forall>x k. P x = P (x - k*D); \<forall>x k. Q x = Q (x - k*D)\<rbrakk>
    \<Longrightarrow> \<forall>x k. (P x \<and> Q x) = (P (x - k*D) \<and> Q (x - k*D))"
  "\<lbrakk>\<forall>x k. P x = P (x - k*D); \<forall>x k. Q x = Q (x - k*D)\<rbrakk>
    \<Longrightarrow> \<forall>x k. (P x \<or> Q x) = (P (x - k*D) \<or> Q (x - k*D))"
  "(d::'a::{comm_ring,Rings.dvd}) dvd D \<Longrightarrow> \<forall>x k. (d dvd x + t) = (d dvd (x - k*D) + t)"
  "(d::'a::{comm_ring,Rings.dvd}) dvd D \<Longrightarrow> \<forall>x k. (\<not>d dvd x + t) = (\<not>d dvd (x - k*D) + t)"
  "\<forall>x k. F = F"
apply (auto elim!: dvdE simp add: algebra_simps)
unfolding mult.assoc [symmetric] distrib_right [symmetric] left_diff_distrib [symmetric]
unfolding dvd_def mult.commute [of d]
by auto

subsection\<open>The A and B sets\<close>
lemma bset:
  "\<lbrakk>\<forall>x.(\<forall>j \<in> {1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> P x \<longrightarrow> P(x - D) ;
     \<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> Q x \<longrightarrow> Q(x - D)\<rbrakk> \<Longrightarrow>
  \<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j) \<longrightarrow> (P x \<and> Q x) \<longrightarrow> (P(x - D) \<and> Q (x - D))"
  "\<lbrakk>\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> P x \<longrightarrow> P(x - D) ;
     \<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> Q x \<longrightarrow> Q(x - D)\<rbrakk> \<Longrightarrow>
  \<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (P x \<or> Q x) \<longrightarrow> (P(x - D) \<or> Q (x - D))"
  "\<lbrakk>D>0; t - 1\<in> B\<rbrakk> \<Longrightarrow> (\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x = t) \<longrightarrow> (x - D = t))"
  "\<lbrakk>D>0 ; t \<in> B\<rbrakk> \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x \<noteq> t) \<longrightarrow> (x - D \<noteq> t))"
  "D>0 \<Longrightarrow> (\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x < t) \<longrightarrow> (x - D < t))"
  "D>0 \<Longrightarrow> (\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x \<le> t) \<longrightarrow> (x - D \<le> t))"
  "\<lbrakk>D>0 ; t \<in> B\<rbrakk> \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x > t) \<longrightarrow> (x - D > t))"
  "\<lbrakk>D>0 ; t - 1 \<in> B\<rbrakk> \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x \<ge> t) \<longrightarrow> (x - D \<ge> t))"
  "d dvd D \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (d dvd x+t) \<longrightarrow> (d dvd (x - D) + t))"
  "d dvd D \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (\<not>d dvd x+t) \<longrightarrow> (\<not> d dvd (x - D) + t))"
  "\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j) \<longrightarrow> F \<longrightarrow> F"
proof (blast, blast)
  assume dp: "D > 0" and tB: "t - 1\<in> B"
  show "(\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x = t) \<longrightarrow> (x - D = t))"
    apply (rule allI, rule impI,erule ballE[where x="1"],erule ballE[where x="t - 1"])
    apply algebra using dp tB by simp_all
next
  assume dp: "D > 0" and tB: "t \<in> B"
  show "(\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x \<noteq> t) \<longrightarrow> (x - D \<noteq> t))"
    apply (rule allI, rule impI,erule ballE[where x="D"],erule ballE[where x="t"])
    apply algebra
    using dp tB by simp_all
next
  assume dp: "D > 0" thus "(\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x < t) \<longrightarrow> (x - D < t))" by arith
next
  assume dp: "D > 0" thus "\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x \<le> t) \<longrightarrow> (x - D \<le> t)" by arith
next
  assume dp: "D > 0" and tB:"t \<in> B"
  {fix x assume nob: "\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j" and g: "x > t" and ng: "\<not> (x - D) > t"
    hence "x -t \<le> D" and "1 \<le> x - t" by simp+
      hence "\<exists>j \<in> {1 .. D}. x - t = j" by auto
      hence "\<exists>j \<in> {1 .. D}. x = t + j" by (simp add: algebra_simps)
      with nob tB have "False" by simp}
  thus "\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x > t) \<longrightarrow> (x - D > t)" by blast
next
  assume dp: "D > 0" and tB:"t - 1\<in> B"
  {fix x assume nob: "\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j" and g: "x \<ge> t" and ng: "\<not> (x - D) \<ge> t"
    hence "x - (t - 1) \<le> D" and "1 \<le> x - (t - 1)" by simp+
      hence "\<exists>j \<in> {1 .. D}. x - (t - 1) = j" by auto
      hence "\<exists>j \<in> {1 .. D}. x = (t - 1) + j" by (simp add: algebra_simps)
      with nob tB have "False" by simp}
  thus "\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x \<ge> t) \<longrightarrow> (x - D \<ge> t)" by blast
next
  assume d: "d dvd D"
  {fix x assume H: "d dvd x + t" with d have "d dvd (x - D) + t" by algebra}
  thus "\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (d dvd x+t) \<longrightarrow> (d dvd (x - D) + t)" by simp
next
  assume d: "d dvd D"
  {fix x assume H: "\<not>(d dvd x + t)" with d have "\<not> d dvd (x - D) + t"
      by (clarsimp simp add: dvd_def,erule_tac x= "ka + k" in allE,simp add: algebra_simps)}
  thus "\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (\<not>d dvd x+t) \<longrightarrow> (\<not>d dvd (x - D) + t)" by auto
qed blast

lemma aset:
  "\<lbrakk>\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> P x \<longrightarrow> P(x + D) ;
     \<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> Q x \<longrightarrow> Q(x + D)\<rbrakk> \<Longrightarrow>
  \<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j) \<longrightarrow> (P x \<and> Q x) \<longrightarrow> (P(x + D) \<and> Q (x + D))"
  "\<lbrakk>\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> P x \<longrightarrow> P(x + D) ;
     \<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> Q x \<longrightarrow> Q(x + D)\<rbrakk> \<Longrightarrow>
  \<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (P x \<or> Q x) \<longrightarrow> (P(x + D) \<or> Q (x + D))"
  "\<lbrakk>D>0; t + 1\<in> A\<rbrakk> \<Longrightarrow> (\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x = t) \<longrightarrow> (x + D = t))"
  "\<lbrakk>D>0 ; t \<in> A\<rbrakk> \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x \<noteq> t) \<longrightarrow> (x + D \<noteq> t))"
  "\<lbrakk>D>0; t\<in> A\<rbrakk> \<Longrightarrow>(\<forall>(x::int). (\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x < t) \<longrightarrow> (x + D < t))"
  "\<lbrakk>D>0; t + 1 \<in> A\<rbrakk> \<Longrightarrow> (\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x \<le> t) \<longrightarrow> (x + D \<le> t))"
  "D>0 \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x > t) \<longrightarrow> (x + D > t))"
  "D>0 \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x \<ge> t) \<longrightarrow> (x + D \<ge> t))"
  "d dvd D \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (d dvd x+t) \<longrightarrow> (d dvd (x + D) + t))"
  "d dvd D \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (\<not>d dvd x+t) \<longrightarrow> (\<not> d dvd (x + D) + t))"
  "\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j) \<longrightarrow> F \<longrightarrow> F"
proof (blast, blast)
  assume dp: "D > 0" and tA: "t + 1 \<in> A"
  show "(\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x = t) \<longrightarrow> (x + D = t))"
    apply (rule allI, rule impI,erule ballE[where x="1"],erule ballE[where x="t + 1"])
    using dp tA by simp_all
next
  assume dp: "D > 0" and tA: "t \<in> A"
  show "(\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x \<noteq> t) \<longrightarrow> (x + D \<noteq> t))"
    apply (rule allI, rule impI,erule ballE[where x="D"],erule ballE[where x="t"])
    using dp tA by simp_all
next
  assume dp: "D > 0" thus "(\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x > t) \<longrightarrow> (x + D > t))" by arith
next
  assume dp: "D > 0" thus "\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x \<ge> t) \<longrightarrow> (x + D \<ge> t)" by arith
next
  assume dp: "D > 0" and tA:"t \<in> A"
  {fix x assume nob: "\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j" and g: "x < t" and ng: "\<not> (x + D) < t"
    hence "t - x \<le> D" and "1 \<le> t - x" by simp+
      hence "\<exists>j \<in> {1 .. D}. t - x = j" by auto
      hence "\<exists>j \<in> {1 .. D}. x = t - j" by (auto simp add: algebra_simps)
      with nob tA have "False" by simp}
  thus "\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x < t) \<longrightarrow> (x + D < t)" by blast
next
  assume dp: "D > 0" and tA:"t + 1\<in> A"
  {fix x assume nob: "\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j" and g: "x \<le> t" and ng: "\<not> (x + D) \<le> t"
    hence "(t + 1) - x \<le> D" and "1 \<le> (t + 1) - x" by (simp_all add: algebra_simps)
      hence "\<exists>j \<in> {1 .. D}. (t + 1) - x = j" by auto
      hence "\<exists>j \<in> {1 .. D}. x = (t + 1) - j" by (auto simp add: algebra_simps)
      with nob tA have "False" by simp}
  thus "\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x \<le> t) \<longrightarrow> (x + D \<le> t)" by blast
next
  assume d: "d dvd D"
  {fix x assume H: "d dvd x + t" with d have "d dvd (x + D) + t"
      by (clarsimp simp add: dvd_def,rule_tac x= "ka + k" in exI,simp add: algebra_simps)}
  thus "\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (d dvd x+t) \<longrightarrow> (d dvd (x + D) + t)" by simp
next
  assume d: "d dvd D"
  {fix x assume H: "\<not>(d dvd x + t)" with d have "\<not>d dvd (x + D) + t"
      by (clarsimp simp add: dvd_def,erule_tac x= "ka - k" in allE,simp add: algebra_simps)}
  thus "\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (\<not>d dvd x+t) \<longrightarrow> (\<not>d dvd (x + D) + t)" by auto
qed blast

subsection\<open>Cooper's Theorem \<open>-\<infinity>\<close> and \<open>+\<infinity>\<close> Version\<close>

subsubsection\<open>First some trivial facts about periodic sets or predicates\<close>
lemma periodic_finite_ex:
  assumes dpos: "(0::int) < d" and modd: "\<forall>x k. P x = P(x - k*d)"
  shows "(\<exists>x. P x) = (\<exists>j \<in> {1..d}. P j)"
  (is "?LHS = ?RHS")
proof
  assume ?LHS
  then obtain x where P: "P x" ..
  have "x mod d = x - (x div d)*d" by(simp add:mult_div_mod_eq [symmetric] ac_simps eq_diff_eq)
  hence Pmod: "P x = P(x mod d)" using modd by simp
  show ?RHS
  proof (cases)
    assume "x mod d = 0"
    hence "P 0" using P Pmod by simp
    moreover have "P 0 = P(0 - (-1)*d)" using modd by blast
    ultimately have "P d" by simp
    moreover have "d \<in> {1..d}" using dpos by simp
    ultimately show ?RHS ..
  next
    assume not0: "x mod d \<noteq> 0"
    have "P(x mod d)" using dpos P Pmod by simp
    moreover have "x mod d \<in> {1..d}"
    proof -
      from dpos have "0 \<le> x mod d" by(rule pos_mod_sign)
      moreover from dpos have "x mod d < d" by(rule pos_mod_bound)
      ultimately show ?thesis using not0 by simp
    qed
    ultimately show ?RHS ..
  qed
qed auto

subsubsection\<open>The \<open>-\<infinity>\<close> Version\<close>

lemma decr_lemma: "0 < (d::int) \<Longrightarrow> x - (\<bar>x - z\<bar> + 1) * d < z"
  by (induct rule: int_gr_induct) (simp_all add: int_distrib)

lemma incr_lemma: "0 < (d::int) \<Longrightarrow> z < x + (\<bar>x - z\<bar> + 1) * d"
  by (induct rule: int_gr_induct) (simp_all add: int_distrib)

lemma decr_mult_lemma:
  assumes dpos: "(0::int) < d" and minus: "\<forall>x. P x \<longrightarrow> P(x - d)" and knneg: "0 <= k"
  shows "\<forall>x. P x \<longrightarrow> P(x - k*d)"
using knneg
proof (induct rule:int_ge_induct)
  case base thus ?case by simp
next
  case (step i)
  {fix x
    have "P x \<longrightarrow> P (x - i * d)" using step.hyps by blast
    also have "\<dots> \<longrightarrow> P(x - (i + 1) * d)" using minus[THEN spec, of "x - i * d"]
      by (simp add: algebra_simps)
    ultimately have "P x \<longrightarrow> P(x - (i + 1) * d)" by blast}
  thus ?case ..
qed

lemma  minusinfinity:
  assumes dpos: "0 < d" and
    P1eqP1: "\<forall>x k. P1 x = P1(x - k*d)" and ePeqP1: "\<exists>z::int. \<forall>x. x < z \<longrightarrow> (P x = P1 x)"
  shows "(\<exists>x. P1 x) \<longrightarrow> (\<exists>x. P x)"
proof
  assume eP1: "\<exists>x. P1 x"
  then obtain x where P1: "P1 x" ..
  from ePeqP1 obtain z where P1eqP: "\<forall>x. x < z \<longrightarrow> (P x = P1 x)" ..
  let ?w = "x - (\<bar>x - z\<bar> + 1) * d"
  from dpos have w: "?w < z" by(rule decr_lemma)
  have "P1 x = P1 ?w" using P1eqP1 by blast
  also have "\<dots> = P(?w)" using w P1eqP by blast
  finally have "P ?w" using P1 by blast
  thus "\<exists>x. P x" ..
qed

lemma cpmi:
  assumes dp: "0 < D" and p1:"\<exists>z. \<forall> x< z. P x = P' x"
  and nb:"\<forall>x.(\<forall> j\<in> {1..D}. \<forall>(b::int) \<in> B. x \<noteq> b+j) \<longrightarrow> P (x) \<longrightarrow> P (x - D)"
  and pd: "\<forall> x k. P' x = P' (x-k*D)"
  shows "(\<exists>x. P x) = ((\<exists>j \<in> {1..D} . P' j) \<or> (\<exists>j \<in> {1..D}. \<exists> b \<in> B. P (b+j)))"
         (is "?L = (?R1 \<or> ?R2)")
proof-
 {assume "?R2" hence "?L"  by blast}
 moreover
 {assume H:"?R1" hence "?L" using minusinfinity[OF dp pd p1] periodic_finite_ex[OF dp pd] by simp}
 moreover
 { fix x
   assume P: "P x" and H: "\<not> ?R2"
   {fix y assume "\<not> (\<exists>j\<in>{1..D}. \<exists>b\<in>B. P (b + j))" and P: "P y"
     hence "\<not>(\<exists>(j::int) \<in> {1..D}. \<exists>(b::int) \<in> B. y = b+j)" by auto
     with nb P  have "P (y - D)" by auto }
   hence "\<forall>x. \<not>(\<exists>(j::int) \<in> {1..D}. \<exists>(b::int) \<in> B. P(b+j)) \<longrightarrow> P (x) \<longrightarrow> P (x - D)" by blast
   with H P have th: " \<forall>x. P x \<longrightarrow> P (x - D)" by auto
   from p1 obtain z where z: "\<forall>x. x < z \<longrightarrow> (P x = P' x)" by blast
   let ?y = "x - (\<bar>x - z\<bar> + 1)*D"
   have zp: "0 <= (\<bar>x - z\<bar> + 1)" by arith
   from dp have yz: "?y < z" using decr_lemma[OF dp] by simp
   from z[rule_format, OF yz] decr_mult_lemma[OF dp th zp, rule_format, OF P] have th2: " P' ?y" by auto
   with periodic_finite_ex[OF dp pd]
   have "?R1" by blast}
 ultimately show ?thesis by blast
qed

subsubsection \<open>The \<open>+\<infinity>\<close> Version\<close>

lemma  plusinfinity:
  assumes dpos: "(0::int) < d" and
    P1eqP1: "\<forall>x k. P' x = P'(x - k*d)" and ePeqP1: "\<exists> z. \<forall> x>z. P x = P' x"
  shows "(\<exists> x. P' x) \<longrightarrow> (\<exists> x. P x)"
proof
  assume eP1: "\<exists>x. P' x"
  then obtain x where P1: "P' x" ..
  from ePeqP1 obtain z where P1eqP: "\<forall>x>z. P x = P' x" ..
  let ?w' = "x + (\<bar>x - z\<bar> + 1) * d"
  let ?w = "x - (- (\<bar>x - z\<bar> + 1)) * d"
  have ww'[simp]: "?w = ?w'" by (simp add: algebra_simps)
  from dpos have w: "?w > z" by(simp only: ww' incr_lemma)
  hence "P' x = P' ?w" using P1eqP1 by blast
  also have "\<dots> = P(?w)" using w P1eqP by blast
  finally have "P ?w" using P1 by blast
  thus "\<exists>x. P x" ..
qed

lemma incr_mult_lemma:
  assumes dpos: "(0::int) < d" and plus: "\<forall>x::int. P x \<longrightarrow> P(x + d)" and knneg: "0 <= k"
  shows "\<forall>x. P x \<longrightarrow> P(x + k*d)"
using knneg
proof (induct rule:int_ge_induct)
  case base thus ?case by simp
next
  case (step i)
  {fix x
    have "P x \<longrightarrow> P (x + i * d)" using step.hyps by blast
    also have "\<dots> \<longrightarrow> P(x + (i + 1) * d)" using plus[THEN spec, of "x + i * d"]
      by (simp add:int_distrib ac_simps)
    ultimately have "P x \<longrightarrow> P(x + (i + 1) * d)" by blast}
  thus ?case ..
qed

lemma cppi:
  assumes dp: "0 < D" and p1:"\<exists>z. \<forall> x> z. P x = P' x"
  and nb:"\<forall>x.(\<forall> j\<in> {1..D}. \<forall>(b::int) \<in> A. x \<noteq> b - j) \<longrightarrow> P (x) \<longrightarrow> P (x + D)"
  and pd: "\<forall> x k. P' x= P' (x-k*D)"
  shows "(\<exists>x. P x) = ((\<exists>j \<in> {1..D} . P' j) \<or> (\<exists> j \<in> {1..D}. \<exists> b\<in> A. P (b - j)))" (is "?L = (?R1 \<or> ?R2)")
proof-
 {assume "?R2" hence "?L"  by blast}
 moreover
 {assume H:"?R1" hence "?L" using plusinfinity[OF dp pd p1] periodic_finite_ex[OF dp pd] by simp}
 moreover
 { fix x
   assume P: "P x" and H: "\<not> ?R2"
   {fix y assume "\<not> (\<exists>j\<in>{1..D}. \<exists>b\<in>A. P (b - j))" and P: "P y"
     hence "\<not>(\<exists>(j::int) \<in> {1..D}. \<exists>(b::int) \<in> A. y = b - j)" by auto
     with nb P  have "P (y + D)" by auto }
   hence "\<forall>x. \<not>(\<exists>(j::int) \<in> {1..D}. \<exists>(b::int) \<in> A. P(b-j)) \<longrightarrow> P (x) \<longrightarrow> P (x + D)" by blast
   with H P have th: " \<forall>x. P x \<longrightarrow> P (x + D)" by auto
   from p1 obtain z where z: "\<forall>x. x > z \<longrightarrow> (P x = P' x)" by blast
   let ?y = "x + (\<bar>x - z\<bar> + 1)*D"
   have zp: "0 <= (\<bar>x - z\<bar> + 1)" by arith
   from dp have yz: "?y > z" using incr_lemma[OF dp] by simp
   from z[rule_format, OF yz] incr_mult_lemma[OF dp th zp, rule_format, OF P] have th2: " P' ?y" by auto
   with periodic_finite_ex[OF dp pd]
   have "?R1" by blast}
 ultimately show ?thesis by blast
qed

lemma simp_from_to: "{i..j::int} = (if j < i then {} else insert i {i+1..j})"
apply(simp add:atLeastAtMost_def atLeast_def atMost_def)
apply(fastforce)
done

theorem unity_coeff_ex: "(\<exists>(x::'a::{semiring_0,Rings.dvd}). P (l * x)) \<equiv> (\<exists>x. l dvd (x + 0) \<and> P x)"
  apply (rule eq_reflection [symmetric])
  apply (rule iffI)
  defer
  apply (erule exE)
  apply (rule_tac x = "l * x" in exI)
  apply (simp add: dvd_def)
  apply (rule_tac x = x in exI, simp)
  apply (erule exE)
  apply (erule conjE)
  apply simp
  apply (erule dvdE)
  apply (rule_tac x = k in exI)
  apply simp
  done

lemma zdvd_mono:
  fixes k m t :: int
  assumes "k \<noteq> 0"
  shows "m dvd t \<equiv> k * m dvd k * t"
  using assms by simp

lemma uminus_dvd_conv:
  fixes d t :: int
  shows "d dvd t \<equiv> - d dvd t" and "d dvd t \<equiv> d dvd - t"
  by simp_all

text \<open>\bigskip Theorems for transforming predicates on nat to predicates on \<open>int\<close>\<close>

lemma zdiff_int_split: "P (int (x - y)) =
  ((y \<le> x \<longrightarrow> P (int x - int y)) \<and> (x < y \<longrightarrow> P 0))"
  by (cases "y \<le> x") (simp_all add: of_nat_diff)

text \<open>
  \medskip Specific instances of congruence rules, to prevent
  simplifier from looping.\<close>

theorem imp_le_cong:
  "\<lbrakk>x = x'; 0 \<le> x' \<Longrightarrow> P = P'\<rbrakk> \<Longrightarrow> (0 \<le> (x::int) \<longrightarrow> P) = (0 \<le> x' \<longrightarrow> P')"
  by simp

theorem conj_le_cong:
  "\<lbrakk>x = x'; 0 \<le> x' \<Longrightarrow> P = P'\<rbrakk> \<Longrightarrow> (0 \<le> (x::int) \<and> P) = (0 \<le> x' \<and> P')"
  by (simp cong: conj_cong)

ML_file \<open>Tools/Qelim/cooper.ML\<close>

method_setup presburger = \<open>
  let
    fun keyword k = Scan.lift (Args.$$$ k -- Args.colon) >> K ()
    fun simple_keyword k = Scan.lift (Args.$$$ k) >> K ()
    val addN = "add"
    val delN = "del"
    val elimN = "elim"
    val any_keyword = keyword addN || keyword delN || simple_keyword elimN
    val thms = Scan.repeats (Scan.unless any_keyword Attrib.multi_thm)
  in
    Scan.optional (simple_keyword elimN >> K false) true --
    Scan.optional (keyword addN |-- thms) [] --
    Scan.optional (keyword delN |-- thms) [] >>
    (fn ((elim, add_ths), del_ths) => fn ctxt =>
      SIMPLE_METHOD' (Cooper.tac elim add_ths del_ths ctxt))
  end
\<close> "Cooper's algorithm for Presburger arithmetic"

declare mod_eq_0_iff_dvd [presburger]
declare mod_by_Suc_0 [presburger]
declare mod_0 [presburger]
declare mod_by_1 [presburger]
declare mod_self [presburger]
declare div_by_0 [presburger]
declare mod_by_0 [presburger]
declare mod_div_trivial [presburger]
declare mult_div_mod_eq [presburger]
declare div_mult_mod_eq [presburger]
declare mod_mult_self1 [presburger]
declare mod_mult_self2 [presburger]
declare mod2_Suc_Suc [presburger]
declare not_mod_2_eq_0_eq_1 [presburger]
declare nat_zero_less_power_iff [presburger]

lemma [presburger, algebra]: "m mod 2 = (1::nat) \<longleftrightarrow> \<not> 2 dvd m " by presburger
lemma [presburger, algebra]: "m mod 2 = Suc 0 \<longleftrightarrow> \<not> 2 dvd m " by presburger
lemma [presburger, algebra]: "m mod (Suc (Suc 0)) = (1::nat) \<longleftrightarrow> \<not> 2 dvd m " by presburger
lemma [presburger, algebra]: "m mod (Suc (Suc 0)) = Suc 0 \<longleftrightarrow> \<not> 2 dvd m " by presburger
lemma [presburger, algebra]: "m mod 2 = (1::int) \<longleftrightarrow> \<not> 2 dvd m " by presburger

context semiring_parity
begin

declare even_mult_iff [presburger]

declare even_power [presburger]

lemma [presburger]:
  "even (a + b) \<longleftrightarrow> even a \<and> even b \<or> odd a \<and> odd b"
  by auto

end

context ring_parity
begin

declare even_minus [presburger]

end

context linordered_idom
begin

declare zero_le_power_eq [presburger]

declare zero_less_power_eq [presburger]

declare power_less_zero_eq [presburger]

declare power_le_zero_eq [presburger]

end

declare even_Suc [presburger]

lemma [presburger]:
  "Suc n div Suc (Suc 0) = n div Suc (Suc 0) \<longleftrightarrow> even n"
  by presburger

declare even_diff_nat [presburger]

lemma [presburger]:
  fixes k :: int
  shows "(k + 1) div 2 = k div 2 \<longleftrightarrow> even k"
  by presburger

lemma [presburger]:
  fixes k :: int
  shows "(k + 1) div 2 = k div 2 + 1 \<longleftrightarrow> odd k"
  by presburger

lemma [presburger]:
  "even n \<longleftrightarrow> even (int n)"
  by simp

subsection \<open>Nice facts about division by \<^term>\<open>4\<close>\<close>

lemma even_even_mod_4_iff:
  "even (n::nat) \<longleftrightarrow> even (n mod 4)"
  by presburger

lemma odd_mod_4_div_2:
  "n mod 4 = (3::nat) \<Longrightarrow> odd ((n - Suc 0) div 2)"
  by presburger

lemma even_mod_4_div_2:
  "n mod 4 = Suc 0 \<Longrightarrow> even ((n - Suc 0) div 2)"
  by presburger

subsection \<open>Try0\<close>

ML_file \<open>Tools/try0.ML\<close>

end


(* Title: Propositional Hoare Logic
   Author: Peixin You
*)

section \<open>Propositional Hoare Logic\<close>

theory PHL
  imports KAT

begin

subsection \<open>Deriving the rules of PHL in KAT\<close>

context kat
begin

definition Ho :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "Ho p x q = (\<tau> p \<cdot> x \<le> x \<cdot> \<tau> q)"

definition while_inv :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("while _ inv _ do _ od" [64,64,64] 63) where
  "while p inv i do x od = while p do x od"

lemma H_abort: "Ho p 0 q"
  unfolding Ho_def by simp

lemma H_skip: "Ho p 1 p"
  unfolding Ho_def by simp

lemma H_cons:
  assumes "\<tau> p \<le> \<tau> p'"
  and "Ho p' x q'"
  and "\<tau> q' \<le> \<tau> q"
shows "Ho p x q"
proof-
  have  "\<tau> p' \<cdot> x \<le> x \<cdot> \<tau> q'"
    using Ho_def assms by blast
  hence "\<tau> p \<cdot> x \<le> x \<cdot> \<tau> q"
    by (meson assms dual_order.trans mult_isol mult_isor)
  thus "Ho p x q"
    unfolding Ho_def.
qed

lemma H_seq:
  assumes "Ho r y q"
  and "Ho p x r"
  shows "Ho p (x \<cdot> y) q"
proof-
  have a: "\<tau> p \<cdot> x \<le> x \<cdot> \<tau> r"
    using Ho_def assms pcorrect_if1 by simp
  have b: "\<tau> r \<cdot> y \<le> y \<cdot> \<tau> q"
    using Ho_def assms pcorrect_if1 by simp
  hence "\<tau> p \<cdot> (x \<cdot> y) \<le> x \<cdot> \<tau> r \<cdot> y"
    by (metis a local.mult_assoc local.mult_isor)
  also have "\<dots> \<le> (x \<cdot> y) \<cdot> \<tau> q"
    by (simp add: b local.mult_assoc local.mult_isol)
  finally show "Ho p (x \<cdot> y) q"
    unfolding Ho_def.
qed

lemma H_cond:
  assumes "Ho (\<tau> p \<cdot> \<tau> r) x q"
  and "Ho (\<tau> p \<cdot> \<alpha> r) y q"
  shows "Ho p (if r then x else y fi) q"
proof-
  have a: "\<tau> p \<cdot> \<tau> r \<cdot> x \<le> x \<cdot> \<tau> q"
    by (metis Ho_def assms a_de_morgan2 t_a_var)
  have b: "\<tau> p \<cdot> \<alpha> r \<cdot> y \<le> y \<cdot> \<tau> q"
    using Ho_def assms t_mult_closed test_def by simp
  hence "\<tau> p \<cdot> (\<tau> r \<cdot> x + \<alpha> r \<cdot> y) = \<tau> p \<cdot> \<tau> r \<cdot> x + \<tau> p \<cdot> \<alpha> r \<cdot> y"
    by (simp add: distl mult_assoc)
  hence "\<tau> p \<cdot> (\<tau> r \<cdot> x + \<alpha> r \<cdot> y) = \<tau> r \<cdot> \<tau> p \<cdot> \<tau> r \<cdot> x + \<alpha> r \<cdot> \<tau> p \<cdot> \<alpha> r \<cdot> y"
    by (metis a_comm a_idem mult_assoc test_def)
  also have "\<dots> \<le> \<tau> r \<cdot> x \<cdot> \<tau> q + \<alpha> r \<cdot> y \<cdot> \<tau> q"
    using a b add_iso mult_assoc mult_isol by simp
  also have "\<dots> = (\<tau> r \<cdot> x + \<alpha> r \<cdot> y) \<cdot> \<tau> q"
    by (simp add: distr)
  finally show "Ho p (if r then x else y fi) q"
    unfolding Ho_def cond_def.
qed

lemma H_cond_iff: "Ho p (if r then x else y fi) q = (Ho (\<tau> p \<cdot> \<tau> r) x q \<and> Ho (\<tau> p \<cdot> \<alpha> r) y q)"
proof
  assume h: "Ho p (if r then x else y fi) q"
  hence "\<tau> p \<cdot> \<tau> r \<cdot> x  \<le> \<tau> r \<cdot> x \<cdot> \<tau> q + \<alpha> r \<cdot> y \<cdot> \<tau> q"
    by (simp add: Ho_def add_lub distl distr cond_def mult_assoc)
  hence "\<tau> p \<cdot> \<tau> r \<cdot> x  \<le> \<tau> r \<cdot> \<tau> r \<cdot> x \<cdot> \<tau> q + \<tau> r \<cdot> \<alpha> r \<cdot> y \<cdot> \<tau> q"
    by (smt distl mult_assoc order_def a_comm a_idem test_def)
  also have "\<dots> \<le> x \<cdot> \<tau> q"
    by (metis a_de_morgan2 add_0_right add_idem annil mult_assoc pcorrect_if3 t_at_compl2 test_def)
  finally have a: "Ho (\<tau> p \<cdot> \<tau> r) x q"
    using Ho_def t_mult_closed test_def by simp
  have "\<tau> p \<cdot> \<alpha> r \<cdot> y \<le> \<tau> r \<cdot> x \<cdot> \<tau> q + \<alpha> r \<cdot> y \<cdot> \<tau> q"
    using Ho_def h add_lub distl distr cond_def mult_assoc by auto
  hence "\<tau> p \<cdot> \<alpha> r \<cdot> y \<le> \<alpha> r \<cdot> \<tau> r \<cdot> x \<cdot> \<tau> q + \<alpha> r \<cdot> \<alpha> r \<cdot> y \<cdot> \<tau> q"
    by (smt a_comm a_idem distl mult_assoc order_def test_def)
  also have "\<dots> \<le> y \<cdot> \<tau> q"
    by (metis add_commute a_absorb2 a_idem add_0_left annil distr mult_1_left order_def test_def test_mult_comp test_one)
  finally have "Ho (\<tau> p \<cdot> \<alpha> r) y q"
    using Ho_def t_mult_closed test_def by auto
  thus "Ho (\<tau> p \<cdot> \<tau> r) x q \<and> Ho (\<tau> p \<cdot> \<alpha> r) y q"
    using a by blast
next
  show  "Ho (\<tau> p \<cdot> \<tau> r) x q \<and> Ho (\<tau> p \<cdot> \<alpha> r) y q \<Longrightarrow> Ho p (if r then x else y fi) q"
    by (simp add: H_cond)
qed

lemma H_while:
  assumes "Ho (\<tau> p \<cdot> \<tau> r) x p"
  shows "Ho p (while r do x od) (\<tau> p \<cdot> \<alpha> r)"
proof -
  have "\<tau> p \<cdot> \<tau> r \<cdot> x \<le> \<tau> r \<cdot> x \<cdot> \<tau> p"
    by (metis Ho_def assms mult_assoc pcorrect_iff1 t_mult_closed test_def)
  hence "\<tau> p \<cdot> (\<tau> r \<cdot> x)\<^sup>\<star> \<cdot> \<alpha> r \<le> (\<tau> r \<cdot> x)\<^sup>\<star> \<cdot> \<tau> p \<cdot> \<alpha> r"
    by (metis mult_isor star_sim1 mult_assoc)
  also have "\<dots> = (\<tau> r \<cdot> x)\<^sup>\<star> \<cdot> \<alpha> r \<cdot> \<tau> p \<cdot> \<alpha> r"
    by (metis a_comm a_idem mult_assoc test_def)
  finally show ?thesis
    using Ho_def mult_assoc t_mult_closed test_def while_def by simp
qed

lemma H_inv:
  assumes "\<tau> p \<le> \<tau> i"
  and "Ho i x i"
  and "\<tau> i \<le> \<tau> q"
  shows "Ho p x q"
  using H_cons assms by blast

lemma H_inv_seq:
  assumes "Ho i x i"
  and "Ho j x j"
  shows "Ho (\<tau> i \<cdot> \<tau> j) x (\<tau> i \<cdot> \<tau> j)"
proof-
  have a: "\<tau> i \<cdot> x \<le> x \<cdot> \<tau> i"
    using Ho_def assms(1) by blast
  have "\<tau> j \<cdot> x \<le> x \<cdot> \<tau> j"
    using Ho_def assms(2) by presburger
  hence "\<tau> i \<cdot> \<tau> j \<cdot> x \<le> \<tau> i \<cdot> x \<cdot> \<tau> j"
    by (simp add: local.mult_assoc local.mult_isol)
  also have "\<dots> \<le> x \<cdot> \<tau> i \<cdot> \<tau> j"
    by (simp add: a local.mult_isor)
  finally show ?thesis
    by (metis Ho_def local.a_de_morgan2 local.mult_assoc local.t_a_var)
qed

lemma H_inv_add:
  assumes "Ho i x i"
  and "Ho j x j"
shows "Ho (\<tau> i + \<tau> j) x (\<tau> i + \<tau> j)"
  by (smt (z3) Ho_def assms(1) assms(2) local.a_de_morgan3 local.add_iso local.distl local.distr local.t_a_var)

lemma H_while_inv:
  assumes "\<tau> p \<le> \<tau> i"
  and "\<tau> i \<cdot> \<alpha> r \<le> \<tau> q"
  and "Ho (\<tau> i \<cdot> \<tau> r) x i"
shows "Ho p (while r inv i do x od) q"
  unfolding while_inv_def by (metis H_cons H_while assms t_mult_closed test_def)

end

subsection \<open>Hoare Triples in the Relational and State Transformer Model\<close>

text \<open>First we consider relations.\<close>

abbreviation rH :: "'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a pred \<Rightarrow> bool" ("H\<^sub>r") where
  "H\<^sub>r P R Q \<equiv> rel_kat.Ho \<lceil>P\<rceil>\<^sub>r R \<lceil>Q\<rceil>\<^sub>r"

abbreviation rcond :: "'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a rel" ("rif _ then _ else _ fi" [64,64,64] 63) where
  "rif P then R else S fi \<equiv> rel_kat.cond \<lceil>P\<rceil>\<^sub>r R S"

abbreviation rwhile :: "'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a rel" ("rwhile _ do _ od" [64,64] 63) where
  "rwhile P do R od \<equiv> rel_kat.while \<lceil>P\<rceil>\<^sub>r R"

abbreviation rwhile_inv :: "'a pred \<Rightarrow> 'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a rel" ("rwhile _ inv _ do _ od" [64,64,64] 63) where
  "rwhile P inv I do R od \<equiv> rel_kat.while_inv \<lceil>P\<rceil>\<^sub>r \<lceil>I\<rceil>\<^sub>r R"

lemma rH_unfold: "H\<^sub>r P R Q = (\<forall>x y. P x \<longrightarrow> (x,y) \<in> R \<longrightarrow> Q y)"
  unfolding p2r_def rel_kat.Ho_def rel_kat.test_def rel_atest_def by force

lemma rH_skip: "H\<^sub>r P Id Q = (\<forall>x. P x \<longrightarrow> Q x)"
  unfolding rH_unfold by simp

lemma rH_cons1:
  assumes  "H\<^sub>r P' R Q"
  and "\<forall>x. P x \<longrightarrow> P' x"
  shows "H\<^sub>r P R Q"
  unfolding rH_unfold by (meson assms rH_unfold)

lemma rH_cons2:
  assumes "H\<^sub>r P R Q'"
  and "\<forall>x. Q' x \<longrightarrow> Q x"
  shows "H\<^sub>r P R Q"
  unfolding rH_unfold by (meson assms rH_unfold)

lemma rH_cons:
  assumes "H\<^sub>r P' R Q'"
  and "\<forall>x. P x \<longrightarrow> P' x"
  and "\<forall>x. Q' x \<longrightarrow> Q x"
  shows "H\<^sub>r P R Q"
  unfolding rH_unfold by (meson assms rH_unfold)

lemma rH_cond [simp]: "(H\<^sub>r P (rif T then R else S fi) Q) = (H\<^sub>r (\<lambda>s. P s \<and> T s) R Q \<and> H\<^sub>r (\<lambda> s. P s \<and> \<not> T s) S Q)"
  by (simp add: rel_kat.H_cond_iff)

lemma rH_while_inv:
  assumes "H\<^sub>r (\<lambda>s. I s \<and> T s) R I"
  and "\<forall>x. P x \<longrightarrow> I x"
  and "\<forall>x. I x \<and> \<not> T x \<longrightarrow> Q x"
  shows "H\<^sub>r P (rwhile T inv I do R od) Q"
  by (rule rel_kat.H_while_inv, simp_all add: assms)

lemma rH_while:
  assumes "H\<^sub>r (\<lambda>s. P s \<and> T s) R P"
  shows "H\<^sub>r P (rwhile T do R od) (\<lambda>s. P s \<and> \<not> T s)"
proof-
  have "H\<^sub>r P (rwhile T inv P do R od) (\<lambda>s. P s \<and> \<not> T s)"
    by (rule rH_while_inv, simp_all add: assms)
  thus ?thesis
    by (simp add: rel_kat.while_inv_def)
qed

text \<open>Next we repeat the development with state transformers.\<close>

abbreviation Hs :: "'a pred \<Rightarrow> 'a sta \<Rightarrow> 'a pred \<Rightarrow> bool" ("H\<^sub>s") where
  "H\<^sub>s P f Q \<equiv> sta_kat.Ho \<lceil>P\<rceil>\<^sub>s f \<lceil>Q\<rceil>\<^sub>s"

abbreviation scond :: "'a pred \<Rightarrow> 'a sta \<Rightarrow> 'a sta \<Rightarrow> 'a sta" ("sif _ then _ else _ fi" [64,64,64] 63) where
  "sif P then f else g fi \<equiv> sta_kat.cond \<lceil>P\<rceil>\<^sub>s f g"

abbreviation swhile :: "'a pred \<Rightarrow> 'a sta \<Rightarrow> 'a sta" ("swhile _ do _ od" [64,64] 63) where
  "swhile P do f od \<equiv> sta_kat.while \<lceil>P\<rceil>\<^sub>s f"

abbreviation swhile_inv :: "'a pred \<Rightarrow> 'a pred \<Rightarrow> 'a sta \<Rightarrow> 'a sta" ("swhile _ inv _ do _ od" [64,64,64] 63) where
  "swhile P inv I do f od \<equiv> sta_kat.while_inv \<lceil>P\<rceil>\<^sub>s \<lceil>I\<rceil>\<^sub>s f"

lemma sH_unfold: "H\<^sub>s P f Q = (\<forall>x y. P x \<longrightarrow> y \<in> f x \<longrightarrow> Q y)"

  unfolding sta_kat.Ho_def p2s_def sta_kat.test_def sta_atest_def kleq_iff kcomp_iff by force

lemma sH_skip: "H\<^sub>s P \<eta> Q = (\<forall>x. P x \<longrightarrow> Q x)"
  unfolding sH_unfold by simp

lemma sH_cons1:
  assumes "H\<^sub>s P' f Q"
  and "\<forall>x. P x \<longrightarrow> P' x"
  shows "H\<^sub>s P f Q"
  unfolding sH_unfold by (meson assms sH_unfold)

lemma sH_cons2:
  assumes "H\<^sub>s P f Q'"
  and "\<forall>x. Q' x \<longrightarrow> Q x"
  shows "H\<^sub>s P f Q"
  unfolding sH_unfold by (meson assms sH_unfold)

lemma sH_cons:
  assumes "H\<^sub>s P' f Q'"
  and "\<forall>x. P x \<longrightarrow> P' x"
  and "\<forall>x. Q' x \<longrightarrow> Q x"
  shows "H\<^sub>s P f Q"
  unfolding sH_unfold by (meson assms sH_unfold)

lemma sH_cond [simp]: "(H\<^sub>s P (sif T then f else g fi) Q) = (H\<^sub>s (\<lambda>s. P s \<and> T s) f Q \<and> H\<^sub>s (\<lambda> s. P s \<and> \<not>T s) g Q)"
    by (simp add: sta_kat.H_cond_iff)

lemma sH_while_inv:
  assumes "H\<^sub>s (\<lambda>s. I s \<and> T s) f I"
  and "\<forall>s. P s \<longrightarrow> I s"
  and "\<forall>s. I s \<and> \<not> T s \<longrightarrow> Q s"
  shows "H\<^sub>s P (swhile T inv I do f od) Q"
  by (rule sta_kat.H_while_inv) (simp_all add: assms)

lemma sH_while:
  assumes "H\<^sub>s (\<lambda>s. P s \<and> T s) f P"
  shows "H\<^sub>s P (swhile T do f od) (\<lambda>s. P s \<and> \<not> T s)"
proof-
  have "H\<^sub>s P (swhile T inv P do f od) (\<lambda>s. P s \<and> \<not> T s)"
    by (rule sH_while_inv, simp_all add: assms)
  thus ?thesis
    by (simp add: sta_kat.while_inv_def)
qed

text \<open>We have taken care that the verification condition generation for relations and state transformers is the same.\<close>

end