(*  Title:       variants/c_gtobcast/Fresher.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke, Inria
    Author:      Peter Höfner, NICTA
*)

section "Quality relations between routes"

theory C_Fresher
imports C_Aodv_Data
begin

subsection "Net sequence numbers"

subsubsection "On individual routes"

definition
  nsqn\<^sub>r :: "r \<Rightarrow> sqn"
where
  "nsqn\<^sub>r r \<equiv> if \<pi>\<^sub>4(r) = val \<or> \<pi>\<^sub>2(r) = 0 then \<pi>\<^sub>2(r) else (\<pi>\<^sub>2(r) - 1)"

lemma nsqnr_def':
  "nsqn\<^sub>r r = (if \<pi>\<^sub>4(r) = inv then \<pi>\<^sub>2(r) - 1 else \<pi>\<^sub>2(r))"
  unfolding nsqn\<^sub>r_def by simp

lemma nsqn\<^sub>r_zero [simp]:
  "\<And>dsn dsk flag hops nhip. nsqn\<^sub>r (0, dsk, flag, hops, nhip) = 0"
  unfolding nsqn\<^sub>r_def by clarsimp

lemma nsqn\<^sub>r_val [simp]:
  "\<And>dsn dsk hops nhip. nsqn\<^sub>r (dsn, dsk, val, hops, nhip) = dsn"
  unfolding nsqn\<^sub>r_def by clarsimp

lemma nsqn\<^sub>r_inv [simp]:
  "\<And>dsn dsk hops nhip. nsqn\<^sub>r (dsn, dsk, inv, hops, nhip) = dsn - 1"
  unfolding nsqn\<^sub>r_def by clarsimp

lemma nsqn\<^sub>r_lte_dsn [simp]:
  "\<And>dsn dsk flag hops nhip. nsqn\<^sub>r (dsn, dsk, flag, hops, nhip) \<le> dsn"
  unfolding nsqn\<^sub>r_def by clarsimp

subsubsection "On routes in routing tables"

definition
  nsqn :: "rt \<Rightarrow> ip \<Rightarrow> sqn"
where
  "nsqn \<equiv> \<lambda>rt dip. case \<sigma>\<^bsub>route\<^esub>(rt, dip) of None \<Rightarrow> 0 | Some r \<Rightarrow> nsqn\<^sub>r(r)"

lemma nsqn_sqn_def:
  "\<And>rt dip. nsqn rt dip = (if flag rt dip = Some val \<or> sqn rt dip = 0
                            then sqn rt dip else sqn rt dip - 1)"
  unfolding nsqn_def sqn_def by (clarsimp split: option.split)

lemma not_in_kD_nsqn [simp]:
  assumes "dip \<notin> kD(rt)"
  shows "nsqn rt dip = 0"
  using assms unfolding nsqn_def by simp

lemma sqn_nsqn:
  "\<And>rt dip. sqn rt dip - 1 \<le> nsqn rt dip"
  unfolding sqn_def nsqn_def by (clarsimp split: option.split)

lemma nsqn_sqn: "nsqn rt dip \<le> sqn rt dip"
  unfolding sqn_def nsqn_def by (cases "rt dip") auto

lemma val_nsqn_sqn [elim, simp]:
  assumes "ip\<in>kD(rt)"
      and "the (flag rt ip) = val"
    shows "nsqn rt ip = sqn rt ip"
  using assms unfolding nsqn_sqn_def by auto

lemma vD_nsqn_sqn [elim, simp]:
  assumes "ip\<in>vD(rt)"
    shows "nsqn rt ip = sqn rt ip"
  proof -
    from \<open>ip\<in>vD(rt)\<close> have "ip\<in>kD(rt)"
                      and "the (flag rt ip) = val" by auto
    thus ?thesis ..
  qed

lemma inv_nsqn_sqn [elim, simp]:
  assumes "ip\<in>kD(rt)"
      and "the (flag rt ip) = inv"
    shows "nsqn rt ip = sqn rt ip - 1"
  using assms unfolding nsqn_sqn_def by auto

lemma iD_nsqn_sqn [elim, simp]:
  assumes "ip\<in>iD(rt)"
    shows "nsqn rt ip = sqn rt ip - 1"
  proof -
    from \<open>ip\<in>iD(rt)\<close> have "ip\<in>kD(rt)"
                      and "the (flag rt ip) = inv" by auto
    thus ?thesis ..
  qed

lemma nsqn_update_changed_kno_val [simp]: "\<And>rt ip dsn dsk hops nhip.
  rt \<noteq> update rt ip (dsn, kno, val, hops, nhip)
   \<Longrightarrow> nsqn (update rt ip (dsn, kno, val, hops, nhip)) ip = dsn"
  unfolding nsqn\<^sub>r_def update_def
  by (clarsimp simp: kD_nsqn split: option.split_asm option.split if_split_asm)
     (metis fun_upd_triv)

lemma nsqn_update_other [simp]:
    fixes dsn dsk flag hops dip nhip rt ip
  assumes "dip \<noteq> ip"
    shows "nsqn (update rt ip (dsn, dsk, flag, hops, nhip)) dip = nsqn rt dip"
    using assms unfolding nsqn_def
    by (clarsimp split: option.split)

lemma nsqn_invalidate_eq:
  assumes "dip \<in> kD(rt)"
      and "dests dip = Some rsn"
    shows "nsqn (invalidate rt dests) dip = rsn - 1"
  using assms
  proof -
    from assms obtain dsk hops nhip pre
      where "invalidate rt dests dip = Some (rsn, dsk, inv, hops, nhip)"
      unfolding invalidate_def
      by auto
    moreover from \<open>dip \<in> kD(rt)\<close> have "dip \<in> kD(invalidate rt dests)" by simp
    ultimately show ?thesis
      using \<open>dests dip = Some rsn\<close> by simp
  qed

lemma nsqn_invalidate_other [simp]:
  assumes "dip\<in>kD(rt)"
      and "dip\<notin>dom dests"
    shows "nsqn (invalidate rt dests) dip = nsqn rt dip"
  using assms by (clarsimp simp add: kD_nsqn)

subsection "Comparing routes "

definition
  fresher :: "r \<Rightarrow> r \<Rightarrow> bool" ("(_/ \<sqsubseteq> _)"  [51, 51] 50)
where
  "fresher r r' \<equiv> ((nsqn\<^sub>r r < nsqn\<^sub>r r') \<or> (nsqn\<^sub>r r  = nsqn\<^sub>r r' \<and> \<pi>\<^sub>5(r) \<ge> \<pi>\<^sub>5(r')))"

lemma fresherI1 [intro]:
  assumes "nsqn\<^sub>r r < nsqn\<^sub>r r'"
    shows "r \<sqsubseteq> r'"
  unfolding fresher_def using assms by simp

lemma fresherI2 [intro]:
  assumes "nsqn\<^sub>r r = nsqn\<^sub>r r'"
      and "\<pi>\<^sub>5(r) \<ge> \<pi>\<^sub>5(r')"
    shows "r \<sqsubseteq> r'"
  unfolding fresher_def using assms by simp

lemma fresherI [intro]:
  assumes "(nsqn\<^sub>r r < nsqn\<^sub>r r') \<or> (nsqn\<^sub>r r  = nsqn\<^sub>r r' \<and> \<pi>\<^sub>5(r) \<ge> \<pi>\<^sub>5(r'))"
    shows "r \<sqsubseteq> r'"
  unfolding fresher_def using assms .

lemma fresherE [elim]:
  assumes "r \<sqsubseteq> r'"
      and "nsqn\<^sub>r r < nsqn\<^sub>r r' \<Longrightarrow> P r r'"
      and "nsqn\<^sub>r r  = nsqn\<^sub>r r' \<and> \<pi>\<^sub>5(r) \<ge> \<pi>\<^sub>5(r') \<Longrightarrow> P r r'"
    shows "P r r'"
  using assms unfolding fresher_def by auto

lemma fresher_refl [simp]: "r \<sqsubseteq> r"
  unfolding fresher_def by simp

lemma fresher_trans [elim, trans]:
  "\<lbrakk> x \<sqsubseteq> y; y \<sqsubseteq> z \<rbrakk> \<Longrightarrow> x \<sqsubseteq> z"
  unfolding fresher_def by auto

lemma not_fresher_trans [elim, trans]:
  "\<lbrakk> \<not>(x \<sqsubseteq> y); \<not>(z \<sqsubseteq> x) \<rbrakk> \<Longrightarrow> \<not>(z \<sqsubseteq> y)"
  unfolding fresher_def by auto

subsection "Comparing routing tables "

definition
  rt_fresher :: "ip \<Rightarrow> rt \<Rightarrow> rt \<Rightarrow> bool"
where
  "rt_fresher \<equiv> \<lambda>dip rt rt'. (the (\<sigma>\<^bsub>route\<^esub>(rt, dip))) \<sqsubseteq> (the (\<sigma>\<^bsub>route\<^esub>(rt', dip)))"

abbreviation
   rt_fresher_syn :: "rt \<Rightarrow> ip \<Rightarrow> rt \<Rightarrow> bool" ("(_/ \<sqsubseteq>\<^bsub>_\<^esub> _)"  [51, 999, 51] 50)
where
  "rt1 \<sqsubseteq>\<^bsub>i\<^esub> rt2 \<equiv> rt_fresher i rt1 rt2"

lemma single_rt_fresher [intro]:
  assumes "the (rt1 ip) \<sqsubseteq> the (rt2 ip)"
    shows "rt1 \<sqsubseteq>\<^bsub>ip\<^esub> rt2"
  using assms unfolding rt_fresher_def .

lemma rt_fresher_single [intro]:
  assumes "rt1 \<sqsubseteq>\<^bsub>ip\<^esub> rt2"
    shows "the (rt1 ip) \<sqsubseteq> the (rt2 ip)"
  using assms unfolding rt_fresher_def .

lemma rt_fresher_def2:
  assumes "dip \<in> kD(rt1)"
      and "dip \<in> kD(rt2)"
    shows "(rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2) = (nsqn rt1 dip < nsqn rt2 dip
                               \<or> (nsqn rt1 dip = nsqn rt2 dip
                                   \<and> the (dhops rt1 dip) \<ge> the (dhops rt2 dip)))"
  using assms unfolding rt_fresher_def fresher_def by (simp add: kD_nsqn proj5_eq_dhops)

lemma rt_fresherI1 [intro]:
  assumes "dip \<in> kD(rt1)"
      and "dip \<in> kD(rt2)"
      and "nsqn rt1 dip < nsqn rt2 dip"
    shows "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2"
  unfolding rt_fresher_def2 [OF assms(1-2)] using assms(3) by simp

lemma rt_fresherI2 [intro]:
  assumes "dip \<in> kD(rt1)"
      and "dip \<in> kD(rt2)"
      and "nsqn rt1 dip = nsqn rt2 dip"
      and "the (dhops rt1 dip) \<ge> the (dhops rt2 dip)"
    shows "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2"
  unfolding rt_fresher_def2 [OF assms(1-2)] using assms(3-4) by simp

lemma rt_fresherE [elim]:
  assumes "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2"
      and "dip \<in> kD(rt1)"
      and "dip \<in> kD(rt2)"
      and "\<lbrakk> nsqn rt1 dip < nsqn rt2 dip \<rbrakk> \<Longrightarrow> P rt1 rt2 dip"
      and "\<lbrakk> nsqn rt1 dip = nsqn rt2 dip;
             the (dhops rt1 dip) \<ge> the (dhops rt2 dip) \<rbrakk> \<Longrightarrow> P rt1 rt2 dip"
    shows "P rt1 rt2 dip"
  using assms(1) unfolding rt_fresher_def2 [OF assms(2-3)]
  using assms(4-5) by auto

lemma rt_fresher_refl [simp]: "rt \<sqsubseteq>\<^bsub>dip\<^esub> rt"
  unfolding rt_fresher_def by simp

lemma rt_fresher_trans [elim, trans]:
  assumes "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2"
      and "rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt3"
    shows "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt3"
  using assms unfolding rt_fresher_def by auto

lemma rt_fresher_if_Some [intro!]:
  assumes "the (rt dip) \<sqsubseteq> r"
    shows "rt \<sqsubseteq>\<^bsub>dip\<^esub> (\<lambda>ip. if ip = dip then Some r else rt ip)"
  using assms unfolding rt_fresher_def by simp

definition rt_fresh_as :: "ip \<Rightarrow> rt \<Rightarrow> rt \<Rightarrow> bool"
where
  "rt_fresh_as \<equiv> \<lambda>dip rt1 rt2. (rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2) \<and> (rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt1)"

abbreviation
   rt_fresh_as_syn :: "rt \<Rightarrow> ip \<Rightarrow> rt \<Rightarrow> bool" ("(_/ \<approx>\<^bsub>_\<^esub> _)"  [51, 999, 51] 50)
where
  "rt1 \<approx>\<^bsub>i\<^esub> rt2 \<equiv> rt_fresh_as i rt1 rt2"

lemma rt_fresh_as_refl [simp]: "\<And>rt dip. rt \<approx>\<^bsub>dip\<^esub> rt"
  unfolding rt_fresh_as_def by simp

