(*
 * cf. planning/hol/sublistScript
 *)
theory FSSublist
  imports Main "HOL-Library.Sublist" ListUtils
begin

text \<open> This file is a port of the original HOL4 source file sublistScript.sml. \<close>

section "Factored System Sublist"
subsection "Sublist Characterization"

text \<open> We take a look at the characterization of sublists. As a precursor, we are replacing the
original definition of `sublist` in HOL4 (sublistScript.sml:10) with the semantically equivalent
`subseq` of Isabelle/HOL's to be able to use the associated theorems and automation.

In HOL4 `sublist` is defined as

  (sublist [] l1 = T) /\
  (sublist (h::t) [] = F) /\
  (sublist (x::l1) (y::l2) = (x = y) /\ sublist l1 l2 \/ sublist (x::l1) l2)

[Abdulaziz et al., HOL4 Definition 10, p.19]. Whereas `subseq` (Sublist.tyh:927) is defined as an
abbrevation of `list\_emb` with the predicate @{term "\<lambda> x y. x = y"}, i.e.

    @{term "subseq xs ys \<equiv> list_emb (=) xs ys"}

`list\_emb` itself is defined as an inductive predicate. However, an equivalent function definition
is provided in `list\_emb\_code` (Sublist.thy:784) which is very close to `sublist` in HOL4.

The correctness of the equivalence claim is shown below by the technical lemma
`sublist\_HOL4\_equiv\_subseq` (where the HOL4 definition of `sublist` is renamed to `sublist\_HOL4`).
\<close>

\<comment> \<open>NOTE added definition\<close>
fun sublist_HOL4 where
  "sublist_HOL4 [] l1 = True"
| "(sublist_HOL4 (h # t) [] = False)"
| "(sublist_HOL4 (x # l1) (y # l2) = ((x = y) \<and> sublist_HOL4 l1 l2 \<or> sublist_HOL4 (x # l1) l2))"

\<comment> \<open>NOTE added lemma\<close>
lemma sublist_HOL4_equiv_subseq:
  fixes l1 l2
  shows "sublist_HOL4 l1 l2 \<longleftrightarrow> subseq l1 l2"
