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

section "Quality relations between routes"

theory Fresher
imports 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 pre. nsqn\<^sub>r (0, dsk, flag, hops, nhip, pre) = 0"
  unfolding nsqn\<^sub>r_def by clarsimp

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

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

lemma nsqn\<^sub>r_lte_dsn [simp]:
  "\<And>dsn dsk flag hops nhip pre. nsqn\<^sub>r (dsn, dsk, flag, hops, nhip, pre) \<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 nsqn\<^sub>r_addpreRT_inv [simp]:
  "\<And>rt dip npre dip'. dip \<in> kD(rt) \<Longrightarrow>
   nsqn\<^sub>r (the (the (addpreRT rt dip npre) dip')) = nsqn\<^sub>r (the (rt dip'))"
  unfolding addpreRT_def nsqn\<^sub>r_def
  by (frule kD_Some) (clarsimp split: option.split)

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_addpreRT_inv [simp]:
  "\<And>rt dip npre dip'. dip \<in> kD(rt) \<Longrightarrow>
   nsqn (the (addpreRT rt dip npre)) dip' = nsqn rt dip'"
  unfolding addpreRT_def nsqn_def nsqn\<^sub>r_def
  by (frule kD_Some) (clarsimp split: option.split)

lemma nsqn_update_other [simp]:
    fixes dsn dsk flag hops dip nhip pre rt ip
  assumes "dip \<noteq> ip"
    shows "nsqn (update rt ip (dsn, dsk, flag, hops, nhip, pre)) 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, pre)"
      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

lemma addpre_fresher [simp]: "\<And>r npre. r \<sqsubseteq> (addpre r npre)"
  by clarsimp

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 pre\<^sub>n
      where rtn [simp]: "the (rt dip) = (dsn\<^sub>n, dsk\<^sub>n, f\<^sub>n, hops\<^sub>n, nhip\<^sub>n, pre\<^sub>n)"
      by (metis prod_cases6)
    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, pre\<^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, pre\<^sub>n)
                                        \<sqsubseteq> (dsn\<^sub>n, unk, val, Suc 0, nhip, pre')"
          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, pre\<^sub>n)
               \<sqsubseteq> the (update rt dip (0, unk, val, Suc 0, nhip, pre) 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, pre\<^sub>n)
               \<sqsubseteq> the (update rt dip (dsn, kno, val, hops, nhip, pre) 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, pre\<^sub>n)
                   \<sqsubseteq> (dsn, kno, val, hops, nhip, pre \<union> pre\<^sub>n)"
              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, pre\<^sub>n)
                   \<sqsubseteq> (dsn, kno, val, hops, nhip, pre \<union> pre\<^sub>n)"
              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, pre\<^sub>n)
                   \<sqsubseteq> (dsn, kno, val, hops, nhip, pre \<union> pre\<^sub>n)"
              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]

lemma rt_fresh_as_addpreRT [simp]:
  assumes "ip\<in>kD(rt)"
    shows "rt \<approx>\<^bsub>dip\<^esub> the (addpreRT rt ip npre)"
  using assms [THEN kD_Some] by (auto simp: addpreRT_def)

lemmas rt_fresher_addpreRT [simp] = rt_fresh_as_addpreRT [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 addpreRT_strictly_fresher [simp]:
  assumes "dip \<in> kD(rt)"
    shows "(the (addpreRT rt dip npre) \<sqsubset>\<^bsub>ip\<^esub> rt2) = (rt \<sqsubset>\<^bsub>ip\<^esub> rt2)"
  using assms 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


(*
  File: Rect_Intersect_Impl.thy
  Author: Bohua Zhan
*)

section \<open>Implementation of rectangle intersection\<close>

theory Rect_Intersect_Impl
  imports "../Functional/Rect_Intersect" IntervalTree_Impl Quicksort_Impl
begin

text \<open>Imperative version of rectangle-intersection algorithm.\<close>

subsection \<open>Operations\<close>

fun operation_encode :: "('a::heap) operation \<Rightarrow> nat" where
  "operation_encode oper =
   (case oper of INS p i n \<Rightarrow> to_nat (is_INS oper, p, i, n)
               | DEL p i n \<Rightarrow> to_nat (is_INS oper, p, i, n))"

instance operation :: (heap) heap
  apply (rule heap_class.intro)
  apply (rule countable_classI [of "operation_encode"])
  apply (case_tac x, simp_all, case_tac y, simp_all)
  apply (simp add: operation.case_eq_if)
  ..

subsection \<open>Initial state\<close>

definition rect_inter_init :: "nat rectangle list \<Rightarrow> nat operation array Heap" where
  "rect_inter_init rects = do {
     p \<leftarrow> Array.of_list (ins_ops rects @ del_ops rects);
     quicksort_all p;
     return p }"

setup \<open>add_rewrite_rule @{thm all_ops_def}\<close>
lemma rect_inter_init_rule [hoare_triple]:
  "<emp> rect_inter_init rects <\<lambda>p. p \<mapsto>\<^sub>a all_ops rects>" by auto2
setup \<open>del_prfstep_thm @{thm all_ops_def}\<close>

definition rect_inter_next :: "nat operation array \<Rightarrow> int_tree \<Rightarrow> nat \<Rightarrow> int_tree Heap" where
  "rect_inter_next a b k = do {
    oper \<leftarrow> Array.nth a k;
    if is_INS oper then
      IntervalTree_Impl.insert_impl (IdxInterval (op_int oper) (op_idx oper)) b
    else
      IntervalTree_Impl.delete_impl (IdxInterval (op_int oper) (op_idx oper)) b }"

lemma op_int_is_interval:
  "is_rect_list rects \<Longrightarrow> ops = all_ops rects \<Longrightarrow> k < length ops \<Longrightarrow>
   is_interval (op_int (ops ! k))"
@proof @have "ops ! k \<in> set ops" @case "is_INS (ops ! k)" @qed
setup \<open>add_forward_prfstep_cond @{thm op_int_is_interval} [with_term "op_int (?ops ! ?k)"]\<close>

lemma rect_inter_next_rule [hoare_triple]:
  "is_rect_list rects \<Longrightarrow> k < length (all_ops rects) \<Longrightarrow>
   <a \<mapsto>\<^sub>a all_ops rects * int_tree_set S b>
   rect_inter_next a b k
   <\<lambda>r. a \<mapsto>\<^sub>a all_ops rects * int_tree_set (apply_ops_k_next rects S k) r>\<^sub>t" by auto2