lemma rt_fresh_as_trans [simp, intro, trans]:
  "\<And>rt1 rt2 rt3 dip. \<lbrakk> rt1 \<approx>\<^bsub>dip\<^esub> rt2; rt2 \<approx>\<^bsub>dip\<^esub> rt3 \<rbrakk> \<Longrightarrow> rt1 \<approx>\<^bsub>dip\<^esub> rt3"
  unfolding rt_fresh_as_def rt_fresher_def
  by (metis (mono_tags) fresher_trans)

lemma rt_fresh_asI [intro!]:
  assumes "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2"
      and "rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt1"
    shows "rt1 \<approx>\<^bsub>dip\<^esub> rt2"
  using assms unfolding rt_fresh_as_def by simp

lemma rt_fresh_as_fresherI [intro]:
  assumes "dip\<in>kD(rt1)"
      and "dip\<in>kD(rt2)"
      and "the (rt1 dip) \<sqsubseteq> the (rt2 dip)"
      and "the (rt2 dip) \<sqsubseteq> the (rt1 dip)"
    shows "rt1 \<approx>\<^bsub>dip\<^esub> rt2"
  using assms unfolding rt_fresh_as_def
  by (clarsimp dest!: single_rt_fresher)

lemma nsqn_rt_fresh_asI:
  assumes "dip \<in> kD(rt)"
      and "dip \<in> kD(rt')"
      and "nsqn rt dip = nsqn rt' dip"
      and "\<pi>\<^sub>5(the (rt dip)) = \<pi>\<^sub>5(the (rt' dip))"
    shows "rt \<approx>\<^bsub>dip\<^esub> rt'"
  proof
    from assms(1-2,4) have dhops': "the (dhops rt' dip) \<le> the (dhops rt dip)"
      by (simp add: proj5_eq_dhops)
    with assms(1-3) show "rt \<sqsubseteq>\<^bsub>dip\<^esub> rt'"
      by (rule rt_fresherI2)
  next
    from assms(1-2,4) have dhops: "the (dhops rt dip) \<le> the (dhops rt' dip)"
      by (simp add: proj5_eq_dhops)
    with assms(2,1) assms(3) [symmetric] show "rt' \<sqsubseteq>\<^bsub>dip\<^esub> rt"
      by (rule rt_fresherI2)
  qed

lemma rt_fresh_asE [elim]:
  assumes "rt1 \<approx>\<^bsub>dip\<^esub> rt2"
      and "\<lbrakk> rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2; rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt1 \<rbrakk> \<Longrightarrow> P rt1 rt2 dip"
    shows "P rt1 rt2 dip"
  using assms unfolding rt_fresh_as_def by simp

lemma rt_fresh_asD1 [dest]:
  assumes "rt1 \<approx>\<^bsub>dip\<^esub> rt2"
    shows "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2"
  using assms unfolding rt_fresh_as_def by simp

lemma rt_fresh_asD2 [dest]:
  assumes "rt1 \<approx>\<^bsub>dip\<^esub> rt2"
    shows "rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt1"
  using assms unfolding rt_fresh_as_def by simp

lemma rt_fresh_as_sym:
  assumes "rt1 \<approx>\<^bsub>dip\<^esub> rt2"
    shows "rt2 \<approx>\<^bsub>dip\<^esub> rt1"
  using assms unfolding rt_fresh_as_def by simp

lemma not_rt_fresh_asI1 [intro]:
  assumes "\<not> (rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2)"
    shows "\<not> (rt1 \<approx>\<^bsub>dip\<^esub> rt2)"
  proof
    assume "rt1 \<approx>\<^bsub>dip\<^esub> rt2"
    hence "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2" ..
    with \<open>\<not> (rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2)\<close> show False ..
  qed

lemma not_rt_fresh_asI2 [intro]:
  assumes "\<not> (rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt1)"
    shows "\<not> (rt1 \<approx>\<^bsub>dip\<^esub> rt2)"
  proof
    assume "rt1 \<approx>\<^bsub>dip\<^esub> rt2"
    hence "rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt1" ..
    with \<open>\<not> (rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt1)\<close> show False ..
  qed

lemma not_single_rt_fresher [elim]:
  assumes "\<not>(the (rt1 ip) \<sqsubseteq> the (rt2 ip))"
    shows "\<not>(rt1 \<sqsubseteq>\<^bsub>ip\<^esub> rt2)"
  proof
    assume "rt1 \<sqsubseteq>\<^bsub>ip\<^esub> rt2"
    hence "the (rt1 ip) \<sqsubseteq> the (rt2 ip)" ..
    with \<open>\<not>(the (rt1 ip) \<sqsubseteq> the (rt2 ip))\<close> show False ..
  qed

lemmas not_single_rt_fresh_asI1 [intro] =  not_rt_fresh_asI1 [OF not_single_rt_fresher]
lemmas not_single_rt_fresh_asI2 [intro] =  not_rt_fresh_asI2 [OF not_single_rt_fresher]

lemma not_rt_fresher_single [elim]:
  assumes "\<not>(rt1 \<sqsubseteq>\<^bsub>ip\<^esub> rt2)"
    shows "\<not>(the (rt1 ip) \<sqsubseteq> the (rt2 ip))"
  proof
    assume "the (rt1 ip) \<sqsubseteq> the (rt2 ip)"
    hence "rt1 \<sqsubseteq>\<^bsub>ip\<^esub> rt2" ..
    with \<open>\<not>(rt1 \<sqsubseteq>\<^bsub>ip\<^esub> rt2)\<close> show False ..
  qed

lemma rt_fresh_as_nsqnr:
  assumes "dip \<in> kD(rt1)"
      and "dip \<in> kD(rt2)"
      and "rt1 \<approx>\<^bsub>dip\<^esub> rt2"
    shows "nsqn\<^sub>r (the (rt2 dip)) = nsqn\<^sub>r (the (rt1 dip))"
  using assms(3) unfolding rt_fresh_as_def
  by (auto simp: rt_fresher_def2 [OF \<open>dip \<in> kD(rt1)\<close> \<open>dip \<in> kD(rt2)\<close>]
                 rt_fresher_def2 [OF \<open>dip \<in> kD(rt2)\<close> \<open>dip \<in> kD(rt1)\<close>]
                 kD_nsqn [OF \<open>dip \<in> kD(rt1)\<close>]
                 kD_nsqn [OF \<open>dip \<in> kD(rt2)\<close>])

lemma rt_fresher_mapupd [intro!]:
  assumes "dip\<in>kD(rt)"
      and "the (rt dip) \<sqsubseteq> r"
    shows "rt \<sqsubseteq>\<^bsub>dip\<^esub> rt(dip \<mapsto> r)"
  using assms unfolding rt_fresher_def by simp

lemma rt_fresher_map_update_other [intro!]:
  assumes "dip\<in>kD(rt)"
      and "dip \<noteq> ip"
    shows "rt \<sqsubseteq>\<^bsub>dip\<^esub> rt(ip \<mapsto> r)"
  using assms unfolding rt_fresher_def by simp

lemma rt_fresher_update_other [simp]:
  assumes inkD: "dip\<in>kD(rt)"
     and "dip \<noteq> ip"
   shows "rt \<sqsubseteq>\<^bsub>dip\<^esub> update rt ip r"
   using assms unfolding update_def
   by (clarsimp split: option.split) (fastforce)

theorem rt_fresher_update [simp]:
  assumes "dip\<in>kD(rt)"
      and "the (dhops rt dip) \<ge> 1"
      and "update_arg_wf r"
   shows "rt \<sqsubseteq>\<^bsub>dip\<^esub> update rt ip r"
  proof (cases "dip = ip")
    assume "dip \<noteq> ip" with \<open>dip\<in>kD(rt)\<close> show ?thesis
      by (rule rt_fresher_update_other)
  next
    assume "dip = ip"

    from \<open>dip\<in>kD(rt)\<close> obtain dsn\<^sub>n dsk\<^sub>n f\<^sub>n hops\<^sub>n nhip\<^sub>n
      where rtn [simp]: "the (rt dip) = (dsn\<^sub>n, dsk\<^sub>n, f\<^sub>n, hops\<^sub>n, nhip\<^sub>n)"
      by (metis prod_cases5)
    with \<open>the (dhops rt dip) \<ge> 1\<close> and \<open>dip\<in>kD(rt)\<close> have "hops\<^sub>n \<ge> 1"
      by (metis proj5_eq_dhops projs(4))
    from \<open>dip\<in>kD(rt)\<close> rtn have [simp]: "sqn rt dip = dsn\<^sub>n"
                           and [simp]: "the (dhops rt dip) = hops\<^sub>n"
                           and [simp]: "the (flag rt dip) = f\<^sub>n"
      by (simp add: sqn_def proj5_eq_dhops [symmetric]
                            proj4_eq_flag [symmetric])+

    from \<open>update_arg_wf r\<close> have "(dsn\<^sub>n, dsk\<^sub>n, f\<^sub>n, hops\<^sub>n, nhip\<^sub>n)
                                  \<sqsubseteq> the ((update rt dip r) dip)"
      proof (rule wf_r_cases)
        fix nhip pre
        from \<open>hops\<^sub>n \<ge> 1\<close> have "\<And>pre'. (dsn\<^sub>n, dsk\<^sub>n, f\<^sub>n, hops\<^sub>n, nhip\<^sub>n)
                                        \<sqsubseteq> (dsn\<^sub>n, unk, val, Suc 0, nhip)"
          unfolding fresher_def sqn_def by (cases f\<^sub>n) auto
        thus "(dsn\<^sub>n, dsk\<^sub>n, f\<^sub>n, hops\<^sub>n, nhip\<^sub>n)
               \<sqsubseteq> the (update rt dip (0, unk, val, Suc 0, nhip) dip)"
          using \<open>dip\<in>kD(rt)\<close> by - (rule update_cases_kD, simp_all)
      next
        fix dsn :: sqn and hops nhip pre
        assume "0 < dsn"
        show "(dsn\<^sub>n, dsk\<^sub>n, f\<^sub>n, hops\<^sub>n, nhip\<^sub>n)
               \<sqsubseteq> the (update rt dip (dsn, kno, val, hops, nhip) dip)"
        proof (rule update_cases_kD [OF _ \<open>dip\<in>kD(rt)\<close>], simp_all add: \<open>0 < dsn\<close>)
          assume "dsn\<^sub>n < dsn"
            thus "(dsn\<^sub>n, dsk\<^sub>n, f\<^sub>n, hops\<^sub>n, nhip\<^sub>n)
                   \<sqsubseteq> (dsn, kno, val, hops, nhip)"
              unfolding fresher_def by auto
        next
          assume "dsn\<^sub>n = dsn"
             and "hops < hops\<^sub>n"
            thus "(dsn, dsk\<^sub>n, f\<^sub>n, hops\<^sub>n, nhip\<^sub>n)
                   \<sqsubseteq> (dsn, kno, val, hops, nhip)"
              unfolding fresher_def nsqn\<^sub>r_def by simp
        next
          assume "dsn\<^sub>n = dsn"
            with \<open>0 < dsn\<close>
            show "(dsn, dsk\<^sub>n, inv, hops\<^sub>n, nhip\<^sub>n)
                   \<sqsubseteq> (dsn, kno, val, hops, nhip)"
              unfolding fresher_def by simp
        qed
      qed
    hence "rt \<sqsubseteq>\<^bsub>dip\<^esub> update rt dip r"
      by - (rule single_rt_fresher, simp)
    with \<open>dip = ip\<close> show ?thesis by simp
  qed

theorem rt_fresher_invalidate [simp]:
  assumes "dip\<in>kD(rt)"
      and indests: "\<forall>rip\<in>dom(dests). rip\<in>vD(rt) \<and> sqn rt rip < the (dests rip)"
    shows "rt \<sqsubseteq>\<^bsub>dip\<^esub> invalidate rt dests"
  proof (cases "dip\<in>dom(dests)")
    assume "dip\<notin>dom(dests)"
      thus ?thesis using \<open>dip\<in>kD(rt)\<close>
      by - (rule single_rt_fresher, simp)
  next
    assume "dip\<in>dom(dests)"
    moreover with indests have "dip\<in>vD(rt)"
                           and "sqn rt dip < the (dests dip)"
      by auto
    ultimately show ?thesis
      unfolding invalidate_def sqn_def
      by - (rule single_rt_fresher, auto simp: fresher_def)
  qed

lemma nsqn\<^sub>r_invalidate [simp]:
  assumes "dip\<in>kD(rt)"
      and "dip\<in>dom(dests)"
    shows "nsqn\<^sub>r (the (invalidate rt dests dip)) = the (dests dip) - 1"
  using assms unfolding invalidate_def by auto

