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

section "The quality increases predicate"

theory Quality_Increases
imports Aodv_Predicates Fresher
begin

definition quality_increases :: "state \<Rightarrow> state \<Rightarrow> bool"
where "quality_increases \<xi> \<xi>' \<equiv> (\<forall>dip\<in>kD(rt \<xi>). dip \<in> kD(rt \<xi>') \<and> rt \<xi> \<sqsubseteq>\<^bsub>dip\<^esub> rt \<xi>')
                                               \<and> (\<forall>dip. sqn (rt \<xi>) dip \<le> sqn (rt \<xi>') dip)"

lemma quality_increasesI [intro!]:
  assumes "\<And>dip. dip \<in> kD(rt \<xi>) \<Longrightarrow> dip \<in> kD(rt \<xi>')"
      and "\<And>dip. \<lbrakk> dip \<in> kD(rt \<xi>); dip \<in> kD(rt \<xi>') \<rbrakk> \<Longrightarrow> rt \<xi> \<sqsubseteq>\<^bsub>dip\<^esub> rt \<xi>'"
      and "\<And>dip. sqn (rt \<xi>) dip \<le> sqn (rt \<xi>') dip"
    shows "quality_increases \<xi> \<xi>'"
  unfolding quality_increases_def using assms by clarsimp

lemma quality_increasesE [elim]:
    fixes dip
  assumes "quality_increases \<xi> \<xi>'"
      and "dip\<in>kD(rt \<xi>)"
      and "\<lbrakk> dip \<in> kD(rt \<xi>'); rt \<xi> \<sqsubseteq>\<^bsub>dip\<^esub> rt \<xi>'; sqn (rt \<xi>) dip \<le> sqn (rt \<xi>') dip \<rbrakk> \<Longrightarrow> R dip \<xi> \<xi>'"
    shows "R dip \<xi> \<xi>'"
  using assms unfolding quality_increases_def by clarsimp

lemma quality_increases_rt_fresherD [dest]:
    fixes ip
  assumes "quality_increases \<xi> \<xi>'"
      and "ip\<in>kD(rt \<xi>)"
    shows "rt \<xi> \<sqsubseteq>\<^bsub>ip\<^esub> rt \<xi>'"
  using assms by auto

lemma quality_increases_sqnE [elim]:
    fixes dip
  assumes "quality_increases \<xi> \<xi>'"
      and "sqn (rt \<xi>) dip \<le> sqn (rt \<xi>') dip \<Longrightarrow> R dip \<xi> \<xi>'"
    shows "R dip \<xi> \<xi>'"
  using assms unfolding quality_increases_def by clarsimp

lemma quality_increases_refl [intro, simp]: "quality_increases \<xi> \<xi>"
  by rule simp_all

lemma strictly_fresher_quality_increases_right [elim]:
    fixes \<sigma> \<sigma>' dip
  assumes "rt (\<sigma> i) \<sqsubset>\<^bsub>dip\<^esub> rt (\<sigma> nhip)"
      and qinc: "quality_increases (\<sigma> nhip) (\<sigma>' nhip)"
      and "dip\<in>kD(rt (\<sigma> nhip))"
    shows "rt (\<sigma> i) \<sqsubset>\<^bsub>dip\<^esub> rt (\<sigma>' nhip)"
  proof -
    from qinc have "rt (\<sigma> nhip) \<sqsubseteq>\<^bsub>dip\<^esub> rt (\<sigma>' nhip)" using \<open>dip\<in>kD(rt (\<sigma> nhip))\<close>
      by auto
    with \<open>rt (\<sigma> i) \<sqsubset>\<^bsub>dip\<^esub> rt (\<sigma> nhip)\<close> show ?thesis ..
  qed

lemma kD_quality_increases [elim]:
  assumes "i\<in>kD(rt \<xi>)"
      and "quality_increases \<xi> \<xi>'"
    shows "i\<in>kD(rt \<xi>')"
  using assms by auto

lemma kD_nsqn_quality_increases [elim]:
  assumes "i\<in>kD(rt \<xi>)"
      and "quality_increases \<xi> \<xi>'"
    shows "i\<in>kD(rt \<xi>') \<and> nsqn (rt \<xi>) i \<le> nsqn (rt \<xi>') i"
  proof -
    from assms have "i\<in>kD(rt \<xi>')" ..
    moreover with assms have "rt \<xi> \<sqsubseteq>\<^bsub>i\<^esub> rt \<xi>'" by auto
    ultimately have "nsqn (rt \<xi>) i \<le> nsqn (rt \<xi>') i"
      using \<open>i\<in>kD(rt \<xi>)\<close> by - (erule(2) rt_fresher_imp_nsqn_le)
    with \<open>i\<in>kD(rt \<xi>')\<close> show ?thesis ..
  qed

lemma nsqn_quality_increases [elim]:
  assumes "i\<in>kD(rt \<xi>)"
      and "quality_increases \<xi> \<xi>'"
    shows "nsqn (rt \<xi>) i \<le> nsqn (rt \<xi>') i"
  using assms by (rule kD_nsqn_quality_increases [THEN conjunct2])

lemma kD_nsqn_quality_increases_trans [elim]:
  assumes "i\<in>kD(rt \<xi>)"
      and "s \<le> nsqn (rt \<xi>) i"
      and "quality_increases \<xi> \<xi>'"
    shows "i\<in>kD(rt \<xi>') \<and> s \<le> nsqn (rt \<xi>') i"
  proof
    from \<open>i\<in>kD(rt \<xi>)\<close> and \<open>quality_increases \<xi> \<xi>'\<close> show "i\<in>kD(rt \<xi>')" ..
  next
    from \<open>i\<in>kD(rt \<xi>)\<close> and \<open>quality_increases \<xi> \<xi>'\<close> have "nsqn (rt \<xi>) i \<le> nsqn (rt \<xi>') i" ..
    with \<open>s \<le> nsqn (rt \<xi>) i\<close> show "s \<le> nsqn (rt \<xi>') i" by (rule le_trans)
  qed

lemma nsqn_quality_increases_nsqn_lt_lt [elim]:
  assumes "i\<in>kD(rt \<xi>)"
      and "quality_increases \<xi> \<xi>'"
     and "s < nsqn (rt \<xi>) i"
    shows "s < nsqn (rt \<xi>') i"
  proof -
    from assms(1-2) have "nsqn (rt \<xi>) i \<le> nsqn (rt \<xi>') i" ..
    with \<open>s < nsqn (rt \<xi>) i\<close> show "s < nsqn (rt \<xi>') i" by simp
  qed

lemma nsqn_quality_increases_dhops [elim]:
  assumes "i\<in>kD(rt \<xi>)"
      and "quality_increases \<xi> \<xi>'"
      and "nsqn (rt \<xi>) i = nsqn (rt \<xi>') i"
    shows "the (dhops (rt \<xi>) i) \<ge> the (dhops (rt \<xi>') i)"
  using assms unfolding quality_increases_def
  by (clarsimp) (drule(1) bspec, clarsimp simp: rt_fresher_def2)

lemma nsqn_quality_increases_nsqn_eq_le [elim]:
  assumes "i\<in>kD(rt \<xi>)"
      and "quality_increases \<xi> \<xi>'"
      and "s = nsqn (rt \<xi>) i"
    shows "s < nsqn (rt \<xi>') i \<or> (s = nsqn (rt \<xi>') i \<and> the (dhops (rt \<xi>) i) \<ge> the (dhops (rt \<xi>') i))"
  using assms by (metis nat_less_le nsqn_quality_increases nsqn_quality_increases_dhops)

lemma quality_increases_rreq_rrep_props [elim]:
    fixes sn ip hops sip
  assumes qinc: "quality_increases (\<sigma> sip) (\<sigma>' sip)"
      and "1 \<le> sn"
      and *: "ip\<in>kD(rt (\<sigma> sip)) \<and> sn \<le> nsqn (rt (\<sigma> sip)) ip
                                \<and> (nsqn (rt (\<sigma> sip)) ip = sn
                                    \<longrightarrow> (the (dhops (rt (\<sigma> sip)) ip) \<le> hops
                                          \<or> the (flag (rt (\<sigma> sip)) ip) = inv))"
    shows "ip\<in>kD(rt (\<sigma>' sip)) \<and> sn \<le> nsqn (rt (\<sigma>' sip)) ip
                              \<and> (nsqn (rt (\<sigma>' sip)) ip = sn
                                  \<longrightarrow> (the (dhops (rt (\<sigma>' sip)) ip) \<le> hops
                                        \<or> the (flag (rt (\<sigma>' sip)) ip) = inv))"
      (is "_ \<and> ?nsqnafter")
  proof -
    from *  obtain "ip\<in>kD(rt (\<sigma> sip))" and "sn \<le> nsqn (rt (\<sigma> sip)) ip" by auto

    from \<open>quality_increases (\<sigma> sip) (\<sigma>' sip)\<close>
       have "sqn (rt (\<sigma> sip)) ip \<le> sqn (rt (\<sigma>' sip)) ip" ..
    from \<open>quality_increases (\<sigma> sip) (\<sigma>' sip)\<close> and \<open>ip\<in>kD (rt (\<sigma> sip))\<close>
      have "ip\<in>kD (rt (\<sigma>' sip))" ..

    from \<open>sn \<le> nsqn (rt (\<sigma> sip)) ip\<close> have ?nsqnafter
    proof
      assume "sn < nsqn (rt (\<sigma> sip)) ip"
      also from \<open>ip\<in>kD(rt (\<sigma> sip))\<close> and \<open>quality_increases (\<sigma> sip) (\<sigma>' sip)\<close>
        have "... \<le> nsqn (rt (\<sigma>' sip)) ip" ..
      finally have "sn < nsqn (rt (\<sigma>' sip)) ip" .
      thus ?thesis by simp
    next
      assume "sn = nsqn (rt (\<sigma> sip)) ip"
      with \<open>ip\<in>kD(rt (\<sigma> sip))\<close> and \<open>quality_increases (\<sigma> sip) (\<sigma>' sip)\<close>
        have "sn < nsqn (rt (\<sigma>' sip)) ip
              \<or> (sn = nsqn (rt (\<sigma>' sip)) ip
                 \<and> the (dhops (rt (\<sigma>' sip)) ip) \<le> the (dhops (rt (\<sigma> sip)) ip))" ..
      hence "sn < nsqn (rt (\<sigma>' sip)) ip
              \<or> (nsqn (rt (\<sigma>' sip)) ip = sn \<and> (the (dhops (rt (\<sigma>' sip)) ip) \<le> hops
                                                 \<or> the (flag (rt (\<sigma>' sip)) ip) = inv))"
      proof
        assume "sn < nsqn (rt (\<sigma>' sip)) ip" thus ?thesis ..
      next
        assume "sn = nsqn (rt (\<sigma>' sip)) ip
                \<and> the (dhops (rt (\<sigma> sip)) ip) \<ge> the (dhops (rt (\<sigma>' sip)) ip)"
        hence "sn = nsqn (rt (\<sigma>' sip)) ip"
          and "the (dhops (rt (\<sigma>' sip)) ip) \<le> the (dhops (rt (\<sigma> sip)) ip)" by auto

        from * and \<open>sn = nsqn (rt (\<sigma> sip)) ip\<close> have "the (dhops (rt (\<sigma> sip)) ip) \<le> hops
                                                       \<or> the (flag (rt (\<sigma> sip)) ip) = inv"
          by simp
        thus ?thesis
        proof
          assume "the (dhops (rt (\<sigma> sip)) ip) \<le> hops"
          with  \<open>the (dhops (rt (\<sigma>' sip)) ip) \<le> the (dhops (rt (\<sigma> sip)) ip)\<close>
           have "the (dhops (rt (\<sigma>' sip)) ip) \<le> hops" by simp
          with \<open>sn = nsqn (rt (\<sigma>' sip)) ip\<close> show ?thesis by simp
        next
          assume "the (flag (rt (\<sigma> sip)) ip) = inv"
          with \<open>ip\<in>kD(rt (\<sigma> sip))\<close> have "nsqn (rt (\<sigma> sip)) ip = sqn (rt (\<sigma> sip)) ip - 1" ..

          with \<open>sn \<ge> 1\<close> and \<open>sn = nsqn (rt (\<sigma> sip)) ip\<close>
            have "sqn (rt (\<sigma> sip)) ip > 1" by simp

          from \<open>ip\<in>kD(rt (\<sigma>' sip))\<close> show ?thesis
          proof (rule vD_or_iD)
            assume "ip\<in>iD(rt (\<sigma>' sip))"
            hence "the (flag (rt (\<sigma>' sip)) ip) = inv" ..
            with \<open>sn = nsqn (rt (\<sigma>' sip)) ip\<close> show ?thesis
              by simp
          next
            (* the tricky case: sn = nsqn (rt (\<sigma>' sip)) ip
                                \<and> ip\<in>iD(rt (\<sigma> sip))
                                \<and> ip\<in>vD(rt (\<sigma>' sip)) *)
            assume "ip\<in>vD(rt (\<sigma>' sip))"
            hence "nsqn (rt (\<sigma>' sip)) ip = sqn (rt (\<sigma>' sip)) ip" ..
            with \<open>sqn (rt (\<sigma> sip)) ip \<le> sqn (rt (\<sigma>' sip)) ip\<close>
              have "nsqn (rt (\<sigma>' sip)) ip \<ge> sqn (rt (\<sigma> sip)) ip" by simp

            with \<open>sqn (rt (\<sigma> sip)) ip > 1\<close>
              have "nsqn (rt (\<sigma>' sip)) ip > sqn (rt (\<sigma> sip)) ip - 1" by simp
            with \<open>nsqn (rt (\<sigma> sip)) ip = sqn (rt (\<sigma> sip)) ip - 1\<close>
              have "nsqn (rt (\<sigma>' sip)) ip > nsqn (rt (\<sigma> sip)) ip" by simp
            with \<open>sn = nsqn (rt (\<sigma> sip)) ip\<close> have "nsqn (rt (\<sigma>' sip)) ip > sn"
              by simp
            thus ?thesis ..
          qed
        qed
      qed
      thus ?thesis by (metis (mono_tags) le_cases not_le)
    qed
    with \<open>ip\<in>kD (rt (\<sigma>' sip))\<close> show "ip\<in>kD (rt (\<sigma>' sip)) \<and> ?nsqnafter" ..
  qed

lemma quality_increases_rreq_rrep_props':
    fixes sn ip hops sip
  assumes "\<forall>j. quality_increases (\<sigma> j) (\<sigma>' j)"
      and "1 \<le> sn"
      and *: "ip\<in>kD(rt (\<sigma> sip)) \<and> sn \<le> nsqn (rt (\<sigma> sip)) ip
                                \<and> (nsqn (rt (\<sigma> sip)) ip = sn
                                    \<longrightarrow> (the (dhops (rt (\<sigma> sip)) ip) \<le> hops
                                          \<or> the (flag (rt (\<sigma> sip)) ip) = inv))"
    shows "ip\<in>kD(rt (\<sigma>' sip)) \<and> sn \<le> nsqn (rt (\<sigma>' sip)) ip
                              \<and> (nsqn (rt (\<sigma>' sip)) ip = sn
                                  \<longrightarrow> (the (dhops (rt (\<sigma>' sip)) ip) \<le> hops
                                        \<or> the (flag (rt (\<sigma>' sip)) ip) = inv))"
  proof -
    from assms(1) have "quality_increases (\<sigma> sip) (\<sigma>' sip)" ..
    thus ?thesis using assms(2-3) by (rule quality_increases_rreq_rrep_props)
  qed

lemma rteq_quality_increases:
  assumes "\<forall>j. j \<noteq> i \<longrightarrow> quality_increases (\<sigma> j) (\<sigma>' j)"
      and "rt (\<sigma>' i) = rt (\<sigma> i)"
    shows "\<forall>j. quality_increases (\<sigma> j) (\<sigma>' j)"
  using assms by clarsimp (metis order_refl quality_increasesI rt_fresher_refl)

definition msg_fresh :: "(ip \<Rightarrow> state) \<Rightarrow> msg \<Rightarrow> bool"
where "msg_fresh \<sigma> m \<equiv>
         case m of Rreq hopsc _ _ _ _ oipc osnc sipc \<Rightarrow> osnc \<ge> 1 \<and> (sipc \<noteq> oipc \<longrightarrow>
                       oipc\<in>kD(rt (\<sigma> sipc)) \<and> nsqn (rt (\<sigma> sipc)) oipc \<ge> osnc
                       \<and> (nsqn (rt (\<sigma> sipc)) oipc = osnc
                             \<longrightarrow> (hopsc \<ge> the (dhops (rt (\<sigma> sipc)) oipc)
                                  \<or> the (flag (rt (\<sigma> sipc)) oipc) = inv)))
                   | Rrep hopsc dipc dsnc _ sipc \<Rightarrow> dsnc \<ge> 1 \<and> (sipc \<noteq> dipc \<longrightarrow>
                       dipc\<in>kD(rt (\<sigma> sipc)) \<and> nsqn (rt (\<sigma> sipc)) dipc \<ge> dsnc
                       \<and> (nsqn (rt (\<sigma> sipc)) dipc = dsnc
                             \<longrightarrow> (hopsc \<ge> the (dhops (rt (\<sigma> sipc)) dipc)
                                   \<or> the (flag (rt (\<sigma> sipc)) dipc) = inv)))
                   | Rerr destsc sipc \<Rightarrow> (\<forall>ripc\<in>dom(destsc). (ripc\<in>kD(rt (\<sigma> sipc))
                                         \<and> the (destsc ripc) - 1 \<le> nsqn (rt (\<sigma> sipc)) ripc))
                   | _ \<Rightarrow> True"

lemma msg_fresh [simp]:
  "\<And>hops rreqid dip dsn dsk oip osn sip.
           msg_fresh \<sigma> (Rreq hops rreqid dip dsn dsk oip osn sip) =
                            (osn \<ge> 1 \<and> (sip \<noteq> oip \<longrightarrow> oip\<in>kD(rt (\<sigma> sip))
                                     \<and> nsqn (rt (\<sigma> sip)) oip \<ge> osn
                                     \<and> (nsqn (rt (\<sigma> sip)) oip = osn
                                           \<longrightarrow> (hops \<ge> the (dhops (rt (\<sigma> sip)) oip)
                                                \<or> the (flag (rt (\<sigma> sip)) oip) = inv))))"
  "\<And>hops dip dsn oip sip. msg_fresh \<sigma> (Rrep hops dip dsn oip sip) =
                            (dsn \<ge> 1 \<and> (sip \<noteq> dip \<longrightarrow> dip\<in>kD(rt (\<sigma> sip))
                                     \<and> nsqn (rt (\<sigma> sip)) dip \<ge> dsn
                                     \<and> (nsqn (rt (\<sigma> sip)) dip = dsn
                                           \<longrightarrow> (hops \<ge> the (dhops (rt (\<sigma> sip)) dip))
                                                 \<or> the (flag (rt (\<sigma> sip)) dip) = inv)))"
  "\<And>dests sip.            msg_fresh \<sigma> (Rerr dests sip) =
                            (\<forall>ripc\<in>dom(dests). (ripc\<in>kD(rt (\<sigma> sip))
                                     \<and> the (dests ripc) - 1 \<le> nsqn (rt (\<sigma> sip)) ripc))"
  "\<And>d dip.                msg_fresh \<sigma> (Newpkt d dip)   = True"
  "\<And>d dip sip.            msg_fresh \<sigma> (Pkt d dip sip)  = True"
  unfolding msg_fresh_def by simp_all

lemma msg_fresh_inc_sn [simp, elim]:
  "msg_fresh \<sigma> m \<Longrightarrow> rreq_rrep_sn m"
  by (cases m) simp_all

lemma recv_msg_fresh_inc_sn [simp, elim]:
  "orecvmsg (msg_fresh) \<sigma> m \<Longrightarrow> recvmsg rreq_rrep_sn m"
  by (cases m) simp_all

lemma rrep_nsqn_is_fresh [simp]:
  fixes \<sigma> msg hops dip dsn oip sip
  assumes "rreq_rrep_fresh (rt (\<sigma> sip)) (Rrep hops dip dsn oip sip)"
      and "rreq_rrep_sn (Rrep hops dip dsn oip sip)"
  shows "msg_fresh \<sigma> (Rrep hops dip dsn oip sip)"
        (is "msg_fresh \<sigma> ?msg")
  proof -
    let ?rt = "rt (\<sigma> sip)"
    from assms have "sip \<noteq> dip \<longrightarrow> dip\<in>kD(?rt) \<and> sqn ?rt dip = dsn \<and> the (flag ?rt dip) = val"
      by simp
    hence "sip \<noteq> dip \<longrightarrow> dip\<in>kD(?rt) \<and> nsqn ?rt dip \<ge> dsn"
    by clarsimp
    with assms show "msg_fresh \<sigma> ?msg"
      by clarsimp
  qed

lemma rerr_nsqn_is_fresh [simp]:
  fixes \<sigma> msg dests sip
  assumes "rerr_invalid (rt (\<sigma> sip)) (Rerr dests sip)"
  shows "msg_fresh \<sigma> (Rerr dests sip)"
        (is "msg_fresh \<sigma> ?msg")
  proof -
    let ?rt = "rt (\<sigma> sip)"
    from assms have *: "(\<forall>rip\<in>dom(dests). (rip\<in>iD(rt (\<sigma> sip))
                                     \<and> the (dests rip) = sqn (rt (\<sigma> sip)) rip))"
      by clarsimp
    have "(\<forall>rip\<in>dom(dests). (rip\<in>kD(rt (\<sigma> sip))
                                     \<and> the (dests rip) - 1 \<le> nsqn (rt (\<sigma> sip)) rip))"
    proof
      fix rip
      assume "rip \<in> dom dests"
      with * have "rip\<in>iD(rt (\<sigma> sip))" and "the (dests rip) = sqn (rt (\<sigma> sip)) rip"
        by auto

      from this(2) have "the (dests rip) - 1 = sqn (rt (\<sigma> sip)) rip - 1" by simp
      also have "... \<le> nsqn (rt (\<sigma> sip)) rip" by (rule sqn_nsqn)
      finally have "the (dests rip) - 1 \<le> nsqn (rt (\<sigma> sip)) rip" .

      with \<open>rip\<in>iD(rt (\<sigma> sip))\<close>
        show "rip\<in>kD(rt (\<sigma> sip)) \<and> the (dests rip) - 1 \<le> nsqn (rt (\<sigma> sip)) rip"
          by clarsimp
    qed
    thus "msg_fresh \<sigma> ?msg"
      by simp
  qed

lemma quality_increases_msg_fresh [elim]:
  assumes qinc: "\<forall>j. quality_increases (\<sigma> j) (\<sigma>' j)"
      and "msg_fresh \<sigma> m"
    shows "msg_fresh \<sigma>' m"
  using assms(2)
  proof (cases m)
    fix hops rreqid dip dsn dsk oip osn sip
    assume [simp]: "m = Rreq hops rreqid dip dsn dsk oip osn sip"
       and "msg_fresh \<sigma> m"
    then have "osn \<ge> 1" and "sip = oip \<or> (oip\<in>kD(rt (\<sigma> sip)) \<and> osn \<le> nsqn (rt (\<sigma> sip)) oip
                                           \<and> (nsqn (rt (\<sigma> sip)) oip = osn
                                                 \<longrightarrow> (the (dhops (rt (\<sigma> sip)) oip) \<le> hops
                                                      \<or> the (flag (rt (\<sigma> sip)) oip) = inv)))"
      by auto
    from this(2) show ?thesis
    proof
      assume "sip = oip" with \<open>osn \<ge> 1\<close> show ?thesis by simp
    next
      assume "oip\<in>kD(rt (\<sigma> sip)) \<and> osn \<le> nsqn (rt (\<sigma> sip)) oip
                                  \<and> (nsqn (rt (\<sigma> sip)) oip = osn
                                      \<longrightarrow> (the (dhops (rt (\<sigma> sip)) oip) \<le> hops
                                           \<or> the (flag (rt (\<sigma> sip)) oip) = inv))"
      moreover from qinc have "quality_increases (\<sigma> sip) (\<sigma>' sip)" ..
      ultimately have "oip\<in>kD(rt (\<sigma>' sip)) \<and> osn \<le> nsqn (rt (\<sigma>' sip)) oip
                                           \<and> (nsqn (rt (\<sigma>' sip)) oip = osn
                                              \<longrightarrow> (the (dhops (rt (\<sigma>' sip)) oip) \<le> hops
                                                    \<or> the (flag (rt (\<sigma>' sip)) oip) = inv))"
       using \<open>osn \<ge> 1\<close> by (rule quality_increases_rreq_rrep_props [rotated 2])
      with \<open>osn \<ge> 1\<close> show "msg_fresh \<sigma>' m"
        by (clarsimp)
    qed
  next
    fix hops dip dsn oip sip
    assume [simp]: "m = Rrep hops dip dsn oip sip"
       and "msg_fresh \<sigma> m"
    then have "dsn \<ge> 1" and "sip = dip \<or> (dip\<in>kD(rt (\<sigma> sip)) \<and> dsn \<le> nsqn (rt (\<sigma> sip)) dip
                                           \<and> (nsqn (rt (\<sigma> sip)) dip = dsn
                                                 \<longrightarrow> (the (dhops (rt (\<sigma> sip)) dip) \<le> hops
                                                      \<or> the (flag (rt (\<sigma> sip)) dip) = inv)))"
      by auto
    from this(2) show "?thesis"
    proof
      assume "sip = dip" with \<open>dsn \<ge> 1\<close> show ?thesis by simp
    next
      assume "dip\<in>kD(rt (\<sigma> sip)) \<and> dsn \<le> nsqn (rt (\<sigma> sip)) dip
                                  \<and> (nsqn (rt (\<sigma> sip)) dip = dsn
                                      \<longrightarrow> (the (dhops (rt (\<sigma> sip)) dip) \<le> hops
                                           \<or> the (flag (rt (\<sigma> sip)) dip) = inv))"
      moreover from qinc have "quality_increases (\<sigma> sip) (\<sigma>' sip)" ..
      ultimately have "dip\<in>kD(rt (\<sigma>' sip)) \<and> dsn \<le> nsqn (rt (\<sigma>' sip)) dip
                                           \<and> (nsqn (rt (\<sigma>' sip)) dip = dsn
                                              \<longrightarrow> (the (dhops (rt (\<sigma>' sip)) dip) \<le> hops
                                                    \<or> the (flag (rt (\<sigma>' sip)) dip) = inv))"
        using \<open>dsn \<ge> 1\<close> by (rule quality_increases_rreq_rrep_props [rotated 2])
      with \<open>dsn \<ge> 1\<close> show "msg_fresh \<sigma>' m"
        by clarsimp
    qed
  next
    fix dests sip
    assume [simp]: "m = Rerr dests sip"
       and "msg_fresh \<sigma> m"
    then have *: "\<forall>rip\<in>dom(dests). rip\<in>kD(rt (\<sigma> sip))
                              \<and> the (dests rip) - 1 \<le> nsqn (rt (\<sigma> sip)) rip"
      by simp
    have "\<forall>rip\<in>dom(dests). rip\<in>kD(rt (\<sigma>' sip))
                         \<and> the (dests rip) - 1 \<le> nsqn (rt (\<sigma>' sip)) rip"
      proof
        fix rip
        assume "rip\<in>dom(dests)"
        with * have "rip\<in>kD(rt (\<sigma> sip))" and "the (dests rip) - 1 \<le> nsqn (rt (\<sigma> sip)) rip"
          by - (drule(1) bspec, clarsimp)+
        moreover from qinc have "quality_increases (\<sigma> sip) (\<sigma>' sip)" by simp
        ultimately show "rip\<in>kD(rt (\<sigma>' sip)) \<and> the (dests rip) - 1 \<le> nsqn (rt (\<sigma>' sip)) rip" ..
      qed
    thus ?thesis by simp
  qed simp_all

end


section \<open>Executable PDDL Checker\<close>
theory PDDL_STRIPS_Checker
imports
  PDDL_STRIPS_Semantics

  Error_Monad_Add
  "HOL.String"

  (*"HOL-Library.Code_Char"     TODO: This might lead to performance loss! CHECK! *)
  "HOL-Library.Code_Target_Nat"

  "HOL-Library.While_Combinator"

  "Containers.Containers"
begin

subsection \<open>Generic DFS Reachability Checker\<close>
text \<open>Used for subtype checks\<close>

definition "E_of_succ succ \<equiv> { (u,v). v\<in>set (succ u) }"
lemma succ_as_E: "set (succ x) = E_of_succ succ `` {x}"
  unfolding E_of_succ_def by auto

context
  fixes succ :: "'a \<Rightarrow> 'a list"
begin

  private abbreviation (input) "E \<equiv> E_of_succ succ"

definition "dfs_reachable D w \<equiv>
  let (V,w,brk) = while (\<lambda>(V,w,brk). \<not>brk \<and> w\<noteq>[]) (\<lambda>(V,w,_).
    case w of v#w \<Rightarrow>
    if D v then (V,v#w,True)
    else if v\<in>V then (V,w,False)
    else
      let V = insert v V in
      let w = succ v @ w in
      (V,w,False)
    ) ({},w,False)
  in brk"

context
  fixes w\<^sub>0 :: "'a list"
  assumes finite_dfs_reachable[simp, intro!]: "finite (E\<^sup>* `` set w\<^sub>0)"
begin

  private abbreviation (input) "W\<^sub>0 \<equiv> set w\<^sub>0"

definition "dfs_reachable_invar D V W brk \<longleftrightarrow>
    W\<^sub>0 \<subseteq> W \<union> V
  \<and> W \<union> V \<subseteq> E\<^sup>* `` W\<^sub>0
  \<and> E``V \<subseteq> W \<union> V
  \<and> Collect D \<inter> V = {}
  \<and> (brk \<longrightarrow> Collect D \<inter> E\<^sup>* `` W\<^sub>0 \<noteq> {})"

lemma card_decreases: "
   \<lbrakk>finite V; y \<notin> V; dfs_reachable_invar D V (Set.insert y W) brk \<rbrakk>
   \<Longrightarrow> card (E\<^sup>* `` W\<^sub>0 - Set.insert y V) < card (E\<^sup>* `` W\<^sub>0 - V)"
  apply (rule psubset_card_mono)
  apply (auto simp: dfs_reachable_invar_def)
  done

lemma all_neq_Cons_is_Nil[simp]: (* Odd term remaining in goal \<dots> *)
  "(\<forall>y ys. x2 \<noteq> y # ys) \<longleftrightarrow> x2 = []" by (cases x2) auto

lemma dfs_reachable_correct: "dfs_reachable D w\<^sub>0 \<longleftrightarrow> Collect D \<inter> E\<^sup>* `` set w\<^sub>0 \<noteq> {}"
  unfolding dfs_reachable_def
  apply (rule while_rule[where
    P="\<lambda>(V,w,brk). dfs_reachable_invar D V (set w) brk \<and> finite V"
    and r="measure (\<lambda>V. card (E\<^sup>* `` (set w\<^sub>0) - V)) <*lex*> measure length <*lex*> measure (\<lambda>True\<Rightarrow>0 | False\<Rightarrow>1)"
    ])
  subgoal by (auto simp: dfs_reachable_invar_def)
  subgoal
    apply (auto simp: neq_Nil_conv succ_as_E[of succ] split: if_splits)
    by (auto simp: dfs_reachable_invar_def Image_iff intro: rtrancl.rtrancl_into_rtrancl)
  subgoal by (fastforce simp: dfs_reachable_invar_def dest: Image_closed_trancl)
  subgoal by blast
  subgoal by (auto simp: neq_Nil_conv card_decreases)
  done

end

definition "tab_succ l \<equiv> Mapping.lookup_default [] (fold (\<lambda>(u,v). Mapping.map_default u [] (Cons v)) l Mapping.empty)"

lemma Some_eq_map_option [iff]: "(Some y = map_option f xo) = (\<exists>z. xo = Some z \<and> f z = y)"
  by (auto simp add: map_option_case split: option.split)

lemma tab_succ_correct: "E_of_succ (tab_succ l) = set l"
proof -
  have "set (Mapping.lookup_default [] (fold (\<lambda>(u,v). Mapping.map_default u [] (Cons v)) l m) u) = set l `` {u} \<union> set (Mapping.lookup_default [] m u)"
    for m u
    apply (induction l arbitrary: m)
    by (auto
      simp: Mapping.lookup_default_def Mapping.map_default_def Mapping.default_def
      simp: lookup_map_entry' lookup_update' keys_is_none_rep Option.is_none_def
      split: if_splits
    )
  from this[where m=Mapping.empty] show ?thesis
    by (auto simp: E_of_succ_def tab_succ_def lookup_default_empty)
qed

end

lemma finite_imp_finite_dfs_reachable:
  "\<lbrakk>finite E; finite S\<rbrakk> \<Longrightarrow> finite (E\<^sup>*``S)"
  apply (rule finite_subset[where B="S \<union> (Relation.Domain E \<union> Relation.Range E)"])
  apply (auto simp: intro: finite_Domain finite_Range elim: rtranclE)
  done

lemma dfs_reachable_tab_succ_correct: "dfs_reachable (tab_succ l) D vs\<^sub>0 \<longleftrightarrow> Collect D \<inter> (set l)\<^sup>*``set vs\<^sub>0 \<noteq> {}"
  apply (subst dfs_reachable_correct)
  by (simp_all add: tab_succ_correct finite_imp_finite_dfs_reachable)

subsection \<open>Implementation Refinements\<close>

subsubsection \<open>Of-Type\<close>

definition "of_type_impl G oT T \<equiv> (\<forall>pt\<in>set (primitives oT). dfs_reachable G ((=) pt) (primitives T))"

fun ty_term' where
  "ty_term' varT objT (term.VAR v) = varT v"
| "ty_term' varT objT (term.CONST c) = Mapping.lookup objT c"

lemma ty_term'_correct_aux: "ty_term' varT objT t = ty_term varT (Mapping.lookup objT) t"
  by (cases t) auto

lemma ty_term'_correct[simp]: "ty_term' varT objT = ty_term varT (Mapping.lookup objT)"
  using ty_term'_correct_aux by auto

context ast_domain begin

  definition "of_type1 pt T \<longleftrightarrow> pt \<in> subtype_rel\<^sup>* `` set (primitives T)"

  lemma of_type_refine1: "of_type oT T \<longleftrightarrow> (\<forall>pt\<in>set (primitives oT). of_type1 pt T)"
    unfolding of_type_def of_type1_def by auto

  definition "STG \<equiv> (tab_succ (map subtype_edge (types D)))"

  lemma subtype_rel_impl: "subtype_rel = E_of_succ (tab_succ (map subtype_edge (types D)))"
    by (simp add: tab_succ_correct subtype_rel_def)

  lemma of_type1_impl: "of_type1 pt T \<longleftrightarrow> dfs_reachable (tab_succ (map subtype_edge (types D))) ((=)pt) (primitives T)"
    by (simp add: subtype_rel_impl of_type1_def dfs_reachable_tab_succ_correct tab_succ_correct)

  lemma of_type_impl_correct: "of_type_impl STG oT T \<longleftrightarrow> of_type oT T"
    unfolding of_type1_impl STG_def of_type_impl_def of_type_refine1 ..

  definition mp_constT :: "(object, type) mapping" where
    "mp_constT = Mapping.of_alist (consts D)"

  lemma mp_objT_correct[simp]: "Mapping.lookup mp_constT = constT"
    unfolding mp_constT_def constT_def
    by transfer (simp add: Map_To_Mapping.map_apply_def)

  text \<open>Lifting the subtype-graph through wf-checker\<close>
  context
    fixes ty_ent :: "'ent \<rightharpoonup> type"  \<comment> \<open>Entity's type, None if invalid\<close>
  begin

    definition "is_of_type' stg v T \<longleftrightarrow> (
      case ty_ent v of
        Some vT \<Rightarrow> of_type_impl stg vT T
      | None \<Rightarrow> False)"

    lemma is_of_type'_correct: "is_of_type' STG v T = is_of_type ty_ent v T"
      unfolding is_of_type'_def is_of_type_def of_type_impl_correct ..

    fun wf_pred_atom' where "wf_pred_atom' stg (p,vs) \<longleftrightarrow> (case sig p of
          None \<Rightarrow> False
        | Some Ts \<Rightarrow> list_all2 (is_of_type' stg) vs Ts)"

    lemma wf_pred_atom'_correct: "wf_pred_atom' STG pvs = wf_pred_atom ty_ent pvs"
      by (cases pvs) (auto simp: is_of_type'_correct[abs_def] split:option.split)

    fun wf_atom' :: "_ \<Rightarrow> 'ent atom \<Rightarrow> bool" where
      "wf_atom' stg (atom.predAtm p vs) \<longleftrightarrow> wf_pred_atom' stg (p,vs)"
    | "wf_atom' stg (atom.Eq a b) = (ty_ent a \<noteq> None \<and> ty_ent b \<noteq> None)"

    lemma wf_atom'_correct: "wf_atom' STG a = wf_atom ty_ent a"
      by (cases a) (auto simp: wf_pred_atom'_correct is_of_type'_correct[abs_def] split: option.splits)

    fun wf_fmla' :: "_ \<Rightarrow> ('ent atom) formula \<Rightarrow> bool" where
      "wf_fmla' stg (Atom a) \<longleftrightarrow> wf_atom' stg a"
    | "wf_fmla' stg \<bottom> \<longleftrightarrow> True"
    | "wf_fmla' stg (\<phi>1 \<^bold>\<and> \<phi>2) \<longleftrightarrow> (wf_fmla' stg \<phi>1 \<and> wf_fmla' stg \<phi>2)"
    | "wf_fmla' stg (\<phi>1 \<^bold>\<or> \<phi>2) \<longleftrightarrow> (wf_fmla' stg \<phi>1 \<and> wf_fmla' stg \<phi>2)"
    | "wf_fmla' stg (\<phi>1 \<^bold>\<rightarrow> \<phi>2) \<longleftrightarrow> (wf_fmla' stg \<phi>1 \<and> wf_fmla' stg \<phi>2)"
    | "wf_fmla' stg (\<^bold>\<not>\<phi>) \<longleftrightarrow> wf_fmla' stg \<phi>"

    lemma wf_fmla'_correct: "wf_fmla' STG \<phi> \<longleftrightarrow> wf_fmla ty_ent \<phi>"
      by (induction \<phi> rule: wf_fmla.induct) (auto simp: wf_atom'_correct)

    fun wf_fmla_atom1' where
      "wf_fmla_atom1' stg (Atom (predAtm p vs)) \<longleftrightarrow> wf_pred_atom' stg (p,vs)"
    | "wf_fmla_atom1' stg _ \<longleftrightarrow> False"

    lemma wf_fmla_atom1'_correct: "wf_fmla_atom1' STG \<phi> = wf_fmla_atom ty_ent \<phi>"
      by (cases \<phi> rule: wf_fmla_atom.cases) (auto
        simp: wf_atom'_correct is_of_type'_correct[abs_def] split: option.splits)

    fun wf_effect' where
      "wf_effect' stg (Effect a d) \<longleftrightarrow>
          (\<forall>ae\<in>set a. wf_fmla_atom1' stg ae)
        \<and> (\<forall>de\<in>set d.  wf_fmla_atom1' stg de)"

    lemma wf_effect'_correct: "wf_effect' STG e = wf_effect ty_ent e"
      by (cases e) (auto simp: wf_fmla_atom1'_correct)

  end \<comment> \<open>Context fixing \<open>ty_ent\<close>\<close>

  fun wf_action_schema' :: "_ \<Rightarrow> _ \<Rightarrow> ast_action_schema \<Rightarrow> bool" where
    "wf_action_schema' stg conT (Action_Schema n params pre eff) \<longleftrightarrow> (
      let
        tyv = ty_term' (map_of params) conT
      in
        distinct (map fst params)
      \<and> wf_fmla' tyv stg pre
      \<and> wf_effect' tyv stg eff)"

  lemma wf_action_schema'_correct: "wf_action_schema' STG mp_constT s = wf_action_schema s"
    by (cases s) (auto simp: wf_fmla'_correct wf_effect'_correct)

  definition wf_domain' :: "_ \<Rightarrow> _ \<Rightarrow> bool" where
    "wf_domain' stg conT \<equiv>
      wf_types
    \<and> distinct (map (predicate_decl.pred) (predicates D))
    \<and> (\<forall>p\<in>set (predicates D). wf_predicate_decl p)
    \<and> distinct (map fst (consts D))
    \<and> (\<forall>(n,T)\<in>set (consts D). wf_type T)
    \<and> distinct (map ast_action_schema.name (actions D))
    \<and> (\<forall>a\<in>set (actions D). wf_action_schema' stg conT a)
    "

  lemma wf_domain'_correct: "wf_domain' STG mp_constT = wf_domain"
    unfolding wf_domain_def wf_domain'_def
    by (auto simp: wf_action_schema'_correct)

end \<comment> \<open>Context of \<open>ast_domain\<close>\<close>

subsubsection \<open>Application of Effects\<close>

context ast_domain begin
  text \<open>We implement the application of an effect by explicit iteration over
    the additions and deletions\<close>
  fun apply_effect_exec
    :: "object ast_effect \<Rightarrow> world_model \<Rightarrow> world_model"
  where
    "apply_effect_exec (Effect a d) s
      = fold (\<lambda>add s. Set.insert add s) a
          (fold (\<lambda>del s. Set.remove del s) d s)"

  lemma apply_effect_exec_refine[simp]:
    "apply_effect_exec (Effect (a) (d)) s
    = apply_effect (Effect (a) (d)) s"
  proof(induction a arbitrary: s)
    case Nil
    then show ?case
    proof(induction d arbitrary: s)
      case Nil
      then show ?case by auto
    next
      case (Cons a d)
      then show ?case
        by (auto simp add: image_def)
    qed
  next
    case (Cons a a)
    then show ?case
    proof(induction d arbitrary: s)
      case Nil
      then show ?case by (auto; metis Set.insert_def sup_assoc insert_iff)
    next
      case (Cons a d)
      then show ?case
        by (auto simp: Un_commute minus_set_fold union_set_fold)
    qed
  qed

  lemmas apply_effect_eq_impl_eq
    = apply_effect_exec_refine[symmetric, unfolded apply_effect_exec.simps]

end \<comment> \<open>Context of \<open>ast_domain\<close>\<close>

subsubsection \<open>Well-Formedness\<close>

context ast_problem begin

  text \<open> We start by defining a mapping from objects to types. The container
    framework will generate efficient, red-black tree based code for that
    later. \<close>

  type_synonym objT = "(object, type) mapping"

  definition mp_objT :: "(object, type) mapping" where
    "mp_objT = Mapping.of_alist (consts D @ objects P)"

  lemma mp_objT_correct[simp]: "Mapping.lookup mp_objT = objT"
    unfolding mp_objT_def objT_alt
    by transfer (simp add: Map_To_Mapping.map_apply_def)

  text \<open>We refine the typecheck to use the mapping\<close>

  definition "is_obj_of_type_impl stg mp n T = (
    case Mapping.lookup mp n of None \<Rightarrow> False | Some oT \<Rightarrow> of_type_impl stg oT T
  )"

  lemma is_obj_of_type_impl_correct[simp]:
    "is_obj_of_type_impl STG mp_objT = is_obj_of_type"
    apply (intro ext)
    apply (auto simp: is_obj_of_type_impl_def is_obj_of_type_def of_type_impl_correct split: option.split)
    done

  text \<open>We refine the well-formedness checks to use the mapping\<close>

  definition wf_fact' :: "objT \<Rightarrow> _ \<Rightarrow> fact \<Rightarrow> bool"
    where
    "wf_fact' ot stg \<equiv> wf_pred_atom' (Mapping.lookup ot) stg"

  lemma wf_fact'_correct[simp]: "wf_fact' mp_objT STG = wf_fact"
    by (auto simp: wf_fact'_def wf_fact_def wf_pred_atom'_correct[abs_def])

  definition "wf_fmla_atom2' mp stg f
    = (case f of formula.Atom (predAtm p vs) \<Rightarrow> (wf_fact' mp stg (p,vs)) | _ \<Rightarrow> False)"

  lemma wf_fmla_atom2'_correct[simp]:
    "wf_fmla_atom2' mp_objT STG \<phi> = wf_fmla_atom objT \<phi>"
    apply (cases \<phi> rule: wf_fmla_atom.cases)
    by (auto simp: wf_fmla_atom2'_def wf_fact_def split: option.splits)

  definition "wf_problem' stg conT mp \<equiv>
      wf_domain' stg conT
    \<and> distinct (map fst (objects P) @ map fst (consts D))
    \<and> (\<forall>(n,T)\<in>set (objects P). wf_type T)
    \<and> distinct (init P)
    \<and> (\<forall>f\<in>set (init P). wf_fmla_atom2' mp stg f)
    \<and> wf_fmla' (Mapping.lookup mp) stg (goal P)"

  lemma wf_problem'_correct:
    "wf_problem' STG mp_constT mp_objT = wf_problem"
    unfolding wf_problem_def wf_problem'_def wf_world_model_def
    by (auto simp: wf_domain'_correct wf_fmla'_correct)

  text \<open>Instantiating actions will yield well-founded effects.
    Corollary of @{thm wf_instantiate_action_schema}.\<close>
  lemma wf_effect_inst_weak:
    fixes a args
    defines "ai \<equiv> instantiate_action_schema a args"
    assumes A: "action_params_match a args"
      "wf_action_schema a"
    shows "wf_effect_inst (effect ai)"
    using wf_instantiate_action_schema[OF A] unfolding ai_def[symmetric]
    by (cases ai) (auto simp: wf_effect_inst_alt)

end \<comment> \<open>Context of \<open>ast_problem\<close>\<close>

context wf_ast_domain begin
  text \<open>Resolving an action yields a well-founded action schema.\<close>
  (* TODO: This must be implicitly proved when showing that plan execution
    preserves wf. Try to remove this redundancy!*)
  lemma resolve_action_wf:
    assumes "resolve_action_schema n = Some a"
    shows "wf_action_schema a"
  proof -
    from wf_domain have
      X1: "distinct (map ast_action_schema.name (actions D))"
      and X2: "\<forall>a\<in>set (actions D). wf_action_schema a"
      unfolding wf_domain_def by auto

    show ?thesis
      using assms unfolding resolve_action_schema_def
      by (auto simp add: index_by_eq_Some_eq[OF X1] X2)
  qed

end \<comment> \<open>Context of \<open>ast_domain\<close>\<close>

subsubsection \<open>Execution of Plan Actions\<close>

text \<open>We will perform two refinement steps, to summarize redundant operations\<close>

text \<open>We first lift action schema lookup into the error monad. \<close>
context ast_domain begin
  definition "resolve_action_schemaE n \<equiv>
    lift_opt
      (resolve_action_schema n)
      (ERR (shows ''No such action schema '' o shows n))"
end \<comment> \<open>Context of \<open>ast_domain\<close>\<close>

context ast_problem begin

(*TODO: change to this valuation definition to hanlde equalities nicely
definition "valuation s \<equiv> \<lambda>x. case x of (atom.Atom P ARGS) \<Rightarrow>
                                                ((formula.Atom x) \<in> s)
                                    | (atom.Eq t1 t2) \<Rightarrow> (t1 = t2)"

primrec holds :: "'a formula set \<Rightarrow> 'a formula \<Rightarrow> bool" where
"holds s (Atom k) = ((Atom k) \<in> s)" |
"holds _ \<bottom> = False" |
"holds s (Not F) = (\<not> (holds s F))" |
"holds s (And F G) = (holds s F \<and> holds s G)" |
"holds s (Or F G) = (holds s F \<or> holds s G)" |
"holds s (Imp F G) = (holds s F \<longrightarrow> holds s G)"

  lemma holds_for_valid_formulas:
        assumes "\<forall>x\<in>s. \<exists>x'. x = formula.Atom x'"
        shows "s \<TTurnstile> F \<Longrightarrow> holds s F"
        unfolding holds_def entailment_def
        using assms
        apply (induction F; auto)
        subgoal for x apply(cases x)*)

  text \<open>We define a function to determine whether a formula holds in
    a world model\<close>
  definition "holds M F \<equiv> (valuation M) \<Turnstile> F"

  text \<open>Justification of this function\<close>

  lemma holds_for_wf_fmlas:
    assumes "wm_basic s"
    shows "holds s F \<longleftrightarrow> close_world s \<TTurnstile> F"
    unfolding holds_def using assms valuation_iff_close_world
    by blast

  (*
  lemma holds_for_wf_fmlas:
    assumes "\<forall>x\<in>s. is_Atom x" "wf_fmla Q F"
    shows "holds s F \<longleftrightarrow> s \<TTurnstile> F"
    unfolding holds_def entailment_def valuation_def
    using assms
  proof (induction F)
    case (Atom x)
    then show ?case
      apply auto
      by (metis formula_semantics.simps(1) is_Atom.elims(2) valuation_def)
  next
    case (Or F1 F2)
    then show ?case
      apply simp apply (safe; clarsimp?)
      by (metis (mono_tags) is_Atom.elims(2) formula_semantics.simps(1))
  qed auto
  *)

  text \<open>The first refinement summarizes the enabledness check and the execution
    of the action. Moreover, we implement the precondition evaluation by our
     @{const holds} function. This way, we can eliminate redundant resolving
     and instantiation of the action.
  \<close>

  definition en_exE :: "plan_action \<Rightarrow> world_model \<Rightarrow> _+world_model" where
    "en_exE \<equiv> \<lambda>(PAction n args) \<Rightarrow> \<lambda>s. do {
      a \<leftarrow> resolve_action_schemaE n;
      check (action_params_match a args) (ERRS ''Parameter mismatch'');
      let ai = instantiate_action_schema a args;
      check (wf_effect_inst (effect ai)) (ERRS ''Effect not well-formed'');
      check ( holds s (precondition ai)) (ERRS ''Precondition not satisfied'');
      Error_Monad.return (apply_effect (effect ai) s)
    }"

  text \<open>Justification of implementation.\<close>
  lemma (in wf_ast_problem) en_exE_return_iff:
    assumes "wm_basic s"
    shows "en_exE a s = Inr s'
      \<longleftrightarrow> plan_action_enabled a s \<and> s' = execute_plan_action a s"
    apply (cases a)
    using assms holds_for_wf_fmlas wf_domain
    unfolding plan_action_enabled_def execute_plan_action_def
      and execute_ground_action_def en_exE_def wf_domain_def
    by (auto
        split: option.splits
        simp: resolve_action_schemaE_def return_iff)

  text \<open>Next, we use the efficient implementation @{const is_obj_of_type_impl}
    for the type check, and omit the well-formedness check, as effects obtained
    from instantiating well-formed action schemas are always well-formed
    (@{thm [source] wf_effect_inst_weak}).\<close>
  abbreviation "action_params_match2 stg mp a args
    \<equiv> list_all2 (is_obj_of_type_impl stg mp)
        args (map snd (ast_action_schema.parameters a))"

  definition en_exE2
    :: "_ \<Rightarrow> (object, type) mapping \<Rightarrow> plan_action \<Rightarrow> world_model \<Rightarrow> _+world_model"
  where
    "en_exE2 G mp \<equiv> \<lambda>(PAction n args) \<Rightarrow> \<lambda>M. do {
      a \<leftarrow> resolve_action_schemaE n;
      check (action_params_match2 G mp a args) (ERRS ''Parameter mismatch'');
      let ai = instantiate_action_schema a args;
      check (holds M (precondition ai)) (ERRS ''Precondition not satisfied'');
      Error_Monad.return (apply_effect (effect ai) M)
    }"

  text \<open>Justification of refinement\<close>
  lemma (in wf_ast_problem) wf_en_exE2_eq:
    shows "en_exE2 STG mp_objT pa s = en_exE pa s"
    apply (cases pa; simp add: en_exE2_def en_exE_def Let_def)
    apply (auto
      simp: return_iff resolve_action_schemaE_def resolve_action_wf
      simp: wf_effect_inst_weak action_params_match_def
      split: error_monad_bind_split)
    done

  text \<open>Combination of the two refinement lemmas\<close>
  lemma (in wf_ast_problem) en_exE2_return_iff:
    assumes "wm_basic M"
    shows "en_exE2 STG mp_objT a M = Inr M'
      \<longleftrightarrow> plan_action_enabled a M \<and> M' = execute_plan_action a M"
    unfolding wf_en_exE2_eq
    apply (subst en_exE_return_iff)
    using assms
    by (auto)

  lemma (in wf_ast_problem) en_exE2_return_iff_compact_notation:
    "\<lbrakk>wm_basic s\<rbrakk> \<Longrightarrow>
      en_exE2 STG mp_objT a s = Inr s'
      \<longleftrightarrow> plan_action_enabled a s \<and> s' = execute_plan_action a s"
    using en_exE2_return_iff .

end \<comment> \<open>Context of \<open>ast_problem\<close>\<close>

subsubsection \<open>Checking of Plan\<close>

context ast_problem begin

  text \<open>First, we combine the well-formedness check of the plan actions and
    their execution into a single iteration.\<close>
  fun valid_plan_from1 :: "world_model \<Rightarrow> plan \<Rightarrow> bool" where
    "valid_plan_from1 s [] \<longleftrightarrow> close_world s \<TTurnstile> (goal P)"
  | "valid_plan_from1 s (\<pi>#\<pi>s)
      \<longleftrightarrow> plan_action_enabled \<pi> s
        \<and> (valid_plan_from1 (execute_plan_action \<pi> s) \<pi>s)"

  lemma valid_plan_from1_refine: "valid_plan_from s \<pi>s = valid_plan_from1 s \<pi>s"
  proof(induction \<pi>s arbitrary: s)
    case Nil
    then show ?case by (auto simp add: plan_action_path_def valid_plan_from_def)
  next
    case (Cons a \<pi>s)
    then show ?case
      by (auto
        simp: valid_plan_from_def plan_action_path_def plan_action_enabled_def
        simp: execute_ground_action_def execute_plan_action_def)
  qed

  text \<open>Next, we use our efficient combined enabledness check and execution
    function, and transfer the implementation to use the error monad: \<close>
  fun valid_plan_fromE
    :: "_ \<Rightarrow> (object, type) mapping \<Rightarrow> nat \<Rightarrow> world_model \<Rightarrow> plan \<Rightarrow> _+unit"
  where
    "valid_plan_fromE stg mp si s []
      = check (holds s (goal P)) (ERRS ''Postcondition does not hold'')"
  | "valid_plan_fromE stg mp si s (\<pi>#\<pi>s) = do {
        s \<leftarrow> en_exE2 stg mp \<pi> s
          <+? (\<lambda>e _. shows ''at step '' o shows si o shows '': '' o e ());
        valid_plan_fromE stg mp (si+1) s \<pi>s
      }"

  text \<open>For the refinement, we need to show that the world models only
    contain atoms, i.e., containing only atoms is an invariant under execution
    of well-formed plan actions.\<close>
  lemma (in wf_ast_problem) wf_actions_only_add_atoms:
    "\<lbrakk> wm_basic s; wf_plan_action a \<rbrakk>
      \<Longrightarrow> wm_basic (execute_plan_action a s)"
    using wf_problem wf_domain
    unfolding wf_problem_def wf_domain_def
    apply (cases a)
    apply (clarsimp
      split: option.splits
      simp: wf_fmla_atom_alt execute_plan_action_def wm_basic_def
      simp: execute_ground_action_def)
    subgoal for n args schema fmla
      apply (cases "effect (instantiate_action_schema schema args)"; simp)
      by (metis ground_action.sel(2) ast_domain.wf_effect.simps
            ast_domain.wf_fmla_atom_alt resolve_action_wf
            wf_ground_action.elims(2) wf_instantiate_action_schema)
    done

  text \<open>Refinement lemma for our plan checking algorithm\<close>
  lemma (in wf_ast_problem) valid_plan_fromE_return_iff[return_iff]:
    assumes "wm_basic s"
    shows "valid_plan_fromE STG mp_objT k s \<pi>s = Inr () \<longleftrightarrow> valid_plan_from s \<pi>s"
    using assms unfolding valid_plan_from1_refine
  proof (induction stg\<equiv>STG mp\<equiv>mp_objT k s \<pi>s rule: valid_plan_fromE.induct)
    case (1 si s)
    then show ?case
      using wf_problem holds_for_wf_fmlas
      by (auto
        simp: return_iff Let_def wf_en_exE2_eq wf_problem_def
        split: plan_action.split)
  next
    case (2 si s \<pi> \<pi>s)
    then show ?case
      apply (clarsimp
        simp: return_iff en_exE2_return_iff
        split: plan_action.split)
      by (meson ast_problem.plan_action_enabled_def wf_actions_only_add_atoms)
  qed

  lemmas valid_plan_fromE_return_iff'[return_iff]
    = wf_ast_problem.valid_plan_fromE_return_iff[of P, OF wf_ast_problem.intro]

  (* TODO: This function is unused! *)
  (*fun apply_effect_exec''
    :: "object atom ast_effect \<Rightarrow> world_model \<Rightarrow> world_model"
    where
    "apply_effect_exec'' (Effect (adds) (dels)) s
      = fold (%add s. insert add s)
          (map formula.Atom adds)
          (fold (%del s. Set.remove del s) (map formula.Atom dels) s)"
  *)

end \<comment> \<open>Context of \<open>ast_problem\<close>\<close>

subsection \<open>Executable Plan Checker\<close>
text \<open>We obtain the main plan checker by combining the well-formedness check
  and executability check. \<close>

definition "check_all_list P l msg msgf \<equiv>
  forallM (\<lambda>x. check (P x) (\<lambda>_::unit. shows msg o shows '': '' o msgf x) ) l <+? snd"

lemma check_all_list_return_iff[return_iff]: "check_all_list P l msg msgf = Inr () \<longleftrightarrow> (\<forall>x\<in>set l. P x)"
  unfolding check_all_list_def
  by (induction l) (auto)

definition "check_wf_types D \<equiv> do {
  check_all_list (\<lambda>(_,t). t=''object'' \<or> t\<in>fst`set (types D)) (types D) ''Undeclared supertype'' (shows o snd)
}"

lemma check_wf_types_return_iff[return_iff]: "check_wf_types D = Inr () \<longleftrightarrow> ast_domain.wf_types D"
  unfolding ast_domain.wf_types_def check_wf_types_def
  by (force simp: return_iff)

definition "check_wf_domain D stg conT \<equiv> do {
  check_wf_types D;
  check (distinct (map (predicate_decl.pred) (predicates D))) (ERRS ''Duplicate predicate declaration'');
  check_all_list (ast_domain.wf_predicate_decl D) (predicates D) ''Malformed predicate declaration'' (shows o predicate.name o predicate_decl.pred);
  check (distinct (map fst (consts D))) (ERRS  ''Duplicate constant declaration'');
  check (\<forall>(n,T)\<in>set (consts D). ast_domain.wf_type D T) (ERRS ''Malformed type'');
  check (distinct (map ast_action_schema.name (actions D))  ) (ERRS ''Duplicate action name'');
  check_all_list (ast_domain.wf_action_schema' D stg conT) (actions D) ''Malformed action'' (shows o ast_action_schema.name)

}"

lemma check_wf_domain_return_iff[return_iff]:
  "check_wf_domain D stg conT = Inr () \<longleftrightarrow> ast_domain.wf_domain' D stg conT"
proof -
  interpret ast_domain D .
  show ?thesis
    unfolding check_wf_domain_def wf_domain'_def
    by (auto simp: return_iff)
qed

definition "prepend_err_msg msg e \<equiv> \<lambda>_::unit. shows msg o shows '': '' o e ()"

definition "check_wf_problem P stg conT mp \<equiv> do {
  let D = ast_problem.domain P;
  check_wf_domain D stg conT <+? prepend_err_msg ''Domain not well-formed'';
  check (distinct (map fst (objects P) @ map fst (consts D))) (ERRS ''Duplicate object declaration'');
  check ((\<forall>(n,T)\<in>set (objects P). ast_domain.wf_type D T)) (ERRS ''Malformed type'');
  check (distinct (init P)) (ERRS ''Duplicate fact in initial state'');
  check (\<forall>f\<in>set (init P). ast_problem.wf_fmla_atom2' P mp stg f) (ERRS ''Malformed formula in initial state'');
  check (ast_domain.wf_fmla' D (Mapping.lookup mp) stg (goal P)) (ERRS ''Malformed goal formula'')
}"

lemma check_wf_problem_return_iff[return_iff]:
  "check_wf_problem P stg conT mp = Inr () \<longleftrightarrow> ast_problem.wf_problem' P stg conT mp"
proof -
  interpret ast_problem P .
  show ?thesis
    unfolding check_wf_problem_def wf_problem'_def
    by (auto simp: return_iff)
qed

definition "check_plan P \<pi>s \<equiv> do {
  let stg=ast_domain.STG (ast_problem.domain P);
  let conT = ast_domain.mp_constT (ast_problem.domain P);
  let mp = ast_problem.mp_objT P;
  check_wf_problem P stg conT mp;
  ast_problem.valid_plan_fromE P stg mp 1 (ast_problem.I P) \<pi>s
} <+? (\<lambda>e. String.implode (e () ''''))"

text \<open>Correctness theorem of the plan checker: It returns @{term "Inr ()"}
  if and only if the problem is well-formed and the plan is valid.
\<close>
theorem check_plan_return_iff[return_iff]: "check_plan P \<pi>s = Inr ()
  \<longleftrightarrow> ast_problem.wf_problem P \<and> ast_problem.valid_plan P \<pi>s"
proof -
  interpret ast_problem P .
  show ?thesis
    unfolding check_plan_def
    by (auto
      simp: return_iff wf_world_model_def wf_fmla_atom_alt I_def wf_problem_def isOK_iff
      simp: wf_problem'_correct ast_problem.I_def ast_problem.valid_plan_def wm_basic_def
      )
qed

subsection \<open>Code Setup\<close>

text \<open>In this section, we set up the code generator to generate verified
  code for our plan checker.\<close>

subsubsection \<open>Code Equations\<close>
text \<open>We first register the code equations for the functions of the checker.
  Note that we not necessarily register the original code equations, but also
  optimized ones.
\<close>

lemmas wf_domain_code =
  ast_domain.sig_def
  ast_domain.wf_types_def
  ast_domain.wf_type.simps
  ast_domain.wf_predicate_decl.simps
  ast_domain.STG_def
  ast_domain.is_of_type'_def
  ast_domain.wf_atom'.simps
  ast_domain.wf_pred_atom'.simps
  ast_domain.wf_fmla'.simps
  ast_domain.wf_fmla_atom1'.simps
  ast_domain.wf_effect'.simps
  ast_domain.wf_action_schema'.simps
  ast_domain.wf_domain'_def
  ast_domain.subst_term.simps
  ast_domain.mp_constT_def
(*
  ast_domain.wf_domain_def
  ast_domain.wf_action_schema.simps
  ast_domain.wf_effect.simps
  ast_domain.wf_fmla.simps
  ast_domain.wf_atom.simps
  ast_domain.is_of_type_def
  ast_domain.of_type_code
*)

declare wf_domain_code[code]

lemmas wf_problem_code =
  ast_problem.wf_problem'_def
  ast_problem.wf_fact'_def
  (*ast_problem.objT_def*)
  ast_problem.is_obj_of_type_alt
  (*ast_problem.wf_object_def*)
  ast_problem.wf_fact_def
  ast_problem.wf_plan_action.simps
  (*ast_problem.wf_effect_inst_weak.simps*)

  ast_domain.subtype_edge.simps
declare wf_problem_code[code]

lemmas check_code =
  ast_problem.valid_plan_def
  ast_problem.valid_plan_fromE.simps
  ast_problem.en_exE2_def
  ast_problem.resolve_instantiate.simps
  ast_domain.resolve_action_schema_def
  ast_domain.resolve_action_schemaE_def
  ast_problem.I_def
  ast_domain.instantiate_action_schema.simps
  ast_domain.apply_effect_exec.simps
  (*ast_domain.apply_effect_exec'.simps*)
  ast_domain.apply_effect_eq_impl_eq
  (*ast_domain.apply_atomic.simps*)
  ast_problem.holds_def
  ast_problem.mp_objT_def
  ast_problem.is_obj_of_type_impl_def
  ast_problem.wf_fmla_atom2'_def
  valuation_def
declare check_code[code]

subsubsection \<open>Setup for Containers Framework\<close>

derive ceq predicate atom object formula
derive ccompare predicate atom object formula
derive (rbt) set_impl atom formula

derive (rbt) mapping_impl object

derive linorder predicate object atom "object atom formula"

subsubsection \<open>More Efficient Distinctness Check for Linorders\<close>
(* TODO: Can probably be optimized even more. *)
fun no_stutter :: "'a list \<Rightarrow> bool" where
  "no_stutter [] = True"
| "no_stutter [_] = True"
| "no_stutter (a#b#l) = (a\<noteq>b \<and> no_stutter (b#l))"

lemma sorted_no_stutter_eq_distinct: "sorted l \<Longrightarrow> no_stutter l \<longleftrightarrow> distinct l"
  apply (induction l rule: no_stutter.induct)
  apply (auto simp: )
  done

definition distinct_ds :: "'a::linorder list \<Rightarrow> bool"
  where "distinct_ds l \<equiv> no_stutter (quicksort l)"

lemma [code_unfold]: "distinct = distinct_ds"
  apply (intro ext)
  unfolding distinct_ds_def
  apply (auto simp: sorted_no_stutter_eq_distinct)
  done

subsubsection \<open>Code Generation\<close>

(* TODO/FIXME: Code_Char was removed from Isabelle-2018!
  Check for performance regression of generated code!
*)
export_code
  check_plan
  nat_of_integer integer_of_nat Inl Inr
  predAtm Eq predicate Pred Either Var Obj PredDecl BigAnd BigOr
  formula.Not formula.Bot Effect ast_action_schema.Action_Schema
  map_atom Domain Problem PAction
  term.CONST term.VAR (* I want to export the entire type, but I can only export the constructor because term is already an isabelle keyword. *)
  String.explode String.implode
  in SML
  module_name PDDL_Checker_Exported
  file "PDDL_STRIPS_Checker_Exported.sml"

export_code ast_domain.apply_effect_exec in SML module_name ast_domain

(* Usage example from within Isabelle *)
(*
ML_val \<open>
  let
    val prefix="/home/lammich/devel/isabelle/planning/papers/pddl_validator/experiments/results/"

    fun check name =
      (name,@{code parse_check_dpp_impl}
        (file_to_string (prefix ^ name ^ ".dom.pddl"))
        (file_to_string (prefix ^ name ^ ".prob.pddl"))
        (file_to_string (prefix ^ name ^ ".plan")))

  in
    (*check "IPC5_rovers_p03"*)
    check "Test2_rover_untyped_pfile07"
  end
\<close>
*)
end \<comment> \<open>Theory\<close>


(*  Title:       Inductive definition of Hoare logic for total correctness
    Author:      Tobias Nipkow, 2001/2006
    Maintainer:  Tobias Nipkow
*)

theory PHoareTotal imports PHoare PTermi begin

subsection{* Hoare logic for total correctness *}

text{*Validity is defined as expected:*}

definition
 tvalid :: "'a assn \<Rightarrow> com \<Rightarrow> 'a assn \<Rightarrow> bool" ("\<Turnstile>\<^sub>t {(1_)}/ (_)/ {(1_)}" 50) where
    "\<Turnstile>\<^sub>t {P}c{Q} \<longleftrightarrow>  \<Turnstile> {P}c{Q} \<and> (\<forall>z s. P z s \<longrightarrow> c\<down>s)"

definition
 ctvalid :: "'a cntxt \<Rightarrow> 'a assn \<Rightarrow> com \<Rightarrow> 'a assn \<Rightarrow> bool"
            ("(_ /\<Turnstile>\<^sub>t {(1_)}/ (_)/ {(1_))}" 50) where
 "C \<Turnstile>\<^sub>t {P}c{Q} \<longleftrightarrow> (\<forall>(P',c',Q') \<in> C. \<Turnstile>\<^sub>t {P'}c'{Q'}) \<longrightarrow> \<Turnstile>\<^sub>t {P}c{Q}"

inductive
  thoare :: "'a cntxt \<Rightarrow> 'a assn \<Rightarrow> com \<Rightarrow> 'a assn \<Rightarrow> bool"
   ("(_ \<turnstile>\<^sub>t/ ({(1_)}/ (_)/ {(1_)}))" [50,0,0,0] 50)
where
  Do: "C \<turnstile>\<^sub>t {\<lambda>z s. (\<forall>t \<in> f s . P z t) \<and> f s \<noteq> {}} Do f {P}"
| Semi: "\<lbrakk> C \<turnstile>\<^sub>t {P}c1{Q}; C \<turnstile>\<^sub>t {Q}c2{R} \<rbrakk> \<Longrightarrow> C \<turnstile>\<^sub>t {P} c1;c2 {R}"
| If: "\<lbrakk> C \<turnstile>\<^sub>t {\<lambda>z s. P z s \<and> b s}c{Q}; C \<turnstile>\<^sub>t {\<lambda>z s. P z s \<and> ~b s}d{Q}  \<rbrakk> \<Longrightarrow>
      C \<turnstile>\<^sub>t {P} IF b THEN c ELSE d {Q}"
| While:
  "\<lbrakk>wf r;  \<forall>s'. C \<turnstile>\<^sub>t {\<lambda>z s. P z s \<and> b s \<and> s' = s} c {\<lambda>z s. P z s \<and> (s,s') \<in> r}\<rbrakk>
   \<Longrightarrow> C \<turnstile>\<^sub>t {P} WHILE b DO c {\<lambda>z s. P z s \<and> \<not>b s}"

| Call:
  "\<lbrakk>wf r;  \<forall>s'. {(\<lambda>z s. P z s \<and> (s,s') \<in> r, CALL, Q)}
                 \<turnstile>\<^sub>t {\<lambda>z s. P z s \<and> s = s'} body {Q}\<rbrakk>
   \<Longrightarrow> {} \<turnstile>\<^sub>t {P} CALL {Q}"

| Asm: "{(P,CALL,Q)} \<turnstile>\<^sub>t {P} CALL {Q}"

| Conseq:
  "\<lbrakk> C \<turnstile>\<^sub>t {P'}c{Q'};
     (\<forall>s t. (\<forall>z. P' z s \<longrightarrow> Q' z t) \<longrightarrow> (\<forall>z. P z s \<longrightarrow> Q z t)) \<and>
     (\<forall>s. (\<exists>z. P z s) \<longrightarrow> (\<exists>z. P' z s)) \<rbrakk>
   \<Longrightarrow> C \<turnstile>\<^sub>t {P}c{Q}"

| Local: "\<lbrakk> \<forall>s'. C \<turnstile>\<^sub>t {\<lambda>z s. P z s' \<and> s = f s'} c {\<lambda>z t. Q z (g s' t)} \<rbrakk> \<Longrightarrow>
        C \<turnstile>\<^sub>t {P} LOCAL f;c;g {Q}"

abbreviation hoare1 :: "'a cntxt \<Rightarrow> 'a assn \<times> com \<times> 'a assn \<Rightarrow> bool" ("_ \<turnstile>\<^sub>t _") where
  "C \<turnstile>\<^sub>t x \<equiv> C \<turnstile>\<^sub>t {fst x}fst (snd x){snd (snd x)}"

text{* The side condition in our rule of consequence looks quite different
from the one by Kleymann, but the two are in fact equivalent:*}

lemma "((\<forall>s t. (\<forall>z. P' z s \<longrightarrow> Q' z t) \<longrightarrow> (\<forall>z. P z s \<longrightarrow> Q z t)) \<and>
            (\<forall>s. (\<exists>z. P z s) \<longrightarrow> (\<exists>z. P' z s)))
        = (\<forall>z s. P z s \<longrightarrow> (\<forall>t.\<exists>z'. P' z' s \<and> (Q' z' t \<longrightarrow> Q z t)))"
by blast

text{* The key difference to the work by Kleymann (and America and de
Boer) is that soundness and completeness are shown for arbitrary,
i.e.\ unbounded nondeterminism.  This is a significant extension and
appears to have been an open problem. The details are found below and
are explained in a separate paper~\cite{Nipkow-CSL02}. *}

theorems tvalid_defs = tvalid_def ctvalid_def valid_defs

lemma [iff]:
"(\<Turnstile>\<^sub>t {\<lambda>z s. P z s \<and> P'}c{Q}) = (P' \<longrightarrow> \<Turnstile>\<^sub>t {P}c{Q})"
apply(unfold tvalid_defs)
apply fast
done

lemma [iff]: "(\<Turnstile>\<^sub>t {P}CALL{Q}) = (\<Turnstile>\<^sub>t {P}body{Q})"
apply(unfold tvalid_defs)
apply fast
done

theorem "C \<turnstile>\<^sub>t {P}c{Q}  \<Longrightarrow>  C \<Turnstile>\<^sub>t {P}c{Q}"
apply(erule thoare.induct)
       apply(simp only:tvalid_defs)
       apply fast
      apply(simp only:tvalid_defs)
      apply fast
     apply(simp only:tvalid_defs)
     apply clarsimp
    prefer 3
    apply(simp add:tvalid_defs)
   prefer 3
   apply(simp only:tvalid_defs)
   apply blast
  apply(simp only:tvalid_defs)
  apply(rule impI, rule conjI)
   apply(rule allI)
   apply(erule wf_induct)
   apply clarify
   apply(drule unfold_while[THEN iffD1])
   apply (simp split add:split_if_asm)
   apply fast
  apply(rule allI, rule allI)
  apply(erule wf_induct)
  apply clarify
  apply(case_tac "b x")
   prefer 2
   apply (erule termi.WhileFalse)
  apply(rule termi.WhileTrue, assumption)
   apply fast
  apply (subgoal_tac "(t,x):r")
   apply fast
  apply blast
 apply(simp (no_asm_use) add:ctvalid_def)
 apply(subgoal_tac "!n. \<Turnstile>\<^sub>t {\<lambda>z s. P z s & s=n} body {Q}")
  apply(simp (no_asm_use) add:tvalid_defs)
  apply blast
 apply(rule allI)
 apply(erule wf_induct)
 apply(unfold tvalid_defs)
 apply fast
apply fast
done

definition MGT\<^sub>t :: "com \<Rightarrow> state assn \<times> com \<times> state assn" where
  [simp]: "MGT\<^sub>t c = (\<lambda>z s. z = s \<and> c\<down>s, c, \<lambda>z t. z -c\<rightarrow> t)"

lemma MGT_implies_complete:
 "{} \<turnstile>\<^sub>t MGT\<^sub>t c \<Longrightarrow> {} \<Turnstile>\<^sub>t {P}c{Q} \<Longrightarrow> {} \<turnstile>\<^sub>t {P}c{Q::state assn}"
apply(simp add: MGT\<^sub>t_def)
apply (erule thoare.Conseq)
apply(simp add: tvalid_defs)
apply blast
done

lemma while_termiE: "\<lbrakk> WHILE b DO c \<down> s; b s \<rbrakk> \<Longrightarrow> c \<down> s"
by(erule termi.cases, auto)

lemma while_termiE2:
  "\<lbrakk> WHILE b DO c \<down> s; b s; s -c\<rightarrow> t \<rbrakk> \<Longrightarrow> WHILE b DO c \<down> t"
by(erule termi.cases, auto)

lemma MGT_lemma: "C \<turnstile>\<^sub>t MGT\<^sub>t CALL \<Longrightarrow> C \<turnstile>\<^sub>t MGT\<^sub>t c"
apply (simp)
apply(induct_tac c)
     apply (rule strengthen_pre[OF _ thoare.Do])
     apply blast
    apply(rename_tac com1 com2)
    apply(rule_tac Q = "\<lambda>z s. z -com1\<rightarrow>s & com2\<down>s" in thoare.Semi)
     apply(erule thoare.Conseq)
     apply fast
    apply(erule thoare.Conseq)
    apply fast
   apply(rule thoare.If)
    apply(erule thoare.Conseq)
    apply simp
   apply(erule thoare.Conseq)
   apply simp
  defer
  apply simp
 apply(fast intro:thoare.Local elim!: thoare.Conseq)
apply(rename_tac b c)
apply(rule_tac P' = "\<lambda>z s. (z,s) \<in> ({(s,t). b s \<and> s -c\<rightarrow> t})^* \<and>
                           WHILE b DO c \<down> s" in thoare.Conseq)
 apply(rule_tac thoare.While[OF wf_termi])
 apply(rule allI)
 apply(erule thoare.Conseq)
 apply(fastforce intro:rtrancl_into_rtrancl dest:while_termiE while_termiE2)
apply(rule conjI)
 apply clarsimp
 apply(erule_tac x = s in allE)
 apply clarsimp
 apply(erule converse_rtrancl_induct)
  apply simp
 apply(fast elim:exec.WhileTrue)
apply(fast intro: rtrancl_refl)
done

inductive_set
  exec1 :: "((com list \<times> state) \<times> (com list \<times> state))set"
  and exec1' :: "(com list \<times> state) \<Rightarrow> (com list \<times> state) \<Rightarrow> bool"  ("_ \<rightarrow> _" [81,81] 100)
where
  "cs0 \<rightarrow> cs1 \<equiv> (cs0,cs1) : exec1"

| Do[iff]: "t \<in> f s \<Longrightarrow> ((Do f)#cs,s) \<rightarrow> (cs,t)"

| Semi[iff]: "((c1;c2)#cs,s) \<rightarrow> (c1#c2#cs,s)"

| IfTrue:   "b s \<Longrightarrow> ((IF b THEN c1 ELSE c2)#cs,s) \<rightarrow> (c1#cs,s)"
| IfFalse: "\<not>b s \<Longrightarrow> ((IF b THEN c1 ELSE c2)#cs,s) \<rightarrow> (c2#cs,s)"

| WhileFalse: "\<not>b s \<Longrightarrow> ((WHILE b DO c)#cs,s) \<rightarrow> (cs,s)"
| WhileTrue:   "b s \<Longrightarrow> ((WHILE b DO c)#cs,s) \<rightarrow> (c#(WHILE b DO c)#cs,s)"

| Call[iff]: "(CALL#cs,s) \<rightarrow> (body#cs,s)"

| Local[iff]: "((LOCAL f;c;g)#cs,s) \<rightarrow> (c # Do(\<lambda>t. {g s t})#cs, f s)"

abbreviation
  exectr :: "(com list \<times> state) \<Rightarrow> (com list \<times> state) \<Rightarrow> bool"   ("_ \<rightarrow>\<^sup>* _" [81,81] 100)
  where "cs0 \<rightarrow>\<^sup>* cs1 \<equiv> (cs0,cs1) : exec1^*"

inductive_cases exec1E[elim!]:
 "([],s) \<rightarrow> (cs',s')"
 "(Do f#cs,s) \<rightarrow> (cs',s')"
 "((c1;c2)#cs,s) \<rightarrow> (cs',s')"
 "((IF b THEN c1 ELSE c2)#cs,s) \<rightarrow> (cs',s')"
 "((WHILE b DO c)#cs,s) \<rightarrow> (cs',s')"
 "(CALL#cs,s) \<rightarrow> (cs',s')"
 "((LOCAL f;c;g)#cs,s) \<rightarrow> (cs',s')"

lemma [iff]: "\<not> ([],s) \<rightarrow> u"
by (induct u) blast

lemma app_exec: "(cs,s) \<rightarrow> (cs',s') \<Longrightarrow> (cs@cs2,s) \<rightarrow> (cs'@cs2,s')"
apply(erule exec1.induct)
       apply(simp_all del:fun_upd_apply)
   apply(blast intro:exec1.intros)+
done

lemma app_execs: "(cs,s) \<rightarrow>\<^sup>* (cs',s') \<Longrightarrow> (cs@cs2,s) \<rightarrow>\<^sup>* (cs'@cs2,s')"
apply(erule rtrancl_induct2)
 apply blast
apply(blast intro:app_exec rtrancl_trans)
done

lemma exec_impl_execs[rule_format]:
 "s -c\<rightarrow> s' \<Longrightarrow> \<forall>cs. (c#cs,s) \<rightarrow>\<^sup>* (cs,s')"
apply(erule exec.induct)
         apply blast
        apply(blast intro:rtrancl_trans)
       apply(blast intro:exec1.IfTrue rtrancl_trans)
      apply(blast intro:exec1.IfFalse rtrancl_trans)
     apply(blast intro:exec1.WhileFalse rtrancl_trans)
    apply(blast intro:exec1.WhileTrue rtrancl_trans)
   apply(blast intro: rtrancl_trans)
apply(blast intro: rtrancl_trans)
done

inductive
  execs :: "state \<Rightarrow> com list \<Rightarrow> state \<Rightarrow> bool"   ("_/ =_\<Rightarrow>/ _" [50,0,50] 50)
where
  "s =[]\<Rightarrow> s"
| "s -c\<rightarrow> t \<Longrightarrow> t =cs\<Rightarrow> u \<Longrightarrow> s =c#cs\<Rightarrow> u"

inductive_cases [elim!]:
 "s =[]\<Rightarrow> t"
 "s =c#cs\<Rightarrow> t"

theorem exec1s_impl_execs: "(cs,s) \<rightarrow>\<^sup>* ([],t) \<Longrightarrow> s =cs\<Rightarrow> t"
apply(erule converse_rtrancl_induct2)
 apply(rule execs.intros)
apply(erule exec1.cases)
apply(blast intro:execs.intros)
apply(blast intro:execs.intros)
apply(fastforce intro:execs.intros)
apply(fastforce intro:execs.intros)
apply(blast intro:execs.intros exec.intros)
apply(blast intro:execs.intros exec.intros)
apply(blast intro:execs.intros exec.intros)
apply(blast intro:execs.intros exec.intros)
done

theorem exec1s_impl_exec: "([c],s) \<rightarrow>\<^sup>* ([],t) \<Longrightarrow> s -c\<rightarrow> t"
by(blast dest: exec1s_impl_execs)

primrec termis :: "com list \<Rightarrow> state \<Rightarrow> bool" (infixl "\<Down>" 60) where
  "[]\<Down>s = True"
| "c#cs \<Down> s = (c\<down>s \<and> (\<forall>t. s -c\<rightarrow> t \<longrightarrow> cs\<Down>t))"

lemma exec1_pres_termis: "(cs,s) \<rightarrow> (cs',s') \<Longrightarrow> cs\<Down>s \<longrightarrow> cs'\<Down>s'"
apply(erule exec1.induct)
       apply(simp_all)
  apply blast
 apply(blast intro:while_termiE while_termiE2 exec.WhileTrue)
apply blast
done

lemma execs_pres_termis: "(cs,s) \<rightarrow>\<^sup>* (cs',s') \<Longrightarrow> cs\<Down>s \<longrightarrow> cs'\<Down>s'"
apply(erule rtrancl_induct2)
 apply blast
apply(blast dest:exec1_pres_termis)
done

definition
 termi_call_steps :: "(state \<times> state)set" where
"termi_call_steps = {(t,s). body\<down>s \<and> (\<exists>cs. ([body], s) \<rightarrow>\<^sup>* (CALL # cs, t))}"

lemma lem:
  "!y. (a,y):r\<^sup>+ \<longrightarrow> P a \<longrightarrow> P y \<Longrightarrow> ((b,a) : {(y,x). P x \<and> (x,y):r}\<^sup>+) = ((b,a) : {(y,x). P x \<and> (x,y):r\<^sup>+})"
apply(rule iffI)
 apply clarify
 apply(erule trancl_induct)
  apply blast
 apply(blast intro:trancl_trans)
apply clarify
apply(erule trancl_induct)
 apply blast
apply(blast intro:trancl_trans)
done

lemma renumber_aux:
 "\<lbrakk>\<forall>i. (a,f i) : r^* \<and> (f i,f(Suc i)) : r; (a,b) : r^* \<rbrakk> \<Longrightarrow> b = f 0 \<longrightarrow> (\<exists>f. f 0 = a & (\<forall>i. (f i, f(Suc i)) : r))"
apply(erule converse_rtrancl_induct)
 apply blast
apply(clarsimp)
apply(rule_tac x="\<lambda>i. case i of 0 \<Rightarrow> y | Suc i \<Rightarrow> fa i" in exI)
apply simp
apply clarify
apply(case_tac i)
 apply simp_all
done

lemma renumber:
 "\<forall>i. (a,f i) : r^* \<and> (f i,f(Suc i)) : r \<Longrightarrow> \<exists>f. f 0 = a & (\<forall>i. (f i, f(Suc i)) : r)"
by(blast dest:renumber_aux)

definition inf :: "com list \<Rightarrow> state \<Rightarrow> bool" where
"inf cs s \<longleftrightarrow> (\<exists>f. f 0 = (cs,s) \<and> (\<forall>i. f i \<rightarrow> f(Suc i)))"

lemma [iff]: "\<not> inf [] s"
apply(unfold inf_def)
apply clarify
apply(erule_tac x = 0 in allE)
apply simp
done

lemma [iff]: "\<not> inf [Do f] s"
apply(unfold inf_def)
apply clarify
apply(frule_tac x = 0 in spec)
apply(erule_tac x = 1 in allE)
apply(case_tac "fa (Suc 0)")
apply clarsimp
done

lemma [iff]: "inf ((c1;c2)#cs) s = inf (c1#c2#cs) s"
apply(unfold inf_def)
apply(rule iffI)
apply clarify
apply(rule_tac x = "\<lambda>i. f(Suc i)" in exI)
apply(frule_tac x = 0 in spec)
apply(case_tac "f (Suc 0)")
apply clarsimp
apply clarify
apply(rule_tac x = "\<lambda>i. case i of 0 \<Rightarrow> ((c1;c2)#cs,s) | Suc i \<Rightarrow> f i" in exI)
apply(simp split:nat.split)
done

lemma [iff]: "inf ((IF b THEN c1 ELSE c2)#cs) s =
              inf ((if b s then c1 else c2)#cs) s"
apply(unfold inf_def)
apply(rule iffI)
 apply clarsimp
 apply(frule_tac x = 0 in spec)
 apply (case_tac "f (Suc 0)")
 apply(rule conjI)
  apply clarsimp
  apply(rule_tac x = "\<lambda>i. f(Suc i)" in exI)
  apply clarsimp
 apply clarsimp
 apply(rule_tac x = "\<lambda>i. f(Suc i)" in exI)
 apply clarsimp
apply clarsimp
apply(rule_tac x = "\<lambda>i. case i of 0 \<Rightarrow> ((IF b THEN c1 ELSE c2)#cs,s) | Suc i \<Rightarrow> f i" in exI)
apply(simp add: exec1.intros split:nat.split)
done

lemma [iff]: "inf (CALL#cs) s =  inf (body#cs) s"
apply(unfold inf_def)
apply(rule iffI)
 apply clarsimp
 apply(frule_tac x = 0 in spec)
 apply (case_tac "f (Suc 0)")
 apply clarsimp
 apply(rule_tac x = "\<lambda>i. f(Suc i)" in exI)
 apply clarsimp
apply clarsimp
apply(rule_tac x = "\<lambda>i. case i of 0 \<Rightarrow> (CALL#cs,s) | Suc i \<Rightarrow> f i" in exI)
apply(simp add: exec1.intros split:nat.split)
done

lemma [iff]: "inf ((LOCAL f;c;g)#cs) s =
              inf (c#Do(\<lambda>t. {g s t})#cs) (f s)"
apply(unfold inf_def)
apply(rule iffI)
 apply clarsimp
 apply(rename_tac F)
 apply(frule_tac x = 0 in spec)
 apply (case_tac "F (Suc 0)")
 apply clarsimp
 apply(rule_tac x = "\<lambda>i. F(Suc i)" in exI)
 apply clarsimp
apply (clarsimp)
apply(rename_tac F)
apply(rule_tac x = "\<lambda>i. case i of 0 \<Rightarrow> ((LOCAL f;c;g)#cs,s) | Suc i \<Rightarrow> F i" in exI)
apply(simp add: exec1.intros split:nat.split)
done

lemma exec1_only1_aux: "(ccs,s) \<rightarrow> (cs',t) \<Longrightarrow>
                    \<forall>c cs. ccs = c#cs \<longrightarrow> (\<exists>cs1. cs' = cs1 @ cs)"
apply(erule exec1.induct)
apply blast
apply force+
done

lemma exec1_only1: "(c#cs,s) \<rightarrow> (cs',t) \<Longrightarrow> \<exists>cs1. cs' = cs1 @ cs"
by(blast dest:exec1_only1_aux)

lemma exec1_drop_suffix_aux:
"(cs12,s) \<rightarrow> (cs1'2,s') \<Longrightarrow> !cs1 cs2 cs1'.
 cs12 = cs1@cs2 & cs1'2 = cs1'@cs2 & cs1 \<noteq> [] \<longrightarrow> (cs1,s) \<rightarrow> (cs1',s')"
apply(erule exec1.induct)
       apply (force intro:exec1.intros simp add: neq_Nil_conv)+
done

lemma exec1_drop_suffix:
 "(cs1@cs2,s) \<rightarrow> (cs1'@cs2,s') \<Longrightarrow> cs1 \<noteq> [] \<Longrightarrow> (cs1,s) \<rightarrow> (cs1',s')"
by(blast dest:exec1_drop_suffix_aux)

lemma execs_drop_suffix[rule_format(no_asm)]:
  "\<lbrakk> f 0 = (c#cs,s);!i. f(i) \<rightarrow> f(Suc i) \<rbrakk> \<Longrightarrow>
   (!i<k. p i \<noteq> [] & fst(f i) = p i@cs) \<longrightarrow> fst(f k) = p k@cs
   \<longrightarrow> ([c],s) \<rightarrow>\<^sup>* (p k,snd(f k))"
apply(induct_tac k)
 apply simp
apply (clarsimp)
apply(erule rtrancl_into_rtrancl)
apply(erule_tac x = n in allE)
apply(erule_tac x = n in allE)
apply(case_tac "f n")
apply(case_tac "f(Suc n)")
apply simp
apply(blast dest:exec1_drop_suffix)
done

lemma execs_drop_suffix0:
  "\<lbrakk> f 0 = (c#cs,s);!i. f(i) \<rightarrow> f(Suc i); !i<k. p i \<noteq> [] & fst(f i) = p i@cs;
     fst(f k) = cs; p k = [] \<rbrakk> \<Longrightarrow> ([c],s) \<rightarrow>\<^sup>* ([],snd(f k))"
apply(drule execs_drop_suffix,assumption,assumption)
 apply simp
apply simp
done

lemma skolemize1: "\<forall>x. P x \<longrightarrow> (\<exists>y. Q x y) \<Longrightarrow> \<exists>f.\<forall>x. P x \<longrightarrow> Q x (f x)"
apply(rule_tac x = "\<lambda>x. SOME y. Q x y" in exI)
apply(fast intro:someI2)
done

lemma least_aux: "\<lbrakk>f 0 = (c # cs, s); \<forall>i. f i \<rightarrow> f (Suc i);
        fst(f k) = cs; !i<k. fst(f i) \<noteq> cs\<rbrakk>
       \<Longrightarrow> \<forall>i \<le> k. (\<exists>p. (p \<noteq> []) = (i < k) & fst(f i) = p @ cs)"
apply(rule allI)
apply(induct_tac i)
 apply simp
 apply (rule ccontr)
 apply simp
apply clarsimp
apply(drule order_le_imp_less_or_eq)
apply(erule disjE)
 prefer 2
 apply simp
apply simp
apply(erule_tac x = n in allE)
apply(erule_tac x = "Suc n" in allE)
apply(case_tac "f n")
apply(case_tac "f(Suc n)")
apply simp
apply(rename_tac sn csn1 sn1)
apply (clarsimp simp add: neq_Nil_conv)
apply(drule exec1_only1)
apply (clarsimp simp add: neq_Nil_conv)
apply(erule disjE)
 apply clarsimp
apply clarsimp
apply(case_tac cs1)
 apply simp
apply simp
done

lemma least_lem: "\<lbrakk>f 0 = (c#cs,s); !i. f i \<rightarrow> f(Suc i); EX i. fst(f i) = cs \<rbrakk>
       \<Longrightarrow> EX k. fst(f k) = cs & ([c],s) \<rightarrow>\<^sup>* ([],snd(f k))"
apply(rule_tac x="LEAST i. fst(f i) = cs" in exI)
apply(rule conjI)
 apply(fast intro: LeastI)
apply(subgoal_tac
 "!i<=LEAST i. fst (f i) = cs. EX p. ((p \<noteq> []) = (i<(LEAST i. fst (f i) = cs))) & fst(f i) = p@cs")
 apply(drule skolemize1)
 apply clarify
 apply(rename_tac p)
 apply(erule_tac p=p in execs_drop_suffix0, assumption)
   apply (blast dest:order_less_imp_le)
  apply(fast intro: LeastI)
 apply(erule thin_rl)
 apply(erule_tac x = "LEAST j. fst (f j) = fst (f i)" in allE)
 apply blast
apply(erule least_aux,assumption)
 apply(fast intro: LeastI)
apply clarify
apply(drule not_less_Least)
apply blast
done

lemma skolemize2: "\<forall>x.\<exists>y. P x y \<Longrightarrow> \<exists>f.\<forall>x. P x (f x)"
apply(rule_tac x = "\<lambda>x. SOME y. P x y" in exI)
apply(fast intro:someI2)
done

lemma inf_cases: "inf (c#cs) s \<Longrightarrow> inf [c] s \<or> (\<exists>t. s -c\<rightarrow> t \<and> inf cs t)"
apply(unfold inf_def)
apply (clarsimp del: disjCI)
apply(case_tac "EX i. fst(f i) = cs")
 apply(rule disjI2)
 apply(drule least_lem, assumption, assumption)
 apply clarify
 apply(drule exec1s_impl_exec)
 apply(case_tac "f k")
 apply simp
 apply (rule exI, rule conjI, assumption)
 apply(rule_tac x="\<lambda>i. f(i+k)" in exI)
 apply (clarsimp)
apply(rule disjI1)
apply simp
apply(subgoal_tac "\<forall>i. \<exists>p. p \<noteq> [] \<and> fst(f i) = p@cs")
 apply(drule skolemize2)
 apply clarify
 apply(rename_tac p)
 apply(rule_tac x = "\<lambda>i. (p i, snd(f i))" in exI)
 apply(rule conjI)
  apply(erule_tac x = 0 in allE, erule conjE)
  apply simp
 apply clarify
 apply(erule_tac x = i in allE)
 apply(erule_tac x = i in allE)
 apply(frule_tac x = i in spec)
 apply(erule_tac x = "Suc i" in allE)
 apply(case_tac "f i")
 apply(case_tac "f(Suc i)")
 apply clarsimp
 apply(blast intro:exec1_drop_suffix)
apply(clarify)
apply(induct_tac i)
 apply force
apply clarsimp
apply(case_tac p)
 apply blast
apply(erule_tac x=n in allE)
apply(erule_tac x="Suc n" in allE)
apply(case_tac "f n")
apply(case_tac "f(Suc n)")
apply clarsimp
apply(drule exec1_only1)
apply clarsimp
done

lemma termi_impl_not_inf: "c \<down> s \<Longrightarrow> \<not> inf [c] s"
apply(erule termi.induct)
        (*Do*)
        apply clarify
       (*Semi*)
       apply(blast dest:inf_cases)
      (* Cond *)
      apply clarsimp
     apply clarsimp
    (*While*)
    apply clarsimp
   apply(fastforce dest:inf_cases)
  (*Call*)
  apply blast
(*Local*)
apply(blast dest:inf_cases)
done

lemma termi_impl_no_inf_chain:
 "c\<down>s \<Longrightarrow> \<not>(\<exists>f. f 0 = ([c],s) \<and> (\<forall>i::nat. (f i, f(i+1)) : exec1^+))"
apply(subgoal_tac "wf({(y,x). ([c],s) \<rightarrow>\<^sup>* x & x \<rightarrow> y}^+)")
 apply(simp only:wf_iff_no_infinite_down_chain)
 apply(erule contrapos_nn)
 apply clarify
 apply(subgoal_tac "!i. ([c], s) \<rightarrow>\<^sup>* f i")
  prefer 2
  apply(rule allI)
  apply(induct_tac i)
   apply simp
  apply simp
  apply(blast intro: trancl_into_rtrancl rtrancl_trans)
 apply(rule_tac x=f in exI)
 apply clarify
 apply(drule_tac x=i in spec)
 apply(subst lem)
  apply(blast intro: trancl_into_rtrancl rtrancl_trans)
 apply clarsimp
apply(rule wf_trancl)
apply(simp only:wf_iff_no_infinite_down_chain)
apply(clarify)
apply simp
apply(drule renumber)
apply(fold inf_def)
apply(simp add: termi_impl_not_inf)
done

primrec cseq :: "(nat \<Rightarrow> state) \<Rightarrow> nat \<Rightarrow> com list" where
  "cseq S 0 = []"
| "cseq S (Suc i) = (SOME cs. ([body], S i) \<rightarrow>\<^sup>* (CALL # cs, S(i+1))) @ cseq S i"

lemma wf_termi_call_steps: "wf termi_call_steps"
apply(unfold termi_call_steps_def)
apply(simp only:wf_iff_no_infinite_down_chain)
apply(clarify)
apply(rename_tac S)
apply simp
apply(subgoal_tac "\<exists>Cs. Cs 0 = [] & (\<forall>i. (body # Cs i,S i) \<rightarrow>\<^sup>* (CALL # Cs(i+1), S(i+1)))")
prefer 2
 apply(rule_tac x = "cseq S" in exI)
 apply clarsimp
 apply(erule_tac x=i in allE)
 apply(clarify)
 apply(erule_tac P = "\<lambda>cs.([body],S i) \<rightarrow>\<^sup>* (CALL # cs, S(Suc i))" in someI2)
 apply(fastforce dest:app_execs)
apply clarify
apply(subgoal_tac "\<forall>i. ((body # Cs i,S i), (body # Cs(i+1), S(i+1))) : exec1^+")
 prefer 2
 apply(blast intro:rtrancl_into_trancl1)
apply(subgoal_tac "\<exists>f. f 0 = ([body],S 0) \<and> (\<forall>i. (f i, f(i+1)) : exec1^+)")
 prefer 2
 apply(rule_tac x = "\<lambda>i.(body#Cs i,S i)" in exI)
 apply blast
apply(blast dest:termi_impl_no_inf_chain)
done

lemma CALL_lemma:
"{(\<lambda>z s. (z=s \<and> body\<down>s) \<and> (s,t) \<in> termi_call_steps, CALL, \<lambda>z s. z -body\<rightarrow> s)} \<turnstile>\<^sub>t
 {\<lambda>z s. (z=s \<and> body\<down>t) \<and> (\<exists>cs. ([body],t) \<rightarrow>\<^sup>* (c#cs,s))} c {\<lambda>z s. z -c\<rightarrow> s}"
apply(induct_tac c)
(*Do*)
     apply (rule strengthen_pre[OF _ thoare.Do])
     apply(blast dest: execs_pres_termi)
(*Semi*)
    apply(rename_tac c1 c2)
    apply(rule_tac Q = "\<lambda>z s. body\<down>t & (EX cs. ([body], t) \<rightarrow>\<^sup>* (c2#cs,s)) & z -c1\<rightarrow>s & c2\<down>s" in thoare.Semi)
     apply(erule thoare.Conseq)
     apply(rule conjI)
      apply clarsimp
      apply(subgoal_tac "s -c1\<rightarrow> ta")
       prefer 2
       apply(blast intro: exec1.Semi exec_impl_execs rtrancl_trans)
      apply(subgoal_tac "([body], t) \<rightarrow>\<^sup>* (c2 # cs, ta)")
       prefer 2
       apply(blast intro:exec1.Semi[THEN r_into_rtrancl] exec_impl_execs rtrancl_trans)
      apply(subgoal_tac "([body], t) \<rightarrow>\<^sup>* (c2 # cs, ta)")
       prefer 2
       apply(blast intro: exec_impl_execs rtrancl_trans)
      apply(blast intro:exec_impl_execs rtrancl_trans execs_pres_termi)
     apply(fast intro: exec1.Semi rtrancl_trans)
    apply(erule thoare.Conseq)
    apply blast
(*Call*)
   prefer 3
   apply(simp only:termi_call_steps_def)
   apply(rule thoare.Conseq[OF thoare.Asm])
   apply(blast dest: execs_pres_termi)
(*If*)
  apply(rule thoare.If)
   apply(erule thoare.Conseq)
   apply simp
   apply(blast intro: exec1.IfTrue rtrancl_trans)
  apply(erule thoare.Conseq)
  apply simp
  apply(blast intro: exec1.IfFalse rtrancl_trans)
(*Var*)
 defer
 apply simp
 apply(rule thoare.Local)
 apply(rule allI)
 apply(erule thoare.Conseq)
 apply (clarsimp)
 apply(rule conjI)
  apply (clarsimp)
  apply(drule rtrancl_trans[OF _ r_into_rtrancl[OF exec1.Local]])
  apply(fast)
 apply (clarsimp)
 apply(drule rtrancl_trans[OF _ r_into_rtrancl[OF exec1.Local]])
 apply blast
apply(rename_tac b c)
apply(rule_tac P' = "\<lambda>z s. (z,s) \<in> ({(s,t). b s \<and> s -c\<rightarrow> t})^* \<and> body \<down> t \<and>
           (\<exists>cs. ([body], t) \<rightarrow>\<^sup>* ((WHILE b DO c) # cs, s))" in thoare.Conseq)
 apply(rule_tac thoare.While[OF wf_termi])
 apply(rule allI)
 apply(erule thoare.Conseq)
 apply clarsimp
 apply(rule conjI)
  apply clarsimp
  apply(rule conjI)
   apply(blast intro: rtrancl_trans exec1.WhileTrue)
  apply(rule conjI)
   apply(rule exI, rule rtrancl_trans, assumption)
   apply(blast intro: exec1.WhileTrue exec_impl_execs rtrancl_trans)
  apply(rule conjI)
   apply(blast intro:execs_pres_termi)
  apply(blast intro: exec1.WhileTrue exec_impl_execs rtrancl_trans)
 apply(blast intro: exec1.WhileTrue exec_impl_execs rtrancl_trans)
apply(rule conjI)
 apply clarsimp
 apply(erule_tac x = s in allE)
 apply clarsimp
 apply(erule impE)
  apply blast
 apply clarify
 apply(erule_tac a=s in converse_rtrancl_induct)
  apply simp
 apply(fast elim:exec.WhileTrue)
apply(fast intro: rtrancl_refl)
done

theorem "{} \<Turnstile>\<^sub>t {P}c{Q}  \<Longrightarrow>  {} \<turnstile>\<^sub>t {P}c{Q::state assn}"
apply(erule MGT_implies_complete[OF MGT_lemma[OF MGT_CALL]])
done

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

(* Author: Gerwin Klein, 2012
   Maintainers: Gerwin Klein <kleing at cse.unsw.edu.au>
                Rafal Kolanski <rafal.kolanski at nicta.com.au>
*)

chapter "Abstract Separation Logic, Alternative Definition"

theory Separation_Algebra_Alt
imports Main
begin

text \<open>
  This theory contains an alternative definition of speration algebra,
  following Calcagno et al very closely. While some of the abstract
  development is more algebraic, it is cumbersome to instantiate.
  We only use it to prove equivalence and to give an impression of how
  it would look like.
\<close>

(* The @{text "++"} notation is a horrible choice, but this theory is
   only intended to show how the development would look like, not to
   actually use it. We remove the notation for map-add so it doesn't
   conflict.
*)
no_notation map_add (infixl "++" 100)

definition
  lift2 :: "('a => 'b => 'c option) \<Rightarrow> 'a option => 'b option => 'c option"
where
  "lift2 f a b \<equiv> case (a,b) of (Some a, Some b) \<Rightarrow> f a b | _ \<Rightarrow> None"

class sep_algebra_alt = zero +
  fixes add :: "'a => 'a => 'a option" (infixr "\<oplus>" 65)

  assumes add_zero [simp]: "x \<oplus> 0 = Some x"
  assumes add_comm: "x \<oplus> y = y \<oplus> x"
  assumes add_assoc: "lift2 add a (lift2 add b c) = lift2 add (lift2 add a b) c"

begin

definition
  disjoint :: "'a => 'a => bool" (infix "##" 60)
where
  "a ## b \<equiv> a \<oplus> b \<noteq> None"

lemma disj_com: "x ## y = y ## x"
  by (auto simp: disjoint_def add_comm)

lemma disj_zero [simp]: "x ## 0"
  by (auto simp: disjoint_def)

lemma disj_zero2 [simp]: "0 ## x"
  by (subst disj_com) simp

lemma add_zero2 [simp]: "0 \<oplus> x = Some x"
  by (subst add_comm) auto

definition
  substate :: "'a => 'a => bool" (infix "\<preceq>" 60) where
  "a \<preceq> b \<equiv> \<exists>c. a \<oplus> c = Some b"

definition
  sep_conj :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" (infixl "**" 61)
  where
  "P ** Q \<equiv> \<lambda>s. \<exists>p q. p \<oplus> q = Some s \<and> P p \<and> Q q"

definition emp :: "'a \<Rightarrow> bool" ("\<box>") where
  "\<box> \<equiv> \<lambda>s. s = 0"

definition
  sep_impl :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" (infixr "\<longrightarrow>\<^sup>*" 25)
  where
  "P \<longrightarrow>\<^sup>* Q \<equiv> \<lambda>h. \<forall>h' h''. h \<oplus> h' = Some h'' \<and> P h' \<longrightarrow> Q h''"

definition
  "sep_true \<equiv> \<lambda>s. True"

definition
  "sep_false \<equiv> \<lambda>s. False"

abbreviation
  add2 :: "'a option => 'a option => 'a option" (infixr "++" 65)
where
  "add2 == lift2 add"

lemma add2_None [simp]:
  "x ++ None = None"
  by (simp add: lift2_def split: option.splits)

lemma None_add2 [simp]:
  "None ++ x = None"
  by (simp add: lift2_def split: option.splits)

lemma add2_Some_Some:
  "Some x ++ Some y = x \<oplus> y"
  by (simp add: lift2_def)

lemma add2_zero [simp]:
  "Some x ++ Some 0 = Some x"
  by (simp add: add2_Some_Some)

lemma zero_add2 [simp]:
  "Some 0 ++ Some x = Some x"
  by (simp add: add2_Some_Some)

lemma sep_conjE:
  "\<lbrakk> (P ** Q) s; \<And>p q. \<lbrakk> P p; Q q; p \<oplus> q = Some s \<rbrakk> \<Longrightarrow> X \<rbrakk> \<Longrightarrow> X"
  by (auto simp: sep_conj_def)

lemma sep_conjI:
  "\<lbrakk> P p; Q q; p \<oplus> q = Some s \<rbrakk> \<Longrightarrow> (P ** Q) s"
  by (auto simp: sep_conj_def)

lemma sep_conj_comI:
  "(P ** Q) s \<Longrightarrow> (Q ** P) s"
  by (auto intro!: sep_conjI elim!: sep_conjE simp: add_comm)

lemma sep_conj_com:
  "P ** Q = Q ** P"
  by (auto intro: sep_conj_comI)

lemma lift_to_add2:
  "\<lbrakk>z \<oplus> q = Some s; x \<oplus> y = Some q\<rbrakk> \<Longrightarrow> Some z ++ Some x ++ Some y = Some s"
  by (simp add: add2_Some_Some)

lemma lift_to_add2':
  "\<lbrakk>q \<oplus> z = Some s; x \<oplus> y = Some q\<rbrakk> \<Longrightarrow> (Some x ++ Some y) ++ Some z = Some s"
  by (simp add: add2_Some_Some)

lemma add2_Some:
  "(x ++ Some y = Some z) = (\<exists>x'. x = Some x' \<and> x' \<oplus> y = Some z)"
  by (simp add: lift2_def split: option.splits)

lemma Some_add2:
  "(Some x ++ y = Some z) = (\<exists>y'. y = Some y' \<and> x \<oplus> y' = Some z)"
  by (simp add: lift2_def split: option.splits)

lemma sep_conj_assoc:
  "P ** (Q ** R) = (P ** Q) ** R"
  unfolding sep_conj_def
  apply (rule ext)
  apply (rule iffI)
   apply clarsimp
   apply (drule (1) lift_to_add2)
   apply (subst (asm) add_assoc)
   apply (fastforce simp: add2_Some_Some add2_Some)
  apply clarsimp
  apply (drule (1) lift_to_add2')
  apply (subst (asm) add_assoc [symmetric])
  apply (fastforce simp: add2_Some_Some Some_add2)
  done

lemma sep_true[simp]: "sep_true s" by (simp add: sep_true_def)
lemma sep_false[simp]: "\<not>sep_false x" by (simp add: sep_false_def)

lemma sep_conj_sep_true:
  "P s \<Longrightarrow> (P ** sep_true) s"
  by (auto simp: sep_conjI [where q=0])

lemma sep_conj_sep_true':
  "P s \<Longrightarrow> (sep_true ** P) s"
  by (auto simp: sep_conjI [where p=0])

lemma disjoint_submaps_exist:
  "\<exists>h\<^sub>0 h\<^sub>1. h\<^sub>0 \<oplus> h\<^sub>1 = Some h"
  by (rule_tac x=0 in exI, auto)

lemma sep_conj_true[simp]:
  "(sep_true ** sep_true) = sep_true"
  unfolding sep_conj_def
  by (auto intro: disjoint_submaps_exist)

lemma sep_conj_false_right[simp]:
  "(P ** sep_false) = sep_false"
  by (force elim: sep_conjE)

lemma sep_conj_false_left[simp]:
  "(sep_false ** P) = sep_false"
  by (subst sep_conj_com) (rule sep_conj_false_right)

lemma sep_conj_left_com:
  "(P ** (Q ** R)) = (Q ** (P ** R))" (is "?x = ?y")
proof -
  have "?x = ((Q ** R) ** P)" by (simp add: sep_conj_com)
  also have "\<dots> = (Q ** (R ** P))" by (subst sep_conj_assoc, simp)
  finally show ?thesis by (simp add: sep_conj_com)
qed

lemmas sep_conj_ac = sep_conj_com sep_conj_assoc sep_conj_left_com

lemma empty_empty[simp]: "\<box> 0"
  by (simp add: emp_def)

lemma sep_conj_empty[simp]:
  "(P ** \<box>) = P"
  by (simp add: sep_conj_def emp_def)

  lemma sep_conj_empty'[simp]:
  "(\<box> ** P) = P"
  by (subst sep_conj_com, rule sep_conj_empty)

lemma sep_conj_sep_emptyI:
  "P s \<Longrightarrow> (P ** \<box>) s"
  by simp

lemma sep_conj_true_P[simp]:
  "(sep_true ** (sep_true ** P)) = (sep_true ** P)"
  by (simp add: sep_conj_assoc)

lemma sep_conj_disj:
  "((\<lambda>s. P s \<or> Q s) ** R) s = ((P ** R) s \<or> (Q ** R) s)" (is "?x = (?y \<or> ?z)")
  by (auto simp: sep_conj_def)

lemma sep_conj_conj:
  "((\<lambda>s. P s \<and> Q s) ** R) s \<Longrightarrow> (P ** R) s \<and> (Q ** R) s"
  by (force intro: sep_conjI elim!: sep_conjE)

lemma sep_conj_exists1:
  "((\<lambda>s. \<exists>x. P x s) ** Q) s = (\<exists>x. (P x ** Q) s)"
  by (force intro: sep_conjI elim: sep_conjE)

lemma sep_conj_exists2:
  "(P ** (\<lambda>s. \<exists>x. Q x s)) = (\<lambda>s. (\<exists>x. (P ** Q x) s))"
  by (force intro!: sep_conjI elim!: sep_conjE)

lemmas sep_conj_exists = sep_conj_exists1 sep_conj_exists2

lemma sep_conj_forall:
  "((\<lambda>s. \<forall>x. P x s) ** Q) s \<Longrightarrow> (P x ** Q) s"
  by (force intro: sep_conjI elim: sep_conjE)

lemma sep_conj_impl:
  "\<lbrakk> (P ** Q) s; \<And>s. P s \<Longrightarrow> P' s; \<And>s. Q s \<Longrightarrow> Q' s \<rbrakk> \<Longrightarrow> (P' ** Q') s"
  by (erule sep_conjE, auto intro!: sep_conjI)

lemma sep_conj_impl1:
  assumes P: "\<And>s. P s \<Longrightarrow> I s"
  shows "(P ** R) s \<Longrightarrow> (I ** R) s"
  by (auto intro: sep_conj_impl P)

lemma sep_conj_sep_true_left:
  "(P ** Q) s \<Longrightarrow> (sep_true ** Q) s"
  by (erule sep_conj_impl, simp+)

lemma sep_conj_sep_true_right:
  "(P ** Q) s \<Longrightarrow> (P ** sep_true) s"
  by (subst (asm) sep_conj_com, drule sep_conj_sep_true_left,
      simp add: sep_conj_ac)

lemma sep_globalise:
  "\<lbrakk> (P ** R) s; (\<And>s. P s \<Longrightarrow> Q s) \<rbrakk> \<Longrightarrow> (Q ** R) s"
  by (fast elim: sep_conj_impl)

lemma sep_implI:
  assumes a: "\<And>h' h''. \<lbrakk> h \<oplus> h' = Some h''; P h' \<rbrakk> \<Longrightarrow> Q h''"
  shows "(P \<longrightarrow>\<^sup>* Q) h"
  unfolding sep_impl_def by (auto elim: a)

lemma sep_implD:
  "(x \<longrightarrow>\<^sup>* y) h \<Longrightarrow> \<forall>h' h''. h \<oplus> h' = Some h'' \<and> x h' \<longrightarrow> y h''"
  by (force simp: sep_impl_def)

lemma sep_impl_sep_true[simp]:
  "(P \<longrightarrow>\<^sup>* sep_true) = sep_true"
  by (force intro!: sep_implI)

lemma sep_impl_sep_false[simp]:
  "(sep_false \<longrightarrow>\<^sup>* P) = sep_true"
  by (force intro!: sep_implI)

lemma sep_impl_sep_true_P:
  "(sep_true \<longrightarrow>\<^sup>* P) s \<Longrightarrow> P s"
  apply (drule sep_implD)
  apply (erule_tac x=0 in allE)
  apply simp
  done

lemma sep_impl_sep_true_false[simp]:
  "(sep_true \<longrightarrow>\<^sup>* sep_false) = sep_false"
  by (force dest: sep_impl_sep_true_P)

lemma sep_conj_sep_impl:
  "\<lbrakk> P s; \<And>s. (P ** Q) s \<Longrightarrow> R s \<rbrakk> \<Longrightarrow> (Q \<longrightarrow>\<^sup>* R) s"
proof (rule sep_implI)
  fix h' h h''
  assume "P h" and "h \<oplus> h' = Some h''" and "Q h'"
  hence "(P ** Q) h''" by (force intro: sep_conjI)
  moreover assume "\<And>s. (P ** Q) s \<Longrightarrow> R s"
  ultimately show "R h''" by simp
qed

lemma sep_conj_sep_impl2:
  "\<lbrakk> (P ** Q) s; \<And>s. P s \<Longrightarrow> (Q \<longrightarrow>\<^sup>* R) s \<rbrakk> \<Longrightarrow> R s"
  by (force dest: sep_implD elim: sep_conjE)

lemma sep_conj_sep_impl_sep_conj2:
  "(P ** R) s \<Longrightarrow> (P ** (Q \<longrightarrow>\<^sup>* (Q ** R))) s"
  by (erule (1) sep_conj_impl, erule sep_conj_sep_impl, simp add: sep_conj_ac)

lemma sep_conj_triv_strip2:
  "Q = R \<Longrightarrow> (Q ** P) = (R ** P)" by simp

end

end