theory Composition
imports Composition_Core "../Mergeable/Mergeable"
begin

(* This file extends the definitions in Composition_Core.thy to a fully general implementation
 * of composition of language semantics. In particular, it does so while requiring
 * a weaker condition than Composition_Simple.thy does on the semantics being composed.
 * For this reason we consider it preferable to use the definitions here in practice,
 * even if the ones in Composition_Simple are more straightforward. *)

(*
 * sups_pres ("SUPremumS are PREServed")
 *
 *
 * Note that unlike Scott continuity, we don't have the "closure" property
 * here (that the set is closed under LUBs) - this doesn't seem to be a problem, but
 * puzzling through the implications of this is a TODO.
 *
 *The type of the syntax involved in the languages being merged is assumed to be the same
 * here - it should be easy to apply the appropriate syntax-translation function before
 * using sups_pres.
*)

(* TODO: do we really need the nonemptiness requirement for Fs' here? *)
(* Original definition. We are generalizing it here to allow talking about sups_pres
 * restricted to specific subsets of the input space (e.g. ok_S) *)
(*
definition sups_pres ::
  "('a \<Rightarrow> ('b :: Mergeable) \<Rightarrow> 'b) set \<Rightarrow> bool" where
"sups_pres Fs =
  (\<forall> x sup syn Xs Fs' f .
    x \<in> Xs \<longrightarrow>
    finite Xs \<longrightarrow>
    is_sup Xs sup \<longrightarrow>
    Fs' \<subseteq> Fs \<longrightarrow>
    f \<in> Fs' \<longrightarrow>
    (\<exists> sup' . is_sup ((\<lambda> f . f syn sup) ` Fs') sup' \<and>
     is_sup (scross ((\<lambda> f . f syn) ` Fs') Xs) sup'))"
*)

(*
definition sups_pres ::
  "('a \<Rightarrow> ('b :: Mergeable) \<Rightarrow> 'b) set \<Rightarrow> ('b :: Mergeable) set \<Rightarrow> bool" where
"sups_pres Fs S =
  (\<forall> x sup syn Xs Fs' f .
    x \<in> Xs \<longrightarrow>
    Xs \<subseteq> S \<longrightarrow>
    finite Xs \<longrightarrow>
    is_sup Xs sup \<longrightarrow>
    sup \<in> S \<longrightarrow>
    Fs' \<subseteq> Fs \<longrightarrow>
    f \<in> Fs' \<longrightarrow>
    (\<exists> sup' . is_sup ((\<lambda> f . f syn sup) ` Fs') sup' \<and>
     is_sup (scross ((\<lambda> f . f syn) ` Fs') Xs) sup' \<and>
     sup' \<in> S))"
*)

definition sups_pres ::
  "('a \<Rightarrow> ('b :: Pord) \<Rightarrow> 'b) set \<Rightarrow> ('a \<Rightarrow> 'b  set) \<Rightarrow> bool" where
"sups_pres Fs S =
  (\<forall> x syn Fs' f .
    x \<in> S syn \<longrightarrow>
    Fs' \<subseteq> Fs \<longrightarrow>
    f \<in> Fs' \<longrightarrow>
    (has_sup ((\<lambda> f . f syn x) ` Fs')))"

lemma sups_presI [intro] :
  assumes "\<And> x syn Fs' f .
           x \<in> S syn \<Longrightarrow>
          Fs' \<subseteq> Fs \<Longrightarrow>
          f \<in> Fs' \<Longrightarrow>
          (has_sup ((\<lambda> f . f syn x) ` Fs'))"
  shows "sups_pres Fs S"
  using assms unfolding sups_pres_def by blast

lemma sups_presD :
  assumes "sups_pres Fs S"
  assumes "x \<in> S syn"
  assumes "Fs' \<subseteq> Fs"
  assumes "f \<in> Fs'"

  shows "(has_sup ((\<lambda> f . f syn x) ` Fs'))" using assms
  unfolding sups_pres_def
  by blast

(* Helper lemmas for scross *)
lemma scross_subset :
  assumes HF : "Fs1 \<subseteq> Fs2"
  assumes HX : "Xs1 \<subseteq> Xs2"
  shows "scross Fs1 Xs1 \<subseteq> scross Fs2 Xs2"
proof
  fix res
  assume Hres : "res \<in> scross Fs1 Xs1"

  obtain f x where
    F : "f \<in> Fs1" and
    X : "x \<in> Xs1" and
    Res : "res = f x" using scross_inD[OF Hres] by blast

  show "res \<in> scross Fs2 Xs2"
  proof(rule scross_inI)
    show "f \<in> Fs2"
      using F HF by blast
    show "x \<in> Xs2"
      using X HX by blast
    show "res = f x" using Res by auto
  qed
qed

definition scross_alt :: "('a \<Rightarrow> 'b) set \<Rightarrow> 'a set \<Rightarrow> 'b set" where
"scross_alt Fs Xs =
  (\<lambda> fx . (case fx of (f, x) \<Rightarrow> f x)) ` (Fs \<times> Xs)"

lemma scross_alt_eq :
  "scross_alt Fs Xs = scross Fs Xs"
  unfolding scross_def scross_alt_def
  by(auto)

lemma scross_finite :
  assumes HF : "finite Fs"
  assumes HX : "finite Xs"
  shows "finite (scross Fs Xs)"
  unfolding sym[OF scross_alt_eq] scross_alt_def
  using finite_cartesian_product[OF HF HX]
  by blast

(*
 * sups_pres being closed under subset is important both as a "sanity-check" on the
 * definition, as well as being useful directly as an ingredient in proving later lemmas.
 *)
(* TODO: what about subsetting of S? supersetting of S?
   something tells me that one isn't true though.
*)
lemma sups_pres_subset :
  fixes Fs :: "('a \<Rightarrow> ('b :: Mergeable) \<Rightarrow> 'b) set"
  assumes H : "sups_pres Fs S"
  assumes Hfin : "finite Fs"
  assumes Hsub : "Fs' \<subseteq> Fs"
  assumes Hnemp : "f \<in> Fs'"
  shows "sups_pres Fs' S"
proof(rule sups_presI)
  fix x :: "'b"
  fix sup1 :: "'b"
  fix syn
  fix Fs_sub :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) set"
  fix f

  assume Subs : "x \<in> S syn"
  assume Hfs_sub : "Fs_sub \<subseteq> Fs'"
  assume Hnemp_Fs_sub : "f \<in> Fs_sub"

  obtain Rest where Rest : "Fs' \<union> Rest = Fs" using Hsub by blast

  have Hnemp_Fs' : "f \<in> Fs'"
    using Hnemp_Fs_sub Hfs_sub Rest
    by auto

  have Sub2: "Fs_sub \<subseteq> Fs"
    using Hsub Rest Hfs_sub
    by auto

  show "has_sup
        ((\<lambda>f. f syn x) ` Fs_sub)"
    using sups_presD[OF H Subs Sub2 Hnemp_Fs_sub] Hfs_sub Hnemp_Fs_sub Hsub
    unfolding has_sup_def
    by(auto)
qed

lemma sups_pres_subset_syn :
  fixes Fs :: "('a \<Rightarrow> ('b :: Mergeable) \<Rightarrow> 'b) set"
  assumes H : "sups_pres Fs S"
  assumes Hfin : "finite Fs"
  assumes Hsub : "\<And> x . S' x \<subseteq> S x"
  assumes Hnemp : "f \<in> Fs'"
  shows "sups_pres Fs S'"
proof(rule sups_presI)
  fix x :: "'b"
  fix sup1 :: "'b"
  fix syn
  fix Fs_sub :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) set"
  fix f

  assume Subs : "x \<in> S' syn"
  assume Hfs_sub : "Fs_sub \<subseteq> Fs"
  assume Hnemp_Fs_sub : "f \<in> Fs_sub"

  have Subs' : "x \<in> S syn"
    using Hsub Subs by blast

  show "has_sup
        ((\<lambda>f. f syn x) ` Fs_sub)"
    using sups_presD[OF H Subs' Hfs_sub Hnemp_Fs_sub]
    unfolding has_sup_def
    by(auto)
qed

(* TODO: we weren't using this lemma, but the fact that
 * we couldn't prove it under our new definition may be a bad sign.
 *)
(*
lemma sups_pres_pair :
  assumes Hf : "sups_pres {f1, f2} S"
  assumes Hsup : "is_sup {x1, x2} sp"
  assumes Hsup_in : "sp \<in> S"
  assumes Hx1 : "x1 \<in> S"
  assumes Hx2 : "x2 \<in> S"
  shows "\<exists> sp' . is_sup {f1 syn x1, f2 syn x2} sp' \<and> sp' \<in> S"
proof-

  have Hx12 : "{x1, x2} \<subseteq> S"
    using Hx1 Hx2 by auto

  obtain sup' where Sup' : "is_sup ((\<lambda>f. f syn sp) ` {f1, f2}) sup'"
    and Sup'_full : "is_sup (scross ((\<lambda>f. f syn) ` {f1, f2}) {x1, x2}) sup'"
    and Sup'_S : "sup' \<in> S"
    using sups_presD[OF Hf _ Hx12 _ Hsup Hsup_in, of x1 "{f1, f2}"]
    by auto

  then obtain z where Z: "is_sup (scross ((\<lambda>f. f syn) ` {f1, f2}) {x1, x2}) z"
    unfolding has_sup_def by auto

  have Scross_eq :
    "(scross ((\<lambda>f. f syn) ` {f1, f2}) {x1, x2}) =
      { f1 syn x1, f1 syn x2, f2 syn x1, f2 syn x2 }"
    unfolding scross_def by blast

  have Sub : "{f1 syn x1, f2 syn x2} \<subseteq> { f1 syn x1, f1 syn x2, f2 syn x1, f2 syn x2 }"
    by blast
(* stronger closure property needed here? or can we play around with another piece of the thm
*)
  show "\<exists>sp'. is_sup {f1 syn x1, f2 syn x2} sp' \<and> sp' \<in> S"
(*
    using has_sup_subset[OF _ Z, of "{f1 syn x1, f2 syn x2}" "f1 syn x1"] *)
    using Sup'_full
    unfolding Scross_eq
    by blast
qed
*)

lemma scross_singleton1 :
"scross {f} Xs = f ` Xs"
  unfolding scross_def
  by blast

lemma scross_singleton2 :
"scross Fs {x} = (\<lambda> f . f x) ` Fs"
  unfolding scross_def
  by blast

(*
 * The function calculated by pcomps is "pointwise" the least upper bound of its constituent
 * functions - that is, if we pass the _same_ input (sem) to all f \<in> Fs, the result we get is <[
 * pcomps l syn sem
 *)

lemma sups_pres_pcomps_sup' :
  assumes Hp : "sups_pres (set l) S"
  assumes Hnemp : "l \<noteq> []"
  assumes Hsem : "sem \<in> S syn"
  shows "is_sup ((\<lambda> f . f syn sem) ` (set l)) (pcomps l syn sem)" using assms
proof (induction l arbitrary: syn sem)
  case Nil
  then show ?case by auto
next
  case (Cons h1 t1)
  show ?case
  proof(cases t1)
    case Nil' : Nil

    have SP : "sups_pres ({h1}) S"
      using sups_pres_subset[OF Cons.prems(1), of "set t1"] Cons.prems Nil'
      by auto

    obtain sup' where Sup' : "is_sup ((\<lambda>f. f syn sem) ` {h1}) sup'"
      using Cons.prems sups_presD[OF SP, of "sem" syn "{h1}" h1]
      by(auto simp add: sup_singleton has_sup_def)

    then show ?thesis using Nil' Cons.prems
      by(auto simp add: sup_singleton scross_def)
  next
    case Cons' : (Cons h2 t2)

    have SP : "sups_pres (set t1) S"
      using sups_pres_subset[OF Cons.prems(1), of "set t1"] Cons' by auto

    have Sup : "is_sup ((\<lambda>f. f syn sem) ` set t1) (pcomps t1 syn sem)"
      using Cons.IH[OF SP] Cons.prems Cons' by( auto)

    have HSup : "is_sup {h1 syn sem} (h1 syn sem)" using sup_singleton by auto

    have Eq3 : "(\<lambda>f. f sem) ` (\<lambda>f. f syn) ` set (h1 # t1) = {h1 syn sem} \<union> (\<lambda>f. f syn sem) ` set t1"
      by auto

    have Sing : "is_sup {sem} sem"
      using sup_singleton[of sem] by(auto simp add: has_sup_def)

    have Sing_sem : "sem \<in> S syn" using Cons.prems by auto

    obtain sup' where Sup' :
      "is_sup ((\<lambda>f. f syn sem) ` set (h1 # t1)) sup'"
      using sups_presD[OF Cons.prems(1) Sing_sem, of "set (h1#t1)" h1]
      by(auto simp add: has_sup_def)

    have Union : "is_sup ({h1 syn sem} \<union> (\<lambda>f. f syn sem) ` set t1) sup'" using Sup'
      unfolding scross_singleton2 Eq3
      by auto

    have Conc' : "has_sup {h1 syn sem, pcomps t1 syn sem}"
      using sup_union2[OF HSup Sup Union]
      by(auto simp add: has_sup_def)

    then obtain s' where S' : "is_sup {h1 syn sem, pcomps t1 syn sem} s'"
      by(auto simp add: has_sup_def)

    have Conc'' : "is_sup {h1 syn sem, pcomps t1 syn sem} [^ h1 syn sem, pcomps (h2 # t2) syn sem ^]"
      using bsup_sup[OF S' bsup_spec] unfolding Cons'  by auto

    have Eqn :
  "(insert (h2 syn sem) (insert (h1 syn sem) ((\<lambda>x. x syn sem) ` set t2))) =
   (insert (h1 syn sem) (insert (h2 syn sem) ((\<lambda>x. x syn sem) ` set t2)))"
      by auto

    have Conc1 : "is_sup ((\<lambda>f. f syn sem) ` set (h1 # t1)) (pcomps (h1 # t1) syn sem)"
      using sup_union1[OF HSup Sup Conc'']
      by(auto simp add: Cons' Eqn)

    show ?thesis using Conc1 by auto
  qed
qed

lemma sups_pres_pcomps_sup1 :
  assumes Hp : "sups_pres (set l) S"
  assumes Hnemp : "l \<noteq> []"
  assumes Hsem : "sem \<in> S syn"
  shows "is_sup ((\<lambda> f . f syn sem) ` (set l)) (pcomps l syn sem)" using assms
    sups_pres_pcomps_sup'
  by fast

(*
 * Another key theorem, both for understanding the correctness of the specification,
 * and for practical reasons. We should expect that pcomps will be associative when
 * sups_pres holds (since then it will be calculating a "real" least upper bound in some
 * sense, and LUBs associate: sup {sup S1, x} = sup (S1 \<union> {x})
 *)
lemma pcomps_assoc :
  assumes H : "sups_pres (set l1 \<union> set l2) S"
  assumes Nemp1 : "l1 \<noteq> []"
  assumes Nemp2 : "l2 \<noteq> []"
  assumes X : "x \<in> S syn"
  shows "pcomps (l1 @ l2) syn x = pcomps [pcomps l1, pcomps l2] syn x"
(*proof(rule ext; rule ext) *)
proof-

  obtain f1 where F1 : "f1 \<in> set l1" using Nemp1 by(cases l1; auto)

  have H1 : "sups_pres (set l1) S"
    using sups_pres_subset[OF H _ _ F1]  by auto

  have Sup1: "is_sup ((\<lambda> f . f syn x) ` (set l1)) (pcomps l1 syn x)"
    using sups_pres_pcomps_sup'[OF H1 Nemp1 X] by auto

  obtain f2 where F2 : "f2 \<in> set l2" using Nemp2 by(cases l2; auto)

  have H2 : "sups_pres (set l2) S"
    using sups_pres_subset[OF H _ _ F2]  by auto

  have Sup2: "is_sup ((\<lambda> f . f syn x) ` (set l2)) (pcomps l2 syn x)"
    using sups_pres_pcomps_sup'[OF H2 Nemp2 X] by auto

  have Unions : "set (l1 @ l2) = set l1 \<union> set l2" by auto

  have SupAll1 : "is_sup ((\<lambda> f . f syn x) ` (set (l1 @ l2))) (pcomps (l1 @ l2) syn x)"
    using sups_pres_pcomps_sup'[of "l1 @ l2"] H Nemp1 X
    unfolding Unions by(auto)

  have SupAll2 : "is_sup ((\<lambda> f . f syn x) ` ({pcomps l1, pcomps l2})) (pcomps (l1 @ l2) syn x)"
    unfolding pcomps.simps
    using sup_union2[OF Sup1(1) Sup2(1), of "(pcomps (l1 @ l2) syn x)"] SupAll1 X
    unfolding Unions Set.image_Un
    by(auto)

  hence SupAll2' : "is_sup {pcomps l1 syn x, pcomps l2 syn x} (pcomps (l1 @ l2) syn x)" by auto

  have Conc' : "[^ pcomps l1 syn x, pcomps l2 syn x ^] = (pcomps (l1 @ l2) syn x)"
    using is_sup_unique[OF SupAll2' bsup_sup[OF SupAll2' bsup_spec]] by auto

  thus "pcomps (l1 @ l2) syn x = pcomps [pcomps l1, pcomps l2] syn x"
    unfolding pcomps.simps Conc' by auto
qed

(*
 * The most general form of the theorem relating pcomps to sups_pres.
 * Informally, if sups_pres holds on the set of functions in a (nonempty) list l,
 * then for any nonempty set of inputs Xs with a supremum xsup,
 * the least upper bound of the _entire_ cross product of functions and inputs (Fs, Xs)
 * is given by applying pcomps l to xsup (the inputs' supremum).
 *)
(*
lemma sups_pres_pcomps_gen' :
  assumes H : "sups_pres (set l) S"
  assumes Hf : "f \<in> set l"
  assumes Hxs : "finite Xs"
  assumes Hx : "x \<in> Xs"
  assumes Hsub : "Xs \<subseteq> S syn"
  assumes Hsup : "is_sup Xs xsup"
  assumes Hsup_in : "xsup \<in> S syn"
  shows "is_sup (scross ((\<lambda> f . f syn) ` (set l)) Xs) (pcomps l syn xsup)" using assms

proof(induction l arbitrary: f x Xs xsup)
  case Nil
  then show ?case by auto
next
  case (Cons fh1 ft1)

  have Xs_has_sup : "has_sup Xs"
    using Cons.prems(6)
    unfolding has_sup_def
    by auto

  show ?case
  proof(cases ft1)
    case Nil' : Nil

    obtain sup' where Sup'1 : "is_sup ((\<lambda>f. f syn xsup) ` {fh1}) sup'" and
      Sup'2 : "is_sup (scross ((\<lambda>f. f syn) ` {fh1}) Xs) sup'"
      using sups_presD[OF Cons.prems(1) Cons.prems(4) Cons.prems(5) Cons.prems(3) Cons.prems(6) Cons.prems(7), of "{fh1}" fh1]
      by auto

    have Sup'1_alt : "is_sup ((\<lambda>f. f syn xsup) ` {fh1}) (fh1 syn xsup)"
      using sup_singleton[of "(fh1 syn xsup)"] Sup'1 by auto

    hence Sup'1_eq : "sup' = (fh1 syn xsup)"
      using is_sup_unique[OF Sup'1 Sup'1_alt]
      by auto

    have Sup'2_alt : "is_sup (fh1 syn ` Xs) (fh1 syn xsup)"
      using Sup'2
      unfolding  Sup'1_eq
      by(auto simp add: scross_singleton1)

    then show ?thesis using Nil' Sup'1_eq
      by(auto simp add: scross_singleton1)
  next
    case Cons' : (Cons fh2 ft2)

    have SP : "sups_pres (set ft1) S"
      using sups_pres_subset[OF Cons.prems(1), of "set ft1"] Cons' by auto

    have Tsup : "is_sup (scross ((\<lambda>f. f syn) ` set ft1) Xs) (pcomps ft1 syn xsup)"
      using Cons.IH[OF SP _ Cons.prems(3) Cons.prems(4) Cons.prems(5) Cons.prems(6) Cons.prems(7)]
      Cons'
      unfolding has_sup_def
      by( auto)

    have Xs_has_sup : "has_sup Xs" using Cons.prems(6)
      unfolding has_sup_def by auto

    obtain hsup1 where Hsup1 : "is_sup (scross ((\<lambda>f. f syn) ` set (fh1 # ft1)) Xs) hsup1"
      and Hsup1_0 : "is_sup ((\<lambda>f. f syn xsup) ` set (fh1 # ft1)) hsup1"
      using sups_presD[OF Cons.prems(1) Cons.prems(4) Cons.prems(5) Cons.prems(3) Cons.prems(6),of "set (fh1 # ft1)" fh1] Cons.prems
      unfolding has_sup_def by auto

    have Hd_subset : "{fh1 syn} \<subseteq> ((\<lambda>f. f syn) ` set (fh1 # ft1))"
      by auto

    have Hd_cross_subset : "scross {fh1 syn} Xs \<subseteq> (scross ((\<lambda>f. f syn) ` set (fh1 # ft1)) Xs)"
      using scross_subset[OF Hd_subset, of Xs Xs]
      by auto

    have Hd_finite : "finite (scross ((\<lambda>f. f syn) ` set (fh1 # ft1)) Xs)"
      using scross_finite[OF _ Cons.prems(3), of "((\<lambda>f. f syn) ` set (fh1 # ft1))"]
      by blast

    have Hd_nemp : "fh1 syn x \<in> scross {fh1 syn} Xs"
      using Cons.prems(4)
      unfolding scross_singleton1
      by auto

    obtain hsup2' where Hsup2'1 : "is_sup ((\<lambda>f. f syn xsup) ` {fh1}) hsup2'" and Hsup2'2 : "is_sup (scross ((\<lambda>f. f syn) ` {fh1}) Xs) hsup2'"
      using sups_presD[OF Cons.prems(1) Cons.prems(4) Cons.prems(5) Cons.prems(3) Cons.prems(6), of "{fh1}" fh1] Cons.prems
      by auto

    hence Hsup2'2_alt : "is_sup (scross {fh1 syn} Xs) hsup2'"
      by(auto)

    have Xsup_sup : "is_sup ((\<lambda>f. f syn xsup) ` {fh1}) (fh1 syn xsup)"
      using sup_singleton
      by auto

    have Hsup2_Xsup : "hsup2' = (fh1 syn xsup)"
      using is_sup_unique[OF Hsup2'1 Xsup_sup] by auto

    have Cross_fact :
      "(scross ((\<lambda>f. f syn) ` set (fh1 # ft1)) Xs) =
       (scross {fh1 syn} Xs) \<union>
       (scross ((\<lambda>f. f syn) ` set (ft1)) Xs)"
      unfolding scross_def
      by(simp; blast)

    have Hsup1' :
      "is_sup ((scross {fh1 syn} Xs) \<union>
       (scross ((\<lambda>f. f syn) ` set (ft1)) Xs)) hsup1"
      using Hsup1 unfolding Cross_fact by auto

    have Conc' : "is_sup {hsup2', pcomps ft1 syn xsup} hsup1"
      using sup_union2[OF Hsup2'2_alt Tsup Hsup1'] Hsup2'1
      by auto

    have Conc'' : "is_sup {hsup2', pcomps ft1 syn xsup} [^ hsup2', pcomps ft1 syn xsup^]"
      using bsup_sup[OF Conc' bsup_spec] unfolding Cons'  by auto

    have Cross_fact : "(scross {fh1 syn} Xs \<union> scross (insert (fh2 syn) ((\<lambda>x. x syn) ` set ft2)) Xs) =
                       (scross (insert (fh1 syn) (insert (fh2 syn) ((\<lambda>x. x syn) ` set ft2))) Xs)"
      by(auto simp add: scross_def)

    have Conc1 : "is_sup (scross ((\<lambda>f. f syn) ` set (fh1 # ft1)) Xs)
     (pcomps (fh1 # ft1) syn xsup)"
      using sup_union1[OF Hsup2'2_alt Tsup Conc''] Cons' Hsup2_Xsup Cross_fact
      by auto

    obtain sup' where Sup' :
      "is_sup (scross ((\<lambda>f. f syn) ` set (fh1 # ft1)) Xs) sup'"
      using sups_presD[OF Cons.prems(1) Cons.prems(4) Cons.prems(5) Cons.prems(3) Cons.prems(6) Cons.prems(7), of "set (fh1 # ft1)" fh1]
      by auto

    have Sup'_Eq :
      "sup' =  (pcomps (fh1 # ft1) syn xsup)"
      using is_sup_unique[OF Conc1 Sup']
      by auto

    show ?thesis
      using Conc1
      by(auto)
  qed
qed

lemma sups_pres_pcomps_gen1 :
  assumes H : "sups_pres (set l) S"
  assumes Hf : "f \<in> set l"
  assumes Hxs : "finite Xs"
  assumes Hx : "x \<in> Xs"
  assumes Hsub : "Xs \<subseteq> S syn"
  assumes Hsup : "is_sup Xs xsup"
  assumes Hsup_in : "xsup \<in> S syn"
  shows "is_sup (scross ((\<lambda> f . f syn) ` (set l)) Xs) (pcomps l syn xsup)"
  using assms sups_pres_pcomps_gen'[OF H Hf Hxs Hx Hsub Hsup]
  by auto
*)
(*
lemma sups_pres_mono :
  assumes H : "sups_pres Fs S"
  assumes Hf : "f \<in> Fs"
  assumes Hx_in : "x \<in> S syn"
  assumes Hy_in : "y \<in> S syn"
  assumes Hxy : "x <[ y"
  shows "f syn x <[ f syn y"
proof-

  have Ysup : "is_sup {x, y} y" using Hxy
    unfolding is_sup_def is_least_def is_ub_def
    by(auto simp add: leq_refl)

  obtain supr where
    Supr1 : "is_sup ((\<lambda>f. f syn y) ` {f}) supr"
    using sups_presD[OF H ] Hf Hx_in Hy_in
    by auto

  have Supr_eq : "supr = f syn y" using Supr1
      is_sup_unique[OF sup_singleton[of "f syn y"], of supr]
    by(simp)

  have Supr_leq : "f syn x <[ supr"
    using is_supD1[OF Supr2, of "f syn x"]
    by(simp add: scross_singleton1)

  show ?thesis
    using Supr_leq unfolding Supr_eq
    by auto
qed

lemma pcomps_mono :
  assumes H : "sups_pres (set l) S"
  assumes Hnemp : "f \<in> set l"
  assumes Hx_in : "x \<in> S syn"
  assumes Hy_in : "y \<in> S syn"
  assumes Hxy : "x <[ y"
  shows "pcomps l syn x <[ pcomps l syn y" using assms
proof(induction l arbitrary: f x y syn)
  case Nil
  then show ?case by auto
next
  case (Cons fh1 ft1)

  then show ?case
  proof(cases ft1)
    case Nil' : Nil
    then show ?thesis
      using sups_pres_mono[OF Cons.prems(1) _ Cons.prems(3) Cons.prems(4), of fh1] Cons.prems
      by(auto)
  next
    case Cons' : (Cons fh2 ft2)

    have SP' : "sups_pres (set ft1) S"
      using sups_pres_subset[OF Cons.prems(1), of "set ft1" fh2] unfolding Cons'
      by auto

    have Ind : "pcomps ft1 syn x <[ pcomps ft1 syn y"
      using Cons.IH[OF SP' _ Cons.prems(3) Cons.prems(4), of fh2] Cons.prems unfolding Cons'
      by auto

    have Mono : "fh1 syn x <[ fh1 syn y"
      using sups_pres_mono[OF Cons.prems(1) _ Cons.prems(3) Cons.prems(4) Cons.prems(5), of fh1]
      by auto

    have SupX :
      "is_sup
        (scross ((\<lambda>f. f syn) ` set (fh1 # ft1)) {x})
        (pcomps (fh1 # ft1) syn x)"
      using sups_pres_pcomps_gen1[OF Cons.prems(1) _ _ _ _ sup_singleton[of x], of fh1 x syn]
        Cons.prems(3)
      by(auto)

    have SupX_tail :  "is_sup
        (scross ((\<lambda>f. f syn) ` set (ft1)) {x})
        (pcomps (ft1) syn x)"
      using sups_pres_pcomps_gen1[OF SP' _ _ _ _ sup_singleton[of x], of fh2  x syn] Cons.prems(3) unfolding Cons'
      by(auto)

    have RewriteX : "(scross ((\<lambda>f. f syn) ` set (fh1 # ft1)) {x}) =
                      ({fh1 syn x} \<union> ((\<lambda> f . f syn x) ` set ft1))"
      unfolding scross_singleton2 by auto

    have SupX2 : "is_sup {fh1 syn x, pcomps ft1 syn x} (pcomps (fh1 # ft1) syn x)"
      using sup_union2[OF sup_singleton[of "fh1 syn x"] SupX_tail] SupX unfolding RewriteX scross_singleton2
      by(auto)

    have SupY :
      "is_sup
        (scross ((\<lambda>f. f syn) ` set (fh1 # ft1)) {y})
        (pcomps (fh1 # ft1) syn y)"
      using sups_pres_pcomps_gen1[OF Cons.prems(1) _ _ _ _ sup_singleton[of y], of fh1 y syn]
        Cons.prems(4)
      by(auto)

    have SupY_tail :  "is_sup
        (scross ((\<lambda>f. f syn) ` set (ft1)) {y})
        (pcomps (ft1) syn y)"
      using sups_pres_pcomps_gen1[OF SP' _ _ _ _ sup_singleton[of y], of fh2  y syn]
        Cons.prems(4)
      unfolding Cons'
      by(auto)

    have RewriteY : "(scross ((\<lambda>f. f syn) ` set (fh1 # ft1)) {y}) =
                      ({fh1 syn y} \<union> ((\<lambda> f . f syn y) ` set ft1))"
      unfolding scross_singleton2 by auto

    have SupY2 : "is_sup {fh1 syn y, pcomps ft1 syn y} (pcomps (fh1 # ft1) syn y)"
      using sup_union2[OF sup_singleton[of "fh1 syn y"] SupY_tail] SupY unfolding RewriteY scross_singleton2
      by(auto)

    have Ub_conc : "is_ub {fh1 syn x, pcomps ft1 syn x} (pcomps (fh1 # ft1) syn y)"
    proof-
      have Leq1 : "fh1 syn x <[ (pcomps (fh1 # ft1) syn y)"
        using leq_trans[OF Mono, of "pcomps (fh1 # ft1) syn y"] is_supD1[OF SupY2, of "fh1 syn y"]
        by auto

      have Leq2 : "pcomps ft1 syn x <[ (pcomps (fh1 # ft1) syn y)"
        using leq_trans[OF Ind, of "(pcomps (fh1 # ft1) syn y)"]
          is_supD1[OF SupY2, of "pcomps ft1 syn y"]
        by auto

      show ?thesis
        unfolding is_ub_def using Leq1 Leq2
        by auto
    qed

    show ?thesis using is_supD2[OF SupX2 Ub_conc]
      by auto
  qed
qed
*)

lemma pcomps_comm' :
  assumes H : "sups_pres {f1, f2} S"
  assumes Hx : "x \<in> S syn"
  shows "pcomps [f1, f2] syn x = pcomps [f2, f1] syn x"
proof-

  have H0 : "sups_pres (set [f1, f2]) S" using H
    by simp

  have Comm : "set [f1, f2] = set [f2, f1]"
    by(auto)

  have H1 : "sups_pres (set [f2, f1]) S" using H Comm
    by(simp)

  have SupAll1 : "is_sup ((\<lambda> f . f syn x) ` (set [f1, f2])) (pcomps [f1, f2] syn x)"
    using sups_pres_pcomps_sup'[OF H0, of x syn] Hx
    by auto

  have SupAll2 : "is_sup ((\<lambda> f . f syn x) ` (set [f2, f1])) (pcomps [f2, f1] syn x)"
    using sups_pres_pcomps_sup'[OF H1, of x syn] Hx
    by auto

  hence SupAll2' : "is_sup ((\<lambda> f . f syn x) ` (set [f1, f2])) (pcomps [f2, f1] syn x)"
    unfolding Comm by simp

  thus "(pcomps [f1, f2] syn x) = (pcomps [f2, f1] syn x)"
    using is_sup_unique[OF SupAll1 SupAll2'] by simp
qed

lemma sups_pres_pcomps_fuse :
  assumes H : "sups_pres (set l1 \<union> set l2) S"
  assumes Hnemp1 : "l1 \<noteq> []"
  assumes Hnemp2 : "l2 \<noteq> []"
  shows "sups_pres {pcomps l1, pcomps l2} S"
proof(rule sups_presI)
  fix el :: "'b"
  fix sup1 :: "'b"
  fix syn
  fix Fs_sub :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) set"
  fix f

  assume H'_in : "sup1 \<in> S syn"
  assume Hfs_sub : "Fs_sub \<subseteq> {pcomps l1, pcomps l2}"
  assume Hnemp_Fs_sub : "f \<in> Fs_sub"

  have Pres' : "sups_pres (set (l1 @ l2)) S" using H by simp

  obtain f1 where F1 : "f1 \<in> set l1" using Hnemp1
    by(cases l1; auto)

  then have F1' : "l1 \<noteq> []"
    by auto

  have Pres1 : "sups_pres (set l1) S"
    using sups_pres_subset[OF H _ _ F1] by auto

  obtain f2 where F2: "f2 \<in> set l2" using Hnemp2
    by(cases l2; auto)

  then have F2' : "l2 \<noteq> []"
    by auto

  have Pres2 : "sups_pres (set l2) S"
    using sups_pres_subset[OF H _ _ F2] by auto

  obtain g where Nemp' : "g \<in> set (l1 @ l2)"
    using Hnemp1 by(cases l1; auto)

  then have Nemp'' : "l1 @ l2 \<noteq> []"
    by auto

  have Sup : "is_sup ((\<lambda>f. f syn sup1) ` set (l1 @ l2)) (pcomps (l1 @ l2) syn sup1)"
    using sups_pres_pcomps_sup'[OF Pres' Nemp'' H'_in]
    by simp

  have Eq: "\<And> z' . z' \<in> S syn \<Longrightarrow> pcomps (l1 @ l2) syn z' = pcomps [pcomps l1, pcomps l2] syn z'"
    using pcomps_assoc[OF H Hnemp1 Hnemp2] by simp

  have Sup1 : "is_sup ((\<lambda>f. f syn sup1) ` set l1) (pcomps l1 syn sup1)"
    using sups_pres_pcomps_sup'[OF Pres1 F1' H'_in]
    by auto

  have Sup2 : "is_sup ((\<lambda>f. f syn sup1) ` set l2) (pcomps l2 syn sup1)"
    using sups_pres_pcomps_sup'[OF Pres2 F2' H'_in]
    by auto

  have Unfold : "(\<lambda>f. f syn sup1) ` set l1 \<union> (\<lambda>f. f syn sup1) ` set l2 = (\<lambda> f . f syn sup1) ` set( l1 @ l2)"
    by(auto)

  have Sup12 : "is_sup ((\<lambda>f. f syn sup1) ` {pcomps l1, pcomps l2}) (pcomps (l1 @ l2) syn sup1)"
    using sup_union2[OF Sup1 Sup2, of "pcomps (l1 @ l2) syn sup1" ] Sup
    unfolding Unfold
    by(auto)

  consider (Emp) "Fs_sub = {}" |
           (L1) "Fs_sub = {pcomps l1}" |
           (L2) "Fs_sub = {pcomps l2}" |
           (L1_2) "Fs_sub = {pcomps l1, pcomps l2}"
    using Hfs_sub by blast
  then show "has_sup ((\<lambda>f. f syn sup1) ` Fs_sub)"
  proof cases
    case Emp
    then show ?thesis using Hnemp_Fs_sub by auto
  next
(* TODO: this should be a lemma *)
    case L1

    have C1 : "is_sup ((\<lambda>f. f syn sup1) ` Fs_sub) (pcomps l1 syn sup1)"
      using sup_singleton unfolding L1 by auto

    then show ?thesis
      by(auto simp add: has_sup_def)

  next
    case L2

    have C1 : "is_sup ((\<lambda>f. f syn sup1) ` Fs_sub) (pcomps l2 syn sup1)"
      using sup_singleton unfolding L2 by auto

    then show ?thesis
      by(auto simp add: has_sup_def)

  next
    case L1_2

    have C1 : "is_sup ((\<lambda>f. f syn sup1) ` Fs_sub) (pcomps (l1 @ l2) syn sup1)"
      using Sup12 unfolding L1_2 by auto

    then show ?thesis
      by(auto simp add: has_sup_def)
  qed
qed

lemma pcomps_comm :
  assumes H : "sups_pres (set l1 \<union> set l2) S"
  assumes Nemp1 : "l1 \<noteq> []"
  assumes Nemp2 : "l2 \<noteq> []"
  assumes Hx : "x \<in> S syn"
  shows "pcomps (l1 @ l2) syn x = pcomps (l2 @ l1) syn x"
proof-

  have Assoc: "pcomps (l1 @ l2) syn x = pcomps [pcomps l1, pcomps l2] syn x"
    using pcomps_assoc[OF H Nemp1 Nemp2 Hx] by auto

  have H_alt : "sups_pres (set (l1 @ l2)) S"
    using H by auto

  have Pres' : "sups_pres {pcomps l1, pcomps l2} S"
    using sups_pres_pcomps_fuse[OF H Nemp1 Nemp2] by simp

  have Comm : "pcomps [pcomps l1, pcomps l2] syn x = pcomps [pcomps l2, pcomps l1] syn x"
    using pcomps_comm'[OF Pres' Hx] by auto

  have Pres'' : "sups_pres (set l2 \<union> set l1) S"
    using H unfolding Un_commute[of "set l1" "set l2"] by simp

  have Conc' : "pcomps [pcomps l2, pcomps l1] syn x = pcomps (l2 @ l1) syn x"
    using pcomps_assoc[OF Pres'' Nemp2 Nemp1 Hx] by auto

  show "pcomps (l1 @ l2) syn x = pcomps (l2 @ l1) syn x"
    using Assoc Comm Conc' by simp
qed

lemma pcomps_set_eq1 :
  assumes H : "sups_pres Fs S"
  assumes Hf : "f \<in> Fs"
  assumes Hl1 : "set l1 = Fs"
  assumes Hx : "x \<in> S syn"
  shows "pcomps (f # l1) syn x = pcomps l1 syn x"
  using assms
proof(induction l1 arbitrary: f Fs)
  case Nil
  then show ?case by auto
next
  case (Cons l1h l1t)

  show ?case
  proof(cases l1t)
    case Nil' : Nil

    then have L1h_eq : "l1h = f"
      using Cons.prems by auto

    then show ?thesis
      using bsup_idem
      unfolding L1h_eq Nil' pcomps.simps
      by auto
  next
    case Cons' : (Cons l2h l2t)

    have S_eq : "(set [f, l1h] \<union> set l1t) = Fs"
      using Cons.prems Cons'
      by(auto)

    have Pres' : "sups_pres (set [f, l1h] \<union> set l1t) S"
      using Cons.prems(1) unfolding S_eq by simp

    have Assoc : "pcomps (f # l1h # l1t) syn x = pcomps [pcomps [f, l1h], pcomps l1t] syn x"
      using pcomps_assoc[OF Pres' _ _ Hx] Cons' H
      by auto

    have Pres_h : "sups_pres {f, l1h} S"
      using sups_pres_subset[OF Cons.prems(1), of "{f, l1h}" f] Cons.prems
      by(auto)

    have Comm : "pcomps [f, l1h] syn x = pcomps [l1h, f] syn x"
      using pcomps_comm'[OF Pres_h Hx] by simp

    have S_eq' : "(set [l1h, f] \<union> set l1t) = Fs"
      using Cons.prems Cons'
      by(auto)

    have Pres'' : "sups_pres (set [l1h, f] \<union> set l1t) S"
      using Cons.prems(1) unfolding S_eq' by simp

    have Assoc' : "pcomps [pcomps [l1h, f], pcomps l1t] syn x = pcomps (l1h#f#l1t) syn x"
      using sym[OF pcomps_assoc[OF Pres'' _ _ Hx]] Cons' by auto

    have Rewritten1 :
      "pcomps (f # l1h # l1t) syn x = pcomps [pcomps [l1h, f], pcomps l1t] syn x"
      using Assoc Comm Assoc'
      by auto

    have Pres''' : "sups_pres (set [f] \<union> set l1t) S"
      using sups_pres_subset[OF Pres', of "set [f] \<union> set l1t" ]
      by(auto)

    have Rewritten2 :
      "pcomps (f # l1h # l1t) syn x = pcomps (l1h#f#l1t) syn x"
      unfolding Rewritten1 Assoc' by simp

    show ?thesis
    proof(cases "f = l1h")
      case True

      have Eq : "pcomps [l1h, f] = pcomps [f]" unfolding True pcomps.simps
        using bsup_idem
        by blast

      have Conc' :
        "pcomps [pcomps [f], pcomps l1t] syn x = pcomps (f # l1t) syn x"
        using pcomps_assoc[OF Pres'''] Cons' by auto

      then show ?thesis using True unfolding Rewritten1 Eq
        by auto
    next
      case False

      then have F_in_t : "f \<in> set l1t"
        using Cons.prems
        by auto

      have Pres_t : "sups_pres (set l1t) S"
        using sups_pres_subset[OF Cons.prems(1) _ _ F_in_t] Cons.prems
        by auto

      have IH_spec : "pcomps (f # l1t) syn x = pcomps l1t syn x"
        using Cons.IH[OF Pres_t F_in_t _ Hx]
        by auto

      show ?thesis using F_in_t unfolding Rewritten2 unfolding pcomps.simps unfolding IH_spec
        by(cases l1t; auto)
    qed
  qed
qed

lemma pcomps_singleton :
  assumes Pres : "sups_pres {f} S"
  assumes H : "set l = {f}"
  assumes Hx : "x \<in> S syn"
  shows "pcomps l syn x = f syn x" using assms
proof(induction l arbitrary: f)
  case Nil
  then show ?case by auto
next
  case (Cons l1h l1t)

  then have L1h : "l1h = f" by auto

  show ?case
  proof(cases l1t)
    case Nil' : Nil

    then show ?thesis using L1h Cons
      by auto
  next

    case Cons' : (Cons l2h l2t)

    have L1t : "set l1t = {f}"
      using Cons Cons'
      by auto

    have Conc' : "pcomps (f # l1t) syn x = pcomps l1t syn x"
      using pcomps_set_eq1[OF Cons.prems(1) _ L1t Hx]
      by(auto)

    then show ?thesis using Cons.IH[OF Cons.prems(1) L1t Hx]
      unfolding L1h
      by auto
  qed
qed

lemma pcomps_swap :
  assumes H : "sups_pres (set (f1 # f2 # l1)) S"
  assumes Hx : "x \<in> S syn"
  shows "pcomps (f1 # f2 # l1) syn x = pcomps (f2 # f1 # l1) syn x"
proof(cases l1)
  case Nil

  have Pres' : "sups_pres {f1, f2} S"
    using sups_pres_subset[OF H, of "{f1, f2}" f1]
    by auto

  have Comm: "pcomps [f1, f2] syn x = pcomps [f2, f1] syn x"
    using pcomps_comm'[OF Pres' Hx]
    by simp

  then show ?thesis using Nil
    by auto
next
  case (Cons l1h l1t)

  have Pres' : "sups_pres {f1, f2} S"
    using sups_pres_subset[OF H, of "{f1, f2}" f1]
    by auto

  have Eq1: "set (f1 # f2 # l1) = (set [f1, f2] \<union> set (l1))"
    by auto

  then have Assoc1 : "pcomps ([f1, f2] @ l1) syn x = pcomps [pcomps [f1, f2], pcomps (l1)] syn x"
    using pcomps_assoc[of "[f1, f2]" "l1"] H Cons Hx
    by(auto)

  have Comm: "pcomps [f1, f2] syn x = pcomps [f2, f1] syn x"
    using pcomps_comm'[OF Pres' Hx]
    by simp

  have Set_comm : "set (f2 # f1 # l1) = set (f1 # f2 # l1)"
    by auto

  have H' : "sups_pres (set (f2 # f1 # l1)) S"
    using H unfolding Set_comm
    by auto

  have Eq2: "set (f2 # f1 # l1) = (set [f2, f1] \<union> set (l1))"
    by auto

  then have Assoc2 : "pcomps ([f2, f1] @ l1) syn x = pcomps [pcomps [f2, f1], pcomps l1] syn x"
    using pcomps_assoc[of "[f2, f1]" "l1"] H' Cons Hx
    by(auto)

  show ?thesis using Assoc1 Assoc2 Comm
    by(auto)
qed

lemma pcomps_removeAll' :
  assumes H : "sups_pres Fs S"
  assumes Hf : "f \<in> Fs"
  assumes Hl1 : "set l1 = Fs"
  assumes Hx : "x \<in> S syn"
  shows "pcomps (f # l1) syn x = pcomps (f # (removeAll f l1)) syn x"
  using assms
proof(induction l1 arbitrary: f Fs)
  case Nil
  then show ?case by auto
next
  case (Cons l1h l1t)

  show ?case
  proof(cases l1t)
    case Nil' : Nil
    show ?thesis
    proof(cases "f = l1h")
      case True

      have Conc' : "(\<lambda>a b. [^ l1h a b, l1h a b ^]) = l1h"
      proof(rule ext; rule ext)
        fix a b

        show "[^ l1h a b, l1h a b ^] = l1h a b"
          using bsup_idem[of "l1h a b"] by simp
      qed

      hence Conc'' : "[^ l1h syn x, l1h syn x ^] = l1h syn x"
        using fun_cong[OF fun_cong[OF Conc']] by auto

      show ?thesis using Cons.prems Nil' Conc''
        by simp
    next
      case False
      then show ?thesis using Cons Nil'
        by(simp)
    qed
  next
    case Cons' : (Cons l1h2 l1t2)

    have Pres' : "sups_pres (set l1t) S"
      using sups_pres_subset[OF Cons.prems(1) _, of "set l1t" l1h2]
        Cons.prems
      unfolding  Cons'
      by auto

    show ?thesis
    proof(cases "f \<in> set l1t")
      case True

      show ?thesis
      proof(cases "f = l1h")
        case True' : True

        have IndHyp : "pcomps (f # l1t) syn x = pcomps (f # removeAll f l1t) syn x"
          using Cons.IH[OF Pres' True] Cons.prems
          by simp

        show ?thesis
          using pcomps_cons_same[of l1h l1t] IndHyp True'
          by(auto)
      next
        case False' : False

        have Pres1 : "sups_pres (set (f # l1h # l1t)) S"
          using sups_pres_subset[OF Cons.prems(1), of "set (f # l1h # l1t)" f] Cons' Cons.prems
          by auto

        have Swap: "pcomps (f # l1h # l1t) syn x = pcomps (l1h # f # l1t) syn x"
          using pcomps_swap[OF Pres1] Cons.prems
          by simp

        have IndHyp : "pcomps (f # l1t) syn x = pcomps (f # removeAll f l1t) syn x"
          using Cons.IH[OF Pres' True] Cons.prems
          by simp

        have Subset2 : "set (f # l1h # removeAll f l1t) \<subseteq> Fs"
          using Cons.prems Cons' False'
          by(auto)

        have Pres2 : "sups_pres (set (f # l1h # removeAll f l1t)) S"
          using sups_pres_subset[OF Cons.prems(1) _ Subset2, of f] Cons.prems
          by auto

        have SetEq : "set (l1h # f # removeAll f l1t) = set (f # l1h # removeAll f l1t)"
          by auto

        then have Pres2' : "sups_pres (set (l1h # f # removeAll f l1t)) S"
          using Pres2 by auto

        have SetEq' : "set (l1h # f # removeAll f l1t) = (set [l1h] \<union> set (f # removeAll f l1t))"
          by auto

        then have Pres2'' : "sups_pres (set [l1h] \<union> set (f # removeAll f l1t)) S"
          using Pres2' by auto

        have Swap' : "pcomps (f # l1h # removeAll f l1t) syn x = pcomps (l1h#f#removeAll f l1t) syn x"
          using pcomps_swap[OF Pres2] Cons.prems by simp

        have Assoc1 : "pcomps (l1h # f # l1t) syn x = pcomps [pcomps [l1h], pcomps (f#l1t)] syn x"
          using pcomps_assoc[of "[l1h]" "f#l1t" S x syn] Pres1 Cons.prems
          by auto

        have Assoc2 : "pcomps (l1h#f#removeAll f l1t) syn x = pcomps [pcomps [l1h], pcomps (f# removeAll f l1t)] syn x"
          using pcomps_assoc[of "[l1h]" "f#removeAll f l1t"] Pres2''
          by auto

        show ?thesis
          using Swap Assoc1 Swap' Assoc2 IndHyp False'
          by(auto)
      qed
    next
      case False

      show ?thesis
      proof(cases "f = l1h")
        case True' : True

        show ?thesis using False True' pcomps_cons_same[of l1h l1t]
          by(auto)

      next
        case False' : False

        have Noop : "removeAll f (l1h # l1t) = l1h # l1t"
          using False  False'
          by auto

        show ?thesis using Noop by simp
      qed
    qed
  qed
qed

lemma pcomps_removeAll :
  assumes H : "sups_pres Fs S"
  assumes Hf : "f \<in> Fs"
  assumes Hl1 : "set l1 = Fs"
  assumes Hx : "x \<in> S syn"
  shows "pcomps (l1) syn x = pcomps (f # (removeAll f l1)) syn x"
  using pcomps_set_eq1[OF H Hf Hl1 Hx]
    pcomps_removeAll'[OF H Hf Hl1 Hx]
  by auto

lemma pcomps_set_eq :
  assumes H : "sups_pres Fs S"
  assumes Hf : "f \<in> Fs"
  assumes Hl1 : "set l1 = Fs"
  assumes Hl2 : "set l2 = Fs"
  assumes Hx : "x \<in> S syn"
  shows "pcomps l1 syn x = pcomps l2 syn x"
  using assms
proof(induction l1 arbitrary: Fs f l2)
  case Nil1_1 : Nil
  then show ?case
    by(cases l2; auto)
next
  case Cons1_1 : (Cons l1h1 l1t1)

  show ?case
  proof(cases l1t1)
    case Nil1_2 : Nil

    show ?thesis
    proof(cases l2)
      case Nil2_1 : Nil
      then show ?thesis
        using Cons1_1 Nil1_2
        by(auto)
    next
      case Cons2_1 : (Cons l2h1 l2t)

      then have L2 : "set l2 = {l1h1}"
        using Cons1_1.prems Nil1_2
        by(auto)

      have L1h1_pres : "sups_pres {l1h1} S"
        using sups_pres_subset[OF Cons1_1.prems(1), of "{l1h1}" l1h1] Cons1_1.prems
        by auto

      have L2_eq : "pcomps l2 syn x = l1h1 syn x"
        using pcomps_singleton[OF L1h1_pres L2] Cons1_1.prems
        by simp

      then show ?thesis
        unfolding L2_eq Nil1_2
        by simp
    qed
  next

    case Cons1_2 : (Cons l1h2 l1t2)
    show ?thesis
    proof(cases l2)
      case Nil2_1 : Nil
      then show ?thesis
        using Cons1_2 Cons1_1.prems
        by(auto)
    next
      case Cons2_1 : (Cons l2h1 l2t)

      have Pres' : "sups_pres (set (l1h2 # l1t2)) S"
        using sups_pres_subset[OF Cons1_1.prems(1), of "set (l1h2 # l1t2)" l1h2]
          Cons1_1.prems(3)
        unfolding Cons1_2
        by(auto)

      show ?thesis
      proof(cases "l1h1 \<in> set l1t1")
        case True

        hence True' : "pcomps l1t1 syn x = pcomps (l1h1#l1t1) syn x"
          using pcomps_set_eq1[OF Pres', of l1h1 "(l1h2#l1t2)"] Cons1_1.prems
          unfolding Cons1_2 by auto

        have Set : "set l1t1 = Fs"
          using True Cons1_1.prems unfolding Cons1_2
          by auto

        then show ?thesis using Cons1_1.IH[OF Cons1_1.prems(1) Cons1_1.prems(2) Set Cons1_1.prems(4)] Cons1_1.prems
          unfolding True'
          by simp
      next
        case False

        have Removed : "pcomps l2 syn x = pcomps (l1h1 # removeAll l1h1 l2) syn x"
          using pcomps_removeAll[of "set l2" "S" "l1h1" "l2"]
            Cons1_1.prems Cons2_1
          by auto

        have Set_eq : "set (removeAll l1h1 l2) = set l1t1"
          using False Cons1_1.prems
          by auto

        have Ind_hyp : "pcomps l1t1 syn x = pcomps (removeAll l1h1 l2) syn x"
          using Cons1_1.IH[OF _ _ _ Set_eq] Pres' Cons1_2 Cons1_1.prems
          by auto

        have Eq1 : "set (l1h1 # l1t1) = set [l1h1] \<union> set l1t1"
          by auto

        have Pres1 : "sups_pres (set [l1h1] \<union> set l1t1) S"
          using Cons1_1.prems Eq1
          by auto

        have Assoc1 : "pcomps (l1h1 # l1t1) syn x = pcomps [ pcomps [l1h1], pcomps l1t1] syn x"
          using pcomps_assoc[OF Pres1] Cons1_2
          by auto

        have Eq2 : "set (l1h1 # removeAll l1h1 l2) = set [l1h1] \<union> set (removeAll l1h1 l2)"
          by auto

        have Pres2 : "sups_pres (set [l1h1] \<union> set (removeAll l1h1 l2)) S"
          using Cons1_1.prems Eq1
          by auto

        show ?thesis
        proof(cases "set l1t1 = {l1h1}")
          case True' : True

          then have False using False by auto

          then show ?thesis by auto
        next
          case False' : False

          then obtain new where New_set : "new \<in> set l1t1" and New_noteq : "new \<noteq> l1h1"
            using Cons1_2
            by auto

          have New_set' : "new \<in> set l2" using Cons1_1.prems New_set
            by auto

          have New_in_2 : "new \<in> set (removeAll l1h1 l2)"
            using Cons1_1.prems New_set' New_noteq set_removeAll[of l1h1 l2]
            by auto

          then have Not_empty2 : "removeAll l1h1 l2 \<noteq> []"
            by(cases "removeAll l1h1 l2"; auto)

          have Assoc2 : "pcomps (l1h1 # removeAll l1h1 l2) syn x = pcomps [ pcomps [l1h1], pcomps (removeAll l1h1 l2)] syn x"
            using pcomps_assoc[OF Pres2 _ Not_empty2] Cons1_1.prems
            by auto

          show ?thesis using Ind_hyp Removed Assoc1 Assoc2
            by(auto)
        qed
      qed
    qed
  qed
qed

end


(*  Title:     HOL/Probability/Helly_Selection.thy
    Authors:   Jeremy Avigad (CMU), Luke Serafin (CMU)
    Authors:   Johannes Hölzl, TU München
*)

section \<open>Helly's selection theorem\<close>

text \<open>The set of bounded, monotone, right continuous functions is sequentially compact\<close>

theory Helly_Selection
  imports "HOL-Library.Diagonal_Subsequence" Weak_Convergence
begin

lemma minus_one_less: "x - 1 < (x::real)"
  by simp

theorem Helly_selection:
  fixes f :: "nat \<Rightarrow> real \<Rightarrow> real"
  assumes rcont: "\<And>n x. continuous (at_right x) (f n)"
  assumes mono: "\<And>n. mono (f n)"
  assumes bdd: "\<And>n x. \<bar>f n x\<bar> \<le> M"
  shows "\<exists>s. strict_mono (s::nat \<Rightarrow> nat) \<and> (\<exists>F. (\<forall>x. continuous (at_right x) F) \<and> mono F \<and> (\<forall>x. \<bar>F x\<bar> \<le> M) \<and>
    (\<forall>x. continuous (at x) F \<longrightarrow> (\<lambda>n. f (s n) x) \<longlonglongrightarrow> F x))"
proof -
  obtain m :: "real \<Rightarrow> nat" where "bij_betw m \<rat> UNIV"
    using countable_rat Rats_infinite by (erule countableE_infinite)
  then obtain r :: "nat \<Rightarrow> real" where bij: "bij_betw r UNIV \<rat>"
    using bij_betw_inv by blast

  have dense_r: "\<And>x y. x < y \<Longrightarrow> \<exists>n. x < r n \<and> r n < y"
    by (metis Rats_dense_in_real bij f_the_inv_into_f bij_betw_def)

  let ?P = "\<lambda>n. \<lambda>s. convergent (\<lambda>k. f (s k) (r n))"
  interpret nat: subseqs ?P
  proof (unfold convergent_def, unfold subseqs_def, auto)
    fix n :: nat and s :: "nat \<Rightarrow> nat" assume s: "strict_mono s"
    have "bounded {-M..M}"
      using bounded_closed_interval by auto
    moreover have "\<And>k. f (s k) (r n) \<in> {-M..M}"
      using bdd by (simp add: abs_le_iff minus_le_iff)
    ultimately have "\<exists>l s'. strict_mono s' \<and> ((\<lambda>k. f (s k) (r n)) \<circ> s') \<longlonglongrightarrow> l"
      using compact_Icc compact_imp_seq_compact seq_compactE by metis
    thus "\<exists>s'. strict_mono (s'::nat\<Rightarrow>nat) \<and> (\<exists>l. (\<lambda>k. f (s (s' k)) (r n)) \<longlonglongrightarrow> l)"
      by (auto simp: comp_def)
  qed
  define d where "d = nat.diagseq"
  have subseq: "strict_mono d"
    unfolding d_def using nat.subseq_diagseq by auto
  have rat_cnv: "?P n d" for n
  proof -
    have Pn_seqseq: "?P n (nat.seqseq (Suc n))"
      by (rule nat.seqseq_holds)
    have 1: "(\<lambda>k. f ((nat.seqseq (Suc n) \<circ> (\<lambda>k. nat.fold_reduce (Suc n) k
      (Suc n + k))) k) (r n)) = (\<lambda>k. f (nat.seqseq (Suc n) k) (r n)) \<circ>
      (\<lambda>k. nat.fold_reduce (Suc n) k (Suc n + k))"
      by auto
    have 2: "?P n (d \<circ> ((+) (Suc n)))"
      unfolding d_def nat.diagseq_seqseq 1
      by (intro convergent_subseq_convergent Pn_seqseq nat.subseq_diagonal_rest)
    then obtain L where 3: "(\<lambda>na. f (d (na + Suc n)) (r n)) \<longlonglongrightarrow> L"
      by (auto simp: add.commute dest: convergentD)
    then have "(\<lambda>k. f (d k) (r n)) \<longlonglongrightarrow> L"
      by (rule LIMSEQ_offset)
    then show ?thesis
      by (auto simp: convergent_def)
  qed
  let ?f = "\<lambda>n. \<lambda>k. f (d k) (r n)"
  have lim_f: "?f n \<longlonglongrightarrow> lim (?f n)" for n
    using rat_cnv convergent_LIMSEQ_iff by auto
  have lim_bdd: "lim (?f n) \<in> {-M..M}" for n
  proof -
    have "closed {-M..M}" using closed_real_atLeastAtMost by auto
    hence "(\<forall>i. ?f n i \<in> {-M..M}) \<and> ?f n \<longlonglongrightarrow> lim (?f n) \<longrightarrow> lim (?f n) \<in> {-M..M}"
      unfolding closed_sequential_limits by (drule_tac x = "\<lambda>k. f (d k) (r n)" in spec) blast
    moreover have "\<forall>i. ?f n i \<in> {-M..M}"
      using bdd by (simp add: abs_le_iff minus_le_iff)
    ultimately show "lim (?f n) \<in> {-M..M}"
      using lim_f by auto
  qed
  then have limset_bdd: "\<And>x. {lim (?f n) |n. x < r n} \<subseteq> {-M..M}"
    by auto
  then have bdd_below: "bdd_below {lim (?f n) |n. x < r n}" for x
    by (metis (mono_tags) bdd_below_Icc bdd_below_mono)
  have r_unbdd: "\<exists>n. x < r n" for x
    using dense_r[OF less_add_one, of x] by auto
  then have nonempty: "{lim (?f n) |n. x < r n} \<noteq> {}" for x
    by auto

  define F where "F x = Inf {lim (?f n) |n. x < r n}" for x
  have F_eq: "ereal (F x) = (INF n\<in>{n. x < r n}. ereal (lim (?f n)))" for x
    unfolding F_def by (subst ereal_Inf'[OF bdd_below nonempty]) (simp add: setcompr_eq_image image_comp)
  have mono_F: "mono F"
    using nonempty by (auto intro!: cInf_superset_mono simp: F_def bdd_below mono_def)
  moreover have "\<And>x. continuous (at_right x) F"
    unfolding continuous_within order_tendsto_iff eventually_at_right[OF less_add_one]
  proof safe
    show "F x < u \<Longrightarrow> \<exists>b>x. \<forall>y>x. y < b \<longrightarrow> F y < u" for x u
      unfolding F_def cInf_less_iff[OF nonempty bdd_below] by auto
  next
    show "\<exists>b>x. \<forall>y>x. y < b \<longrightarrow> l < F y" if l: "l < F x" for x l
      using less_le_trans[OF l mono_F[THEN monoD, of x]] by (auto intro: less_add_one)
  qed
  moreover
  { fix x
    have "F x \<in> {-M..M}"
      unfolding F_def using limset_bdd bdd_below r_unbdd by (intro closed_subset_contains_Inf) auto
    then have "\<bar>F x\<bar> \<le> M" by auto }
  moreover have "(\<lambda>n. f (d n) x) \<longlonglongrightarrow> F x" if cts: "continuous (at x) F" for x
  proof (rule limsup_le_liminf_real)
    show "limsup (\<lambda>n. f (d n) x) \<le> F x"
    proof (rule tendsto_lowerbound)
      show "(F \<longlongrightarrow> ereal (F x)) (at_right x)"
        using cts unfolding continuous_at_split by (auto simp: continuous_within)
      show "\<forall>\<^sub>F i in at_right x. limsup (\<lambda>n. f (d n) x) \<le> F i"
        unfolding eventually_at_right[OF less_add_one]
      proof (rule, rule, rule less_add_one, safe)
        fix y assume y: "x < y"
        with dense_r obtain N where "x < r N" "r N < y" by auto
        have *: "y < r n' \<Longrightarrow> lim (?f N) \<le> lim (?f n')" for n'
          using \<open>r N < y\<close> by (intro LIMSEQ_le[OF lim_f lim_f]) (auto intro!: mono[THEN monoD])
        have "limsup (\<lambda>n. f (d n) x) \<le> limsup (?f N)"
          using \<open>x < r N\<close> by (auto intro!: Limsup_mono always_eventually mono[THEN monoD])
        also have "\<dots> = lim (\<lambda>n. ereal (?f N n))"
          using rat_cnv[of N] by (force intro!: convergent_limsup_cl simp: convergent_def)
        also have "\<dots> \<le> F y"
          by (auto intro!: INF_greatest * simp: convergent_real_imp_convergent_ereal rat_cnv F_eq)
        finally show "limsup (\<lambda>n. f (d n) x) \<le> F y" .
      qed
    qed simp
    show "F x \<le> liminf (\<lambda>n. f (d n) x)"
    proof (rule tendsto_upperbound)
      show "(F \<longlongrightarrow> ereal (F x)) (at_left x)"
        using cts unfolding continuous_at_split by (auto simp: continuous_within)
      show "\<forall>\<^sub>F i in at_left x. F i \<le> liminf (\<lambda>n. f (d n) x)"
        unfolding eventually_at_left[OF minus_one_less]
      proof (rule, rule, rule minus_one_less, safe)
        fix y assume y: "y < x"
        with dense_r obtain N where "y < r N" "r N < x" by auto
        have "F y \<le> liminf (?f N)"
          using \<open>y < r N\<close> by (auto simp: F_eq convergent_real_imp_convergent_ereal
            rat_cnv convergent_liminf_cl intro!: INF_lower2)
        also have "\<dots> \<le> liminf (\<lambda>n. f (d n) x)"
          using \<open>r N < x\<close> by (auto intro!: Liminf_mono monoD[OF mono] always_eventually)
        finally show "F y \<le> liminf (\<lambda>n. f (d n) x)" .
      qed
    qed simp
  qed
  ultimately show ?thesis using subseq by auto
qed

(** Weak convergence corollaries to Helly's theorem. **)

definition
  tight :: "(nat \<Rightarrow> real measure) \<Rightarrow> bool"
where
  "tight \<mu> \<equiv> (\<forall>n. real_distribution (\<mu> n)) \<and> (\<forall>(\<epsilon>::real)>0. \<exists>a b::real. a < b \<and> (\<forall>n. measure (\<mu> n) {a<..b} > 1 - \<epsilon>))"

(* Can strengthen to equivalence. *)
theorem tight_imp_convergent_subsubsequence:
  assumes \<mu>: "tight \<mu>" "strict_mono s"
  shows "\<exists>r M. strict_mono (r :: nat \<Rightarrow> nat) \<and> real_distribution M \<and> weak_conv_m (\<mu> \<circ> s \<circ> r) M"
proof -
  define f where "f k = cdf (\<mu> (s k))" for k
  interpret \<mu>: real_distribution "\<mu> k" for k
    using \<mu> unfolding tight_def by auto

  have rcont: "\<And>x. continuous (at_right x) (f k)"
    and mono: "mono (f k)"
    and top: "(f k \<longlongrightarrow> 1) at_top"
    and bot: "(f k \<longlongrightarrow> 0) at_bot" for k
    unfolding f_def mono_def
    using \<mu>.cdf_nondecreasing \<mu>.cdf_is_right_cont \<mu>.cdf_lim_at_top_prob \<mu>.cdf_lim_at_bot by auto
  have bdd: "\<bar>f k x\<bar> \<le> 1" for k x
    by (auto simp add: abs_le_iff minus_le_iff f_def \<mu>.cdf_nonneg \<mu>.cdf_bounded_prob)

  from Helly_selection[OF rcont mono bdd, of "\<lambda>x. x"] obtain r F
    where F: "strict_mono r" "\<And>x. continuous (at_right x) F" "mono F" "\<And>x. \<bar>F x\<bar> \<le> 1"
    and lim_F: "\<And>x. continuous (at x) F \<Longrightarrow> (\<lambda>n. f (r n) x) \<longlonglongrightarrow> F x"
    by blast

  have "0 \<le> f n x" for n x
    unfolding f_def by (rule \<mu>.cdf_nonneg)
  have F_nonneg: "0 \<le> F x" for x
  proof -
    obtain y where "y < x" "isCont F y"
      using open_minus_countable[OF mono_ctble_discont[OF \<open>mono F\<close>], of "{..< x}"] by auto
    then have "0 \<le> F y"
      by (intro LIMSEQ_le_const[OF lim_F]) (auto simp: f_def \<mu>.cdf_nonneg)
    also have "\<dots> \<le> F x"
      using \<open>y < x\<close> by (auto intro!: monoD[OF \<open>mono F\<close>])
    finally show "0 \<le> F x" .
  qed

  have Fab: "\<exists>a b. (\<forall>x\<ge>b. F x \<ge> 1 - \<epsilon>) \<and> (\<forall>x\<le>a. F x \<le> \<epsilon>)" if \<epsilon>: "0 < \<epsilon>" for \<epsilon>
  proof auto
    obtain a' b' where a'b': "a' < b'" "\<And>k. measure (\<mu> k) {a'<..b'} > 1 - \<epsilon>"
      using \<epsilon> \<mu> by (auto simp: tight_def)
    obtain a where a: "a < a'" "isCont F a"
      using open_minus_countable[OF mono_ctble_discont[OF \<open>mono F\<close>], of "{..< a'}"] by auto
    obtain b where b: "b' < b" "isCont F b"
      using open_minus_countable[OF mono_ctble_discont[OF \<open>mono F\<close>], of "{b' <..}"] by auto
    have "a < b"
      using a b a'b' by simp

    let ?\<mu> = "\<lambda>k. measure (\<mu> (s (r k)))"
    have ab: "?\<mu> k {a<..b} > 1 - \<epsilon>" for k
    proof -
      have "?\<mu> k {a'<..b'} \<le> ?\<mu> k {a<..b}"
        using a b by (intro \<mu>.finite_measure_mono) auto
      then show ?thesis
        using a'b'(2) by (metis less_eq_real_def less_trans)
    qed

    have "(\<lambda>k. ?\<mu> k {..b}) \<longlonglongrightarrow> F b"
      using b(2) lim_F unfolding f_def cdf_def o_def by auto
    then have "1 - \<epsilon> \<le> F b"
    proof (rule tendsto_lowerbound, intro always_eventually allI)
      fix k
      have "1 - \<epsilon> < ?\<mu> k {a<..b}"
        using ab by auto
      also have "\<dots> \<le> ?\<mu> k {..b}"
        by (auto intro!: \<mu>.finite_measure_mono)
      finally show "1 - \<epsilon> \<le> ?\<mu> k {..b}"
        by (rule less_imp_le)
    qed (rule sequentially_bot)
    then show "\<exists>b. \<forall>x\<ge>b. 1 - \<epsilon> \<le> F x"
      using F unfolding mono_def by (metis order.trans)

    have "(\<lambda>k. ?\<mu> k {..a}) \<longlonglongrightarrow> F a"
      using a(2) lim_F unfolding f_def cdf_def o_def by auto
    then have Fa: "F a \<le> \<epsilon>"
    proof (rule tendsto_upperbound, intro always_eventually allI)
      fix k
      have "?\<mu> k {..a} + ?\<mu> k {a<..b} \<le> 1"
        by (subst \<mu>.finite_measure_Union[symmetric]) auto
      then show "?\<mu> k {..a} \<le> \<epsilon>"
        using ab[of k] by simp
    qed (rule sequentially_bot)
    then show "\<exists>a. \<forall>x\<le>a. F x \<le> \<epsilon>"
      using F unfolding mono_def by (metis order.trans)
  qed

  have "(F \<longlongrightarrow> 1) at_top"
  proof (rule order_tendstoI)
    show "1 < y \<Longrightarrow> \<forall>\<^sub>F x in at_top. F x < y" for y
      using \<open>\<And>x. \<bar>F x\<bar> \<le> 1\<close> \<open>\<And>x. 0 \<le> F x\<close> by (auto intro: le_less_trans always_eventually)
    fix y :: real assume "y < 1"
    then obtain z where "y < z" "z < 1"
      using dense[of y 1] by auto
    with Fab[of "1 - z"] show "\<forall>\<^sub>F x in at_top. y < F x"
      by (auto simp: eventually_at_top_linorder intro: less_le_trans)
  qed
  moreover
  have "(F \<longlongrightarrow> 0) at_bot"
  proof (rule order_tendstoI)
    show "y < 0 \<Longrightarrow> \<forall>\<^sub>F x in at_bot. y < F x" for y
      using \<open>\<And>x. 0 \<le> F x\<close> by (auto intro: less_le_trans always_eventually)
    fix y :: real assume "0 < y"
    then obtain z where "0 < z" "z < y"
      using dense[of 0 y] by auto
    with Fab[of z] show "\<forall>\<^sub>F x in at_bot. F x < y"
      by (auto simp: eventually_at_bot_linorder intro: le_less_trans)
  qed
  ultimately have M: "real_distribution (interval_measure F)" "cdf (interval_measure F) = F"
    using F by (auto intro!: real_distribution_interval_measure cdf_interval_measure simp: mono_def)
  with lim_F LIMSEQ_subseq_LIMSEQ M have "weak_conv_m (\<mu> \<circ> s \<circ> r) (interval_measure F)"
    by (auto simp: weak_conv_def weak_conv_m_def f_def comp_def)
  then show "\<exists>r M. strict_mono (r :: nat \<Rightarrow> nat) \<and> (real_distribution M \<and> weak_conv_m (\<mu> \<circ> s \<circ> r) M)"
    using F M by auto
qed

corollary tight_subseq_weak_converge:
  fixes \<mu> :: "nat \<Rightarrow> real measure" and M :: "real measure"
  assumes "\<And>n. real_distribution (\<mu> n)" "real_distribution M" and tight: "tight \<mu>" and
    subseq: "\<And>s \<nu>. strict_mono s \<Longrightarrow> real_distribution \<nu> \<Longrightarrow> weak_conv_m (\<mu> \<circ> s) \<nu> \<Longrightarrow> weak_conv_m (\<mu> \<circ> s) M"
  shows "weak_conv_m \<mu> M"
proof (rule ccontr)
  define f where "f n = cdf (\<mu> n)" for n
  define F where "F = cdf M"

  assume "\<not> weak_conv_m \<mu> M"
  then obtain x where x: "isCont F x" "\<not> (\<lambda>n. f n x) \<longlonglongrightarrow> F x"
    by (auto simp: weak_conv_m_def weak_conv_def f_def F_def)
  then obtain \<epsilon> where "\<epsilon> > 0" and "infinite {n. \<not> dist (f n x) (F x) < \<epsilon>}"
    by (auto simp: tendsto_iff not_eventually INFM_iff_infinite cofinite_eq_sequentially[symmetric])
  then obtain s :: "nat \<Rightarrow> nat" where s: "\<And>n. \<not> dist (f (s n) x) (F x) < \<epsilon>" and "strict_mono s"
    using enumerate_in_set enumerate_mono by (fastforce simp: strict_mono_def)
  then obtain r \<nu> where r: "strict_mono r" "real_distribution \<nu>" "weak_conv_m (\<mu> \<circ> s \<circ> r) \<nu>"
    using tight_imp_convergent_subsubsequence[OF tight] by blast
  then have "weak_conv_m (\<mu> \<circ> (s \<circ> r)) M"
    using \<open>strict_mono s\<close> r by (intro subseq strict_mono_o) (auto simp: comp_assoc)
  then have "(\<lambda>n. f (s (r n)) x) \<longlonglongrightarrow> F x"
    using x by (auto simp: weak_conv_m_def weak_conv_def F_def f_def)
  then show False
    using s \<open>\<epsilon> > 0\<close> by (auto dest: tendstoD)
qed

end


theory Exercise4
  imports Main
begin

fun snoc :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "snoc Nil x = Cons x Nil"
  | "snoc (Cons x xs) y = Cons x (snoc xs y)"

fun reverse :: "'a list \<Rightarrow> 'a list" where
  "reverse Nil = Nil"
  | "reverse (Cons x xs) = snoc (reverse xs) x"

lemma reverse_snoc [simp]: "reverse (snoc xs x) = Cons x (reverse xs)"
  apply (induction xs)
  apply (auto)
done

theorem double_reverse [simp]: "reverse (reverse xs) = xs"
  apply (induction xs)
  apply (auto)
done

end


(*  Title:      IP_Address.thy
    Authors:    Cornelius Diekmann
*)
theory IP_Address
  imports
    Word_Lib.Word_Lemmas
    Word_Lib.Word_Syntax
    Word_Lib.Reversed_Bit_Lists
    Hs_Compat
    WordInterval
begin

section \<open>Modelling IP Adresses\<close>
  text\<open>An IP address is basically an unsigned integer.
    We model IP addresses of arbitrary lengths.

    We will write @{typ "'i::len word"} for IP addresses of length @{term "LENGTH('i::len)"}.
    We use the convention to write @{typ 'i} whenever we mean IP addresses instead of generic words.
    When we will later have theorems with several polymorphic types in it (e.g. arbitrarily
    extensible packets), this notation makes it easier to spot that type @{typ 'i} is for
    IP addresses.

    The files @{file \<open>IPv4.thy\<close>} @{file \<open>IPv6.thy\<close>} concrete this for IPv4 and IPv6.\<close>

  text\<open>The maximum IP address\<close>
  definition max_ip_addr :: "'i::len word" where
    "max_ip_addr \<equiv> of_nat ((2^(len_of(TYPE('i)))) - 1)"

  lemma max_ip_addr_max_word: "max_ip_addr = - 1"
    by (simp only: max_ip_addr_def of_nat_mask_eq flip: mask_eq_exp_minus_1) simp

  lemma max_ip_addr_max: "\<forall>a. a \<le> max_ip_addr"
    by(simp add: max_ip_addr_max_word)
  lemma range_0_max_UNIV: "UNIV = {0 .. max_ip_addr}" (*not in the simp set, for a reason*)
    by(simp add: max_ip_addr_max_word) fastforce

  lemma "size (x::'i::len word) = len_of(TYPE('i))" by(simp add:word_size)

subsection\<open>Sets of IP Addresses\<close>
  (*Warning, not executable!*)
  text\<open>Specifying sets with network masks: 192.168.0.0 255.255.255.0\<close>
  definition ipset_from_netmask::"'i::len word \<Rightarrow> 'i::len word \<Rightarrow> 'i::len word set" where
    "ipset_from_netmask addr netmask \<equiv>
      let
        network_prefix = (addr AND netmask)
      in
        {network_prefix .. network_prefix OR (NOT netmask)}"

  text\<open>Example (pseudo syntax):
    @{const ipset_from_netmask} \<open>192.168.1.129  255.255.255.0\<close> =
        \<open>{192.168.1.0 .. 192.168.1.255}\<close>\<close>

  text\<open>A network mask of all ones (i.e. @{term "(- 1)::'i::len word"}).\<close>
  lemma ipset_from_netmask_minusone:
    "ipset_from_netmask ip (- 1) = {ip}" by (simp add: ipset_from_netmask_def)
  lemma ipset_from_netmask_maxword:
    "ipset_from_netmask ip (- 1) = {ip}" by (simp add: ipset_from_netmask_def)

  lemma ipset_from_netmask_zero:
    "ipset_from_netmask ip 0 = UNIV" by (auto simp add: ipset_from_netmask_def)

  text\<open>Specifying sets in Classless Inter-domain Routing (CIDR) notation: 192.168.0.0/24\<close>
  definition ipset_from_cidr ::"'i::len word \<Rightarrow> nat \<Rightarrow> 'i::len word set" where
    "ipset_from_cidr addr pflength \<equiv>
       ipset_from_netmask addr ((mask pflength) << (len_of(TYPE('i)) - pflength))"

  text\<open>Example (pseudo syntax):
    @{const ipset_from_cidr} \<open>192.168.1.129 24\<close> = \<open>{192.168.1.0 .. 192.168.1.255}\<close>\<close>

  (*does this simplify stuff?*)
  lemma "(case ipcidr of (base, len) \<Rightarrow> ipset_from_cidr base len) = uncurry ipset_from_cidr ipcidr"
    by(simp add: uncurry_case_stmt)

  lemma ipset_from_cidr_0: "ipset_from_cidr ip 0 = UNIV"
    by(auto simp add: ipset_from_cidr_def ipset_from_netmask_def Let_def)

  text\<open>A prefix length of word size gives back the singleton set with the IP address.
       Example: \<open>192.168.1.2/32 = {192.168.1.2}\<close>\<close>
  lemma ipset_from_cidr_wordlength:
    fixes ip :: "'i::len word"
    shows "ipset_from_cidr ip (LENGTH('i)) = {ip}"
    by (simp add: ipset_from_cidr_def ipset_from_netmask_def)

  text\<open>Alternative definition: Considering words as bit lists:\<close>
  lemma ipset_from_cidr_bl:
    fixes addr :: "'i::len word"
    shows "ipset_from_cidr addr pflength \<equiv>
            ipset_from_netmask addr (of_bl ((replicate pflength True) @
                                            (replicate ((len_of(TYPE('i))) - pflength)) False))"
    by(simp add: ipset_from_cidr_def mask_bl shiftl_of_bl)

  lemma ipset_from_cidr_alt:
    fixes pre :: "'i::len word"
    shows "ipset_from_cidr pre len =
            {pre AND (mask len << LENGTH('i) - len)
             ..
             pre OR mask (LENGTH('i) - len)}"
    apply(simp add: ipset_from_cidr_def ipset_from_netmask_def Let_def)
    apply(simp add: word_oa_dist)
    apply(simp add: NOT_mask_shifted_lenword)
    done

  lemma ipset_from_cidr_alt2:
    fixes base ::"'i::len word"
    shows "ipset_from_cidr base len =
           ipset_from_netmask base (NOT (mask (LENGTH('i) - len)))"
    apply(simp add: ipset_from_cidr_def)
    using NOT_mask_shifted_lenword by(metis word_not_not)

  text\<open>In CIDR notation, we cannot express the empty set.\<close>
  lemma ipset_from_cidr_not_empty: "ipset_from_cidr base len \<noteq> {}"
    by(simp add: ipset_from_cidr_alt bitmagic_zeroLast_leq_or1Last)

  text\<open>Though we can write 192.168.1.2/24, we say that 192.168.0.0/24 is well-formed.\<close>
  lemma ipset_from_cidr_base_wellforemd: fixes base:: "'i::len word"
    assumes "mask (LENGTH('i) - l) AND base = 0"
      shows "ipset_from_cidr base l = {base .. base OR mask (LENGTH('i) - l)}"
  proof -
    have maskshift_eq_not_mask_generic:
      "((mask l << LENGTH('i) - l) :: 'i::len word) = NOT (mask (LENGTH('i) - l))"
      using NOT_mask_shifted_lenword by (metis word_not_not)
    have *: "base AND NOT (mask (LENGTH('i) - l)) = base"
      unfolding mask_eq_0_eq_x[symmetric] using assms word_bw_comms(1)[of base] by simp
    hence **: "base AND NOT (mask (LENGTH('i) - l)) OR mask (LENGTH('i) - l) =
                base OR mask (LENGTH('i) - l)" by simp
    have "ipset_from_netmask base (NOT (mask (LENGTH('i) - l))) =
            {base .. base || mask (LENGTH('i) - l)}"
      by(simp add: ipset_from_netmask_def Let_def ** *)
    thus ?thesis by(simp add: ipset_from_cidr_def maskshift_eq_not_mask_generic)
  qed

  lemma ipset_from_cidr_large_pfxlen:
    fixes ip:: "'i::len word"
    assumes "n \<ge> LENGTH('i)"
    shows "ipset_from_cidr ip n = {ip}"
  proof -
    have obviously: "mask (LENGTH('i) - n) = 0" by (simp add: assms)
    show ?thesis
      apply(subst ipset_from_cidr_base_wellforemd)
       subgoal using assms by simp
      by (simp add: obviously)
  qed

  lemma ipset_from_netmask_base_mask_consume:
    fixes base :: "'i::len word"
    shows "ipset_from_netmask (base AND NOT (mask (LENGTH('i) - m)))
                              (NOT (mask (LENGTH('i) - m)))
            =
             ipset_from_netmask base (NOT (mask (LENGTH('i) - m)))"
    unfolding ipset_from_netmask_def by(simp)

  text\<open>Another definition of CIDR notation:
       All IP address which are equal on the first @{term "len - n"} bits\<close>
  definition ip_cidr_set :: "'i::len word \<Rightarrow> nat \<Rightarrow> 'i word set" where
    "ip_cidr_set i r \<equiv>
      {j . i AND NOT (mask (LENGTH('i) - r)) = j AND NOT (mask (LENGTH('i) - r))}"

  text\<open>The definitions are equal\<close>
  lemma ipset_from_cidr_eq_ip_cidr_set:
    fixes base::"'i::len word"
    shows "ipset_from_cidr base len = ip_cidr_set base len"
  proof -
    have maskshift_eq_not_mask_generic:
      "((mask len << LENGTH('a) - len) :: 'a::len word) = NOT (mask (LENGTH('a) - len))"
      using NOT_mask_shifted_lenword by (metis word_not_not)
    have 1: "mask (len - m) AND base AND NOT (mask (len - m)) = 0"
      for len m and base::"'i::len word"
      by(simp add: word_bw_lcs)
    have 2: "mask (LENGTH('i) - len) AND pfxm_p = 0 \<Longrightarrow>
           (a \<in> ipset_from_netmask pfxm_p (NOT (mask (LENGTH('i) - len)))) \<longleftrightarrow>
           (pfxm_p = NOT (mask (LENGTH('i) - len)) AND a)" for a::"'i::len word" and pfxm_p
    apply(subst ipset_from_cidr_alt2[symmetric])
    apply(subst zero_base_lsb_imp_set_eq_as_bit_operation)
     apply(simp; fail)
    apply(subst ipset_from_cidr_base_wellforemd)
     apply(simp; fail)
    apply(simp)
    done
    from 2[OF 1, of _ base] have
      "(x \<in> ipset_from_netmask base (~~ (mask (LENGTH('i) - len)))) \<longleftrightarrow>
       (base && ~~ (mask (LENGTH('i) - len)) = x && ~~ (mask (LENGTH('i) - len)))" for x
    apply(simp add: ipset_from_netmask_base_mask_consume)
    unfolding word_bw_comms(1)[of _ " ~~ (mask (LENGTH('i) - len))"] by simp
    then show ?thesis
      unfolding ip_cidr_set_def ipset_from_cidr_def
      by(auto simp add:  maskshift_eq_not_mask_generic)
  qed

  lemma ip_cidr_set_change_base: "j \<in> ip_cidr_set i r \<Longrightarrow> ip_cidr_set j r = ip_cidr_set i r"
    by (auto simp: ip_cidr_set_def)

subsection\<open>IP Addresses as WordIntervals\<close>
  text\<open>The nice thing is: @{typ "'i wordinterval"}s are executable.\<close>

  definition iprange_single :: "'i::len word \<Rightarrow> 'i wordinterval" where
    "iprange_single ip \<equiv> WordInterval ip ip"

  fun iprange_interval :: "('i::len word \<times> 'i::len word) \<Rightarrow> 'i wordinterval" where
    "iprange_interval (ip_start, ip_end) = WordInterval ip_start ip_end"
  declare iprange_interval.simps[simp del]

  lemma iprange_interval_uncurry: "iprange_interval ipcidr = uncurry WordInterval ipcidr"
    by(cases ipcidr) (simp add: iprange_interval.simps)

  lemma "wordinterval_to_set (iprange_single ip) = {ip}"
    by(simp add: iprange_single_def)
  lemma "wordinterval_to_set (iprange_interval (ip1, ip2)) = {ip1 .. ip2}"
    by(simp add: iprange_interval.simps)

  text\<open>Now we can use the set operations on @{typ "'i::len wordinterval"}s\<close>
  term wordinterval_to_set
  term wordinterval_element
  term wordinterval_union
  term wordinterval_empty
  term wordinterval_setminus
  term wordinterval_UNIV
  term wordinterval_invert
  term wordinterval_intersection
  term wordinterval_subset
  term wordinterval_eq

subsection\<open>IP Addresses in CIDR Notation\<close>
  text\<open>We want to convert IP addresses in CIDR notation to intervals.
    We already have @{const ipset_from_cidr}, which gives back a non-executable set.
    We want to convert to something we can store in an @{typ "'i wordinterval"}.\<close>

  fun ipcidr_to_interval_start :: "('i::len word \<times> nat) \<Rightarrow> 'i::len word" where
    "ipcidr_to_interval_start (pre, len) = (
      let netmask = (mask len) << (LENGTH('i) - len);
          network_prefix = (pre AND netmask)
      in network_prefix)"
  fun ipcidr_to_interval_end :: "('i::len word \<times> nat) \<Rightarrow> 'i::len word" where
    "ipcidr_to_interval_end (pre, len) = (
      let netmask = (mask len) << (LENGTH('i) - len);
          network_prefix = (pre AND netmask)
      in network_prefix OR (NOT netmask))"
  definition ipcidr_to_interval :: "('i::len word \<times> nat) \<Rightarrow> ('i word \<times> 'i word)" where
    "ipcidr_to_interval cidr \<equiv> (ipcidr_to_interval_start cidr, ipcidr_to_interval_end cidr)"

  lemma ipset_from_cidr_ipcidr_to_interval:
    "ipset_from_cidr base len =
      {ipcidr_to_interval_start (base,len) .. ipcidr_to_interval_end (base,len)}"
    by(simp add: Let_def ipcidr_to_interval_def ipset_from_cidr_def ipset_from_netmask_def)
  declare ipcidr_to_interval_start.simps[simp del] ipcidr_to_interval_end.simps[simp del]

  lemma ipcidr_to_interval:
    "ipcidr_to_interval (base, len) = (s,e) \<Longrightarrow> ipset_from_cidr base len = {s .. e}"
    by (simp add: ipcidr_to_interval_def ipset_from_cidr_ipcidr_to_interval)

  definition ipcidr_tuple_to_wordinterval :: "('i::len word \<times> nat) \<Rightarrow> 'i wordinterval" where
    "ipcidr_tuple_to_wordinterval iprng \<equiv> iprange_interval (ipcidr_to_interval iprng)"

  lemma wordinterval_to_set_ipcidr_tuple_to_wordinterval:
    "wordinterval_to_set (ipcidr_tuple_to_wordinterval (b, m)) = ipset_from_cidr b m"
    unfolding ipcidr_tuple_to_wordinterval_def ipset_from_cidr_ipcidr_to_interval
              ipcidr_to_interval_def
    by(simp add: iprange_interval.simps)

  lemma wordinterval_to_set_ipcidr_tuple_to_wordinterval_uncurry:
    "wordinterval_to_set (ipcidr_tuple_to_wordinterval ipcidr) = uncurry ipset_from_cidr ipcidr"
    by(cases ipcidr, simp add: wordinterval_to_set_ipcidr_tuple_to_wordinterval)

  definition ipcidr_union_set :: "('i::len word \<times> nat) set \<Rightarrow> ('i word) set" where
    "ipcidr_union_set ips \<equiv> \<Union>(base, len) \<in> ips. ipset_from_cidr base len"

  lemma ipcidr_union_set_uncurry:
    "ipcidr_union_set ips = (\<Union> ipcidr \<in> ips. uncurry ipset_from_cidr ipcidr)"
    by(simp add: ipcidr_union_set_def uncurry_case_stmt)

subsection\<open>Clever Operations on IP Addresses in CIDR Notation\<close>
  text\<open>Intersecting two intervals may result in a new interval.
    Example: \<open>{1..10} \<inter> {5..20} = {5..10}\<close>

    Intersecting two IP address ranges represented as CIDR ranges results either in the empty set
    or the smaller of the two ranges. It will never create a new range.
    \<close>
  context
  begin
    (*contributed by Lars Noschinski*)
    private lemma less_and_not_mask_eq:
      fixes i :: "('a :: len) word"
      assumes "r2 \<le> r1" "i && ~~ (mask r2) = x && ~~ (mask r2)"
      shows "i && ~~ (mask r1) = x && ~~ (mask r1)"
    proof -
      have "i AND NOT (mask r1) = (i && ~~ (mask r2)) && ~~ (mask r1)" (is "_ = ?w && _")
        using \<open>r2 \<le> r1\<close> by (simp add: and_not_mask_twice max_def)
      also have "?w = x && ~~ (mask r2)" by fact
      also have "\<dots> && ~~ (mask r1) = x && ~~ (mask r1)"
        using \<open>r2 \<le> r1\<close> by (simp add: and_not_mask_twice max_def)
      finally show ?thesis .
    qed

    lemma ip_cidr_set_less:
      fixes i :: "'i::len word"
      shows "r1 \<le> r2 \<Longrightarrow> ip_cidr_set i r2 \<subseteq> ip_cidr_set i r1"
      unfolding ip_cidr_set_def
      apply auto
      apply (rule less_and_not_mask_eq[where ?r2.0="LENGTH('i) - r2"])
      apply auto
      done

    private lemma ip_cidr_set_intersect_subset_helper:
      fixes i1 r1 i2 r2
      assumes disj: "ip_cidr_set i1 r1 \<inter> ip_cidr_set i2 r2 \<noteq> {}" and  "r1 \<le> r2"
      shows "ip_cidr_set i2 r2 \<subseteq> ip_cidr_set i1 r1"
      proof -
      from disj obtain j where "j \<in> ip_cidr_set i1 r1" "j \<in> ip_cidr_set i2 r2" by auto
      with \<open>r1 \<le> r2\<close> have "j \<in> ip_cidr_set j r1" "j \<in> ip_cidr_set j r1"
        using ip_cidr_set_change_base ip_cidr_set_less by blast+

      show "ip_cidr_set i2 r2 \<subseteq> ip_cidr_set i1 r1"
      proof
        fix i assume "i \<in> ip_cidr_set i2 r2"
        with \<open>j \<in> ip_cidr_set i2 r2\<close> have "i \<in> ip_cidr_set j r2" using ip_cidr_set_change_base by auto
        also have "ip_cidr_set j r2 \<subseteq> ip_cidr_set j r1" using \<open>r1 \<le> r2\<close> ip_cidr_set_less by blast
        also have "\<dots> = ip_cidr_set i1 r1" using \<open>j \<in> ip_cidr_set i1 r1\<close> ip_cidr_set_change_base by blast
        finally show "i \<in> ip_cidr_set i1 r1" .
      qed
    qed

    lemma ip_cidr_set_notsubset_empty_inter:
      "\<not> ip_cidr_set i1 r1 \<subseteq> ip_cidr_set i2 r2 \<Longrightarrow>
       \<not> ip_cidr_set i2 r2 \<subseteq> ip_cidr_set i1 r1 \<Longrightarrow>
       ip_cidr_set i1 r1 \<inter> ip_cidr_set i2 r2 = {}"
      apply(cases "r1 \<le> r2")
       subgoal using ip_cidr_set_intersect_subset_helper by blast
      apply(cases "r2 \<le> r1")
       subgoal using ip_cidr_set_intersect_subset_helper by blast
      by(simp)
  end

  lemma ip_cidr_intersect:
     "\<not> ipset_from_cidr b2 m2 \<subseteq> ipset_from_cidr b1 m1 \<Longrightarrow>
      \<not> ipset_from_cidr b1 m1 \<subseteq> ipset_from_cidr b2 m2 \<Longrightarrow>
      ipset_from_cidr b1 m1 \<inter> ipset_from_cidr b2 m2 = {}"
    apply(simp add: ipset_from_cidr_eq_ip_cidr_set)
    using ip_cidr_set_notsubset_empty_inter by blast

  text\<open>Computing the intersection of two IP address ranges in CIDR notation\<close>
  fun ipcidr_conjunct :: "('i::len word \<times> nat) \<Rightarrow> ('i word \<times> nat) \<Rightarrow> ('i word \<times> nat) option" where
    "ipcidr_conjunct (base1, m1) (base2, m2) = (
       if
         ipset_from_cidr base1 m1 \<inter> ipset_from_cidr base2 m2 = {}
       then
         None
       else if
         ipset_from_cidr base1 m1 \<subseteq> ipset_from_cidr base2 m2
       then
         Some (base1, m1)
       else
         Some (base2, m2)
      )"

  text\<open>Intersecting with an address with prefix length zero always yields a non-empty result.\<close>
  lemma ipcidr_conjunct_any: "ipcidr_conjunct a (x,0) \<noteq> None" "ipcidr_conjunct (y,0) b \<noteq> None"
     apply(cases a, simp add: ipset_from_cidr_0 ipset_from_cidr_not_empty)
    by(cases b, simp add: ipset_from_cidr_0 ipset_from_cidr_not_empty)

  lemma ipcidr_conjunct_correct: "(case ipcidr_conjunct (b1, m1) (b2, m2)
                                          of Some (bx, mx) \<Rightarrow> ipset_from_cidr bx mx
                                          |  None \<Rightarrow> {}) =
                                   (ipset_from_cidr b1 m1) \<inter> (ipset_from_cidr b2 m2)"
    apply(simp split: if_split_asm)
    using ip_cidr_intersect by fast
  declare ipcidr_conjunct.simps[simp del]

subsection\<open>Code Equations\<close>
  text\<open>Executable definition using word intervals\<close>
  lemma ipcidr_conjunct_word[code_unfold]:
  "ipcidr_conjunct ips1 ips2 = (
     if
      wordinterval_empty (wordinterval_intersection
                            (ipcidr_tuple_to_wordinterval ips1) (ipcidr_tuple_to_wordinterval ips2))
     then
       None
     else if
       wordinterval_subset (ipcidr_tuple_to_wordinterval ips1) (ipcidr_tuple_to_wordinterval ips2)
     then
       Some ips1
     else
       Some ips2
     )"
  apply(simp)
  apply(cases ips1, cases ips2, rename_tac b1 m1 b2 m2, simp)
  apply(auto simp add: wordinterval_to_set_ipcidr_tuple_to_wordinterval ipcidr_conjunct.simps
             split: if_split_asm)
  done

  (*with the code_unfold lemma before, this works!*)
  lemma "ipcidr_conjunct (0::32 word,0) (8,1) = Some (8, 1)" by eval
  export_code ipcidr_conjunct checking SML

  text\<open>making element check executable\<close>
  lemma addr_in_ipset_from_netmask_code[code_unfold]:
    "addr \<in> (ipset_from_netmask base netmask) \<longleftrightarrow>
      (base AND netmask) \<le> addr \<and> addr \<le> (base AND netmask) OR (NOT netmask)"
    by(simp add: ipset_from_netmask_def Let_def)
  lemma addr_in_ipset_from_cidr_code[code_unfold]:
    "(addr::'i::len word) \<in> (ipset_from_cidr pre len) \<longleftrightarrow>
       (pre AND ((mask len) << (LENGTH('i) - len))) \<le> addr \<and>
        addr \<le> pre OR (mask (LENGTH('i) - len))"
  unfolding ipset_from_cidr_alt by simp

end


(*  Title:      Well-Quasi-Orders
    Author:     Christian Sternagel <c.sternagel@gmail.com>
    Maintainer: Christian Sternagel
    License:    LGPL
*)

section \<open>Infinite Sequences\<close>

text \<open>Some useful constructions on and facts about infinite sequences.\<close>

theory Infinite_Sequences
imports Main
begin

text \<open>The set of all infinite sequences over elements from @{term A}.\<close>
definition "SEQ A = {f::nat \<Rightarrow> 'a. \<forall>i. f i \<in> A}"

lemma SEQ_iff [iff]:
  "f \<in> SEQ A \<longleftrightarrow> (\<forall>i. f i \<in> A)"
by (auto simp: SEQ_def)

text \<open>The \<open>i\<close>-th "column" of a set \<open>B\<close> of infinite sequences.\<close>
definition "ith B i = {f i | f. f \<in> B}"

lemma ithI [intro]:
  "f \<in> B \<Longrightarrow> f i = x \<Longrightarrow> x \<in> ith B i"
by (auto simp: ith_def)

lemma ithE [elim]:
  "\<lbrakk>x \<in> ith B i; \<And>f. \<lbrakk>f \<in> B; f i = x\<rbrakk> \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
by (auto simp: ith_def)

lemma ith_conv:
  "x \<in> ith B i \<longleftrightarrow> (\<exists>f \<in> B. x = f i)"
by auto

text \<open>
  The restriction of a set \<open>B\<close> of sequences to sequences that are equal to a given sequence
  \<open>f\<close> up to position \<open>i\<close>.
\<close>
definition eq_upto :: "(nat \<Rightarrow> 'a) set \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> (nat \<Rightarrow> 'a) set"
where
  "eq_upto B f i = {g \<in> B. \<forall>j < i. f j = g j}"

lemma eq_uptoI [intro]:
  "\<lbrakk>g \<in> B; \<And>j. j < i \<Longrightarrow> f j = g j\<rbrakk> \<Longrightarrow> g \<in> eq_upto B f i"
by (auto simp: eq_upto_def)

lemma eq_uptoE [elim]:
  "\<lbrakk>g \<in> eq_upto B f i; \<lbrakk>g \<in> B; \<And>j. j < i \<Longrightarrow> f j = g j\<rbrakk> \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
by (auto simp: eq_upto_def)

lemma eq_upto_Suc:
  "\<lbrakk>g \<in> eq_upto B f i; g i = f i\<rbrakk> \<Longrightarrow> g \<in> eq_upto B f (Suc i)"
by (auto simp: eq_upto_def less_Suc_eq)

lemma eq_upto_0 [simp]:
  "eq_upto B f 0 = B"
by (auto simp: eq_upto_def)

lemma eq_upto_cong [fundef_cong]:
  assumes "\<And>j. j < i \<Longrightarrow> f j = g j" and "B = C"
  shows "eq_upto B f i = eq_upto C g i"
using assms by (auto simp: eq_upto_def)

subsection \<open>Lexicographic Order on Infinite Sequences\<close>

definition "LEX P f g \<longleftrightarrow> (\<exists>i::nat. P (f i) (g i) \<and> (\<forall>j<i. f j = g j))"
abbreviation "LEXEQ P \<equiv> (LEX P)\<^sup>=\<^sup>="

lemma LEX_imp_not_LEX:
  assumes "LEX P f g"
    and [dest]: "\<And>x y z. P x y \<Longrightarrow> P y z \<Longrightarrow> P x z"
    and [simp]: "\<And>x. \<not> P x x"
  shows "\<not> LEX P g f"
proof -
  { fix i j :: nat
    assume "P (f i) (g i)" and "\<forall>k<i. f k = g k"
      and "P (g j) (f j)" and "\<forall>k<j. g k = f k"
    then have False by (cases "i < j") (auto simp: not_less dest!: le_imp_less_or_eq) }
  then show "\<not> LEX P g f" using \<open>LEX P f g\<close> unfolding LEX_def by blast
qed

lemma LEX_cases:
  assumes "LEX P f g"
  obtains (eq) "f = g" | (neq) k where "\<forall>i<k. f i = g i" and "P (f k) (g k)"
using assms by (auto simp: LEX_def)

lemma LEX_imp_less:
  assumes "\<forall>x\<in>A. \<not> P x x" and "f \<in> SEQ A \<or> g \<in> SEQ A"
    and "LEX P f g" and "\<forall>i<k. f i = g i" and "f k \<noteq> g k"
  shows "P (f k) (g k)"
using assms by (auto elim!: LEX_cases) (metis linorder_neqE_nat)+

end


theory Misc_Ext_Ext
  imports
    Main
begin

lemma tl_rev:
  "tl (rev p) = rev (butlast p)"
  by (induct p) auto

lemma tl_butlast_rev:
  shows "tl (butlast (rev l)) = rev (tl (butlast l))"
  unfolding butlast_rev tl_rev butlast_tl
  ..

lemma mem_setD:
  assumes "x \<in> set l"
  shows "x = hd l \<or> x \<in> set (tl (butlast l)) \<or> x = last l"
proof (cases "l = []")
  case True
  thus ?thesis
    using assms
    by fastforce
next
  case l_non_empty: False
  show ?thesis
  proof (cases "tl l = []")
    case True
    thus ?thesis
      using l_non_empty assms
      by (auto simp add: tl_Nil)
  next
    case False
    have "hd l # tl (butlast l) @ [last l] = l"
    proof -
      have "hd l # tl (butlast l) @ [last l] = hd l # tl (butlast l @ [last l])"
      proof -
        have "0 < length (tl l)"
          using False
          by blast
        hence "0 < length (butlast l)"
          by simp
        hence "butlast l \<noteq> []"
          by fast
        thus ?thesis
          by simp
      qed
      also have "... = hd l # tl l"
        using l_non_empty
        by auto
      also have "... = l"
        using l_non_empty
        by fastforce
      finally show ?thesis
        .
    qed
    thus ?thesis
      using assms
      by (metis set_ConsD set_rotate1 rotate1.simps(2))
  qed
qed

lemma split_list_2:
  assumes "x \<in> set l"
  assumes "y \<in> set l"
  assumes "x \<noteq> y"
  obtains l1 l2 l3 where
    "l1 @ x # l2 @ y # l3 = l \<or> l1 @ x # l2 @ y # l3 = rev l"
proof -
  obtain l1 l2 where
    l1_l2: "l1 @ x # l2 = l"
    using assms(1)
    by (blast dest: split_list)
  then consider
    (l1) "y \<in> set l1" |
    (l2) "y \<in> set l2"
    using assms(2, 3)
    by fastforce
  then obtain l3 l4 l5 where
    "l3 @ x # l4 @ y # l5 = l \<or> l3 @ x # l4 @ y # l5 = rev l"
  proof (cases)
    case l1
    then obtain l3 l4 where
      "l3 @ y # l4 @ x # l2 = l"
      using l1_l2
      by (auto dest: split_list)
    thus ?thesis
      by (auto intro: that)
  next
    case l2
    then obtain l3 l4 where
      "l1 @ x # l3 @ y # l4 = l"
      using l1_l2
      by (auto dest: split_list)
    thus ?thesis
      by (auto intro: that)
  qed
  thus ?thesis
    by (intro that)
qed

end


(*  Title:      HOL/HOLCF/IOA/NTP/Multiset.thy
    Author:     Tobias Nipkow & Konrad Slind
*)

section \<open>Axiomatic multisets\<close>

theory Multiset
imports Lemmas
begin

typedecl
  'a multiset

consts

  emptym :: "'a multiset"                        ("{|}")
  addm   :: "['a multiset, 'a] => 'a multiset"
  delm   :: "['a multiset, 'a] => 'a multiset"
  countm :: "['a multiset, 'a => bool] => nat"
  count  :: "['a multiset, 'a] => nat"

axiomatization where

delm_empty_def:
  "delm {|} x = {|}" and

delm_nonempty_def:
  "delm (addm M x) y == (if x=y then M else addm (delm M y) x)" and

countm_empty_def:
   "countm {|} P == 0" and

countm_nonempty_def:
   "countm (addm M x) P == countm M P + (if P x then Suc 0 else 0)" and

count_def:
   "count M x == countm M (%y. y = x)" and

"induction":
   "\<And>P M. [| P({|}); !!M x. P(M) ==> P(addm M x) |] ==> P(M)"

lemma count_empty:
   "count {|} x = 0"
  by (simp add: Multiset.count_def Multiset.countm_empty_def)

lemma count_addm_simp:
     "count (addm M x) y = (if y=x then Suc(count M y) else count M y)"
  by (simp add: Multiset.count_def Multiset.countm_nonempty_def)

lemma count_leq_addm: "count M y <= count (addm M x) y"
  by (simp add: count_addm_simp)

lemma count_delm_simp:
     "count (delm M x) y = (if y=x then count M y - 1 else count M y)"
apply (unfold Multiset.count_def)
apply (rule_tac M = "M" in Multiset.induction)
apply (simp (no_asm_simp) add: Multiset.delm_empty_def Multiset.countm_empty_def)
apply (simp add: Multiset.delm_nonempty_def Multiset.countm_nonempty_def)
apply safe
apply simp
done

lemma countm_props: "!!M. (!x. P(x) --> Q(x)) ==> (countm M P <= countm M Q)"
apply (rule_tac M = "M" in Multiset.induction)
 apply (simp (no_asm) add: Multiset.countm_empty_def)
apply (simp (no_asm) add: Multiset.countm_nonempty_def)
apply auto
done

lemma countm_spurious_delm: "!!P. ~P(obj) ==> countm M P = countm (delm M obj) P"
  apply (rule_tac M = "M" in Multiset.induction)
  apply (simp (no_asm) add: Multiset.delm_empty_def Multiset.countm_empty_def)
  apply (simp (no_asm_simp) add: Multiset.countm_nonempty_def Multiset.delm_nonempty_def)
  done

lemma pos_count_imp_pos_countm [rule_format (no_asm)]: "!!P. P(x) ==> 0<count M x --> countm M P > 0"
  apply (rule_tac M = "M" in Multiset.induction)
  apply (simp (no_asm) add: Multiset.delm_empty_def Multiset.count_def Multiset.countm_empty_def)
  apply (simp add: Multiset.count_def Multiset.delm_nonempty_def Multiset.countm_nonempty_def)
  done

lemma countm_done_delm:
   "!!P. P(x) ==> 0<count M x --> countm (delm M x) P = countm M P - 1"
  apply (rule_tac M = "M" in Multiset.induction)
  apply (simp (no_asm) add: Multiset.delm_empty_def Multiset.countm_empty_def)
  apply (simp (no_asm_simp) add: count_addm_simp Multiset.delm_nonempty_def Multiset.countm_nonempty_def pos_count_imp_pos_countm)
  apply auto
  done

declare count_addm_simp [simp] count_delm_simp [simp]
  Multiset.countm_empty_def [simp] Multiset.delm_empty_def [simp] count_empty [simp]

end