lemma rt_fresh_as_inc_invalidate [simp]:
  assumes "dip\<in>kD(rt)"
      and "\<forall>rip\<in>dom(dests). rip\<in>vD(rt) \<and> the (dests rip) = inc (sqn rt rip)"
    shows "rt \<approx>\<^bsub>dip\<^esub> invalidate rt dests"
  proof (cases "dip\<in>dom(dests)")
    assume "dip\<notin>dom(dests)"
    with \<open>dip\<in>kD(rt)\<close> have "dip\<in>kD(invalidate rt dests)"
      by simp
    with \<open>dip\<in>kD(rt)\<close> show ?thesis
      by rule (simp_all add: \<open>dip\<notin>dom(dests)\<close>)
  next
    assume "dip\<in>dom(dests)"
    with assms(2) have "dip\<in>vD(rt)"
                  and "the (dests dip) = inc (sqn rt dip)" by auto
    from \<open>dip\<in>vD(rt)\<close> have "dip\<in>kD(rt)" by simp
    moreover then have "dip\<in>kD(invalidate rt dests)" by simp
    ultimately show ?thesis
    proof (rule nsqn_rt_fresh_asI)
      from \<open>dip\<in>vD(rt)\<close> have "nsqn rt dip = sqn rt dip" by simp
      also have "sqn rt dip = nsqn\<^sub>r (the (invalidate rt dests dip))"
      proof -
        from \<open>dip\<in>kD(rt)\<close> have "nsqn\<^sub>r (the (invalidate rt dests dip)) = the (dests dip) - 1"
          using \<open>dip\<in>dom(dests)\<close> by (rule nsqn\<^sub>r_invalidate)
        with \<open>the (dests dip) = inc (sqn rt dip)\<close>
          show "sqn rt dip = nsqn\<^sub>r (the (invalidate rt dests dip))" by simp
      qed
      also from \<open>dip\<in>kD(invalidate rt dests)\<close>
        have "nsqn\<^sub>r (the (invalidate rt dests dip)) = nsqn (invalidate rt dests) dip"
          by (simp add: kD_nsqn)
      finally show "nsqn rt dip = nsqn (invalidate rt dests) dip" .
    qed simp
  qed

lemmas rt_fresher_inc_invalidate [simp] = rt_fresh_as_inc_invalidate [THEN rt_fresh_asD1]

subsection "Strictly comparing routing tables "

definition rt_strictly_fresher :: "ip \<Rightarrow> rt \<Rightarrow> rt \<Rightarrow> bool"
where
  "rt_strictly_fresher \<equiv> \<lambda>dip rt1 rt2. (rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2) \<and> \<not>(rt1 \<approx>\<^bsub>dip\<^esub> rt2)"

abbreviation
   rt_strictly_fresher_syn :: "rt \<Rightarrow> ip \<Rightarrow> rt \<Rightarrow> bool" ("(_/ \<sqsubset>\<^bsub>_\<^esub> _)"  [51, 999, 51] 50)
where
  "rt1 \<sqsubset>\<^bsub>i\<^esub> rt2 \<equiv> rt_strictly_fresher i rt1 rt2"

lemma rt_strictly_fresher_def'':
  "rt1 \<sqsubset>\<^bsub>i\<^esub> rt2 = ((rt1 \<sqsubseteq>\<^bsub>i\<^esub> rt2) \<and> \<not>(rt2 \<sqsubseteq>\<^bsub>i\<^esub> rt1))"
  unfolding rt_strictly_fresher_def rt_fresh_as_def by auto

lemma rt_strictly_fresherI' [intro]:
  assumes "rt1 \<sqsubseteq>\<^bsub>i\<^esub> rt2"
      and "\<not>(rt2 \<sqsubseteq>\<^bsub>i\<^esub> rt1)"
    shows "rt1 \<sqsubset>\<^bsub>i\<^esub> rt2"
  using assms unfolding rt_strictly_fresher_def'' by simp

lemma rt_strictly_fresherE' [elim]:
  assumes "rt1 \<sqsubset>\<^bsub>i\<^esub> rt2"
      and "\<lbrakk> rt1 \<sqsubseteq>\<^bsub>i\<^esub> rt2; \<not>(rt2 \<sqsubseteq>\<^bsub>i\<^esub> rt1) \<rbrakk> \<Longrightarrow> P rt1 rt2 i"
    shows "P rt1 rt2 i"
  using assms unfolding rt_strictly_fresher_def'' by simp

lemma rt_strictly_fresherI [intro]:
  assumes "rt1 \<sqsubseteq>\<^bsub>i\<^esub> rt2"
      and "\<not>(rt1 \<approx>\<^bsub>i\<^esub> rt2)"
    shows "rt1 \<sqsubset>\<^bsub>i\<^esub> rt2"
  unfolding rt_strictly_fresher_def using assms ..

lemmas rt_strictly_fresher_singleI [elim] = rt_strictly_fresherI [OF single_rt_fresher]

lemma rt_strictly_fresherE [elim]:
  assumes "rt1 \<sqsubset>\<^bsub>i\<^esub> rt2"
      and "\<lbrakk> rt1 \<sqsubseteq>\<^bsub>i\<^esub> rt2; \<not>(rt1 \<approx>\<^bsub>i\<^esub> rt2) \<rbrakk> \<Longrightarrow> P rt1 rt2 i"
    shows "P rt1 rt2 i"
  using assms(1) unfolding rt_strictly_fresher_def
  by rule (erule(1) assms(2))

lemma rt_strictly_fresher_def':
  "rt1 \<sqsubset>\<^bsub>i\<^esub> rt2 =
     (nsqn\<^sub>r (the (rt1 i)) < nsqn\<^sub>r (the (rt2 i))
       \<or> (nsqn\<^sub>r (the (rt1 i)) = nsqn\<^sub>r (the (rt2 i)) \<and> \<pi>\<^sub>5(the (rt1 i)) > \<pi>\<^sub>5(the (rt2 i))))"
  unfolding rt_strictly_fresher_def'' rt_fresher_def fresher_def by auto

lemma rt_strictly_fresher_fresherD [dest]:
  assumes "rt1 \<sqsubset>\<^bsub>dip\<^esub> rt2"
    shows "the (rt1 dip) \<sqsubseteq> the (rt2 dip)"
  using assms unfolding rt_strictly_fresher_def rt_fresher_def by auto

lemma rt_strictly_fresher_not_fresh_asD [dest]:
  assumes "rt1 \<sqsubset>\<^bsub>dip\<^esub> rt2"
    shows "\<not> rt1 \<approx>\<^bsub>dip\<^esub> rt2"
  using assms unfolding rt_strictly_fresher_def by auto

lemma rt_strictly_fresher_trans [elim, trans]:
  assumes "rt1 \<sqsubset>\<^bsub>dip\<^esub> rt2"
      and "rt2 \<sqsubset>\<^bsub>dip\<^esub> rt3"
    shows "rt1 \<sqsubset>\<^bsub>dip\<^esub> rt3"
  using assms proof -
    from \<open>rt1 \<sqsubset>\<^bsub>dip\<^esub> rt2\<close> obtain "the (rt1 dip) \<sqsubseteq> the (rt2 dip)" by auto
    also from \<open>rt2 \<sqsubset>\<^bsub>dip\<^esub> rt3\<close> obtain "the (rt2 dip) \<sqsubseteq> the (rt3 dip)" by auto
    finally have "the (rt1 dip) \<sqsubseteq> the (rt3 dip)" .

    moreover have "\<not> (rt1 \<approx>\<^bsub>dip\<^esub> rt3)"
    proof -
      from \<open>rt1 \<sqsubset>\<^bsub>dip\<^esub> rt2\<close> obtain "\<not>(the (rt2 dip) \<sqsubseteq> the (rt1 dip))" by auto
      also from \<open>rt2 \<sqsubset>\<^bsub>dip\<^esub> rt3\<close> obtain "\<not>(the (rt3 dip) \<sqsubseteq> the (rt2 dip))" by auto
      finally have "\<not>(the (rt3 dip) \<sqsubseteq> the (rt1 dip))" .
      thus ?thesis ..
    qed
    ultimately show "rt1 \<sqsubset>\<^bsub>dip\<^esub> rt3" ..
 qed

lemma rt_strictly_fresher_irefl [simp]: "\<not> (rt \<sqsubset>\<^bsub>dip\<^esub> rt)"
  unfolding rt_strictly_fresher_def
  by clarsimp

lemma rt_fresher_trans_rt_strictly_fresher [elim, trans]:
  assumes "rt1 \<sqsubset>\<^bsub>dip\<^esub> rt2"
      and "rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt3"
    shows "rt1 \<sqsubset>\<^bsub>dip\<^esub> rt3"
  proof -
    from \<open>rt1 \<sqsubset>\<^bsub>dip\<^esub> rt2\<close> have "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2"
                           and "\<not>(rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt1)"
      unfolding rt_strictly_fresher_def'' by auto
    from this(1) and \<open>rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt3\<close> have "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt3" ..

    moreover from \<open>\<not>(rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt1)\<close> have "\<not>(rt3 \<sqsubseteq>\<^bsub>dip\<^esub> rt1)"
      proof (rule contrapos_nn)
        assume "rt3 \<sqsubseteq>\<^bsub>dip\<^esub> rt1"
        with \<open>rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt3\<close> show "rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt1" ..
      qed

    ultimately show "rt1 \<sqsubset>\<^bsub>dip\<^esub> rt3"
      unfolding rt_strictly_fresher_def'' by auto
  qed

lemma rt_fresher_trans_rt_strictly_fresher' [elim, trans]:
  assumes "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2"
      and "rt2 \<sqsubset>\<^bsub>dip\<^esub> rt3"
    shows "rt1 \<sqsubset>\<^bsub>dip\<^esub> rt3"
  proof -
    from \<open>rt2 \<sqsubset>\<^bsub>dip\<^esub> rt3\<close> have "rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt3"
                           and "\<not>(rt3 \<sqsubseteq>\<^bsub>dip\<^esub> rt2)"
      unfolding rt_strictly_fresher_def'' by auto
    from \<open>rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2\<close> and this(1) have "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt3" ..

    moreover from \<open>\<not>(rt3 \<sqsubseteq>\<^bsub>dip\<^esub> rt2)\<close> have "\<not>(rt3 \<sqsubseteq>\<^bsub>dip\<^esub> rt1)"
      proof (rule contrapos_nn)
        assume "rt3 \<sqsubseteq>\<^bsub>dip\<^esub> rt1"
        thus "rt3 \<sqsubseteq>\<^bsub>dip\<^esub> rt2" using \<open>rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2\<close> ..
      qed

    ultimately show "rt1 \<sqsubset>\<^bsub>dip\<^esub> rt3"
      unfolding rt_strictly_fresher_def'' by auto
  qed

lemma rt_fresher_imp_nsqn_le:
  assumes "rt1 \<sqsubseteq>\<^bsub>ip\<^esub> rt2"
      and "ip \<in> kD rt1"
      and "ip \<in> kD rt2"
    shows "nsqn rt1 ip \<le> nsqn rt2 ip"
  using assms(1)
  by (auto simp add: rt_fresher_def2 [OF assms(2-3)])

lemma rt_strictly_fresher_ltI [intro]:
  assumes "dip \<in> kD(rt1)"
      and "dip \<in> kD(rt2)"
      and "nsqn rt1 dip < nsqn rt2 dip"
    shows "rt1 \<sqsubset>\<^bsub>dip\<^esub> rt2"
  proof
    from assms show "rt1 \<sqsubseteq>\<^bsub>dip\<^esub> rt2" ..
  next
    show "\<not>(rt1 \<approx>\<^bsub>dip\<^esub> rt2)"
    proof
      assume "rt1 \<approx>\<^bsub>dip\<^esub> rt2"
      hence "rt2 \<sqsubseteq>\<^bsub>dip\<^esub> rt1" ..
      hence "nsqn rt2 dip \<le> nsqn rt1 dip"
        using \<open>dip \<in> kD(rt2)\<close> \<open>dip \<in> kD(rt1)\<close>
        by (rule rt_fresher_imp_nsqn_le)
      with \<open>nsqn rt1 dip < nsqn rt2 dip\<close> show "False"
        by simp
    qed
  qed

lemma rt_strictly_fresher_eqI [intro]:
  assumes "i\<in>kD(rt1)"
      and "i\<in>kD(rt2)"
      and "nsqn rt1 i = nsqn rt2 i"
      and "\<pi>\<^sub>5(the (rt2 i)) < \<pi>\<^sub>5(the (rt1 i))"
    shows "rt1 \<sqsubset>\<^bsub>i\<^esub> rt2"
  using assms unfolding rt_strictly_fresher_def' by (auto simp add: kD_nsqn)

lemma invalidate_rtsf_left [simp]:
  "\<And>dests dip rt rt'. dests dip = None \<Longrightarrow> (invalidate rt dests \<sqsubset>\<^bsub>dip\<^esub> rt') = (rt \<sqsubset>\<^bsub>dip\<^esub> rt')"
  unfolding invalidate_def rt_strictly_fresher_def'
  by (rule iffI) (auto split: option.split_asm)