partial_function (heap) rect_inter_impl ::
  "nat operation array \<Rightarrow> int_tree \<Rightarrow> nat \<Rightarrow> bool Heap" where
  "rect_inter_impl a b k = do {
    n \<leftarrow> Array.len a;
    (if k \<ge> n then return False
     else do {
       oper \<leftarrow> Array.nth a k;
       (if is_INS oper then do {
          overlap \<leftarrow> IntervalTree_Impl.search_impl (op_int oper) b;
          if overlap then return True
          else if k = n - 1 then return False
          else do {
            b' \<leftarrow> rect_inter_next a b k;
            rect_inter_impl a b' (k + 1)}}
        else
          if k = n - 1 then return False
          else do {
            b' \<leftarrow> rect_inter_next a b k;
            rect_inter_impl a b' (k + 1)})})}"

lemma rect_inter_to_fun_ind [hoare_triple]:
  "is_rect_list rects \<Longrightarrow> k < length (all_ops rects) \<Longrightarrow>
   <a \<mapsto>\<^sub>a all_ops rects * int_tree_set S b>
   rect_inter_impl a b k
   <\<lambda>r. a \<mapsto>\<^sub>a all_ops rects * \<up>(r \<longleftrightarrow> rect_inter rects S k)>\<^sub>t"
@proof
  @let "d = length (all_ops rects) - k"
  @strong_induct d arbitrary k S b
  @case "k \<ge> length (all_ops rects)"
  @unfold "rect_inter rects S k"
  @case "is_INS (all_ops rects ! k)" @with
    @case "has_overlap S (op_int (all_ops rects ! k))"
    @case "k = length (all_ops rects) - 1"
    @apply_induct_hyp "length (all_ops rects) - (k + 1)" "k + 1"
    @have "length (all_ops rects) - (k + 1) < d"
  @end
  @case "k = length (all_ops rects) - 1"
  @apply_induct_hyp "length (all_ops rects) - (k + 1)" "k + 1"
  @have "length (all_ops rects) - (k + 1) < d"
@qed

definition rect_inter_all :: "nat rectangle list \<Rightarrow> bool Heap" where
  "rect_inter_all rects =
    (if rects = [] then return False
     else do {
       a \<leftarrow> rect_inter_init rects;
       b \<leftarrow> int_tree_empty;
       rect_inter_impl a b 0 })"

text \<open>Correctness of rectangle intersection algorithm.\<close>
theorem rect_inter_all_correct:
  "is_rect_list rects \<Longrightarrow>
   <emp>
   rect_inter_all rects
   <\<lambda>r. \<up>(r = has_rect_overlap rects)>\<^sub>t" by auto2

end


theory v1_isar
  imports Main "../QML_S5"
begin

text \<open>
@{text "Compossibility\<^sub>1"}: If a table @{term x} is originally made from matter @{term y} and it
is possible for any table to be originally made from matter @{term z} such that @{term y} and @{term z}
are distinct, then it is  possible for table @{term x} to be originally made from matter @{term y}
and in addition some table @{term x'} to be originally made from matter @{term z}.
\<close>

text \<open>
@{text "Origin Uniqueness\<^sub>1"}: It is impossible that a single table @{term x}, is originally made from
matter @{term y} and originally made from matter @{term z} such that @{term y} and @{term z} are distinct.
\<close>

text \<open>
@{text "Sufficiency\<^sub>1"}: If it is possible that a table @{term x'} is originally made from matter @{term y},
then necessarily any table, say @{term x}, originally made from matter @{term y} is the very table @{term x'}.
\<close>

text \<open>
@{text "Origin Essentialism\<^sub>1"}: If it is possible that a table @{term x} is originally made from matter
@{term y} and that matter @{term y} and matter @{term z} are distinct, then it is impossible that
table @{term x} be originally made from any @{term z}.
\<close>

consts makeTable ::  "\<mu> \<Rightarrow> \<mu> \<Rightarrow> \<sigma>"  ("T") (* (T x y) \<equiv> x made from y *)
abbreviation overlap ::  "\<mu> \<Rightarrow> \<mu> \<Rightarrow> \<sigma>"  ("O")
  where "O x y \<equiv> x \<^bold>=\<^sup>L y"

lemma self_identity: "\<lfloor>\<^bold>\<forall>x. \<^bold>\<box>(x \<^bold>=\<^sup>L x) \<rfloor>" by auto
lemma necessity_of_identity: "\<lfloor>\<^bold>\<box>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<diamond>(x\<^bold>=\<^sup>Ly) \<^bold>\<rightarrow> \<^bold>\<box>(x\<^bold>=\<^sup>Ly))\<rfloor>" by auto
lemma necessity_of_distinctness: "\<lfloor>\<^bold>\<box>(\<^bold>\<forall>x. \<^bold>\<forall>y.\<^bold>\<not>\<^bold>\<diamond>(x\<^bold>=\<^sup>Ly) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<not>(x\<^bold>=\<^sup>Ly)))\<rfloor>" by auto

lemma
  assumes compossibilty1: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. ((T x y) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. T t z)) \<^bold>\<rightarrow> \<^bold>\<diamond>((T x y) \<^bold>\<and> (\<^bold>\<exists>x'. (T x' z))))\<rfloor>"
  assumes origin_uniqueness: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<not>\<^bold>\<diamond>((T x y) \<^bold>\<and> (T x z) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z)))\<rfloor>"
  assumes sufficiency1: "\<lfloor>(\<^bold>\<forall>y. \<^bold>\<forall>x'. \<^bold>\<diamond>(T x' y) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x. (T x y) \<^bold>\<rightarrow> (x\<^bold>=\<^sup>Lx')))\<rfloor>"
  shows origin_essentialism1: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. (\<^bold>\<diamond>((\<^bold>\<not>(y \<^bold>=\<^sup>L z)) \<^bold>\<and> (T x y))) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(T x z)))\<rfloor>"
proof (rule allI)
  fix w (* for the outer \<lfloor> \<rfloor> *)
  show "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<diamond>((\<^bold>\<not>(y \<^bold>=\<^sup>L z)) \<^bold>\<and> (T x y)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(T x z))) w"
  proof (rule allI)
    fix x (* for table x *)
    show "(\<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<diamond>((\<^bold>\<not>(y \<^bold>=\<^sup>L z)) \<^bold>\<and> (T x y)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(T x z))) w"
    proof (rule allI)
      fix y (* for material y *)
      show "(\<^bold>\<forall>z. \<^bold>\<diamond>((\<^bold>\<not>(y \<^bold>=\<^sup>L z)) \<^bold>\<and> (T x y)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(T x z))) w"
      proof (rule allI)
        fix z (* for material z *)
        show "(\<^bold>\<diamond>((\<^bold>\<not>(y \<^bold>=\<^sup>L z)) \<^bold>\<and> (T x y)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(T x z))) w"
        proof (rule impI)
          assume antecedent: "(\<^bold>\<diamond>((\<^bold>\<not>(y \<^bold>=\<^sup>L z)) \<^bold>\<and> (T x y))) w"
          show "(\<^bold>\<not>(\<^bold>\<diamond>(T x z))) w"
            proof (rule notI)
              assume "(\<^bold>\<diamond>(T x z)) w"
              from antecedent obtain w where w: "((\<^bold>\<not>(y \<^bold>=\<^sup>L z)) \<^bold>\<and> (T x y)) w"
                by (rule exE) (* Expanding \<diamond> in the same world *)
              then have non_overlapping: "((\<^bold>\<not>(y \<^bold>=\<^sup>L z))) w"
                by (rule conjE)
              have table_x_from_y: "(T x y w)"
                using `((\<^bold>\<not>(y \<^bold>=\<^sup>L z)) \<^bold>\<and> (T x y)) w` by (rule conjE)
              have compossibilty1_ante: "((T x y) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. T t z)) w"
                using table_x_from_y and `(\<^bold>\<diamond>(T x z)) w` and non_overlapping by auto

              from compossibilty1 have "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. ((T x y) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. T t z)) \<^bold>\<rightarrow> \<^bold>\<diamond>((T x y) \<^bold>\<and> (\<^bold>\<exists>x'. (T x' z)))) w"..
              then have "(\<^bold>\<forall>y. \<^bold>\<forall>z. ((T x y) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. T t z)) \<^bold>\<rightarrow> \<^bold>\<diamond>((T x y) \<^bold>\<and> (\<^bold>\<exists>x'. (T x' z)))) w"
                by (rule allE)
              then have "(\<^bold>\<forall>z. ((T x y) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. T t z)) \<^bold>\<rightarrow> \<^bold>\<diamond>((T x y) \<^bold>\<and> (\<^bold>\<exists>x'. (T x' z)))) w"
                by (rule allE)
              then have "(((T x y) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. T t z)) \<^bold>\<rightarrow> \<^bold>\<diamond>((T x y) \<^bold>\<and> (\<^bold>\<exists>x'. (T x' z)))) w"
                by (rule allE)
              then have "\<^bold>\<diamond>((T x y) \<^bold>\<and> (\<^bold>\<exists>x'. (T x' z))) w"
                using compossibilty1_ante by (rule mp)
              then obtain u where u: "(T x y u  \<and> (\<exists>t. T t z u)) "
                by (rule exE)
              then have "(\<exists>t. T t z u)" by (rule conjE)
              then obtain x' where x': "T x' z u" by (rule exE)

              from sufficiency1 have "(\<^bold>\<forall>y. \<^bold>\<forall>x'. \<^bold>\<diamond>(T x' y) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x. (T x y) \<^bold>\<rightarrow> (x\<^bold>=\<^sup>Lx'))) w"..
              then have "(\<^bold>\<forall>x'. \<^bold>\<diamond>(T x' z) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x. (T x z) \<^bold>\<rightarrow> (x\<^bold>=\<^sup>Lx'))) w"
                by (rule allE)
              then have "(\<^bold>\<diamond>(T x z) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>t. (T t z) \<^bold>\<rightarrow> (t\<^bold>=\<^sup>Lx))) w"
                by (rule allE)
              then have "\<^bold>\<box>(\<^bold>\<forall>t. (T t z) \<^bold>\<rightarrow> (t\<^bold>=\<^sup>Lx)) w"
                using `(\<^bold>\<diamond>(T x z)) w` by (rule mp)
              then have "(\<^bold>\<forall>t. (T t z) \<^bold>\<rightarrow> (t\<^bold>=\<^sup>Lx)) u" by (rule allE)
              then have "((T x' z) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx)) u" by (rule allE)
              then have "(x' \<^bold>=\<^sup>L x) u"
                using `T x' z u` by (rule mp)
              then have "(T x z) u"
                using `(T x' z) u` by auto
              moreover from u have "(T x y) u"..
              then have "(T x y) u \<and> (T x z) u"
                using `(T x z) u` by (rule conjI)
              then have impossible_arg: "(T x y \<^bold>\<and> T x z \<^bold>\<and> (\<^bold>\<not>(y \<^bold>=\<^sup>L z))) u"
                using non_overlapping by auto

              from origin_uniqueness have "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<not>\<^bold>\<diamond>((T x y) \<^bold>\<and> (T x z) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) u"..
              then have "(\<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<not>\<^bold>\<diamond>((T x y) \<^bold>\<and> (T x z) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) u"
                by (rule allE)
              then have "(\<^bold>\<forall>z. \<^bold>\<not>\<^bold>\<diamond>((T x y) \<^bold>\<and> (T x z) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) u"
                by (rule allE)
              then have "(\<^bold>\<not>\<^bold>\<diamond>((T x y) \<^bold>\<and> (T x z) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) u"
                by (rule allE)
              then have "\<^bold>\<box>(\<^bold>\<not>((T x y) \<^bold>\<and> (T x z) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) u"
                by auto
              then have "(\<^bold>\<not>((T x y) \<^bold>\<and> (T x z) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) u"
                by (rule allE)
              then show "False"
                using impossible_arg by (rule notE)
            qed
          qed
        qed
      qed
    qed
  qed

end


(* Author: Tobias Nipkow *)

section "Computable Abstract Interpretation"

theory Abs_Int1
imports Abs_State
begin

text\<open>Abstract interpretation over type \<open>st\<close> instead of
functions.\<close>

context Gamma
begin

fun aval' :: "aexp \<Rightarrow> 'av st \<Rightarrow> 'av" where
"aval' (N n) S = num' n" |
"aval' (V x) S = lookup S x" |
"aval' (Plus a1 a2) S = plus' (aval' a1 S) (aval' a2 S)"

lemma aval'_sound: "s : \<gamma>\<^sub>f S \<Longrightarrow> aval a s : \<gamma>(aval' a S)"
by (induction a) (auto simp: gamma_num' gamma_plus' \<gamma>_st_def lookup_def)

end

text\<open>The for-clause (here and elsewhere) only serves the purpose of fixing
the name of the type parameter @{typ 'av} which would otherwise be renamed to
@{typ 'a}.\<close>

locale Abs_Int = Gamma where \<gamma>=\<gamma> for \<gamma> :: "'av::SL_top \<Rightarrow> val set"
begin

fun step' :: "'av st option \<Rightarrow> 'av st option acom \<Rightarrow> 'av st option acom" where
"step' S (SKIP {P}) = (SKIP {S})" |
"step' S (x ::= e {P}) =
  x ::= e {case S of None \<Rightarrow> None | Some S \<Rightarrow> Some(update S x (aval' e S))}" |
"step' S (c1;; c2) = step' S c1;; step' (post c1) c2" |
"step' S (IF b THEN c1 ELSE c2 {P}) =
  (let c1' = step' S c1; c2' = step' S c2
   in IF b THEN c1' ELSE c2' {post c1 \<squnion> post c2})" |
"step' S ({Inv} WHILE b DO c {P}) =
   {S \<squnion> post c} WHILE b DO step' Inv c {Inv}"

definition AI :: "com \<Rightarrow> 'av st option acom option" where
"AI = lpfp\<^sub>c (step' \<top>)"

lemma strip_step'[simp]: "strip(step' S c) = strip c"
by(induct c arbitrary: S) (simp_all add: Let_def)

text\<open>Soundness:\<close>

lemma in_gamma_update:
  "\<lbrakk> s : \<gamma>\<^sub>f S; i : \<gamma> a \<rbrakk> \<Longrightarrow> s(x := i) : \<gamma>\<^sub>f(update S x a)"
by(simp add: \<gamma>_st_def lookup_update)

text\<open>The soundness proofs are textually identical to the ones for the step
function operating on states as functions.\<close>

lemma step_preserves_le:
  "\<lbrakk> S \<subseteq> \<gamma>\<^sub>o S'; c \<le> \<gamma>\<^sub>c c' \<rbrakk> \<Longrightarrow> step S c \<le> \<gamma>\<^sub>c (step' S' c')"
proof(induction c arbitrary: c' S S')
  case SKIP thus ?case by(auto simp:SKIP_le map_acom_SKIP)
next
  case Assign thus ?case
    by (fastforce simp: Assign_le  map_acom_Assign intro: aval'_sound in_gamma_update
      split: option.splits del:subsetD)
next
  case Seq thus ?case apply (auto simp: Seq_le map_acom_Seq)
    by (metis le_post post_map_acom)
next
  case (If b c1 c2 P)
  then obtain c1' c2' P' where
      "c' = IF b THEN c1' ELSE c2' {P'}"
      "P \<subseteq> \<gamma>\<^sub>o P'" "c1 \<le> \<gamma>\<^sub>c c1'" "c2 \<le> \<gamma>\<^sub>c c2'"
    by (fastforce simp: If_le map_acom_If)
  moreover have "post c1 \<subseteq> \<gamma>\<^sub>o(post c1' \<squnion> post c2')"
    by (metis (no_types) \<open>c1 \<le> \<gamma>\<^sub>c c1'\<close> join_ge1 le_post mono_gamma_o order_trans post_map_acom)
  moreover have "post c2 \<subseteq> \<gamma>\<^sub>o(post c1' \<squnion> post c2')"
    by (metis (no_types) \<open>c2 \<le> \<gamma>\<^sub>c c2'\<close> join_ge2 le_post mono_gamma_o order_trans post_map_acom)
  ultimately show ?case using \<open>S \<subseteq> \<gamma>\<^sub>o S'\<close> by (simp add: If.IH subset_iff)
next
  case (While I b c1 P)
  then obtain c1' I' P' where
    "c' = {I'} WHILE b DO c1' {P'}"
    "I \<subseteq> \<gamma>\<^sub>o I'" "P \<subseteq> \<gamma>\<^sub>o P'" "c1 \<le> \<gamma>\<^sub>c c1'"
    by (fastforce simp: map_acom_While While_le)
  moreover have "S \<union> post c1 \<subseteq> \<gamma>\<^sub>o (S' \<squnion> post c1')"
    using \<open>S \<subseteq> \<gamma>\<^sub>o S'\<close> le_post[OF \<open>c1 \<le> \<gamma>\<^sub>c c1'\<close>, simplified]
    by (metis (no_types) join_ge1 join_ge2 le_sup_iff mono_gamma_o order_trans)
  ultimately show ?case by (simp add: While.IH subset_iff)
qed

lemma AI_sound: "AI c = Some c' \<Longrightarrow> CS c \<le> \<gamma>\<^sub>c c'"
proof(simp add: CS_def AI_def)
  assume 1: "lpfp\<^sub>c (step' \<top>) c = Some c'"
  have 2: "step' \<top> c' \<sqsubseteq> c'" by(rule lpfpc_pfp[OF 1])
  have 3: "strip (\<gamma>\<^sub>c (step' \<top> c')) = c"
    by(simp add: strip_lpfpc[OF _ 1])
  have "lfp (step UNIV) c \<le> \<gamma>\<^sub>c (step' \<top> c')"
  proof(rule lfp_lowerbound[simplified,OF 3])
    show "step UNIV (\<gamma>\<^sub>c (step' \<top> c')) \<le> \<gamma>\<^sub>c (step' \<top> c')"
    proof(rule step_preserves_le[OF _ _])
      show "UNIV \<subseteq> \<gamma>\<^sub>o \<top>" by simp
      show "\<gamma>\<^sub>c (step' \<top> c') \<le> \<gamma>\<^sub>c c'" by(rule mono_gamma_c[OF 2])
    qed
  qed
  from this 2 show "lfp (step UNIV) c \<le> \<gamma>\<^sub>c c'"
    by (blast intro: mono_gamma_c order_trans)
qed

end

subsection "Monotonicity"

locale Abs_Int_mono = Abs_Int +
assumes mono_plus': "a1 \<sqsubseteq> b1 \<Longrightarrow> a2 \<sqsubseteq> b2 \<Longrightarrow> plus' a1 a2 \<sqsubseteq> plus' b1 b2"
begin

lemma mono_aval': "S \<sqsubseteq> S' \<Longrightarrow> aval' e S \<sqsubseteq> aval' e S'"
by(induction e) (auto simp: le_st_def lookup_def mono_plus')

lemma mono_update: "a \<sqsubseteq> a' \<Longrightarrow> S \<sqsubseteq> S' \<Longrightarrow> update S x a \<sqsubseteq> update S' x a'"
by(auto simp add: le_st_def lookup_def update_def)

lemma mono_step': "S \<sqsubseteq> S' \<Longrightarrow> c \<sqsubseteq> c' \<Longrightarrow> step' S c \<sqsubseteq> step' S' c'"
apply(induction c c' arbitrary: S S' rule: le_acom.induct)
apply (auto simp: Let_def mono_update mono_aval' mono_post le_join_disj
            split: option.split)
done

end

subsection "Ascending Chain Condition"

abbreviation "strict r == r \<inter> -(r^-1)"
abbreviation "acc r == wf((strict r)^-1)"

lemma strict_inv_image: "strict(inv_image r f) = inv_image (strict r) f"
by(auto simp: inv_image_def)

lemma acc_inv_image:
  "acc r \<Longrightarrow> acc (inv_image r f)"
by (metis converse_inv_image strict_inv_image wf_inv_image)

text\<open>ACC for option type:\<close>

lemma acc_option: assumes "acc {(x,y::'a::preord). x \<sqsubseteq> y}"
shows "acc {(x,y::'a::preord option). x \<sqsubseteq> y}"
proof(auto simp: wf_eq_minimal)
  fix xo :: "'a option" and Qo assume "xo : Qo"
  let ?Q = "{x. Some x \<in> Qo}"
  show "\<exists>yo\<in>Qo. \<forall>zo. yo \<sqsubseteq> zo \<and> ~ zo \<sqsubseteq> yo \<longrightarrow> zo \<notin> Qo" (is "\<exists>zo\<in>Qo. ?P zo")
  proof cases
    assume "?Q = {}"
    hence "?P None" by auto
    moreover have "None \<in> Qo" using \<open>?Q = {}\<close> \<open>xo : Qo\<close>
      by auto (metis not_Some_eq)
    ultimately show ?thesis by blast
  next
    assume "?Q \<noteq> {}"
    with assms show ?thesis
      apply(auto simp: wf_eq_minimal)
      apply(erule_tac x="?Q" in allE)
      apply auto
      apply(rule_tac x = "Some z" in bexI)
      by auto
  qed
qed

text\<open>ACC for abstract states, via measure functions.\<close>

lemma measure_st: assumes "(strict{(x,y::'a::SL_top). x \<sqsubseteq> y})^-1 <= measure m"
and "\<forall>x y::'a::SL_top. x \<sqsubseteq> y \<and> y \<sqsubseteq> x \<longrightarrow> m x = m y"
shows "(strict{(S,S'::'a::SL_top st). S \<sqsubseteq> S'})^-1 \<subseteq>
  measure(%fd. \<Sum>x| x\<in>set(dom fd) \<and> ~ \<top> \<sqsubseteq> fun fd x. m(fun fd x)+1)"
proof-
  { fix S S' :: "'a st" assume "S \<sqsubseteq> S'" "~ S' \<sqsubseteq> S"
    let ?X = "set(dom S)" let ?Y = "set(dom S')"
    let ?f = "fun S" let ?g = "fun S'"
    let ?X' = "{x:?X. ~ \<top> \<sqsubseteq> ?f x}" let ?Y' = "{y:?Y. ~ \<top> \<sqsubseteq> ?g y}"
    from \<open>S \<sqsubseteq> S'\<close> have "\<forall>y\<in>?Y'\<inter>?X. ?f y \<sqsubseteq> ?g y"
      by(auto simp: le_st_def lookup_def)
    hence 1: "\<forall>y\<in>?Y'\<inter>?X. m(?g y)+1 \<le> m(?f y)+1"
      using assms(1,2) by(fastforce)
    from \<open>~ S' \<sqsubseteq> S\<close> obtain u where u: "u : ?X" "~ lookup S' u \<sqsubseteq> ?f u"
      by(auto simp: le_st_def)
    hence "u : ?X'" by simp (metis preord_class.le_trans top)
    have "?Y'-?X = {}" using \<open>S \<sqsubseteq> S'\<close> by(fastforce simp: le_st_def lookup_def)
    have "?Y'\<inter>?X <= ?X'" apply auto
      apply (metis \<open>S \<sqsubseteq> S'\<close> le_st_def lookup_def preord_class.le_trans)
      done
    have "(\<Sum>y\<in>?Y'. m(?g y)+1) = (\<Sum>y\<in>(?Y'-?X) \<union> (?Y'\<inter>?X). m(?g y)+1)"
      by (metis Un_Diff_Int)
    also have "\<dots> = (\<Sum>y\<in>?Y'\<inter>?X. m(?g y)+1)"
      using \<open>?Y'-?X = {}\<close> by (metis Un_empty_left)
    also have "\<dots> < (\<Sum>x\<in>?X'. m(?f x)+1)"
    proof cases
      assume "u \<in> ?Y'"
      hence "m(?g u) < m(?f u)" using assms(1) \<open>S \<sqsubseteq> S'\<close> u
        by (fastforce simp: le_st_def lookup_def)
      have "(\<Sum>y\<in>?Y'\<inter>?X. m(?g y)+1) < (\<Sum>y\<in>?Y'\<inter>?X. m(?f y)+1)"
        using \<open>u:?X\<close> \<open>u:?Y'\<close> \<open>m(?g u) < m(?f u)\<close>
        by(fastforce intro!: sum_strict_mono_ex1[OF _ 1])
      also have "\<dots> \<le> (\<Sum>y\<in>?X'. m(?f y)+1)"
        by(simp add: sum_mono2[OF _ \<open>?Y'\<inter>?X <= ?X'\<close>])
      finally show ?thesis .
    next
      assume "u \<notin> ?Y'"
      with \<open>?Y'\<inter>?X <= ?X'\<close> have "?Y'\<inter>?X - {u} <= ?X' - {u}" by blast
      have "(\<Sum>y\<in>?Y'\<inter>?X. m(?g y)+1) = (\<Sum>y\<in>?Y'\<inter>?X - {u}. m(?g y)+1)"
      proof-
        have "?Y'\<inter>?X = ?Y'\<inter>?X - {u}" using \<open>u \<notin> ?Y'\<close> by auto
        thus ?thesis by metis
      qed
      also have "\<dots> < (\<Sum>y\<in>?Y'\<inter>?X-{u}. m(?g y)+1) + (\<Sum>y\<in>{u}. m(?f y)+1)" by simp
      also have "(\<Sum>y\<in>?Y'\<inter>?X-{u}. m(?g y)+1) \<le> (\<Sum>y\<in>?Y'\<inter>?X-{u}. m(?f y)+1)"
        using 1 by(blast intro: sum_mono)
      also have "\<dots> \<le> (\<Sum>y\<in>?X'-{u}. m(?f y)+1)"
        by(simp add: sum_mono2[OF _ \<open>?Y'\<inter>?X-{u} <= ?X'-{u}\<close>])
      also have "\<dots> + (\<Sum>y\<in>{u}. m(?f y)+1)= (\<Sum>y\<in>(?X'-{u}) \<union> {u}. m(?f y)+1)"
        using \<open>u:?X'\<close> by(subst sum.union_disjoint[symmetric]) auto
      also have "\<dots> = (\<Sum>x\<in>?X'. m(?f x)+1)"
        using \<open>u : ?X'\<close> by(simp add:insert_absorb)
      finally show ?thesis by (blast intro: add_right_mono)
    qed
    finally have "(\<Sum>y\<in>?Y'. m(?g y)+1) < (\<Sum>x\<in>?X'. m(?f x)+1)" .
  } thus ?thesis by(auto simp add: measure_def inv_image_def)
qed

text\<open>ACC for acom. First the ordering on acom is related to an ordering on
lists of annotations.\<close>

(* FIXME mv and add [simp] *)
lemma listrel_Cons_iff:
  "(x#xs, y#ys) : listrel r \<longleftrightarrow> (x,y) \<in> r \<and> (xs,ys) \<in> listrel r"
by (blast intro:listrel.Cons)

lemma listrel_app: "(xs1,ys1) : listrel r \<Longrightarrow> (xs2,ys2) : listrel r
  \<Longrightarrow> (xs1@xs2, ys1@ys2) : listrel r"
by(auto simp add: listrel_iff_zip)

lemma listrel_app_same_size: "size xs1 = size ys1 \<Longrightarrow> size xs2 = size ys2 \<Longrightarrow>
  (xs1@xs2, ys1@ys2) : listrel r \<longleftrightarrow>
  (xs1,ys1) : listrel r \<and> (xs2,ys2) : listrel r"
by(auto simp add: listrel_iff_zip)

lemma listrel_converse: "listrel(r^-1) = (listrel r)^-1"
proof-
  { fix xs ys
    have "(xs,ys) : listrel(r^-1) \<longleftrightarrow> (ys,xs) : listrel r"
      apply(induct xs arbitrary: ys)
      apply (fastforce simp: listrel.Nil)
      apply (fastforce simp: listrel_Cons_iff)
      done
  } thus ?thesis by auto
qed

(* It would be nice to get rid of refl & trans and build them into the proof *)
lemma acc_listrel: fixes r :: "('a*'a)set" assumes "refl r" and "trans r"
and "acc r" shows "acc (listrel r - {([],[])})"
proof-
  have refl: "!!x. (x,x) : r" using \<open>refl r\<close> unfolding refl_on_def by blast
  have trans: "!!x y z. (x,y) : r \<Longrightarrow> (y,z) : r \<Longrightarrow> (x,z) : r"
    using \<open>trans r\<close> unfolding trans_def by blast
  from assms(3) obtain mx :: "'a set \<Rightarrow> 'a" where
    mx: "!!S x. x:S \<Longrightarrow> mx S : S \<and> (\<forall>y. (mx S,y) : strict r \<longrightarrow> y \<notin> S)"
    by(simp add: wf_eq_minimal) metis
  let ?R = "listrel r - {([], [])}"
  { fix Q and xs :: "'a list"
    have "xs \<in> Q \<Longrightarrow> \<exists>ys. ys\<in>Q \<and> (\<forall>zs. (ys, zs) \<in> strict ?R \<longrightarrow> zs \<notin> Q)"
      (is "_ \<Longrightarrow> \<exists>ys. ?P Q ys")
    proof(induction xs arbitrary: Q rule: length_induct)
      case (1 xs)
      { have "!!ys Q. size ys < size xs \<Longrightarrow> ys : Q \<Longrightarrow> \<exists>ms. ?P Q ms"
          using "1.IH" by blast
      } note IH = this
      show ?case
      proof(cases xs)
        case Nil with \<open>xs : Q\<close> have "?P Q []" by auto
        thus ?thesis by blast
      next
        case (Cons x ys)
        let ?Q1 = "{a. \<exists>bs. size bs = size ys \<and> a#bs : Q}"
        have "x : ?Q1" using \<open>xs : Q\<close> Cons by auto
        from mx[OF this] obtain m1 where
          1: "m1 \<in> ?Q1 \<and> (\<forall>y. (m1,y) \<in> strict r \<longrightarrow> y \<notin> ?Q1)" by blast
        then obtain ms1 where "size ms1 = size ys" "m1#ms1 : Q" by blast+
        hence "size ms1 < size xs" using Cons by auto
        let ?Q2 = "{bs. \<exists>m1'. (m1',m1):r \<and> (m1,m1'):r \<and> m1'#bs : Q \<and> size bs = size ms1}"
        have "ms1 : ?Q2" using \<open>m1#ms1 : Q\<close> by(blast intro: refl)
        from IH[OF \<open>size ms1 < size xs\<close> this]
        obtain ms where 2: "?P ?Q2 ms" by auto
        then obtain m1' where m1': "(m1',m1) : r \<and> (m1,m1') : r \<and> m1'#ms : Q"
          by blast
        hence "\<forall>ab. (m1'#ms,ab) : strict ?R \<longrightarrow> ab \<notin> Q" using 1 2
          apply (auto simp: listrel_Cons_iff)
          apply (metis \<open>length ms1 = length ys\<close> listrel_eq_len trans)
          by (metis \<open>length ms1 = length ys\<close> listrel_eq_len trans)
        with m1' show ?thesis by blast
      qed
    qed
  }
  thus ?thesis unfolding wf_eq_minimal by (metis converse_iff)
qed

lemma le_iff_le_annos: "c1 \<sqsubseteq> c2 \<longleftrightarrow>
 (annos c1, annos c2) : listrel{(x,y). x \<sqsubseteq> y} \<and> strip c1 = strip c2"
apply(induct c1 c2 rule: le_acom.induct)
apply (auto simp: listrel.Nil listrel_Cons_iff listrel_app size_annos_same2)
apply (metis listrel_app_same_size size_annos_same)+
done

lemma le_acom_subset_same_annos:
 "(strict{(c,c'::'a::preord acom). c \<sqsubseteq> c'})^-1 \<subseteq>
  (strict(inv_image (listrel{(a,a'::'a). a \<sqsubseteq> a'} - {([],[])}) annos))^-1"
by(auto simp: le_iff_le_annos)

lemma acc_acom: "acc {(a,a'::'a::preord). a \<sqsubseteq> a'} \<Longrightarrow>
  acc {(c,c'::'a acom). c \<sqsubseteq> c'}"
apply(rule wf_subset[OF _ le_acom_subset_same_annos])
apply(rule acc_inv_image[OF acc_listrel])
apply(auto simp: refl_on_def trans_def intro: le_trans)
done

text\<open>Termination of the fixed-point finders, assuming monotone functions:\<close>

lemma pfp_termination:
fixes x0 :: "'a::preord"
assumes mono: "\<And>x y. x \<sqsubseteq> y \<Longrightarrow> f x \<sqsubseteq> f y" and "acc {(x::'a,y). x \<sqsubseteq> y}"
and "x0 \<sqsubseteq> f x0" shows "\<exists>x. pfp f x0 = Some x"
proof(simp add: pfp_def, rule wf_while_option_Some[where P = "%x. x \<sqsubseteq> f x"])
  show "wf {(x, s). (s \<sqsubseteq> f s \<and> \<not> f s \<sqsubseteq> s) \<and> x = f s}"
    by(rule wf_subset[OF assms(2)]) auto
next
  show "x0 \<sqsubseteq> f x0" by(rule assms)
next
  fix x assume "x \<sqsubseteq> f x" thus "f x \<sqsubseteq> f(f x)" by(rule mono)
qed

lemma lpfpc_termination:
  fixes f :: "(('a::SL_top)option acom \<Rightarrow> 'a option acom)"
  assumes "acc {(x::'a,y). x \<sqsubseteq> y}" and "\<And>x y. x \<sqsubseteq> y \<Longrightarrow> f x \<sqsubseteq> f y"
  and "\<And>c. strip(f c) = strip c"
  shows "\<exists>c'. lpfp\<^sub>c f c = Some c'"
unfolding lpfp\<^sub>c_def
apply(rule pfp_termination)
  apply(erule assms(2))
 apply(rule acc_acom[OF acc_option[OF assms(1)]])
apply(simp add: bot_acom assms(3))
done

context Abs_Int_mono
begin

lemma AI_Some_measure:
assumes "(strict{(x,y::'a). x \<sqsubseteq> y})^-1 <= measure m"
and "\<forall>x y::'a. x \<sqsubseteq> y \<and> y \<sqsubseteq> x \<longrightarrow> m x = m y"
shows "\<exists>c'. AI c = Some c'"
unfolding AI_def
apply(rule lpfpc_termination)
apply(rule wf_subset[OF wf_measure measure_st[OF assms]])
apply(erule mono_step'[OF le_refl])
apply(rule strip_step')
done

end

end


(*  Title:      HOL/ex/Refute_Examples.thy
    Author:     Tjark Weber
    Copyright   2003-2007

See HOL/Refute.thy for help.
*)

section \<open>Examples for the 'refute' command\<close>

theory Refute_Examples
imports "HOL-Library.Refute"
begin

refute_params [satsolver = "cdclite"]

lemma "P \<and> Q"
apply (rule conjI)
refute [expect = genuine] 1  \<comment> \<open>refutes \<^term>\<open>P\<close>\<close>
refute [expect = genuine] 2  \<comment> \<open>refutes \<^term>\<open>Q\<close>\<close>
refute [expect = genuine]    \<comment> \<open>equivalent to 'refute 1'\<close>
  \<comment> \<open>here 'refute 3' would cause an exception, since we only have 2 subgoals\<close>
refute [maxsize = 5, expect = genuine]   \<comment> \<open>we can override parameters ...\<close>
refute [satsolver = "cdclite", expect = genuine] 2
  \<comment> \<open>... and specify a subgoal at the same time\<close>
oops

(*****************************************************************************)

subsection \<open>Examples and Test Cases\<close>

subsubsection \<open>Propositional logic\<close>

lemma "True"
refute [expect = none]
by auto

lemma "False"
refute [expect = genuine]
oops

lemma "P"
refute [expect = genuine]
oops

lemma "~ P"
refute [expect = genuine]
oops

lemma "P & Q"
refute [expect = genuine]
oops

lemma "P | Q"
refute [expect = genuine]
oops

lemma "P \<longrightarrow> Q"
refute [expect = genuine]
oops

lemma "(P::bool) = Q"
refute [expect = genuine]
oops

lemma "(P | Q) \<longrightarrow> (P & Q)"
refute [expect = genuine]
oops

(*****************************************************************************)

subsubsection \<open>Predicate logic\<close>

lemma "P x y z"
refute [expect = genuine]
oops

lemma "P x y \<longrightarrow> P y x"
refute [expect = genuine]
oops

lemma "P (f (f x)) \<longrightarrow> P x \<longrightarrow> P (f x)"
refute [expect = genuine]
oops

(*****************************************************************************)

subsubsection \<open>Equality\<close>

lemma "P = True"
refute [expect = genuine]
oops

lemma "P = False"
refute [expect = genuine]
oops

lemma "x = y"
refute [expect = genuine]
oops

lemma "f x = g x"
refute [expect = genuine]
oops

lemma "(f::'a\<Rightarrow>'b) = g"
refute [expect = genuine]
oops

lemma "(f::('d\<Rightarrow>'d)\<Rightarrow>('c\<Rightarrow>'d)) = g"
refute [expect = genuine]
oops

lemma "distinct [a, b]"
(* refute *)
apply simp
refute [expect = genuine]
oops

(*****************************************************************************)

subsubsection \<open>First-Order Logic\<close>

lemma "\<exists>x. P x"
refute [expect = genuine]
oops

lemma "\<forall>x. P x"
refute [expect = genuine]
oops

lemma "\<exists>!x. P x"
refute [expect = genuine]
oops

lemma "Ex P"
refute [expect = genuine]
oops

lemma "All P"
refute [expect = genuine]
oops

lemma "Ex1 P"
refute [expect = genuine]
oops

lemma "(\<exists>x. P x) \<longrightarrow> (\<forall>x. P x)"
refute [expect = genuine]
oops

lemma "(\<forall>x. \<exists>y. P x y) \<longrightarrow> (\<exists>y. \<forall>x. P x y)"
refute [expect = genuine]
oops

lemma "(\<exists>x. P x) \<longrightarrow> (\<exists>!x. P x)"
refute [expect = genuine]
oops

text \<open>A true statement (also testing names of free and bound variables being identical)\<close>

lemma "(\<forall>x y. P x y \<longrightarrow> P y x) \<longrightarrow> (\<forall>x. P x y) \<longrightarrow> P y x"
refute [maxsize = 4, expect = none]
by fast

text \<open>"A type has at most 4 elements."\<close>

lemma "a=b | a=c | a=d | a=e | b=c | b=d | b=e | c=d | c=e | d=e"
refute [expect = genuine]
oops

lemma "\<forall>a b c d e. a=b | a=c | a=d | a=e | b=c | b=d | b=e | c=d | c=e | d=e"
refute [expect = genuine]
oops

text \<open>"Every reflexive and symmetric relation is transitive."\<close>

lemma "\<lbrakk> \<forall>x. P x x; \<forall>x y. P x y \<longrightarrow> P y x \<rbrakk> \<Longrightarrow> P x y \<longrightarrow> P y z \<longrightarrow> P x z"
refute [expect = genuine]
oops

text \<open>The "Drinker's theorem" ...\<close>

lemma "\<exists>x. f x = g x \<longrightarrow> f = g"
refute [maxsize = 4, expect = none]
by (auto simp add: ext)

text \<open>... and an incorrect version of it\<close>

lemma "(\<exists>x. f x = g x) \<longrightarrow> f = g"
refute [expect = genuine]
oops

text \<open>"Every function has a fixed point."\<close>

lemma "\<exists>x. f x = x"
refute [expect = genuine]
oops

text \<open>"Function composition is commutative."\<close>

lemma "f (g x) = g (f x)"
refute [expect = genuine]
oops

text \<open>"Two functions that are equivalent wrt.\ the same predicate 'P' are equal."\<close>

lemma "((P::('a\<Rightarrow>'b)\<Rightarrow>bool) f = P g) \<longrightarrow> (f x = g x)"
refute [expect = genuine]
oops

(*****************************************************************************)

subsubsection \<open>Higher-Order Logic\<close>

lemma "\<exists>P. P"
refute [expect = none]
by auto

lemma "\<forall>P. P"
refute [expect = genuine]
oops

lemma "\<exists>!P. P"
refute [expect = none]
by auto

lemma "\<exists>!P. P x"
refute [expect = genuine]
oops

lemma "P Q | Q x"
refute [expect = genuine]
oops

lemma "x \<noteq> All"
refute [expect = genuine]
oops

lemma "x \<noteq> Ex"
refute [expect = genuine]
oops

lemma "x \<noteq> Ex1"
refute [expect = genuine]
oops

text \<open>"The transitive closure 'T' of an arbitrary relation 'P' is non-empty."\<close>

definition "trans" :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
  "trans P \<equiv> (\<forall>x y z. P x y \<longrightarrow> P y z \<longrightarrow> P x z)"

definition "subset" :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
  "subset P Q \<equiv> (\<forall>x y. P x y \<longrightarrow> Q x y)"

definition "trans_closure" :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
  "trans_closure P Q \<equiv> (subset Q P) \<and> (trans P) \<and> (\<forall>R. subset Q R \<longrightarrow> trans R \<longrightarrow> subset P R)"

lemma "trans_closure T P \<longrightarrow> (\<exists>x y. T x y)"
refute [expect = genuine]
oops

text \<open>"Every surjective function is invertible."\<close>

lemma "(\<forall>y. \<exists>x. y = f x) \<longrightarrow> (\<exists>g. \<forall>x. g (f x) = x)"
refute [expect = genuine]
oops

text \<open>"Every invertible function is surjective."\<close>

lemma "(\<exists>g. \<forall>x. g (f x) = x) \<longrightarrow> (\<forall>y. \<exists>x. y = f x)"
refute [expect = genuine]
oops

text \<open>Every point is a fixed point of some function.\<close>

lemma "\<exists>f. f x = x"
refute [maxsize = 4, expect = none]
apply (rule_tac x="\<lambda>x. x" in exI)
by simp

text \<open>Axiom of Choice: first an incorrect version ...\<close>

lemma "(\<forall>x. \<exists>y. P x y) \<longrightarrow> (\<exists>!f. \<forall>x. P x (f x))"
refute [expect = genuine]
oops

text \<open>... and now two correct ones\<close>

lemma "(\<forall>x. \<exists>y. P x y) \<longrightarrow> (\<exists>f. \<forall>x. P x (f x))"
refute [maxsize = 4, expect = none]
by (simp add: choice)

lemma "(\<forall>x. \<exists>!y. P x y) \<longrightarrow> (\<exists>!f. \<forall>x. P x (f x))"
refute [maxsize = 2, expect = none]
apply auto
  apply (simp add: ex1_implies_ex choice)
by (fast intro: ext)

(*****************************************************************************)

subsubsection \<open>Meta-logic\<close>

lemma "!!x. P x"
refute [expect = genuine]
oops

lemma "f x == g x"
refute [expect = genuine]
oops

lemma "P \<Longrightarrow> Q"
refute [expect = genuine]
oops

lemma "\<lbrakk> P; Q; R \<rbrakk> \<Longrightarrow> S"
refute [expect = genuine]
oops

lemma "(x == Pure.all) \<Longrightarrow> False"
refute [expect = genuine]
oops

lemma "(x == (==)) \<Longrightarrow> False"
refute [expect = genuine]
oops

lemma "(x == (\<Longrightarrow>)) \<Longrightarrow> False"
refute [expect = genuine]
oops

(*****************************************************************************)

subsubsection \<open>Schematic variables\<close>

schematic_goal "?P"
refute [expect = none]
by auto

schematic_goal "x = ?y"
refute [expect = none]
by auto

(******************************************************************************)

subsubsection \<open>Abstractions\<close>

lemma "(\<lambda>x. x) = (\<lambda>x. y)"
refute [expect = genuine]
oops

lemma "(\<lambda>f. f x) = (\<lambda>f. True)"
refute [expect = genuine]
oops

lemma "(\<lambda>x. x) = (\<lambda>y. y)"
refute
by simp

(*****************************************************************************)

subsubsection \<open>Sets\<close>

lemma "P (A::'a set)"
refute
oops

lemma "P (A::'a set set)"
refute
oops

lemma "{x. P x} = {y. P y}"
refute
by simp

lemma "x \<in> {x. P x}"
refute
oops

lemma "P (\<in>)"
refute
oops

lemma "P ((\<in>) x)"
refute
oops

lemma "P Collect"
refute
oops

lemma "A \<union> B = A \<inter> B"
refute
oops

lemma "(A \<inter> B) \<union> C = (A \<union> C) \<inter> B"
refute
oops

lemma "Ball A P \<longrightarrow> Bex A P"
refute
oops

(*****************************************************************************)

subsubsection \<open>undefined\<close>

lemma "undefined"
refute [expect = genuine]
oops

lemma "P undefined"
refute [expect = genuine]
oops

lemma "undefined x"
refute [expect = genuine]
oops

lemma "undefined undefined"
refute [expect = genuine]
oops

(*****************************************************************************)

subsubsection \<open>The\<close>

lemma "The P"
refute [expect = genuine]
oops

lemma "P The"
refute [expect = genuine]
oops

lemma "P (The P)"
refute [expect = genuine]
oops

lemma "(THE x. x=y) = z"
refute [expect = genuine]
oops

lemma "Ex P \<longrightarrow> P (The P)"
refute [expect = genuine]
oops

(*****************************************************************************)

subsubsection \<open>Eps\<close>

lemma "Eps P"
refute [expect = genuine]
oops

lemma "P Eps"
refute [expect = genuine]
oops

lemma "P (Eps P)"
refute [expect = genuine]
oops

lemma "(SOME x. x=y) = z"
refute [expect = genuine]
oops

lemma "Ex P \<longrightarrow> P (Eps P)"
refute [maxsize = 3, expect = none]
by (auto simp add: someI)

(*****************************************************************************)

subsubsection \<open>Subtypes (typedef), typedecl\<close>

text \<open>A completely unspecified non-empty subset of \<^typ>\<open>'a\<close>:\<close>

definition "myTdef = insert (undefined::'a) (undefined::'a set)"

typedef 'a myTdef = "myTdef :: 'a set"
  unfolding myTdef_def by auto

lemma "(x::'a myTdef) = y"
refute
oops

typedecl myTdecl

definition "T_bij = {(f::'a\<Rightarrow>'a). \<forall>y. \<exists>!x. f x = y}"

typedef 'a T_bij = "T_bij :: ('a \<Rightarrow> 'a) set"
  unfolding T_bij_def by auto

lemma "P (f::(myTdecl myTdef) T_bij)"
refute
oops

(*****************************************************************************)

subsubsection \<open>Inductive datatypes\<close>

text \<open>unit\<close>

lemma "P (x::unit)"
refute [expect = genuine]
oops

lemma "\<forall>x::unit. P x"
refute [expect = genuine]
oops

lemma "P ()"
refute [expect = genuine]
oops

lemma "P (case x of () \<Rightarrow> u)"
refute [expect = genuine]
oops

text \<open>option\<close>

lemma "P (x::'a option)"
refute [expect = genuine]
oops

lemma "\<forall>x::'a option. P x"
refute [expect = genuine]
oops

lemma "P None"
refute [expect = genuine]
oops

lemma "P (Some x)"
refute [expect = genuine]
oops

lemma "P (case x of None \<Rightarrow> n | Some u \<Rightarrow> s u)"
refute [expect = genuine]
oops

text \<open>*\<close>

lemma "P (x::'a*'b)"
refute [expect = genuine]
oops

lemma "\<forall>x::'a*'b. P x"
refute [expect = genuine]
oops

lemma "P (x, y)"
refute [expect = genuine]
oops

lemma "P (fst x)"
refute [expect = genuine]
oops

lemma "P (snd x)"
refute [expect = genuine]
oops

lemma "P Pair"
refute [expect = genuine]
oops

lemma "P (case x of Pair a b \<Rightarrow> p a b)"
refute [expect = genuine]
oops

text \<open>+\<close>

lemma "P (x::'a+'b)"
refute [expect = genuine]
oops

lemma "\<forall>x::'a+'b. P x"
refute [expect = genuine]
oops

lemma "P (Inl x)"
refute [expect = genuine]
oops

lemma "P (Inr x)"
refute [expect = genuine]
oops

lemma "P Inl"
refute [expect = genuine]
oops

lemma "P (case x of Inl a \<Rightarrow> l a | Inr b \<Rightarrow> r b)"
refute [expect = genuine]
oops

text \<open>Non-recursive datatypes\<close>

datatype T1 = A | B

lemma "P (x::T1)"
refute [expect = genuine]
oops

lemma "\<forall>x::T1. P x"
refute [expect = genuine]
oops

lemma "P A"
refute [expect = genuine]
oops

lemma "P B"
refute [expect = genuine]
oops

lemma "rec_T1 a b A = a"
refute [expect = none]
by simp

lemma "rec_T1 a b B = b"
refute [expect = none]
by simp

lemma "P (rec_T1 a b x)"
refute [expect = genuine]
oops

lemma "P (case x of A \<Rightarrow> a | B \<Rightarrow> b)"
refute [expect = genuine]
oops

datatype 'a T2 = C T1 | D 'a

lemma "P (x::'a T2)"
refute [expect = genuine]
oops

lemma "\<forall>x::'a T2. P x"
refute [expect = genuine]
oops

lemma "P D"
refute [expect = genuine]
oops

lemma "rec_T2 c d (C x) = c x"
refute [maxsize = 4, expect = none]
by simp

lemma "rec_T2 c d (D x) = d x"
refute [maxsize = 4, expect = none]
by simp

lemma "P (rec_T2 c d x)"
refute [expect = genuine]
oops

lemma "P (case x of C u \<Rightarrow> c u | D v \<Rightarrow> d v)"
refute [expect = genuine]
oops

datatype ('a,'b) T3 = E "'a \<Rightarrow> 'b"

lemma "P (x::('a,'b) T3)"
refute [expect = genuine]
oops

lemma "\<forall>x::('a,'b) T3. P x"
refute [expect = genuine]
oops

lemma "P E"
refute [expect = genuine]
oops

lemma "rec_T3 e (E x) = e x"
refute [maxsize = 2, expect = none]
by simp

lemma "P (rec_T3 e x)"
refute [expect = genuine]
oops

lemma "P (case x of E f \<Rightarrow> e f)"
refute [expect = genuine]
oops

text \<open>Recursive datatypes\<close>

text \<open>nat\<close>

lemma "P (x::nat)"
refute [expect = potential]
oops

lemma "\<forall>x::nat. P x"
refute [expect = potential]
oops

lemma "P (Suc 0)"
refute [expect = potential]
oops

lemma "P Suc"
refute [maxsize = 3, expect = none]
\<comment> \<open>\<^term>\<open>Suc\<close> is a partial function (regardless of the size
      of the model), hence \<^term>\<open>P Suc\<close> is undefined and no
      model will be found\<close>
oops

lemma "rec_nat zero suc 0 = zero"
refute [expect = none]
by simp

lemma "rec_nat zero suc (Suc x) = suc x (rec_nat zero suc x)"
refute [maxsize = 2, expect = none]
by simp

lemma "P (rec_nat zero suc x)"
refute [expect = potential]
oops

lemma "P (case x of 0 \<Rightarrow> zero | Suc n \<Rightarrow> suc n)"
refute [expect = potential]
oops

text \<open>'a list\<close>

lemma "P (xs::'a list)"
refute [expect = potential]
oops

lemma "\<forall>xs::'a list. P xs"
refute [expect = potential]
oops

lemma "P [x, y]"
refute [expect = potential]
oops

lemma "rec_list nil cons [] = nil"
refute [maxsize = 3, expect = none]
by simp

lemma "rec_list nil cons (x#xs) = cons x xs (rec_list nil cons xs)"
refute [maxsize = 2, expect = none]
by simp

lemma "P (rec_list nil cons xs)"
refute [expect = potential]
oops

lemma "P (case x of Nil \<Rightarrow> nil | Cons a b \<Rightarrow> cons a b)"
refute [expect = potential]
oops

lemma "(xs::'a list) = ys"
refute [expect = potential]
oops

lemma "a # xs = b # xs"
refute [expect = potential]
oops

datatype BitList = BitListNil | Bit0 BitList | Bit1 BitList

lemma "P (x::BitList)"
refute [expect = potential]
oops

lemma "\<forall>x::BitList. P x"
refute [expect = potential]
oops

lemma "P (Bit0 (Bit1 BitListNil))"
refute [expect = potential]
oops

lemma "rec_BitList nil bit0 bit1 BitListNil = nil"
refute [maxsize = 4, expect = none]
by simp

lemma "rec_BitList nil bit0 bit1 (Bit0 xs) = bit0 xs (rec_BitList nil bit0 bit1 xs)"
refute [maxsize = 2, expect = none]
by simp

lemma "rec_BitList nil bit0 bit1 (Bit1 xs) = bit1 xs (rec_BitList nil bit0 bit1 xs)"
refute [maxsize = 2, expect = none]
by simp

lemma "P (rec_BitList nil bit0 bit1 x)"
refute [expect = potential]
oops

(*****************************************************************************)

subsubsection \<open>Examples involving special functions\<close>

lemma "card x = 0"
refute [expect = potential]
oops

lemma "finite x"
refute \<comment> \<open>no finite countermodel exists\<close>
oops

lemma "(x::nat) + y = 0"
refute [expect = potential]
oops

lemma "(x::nat) = x + x"
refute [expect = potential]
oops

lemma "(x::nat) - y + y = x"
refute [expect = potential]
oops

lemma "(x::nat) = x * x"
refute [expect = potential]
oops

lemma "(x::nat) < x + y"
refute [expect = potential]
oops

lemma "xs @ [] = ys @ []"
refute [expect = potential]
oops

lemma "xs @ ys = ys @ xs"
refute [expect = potential]
oops

(*****************************************************************************)

subsubsection \<open>Type classes and overloading\<close>

text \<open>A type class without axioms:\<close>

class classA

lemma "P (x::'a::classA)"
refute [expect = genuine]
oops

text \<open>An axiom with a type variable (denoting types which have at least two elements):\<close>

class classC =
  assumes classC_ax: "\<exists>x y. x \<noteq> y"

lemma "P (x::'a::classC)"
refute [expect = genuine]
oops

lemma "\<exists>x y. (x::'a::classC) \<noteq> y"
(* refute [expect = none] FIXME *)
oops

text \<open>A type class for which a constant is defined:\<close>

class classD =
  fixes classD_const :: "'a \<Rightarrow> 'a"
  assumes classD_ax: "classD_const (classD_const x) = classD_const x"

lemma "P (x::'a::classD)"
refute [expect = genuine]
oops

text \<open>A type class with multiple superclasses:\<close>

class classE = classC + classD

lemma "P (x::'a::classE)"
refute [expect = genuine]
oops

text \<open>OFCLASS:\<close>

lemma "OFCLASS('a::type, type_class)"
refute [expect = none]
by intro_classes

lemma "OFCLASS('a::classC, type_class)"
refute [expect = none]
by intro_classes

lemma "OFCLASS('a::type, classC_class)"
refute [expect = genuine]
oops

text \<open>Overloading:\<close>

consts inverse :: "'a \<Rightarrow> 'a"

overloading inverse_bool \<equiv> "inverse :: bool \<Rightarrow> bool"
begin
  definition "inverse (b::bool) \<equiv> \<not> b"
end

overloading inverse_set \<equiv> "inverse :: 'a set \<Rightarrow> 'a set"
begin
  definition "inverse (S::'a set) \<equiv> -S"
end

overloading inverse_pair \<equiv> "inverse :: 'a \<times> 'b \<Rightarrow> 'a \<times> 'b"
begin
  definition "inverse_pair p \<equiv> (inverse (fst p), inverse (snd p))"
end

lemma "inverse b"
refute [expect = genuine]
oops

lemma "P (inverse (S::'a set))"
refute [expect = genuine]
oops

lemma "P (inverse (p::'a\<times>'b))"
refute [expect = genuine]
oops

text \<open>Structured proofs\<close>

lemma "x = y"
proof cases
  assume "x = y"
  show ?thesis
  refute [expect = none]
  refute [no_assms, expect = genuine]
  refute [no_assms = false, expect = none]
oops

refute_params [satsolver = "auto"]

end


subsection \<open>Executable version\<close>

theory Multiset_Extension_Pair_Impl
  imports
    Multiset_Extension_Pair
begin

lemma subset_mult2_alt:
  assumes "X \<subseteq># Y" "(Y, Z) \<in> mult2_alt b ns s" "b \<Longrightarrow> b'"
  shows "(X, Z) \<in> mult2_alt b' ns s"
proof -
  from assms(2) obtain Y1 Y2 Z1 Z2 where *: "Y = Y1 + Y2" "Z = Z1 + Z2"
    "(Y1, Z1) \<in> multpw ns" "b \<or> Z2 \<noteq> {#}" "\<forall>y. y \<in># Y2 \<longrightarrow> (\<exists>z. z \<in># Z2 \<and> (y, z) \<in> s)"
    unfolding mult2_alt_def by blast
  define Y11 Y12 X2 where "Y11 = Y1 \<inter># X" and "Y12 = Y1 - X" and "X2 = X - Y11"
  have **: "X = Y11 + X2" "X2 \<subseteq># Y2" "Y1 = Y11 + Y12" using *(1)
    by (auto simp: Y11_def Y12_def X2_def multiset_eq_iff subseteq_mset_def)
      (metis add.commute assms(1) le_diff_conv subseteq_mset_def)
  obtain Z11 Z12 where ***: "Z = Z11 + (Z12 + Z2)" "Z1 = Z11 + Z12" "(Y11, Z11) \<in> multpw ns"
    using *(2,3) **(3) by (auto elim: multpw_splitR simp: ac_simps)
  moreover have "\<forall>y. y \<in># X2 \<longrightarrow> (\<exists>z. z \<in># Z12 + Z2 \<and> (y, z) \<in> s)" "b \<or> Z12 + Z2 \<noteq> {#}"
    using *(4,5) **(2) by (auto dest!: mset_subset_eqD)
  ultimately show ?thesis using *(2) **(1) assms(3) unfolding mult2_alt_def by blast
qed

text \<open>Case distinction for recursion on left argument\<close>

lemma mem_multiset_diff: "x \<in># A \<Longrightarrow> x \<noteq> y \<Longrightarrow> x \<in># (A - {#y#})"
  by (metis add_mset_remove_trivial_If diff_single_trivial insert_noteq_member)

lemma mult2_alt_addL: "(add_mset x X, Y) \<in> mult2_alt b ns s \<longleftrightarrow>
  (\<exists>y. y \<in># Y \<and> (x, y) \<in> s \<and> ({# x \<in># X. (x, y) \<notin> s #}, Y - {#y#}) \<in> mult2_alt_ns ns s) \<or>
  (\<exists>y. y \<in># Y \<and> (x, y) \<in> ns \<and> (x, y) \<notin> s \<and> (X, Y - {#y#}) \<in> mult2_alt b ns s)" (is "?L \<longleftrightarrow> ?R1 \<or> ?R2")
proof (intro iffI; (elim disjE)?)
  assume ?L then obtain X1 X2 Y1 Y2 where *: "add_mset x X = X1 + X2" "Y = Y1 + Y2"
    "(X1, Y1) \<in> multpw ns" "b \<or> Y2 \<noteq> {#}" "\<forall>x. x \<in># X2 \<longrightarrow> (\<exists>y. y \<in># Y2 \<and> (x, y) \<in> s)"
    unfolding mult2_alt_def by blast
  from union_single_eq_member[OF this(1)] multi_member_split
  consider X1' where "X1 = add_mset x X1'" "x \<in># X1" | X2' where "X2 = add_mset x X2'" "x \<in># X2"
    unfolding set_mset_union Un_iff by metis
  then show "?R1 \<or> ?R2"
  proof cases
    case 1 then obtain y Y1' where **: "y \<in># Y1" "Y1 = add_mset y Y1'" "(X1', Y1') \<in> multpw ns" "(x, y) \<in> ns"
      using * by (auto elim: multpw_split1R)
    show ?thesis
    proof (cases "(x, y) \<in> s")
      case False then show ?thesis using mult2_altI[OF refl refl **(3) *(4,5)] *
        by (auto simp: 1 ** intro: exI[of _ y])
    next
      case True
      define X2' where "X2' = {# x \<in># X2. (x, y) \<notin> s #}"
      have x3: "\<forall>x. x \<in># X2' \<longrightarrow> (\<exists>z. z \<in># Y2 \<and> (x, z) \<in> s)" using *(5) **(1,2) by (auto simp: X2'_def)
      have x4: "{# x \<in># X. (x, y) \<notin> s#} \<subseteq># X1' + X2'" using *(1) 1
        by (auto simp: X2'_def multiset_eq_iff intro!: mset_subset_eqI split: if_splits elim!: in_countE) (metis le_refl)
      show ?thesis using mult2_alt_nsI[OF refl refl **(3) x3, THEN subset_mult2_alt[OF x4]]
          **(2) *(2) True by (auto intro: exI[of _ y])
    qed
  next
    case 2 then obtain y where **: "y \<in># Y2" "(x, y) \<in> s" using * by blast
    define X2' where "X2' = {# x \<in># X2. (x, y) \<notin> s #}"
    have x3: "\<forall>x. x \<in># X2' \<longrightarrow> (\<exists>z. z \<in># Y2 - {#y#} \<and> (x, z) \<in> s)"
      using *(5) **(1,2) by (auto simp: X2'_def) (metis mem_multiset_diff)
    have x4: "{# x \<in># X. (x, y) \<notin> s#} \<subseteq># X1 + X2'"
      using *(1) **(2) by (auto simp: X2'_def multiset_eq_iff intro!: mset_subset_eqI split: if_splits)
    show ?thesis
      using mult2_alt_nsI[OF refl refl *(3) x3, THEN subset_mult2_alt[OF x4], of True] **(1,2) *(2)
      by (auto simp: diff_union_single_conv[symmetric])
  qed
next
  assume ?R1
  then obtain y where *: "y \<in># Y" "(x, y) \<in> s" "({# x \<in># X. (x, y) \<notin> s #}, Y - {#y#}) \<in> mult2_alt_ns ns s"
    by blast
  then have **: "({# x \<in># X. (x, y) \<in> s #} + {#x#}, {#y#}) \<in> mult2_alt b ns s"
    "{# x \<in># X. (x, y) \<notin> s #} + {# x \<in># X. (x, y) \<in> s #} = X"
    by (auto intro: mult2_altI[of _ "{#}" _ _ "{#}"] multiset_eqI split: if_splits)
  show ?L using mult2_alt_add[OF *(3) **(1)] * ** by (auto simp: union_assoc[symmetric])
next
  assume ?R2
  then obtain y where *: "y \<in># Y" "(x, y) \<in> ns" "(X, Y - {#y#}) \<in> mult2_alt b ns s" by blast
  then show ?L using mult2_alt_add[OF *(3) multpw_implies_mult2_alt_ns, of "{#x#}" "{#y#}"]
    by (auto intro: multpw_single)
qed

text \<open>Auxiliary version with an extra @{typ bool} argument for distinguishing between the
  non-strict and the strict orders\<close>

context fixes nss :: "'a \<Rightarrow> 'a \<Rightarrow> bool \<Rightarrow> bool"
begin

fun mult2_impl0 :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool \<Rightarrow> bool"
  and mult2_ex_dom0 :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool \<Rightarrow> bool"
  where
    "mult2_impl0 []       [] b \<longleftrightarrow> b"
  | "mult2_impl0 xs       [] b \<longleftrightarrow> False"
  | "mult2_impl0 []       ys b \<longleftrightarrow> True"
  | "mult2_impl0 (x # xs) ys b \<longleftrightarrow> mult2_ex_dom0 x xs ys [] b"

| "mult2_ex_dom0 x xs []       ys' b \<longleftrightarrow> False"
| "mult2_ex_dom0 x xs (y # ys) ys' b \<longleftrightarrow>
     nss x y False \<and> mult2_impl0 (filter (\<lambda>x. \<not> nss x y False) xs) (ys @ ys') True \<or>
     nss x y True \<and> \<not> nss x y False \<and> mult2_impl0 xs (ys @ ys') b \<or>
     mult2_ex_dom0 x xs ys (y # ys') b"

end

lemma mult2_impl0_sound:
  fixes nss
  defines "ns \<equiv> {(x, y). nss x y True}" and "s \<equiv> {(x, y). nss x y False}"
  shows "mult2_impl0 nss xs ys b \<longleftrightarrow> (mset xs, mset ys) \<in> mult2_alt b ns s"
    "mult2_ex_dom0 nss x xs ys ys' b \<longleftrightarrow>
      (\<exists>y. y \<in># mset ys \<and> (x, y) \<in> s \<and> (mset (filter (\<lambda>x. (x, y) \<notin> s) xs), mset (ys @ ys') - {#y#}) \<in> mult2_alt True ns s) \<or>
      (\<exists>y. y \<in># mset ys \<and> (x, y) \<in> ns \<and> (x, y) \<notin> s \<and> (mset xs, mset (ys @ ys') - {#y#}) \<in> mult2_alt b ns s)"
proof (induct xs ys b and x xs ys ys' b taking: nss rule: mult2_impl0_mult2_ex_dom0.induct)
  case (4 x xs y ys b) show ?case unfolding mult2_impl0.simps 4
    using mult2_alt_addL[of x "mset xs" "mset (y # ys)" b ns s] by (simp add: mset_filter)
next
  case (6 x xs y ys ys' b) show ?case unfolding mult2_ex_dom0.simps 6
    using subset_mult2_alt[of "mset [x\<leftarrow>xs . (x, y) \<notin> s]" "mset xs" "mset (ys @ ys')" b ns s True]
    apply (intro iffI; elim disjE conjE exE; simp add: mset_filter ns_def s_def; (elim disjE)?)
    subgoal by (intro disjI1 exI[of _ y]) auto
    subgoal by (intro disjI2 exI[of _ y]) auto
    subgoal for y' by (intro disjI1 exI[of _ y']) auto
    subgoal for y' by (intro disjI2 exI[of _ y']) auto
    subgoal for y' by simp
    subgoal for y' by (rule disjI2, rule disjI2, rule disjI1, rule exI[of _ y']) simp
    subgoal for y' by simp
    subgoal for y' by (rule disjI2, rule disjI2, rule disjI2, rule exI[of _ y']) simp
    done
qed (auto simp: mult2_alt_emptyL mult2_alt_emptyR)

text \<open>Now, instead of functions of type @{typ "bool \<Rightarrow> bool"}, use pairs of type
  @{typ "bool \<times> bool"}\<close>

definition [simp]: "or2 a b = (fst a \<or> fst b, snd a \<or> snd b)"

context fixes sns :: "'a \<Rightarrow> 'a \<Rightarrow> bool \<times> bool"
begin

fun mult2_impl :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool \<times> bool"
  and mult2_ex_dom :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool \<times> bool"
  where
    "mult2_impl []       [] = (False, True)"
  | "mult2_impl xs       [] = (False, False)"
  | "mult2_impl []       ys = (True, True)"
  | "mult2_impl (x # xs) ys = mult2_ex_dom x xs ys []"

| "mult2_ex_dom x xs []       ys' = (False, False)"
| "mult2_ex_dom x xs (y # ys) ys' =
    (case sns x y of
      (True, _) \<Rightarrow> if snd (mult2_impl (filter (\<lambda>x. \<not> fst (sns x y)) xs) (ys @ ys')) then (True, True)
                   else mult2_ex_dom x xs ys (y # ys')
    | (False, True) \<Rightarrow> or2 (mult2_impl xs (ys @ ys')) (mult2_ex_dom x xs ys (y # ys'))
    | _ \<Rightarrow> mult2_ex_dom x xs ys (y # ys'))"
end

lemma mult2_impl_sound0:
  defines "pair \<equiv> \<lambda>f. (f False, f True)" and "fun \<equiv> \<lambda>p b. if b then snd p else fst p"
  shows "mult2_impl sns xs ys = pair (mult2_impl0 (\<lambda>x y. fun (sns x y)) xs ys)" (is ?P)
    "mult2_ex_dom sns x xs ys ys' = pair (mult2_ex_dom0 (\<lambda>x y. fun (sns x y)) x xs ys ys')" (is ?Q)
proof -
  show ?P ?Q
  proof (induct xs ys and x xs ys ys' taking: sns rule: mult2_impl_mult2_ex_dom.induct)
    case (6 x xs y ys ys')
    show ?case unfolding mult2_ex_dom.simps mult2_ex_dom0.simps
      by (fastforce simp: pair_def fun_def 6 if_bool_eq_conj split: prod.splits bool.splits)
  qed (auto simp: pair_def fun_def if_bool_eq_conj)
qed

lemmas mult2_impl_sound = mult2_impl_sound0(1)[unfolded mult2_impl0_sound if_True if_False]
end


section \<open> Building Entry System \<close>

theory BuildingEntry
  imports "Z_Machines.Z_Machine"
begin

term subst_upd

type_synonym staff = \<nat>

consts
  Staff :: "staff set"
  maxentry :: "\<nat>"

schema ASystem =
  s :: "\<bbbP> staff"
  where "s \<in> \<bbbF> Staff" "#s < maxentry"

record_default ASystem

zoperation AEnterBuilding =
  over ASystem
  params p\<in>Staff
  pre "#s < maxentry \<and> p \<notin> s"
  update "[s \<leadsto> s \<union> {p}]"

zoperation ALeaveBuilding =
  over ASystem
  params p\<in>Staff
  pre "p \<in> s"
  update "[s \<leadsto> s - {p}]"

zmachine ABuildingEntry =
  over ASystem
  init "[s \<leadsto> {}]"
  operations AEnterBuilding ALeaveBuilding

def_consts
  Staff = "{0..10}"
  maxentry = "5"

animate ABuildingEntry

schema CSystem =
  l :: "staff list"
  where
    "l \<in> iseq Staff" "#l \<le> maxentry"

record_default CSystem

zoperation CEnterBuilding =
  params p \<in> Staff
  pre "#l < maxentry \<and> p \<notin> ran l"
  update "[l \<leadsto> l @ [p]]"

definition ListRetrieveSet :: "CSystem \<Rightarrow> (_, ASystem) itree" where
"ListRetrieveSet = \<questiondown>CSystem? ;; \<langle>\<lblot>s \<leadsto> set l\<rblot>\<rangle>\<^sub>a"

definition SetRetrieveList :: "ASystem \<Rightarrow> (_, CSystem) itree" where
"SetRetrieveList = \<questiondown>ASystem? ;; \<langle>\<lblot>l \<leadsto> sorted_list_of_set s\<rblot>\<rangle>\<^sub>a"

find_theorems "(\<circ>\<^sub>s)"

lemma "ListRetrieveSet ;; SetRetrieveList = \<questiondown>CSystem?"
  apply (simp add: ListRetrieveSet_def SetRetrieveList_def ASystem_inv_def assigns_seq kcomp_assoc assigns_assume assigns_seq_comp usubst usubst_eval)

lemma "p \<in> Staff \<Longrightarrow> (ListRetrieveSet ;; AEnterBuilding p) \<sqsubseteq> (CEnterBuilding p ;; ListRetrieveSet)"
  unfolding ListRetrieveSet_def AEnterBuilding_def CEnterBuilding_def
  apply refine_auto
   apply (simp add: distinct_card)
  done

end