proof -
  have "subseq l1 l2 = list_emb (\<lambda>x y. x = y) l1 l2"
    by blast
  moreover {
    have "sublist_HOL4 l1 l2 \<longleftrightarrow> list_emb (\<lambda>x y. x = y) l1 l2"
    proof (induction rule: sublist_HOL4.induct)
      case (3 x l1 y l2)
      then show "sublist_HOL4 (x # l1) (y # l2) \<longleftrightarrow> list_emb (\<lambda>x y. x = y) (x # l1) (y # l2)"
      proof (cases "x = y")
        case True
        then show ?thesis
          using "3.IH"(1, 2)
          by (metis sublist_HOL4.simps(3) subseq_Cons' subseq_Cons2_iff)
      next
        case False
        then show ?thesis
          using "3.IH"(2)
          by force
      qed
    qed simp+
  }
  ultimately show ?thesis
    by blast
qed

text \<open> Likewise as with `sublist` and `subseq`, the HOL4 definition of `list\_frag`
(list\_utilsScript.sml:207) has a an Isabelle/HOL counterpart in `sublist` (Sublist.thy:1124).

The equivalence claim is proven in the technical lemma `list\_frag\_HOL4\_equiv\_sublist`. Note that
`sublist` reverses the argument order of `list\_frag`. Other than that, both definitions are
syntactically identical. \<close>
definition list_frag_HOL4 where
  "list_frag_HOL4 l frag \<equiv> \<exists>pfx sfx. pfx @ frag @ sfx = l"

lemma list_frag_HOL4_equiv_sublist:
  shows "list_frag_HOL4 l l' \<longleftrightarrow> sublist l' l"
  unfolding list_frag_HOL4_def sublist_def
  by blast

text \<open> Given these equivalences, occurences of `sublist` and `list\_frag` in the original HOL4
source are now always translated directly to `subseq` and `sublist` respectively.

The remainer of this subsection is concerned with characterizations of `sublist`/ `subseq`. \<close>

lemma sublist_EQNS:
  "subseq [] l = True"
  "subseq (h # t) [] = False"
  by auto

lemma sublist_refl: "subseq l l"
  by auto

lemma sublist_cons:
  assumes "subseq l1 l2"
  shows "subseq l1 (h # l2)"
  using assms
  by blast

lemma sublist_NIL: "subseq l1 [] = (l1 = [])"
  by fastforce

lemma sublist_trans:
  fixes l1 l2
  assumes "subseq l1 l2" "subseq l2 l3"
  shows "subseq l1 l3"
  using assms
  by force

\<comment> \<open>NOTE can be solved directly with 'list\_emb\_length'.\<close>
lemma sublist_length:
  fixes l l'
  assumes "subseq l l'"
  shows "length l \<le> length l'"
  using assms list_emb_length
  by blast

\<comment> \<open>NOTE can be solved directly with subseq\_Cons'.\<close>
lemma sublist_CONS1_E:
  fixes l1 l2
  assumes "subseq (h # l1) l2"
  shows "subseq l1 l2"
  using assms subseq_Cons'
  by metis

lemma sublist_equal_lengths:
  fixes l1 l2
  assumes "subseq l1 l2" "(length l1 = length l2)"
  shows "(l1 = l2)"
  using assms subseq_same_length
  by blast

\<comment> \<open>NOTE can be solved directly with 'subseq\_order.antisym'.\<close>
lemma sublist_antisym:
  assumes "subseq l1 l2" "subseq l2 l1"
  shows "(l1 = l2)"
  using assms subseq_order.antisym
  by blast

\<comment> \<open>NOTE can be solved directly with 'subseq\_rev\_drop\_many'.\<close>
lemma sublist_snoc:
  fixes l1 l2
  assumes "subseq l1 l2"
  shows "subseq l1 (l2 @ [h])"
  using assms subseq_rev_drop_many
  by blast

lemma sublist_append_front:
  fixes l1 l2
  shows "subseq l1 (l1 @ l2)"
  by fast

lemma append_sublist_1:
  assumes "subseq (l1 @ l2) l"
  shows "subseq l1 l \<and> subseq l2 l"
  using assms sublist_append_back sublist_append_front sublist_trans
  by blast

\<comment> \<open>NOTE added lemma (eventually wasn't needed in the remaining proofs).\<close>
lemma sublist_prefix:
  shows "subseq (h # l1) l2 \<Longrightarrow> \<exists>l2a l2b. l2 = l2a @ [h] @ l2b \<and> \<not>ListMem h l2a"
proof (induction l2 arbitrary: h l1)
  \<comment> \<open>NOTE l2 cannot be empty when @{term "(h # l1)"} isn't.\<close>
  case Nil
  have "\<not>(subseq (h # l1) [])"
    by simp
  then show ?case
    using Nil.prems
    by blast
next
  case (Cons a l2)
  then show ?case proof (cases "a = h")
    \<comment> \<open>NOTE If a = h then a trivial solution exists in l2a = [] and l2b = l2.\<close>
    case True
    then show "\<exists> l2a l2b. (Cons a l2) = l2a @ [h] @ l2b \<and> \<not>ListMem h l2a"
      using ListMem_iff
      by force
  next
    case False
    have "subseq (h # l1) l2"
      using Cons.prems False subseq_Cons2_neq
      by force
    then obtain l2a l2b where "l2 = l2a @ [h] @ l2b" "\<not>ListMem h l2a"
      using Cons.IH Cons.prems
      by meson
    moreover have "a # l2 = (a # l2a) @ [h] @ l2b"
      using calculation(1)
      by simp
    moreover have "\<not>(ListMem h (a # l2a))"
      using False calculation(2) ListMem.simps
      by fastforce
    ultimately show ?thesis
      by blast
  qed
qed

\<comment> \<open>NOTE added lemma (eventually wasn't needed in the remaining proofs).\<close>
lemma sublist_skip:
  fixes l1 l2 h l1'
  assumes "l1 = (h # l1')" "l2 = l2a @ [h] @ l2b" "subseq l1 l2" "\<not>(ListMem h l2a)"
  shows "subseq l1 (h # l2b)"
  using assms
proof (induction l2a arbitrary: l1 l2 h l1')
  case Nil
  then have "l2 = h # l2b"
    by fastforce
  then show ?case using Nil.prems(3)
    by blast
next
  case (Cons a l2a)
  have "a \<noteq> h"
    using Cons.prems(4) ListMem.simps
    by fast
  then have "subseq l1 (l2a @ [h] @ l2b)"
    using Cons.prems(1, 2, 3) subseq_Cons2_neq
    by force
  moreover have "\<not>ListMem h l2a"
    using Cons.prems(4) insert
    by metis
  ultimately have "subseq l1 (h # l2b)"
    using Cons.IH Cons.prems
    by meson
  then show ?case
    by simp
qed

\<comment> \<open>NOTE added lemma (eventually wasn't needed in the remaining proofs).\<close>
lemma sublist_split_trans:
  fixes l1 l2 h l1'
  assumes "l1 = (h # l1')" "l2 = l2a @ [h] @ l2b" "subseq l1 l2" "\<not>(ListMem h l2a)"
  shows "subseq l1' l2b"
proof -
  have "subseq (h # l1') (h # l2b)"
    using assms sublist_skip
    by metis
  then show ?thesis
    using subseq_Cons2'
    by metis
qed

lemma sublist_cons_exists:
  shows "
    subseq (h # l1) l2
    \<longleftrightarrow> (\<exists>l2a l2b. (l2 = l2a @ [h] @ l2b) \<and> \<not>ListMem h l2a \<and> subseq l1 l2b)
  "
proof -
  \<comment> \<open>NOTE show both directions of the equivalence in pure proof blocks.\<close>
  {
    have
      "subseq (h # l1) l2 \<Longrightarrow> (\<exists>l2a l2b. (l2 = l2a @ [h] @ l2b) \<and> \<not>ListMem h l2a \<and> subseq l1 l2b)"
    proof (induction l2 arbitrary: h l1)
      case (Cons a l2)
      show ?case
      proof (cases "a = h")
        case True
          \<comment> \<open>NOTE This case has a trivial solution in '?l2a = []', '?l2b = l2'.\<close>
        let ?l2a="[]"
        have "(a # l2) = ?l2a @ [h] @ l2"
          using True
          by auto
        moreover have "\<not>(ListMem h ?l2a)"
          using ListMem_iff
          by force
        moreover have "subseq l1 l2"
          using Cons.prems True
          by simp
        ultimately show ?thesis
          by blast
      next
        case False
        have 1: "subseq (h # l1) l2"
          using Cons.prems False subseq_Cons2_neq
          by metis
        then obtain l2a l2b where "l2 = l2a @ [h] @ l2b" "\<not>ListMem h l2a"
          using Cons.IH Cons.prems
          by meson
        moreover have "a # l2 = (a # l2a) @ [h] @ l2b"
          using calculation(1)
          by simp
        moreover have "\<not>(ListMem h (a # l2a))"
          using False calculation(2) ListMem.simps
          by fastforce
        ultimately show ?thesis
          using 1 sublist_split_trans
          by metis
      qed
    qed simp
  }
  moreover
  {
    assume "\<exists>l2a l2b. (l2 = l2a @ [h] @ l2b) \<and> \<not>ListMem h l2a \<and> subseq l1 l2b"
    then have  "subseq (h # l1) l2"
      by auto
  }
  ultimately show ?thesis
    by argo
qed

lemma sublist_append_exists:
  fixes l1 l2
  shows "subseq (l1 @ l2) l3 \<Longrightarrow> \<exists>l3a l3b. (l3 = l3a @ l3b) \<and> subseq l1 l3a \<and> subseq l2 l3b"
  using list_emb_appendD
  by fast

\<comment> \<open>NOTE can be solved directly with 'list\_emb\_append\_mono'.\<close>
lemma sublist_append_both_I:
  assumes "subseq a b" "subseq c d"
  shows "subseq (a @ c) (b @ d)"
  using assms list_emb_append_mono
  by blast

lemma sublist_append:
  assumes "subseq l1 l1'" "subseq l2 l2'"
  shows "subseq (l1 @ l2) (l1' @ l2')"
  using assms sublist_append_both_I
  by blast

lemma sublist_append2:
  assumes "subseq l1 l2"
  shows "subseq l1 (l2 @ l3)"
  using assms sublist_append[of "l1" "l2" "[]" "l3"]
  by fast

lemma append_sublist:
  shows "subseq (l1 @ l2 @ l3) l \<Longrightarrow> subseq (l1 @ l3) l"
proof (induction l)
  case Nil
  then show ?case
    using sublist_NIL
    by fastforce
next
  case (Cons a l)
  then show ?case
  proof (cases l1)
    case Nil
    then show ?thesis
      using Cons.prems append_sublist_1
      by auto
  next
    case (Cons a list)
    then show ?thesis
      using Cons.prems subseq_append' subseq_order.dual_order.trans
      by blast
  qed
qed

lemma sublist_subset:
  assumes "subseq l1 l2"
  shows "set l1 \<subseteq> set l2"
  using assms set_nths_subset subseq_conv_nths
  by metis

lemma sublist_filter:
  fixes P l
  shows "subseq (filter P l) l"
  using subseq_filter_left
  by blast

lemma sublist_cons_2:
  fixes l1 l2 h
  shows "(subseq (h # l1) (h # l2) \<longleftrightarrow> (subseq l1 l2))"
  by fastforce

lemma sublist_every:
  fixes l1 l2 P
  assumes "(subseq l1 l2 \<and> list_all P l2)"
  shows "list_all P l1"
  by (metis (full_types) Ball_set assms list_emb_set)

lemma sublist_SING_MEM: "subseq [h] l \<longleftrightarrow> ListMem h l"
  using ListMem_iff subseq_singleton_left
  by metis

\<comment> \<open>NOTE renamed due to previous declaration of `sublist\_append\_exists\_2.\<close>
lemma sublist_append_exists_2:
  fixes l1 l2 l3
  assumes "subseq (h # l1) l2"
  shows "(\<exists>l3 l4. (l2 = l3 @ [h] @ l4) \<and> (subseq l1 l4))"
  using assms sublist_cons_exists
  by metis

lemma sublist_append_4:
  fixes l l1 l2 h
  assumes "(subseq (h # l) (l1 @ [h] @ l2))" "(list_all (\<lambda>x. \<not>(h = x)) l1)"
  shows "subseq l l2"
  using assms
proof (induction l1)
qed auto

lemma sublist_append_5:
  fixes l l1 l2 h
  assumes "(subseq (h # l) (l1 @ l2))" "(list_all (\<lambda>x. \<not>(h = x)) l1)"
  shows "subseq (h # l) l2"
  using assms
proof (induction l1)
qed auto

lemma sublist_append_6:
  fixes l l1 l2 h
  assumes "(subseq (h # l) (l1 @ l2))" "(\<not>(ListMem h l1))"
  shows "subseq (h # l) l2"
  using assms
proof (induction l1)
  case (Cons a l1)
  then show ?case
    by (simp add: ListMem_iff)
qed simp

lemma sublist_MEM:
  fixes h l1 l2
  shows "subseq (h # l1) l2 \<Longrightarrow> ListMem h l2"
proof (induction l2)
next
  case (Cons a l2)
  then show ?case
    using elem insert subseq_Cons2_neq
    by metis
qed simp

lemma sublist_cons_4:
  fixes l h l'
  shows "subseq l l' \<Longrightarrow> subseq l (h # l')"
  using sublist_cons
  by blast

subsection "Main Theorems"

theorem sublist_imp_len_filter_le:
  fixes P l l'
  assumes "subseq l' l"
  shows "length (filter P l') \<le> length (filter P l)"
  using assms
  by (simp add: sublist_length)

\<comment> \<open>TODO showcase (non-trivial proof translation/ obscurity).\<close>
theorem list_with_three_types_shorten_type2:
  fixes P1 P2 P3 k1 f PProbs PProbl s l
  assumes "(PProbs s)" "(PProbl l)"
    "(\<forall>l s.
      (PProbs s)
      \<and> (PProbl l)
      \<and> (list_all P1 l)
      \<longrightarrow> (\<exists>l'.
          (f s l' = f s l)
          \<and> (length (filter P2 l') \<le> k1)
          \<and> (length (filter P3 l') \<le> length (filter P3 l))
          \<and> (list_all P1 l')
          \<and> (subseq l' l)
      )
    )"
    "(\<forall>s l1 l2. f (f s l1) l2 = f s (l1 @ l2))"
    "(\<forall>s l. (PProbs s) \<and> (PProbl l) \<longrightarrow> (PProbs (f s l)))"
    "(\<forall>l1 l2. (subseq l1 l2) \<and> (PProbl l2) \<longrightarrow> (PProbl l1))"
    "(\<forall>l1 l2. PProbl (l1 @ l2) \<longleftrightarrow> (PProbl l1 \<and> PProbl l2))"
  shows "(\<exists>l'.
    (f s l' = f s l)
    \<and> (length (filter P3 l') \<le> length (filter P3 l))
    \<and> (\<forall>l''.
      (sublist l'' l') \<and> (list_all P1 l'')
       \<longrightarrow> (length (filter P2 l'') \<le> k1)
    )
    \<and> (subseq l' l)
  )"
  using assms
proof (induction "filter (\<lambda>x. \<not>P1 x) l" arbitrary: P1 P2 P3 k1 f PProbs PProbl s l)
  case Nil
  then have "list_all (\<lambda>x. P1 x) l"
    using Nil(1) filter_empty_every_not[of "\<lambda>x. \<not>P1 x" l]
    by presburger
  then obtain l' where 1:
    "(f s l' = f s l)" "length (filter P2 l') \<le> k1" "length (filter P3 l') \<le> length (filter P3 l)"
    "list_all P1 l'" "subseq l' l"
    using Nil.prems(1, 2, 3)
    by blast
  moreover {
    fix l''
    assume "sublist l'' l'" "list_all P1 l''"
    then have "subseq l'' l'"
      by blast
        \<comment> \<open>NOTE original proof uses `frag\_len\_filter\_le` which however requires the fact
      `sublist l' ?l`. Unfortunately, this could not be derived in Isabelle/HOL.\<close>
    then have "length (filter P2 l'') \<le> length (filter P2 l')"
      using sublist_imp_len_filter_le
      by blast
    then have "length (filter P2 l'') \<le> k1"
      using 1
      by linarith
  }
  ultimately show ?case
    by blast
next
  case (Cons a x)
    \<comment> \<open>NOTE The proof of the induction step basically consists of construction a list
    `?l'=l'' @ [a] @ l'''` where `l''` and `l'''` are lists obtained from certain specifications
    of the induction hypothesis.\<close>
  then obtain l1 l2 where 2:
    "l = l1 @ a # l2" "(\<forall>u\<in>set l1. P1 u)" "\<not> P1 a \<and> x = [x\<leftarrow>l2 . \<not> P1 x]"
    using Cons(2) filter_eq_Cons_iff[of "\<lambda>x. \<not>P1 x"]
    by metis
  then have 3: "PProbl l2"
    using Cons.prems(2, 6) 2(1) sublist_append_back
    by blast
      \<comment> \<open>NOTE Use the induction hypothesis to obtain a specific  `l'''`.\<close>
  {
    have "x = filter (\<lambda>x. \<not>P1 x) l2"
      using 2(3)
      by blast
    moreover have "PProbs (f (f s l1) [a])"
      using Cons.prems(1, 2, 5, 6, 7) 2(1) elem sublist_SING_MEM
      by metis
    moreover have "\<forall>l s. PProbs s \<and> PProbl l \<and> list_all P1 l \<longrightarrow> (\<exists>l'.
      f s l' = f s l \<and> length (filter P2 l') \<le> k1 \<and> length (filter P3 l') \<le> length (filter P3 l)
      \<and> list_all P1 l' \<and> subseq l' l)"
      using Cons.prems(3)
      by blast
    moreover have "\<forall>s l1 l2. f (f s l1) l2 = f s (l1 @ l2)"
      "\<forall>s l. PProbs s \<and> PProbl l \<longrightarrow> PProbs (f s l)"
      "\<forall>l1 l2. subseq l1 l2 \<and> PProbl l2 \<longrightarrow> PProbl l1"
      "\<forall>l1 l2. PProbl (l1 @ l2) = (PProbl l1 \<and> PProbl l2)"
      using Cons.prems(4, 5, 6, 7)
      by blast+
    ultimately have "\<exists>l'.
      f (f (f s l1) [a]) l' = f (f (f s l1) [a]) l2 \<and> length (filter P3 l') \<le> length (filter P3 l2)
      \<and> (\<forall>l''. sublist l'' l' \<and> list_all P1 l'' \<longrightarrow> length (filter P2 l'') \<le> k1) \<and> subseq l' l2"
      using 3 Cons(1)[of P1 l2, where s="(f (f s l1) [a])"]
      by blast
  }
  then obtain l''' where 4:
    "f (f (f s l1) [a]) l''' = f (f (f s l1) [a]) l2"
    "length (filter P3 l''') \<le> length (filter P3 l2)"
    "(\<forall>l''. sublist l'' l''' \<and> list_all P1 l'' \<longrightarrow> length (filter P2 l'') \<le> k1) \<and> subseq l''' l2"
    by blast
  then have "f s (l1 @ [a] @ l''') = f s (l1 @ [a] @ l2)"
    using Cons.prems(4)
    by auto
  then have "subseq l''' l2"
    using 4(3)
    by blast
      \<comment> \<open>NOTE Use the induction hypothesis to obtain a specific  `l''`.\<close>
  {
    have "\<forall>l s.
        PProbs s \<and> PProbl l1 \<and> list_all P1 l1
        \<longrightarrow> (\<exists>l''.
          f s l'' = f s l1 \<and> length (filter P2 l'') \<le> k1 \<and> length (filter P3 l'') \<le> length (filter P3 l1)
          \<and> list_all P1 l'' \<and> subseq l'' l1)"
      using Cons.prems(3)
      by blast
    then have "\<exists>l''.
        f s l'' = f s l1 \<and> length (filter P2 l'') \<le> k1 \<and> length (filter P3 l'') \<le> length (filter P3 l1)
        \<and> list_all P1 l'' \<and> subseq l'' l1"
      using Cons.prems(1, 2, 7) 2(1, 2)
      by (metis Ball_set)
  }

  then obtain l'' where 5:
    "f s l'' = f s l1" "length (filter P2 l'') \<le> k1"
    "length (filter P3 l'') \<le> length (filter P3 l1)" "list_all P1 l'' \<and> subseq l'' l1"
    by blast
  text \<open> Proof the proposition by providing the witness @{term "l'=(l'' @ [a] @ l''')"}. \<close>
  let ?l'="(l'' @ [a] @ l''') "
  {
    have "\<forall>s l1 l2. f (f s l1) l2 = f s (l1 @ l2)"
      by (simp add: Cons.prems(4))
    text \<open> Rewrite and show the goal.\<close>
    have "f s ?l' = f s (l1 @ [a] @ l2) \<longleftrightarrow> f s (l'' @ (a # l''')) = f s (l1 @ (a # l2))"
      by simp
    also have "\<dots> \<longleftrightarrow> f (f (f s l1) [a]) l''' = f (f (f s l1) [a]) l2"
      by (metis Cons.prems(4) \<open>f s l'' = f s l1\<close> calculation)
    finally have "f s ?l' = f s (l1 @ [a] @ l2)"
      using 4(1)
      by blast
  }
  moreover
  {
    have "
      length (filter P3 ?l') \<le> length (filter P3 (l1 @ [a] @ l2))
      \<longleftrightarrow>
        (length (filter P3 l'') + 1 + length (filter P3 l''')
        \<le> length (filter P3 l1) + 1 + length (filter P3 l2))"
      by force
    then have "
      length (filter P3 ?l') \<le> length (filter P3 (l1 @ [a] @ l2))
      \<longleftrightarrow>
        length (filter P3 l'') + length (filter P3 l''')
        \<le> length (filter P3 l1) + length (filter P3 l2)"
      by linarith
    then have "length (filter P3 ?l') \<le> length (filter P3 (l1 @ [a] @ l2))"
      using 4(2) \<open>length (filter P3 l'') \<le> length (filter P3 l1)\<close>
        add_mono_thms_linordered_semiring(1)
      by blast
  }
  moreover
  {
    fix l''''
    assume P: "sublist l'''' ?l'" "list_all P1 l''''"
    have "list_all P1 l1"
      using 2(2) Ball_set
      by blast
    consider (i) "sublist l'''' l''" | (ii) "sublist l'''' l'''"
      using P(1, 2) 2(3)  LIST_FRAG_DICHOTOMY_2
      by metis
    then have "length (filter P2 l'''') \<le> k1"
    proof (cases)
      case i
      then have "length (filter P2 l'''') \<le> length (filter P2 l'')"
        using frag_len_filter_le
        by blast
      then show ?thesis
        using 5(2) order_trans
        by blast
    next
      case ii
      then show ?thesis
        using 4(3) P(2)
        by blast
    qed
  }
    \<comment> \<open>NOTE the following two steps seem to be necessary to convince Isabelle that the split
  @{term "l = l1 @ a # l2"} matches the split `(l1 @ [a] @ l2` and the previous proof steps therefore is
  prove the goal.\<close>
  moreover {
    have "subseq ?l' (l1 @ [a] @ l2)"
      by (simp add: FSSublist.sublist_append \<open>list_all P1 l'' \<and> subseq l'' l1\<close> \<open>subseq l''' l2\<close>)
  }
  moreover have "l = l1 @ [a] @ l2"
    using 2
    by force
  ultimately show ?case
    by blast
qed

lemma isPREFIX_sublist:
  fixes x y
  assumes "prefix x y"
  shows "subseq x y"
  using assms prefix_order.dual_order.antisym
  by blast

end


(* Title: Binary Modalities
   Author: Brijesh Dongol, Victor Gomes, Ian J Hayes, Georg Struth
   Maintainer: Victor Gomes <victor.gomes@cl.cam.ac.uk>
               Georg Struth <g.struth@sheffield.ac.uk>
*)

section \<open>Binary Modalities and Relational Convolution\<close>

theory Binary_Modalities
  imports Quantales

begin

subsection \<open>Auxiliary Properties\<close>

lemma SUP_is_Sup: "(SUP f:F. f y) = \<Squnion>{(f::'a \<Rightarrow> 'b::proto_near_quantale) y |f. f \<in> F}"
proof (rule antisym)
  fix f::"'a \<Rightarrow> 'b::proto_near_quantale"
  have "f \<in> F \<Longrightarrow> f y \<in> {f y |f. f \<in> F}"
    by (simp add: Setcompr_eq_image)
  hence "f \<in> F \<Longrightarrow> f y \<le> \<Squnion>{f y |f. f \<in> F}"
    by (simp add: Sup_upper)
  thus "(SUP f:F. f y) \<le> \<Squnion>{(f::'a \<Rightarrow> 'b::proto_near_quantale) y |f. f \<in> F}"
    by (simp add: Setcompr_eq_image)
next
  fix x
  have "x \<in> {f y |f. f \<in> F} \<Longrightarrow> x \<le> (SUP f:F. f y) "
    using mk_disjoint_insert by force
  thus "Sup {(f::'a \<Rightarrow> 'b::proto_near_quantale) y |f. f \<in> F} \<le> (SUP f:F. f y)"
    by (simp add: Setcompr_eq_image)
qed

lemma bmod_auxl: "{x \<cdot> g z |x. \<exists>f. x = f y \<and> f \<in> F} = {f y \<cdot> g z |f. f \<in> F}"
  by force

lemma bmod_auxr: "{f y \<cdot> x |x. \<exists>g. x = g z \<and> g \<in> G} = {f y \<cdot> g z |g. g \<in> G}"
  by force

lemma bmod_assoc_aux1:
  "\<Squnion>{\<Squnion>{(f :: 'a \<Rightarrow> 'b::proto_near_quantale) u \<cdot> g v \<cdot> h w |u v. R y u v} |y w. R x y w}
     = \<Squnion>{(f u \<cdot> g v) \<cdot> h w |u v y w. R y u v \<and> R x y w}"
  apply (rule antisym)
  apply (rule Sup_least, safe)
  apply (intro Sup_least Sup_upper, force)
  apply (rule Sup_least, safe)
  by (rule Sup_upper2, auto)+

lemma bmod_assoc_aux2:
  "\<Squnion>{\<Squnion>{(f::'a \<Rightarrow> 'b::proto_near_quantale) u \<cdot> g v \<cdot> h w |v w. R y v w} |u y. R x u y}
     = \<Squnion>{f u \<cdot> g v \<cdot> h w |u v w y. R y v w \<and> R x u y}"
  apply (rule antisym)
  apply (rule Sup_least, safe)
  apply (intro Sup_least Sup_upper, force)
  apply (rule Sup_least, safe)
  by (rule Sup_upper2, auto)+

subsection \<open>Binary Modalities\<close>

text \<open>Most of the development in the papers mentioned in the introduction generalises to proto-near-quantales. Binary modalities
are interesting for various substructural logics over ternary Kripke frames. They also arise, e.g.,
as chop modalities in interval logics or as separation conjunction in separation logic. Binary modalities can be understood as a convolution
operation parametrised by a ternary operation. Our development yields a
unifying framework.\<close>

text \<open>We would prefer a notation that is more similar to our articles, that is, $f\ast_R g$, but we don' know how we could
index an infix operator by a variable in Isabelle.\<close>

definition bmod_comp :: "('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'd::proto_near_quantale) \<Rightarrow> ('c \<Rightarrow> 'd) \<Rightarrow> 'a \<Rightarrow> 'd" ("\<otimes>") where
  "\<otimes> R f g x = \<Squnion>{f y \<cdot> g z |y z. R x y z}"

definition bmod_bres :: "('c \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'd::proto_near_quantale) \<Rightarrow> ('c \<Rightarrow> 'd) \<Rightarrow> 'a \<Rightarrow> 'd" ("\<lhd>") where
  "\<lhd> R f g x = \<Sqinter>{(f y) \<rightarrow> (g z) |y z. R z y x}"

definition bmod_fres :: "('b \<Rightarrow> 'a \<Rightarrow> 'c \<Rightarrow> bool)  \<Rightarrow> ('b \<Rightarrow> 'd::proto_near_quantale) \<Rightarrow> ('c \<Rightarrow> 'd) \<Rightarrow> 'a \<Rightarrow> 'd" ("\<rhd>")where
  "\<rhd> R f g x = \<Sqinter>{(f y) \<leftarrow> (g z) |y z. R y x z}"

lemma bmod_un_rel: "\<otimes> (R \<squnion> S) = \<otimes> R \<squnion> \<otimes> S"
  apply  (clarsimp simp: fun_eq_iff bmod_comp_def Sup_union_distrib[symmetric] Collect_disj_eq[symmetric])
  by (metis (no_types, lifting))

lemma bmod_Un_rel: "\<otimes> (\<Squnion>\<R>) f g x = \<Squnion>{\<otimes> R f g x |R. R \<in> \<R>}"
  apply (simp add: bmod_comp_def)
  apply (rule antisym)
  apply (rule Sup_least, safe)
  apply (rule Sup_upper2, force)
  apply (rule Sup_upper, force)
  apply (rule Sup_least, safe)+
  by (metis (mono_tags, lifting) Sup_upper mem_Collect_eq)

lemma bmod_sup_fun1: "\<otimes> R (f \<squnion> g) = \<otimes> R f \<squnion> \<otimes> R g"
  apply (clarsimp simp add: fun_eq_iff bmod_comp_def sup_distr)
  apply (rule antisym)
  apply (intro Sup_least, safe)
  apply (rule sup_least)
  apply (intro le_supI1 Sup_upper, force)
  apply (intro le_supI2 Sup_upper, force)
  apply (rule sup_least)
  by (intro Sup_least, safe, rule Sup_upper2, force, simp)+

lemma bmod_Sup_fun1: "\<otimes> R (\<Squnion>\<F>) g x = \<Squnion>{\<otimes> R f g x |f. f \<in> \<F>}"
proof -
  have "\<otimes> R (\<Squnion>{f. f \<in> \<F>}) g x = \<Squnion>{\<Squnion>{f y |f. f \<in> \<F>} \<cdot> g z |y z. R x y z}"
    by (simp add: bmod_comp_def SUP_is_Sup)
  also have "... = \<Squnion>{\<Squnion>{f y \<cdot> g z |f. f \<in> \<F>} |y z. R x y z}"
    by (simp add: Sup_distr bmod_auxl)
  also have "... = \<Squnion>{\<Squnion>{f y \<cdot> g z |y z. R x y z} |f. f \<in> \<F>}"
    apply (rule antisym)
    by ((rule Sup_least, safe)+ , (rule Sup_upper2, force, rule Sup_upper, force))+
  finally show ?thesis
    by (simp add: bmod_comp_def)
qed

lemma bmod_comp_bres_galois: "(\<forall>x. \<otimes> R f g x \<le> h x) \<longleftrightarrow> (\<forall>x. g x \<le> \<lhd> R f h x)" (* nitpick[expect=genuine] *)
  oops

text \<open>The following Galois connection requires functions into proto-quantales.\<close>

lemma bmod_comp_bres_galois: "(\<forall>x. \<otimes> R (f::'a \<Rightarrow> 'b::proto_quantale) g x \<le> h x) \<longleftrightarrow> (\<forall>x. g x \<le> \<lhd> R f h x)"
proof -
  have "(\<forall>x. \<otimes> R f g x \<le> h x) \<longleftrightarrow> (\<forall>x y z. R x y z \<longrightarrow> (f y) \<cdot> (g z) \<le> h x)"
    apply (simp add: bmod_comp_def, standard, safe)
    apply (metis (mono_tags, lifting) CollectI Sup_le_iff)
    by (rule Sup_least, force)
  also have "... \<longleftrightarrow>  (\<forall>x y z. R x y z \<longrightarrow> g z \<le> (f y) \<rightarrow> (h x))"
    by (simp add: bres_galois)
  finally show ?thesis
    apply (simp add: fun_eq_iff bmod_bres_def)
    apply standard
    using le_Inf_iff apply fastforce
    by (metis (mono_tags, lifting) CollectI le_Inf_iff)
qed

lemma bmod_comp_fres_galois: "(\<forall>x. \<otimes> R f g x \<le> h x) \<longleftrightarrow> (\<forall>x. f x \<le> \<rhd> R h g x)"
proof -
  have "(\<forall>x. \<otimes> R f g x \<le> h x) \<longleftrightarrow> (\<forall>x y z. R x y z \<longrightarrow> (f y) \<cdot> (g z) \<le> h x)"
    apply (simp add: bmod_comp_def, standard, safe)
    apply (metis (mono_tags, lifting) CollectI Sup_le_iff)
    by (rule Sup_least, force)
  also have "... \<longleftrightarrow>  (\<forall>x y z. R x y z \<longrightarrow> f y \<le> (h x) \<leftarrow> (g z))"
    by (simp add: fres_galois)
  finally show ?thesis
    apply (simp add: bmod_fres_def fun_eq_iff)
    apply standard
    using le_Inf_iff apply fastforce
    by (metis (mono_tags, lifting) CollectI le_Inf_iff)
qed

subsection \<open>Relational Convolution and Correspondence Theory\<close>

text\<open>We now fix a ternary relation $\rho$ and can then hide the parameter in a convolution-style notation.\<close>

class rel_magma =
  fixes \<rho> :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"

begin

definition times_rel_fun :: "('a \<Rightarrow> 'b::proto_near_quantale) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" (infix "\<star>" 70) where
  "f \<star> g = \<otimes> \<rho> f g"

lemma rel_fun_Sup_distl_weak:
  "G \<noteq> {} \<Longrightarrow> (f::'a \<Rightarrow> 'b::weak_proto_quantale) \<star> \<Squnion>G = \<Squnion>{f \<star> g |g. g \<in> G}"
proof-
  fix f :: "'a \<Rightarrow> 'b" and G :: "('a \<Rightarrow> 'b) set"
  assume a: "G \<noteq> {}"
  show "f \<star> \<Squnion>G = \<Squnion>{f \<star> g |g. g \<in> G}"
    apply (clarsimp simp: fun_eq_iff times_rel_fun_def bmod_Sup_fun2_weak[OF a])
    apply (rule antisym)
    apply (rule Sup_least, safe)
    apply (rule SUP_upper2, force+)
    apply (rule SUP_least, safe)
    by (rule Sup_upper2, force+)
qed

lemma rel_fun_Sup_distr: "\<Squnion>G \<star> (f::'a \<Rightarrow> 'b::proto_near_quantale) = \<Squnion>{g \<star> f |g. g \<in> G}"
  apply (clarsimp simp: fun_eq_iff times_rel_fun_def bmod_Sup_fun1)
  apply (rule antisym)
  apply (rule Sup_least, safe)
  apply (rule SUP_upper2, force+)
  apply (rule SUP_least, safe)
  by (rule Sup_upper2, force+)

end

class rel_semigroup = rel_magma +
  assumes rel_assoc: "(\<exists>y. \<rho> y u v \<and> \<rho> x y w) \<longleftrightarrow> (\<exists>z. \<rho> z v w \<and> \<rho> x u z)"

begin

text \<open>Nitpick produces counterexamples even for weak quantales.
Hence one cannot generally lift functions into weak quantales to weak quantales.\<close>

lemma bmod_assoc: "\<otimes> \<rho> (\<otimes> \<rho> (f::'a \<Rightarrow> 'b::weak_quantale) g) h x = \<otimes> \<rho> f (\<otimes> \<rho> g h) x"
  (*nitpick[show_all,expect=genuine]*)
    oops

lemma bmod_assoc: "\<otimes> \<rho> (\<otimes> \<rho> (f::'a \<Rightarrow> 'b::quantale) g) h x = \<otimes> \<rho> f (\<otimes> \<rho> g h) x"
proof -
  have "\<otimes> \<rho> (\<otimes> \<rho> f g) h x = \<Squnion>{\<Squnion>{f u \<cdot> g v \<cdot> h z |u v. \<rho> y u v} |y z. \<rho> x y z}"
    apply (simp add: bmod_comp_def Sup_distr)
    apply (rule antisym)
    by (intro Sup_least Sup_upper, safe, intro exI conjI, simp_all, rule_tac f = Sup and g = Sup in cong, auto)+
  also have "... = \<Squnion>{f u \<cdot> g v \<cdot> h z |u v y z. \<rho> y u v \<and> \<rho> x y z}"
    by (simp add: bmod_assoc_aux1)
  also have "... = \<Squnion>{f u \<cdot> g v \<cdot> h z |u v z y. \<rho> y v z \<and> \<rho> x u y}"
    apply (rule antisym)
    apply (rule Sup_least, rule Sup_upper, safe)
    using rel_assoc apply force
    apply (rule Sup_least, rule Sup_upper, safe)
    using rel_assoc by blast
  also have "... = \<Squnion>{\<Squnion>{f u \<cdot> g v \<cdot> h z |v z. \<rho> y v z} |u y. \<rho> x u y}"
    by (simp add: bmod_assoc_aux2)
  also have "... = \<Squnion>{f u \<cdot> \<Squnion>{g v \<cdot> h z |v z. \<rho> y v z} |u y. \<rho> x u y}"
    apply (simp add: Sup_distl mult.assoc)
    apply (rule antisym)
    by (intro Sup_least Sup_upper, safe, intro exI conjI, simp_all, rule_tac f = Sup and g = Sup in cong, auto)+
  finally show ?thesis
    by (auto simp: bmod_comp_def)
qed

lemma rel_fun_assoc: "((f :: 'a \<Rightarrow> 'b::quantale) \<star> g) \<star> h = f \<star> (g \<star> h)"
  by (simp add: times_rel_fun_def fun_eq_iff bmod_assoc[symmetric])

end

lemma "\<otimes> R (\<otimes> R f f) f x = \<otimes> R f (\<otimes> R f f) x"
(*apply (simp add: bmod_comp_def) nitpick[expect=genuine] *)
oops

class rel_monoid = rel_semigroup +
  fixes \<xi> :: "'a set"
  assumes unitl_ex: "\<exists>e \<in> \<xi>. \<rho> x e x"
  and unitr_ex: "\<exists>e \<in> \<xi>. \<rho> x x e"
  and unitl_eq: "e \<in> \<xi> \<Longrightarrow> \<rho> x e y \<Longrightarrow> x = y"
  and unitr_eq: "e \<in> \<xi> \<Longrightarrow> \<rho> x y e \<Longrightarrow> x = y"

begin

lemma xi_prop: "e1 \<in> \<xi> \<Longrightarrow> e2 \<in> \<xi> \<Longrightarrow> e1 \<noteq> e2 \<Longrightarrow> \<not> \<rho> x e1 e2 \<and> \<not> \<rho> x e2 e1"
  using unitl_eq unitr_eq by blast

definition pid :: "'a  \<Rightarrow> 'b::unital_weak_quantale" ("\<delta>") where
  "\<delta> x = (if x \<in> \<xi> then 1 else \<bottom>)"

text \<open>Due to the absence of right annihilation, the right unit law fails for functions into weak quantales.\<close>

lemma bmod_onel: "\<otimes> \<rho> f (\<delta>::'a \<Rightarrow> 'b::unital_weak_quantale) x = f x"
(*nitpick[expect=genuine]*)
  oops

text \<open>A unital quantale is required for this lifting.\<close>

lemma bmod_onel: "\<otimes> \<rho> f (\<delta>::'a \<Rightarrow> 'b::unital_quantale) x = f x"
  apply (simp add: bmod_comp_def pid_def)
  apply (rule antisym)
  apply (rule Sup_least, safe)
  apply (simp add: bres_galois)
  using unitr_eq apply fastforce
  apply (metis bot.extremum)
  by (metis (mono_tags, lifting) Sup_upper mem_Collect_eq unitr_ex)

lemma  bmod_oner: "\<otimes> \<rho> \<delta> f x = f x"
  apply (simp add: bmod_comp_def pid_def)
  apply (rule antisym)
  apply (rule Sup_least, safe)
  apply (simp add: fres_galois)
  using unitl_eq apply fastforce
  apply (metis bot.extremum)
  by (metis (mono_tags, lifting) Sup_upper mem_Collect_eq unitl_ex)

lemma [simp]: "f \<star> (\<delta>::'a \<Rightarrow> 'b::unital_quantale) = f"
  by (simp add: fun_eq_iff times_rel_fun_def bmod_onel)

lemma bmod_assoc_weak_aux:
  "f u \<cdot> \<Squnion>{g v \<cdot> h z |v z. \<rho> y v z} = \<Squnion>{(f::'a \<Rightarrow> 'b::weak_quantale) u \<cdot> g v \<cdot> h z |v z. \<rho> y v z}"
  apply (subst weak_Sup_distl)
  using unitl_ex apply force
  apply simp
  by (metis (no_types, lifting) mult.assoc)

lemma bmod_assoc_weak: "\<otimes> \<rho> (\<otimes> \<rho> (f::'a \<Rightarrow> 'b::weak_quantale) g) h x = \<otimes> \<rho> f (\<otimes> \<rho> g h) x"
proof -
  have "\<otimes> \<rho> (\<otimes> \<rho> f g) h x = \<Squnion>{\<Squnion>{f u \<cdot> g v \<cdot> h z |u v. \<rho> y u v} |y z. \<rho> x y z}"
    apply (simp add: bmod_comp_def Sup_distr)
    apply (rule antisym)
    by (intro Sup_least Sup_upper, safe, intro exI conjI, simp_all, rule_tac f = Sup and g = Sup in cong, auto)+
  also have "... = \<Squnion>{f u \<cdot> g v \<cdot> h z |u v y z. \<rho> y u v \<and> \<rho> x y z}"
    by (simp add: bmod_assoc_aux1)
  also have "... = \<Squnion>{f u \<cdot> g v \<cdot> h z |u v z y. \<rho> y v z \<and> \<rho> x u y}"
    apply (rule antisym)
    apply (rule Sup_least, rule Sup_upper, safe)
    using rel_assoc apply force
    apply (rule Sup_least, rule Sup_upper, safe)
    using rel_assoc by blast
  also have "... = \<Squnion>{\<Squnion>{f u \<cdot> g v \<cdot> h z |v z. \<rho> y v z} |u y. \<rho> x u y}"
    by (simp add: bmod_assoc_aux2)
  also have "... = \<Squnion>{f u \<cdot> \<Squnion>{g v \<cdot> h z |v z. \<rho> y v z} |u y. \<rho> x u y}"
    by (simp add: bmod_assoc_weak_aux)
  finally show ?thesis
    by (auto simp: bmod_comp_def)
qed

lemma rel_fun_assoc_weak: "((f :: 'a \<Rightarrow> 'b::weak_quantale) \<star> g) \<star> h = f \<star> (g \<star> h)"
  by (simp add: times_rel_fun_def fun_eq_iff bmod_assoc_weak[symmetric])

end

lemma (in rel_semigroup) "\<exists>id. \<forall>f x. (\<otimes> \<rho> f id x = f x \<and> \<otimes> \<rho> id f x = f x)"
(* apply (simp add: bmod_comp_def) nitpick [expect=genuine] *)
  oops

class rel_ab_semigroup = rel_semigroup +
  assumes rel_comm: "\<rho> x y z \<Longrightarrow>  \<rho> x z y"

begin

lemma bmod_comm: "\<otimes> \<rho> (f::'a \<Rightarrow> 'b::ab_quantale) g = \<otimes> \<rho> g f"
  by (simp add: fun_eq_iff bmod_comp_def mult.commute, meson rel_comm)

lemma "\<otimes> \<rho> f g = \<otimes> \<rho> g f" (* nitpick [expect=genuine] *)
oops

lemma bmod_bres_fres_eq: "\<lhd> \<rho> (f::'a \<Rightarrow> 'b::ab_quantale) g = \<rhd> \<rho> g f"
  by (simp add: fun_eq_iff bmod_bres_def bmod_fres_def bres_fres_eq, meson rel_comm)

lemma rel_fun_comm: "(f :: 'a \<Rightarrow> 'b::ab_quantale) \<star> g = g \<star> f"
  by (simp add: times_rel_fun_def bmod_comm)

end

class rel_ab_monoid = rel_ab_semigroup + rel_monoid

subsection \<open>Lifting to Function Spaces\<close>

text \<open>We lift by interpretation, since we need sort instantiations to be
     used for functions from PAM's to Quantales. Both instantiations cannot be
     used in Isabelle at the same time.\<close>

interpretation rel_fun: weak_proto_quantale Inf Sup inf less_eq less sup bot "top :: 'a::rel_magma \<Rightarrow> 'b::weak_proto_quantale" times_rel_fun
  by standard (simp_all add: rel_fun_Sup_distr rel_fun_Sup_distl_weak)

interpretation rel_fun: proto_quantale Inf Sup inf less_eq less sup bot "top :: 'a::rel_magma \<Rightarrow> 'b::proto_quantale" times_rel_fun
  by standard (simp add: rel_fun_Sup_distl)

text \<open>Nitpick shows that the lifting of weak quantales to weak quantales does not work for relational semigroups, because associativity fails.\<close>

interpretation rel_fun: weak_quantale times_rel_fun Inf Sup inf less_eq less sup bot "top::'a::rel_semigroup \<Rightarrow> 'b::weak_quantale"
  (*apply standard  nitpick[expect=genuine]*)
  oops

text \<open>Associativity is obtained when lifting from relational monoids, but the right unit law doesn't hold
 in the quantale on the function space, according to our above results. Hence the lifting results into a
non-unital quantale, in which only the left unit law holds, as shown above. We don't provide a special class for
such quantales. Hence we lift only to non-unital quantales.\<close>

interpretation rel_fun: weak_quantale times_rel_fun Inf Sup inf less_eq less sup bot "top::'a::rel_monoid \<Rightarrow> 'b::unital_weak_quantale"
  by standard (simp_all add: rel_fun_assoc_weak)

interpretation rel_fun2: quantale times_rel_fun Inf Sup inf less_eq less sup bot "top::'a::rel_semigroup \<Rightarrow> 'b::quantale"
  by standard (simp add: rel_fun_assoc)

interpretation rel_fun2: distrib_quantale Inf Sup inf less_eq less sup bot "top::'a::rel_semigroup \<Rightarrow> 'b::distrib_quantale" times_rel_fun ..

interpretation rel_fun2: bool_quantale Inf Sup inf less_eq less sup bot "top::'a::rel_semigroup \<Rightarrow> 'b::bool_quantale" minus uminus times_rel_fun ..

interpretation rel_fun2: unital_quantale pid times_rel_fun Inf Sup inf less_eq less sup bot "top::'a::rel_monoid \<Rightarrow> 'b::unital_quantale"
  by (standard; simp)

interpretation rel_fun2: distrib_unital_quantale Inf Sup inf less_eq less sup bot "top::'a::rel_monoid \<Rightarrow> 'b::distrib_unital_quantale" pid times_rel_fun ..

interpretation rel_fun2: bool_unital_quantale Inf Sup inf less_eq less sup bot "top::'a::rel_monoid \<Rightarrow> 'b::bool_unital_quantale" minus uminus pid times_rel_fun ..

interpretation rel_fun: ab_quantale times_rel_fun Inf Sup inf less_eq less sup bot "top::'a::rel_ab_semigroup \<Rightarrow> 'b::ab_quantale"
  by standard (simp add: rel_fun_comm)

interpretation rel_fun: ab_unital_quantale times_rel_fun Inf Sup inf less_eq less sup bot "top::'a::rel_ab_monoid \<Rightarrow> 'b::ab_unital_quantale" pid ..

interpretation rel_fun2: distrib_ab_unital_quantale Inf Sup inf less_eq less sup bot "top::'a::rel_ab_monoid \<Rightarrow> 'b::distrib_ab_unital_quantale" times_rel_fun pid ..

interpretation rel_fun2: bool_ab_unital_quantale times_rel_fun Inf Sup inf less_eq less sup bot "top::'a::rel_ab_monoid \<Rightarrow> 'b::bool_ab_unital_quantale" minus uminus pid ..

end


(*  Title:      HOL/Quickcheck_Examples/Quickcheck_Examples.thy
    Author:     Stefan Berghofer, Lukas Bulwahn
    Copyright   2004 - 2010 TU Muenchen
*)

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

theory Quickcheck_Examples
imports Complex_Main "HOL-Library.Dlist" "HOL-Library.DAList_Multiset"
begin

text \<open>
The 'quickcheck' command allows to find counterexamples by evaluating
formulae.
Currently, there are two different exploration schemes:
- random testing: this is incomplete, but explores the search space faster.
- exhaustive testing: this is complete, but increasing the depth leads to
  exponentially many assignments.

quickcheck can handle quantifiers on finite universes.

\<close>

declare [[quickcheck_timeout = 3600]]

subsection \<open>Lists\<close>

theorem "map g (map f xs) = map (g o f) xs"
  quickcheck[random, expect = no_counterexample]
  quickcheck[exhaustive, size = 3, expect = no_counterexample]
  oops

theorem "map g (map f xs) = map (f o g) xs"
  quickcheck[random, expect = counterexample]
  quickcheck[exhaustive, expect = counterexample]
  oops

theorem "rev (xs @ ys) = rev ys @ rev xs"
  quickcheck[random, expect = no_counterexample]
  quickcheck[exhaustive, expect = no_counterexample]
  quickcheck[exhaustive, size = 1000, timeout = 0.1]
  oops

theorem "rev (xs @ ys) = rev xs @ rev ys"
  quickcheck[random, expect = counterexample]
  quickcheck[exhaustive, expect = counterexample]
  oops

theorem "rev (rev xs) = xs"
  quickcheck[random, expect = no_counterexample]
  quickcheck[exhaustive, expect = no_counterexample]
  oops

theorem "rev xs = xs"
  quickcheck[tester = random, finite_types = true, report = false, expect = counterexample]
  quickcheck[tester = random, finite_types = false, report = false, expect = counterexample]
  quickcheck[tester = random, finite_types = true, report = true, expect = counterexample]
  quickcheck[tester = random, finite_types = false, report = true, expect = counterexample]
  quickcheck[tester = exhaustive, finite_types = true, expect = counterexample]
  quickcheck[tester = exhaustive, finite_types = false, expect = counterexample]
oops

text \<open>An example involving functions inside other data structures\<close>

primrec app :: "('a \<Rightarrow> 'a) list \<Rightarrow> 'a \<Rightarrow> 'a" where
  "app [] x = x"
  | "app (f # fs) x = app fs (f x)"

lemma "app (fs @ gs) x = app gs (app fs x)"
  quickcheck[random, expect = no_counterexample]
  quickcheck[exhaustive, size = 2, expect = no_counterexample]
  by (induct fs arbitrary: x) simp_all

lemma "app (fs @ gs) x = app fs (app gs x)"
  quickcheck[random, expect = counterexample]
  quickcheck[exhaustive, expect = counterexample]
  oops

primrec occurs :: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
  "occurs a [] = 0"
  | "occurs a (x#xs) = (if (x=a) then Suc(occurs a xs) else occurs a xs)"

primrec del1 :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "del1 a [] = []"
  | "del1 a (x#xs) = (if (x=a) then xs else (x#del1 a xs))"

text \<open>A lemma, you'd think to be true from our experience with delAll\<close>
lemma "Suc (occurs a (del1 a xs)) = occurs a xs"
  \<comment> \<open>Wrong. Precondition needed.\<close>
  quickcheck[random, expect = counterexample]
  quickcheck[exhaustive, expect = counterexample]
  oops

lemma "xs ~= [] \<longrightarrow> Suc (occurs a (del1 a xs)) = occurs a xs"
  quickcheck[random, expect = counterexample]
  quickcheck[exhaustive, expect = counterexample]
    \<comment> \<open>Also wrong.\<close>
  oops

lemma "0 < occurs a xs \<longrightarrow> Suc (occurs a (del1 a xs)) = occurs a xs"
  quickcheck[random, expect = no_counterexample]
  quickcheck[exhaustive, expect = no_counterexample]
  by (induct xs) auto

primrec replace :: "'a \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "replace a b [] = []"
  | "replace a b (x#xs) = (if (x=a) then (b#(replace a b xs))
                            else (x#(replace a b xs)))"

lemma "occurs a xs = occurs b (replace a b xs)"
  quickcheck[random, expect = counterexample]
  quickcheck[exhaustive, expect = counterexample]
  \<comment> \<open>Wrong. Precondition needed.\<close>
  oops

lemma "occurs b xs = 0 \<or> a=b \<longrightarrow> occurs a xs = occurs b (replace a b xs)"
  quickcheck[random, expect = no_counterexample]
  quickcheck[exhaustive, expect = no_counterexample]
  by (induct xs) simp_all

subsection \<open>Trees\<close>

datatype 'a tree = Twig |  Leaf 'a | Branch "'a tree" "'a tree"

primrec leaves :: "'a tree \<Rightarrow> 'a list" where
  "leaves Twig = []"
  | "leaves (Leaf a) = [a]"
  | "leaves (Branch l r) = (leaves l) @ (leaves r)"

primrec plant :: "'a list \<Rightarrow> 'a tree" where
  "plant [] = Twig "
  | "plant (x#xs) = Branch (Leaf x) (plant xs)"

primrec mirror :: "'a tree \<Rightarrow> 'a tree" where
  "mirror (Twig) = Twig "
  | "mirror (Leaf a) = Leaf a "
  | "mirror (Branch l r) = Branch (mirror r) (mirror l)"

theorem "plant (rev (leaves xt)) = mirror xt"
  quickcheck[random, expect = counterexample]
  quickcheck[exhaustive, expect = counterexample]
    \<comment> \<open>Wrong!\<close>
  oops

theorem "plant((leaves xt) @ (leaves yt)) = Branch xt yt"
  quickcheck[random, expect = counterexample]
  quickcheck[exhaustive, expect = counterexample]
    \<comment> \<open>Wrong!\<close>
  oops

datatype 'a ntree = Tip "'a" | Node "'a" "'a ntree" "'a ntree"

primrec inOrder :: "'a ntree \<Rightarrow> 'a list" where
  "inOrder (Tip a)= [a]"
  | "inOrder (Node f x y) = (inOrder x)@[f]@(inOrder y)"

primrec root :: "'a ntree \<Rightarrow> 'a" where
  "root (Tip a) = a"
  | "root (Node f x y) = f"

theorem "hd (inOrder xt) = root xt"
  quickcheck[random, expect = counterexample]
  quickcheck[exhaustive, expect = counterexample]
  \<comment> \<open>Wrong!\<close>
  oops

subsection \<open>Exhaustive Testing beats Random Testing\<close>

text \<open>Here are some examples from mutants from the List theory
where exhaustive testing beats random testing\<close>

lemma
  "[] ~= xs ==> hd xs = last (x # xs)"
quickcheck[random]
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  assumes "!!i. [| i < n; i < length xs |] ==> P (xs ! i)" "n < length xs ==> ~ P (xs ! n)"
  shows "drop n xs = takeWhile P xs"
quickcheck[random, iterations = 10000, quiet]
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "i < length (List.transpose (List.transpose xs)) ==> xs ! i = map (%xs. xs ! i) [ys<-xs. i < length ys]"
quickcheck[random, iterations = 10000]
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "i < n - m ==> f (lcm m i) = map f [m..<n] ! i"
quickcheck[random, iterations = 10000, finite_types = false]
quickcheck[exhaustive, finite_types = false, expect = counterexample]
oops

lemma
  "i < n - m ==> f (lcm m i) = map f [m..<n] ! i"
quickcheck[random, iterations = 10000, finite_types = false]
quickcheck[exhaustive, finite_types = false, expect = counterexample]
oops

lemma
  "ns ! k < length ns ==> k <= sum_list ns"
quickcheck[random, iterations = 10000, finite_types = false, quiet]
quickcheck[exhaustive, finite_types = false, expect = counterexample]
oops

lemma
  "[| ys = x # xs1; zs = xs1 @ xs |] ==> ys @ zs = x # xs"
quickcheck[random, iterations = 10000]
quickcheck[exhaustive, expect = counterexample]
oops

lemma
"i < length xs ==> take (Suc i) xs = [] @ xs ! i # take i xs"
quickcheck[random, iterations = 10000]
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "i < length xs ==> take (Suc i) xs = (xs ! i # xs) @ take i []"
quickcheck[random, iterations = 10000]
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "[| sorted (rev (map length xs)); i < length xs |] ==> xs ! i = map (%ys. ys ! i) [ys<-remdups xs. i < length ys]"
quickcheck[random]
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "[| sorted (rev (map length xs)); i < length xs |] ==> xs ! i = map (%ys. ys ! i) [ys<-List.transpose xs. length ys \<in> {..<i}]"
quickcheck[random]
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "(ys = zs) = (xs @ ys = splice xs zs)"
quickcheck[random]
quickcheck[exhaustive, expect = counterexample]
oops

subsection \<open>Random Testing beats Exhaustive Testing\<close>

lemma mult_inj_if_coprime_nat:
  "inj_on f A \<Longrightarrow> inj_on g B
   \<Longrightarrow> inj_on (%(a,b). f a * g b::nat) (A \<times> B)"
quickcheck[exhaustive]
quickcheck[random]
oops

subsection \<open>Examples with quantifiers\<close>

text \<open>
  These examples show that we can handle quantifiers.
\<close>

lemma "(\<exists>x. P x) \<longrightarrow> (\<forall>x. P x)"
  quickcheck[random, expect = counterexample]
  quickcheck[exhaustive, expect = counterexample]
oops

lemma "(\<forall>x. \<exists>y. P x y) \<longrightarrow> (\<exists>y. \<forall>x. P x y)"
  quickcheck[random, expect = counterexample]
  quickcheck[expect = counterexample]
oops

lemma "(\<exists>x. P x) \<longrightarrow> (\<exists>!x. P x)"
  quickcheck[random, expect = counterexample]
  quickcheck[expect = counterexample]
oops

subsection \<open>Examples with sets\<close>

lemma
  "{} = A Un - A"
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "[| bij_betw f A B; bij_betw f C D |] ==> bij_betw f (A Un C) (B Un D)"
quickcheck[exhaustive, expect = counterexample]
oops

subsection \<open>Examples with relations\<close>

lemma
  "acyclic (R :: ('a * 'a) set) ==> acyclic S ==> acyclic (R Un S)"
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "acyclic (R :: (nat * nat) set) ==> acyclic S ==> acyclic (R Un S)"
quickcheck[exhaustive, expect = counterexample]
oops

(* FIXME: some dramatic performance decrease after changing the code equation of the ntrancl *)
lemma
  "(x, z) \<in> rtrancl (R Un S) \<Longrightarrow> \<exists>y. (x, y) \<in> rtrancl R \<and> (y, z) \<in> rtrancl S"
(*quickcheck[exhaustive, expect = counterexample]*)
oops

lemma
  "wf (R :: ('a * 'a) set) ==> wf S ==> wf (R Un S)"
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "wf (R :: (nat * nat) set) ==> wf S ==> wf (R Un S)"
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "wf (R :: (int * int) set) ==> wf S ==> wf (R Un S)"
quickcheck[exhaustive, expect = counterexample]
oops

subsection \<open>Examples with the descriptive operator\<close>

lemma
  "(THE x. x = a) = b"
quickcheck[random, expect = counterexample]
quickcheck[exhaustive, expect = counterexample]
oops

subsection \<open>Examples with Multisets\<close>

lemma
  "X + Y = Y + (Z :: 'a multiset)"
quickcheck[random, expect = counterexample]
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "X - Y = Y - (Z :: 'a multiset)"
quickcheck[random, expect = counterexample]
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "N + M - N = (N::'a multiset)"
quickcheck[random, expect = counterexample]
quickcheck[exhaustive, expect = counterexample]
oops

subsection \<open>Examples with numerical types\<close>

text \<open>
Quickcheck supports the common types nat, int, rat and real.
\<close>

lemma
  "(x :: nat) > 0 ==> y > 0 ==> z > 0 ==> x * x + y * y \<noteq> z * z"
quickcheck[exhaustive, size = 10, expect = counterexample]
quickcheck[random, size = 10]
oops

lemma
  "(x :: int) > 0 ==> y > 0 ==> z > 0 ==> x * x + y * y \<noteq> z * z"
quickcheck[exhaustive, size = 10, expect = counterexample]
quickcheck[random, size = 10]
oops

lemma
  "(x :: rat) > 0 ==> y > 0 ==> z > 0 ==> x * x + y * y \<noteq> z * z"
quickcheck[exhaustive, size = 10, expect = counterexample]
quickcheck[random, size = 10]
oops

lemma "(x :: rat) >= 0"
quickcheck[random, expect = counterexample]
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "(x :: real) > 0 ==> y > 0 ==> z > 0 ==> x * x + y * y \<noteq> z * z"
quickcheck[exhaustive, size = 10, expect = counterexample]
quickcheck[random, size = 10]
oops

lemma "(x :: real) >= 0"
quickcheck[random, expect = counterexample]
quickcheck[exhaustive, expect = counterexample]
oops

subsubsection \<open>floor and ceiling functions\<close>

lemma "\<lfloor>x\<rfloor> + \<lfloor>y\<rfloor> = \<lfloor>x + y :: rat\<rfloor>"
quickcheck[expect = counterexample]
oops

lemma "\<lfloor>x\<rfloor> + \<lfloor>y\<rfloor> = \<lfloor>x + y :: real\<rfloor>"
quickcheck[expect = counterexample]
oops

lemma "\<lceil>x\<rceil> + \<lceil>y\<rceil> = \<lceil>x + y :: rat\<rceil>"
quickcheck[expect = counterexample]
oops

lemma "\<lceil>x\<rceil> + \<lceil>y\<rceil> = \<lceil>x + y :: real\<rceil>"
quickcheck[expect = counterexample]
oops

subsection \<open>Examples with abstract types\<close>

lemma
  "Dlist.length (Dlist.remove x xs) = Dlist.length xs - 1"
quickcheck[exhaustive]
quickcheck[random]
oops

lemma
  "Dlist.length (Dlist.insert x xs) = Dlist.length xs + 1"
quickcheck[exhaustive]
quickcheck[random]
oops

subsection \<open>Examples with Records\<close>

record point =
  xpos :: nat
  ypos :: nat

lemma
  "xpos r = xpos r' ==> r = r'"
quickcheck[exhaustive, expect = counterexample]
quickcheck[random, expect = counterexample]
oops

datatype colour = Red | Green | Blue

record cpoint = point +
  colour :: colour

lemma
  "xpos r = xpos r' ==> ypos r = ypos r' ==> (r :: cpoint) = r'"
quickcheck[exhaustive, expect = counterexample]
quickcheck[random, expect = counterexample]
oops

subsection \<open>Examples with locales\<close>

locale Truth

context Truth
begin

lemma "False"
quickcheck[exhaustive, expect = counterexample]
oops

end

interpretation Truth .

context Truth
begin

lemma "False"
quickcheck[exhaustive, expect = counterexample]
oops

end

locale antisym =
  fixes R
  assumes "R x y --> R y x --> x = y"

interpretation equal : antisym "(=)" by standard simp
interpretation order_nat : antisym "(<=) :: nat => _ => _" by standard simp

lemma (in antisym)
  "R x y --> R y z --> R x z"
quickcheck[exhaustive, finite_type_size = 2, expect = no_counterexample]
quickcheck[exhaustive, expect = counterexample]
oops

declare [[quickcheck_locale = "interpret"]]

lemma (in antisym)
  "R x y --> R y z --> R x z"
quickcheck[exhaustive, expect = no_counterexample]
oops

declare [[quickcheck_locale = "expand"]]

lemma (in antisym)
  "R x y --> R y z --> R x z"
quickcheck[exhaustive, finite_type_size = 2, expect = no_counterexample]
quickcheck[exhaustive, expect = counterexample]
oops

subsection \<open>Examples with HOL quantifiers\<close>

lemma
  "\<forall> xs ys. xs = [] --> xs = ys"
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "ys = [] --> (\<forall>xs. xs = [] --> xs = y # ys)"
quickcheck[exhaustive, expect = counterexample]
oops

lemma
  "\<forall>xs. (\<exists> ys. ys = []) --> xs = ys"
quickcheck[exhaustive, expect = counterexample]
oops

subsection \<open>Examples with underspecified/partial functions\<close>

lemma
  "xs = [] ==> hd xs \<noteq> x"
quickcheck[exhaustive, expect = no_counterexample]
quickcheck[random, report = false, expect = no_counterexample]
quickcheck[random, report = true, expect = no_counterexample]
oops

lemma
  "xs = [] ==> hd xs = x"
quickcheck[exhaustive, expect = no_counterexample]
quickcheck[random, report = false, expect = no_counterexample]
quickcheck[random, report = true, expect = no_counterexample]
oops

lemma "xs = [] ==> hd xs = x ==> x = y"
quickcheck[exhaustive, expect = no_counterexample]
quickcheck[random, report = false, expect = no_counterexample]
quickcheck[random, report = true, expect = no_counterexample]
oops

text \<open>with the simple testing scheme\<close>

setup Exhaustive_Generators.setup_exhaustive_datatype_interpretation
declare [[quickcheck_full_support = false]]

lemma
  "xs = [] ==> hd xs \<noteq> x"
quickcheck[exhaustive, expect = no_counterexample]
oops

lemma
  "xs = [] ==> hd xs = x"
quickcheck[exhaustive, expect = no_counterexample]
oops

lemma "xs = [] ==> hd xs = x ==> x = y"
quickcheck[exhaustive, expect = no_counterexample]
oops

declare [[quickcheck_full_support = true]]

subsection \<open>Equality Optimisation\<close>

lemma
  "f x = y ==> y = (0 :: nat)"
quickcheck
oops

lemma
  "y = f x ==> y = (0 :: nat)"
quickcheck
oops

lemma
  "f y = zz # zzs ==> zz = (0 :: nat) \<and> zzs = []"
quickcheck
oops

lemma
  "f y = x # x' # xs ==> x = (0 :: nat) \<and> x' = 0 \<and> xs = []"
quickcheck
oops

lemma
  "x = f x \<Longrightarrow> x = (0 :: nat)"
quickcheck
oops

lemma
  "f y = x # x # xs ==> x = (0 :: nat) \<and> xs = []"
quickcheck
oops

lemma
  "m1 k = Some v \<Longrightarrow> (m1 ++ m2) k = Some v"
quickcheck
oops

end


theory Functions imports Main begin

text\<open>
@{thm[display] id_def[no_vars]}
\rulename{id_def}

@{thm[display] o_def[no_vars]}
\rulename{o_def}

@{thm[display] o_assoc[no_vars]}
\rulename{o_assoc}
\<close>

text\<open>
@{thm[display] fun_upd_apply[no_vars]}
\rulename{fun_upd_apply}

@{thm[display] fun_upd_upd[no_vars]}
\rulename{fun_upd_upd}
\<close>

text\<open>
definitions of injective, surjective, bijective

@{thm[display] inj_on_def[no_vars]}
\rulename{inj_on_def}

@{thm[display] surj_def[no_vars]}
\rulename{surj_def}

@{thm[display] bij_def[no_vars]}
\rulename{bij_def}
\<close>

text\<open>
possibly interesting theorems about inv
\<close>

text\<open>
@{thm[display] inv_f_f[no_vars]}
\rulename{inv_f_f}

@{thm[display] inj_imp_surj_inv[no_vars]}
\rulename{inj_imp_surj_inv}

@{thm[display] surj_imp_inj_inv[no_vars]}
\rulename{surj_imp_inj_inv}

@{thm[display] surj_f_inv_f[no_vars]}
\rulename{surj_f_inv_f}

@{thm[display] bij_imp_bij_inv[no_vars]}
\rulename{bij_imp_bij_inv}

@{thm[display] inv_inv_eq[no_vars]}
\rulename{inv_inv_eq}

@{thm[display] o_inv_distrib[no_vars]}
\rulename{o_inv_distrib}
\<close>

text\<open>
small sample proof

@{thm[display] ext[no_vars]}
\rulename{ext}

@{thm[display] fun_eq_iff[no_vars]}
\rulename{fun_eq_iff}
\<close>

lemma "inj f \<Longrightarrow> (f o g = f o h) = (g = h)"
  apply (simp add: fun_eq_iff inj_on_def)
  apply (auto)
  done

text\<open>
\begin{isabelle}
inj\ f\ \isasymLongrightarrow \ (f\ \isasymcirc \ g\ =\ f\ \isasymcirc \ h)\ =\ (g\ =\ h)\isanewline
\ 1.\ \isasymforall x\ y.\ f\ x\ =\ f\ y\ \isasymlongrightarrow \ x\ =\ y\ \isasymLongrightarrow \isanewline
\ \ \ \ (\isasymforall x.\ f\ (g\ x)\ =\ f\ (h\ x))\ =\ (\isasymforall x.\ g\ x\ =\ h\ x)
\end{isabelle}
\<close>

text\<open>image, inverse image\<close>

text\<open>
@{thm[display] image_def[no_vars]}
\rulename{image_def}
\<close>

text\<open>
@{thm[display] image_Un[no_vars]}
\rulename{image_Un}
\<close>

text\<open>
@{thm[display] image_comp[no_vars]}
\rulename{image_comp}

@{thm[display] image_Int[no_vars]}
\rulename{image_Int}

@{thm[display] bij_image_Compl_eq[no_vars]}
\rulename{bij_image_Compl_eq}
\<close>

text\<open>
illustrates Union as well as image
\<close>

lemma "f`A \<union> g`A = (\<Union>x\<in>A. {f x, g x})"
by blast

lemma "f ` {(x,y). P x y} = {f(x,y) | x y. P x y}"
by blast

text\<open>actually a macro!\<close>

lemma "range f = f`UNIV"
by blast

text\<open>
inverse image
\<close>

text\<open>
@{thm[display] vimage_def[no_vars]}
\rulename{vimage_def}

@{thm[display] vimage_Compl[no_vars]}
\rulename{vimage_Compl}
\<close>

end


(*  Author: Lukas Bulwahn <lukas.bulwahn-at-gmail.com> *)

section \<open>Additions to Isabelle's Main Theories\<close>

theory Additions_to_Main
imports "HOL-Library.Multiset"
begin

subsection \<open>Addition to Finite-Set Theory\<close>

lemma bound_domain_and_range_impl_finitely_many_functions:
  "finite {f::nat\<Rightarrow>nat. (\<forall>i. f i \<le> n) \<and> (\<forall>i\<ge>m. f i = 0)}"
proof (induct m)
  case 0
  have eq: "{f. (\<forall>i. f i \<le> n) \<and> (\<forall>i. f i = 0)} = {(\<lambda>_. 0)}" by auto
  from this show ?case by auto (subst eq; auto)
next
  case (Suc m)
  let ?S = "(\<lambda>(y, f). f(m := y)) ` ({0..n} \<times> {f. (\<forall>i. f i \<le> n) \<and> (\<forall>i\<ge>m. f i = 0)})"
  {
    fix g
    assume "\<forall>i. g i \<le> n" "\<forall>i\<ge>Suc m. g i = 0"
    from this have "g \<in> ?S"
      by (auto intro: image_eqI[where x="(g m, g(m:=0))"])
  }
  from this have "{f. (\<forall>i. f i \<le> n) \<and> (\<forall>i\<ge>Suc m. f i = 0)} = ?S" by auto
  from this Suc show ?case by simp
qed

subsection \<open>Addition to Set-Interval Theory\<close>

lemma sum_atMost_remove_nat:
  assumes "k \<le> (n :: nat)"
  shows "(\<Sum>i\<le>n. f i) = f k + (\<Sum>i\<in>{..n}-{k}. f i)"
using assms by (auto simp add: sum.remove[where x=k])

subsection \<open>Additions to Multiset Theory\<close>

lemma set_mset_Abs_multiset:
  assumes "finite {x. f x > 0}"
  shows "set_mset (Abs_multiset f) = {x. f x > 0}"
using assms unfolding set_mset_def by simp

lemma sum_mset_sum_count:
  "sum_mset M = (\<Sum>i\<in>set_mset M. count M i * i)"
proof (induct M)
  show "sum_mset {#} = (\<Sum>i\<in>set_mset {#}. count {#} i * i)" by simp
next
  fix M x
  assume hyp: "sum_mset M = (\<Sum>i\<in>set_mset M. count M i * i)"
  show "sum_mset (add_mset x M) = (\<Sum>i\<in>set_mset (add_mset x M). count (add_mset x M) i * i)"
  proof (cases "x \<in># M")
    assume a: "\<not> x \<in># M"
    from this have "count M x = 0" by (meson count_inI)
    from \<open>\<not> x \<in># M\<close> this hyp show ?thesis
      by (auto intro!: sum.cong)
  next
    assume "x \<in># M"
    have "sum_mset (add_mset x M) = (\<Sum>i\<in>set_mset M. count M i * i) + x"
      using hyp by simp
    also have "\<dots> = (\<Sum>i\<in>set_mset M - {x}. count M i * i) + count M x * x + x"
      using \<open>x \<in># M\<close> by (simp add: sum.remove[of _ x])
    also have "\<dots> = count (add_mset x M) x * x + (\<Sum>i\<in>set_mset (add_mset x M) - {x}. count (add_mset x M) i * i)"
      by simp
    also have "\<dots> = (\<Sum>i\<in>set_mset (add_mset x M). count (add_mset x M) i * i)"
      using \<open>x \<in># M\<close> by (simp add: sum.remove[of _ x])
    finally show ?thesis .
  qed
qed

lemma sum_mset_eq_sum_on_supersets:
  assumes "finite A" "set_mset M \<subseteq> A"
  shows "(\<Sum>i\<in>set_mset M. count M i * i) = (\<Sum>i\<in>A. count M i * i)"
proof -
  note \<open>finite A\<close> \<open>set_mset M \<subseteq> A\<close>
  moreover have "\<forall>i\<in>A - set_mset M. count M i * i = 0"
    using count_inI by fastforce
  ultimately show ?thesis
    by (auto intro: sum.mono_neutral_cong_left)
qed

end