lemma vD_invalidate_rt_strictly_fresher [simp]:
  assumes "dip \<in> vD(invalidate rt1 dests)"
    shows "(invalidate rt1 dests \<sqsubset>\<^bsub>dip\<^esub> rt2) = (rt1 \<sqsubset>\<^bsub>dip\<^esub> rt2)"
  proof (cases "dip \<in> dom(dests)")
    assume "dip \<in> dom(dests)"
    hence "dip \<notin> vD(invalidate rt1 dests)"
      unfolding invalidate_def vD_def
      by clarsimp (metis assms option.simps(3) vD_invalidate_vD_not_dests)
    with \<open>dip \<in> vD(invalidate rt1 dests)\<close> show ?thesis by simp
  next
    assume "dip \<notin> dom(dests)"
    hence "dests dip = None" by auto
    moreover with \<open>dip \<in> vD(invalidate rt1 dests)\<close> have "dip \<in> vD(rt1)"
      unfolding invalidate_def vD_def
      by clarsimp (metis (hide_lams, no_types) assms vD_Some vD_invalidate_vD_not_dests)
    ultimately show ?thesis
      unfolding invalidate_def rt_strictly_fresher_def' by auto
  qed

lemma rt_strictly_fresher_update_other [elim!]:
  "\<And>dip ip rt r rt'. \<lbrakk> dip \<noteq> ip; rt \<sqsubset>\<^bsub>dip\<^esub> rt' \<rbrakk> \<Longrightarrow> update rt ip r \<sqsubset>\<^bsub>dip\<^esub> rt'"
  unfolding rt_strictly_fresher_def' by clarsimp

lemma lt_sqn_imp_update_strictly_fresher:
  assumes "dip \<in> vD (rt2 nhip)"
      and  *: "osn < sqn (rt2 nhip) dip"
      and **: "rt \<noteq> update rt dip (osn, kno, val, hops, nhip)"
    shows "update rt dip (osn, kno, val, hops, nhip) \<sqsubset>\<^bsub>dip\<^esub> rt2 nhip"
  unfolding rt_strictly_fresher_def'
  proof (rule disjI1)
    from ** have "nsqn (update rt dip (osn, kno, val, hops, nhip)) dip = osn"
      by (rule nsqn_update_changed_kno_val)
    with \<open>dip\<in>vD(rt2 nhip)\<close>
      have "nsqn\<^sub>r (the (update rt dip (osn, kno, val, hops, nhip) dip)) = osn"
        by (simp add: kD_nsqn)
    also have "osn < sqn (rt2 nhip) dip" by (rule *)
    also have "sqn (rt2 nhip) dip = nsqn\<^sub>r (the (rt2 nhip dip))"
      unfolding nsqn\<^sub>r_def using \<open>dip \<in> vD (rt2 nhip)\<close>
      by - (metis vD_flag_val proj2_eq_sqn proj4_eq_flag vD_iD_gives_kD(1))
    finally show "nsqn\<^sub>r (the (update rt dip (osn, kno, val, hops, nhip) dip))
                                                              < nsqn\<^sub>r (the (rt2 nhip dip))" .
  qed

lemma dhops_le_hops_imp_update_strictly_fresher:
  assumes "dip \<in> vD(rt2 nhip)"
      and sqn: "sqn (rt2 nhip) dip = osn"
      and hop: "the (dhops (rt2 nhip) dip) \<le> hops"
      and **: "rt \<noteq> update rt dip (osn, kno, val, Suc hops, nhip)"
    shows "update rt dip (osn, kno, val, Suc hops, nhip) \<sqsubset>\<^bsub>dip\<^esub> rt2 nhip"
  unfolding rt_strictly_fresher_def'
  proof (rule disjI2, rule conjI)
    from ** have "nsqn (update rt dip (osn, kno, val, Suc hops, nhip)) dip = osn"
      by (rule nsqn_update_changed_kno_val)
    with \<open>dip\<in>vD(rt2 nhip)\<close>
      have "nsqn\<^sub>r (the (update rt dip (osn, kno, val, Suc hops, nhip) dip)) = osn"
        by (simp add: kD_nsqn)
    also have "osn = sqn (rt2 nhip) dip" by (rule sqn [symmetric])
    also have "sqn (rt2 nhip) dip = nsqn\<^sub>r (the (rt2 nhip dip))"
      unfolding nsqn\<^sub>r_def using \<open>dip \<in> vD(rt2 nhip)\<close>
      by - (metis vD_flag_val proj2_eq_sqn proj4_eq_flag vD_iD_gives_kD(1))
    finally show "nsqn\<^sub>r (the (update rt dip (osn, kno, val, Suc hops, nhip) dip))
                                                              = nsqn\<^sub>r (the (rt2 nhip dip))" .
  next
    have "the (dhops (rt2 nhip) dip) \<le> hops" by (rule hop)
    also have "hops < hops + 1" by simp
    also have "hops + 1 = the (dhops (update rt dip (osn, kno, val, Suc hops, nhip)) dip)"
      using ** by simp
    finally have "the (dhops (rt2 nhip) dip)
                        < the (dhops (update rt dip (osn, kno, val, Suc hops, nhip)) dip)" .
    thus "\<pi>\<^sub>5 (the (rt2 nhip dip)) < \<pi>\<^sub>5 (the (update rt dip (osn, kno, val, Suc hops, nhip) dip))"
      using \<open>dip \<in> vD(rt2 nhip)\<close> by (simp add: proj5_eq_dhops)
  qed

lemma nsqn_invalidate:
  assumes "dip \<in> kD(rt)"
      and "\<forall>ip\<in>dom(dests). ip \<in> vD(rt) \<and> the (dests ip) = inc (sqn rt ip)"
    shows "nsqn (invalidate rt dests) dip = nsqn rt dip"
  proof -
    from \<open>dip \<in> kD(rt)\<close> have "dip \<in> kD(invalidate rt dests)" by simp

    from assms have "rt \<approx>\<^bsub>dip\<^esub> invalidate rt dests"
      by (rule rt_fresh_as_inc_invalidate)
    with \<open>dip \<in> kD(rt)\<close> \<open>dip \<in> kD(invalidate rt dests)\<close> show ?thesis
      by (simp add: kD_nsqn del: invalidate_kD_inv)
         (erule(2) rt_fresh_as_nsqnr)
  qed

end


theory Coeffs

imports Main "HOL-Computational_Algebra.Computational_Algebra"

begin

lemma coeffs_in_coeff:
  assumes "\<forall>i. poly.coeff x i \<in> A"
  shows "set (coeffs x) \<subseteq> A"
by (simp add: assms coeffs_def image_subsetI)

end


(* Author: Andreas Lochbihler, ETH Zurich *)

subsection \<open>Probability mass functions implemented as lists with duplicates\<close>

theory Applicative_Probability_List imports
  Applicative_List
  Complex_Main
begin

lemma sum_list_concat_map: "sum_list (concat (map f xs)) = sum_list (map (\<lambda>x. sum_list (f x)) xs)"
by(induction xs) simp_all

context includes applicative_syntax begin

lemma set_ap_list [simp]: "set (f \<diamondop> x) = (\<lambda>(f, x). f x) ` (set f \<times> set x)"
by(auto simp add: ap_list_def List.bind_def)

text \<open>We call the implementation type \<open>pfp\<close> because it is the basis for the Haskell library
  Probability by Martin Erwig and Steve Kollmansberger (Probabilistic Functional Programming).\<close>

typedef 'a pfp = "{xs :: ('a \<times> real) list. (\<forall>(_, p) \<in> set xs. p > 0) \<and> sum_list (map snd xs) = 1}"
proof
  show "[(x, 1)] \<in> ?pfp" for x by simp
qed

setup_lifting type_definition_pfp

lift_definition pure_pfp :: "'a \<Rightarrow> 'a pfp" is "\<lambda>x. [(x, 1)]" by simp

lift_definition ap_pfp :: "('a \<Rightarrow> 'b) pfp \<Rightarrow> 'a pfp \<Rightarrow> 'b pfp"
is "\<lambda>fs xs. [\<lambda>(f, p) (x, q). (f x, p * q)] \<diamondop> fs \<diamondop> xs"
proof safe
  fix xs :: "(('a \<Rightarrow> 'b) \<times> real) list" and ys :: "('a \<times> real) list"
  assume xs: "\<forall>(x, y) \<in> set xs. 0 < y" "sum_list (map snd xs) = 1"
    and ys: "\<forall>(x, y) \<in> set ys. 0 < y" "sum_list (map snd ys) = 1"
  let ?ap = "[\<lambda>(f, p) (x, q). (f x, p * q)] \<diamondop> xs \<diamondop> ys"
  show "0 < b" if "(a, b) \<in> set ?ap" for a b using that xs ys
    by(auto intro!: mult_pos_pos)
  show "sum_list (map snd ?ap) = 1" using xs ys
    by(simp add: ap_list_def List.bind_def map_concat o_def split_beta sum_list_concat_map sum_list_const_mult)
qed

adhoc_overloading Applicative.ap ap_pfp

applicative pfp
 for pure: pure_pfp
     ap: ap_pfp
proof -
  show "pure_pfp (\<lambda>x. x) \<diamondop> x = x" for x :: "'a pfp"
    by transfer(simp add: ap_list_def List.bind_def)
  show "pure_pfp f \<diamondop> pure_pfp x = pure_pfp (f x)" for f :: "'a \<Rightarrow> 'b" and x
    by transfer (applicative_lifting; simp)
  show "pure_pfp (\<lambda>g f x. g (f x)) \<diamondop> g \<diamondop> f \<diamondop> x = g \<diamondop> (f \<diamondop> x)"
    for g :: "('b \<Rightarrow> 'c) pfp" and f :: "('a \<Rightarrow> 'b) pfp" and x
    by transfer(applicative_lifting; clarsimp)
  show "f \<diamondop> pure_pfp x = pure_pfp (\<lambda>f. f x) \<diamondop> f" for f :: "('a \<Rightarrow> 'b) pfp" and x
    by transfer(applicative_lifting; clarsimp)
qed

end

end


theory Modelica_Discrete
  imports "../Modelica_Core"
begin

definition sample :: "real \<Rightarrow> real \<Rightarrow> _" where
[upred_defs]: "sample s p = (\<^bold>\<exists> n::nat \<bullet> &time =\<^sub>u \<guillemotleft>s\<guillemotright> + \<guillemotleft>of_nat n\<guillemotright>*\<guillemotleft>p\<guillemotright>)"

text {* The following function construct the overall event iteration guard by extracting the condition
  of each "when" construct in the model and taking their disjunction. In order words, if ever
  the condition of a "when" is satisfied then event iteration will begin. For us, event iteration
  begins whenever one of the guards changes state, either from false to true to true to false.
  The latter will not actually yield any behaviour though as the discrete equations are only
  executed when their condition was false and is now true.*}

definition mevs :: "('l, 'c) mblock \<Rightarrow> ('l, 'c) mst_scheme hrel" where
[upred_defs]: "mevs M = foldr (\<lambda> g p. (\<lceil>g\<rceil>\<^sub>< \<noteq>\<^sub>u \<lceil>g\<rceil>\<^sub>>) \<or> p) (map fst (mgrds M)) false"

text {* The next construct describes the behaviour of event iteration. At each step, "when" guards
  which are satisfied giving rise to execution of the associated discrete equations. Once no
  more conditions are true, the iteration terminates.

  This behaviour is constructed by folding the conditional construct over the list of guards.
  If a condition $p$ is satisfied, and it wasn't satisfied at the beginning of the interval,
  then the corresponding discrete equation $dq$ will be executed
  and the iteration will recurse. If no more events are possible then the else branch is reached
  and the iteration terminates. *}

definition mdeqs :: "('c::t2_space) mblock \<Rightarrow> 'c mrel" where
"mdeqs M = (\<mu>\<^sub>R X \<bullet> foldr (\<lambda> (p, dq) q. (dq ;; X) \<triangleleft> (\<lceil>p\<rceil>\<^sub>> \<and> \<lceil>\<not> p\<rceil>\<^sub>>\<lbrakk>&\<^bold>d/&\<^bold>c\<rbrakk>) \<triangleright>\<^sub>R q) (mgrds M) II\<^sub>R)"
(*                      p is currently satisfied ---^     ^--- p wasn't satisfied previously *)

text {* The overall behaviour of a Modelica model is then given below. The initialisation is first
  executed. Then the main body of the model's behaviour is given. The continuous equation system
  is first activated, with the "when" guards attached. Once one of the guards changes its value
  from $false$ to $true -- that is when the guard was false in the initial state but is true in the final
  state -- the event iteration is activated. *}

definition mblock_sem :: "('c::t2_space) mblock \<Rightarrow> 'c mrel" ("\<lbrakk>_\<rbrakk>\<^sub>m") where
"\<lbrakk>M\<rbrakk>\<^sub>m = minit M ;;
       (\<mu>\<^sub>R X \<bullet> \<^bold>d :=\<^sub>R &\<^bold>c ;; ((mceqs M) [mevs M]\<^sub>H (mdeqs M)) ;; X)"

definition mblock_sum :: "'c mblock \<Rightarrow> 'c mblock \<Rightarrow> 'c mblock" (infixl "\<oplus>\<^sub>m" 85) where
[upred_defs]:
"A \<oplus>\<^sub>m B = \<lparr> minit = (minit A \<and> minit B)
          , mceqs = (mceqs A \<and> mceqs B)
          , mgrds = (mgrds A @ mgrds B) \<rparr>"

lemma hEvolve_conj: "(&x \<leftarrow>\<^sub>H f(ti) \<and> &y \<leftarrow>\<^sub>H g(ti)) = ({&x,&y} \<leftarrow>\<^sub>H (f(ti), g(ti))\<^sub>u)"
  by (rel_auto)

definition Block :: "('c::t2_space) mblock" where
[upred_defs]:
  "Block = \<lparr> minit = ($st:\<^bold>c:time =\<^sub>u 0), mceqs = &time \<leftarrow>\<^sub>H (&time + \<guillemotleft>ti\<guillemotright>), mgrds = [] \<rparr>"

definition DiscreteBlock :: "real \<Rightarrow> real \<Rightarrow> (bool \<Longrightarrow> 'c mst_ext) \<Rightarrow> (bool \<Longrightarrow> 'c mst_ext) \<Rightarrow> ('d,'c::t2_space) mblock" where
[upred_defs]:
  "DiscreteBlock samplePeriod startTime sampleTrigger firstTrigger
  = Block \<oplus>\<^sub>m
    \<lparr> minit = true
    , mceqs = {&sampleTrigger, &firstTrigger} \<leftarrow>\<^sub>H (&sampleTrigger, &firstTrigger)\<^sub>u
    , mevs = sample startTime samplePeriod
    , mdeqs = undefined \<rparr>"

definition ZeroOrderHold ::
  "real \<Rightarrow> real \<Rightarrow>
  (real \<Longrightarrow> 'c mst_ext) \<Rightarrow> (real \<Longrightarrow> 'c mst_ext) \<Rightarrow> (real \<Longrightarrow> 'c mst_ext) \<Rightarrow>
  ('d, 'c::t2_space) mblock" where
[upred_defs]:
  "ZeroOrderHold samplePeriod startTime u y ySample
  = Block \<oplus>\<^sub>m
    \<lparr> minit = \<lceil>$ySample =\<^sub>u $u \<and> $y =\<^sub>u $ySample\<rceil>\<^sub>C
    , mceqs = ({&y,&ySample} \<leftarrow>\<^sub>H (&ySample, &ySample)\<^sub>u)
    , mevs  = sample startTime samplePeriod
    , mdeqs = \<lceil>$ySample\<acute> =\<^sub>u $u\<rceil>\<^sub>C \<rparr>"

end


theory Force imports Main begin
  (*Use Divides rather than Main to experiment with the first proof.
    Otherwise, it is done by the nat_divide_cancel_factor simprocs.*)

declare div_mult_self_is_m [simp del]

lemma div_mult_self_is_m:
      "0<n \<Longrightarrow> (m*n) div n = (m::nat)"
apply (insert div_mult_mod_eq [of "m*n" n])
apply simp
done

lemma "(\<forall>x. P x) \<and> (\<exists>x. Q x) \<longrightarrow> (\<forall>x. P x \<and> Q x)"
apply clarify
oops

text \<open>
proof\ {\isacharparenleft}prove{\isacharparenright}{\isacharcolon}\ step\ {\isadigit{1}}\isanewline
\isanewline
goal\ {\isacharparenleft}lemma{\isacharparenright}{\isacharcolon}\isanewline
{\isacharparenleft}{\isasymforall}x{\isachardot}\ P\ x{\isacharparenright}\ {\isasymand}\ {\isacharparenleft}{\isasymexists}x{\isachardot}\ Q\ x{\isacharparenright}\ {\isasymlongrightarrow}\ {\isacharparenleft}{\isasymforall}x{\isachardot}\ P\ x\ {\isasymand}\ Q\ x{\isacharparenright}\isanewline
\ {\isadigit{1}}{\isachardot}\ {\isasymAnd}x\ xa{\isachardot}\ {\isasymlbrakk}{\isasymforall}x{\isachardot}\ P\ x{\isacharsemicolon}\ Q\ xa{\isasymrbrakk}\ {\isasymLongrightarrow}\ P\ x\ {\isasymand}\ Q\ x
\<close>

text \<open>
couldn't find a good example of clarsimp

@{thm[display]"someI"}
\rulename{someI}
\<close>

lemma "\<lbrakk>Q a; P a\<rbrakk> \<Longrightarrow> P (SOME x. P x \<and> Q x) \<and> Q (SOME x. P x \<and> Q x)"
apply (rule someI)
oops

lemma "\<lbrakk>Q a; P a\<rbrakk> \<Longrightarrow> P (SOME x. P x \<and> Q x) \<and> Q (SOME x. P x \<and> Q x)"
apply (fast intro!: someI)
done

text\<open>
proof\ {\isacharparenleft}prove{\isacharparenright}{\isacharcolon}\ step\ \isadigit{1}\isanewline
\isanewline
goal\ {\isacharparenleft}lemma{\isacharparenright}{\isacharcolon}\isanewline
{\isasymlbrakk}Q\ a{\isacharsemicolon}\ P\ a{\isasymrbrakk}\ {\isasymLongrightarrow}\ P\ {\isacharparenleft}SOME\ x{\isachardot}\ P\ x\ {\isasymand}\ Q\ x{\isacharparenright}\ {\isasymand}\ Q\ {\isacharparenleft}SOME\ x{\isachardot}\ P\ x\ {\isasymand}\ Q\ x{\isacharparenright}\isanewline
\ \isadigit{1}{\isachardot}\ {\isasymlbrakk}Q\ a{\isacharsemicolon}\ P\ a{\isasymrbrakk}\ {\isasymLongrightarrow}\ P\ {\isacharquery}x\ {\isasymand}\ Q\ {\isacharquery}x
\<close>

end


(*  Title:      HOL/UNITY/Comp/Client.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1998  University of Cambridge
*)

section\<open>Distributed Resource Management System: the Client\<close>

theory Client imports "../Rename" AllocBase begin

type_synonym
  tokbag = nat     \<comment> \<open>tokbags could be multisets...or any ordered type?\<close>

record state =
  giv :: "tokbag list" \<comment> \<open>input history: tokens granted\<close>
  ask :: "tokbag list" \<comment> \<open>output history: tokens requested\<close>
  rel :: "tokbag list" \<comment> \<open>output history: tokens released\<close>
  tok :: tokbag        \<comment> \<open>current token request\<close>

record 'a state_d =
  state +
  dummy :: 'a          \<comment> \<open>new variables\<close>

(*Array indexing is translated to list indexing as A[n] == A!(n-1). *)

  (** Release some tokens **)

definition
  rel_act :: "('a state_d * 'a state_d) set"
  where "rel_act = {(s,s').
                  \<exists>nrel. nrel = size (rel s) &
                         s' = s (| rel := rel s @ [giv s!nrel] |) &
                         nrel < size (giv s) &
                         ask s!nrel \<le> giv s!nrel}"

  (** Choose a new token requirement **)

  (** Including s'=s suppresses fairness, allowing the non-trivial part
      of the action to be ignored **)

definition
  tok_act :: "('a state_d * 'a state_d) set"
  where "tok_act = {(s,s'). s'=s | s' = s (|tok := Suc (tok s mod NbT) |)}"

definition
  ask_act :: "('a state_d * 'a state_d) set"
  where "ask_act = {(s,s'). s'=s |
                         (s' = s (|ask := ask s @ [tok s]|))}"

definition
  Client :: "'a state_d program"
  where "Client =
       mk_total_program
            ({s. tok s \<in> atMost NbT &
                 giv s = [] & ask s = [] & rel s = []},
             {rel_act, tok_act, ask_act},
             \<Union>G \<in> preserves rel Int preserves ask Int preserves tok.
                   Acts G)"

definition
  (*Maybe want a special theory section to declare such maps*)
  non_dummy :: "'a state_d => state"
  where "non_dummy s = (|giv = giv s, ask = ask s, rel = rel s, tok = tok s|)"

definition
  (*Renaming map to put a Client into the standard form*)
  client_map :: "'a state_d => state*'a"
  where "client_map = funPair non_dummy dummy"

declare Client_def [THEN def_prg_Init, simp]
declare Client_def [THEN def_prg_AllowedActs, simp]
declare rel_act_def [THEN def_act_simp, simp]
declare tok_act_def [THEN def_act_simp, simp]
declare ask_act_def [THEN def_act_simp, simp]

lemma Client_ok_iff [iff]:
     "(Client ok G) =
      (G \<in> preserves rel & G \<in> preserves ask & G \<in> preserves tok &
       Client \<in> Allowed G)"
by (auto simp add: ok_iff_Allowed Client_def [THEN def_total_prg_Allowed])

text\<open>Safety property 1: ask, rel are increasing\<close>
lemma increasing_ask_rel:
     "Client \<in> UNIV guarantees Increasing ask Int Increasing rel"
apply (auto intro!: increasing_imp_Increasing simp add: guar_def preserves_subset_increasing [THEN subsetD])
apply (auto simp add: Client_def increasing_def)
apply (safety, auto)+
done

declare nth_append [simp] append_one_prefix [simp]

text\<open>Safety property 2: the client never requests too many tokens.
      With no Substitution Axiom, we must prove the two invariants
      simultaneously.\<close>
lemma ask_bounded_lemma:
     "Client ok G
      ==> Client \<squnion> G \<in>
              Always ({s. tok s \<le> NbT}  Int
                      {s. \<forall>elt \<in> set (ask s). elt \<le> NbT})"
apply auto
apply (rule invariantI [THEN stable_Join_Always2], force)
 prefer 2
 apply (fast elim!: preserves_subset_stable [THEN subsetD] intro!: stable_Int)
apply (simp add: Client_def, safety)
apply (cut_tac m = "tok s" in NbT_pos [THEN mod_less_divisor], auto)
done

text\<open>export version, with no mention of tok in the postcondition, but
  unfortunately tok must be declared local.\<close>
lemma ask_bounded:
     "Client \<in> UNIV guarantees Always {s. \<forall>elt \<in> set (ask s). elt \<le> NbT}"
apply (rule guaranteesI)
apply (erule ask_bounded_lemma [THEN Always_weaken])
apply (rule Int_lower2)
done

text\<open>** Towards proving the liveness property **\<close>

lemma stable_rel_le_giv: "Client \<in> stable {s. rel s \<le> giv s}"
by (simp add: Client_def, safety, auto)

lemma Join_Stable_rel_le_giv:
     "[| Client \<squnion> G \<in> Increasing giv;  G \<in> preserves rel |]
      ==> Client \<squnion> G \<in> Stable {s. rel s \<le> giv s}"
by (rule stable_rel_le_giv [THEN Increasing_preserves_Stable], auto)

lemma Join_Always_rel_le_giv:
     "[| Client \<squnion> G \<in> Increasing giv;  G \<in> preserves rel |]
      ==> Client \<squnion> G \<in> Always {s. rel s \<le> giv s}"
by (force intro: AlwaysI Join_Stable_rel_le_giv)

lemma transient_lemma:
     "Client \<in> transient {s. rel s = k & k<h & h \<le> giv s & h pfixGe ask s}"
apply (simp add: Client_def mk_total_program_def)
apply (rule_tac act = rel_act in totalize_transientI)
  apply (auto simp add: Domain_unfold Client_def)
 apply (blast intro: less_le_trans prefix_length_le strict_prefix_length_less)
apply (auto simp add: prefix_def genPrefix_iff_nth Ge_def)
apply (blast intro: strict_prefix_length_less)
done

lemma induct_lemma:
     "[| Client \<squnion> G \<in> Increasing giv;  Client ok G |]
  ==> Client \<squnion> G \<in> {s. rel s = k & k<h & h \<le> giv s & h pfixGe ask s}
                      LeadsTo {s. k < rel s & rel s \<le> giv s &
                                  h \<le> giv s & h pfixGe ask s}"
apply (rule single_LeadsTo_I)
apply (frule increasing_ask_rel [THEN guaranteesD], auto)
apply (rule transient_lemma [THEN Join_transient_I1, THEN transient_imp_leadsTo, THEN leadsTo_imp_LeadsTo, THEN PSP_Stable, THEN LeadsTo_weaken])
  apply (rule Stable_Int [THEN Stable_Int, THEN Stable_Int])
     apply (erule_tac f = giv and x = "giv s" in IncreasingD)
    apply (erule_tac f = ask and x = "ask s" in IncreasingD)
   apply (erule_tac f = rel and x = "rel s" in IncreasingD)
  apply (erule Join_Stable_rel_le_giv, blast)
 apply (blast intro: order_less_imp_le order_trans)
apply (blast intro: sym order_less_le [THEN iffD2] order_trans
                    prefix_imp_pfixGe pfixGe_trans)
done

lemma rel_progress_lemma:
     "[| Client \<squnion> G \<in> Increasing giv;  Client ok G |]
  ==> Client \<squnion> G \<in> {s. rel s < h & h \<le> giv s & h pfixGe ask s}
                      LeadsTo {s. h \<le> rel s}"
apply (rule_tac f = "%s. size h - size (rel s) " in LessThan_induct)
apply (auto simp add: vimage_def)
apply (rule single_LeadsTo_I)
apply (rule induct_lemma [THEN LeadsTo_weaken], auto)
 apply (blast intro: order_less_le [THEN iffD2] dest: common_prefix_linear)
apply (drule strict_prefix_length_less)+
apply arith
done

lemma client_progress_lemma:
     "[| Client \<squnion> G \<in> Increasing giv;  Client ok G |]
      ==> Client \<squnion> G \<in> {s. h \<le> giv s & h pfixGe ask s}
                          LeadsTo {s. h \<le> rel s}"
apply (rule Join_Always_rel_le_giv [THEN Always_LeadsToI], simp_all)
apply (rule LeadsTo_Un [THEN LeadsTo_weaken_L])
  apply (blast intro: rel_progress_lemma)
 apply (rule subset_refl [THEN subset_imp_LeadsTo])
apply (blast intro: order_less_le [THEN iffD2] dest: common_prefix_linear)
done

text\<open>Progress property: all tokens that are given will be released\<close>
lemma client_progress:
     "Client \<in>
       Increasing giv  guarantees
       (INT h. {s. h \<le> giv s & h pfixGe ask s} LeadsTo {s. h \<le> rel s})"
apply (rule guaranteesI, clarify)
apply (blast intro: client_progress_lemma)
done

text\<open>This shows that the Client won't alter other variables in any state
  that it is combined with\<close>
lemma client_preserves_dummy: "Client \<in> preserves dummy"
by (simp add: Client_def preserves_def, clarify, safety, auto)

text\<open>* Obsolete lemmas from first version of the Client *\<close>

lemma stable_size_rel_le_giv:
     "Client \<in> stable {s. size (rel s) \<le> size (giv s)}"
by (simp add: Client_def, safety, auto)

text\<open>clients return the right number of tokens\<close>
lemma ok_guar_rel_prefix_giv:
     "Client \<in> Increasing giv  guarantees  Always {s. rel s \<le> giv s}"
apply (rule guaranteesI)
apply (rule AlwaysI, force)
apply (blast intro: Increasing_preserves_Stable stable_rel_le_giv)
done

end


section "Small Proofs"

theory Small_Proof
imports Common_Proof Small_Aux
begin

lemma step_size [simp]: "invar (small :: 'a state) \<Longrightarrow> size (step small) = size small"
  by(induction small rule: step_state.induct)(auto split: current.splits)

lemma step_size_new [simp]: "invar (small :: 'a state) \<Longrightarrow> size_new (step small) = size_new small"
  by(induction small rule: step_state.induct)(auto split: current.splits)

lemma size_push [simp]: "invar small \<Longrightarrow> size (push x small) = Suc (size small)"
  by(induction x small rule: push.induct) (auto split: current.splits)

lemma size_new_push [simp]: "invar small \<Longrightarrow> size_new (push x small) = Suc (size_new small)"
  by(induction x small rule: push.induct) (auto split: current.splits)

lemma size_pop [simp]: "\<lbrakk>invar small; 0 < size small; pop small = (x, small')\<rbrakk>
   \<Longrightarrow> Suc (size small') = size small"
proof(induction small rule: pop.induct)
  case (1 state)
  then show ?case
    by(auto split: prod.splits)
next
  case (2 current small auxS)
  then show ?case
    using Current_Proof.size_pop[of current]
    by(induction current rule: Current.pop.induct) auto
next
  case (3 current auxS big newS count)
  then show ?case
    using Current_Proof.size_pop[of current]
    by(induction current rule: Current.pop.induct) auto
qed

lemma size_new_pop [simp]: "\<lbrakk>invar small; 0 < size_new small; pop small = (x, small')\<rbrakk>
   \<Longrightarrow> Suc (size_new small') = size_new small"
proof(induction small rule: pop.induct)
  case (1 state)
  then show ?case
    by(auto split: prod.splits)
next
  case (2 current small auxS)
  then show ?case
  by(induction current rule: Current.pop.induct) auto
next
  case (3 current auxS big newS count)
  then show ?case
    by(induction current rule: Current.pop.induct) auto
qed

lemma size_size_new: "\<lbrakk>invar (small :: 'a state); 0 < size small\<rbrakk> \<Longrightarrow> 0 < size_new small"
  by(induction small)(auto simp: size_size_new)

lemma step_list_current [simp]: "invar small \<Longrightarrow> list_current (step small) = list_current small"
  by(induction small rule: step_state.induct)(auto split: current.splits)

lemma step_list_common [simp]:
    "\<lbrakk>small = Common common; invar small\<rbrakk> \<Longrightarrow> list (step small) = list small"
  by auto

lemma step_list_reverse2 [simp]:
  assumes
    "small = (Reverse2 current aux big new count)"
    "invar small"
  shows
    "list (step small) = list small"
proof -

  have size_not_empty: "(0 < size big) = (\<not> is_empty big)"
    by (simp add: Stack_Proof.size_not_empty)

  have "\<not> is_empty big
     \<Longrightarrow> rev (Stack_Aux.list (Stack.pop big)) @ [Stack.first big] = rev (Stack_Aux.list big)"
    by(induction big rule: Stack.pop.induct) auto

  with assms show ?thesis
    using Stack_Proof.size_pop[of big] size_not_empty
    by(auto simp: Stack_Proof.list_empty split: current.splits)
qed

      with 2 have "rev (Stack_Aux.list small) @ aux =
                   rev (Stack_Aux.list (Stack.pop small)) @ Stack.first small # aux"
        by(auto simp: rev_app_single Stack_Proof.list_not_empty)

      with 2 show ?thesis
        by(auto split: current.splits)
    qed
next
  case (3 current auxS big newS count)
  then show ?case
  proof(cases "is_empty big")
    case True

    then have big_size [simp]: "size big = 0"
      by (simp add: Stack_Proof.size_empty)

    with True 3 show ?thesis
    proof(cases current)
      case (Current extra added old remained)
      with 3 True show ?thesis
      proof(cases "remained \<le> count")
        case True
        with 3 Current show ?thesis
          using Stack_Proof.size_empty[of big]
          by auto
      next
        case False
        with True 3 Current show ?thesis
          by(auto)
        qed
    qed
  next
    case False
    with 3 show ?thesis
      using Stack_Proof.size_pop[of big]
      by(auto simp: Stack_Proof.size_not_empty split: current.splits)
  qed
qed

lemma invar_push: "invar small \<Longrightarrow> invar (push x small)"
  by(induction x small rule: push.induct)(auto simp: invar_push split: current.splits)

lemma invar_pop: "\<lbrakk>
  0 < size small;
  invar small;
  pop small = (x, small')
\<rbrakk> \<Longrightarrow> invar small'"
proof(induction small arbitrary: x rule: pop.induct)
case (1 state)
  then show ?case
    by(auto simp: invar_pop split: prod.splits)
next
  case (2 current small auxS)
  then show ?case
  proof(induction current rule: Current.pop.induct)
    case (1 added old remained)
    then show ?case
      by(cases "size small < size old")
        (auto simp: rev_take Suc_diff_le drop_Suc tl_drop)
  next
    case 2
    then show ?case by auto
  qed
next
  case (3 current auxS big newS count)
  then show ?case
    by (induction current rule: Current.pop.induct)
       (auto simp: rev_take Suc_diff_le drop_Suc tl_drop)
qed

lemma push_list_common [simp]: "small = Common common \<Longrightarrow> list (push x small) = x # list small"
  by auto

lemma push_list_current [simp]: "list_current (push x small) = x # list_current small"
  by(induction x small rule: push.induct) auto

lemma pop_list_current [simp]: "\<lbrakk>invar small; 0 < size small; Small.pop small = (x, small')\<rbrakk>
  \<Longrightarrow> x # list_current small' = list_current small"
proof(induction small arbitrary: x rule: pop.induct)
  case (1 state)
  then show ?case
    by(auto simp: pop_list_current split: prod.splits)
next
  case (2 current small auxS)
  then have "invar current"
    by(auto split: current.splits)

  with 2 show ?case
    by auto
next
  case (3 current auxS big newS count)
  then show ?case
  proof(induction current rule: Current.pop.induct)
    case (1 added old remained)
    then have "\<not>is_empty old"
      by(auto simp: Stack_Proof.size_not_empty)

    with 1 show ?case
      by(auto simp: rev_take drop_Suc drop_tl)
  next
    case 2
    then show ?case
      by auto
  qed
qed

lemma list_current_size [simp]: "\<lbrakk>0 < size small; list_current small = []; invar small\<rbrakk> \<Longrightarrow> False"
proof(induction small)
  case (Reverse1 current)
  then have "invar current"
    by(auto split: current.splits)

  with Reverse1 show ?case
    using Current_Proof.list_size
    by auto
next
  case Reverse2
  then show ?case
    by(auto split: current.splits)
next
  case Common
  then show ?case
    using list_current_size by auto
qed

lemma list_Reverse2 [simp]: "\<lbrakk>
  0 < size (Reverse2 current auxS big newS count);
  invar (Reverse2 current auxS big newS count)
\<rbrakk> \<Longrightarrow>
   fst (Current.pop current) # list (Reverse2 (drop_first current) auxS big newS count) =
   list (Reverse2 current auxS big newS count)"
  by(induction current rule: Current.pop.induct)
    (auto simp: first_hd rev_take Suc_diff_le)

end


header{*Gödel's Second Incompleteness Theorem*}

theory Goedel_II
imports Goedel_I Quote
begin

text{*The connection between @{term Quote} and @{term HR} (for interest only). *}

lemma Quote_q_Eats [intro]:
  "Quote y y' \<Longrightarrow> Quote z z' \<Longrightarrow> Quote (y \<triangleleft> z) (q_Eats y' z')"
  by (auto simp: Quote_def SeqQuote_def intro: BuildSeq2_combine)

lemma Quote_q_Succ [intro]:  "Quote y y' \<Longrightarrow> Quote (succ y) (q_Succ y')"
  by (auto simp: succ_def q_Succ_def)

lemma HR_imp_eq_H: "HR x z \<Longrightarrow> z = \<lbrakk>HF x\<rbrakk>e"
  apply (auto simp add: SeqHR_def HR_def)
  apply (erule BuildSeq2_induct, auto simp add: q_defs WR_iff_eq_W [where e=e])
  done

lemma HR_Ord_D: "HR x y \<Longrightarrow> Ord x \<Longrightarrow> WR x y"
  by (metis HF_Ord HR_imp_eq_H WR_iff_eq_W)

lemma WR_Quote: "WR (ord_of i) y \<Longrightarrow> Quote (ord_of i) y"
  by (induct i arbitrary: y) (auto simp: Quote_0 WR0_iff WR_succ_iff q_Succ_def [symmetric])

lemma HR_imp_Quote: "coding_hf x \<Longrightarrow> HR x y \<Longrightarrow> Quote x y"
  apply (induct x arbitrary: y rule: coding_hf.induct, auto simp: WR_Quote HR_Ord_D)
  apply (auto dest!: HR_imp_eq_H [where e= e0])
  by (metis hpair_def' Quote_0 HR_H Quote_q_Eats)

interpretation qp0: quote_perm 0 "{}" "make_F {} 0"
  proof unfold_locales qed auto

lemma MonPon_PfP_implies_PfP:
  "\<lbrakk>{} \<turnstile> \<alpha> IMP \<beta>; ground_fm \<alpha>; ground_fm \<beta>\<rbrakk> \<Longrightarrow> {PfP \<lceil>\<alpha>\<rceil>} \<turnstile> PfP \<lceil>\<beta>\<rceil>"
  using qp0.quote_all_MonPon_PfP_ssubst
  by auto (metis Assume PfP_implies_ModPon_PfP_quot proved_iff_proved_PfP thin0)

lemma PfP_quot_contra: "ground_fm \<alpha> \<Longrightarrow> {} \<turnstile> PfP \<lceil>\<alpha>\<rceil> IMP PfP \<lceil>Neg \<alpha>\<rceil> IMP PfP \<lceil>Fls\<rceil>"
  using qp0.quote_all_Contra_PfP_ssubst
  by (auto simp: qp0.quote_all_Contra_PfP_ssubst ground_fm_aux_def)

text{*Gödel's second incompleteness theorem:
      If consistent, our theory cannot prove its own consistency.*}
theorem Goedel_II:
  assumes "\<not> {} \<turnstile> Fls"
    shows "\<not> {} \<turnstile> Neg (PfP \<lceil>Fls\<rceil>)"
proof -
  from assms Goedel_I obtain \<delta>
    where diag: "{} \<turnstile> \<delta> IFF Neg (PfP \<lceil>\<delta>\<rceil>)"  "\<not> {} \<turnstile> \<delta>"
      and gnd:  "ground_fm \<delta>"
    by metis
  have "{PfP \<lceil>\<delta>\<rceil>} \<turnstile> PfP \<lceil>PfP \<lceil>\<delta>\<rceil>\<rceil>"
    by (auto simp: Provability ground_fm_aux_def supp_conv_fresh)
  moreover have "{PfP \<lceil>\<delta>\<rceil>} \<turnstile> PfP \<lceil>Neg (PfP \<lceil>\<delta>\<rceil>)\<rceil>"
    apply (rule MonPon_PfP_implies_PfP [OF _ gnd])
    apply (metis Conj_E2 Iff_def Iff_sym diag(1))
    apply (auto simp: ground_fm_aux_def supp_conv_fresh)
    done
  moreover have "ground_fm (PfP \<lceil>\<delta>\<rceil>)"
    by (auto simp: ground_fm_aux_def supp_conv_fresh)
  ultimately have "{PfP \<lceil>\<delta>\<rceil>} \<turnstile> PfP \<lceil>Fls\<rceil>" using PfP_quot_contra
    by (metis (no_types) anti_deduction cut2)
  thus "\<not> {} \<turnstile> Neg (PfP \<lceil>Fls\<rceil>)"
    by (metis Iff_MP2_same Neg_mono cut1 diag)
qed

end


theory deMorgan3
  imports Main
begin
  text\<open> Apply style \<close>
lemma lem_k_1 : " (\<not>p \<or> \<not>q)\<longrightarrow> \<not>(p \<and> q)"
    apply (rule impI)
  apply (erule disjE)
   apply (rule notI)
  apply (erule notE)
   apply (erule conjE)
   apply assumption
  apply (rule notI)
  apply (erule conjE)
  apply (erule notE)
  apply assumption
  done
end


theory model
imports HHL
begin

definition T :: exp where
"T == Real 0.01"
definition t :: exp where
"t == RVar ''t''"
definition h :: exp where
"h == RVar ''h''"
definition v :: exp where
"v == RVar ''v''"
consts Qmax :: exp
consts pi :: exp
consts g :: exp
consts r :: exp

consts c2p :: cname
consts p2c :: cname

definition x :: exp where
"x == RVar ''x''"
definition y :: exp where
"y == RVar ''y''"

definition conProp :: fform where
"conProp == (y[=](Real 0) [|] y[=](Real 1))"

definition inv :: fform where
"inv == t[>=](Real 0) [&] t[<=]T [&] (v[=](Real 1) [&] (h[>=](Real 0.30) [&] h[*](Real 1000)[<=](Real 590)[+](Real 3)[*]t) [|] (v[=](Real 0) [&] h[<=](Real 0.60) [&] h[*](Real 1000)[>=](Real 310) [-] (Real 7)[*]t))"
definition invT0 :: fform where
"invT0 == (v[=](Real 1) [&] (h[>=](Real 0.30) [&] h[<=](Real 0.59)) [|] (v[=](Real 0) [&] h[<=](Real 0.60) [&] h[>=](Real 0.31)))"
definition invX :: fform where
"invX == x[=]h [&] t[>=](Real 0) [&] t[<=]T [&] (v[=](Real 1) [&] (x[>=](Real 0.30) [&] x[*](Real 1000)[<=](Real 590)[+](Real 3)[*]t) [|] (v[=](Real 0) [&] x[<=](Real 0.60) [&] x[*](Real 1000)[>=](Real 310) [-] (Real 7)[*]t)) [&] conProp"
definition invXY :: fform where
"invXY == x[=]h [&] t[>=](Real 0) [&] t[<=]T [&] (v[=](Real 1) [&] (x[>=](Real 0.30) [&] x[*](Real 1000)[<=](Real 590)[+](Real 3)[*]t) [|] (v[=](Real 0) [&] x[<=](Real 0.60) [&] x[*](Real 1000)[>=](Real 310) [-] (Real 7)[*]t)) [&] ((y[=](Real 1) [|] x[>](Real 0.31))) [&] conProp"
definition invXY0 :: fform where
"invXY0 == x[=]h [&] t[>=](Real 0) [&] t[<=]T [&] (y[=](Real 1) [&] (x[>=](Real 0.30) [&] x[<=](Real 0.59)) [|] (y[=](Real 0) [&] x[<=](Real 0.60) [&] x[>=](Real 0.31))) [&] conProp"

definition init :: fform where
"init == (t[=](Real 0)) [&] (h[=](Real 0.31)) [&] (v[=](Real 1))"
definition post :: fform where
"post == (h[>=](Real 0.30)) [&] (h[<=](Real 0.60))"
definition H :: fform where
"H == high (post)"

definition mid0 :: "mid" where
"mid0 == (inv, (high inv) [&] (l[=]T))"
definition mid1 :: "mid" where
"mid1 == (invT0, (high inv) [&] (l[=]T))"
definition mid2 :: "mid" where
"mid2 == (conProp, (l[=]T))"
definition mid3 :: "mid" where
"mid3 == (invX, (l[=]T))"
definition mid4 :: "mid" where
"mid4 == (invXY, (l[=](Real 0)))"
definition mid5 :: "mid" where
"mid5 == (invXY0, (l[=]T))"

definition Plant :: proc where
"Plant ==  (((<inv && (t[<]T)> : (l[=]T)) [[> (p2c !! h)); mid0; (c2p ?? v)); mid1; (t:=(Real 0))"

definition Control :: proc where
"Control ==(((<conProp && WTrue> : (l[=]T)); mid2; p2c??x); mid3; ((IF (x[<=](Real 0.31)) (y:=(Real 1))); mid4; (IF (x[>=](Real 0.59)) (y:=(Real 0))))); mid5; c2p!!y"

definition WLCS :: proc where
"WLCS == (Plant *) || (Control *)"

lemma "{init, conProp} WLCS {post, conProp; H, WTrue}"
apply (simp add: WLCS_def)
apply (cut_tac px= "inv" and py="conProp" and qx="inv" and qy="conProp" and Hx="high inv " and Hy="WTrue" in ConsequenceP,auto)
prefer 2
(*to inv*)
apply (rule conjR)
apply (rule Trans)
apply (simp add: init_def inv_def v_def h_def t_def equal_greater_def equal_less_def T_def)
apply (rule conjR)
apply (rule Trans)
apply (simp add: init_def inv_def v_def h_def t_def equal_greater_def equal_less_def)
apply (rule conjR)
apply (simp add: inv_def post_def)
apply (rule impR)
apply (rule conjL, rule conjL)
apply (rule disjL)
apply (rule conjR)
apply (rule Trans3)
apply (simp add: init_def inv_def v_def h_def t_def equal_greater_def equal_less_def post_def T_def)
apply (rule conjL)+
apply (cut_tac P="v [=] Real 1" in thinL, auto)
apply (cut_tac P="h [>=] Real 3 / 10" in thinL, auto)
apply (rule Trans3)
apply (simp add: init_def inv_def v_def h_def t_def equal_greater_def equal_less_def post_def T_def)
apply smt
apply (rule Trans3)
apply (simp add: init_def inv_def v_def h_def t_def equal_greater_def equal_less_def post_def T_def)
apply smt
apply (rule conjR, rule impR, rule basic)
apply (rule conjR, rule impR)
apply (simp add: H_def)
apply (rule DC18)
apply (simp add: inv_def post_def)
apply (rule conjL, rule conjL)
apply (rule disjL)
apply (rule Trans3)
apply (simp add: init_def inv_def v_def h_def t_def equal_greater_def equal_less_def post_def T_def)
apply smt
apply (rule Trans3)
apply (simp add: init_def inv_def v_def h_def t_def equal_greater_def equal_less_def post_def T_def)
apply smt
apply (rule impR, rule basic)
(*rep*)
apply (rule Repetition)
defer
(*to inv*)
apply (rule impR)
apply (rule DCR3, rule basic)
apply (rule impR, rule thinL, rule Trans, simp)
(*one*)
apply (cut_tac px= "inv" and py="conProp" and qx="inv" and qy="conProp" and Hx="(high inv) [&] (l[=]T)" and Hy="WTrue [&] (l[=]T)" in ConsequenceP,auto)
prefer 2
apply (rule Trans, simp)
apply (simp add: Plant_def Control_def)
apply (rule Structure)
apply (simp add: mid5_def mid1_def)
apply (cut_tac Gy="l[=](Real 0)" in Parallel1a, auto)
defer
apply (rule Assign, auto)
apply (simp add: inv_def equal_greater_def equal_less_def)
apply (rule Trans)
apply (simp add: invT0_def t_def inv_def init_def inv_def v_def h_def t_def equal_greater_def equal_less_def T_def)
apply smt
apply (rule impR, rule LL4, rule basic)
(*comm1*)
apply (simp add: mid0_def)
apply (rule Communication1, auto)
apply (simp add: invT0_def equal_greater_def equal_less_def)
defer
apply (rule conjR, rule impR)
apply (simp add: invXY0_def)
apply (rule conjL)+
apply (rule basic)
apply (rule impR, rule conjL, cut_tac P="inv" in thinL, auto)
apply (simp add: invXY0_def invT0_def v_def y_def h_def equal_greater_def equal_less_def x_def)
apply (rule conjL)+
apply (cut_tac P="t [>] Real 0 [|] t [=] Real 0" in thinL, auto)
apply (cut_tac P="t [<] T [|] t [=] T" in thinL, auto)
apply (cut_tac P="conProp" in thinL, auto)
apply (rule Trans2, simp)
apply (metis zero_neq_one)
apply (rule conjR, rule impR, rule thinL, rule Trans, simp)
apply (rule impR, rule LC1)
apply (rule DCL3)
apply (rule basic)
apply (rule Trans, simp)
(*ass*)
apply (rule Structure)
apply (simp add: mid3_def)
apply (cut_tac Gy="l[=](Real 0)" in Parallel1a, auto)
defer
apply (cut_tac px="invX" and qx="invXY0" and Hx="(l[=](Real 0))[^](l[=](Real 0))" in ConsequenceS, auto)
apply (simp add: mid4_def)
apply (rule Sequence)
apply (cut_tac b="(x [<=] Real 31 / 100)" in Case, auto)
apply (rule ConditionT)
apply (rule Trans, simp)
apply (rule Assign, auto)
apply (simp add: invXY_def conProp_def equal_greater_def equal_less_def)
apply (rule conjR)
apply (simp add: x_def y_def invX_def invXY_def equal_greater_def equal_less_def t_def T_def h_def v_def)
apply (rule impR)
apply (rule conjL)+
apply (rule conjR, rule basic)+
apply (rule thinL)+
apply (rule Trans, simp add: conProp_def y_def)
apply (rule impR, rule basic)
apply (rule ConditionF)
apply (rule Trans, simp)
apply (simp add: x_def y_def invX_def invXY_def equal_greater_def equal_less_def t_def T_def h_def v_def)
apply (rule impR)
apply (rule conjL)+
apply (rule conjR, rule basic)+
apply (rule thinL, rule thinL, rule thinL, rule thinL)
apply (rule conjR, rule thinL)
apply (rule disjR, rule thinR)
apply (rule Trans1, simp)
apply (rule basic)
apply (rule impR, rule basic)
apply (cut_tac b="(x [>=] Real 59 / 100)" in Case, auto)
apply (rule ConditionT)
apply (rule Trans, simp)
apply (rule Assign, auto)
apply (simp add: invXY0_def conProp_def equal_greater_def equal_less_def)
apply (rule conjR)
apply (simp add: invXY_def invXY0_def equal_greater_def equal_less_def t_def T_def h_def v_def y_def x_def conProp_def)
apply (rule Trans, simp)
apply smt
apply (rule impR, rule basic)
apply (rule ConditionF)
apply (rule Trans, simp)
apply (simp add: invXY_def invXY0_def)
apply (rule impR)
apply (rule conjL)+
apply (rule conjR, rule basic)+
apply (rule conjR)
apply (cut_tac P="x [>=] Real 3 / 10" in cut, auto)
apply (rule thinR)
apply (rule thinL, rule thinL)
apply (cut_tac P="conProp" in thinL, auto)
apply (rule Trans4)
apply (simp add: invXY_def invXY0_def equal_greater_def equal_less_def t_def T_def h_def v_def y_def x_def)
apply smt
apply (rule thinL, rule thinL, rule thinL, rule thinL)
apply (rule Trans4, simp add: conProp_def x_def y_def equal_greater_def equal_less_def)
apply metis
apply (rule basic)
apply (rule impR, rule basic)
apply (rule conjR, rule impR, rule basic)+
apply (rule impR, rule LL4, rule basic)+
(*comm2*)
apply (simp add: mid2_def)
apply (cut_tac Hy="l[=]T" and H="l[=]T" and pre="inv" and Init="WTrue" in CommunicationI1b, auto)
apply (simp add: invX_def conProp_def equal_greater_def equal_less_def)
apply (rule impR, rule basic)
apply (rule impR, rule RL3)
apply (cut_tac R=WTrue in CMR, auto)
apply (rule basic)
apply (rule thinL, rule Trans, simp)
apply (cut_tac px="conProp [&] WTrue" and qx="conProp" and Hx="l [=] T" in ConsequenceS, auto)
apply (rule Continue)
prefer 6
apply (simp add: invXY_def invXY0_def equal_greater_def equal_less_def t_def T_def h_def v_def y_def x_def)
apply (simp add: invX_def inv_def equal_greater_def equal_less_def t_def T_def h_def v_def y_def x_def)
apply (rule impR)
apply (rule conjL)+
apply (rule conjR)
apply (rule thinL)+
apply (rule Trans, simp)
apply (rule conjR, rule basic)+
apply (simp add: conProp_def y_def, rule basic)
prefer 6
apply (rule impR)
apply (rule conjL)+
apply (rule disjL)
apply (rule Trans2, simp add: ltrans T_def)
apply (metis mult_zero_left zero_neq_one)
apply (rule conjR)
apply (cut_tac P="l[=]T" in thinL, auto)
apply (rule DC18)
apply (rule conjL)+
apply (rule basic)+
apply (rule Trans, simp add: conProp_def)+
done

end


section {*L\_ATS\_History*}
theory
  L_ATS_History

imports
  PRJ_06_02__ENTRY

begin

locale ATS_History =
  ATS
  "TSstructure :: 'TSstructure \<Rightarrow> bool"
  "configurations :: 'TSstructure \<Rightarrow> 'conf set"
  "initial_configurations :: 'TSstructure \<Rightarrow> 'conf set"
  "step_labels :: 'TSstructure \<Rightarrow> 'label set"
  "step_relation :: 'TSstructure \<Rightarrow> 'conf \<Rightarrow> 'label \<Rightarrow> 'conf \<Rightarrow> bool"
  for
    TSstructure configurations initial_configurations step_labels step_relation
    +

fixes histories :: "'TSstructure \<Rightarrow> 'history set"
fixes history_fragments :: "'TSstructure \<Rightarrow> 'history_fragment set"
fixes empty_history :: "'TSstructure \<Rightarrow> 'history"
fixes empty_history_fragment :: "'TSstructure \<Rightarrow> 'history_fragment"
fixes set_history :: "'conf \<Rightarrow> 'history \<Rightarrow> 'conf"
fixes extend_history :: "'history \<Rightarrow> 'history_fragment \<Rightarrow> 'history"
fixes join_history_fragments :: "'history_fragment \<Rightarrow> 'history_fragment \<Rightarrow> 'history_fragment"
fixes get_history :: "'conf \<Rightarrow> 'history"

assumes AX_initial_history_empty: "
  TSstructure G
  \<Longrightarrow> c \<in> initial_configurations G
  \<Longrightarrow> get_history c = empty_history G"

assumes AX_steps_extend_history: "
  TSstructure G
  \<Longrightarrow> c \<in> configurations G
  \<Longrightarrow> step_relation G c e c'
  \<Longrightarrow> \<exists>hf \<in> history_fragments G. get_history c' = extend_history (get_history c) hf"

assumes AX_empty_history_is_history: "
  TSstructure G
  \<Longrightarrow> empty_history G \<in> histories G"

assumes AX_empty_history_fragment_is_history_fragment: "
  TSstructure G
  \<Longrightarrow> empty_history_fragment G \<in> history_fragments G"

assumes AX_set_get_history: "
  TSstructure G
  \<Longrightarrow> c \<in> configurations G
  \<Longrightarrow> set_history c (get_history c) = c"

assumes AX_get_set_history: "
  TSstructure G
  \<Longrightarrow> c \<in> configurations G
  \<Longrightarrow> h \<in> histories G
  \<Longrightarrow> get_history (set_history c h) = h"

assumes AX_extend_history_empty1: "
  TSstructure G
  \<Longrightarrow> h \<in> histories G
  \<Longrightarrow> extend_history h (empty_history_fragment G) = h"

assumes AX_extend_history_empty2: "
  TSstructure G
  \<Longrightarrow> h \<in> histories G
  \<Longrightarrow> extend_history h hf = h
  \<Longrightarrow> hf = empty_history_fragment G"

assumes AX_extend_history_add: "
  TSstructure G
  \<Longrightarrow> h \<in> histories G
  \<Longrightarrow> hf1 \<in> history_fragments G
  \<Longrightarrow> hf2 \<in> history_fragments G
  \<Longrightarrow> extend_history h (join_history_fragments hf1 hf2) = h1
  \<Longrightarrow> extend_history (extend_history h hf1) hf2 = h2
  \<Longrightarrow> h1 = h2"

assumes AX_join_history_fragments_closed: "
  TSstructure G
  \<Longrightarrow> hf1 \<in> history_fragments G
  \<Longrightarrow> hf2 \<in> history_fragments G
  \<Longrightarrow> join_history_fragments hf1 hf2 \<in> history_fragments G"

assumes AX_join_history_fragments_empty1: "
  TSstructure G
  \<Longrightarrow> hf \<in> history_fragments G
  \<Longrightarrow> join_history_fragments hf (empty_history_fragment G) = hf"

assumes AX_join_history_fragments_empty2: "
  TSstructure G
  \<Longrightarrow> hf \<in> history_fragments G
  \<Longrightarrow> join_history_fragments (empty_history_fragment G) hf = hf"

assumes AX_join_history_fragments_asso: "
  TSstructure G
  \<Longrightarrow> hf1 \<in> history_fragments G
  \<Longrightarrow> hf2 \<in> history_fragments G
  \<Longrightarrow> hf3 \<in> history_fragments G
  \<Longrightarrow> join_history_fragments (join_history_fragments hf1 hf2) hf3 = join_history_fragments hf1 (join_history_fragments hf2 hf3)"

assumes AX_get_history_closed: "
  TSstructure G
  \<Longrightarrow> c \<in> configurations G
  \<Longrightarrow> get_history c \<in> histories G"

assumes AX_join_history_fragments_injective: "
  TSstructure G
  \<Longrightarrow> h \<in> histories G
  \<Longrightarrow> hf1 \<in> history_fragments G
  \<Longrightarrow> hf2 \<in> history_fragments G
  \<Longrightarrow> extend_history h hf1 = h'
  \<Longrightarrow> extend_history h hf2 = h'
  \<Longrightarrow> hf1 = hf2"

assumes AX_mutual_prefix: "
  TSstructure G
  \<Longrightarrow> hf1 \<in> history_fragments G
  \<Longrightarrow> hf2 \<in> history_fragments G
  \<Longrightarrow> hf3 \<in> history_fragments G
  \<Longrightarrow> hf4 \<in> history_fragments G
  \<Longrightarrow> join_history_fragments hf1 hf2 = join_history_fragments hf3 hf4
  \<Longrightarrow> (\<exists>hf \<in> history_fragments G. join_history_fragments hf1 hf = hf3)
  \<or> (\<exists>hf \<in> history_fragments G. join_history_fragments hf3 hf = hf1)"

context ATS_History begin

definition history_fragment_prefixes :: "'TSstructure \<Rightarrow> 'history_fragment \<Rightarrow> 'history_fragment set" where
  "history_fragment_prefixes G hf = {hf'\<in> history_fragments G.
  \<exists>hf''\<in> history_fragments G.
  join_history_fragments hf' hf'' = hf
  }"

lemma steps_extend_history_derivation: "
  TSstructure G
  \<Longrightarrow> derivation G d
  \<Longrightarrow> c \<in> configurations G
  \<Longrightarrow> get_configuration (d n) = Some c
  \<Longrightarrow> get_configuration (d (n+m)) = Some c'
  \<Longrightarrow> \<exists>h\<in> history_fragments G. get_history c' = extend_history (get_history c) h"
  apply(induct m arbitrary: c')
   apply(rename_tac c')(*strict*)
   apply(clarsimp)
   apply(rule_tac
      x="empty_history_fragment G"
      in bexI)
    apply(rule sym)
    apply(rule AX_extend_history_empty1)
     apply(force)
    apply(rule AX_get_history_closed)
     apply(force)
    apply(force)
   apply(rule AX_empty_history_fragment_is_history_fragment)
   apply(force)
  apply(rename_tac m c')(*strict*)
  apply(clarsimp)
  apply(subgoal_tac "\<exists>e1 e2 c1 c2. d (n+m) = Some (pair e1 c1) \<and> d (Suc (n+m)) = Some (pair (Some e2) c2) \<and> step_relation G c1 e2 c2")
   apply(rename_tac m c')(*strict*)
   prefer 2
   apply(rule_tac
      m="Suc(n+m)"
      in step_detail_before_some_position)
     apply(rename_tac m c')(*strict*)
     apply(force)
    apply(rename_tac m c')(*strict*)
    apply(simp add: get_configuration_def)
    apply(case_tac "d (Suc (n + m))")
     apply(rename_tac m c')(*strict*)
     apply(clarsimp)
    apply(rename_tac m c' a)(*strict*)
    apply(clarsimp)
   apply(rename_tac m c')(*strict*)
   apply(force)
  apply(rename_tac m c')(*strict*)
  apply(clarsimp)
  apply(rename_tac m c' e1 e2 c1 c2)(*strict*)
  apply(simp add: get_configuration_def)
  apply(erule_tac
      x="c1"
      in meta_allE)
  apply(clarsimp)
  apply(rename_tac m c' e1 e2 c1 h)(*strict*)
  apply(case_tac "d n")
   apply(rename_tac m c' e1 e2 c1 h)(*strict*)
   apply(clarsimp)
  apply(rename_tac m c' e1 e2 c1 h a)(*strict*)
  apply(clarsimp)
  apply(case_tac a)
  apply(rename_tac m c' e1 e2 c1 h a option b)(*strict*)
  apply(clarsimp)
  apply(rename_tac m c' e1 e2 c1 h option)(*strict*)
  apply(subgoal_tac "\<exists>hf\<in> history_fragments G. get_history c' = extend_history (get_history c1) hf")
   apply(rename_tac m c' e1 e2 c1 h option)(*strict*)
   prefer 2
   apply(rule AX_steps_extend_history)
     apply(rename_tac m c' e1 e2 c1 h option)(*strict*)
     apply(force)
    apply(rename_tac m c' e1 e2 c1 h option)(*strict*)
    apply(rule stays_in_configuration)
         apply(rename_tac m c' e1 e2 c1 h option)(*strict*)
         apply(force)
        apply(rename_tac m c' e1 e2 c1 h option)(*strict*)
        apply(force)
       apply(rename_tac m c' e1 e2 c1 h option)(*strict*)
       prefer 2
       apply(force)
      apply(rename_tac m c' e1 e2 c1 h option)(*strict*)
      apply(force)
     apply(rename_tac m c' e1 e2 c1 h option)(*strict*)
     prefer 2
     apply(force)
    apply(rename_tac m c' e1 e2 c1 h option)(*strict*)
    apply(force)
   apply(rename_tac m c' e1 e2 c1 h option)(*strict*)
   apply(force)
  apply(rename_tac m c' e1 e2 c1 h option)(*strict*)
  apply(clarsimp)
  apply(rename_tac m c' e1 e2 c1 h option hf)(*strict*)
  apply(rule_tac
      x="join_history_fragments h hf"
      in bexI)
   apply(rename_tac m c' e1 e2 c1 h option hf)(*strict*)
   apply(rule_tac
      t="get_history c1"
      and s="extend_history (get_history c) h"
      in ssubst)
    apply(rename_tac m c' e1 e2 c1 h option hf)(*strict*)
    apply(force)
   apply(rename_tac m c' e1 e2 c1 h option hf)(*strict*)
   apply(rule sym)
   apply(rule AX_extend_history_add)
        apply(rename_tac m c' e1 e2 c1 h option hf)(*strict*)
        apply(force)
       apply(rename_tac m c' e1 e2 c1 h option hf)(*strict*)
       prefer 4
       apply(force)
      apply(rename_tac m c' e1 e2 c1 h option hf)(*strict*)
      prefer 4
      apply(force)
     apply(rename_tac m c' e1 e2 c1 h option hf)(*strict*)
     apply(rule AX_get_history_closed)
      apply(rename_tac m c' e1 e2 c1 h option hf)(*strict*)
      apply(force)
     apply(rename_tac m c' e1 e2 c1 h option hf)(*strict*)
     apply(force)
    apply(rename_tac m c' e1 e2 c1 h option hf)(*strict*)
    apply(force)
   apply(rename_tac m c' e1 e2 c1 h option hf)(*strict*)
   apply(force)
  apply(rename_tac m c' e1 e2 c1 h option hf)(*strict*)
  apply(rule AX_join_history_fragments_closed)
    apply(rename_tac m c' e1 e2 c1 h option hf)(*strict*)
    apply(force)
   apply(rename_tac m c' e1 e2 c1 h option hf)(*strict*)
   apply(force)
  apply(rename_tac m c' e1 e2 c1 h option hf)(*strict*)
  apply(force)
  done

lemma history_fragment_prefixes: "
  TSstructure G
  \<Longrightarrow> hf1 \<in> history_fragments G
  \<Longrightarrow> hf2 \<in> history_fragments G
  \<Longrightarrow> hf3 \<in> history_fragments G
  \<Longrightarrow> hf4 \<in> history_fragments G
  \<Longrightarrow> join_history_fragments hf1 hf2 = join_history_fragments hf3 hf4
  \<Longrightarrow> hf1 \<in> history_fragment_prefixes G hf3
  \<or> hf3 \<in> history_fragment_prefixes G hf1"
  apply(subgoal_tac "X" for X)
   prefer 2
   apply(rule_tac
      ?hf1.0="hf1"
      and ?hf2.0="hf2"
      and ?hf3.0="hf3"
      and ?hf4.0="hf4"
      in AX_mutual_prefix)
        apply(force)
       apply(force)
      apply(force)
     apply(force)
    apply(force)
   apply(force)
  apply(simp add: history_fragment_prefixes_def)
  done

end

end