(*
Auction Theory Toolbox (http://formare.github.io/auctions/)

Authors:
* Marco B. Caminati http://caminati.co.nr
* Manfred Kerber <mnfrd.krbr@gmail.com>
* Christoph Lange <math.semantic.web@gmail.com>
* Colin Rowat <c.rowat@bham.ac.uk>

Dually licenced under
* Creative Commons Attribution (CC-BY) 3.0
* ISC License (1-clause BSD License)
See LICENSE file for details
(Rationale for this dual licence: http://arxiv.org/abs/1107.3212)
*)

section \<open>Partitions of sets\<close>

theory Partitions
imports
  SetUtils

begin

text \<open>
We define the set of all partitions of a set (@{term all_partitions}) in textbook style, as well as a computable function @{term all_partitions_list} to algorithmically compute this set (then represented as a list).  This function is suitable for code generation.  We prove the equivalence of the two definition in order to ensure that the generated code correctly implements the original textbook-style definition.  For further background on the overall approach, see Caminati, Kerber, Lange, Rowat: \href{http://arxiv.org/abs/1308.1779}{Proving soundness of combinatorial Vickrey auctions and generating verified executable code}, 2013.
\<close>

text \<open>@{term P} is a family of non-overlapping  sets.\<close>
definition is_non_overlapping
           where "is_non_overlapping P = (\<forall> X\<in>P . \<forall> Y\<in> P . (X \<inter> Y \<noteq> {} \<longleftrightarrow> X = Y))"
(* alternative, less concise formalisation:
"is_non_overlapping P = (\<forall> ec1 \<in> P . ec1 \<noteq> {} \<and> (\<forall> ec2 \<in> P - {ec1}. ec1 \<inter> ec2 = {}))"
*)

text \<open>A subfamily of a non-overlapping family is also a non-overlapping family\<close>

lemma subset_is_non_overlapping:
  assumes subset: "P \<subseteq> Q" and
          non_overlapping: "is_non_overlapping Q"
  shows "is_non_overlapping P"
(* CL: The following takes 387 ms with Isabelle2013-1-RC1:
   by (metis is_non_overlapping_def non_overlapping rev_subsetD subset). MC: possibly useful for TPTP *)
proof -
  {
    fix X Y assume "X \<in> P \<and> Y \<in> P"
    then have "X \<in> Q \<and> Y \<in> Q" using subset by fast
    then have "X \<inter> Y \<noteq> {} \<longleftrightarrow> X = Y" using non_overlapping unfolding is_non_overlapping_def by force
  }
  then show ?thesis unfolding is_non_overlapping_def by force
qed

(* This is not used at the moment, but it is interesting, as the proof
   was very hard to find for Sledgehammer. MC: possibly useful for TPTP *)

text \<open>The family that results from removing one element from an equivalence class of a non-overlapping family is not otherwise a member of the family.\<close>
lemma remove_from_eq_class_preserves_disjoint:
      fixes elem::'a
        and X::"'a set"
        and P::"'a set set"
      assumes non_overlapping: "is_non_overlapping P"
        and eq_class: "X \<in> P"
        and elem: "elem \<in> X"
      shows "X - {elem} \<notin> P"
  using assms Int_Diff is_non_overlapping_def Diff_disjoint Diff_eq_empty_iff
        Int_absorb2 insert_Diff_if insert_not_empty by (metis)

text \<open>Inserting into a non-overlapping family @{term P} a set @{term X}, which is disjoint with the set
  partitioned by @{term P}, yields another non-overlapping family.\<close>

lemma non_overlapping_extension1:
  fixes P::"'a set set"
    and X::"'a set"
  assumes partition: "is_non_overlapping P"
       and disjoint: "X \<inter> \<Union> P = {}"
      and non_empty: "X \<noteq> {}"
  shows "is_non_overlapping (insert X P)"
proof -
  {
    fix Y::"'a set" and Z::"'a set"
    assume Y_Z_in_ext_P: "Y \<in> insert X P \<and> Z \<in> insert X P"
    have "Y \<inter> Z \<noteq> {} \<longleftrightarrow> Y = Z"
    proof
      assume "Y \<inter> Z \<noteq> {}"
      then show "Y = Z"
        using Y_Z_in_ext_P partition disjoint
        unfolding is_non_overlapping_def
        by fast
    next
      assume "Y = Z"
      then show "Y \<inter> Z \<noteq> {}"
        using Y_Z_in_ext_P partition non_empty
        unfolding is_non_overlapping_def
        by auto
    qed
  }
  then show ?thesis unfolding is_non_overlapping_def by force
qed

text \<open>An element of a non-overlapping family has no intersection with any other of its elements.\<close>
lemma disj_eq_classes:
  fixes P::"'a set set"
    and X::"'a set"
  assumes "is_non_overlapping P"
      and "X \<in> P"
  shows "X \<inter> \<Union> (P - {X}) = {}"
proof -
  {
    fix x::'a
    assume x_in_two_eq_classes: "x \<in> X \<inter> \<Union> (P - {X})"
    then obtain Y where other_eq_class: "Y \<in> P - {X} \<and> x \<in> Y" by blast
    have "x \<in> X \<inter> Y \<and> Y \<in> P"
      using x_in_two_eq_classes other_eq_class by force
    then have "X = Y" using assms is_non_overlapping_def by fast
    then have "x \<in> {}" using other_eq_class by fast
  }
  then show ?thesis by blast
qed

text \<open>The empty set is not element of a non-overlapping family.\<close>
lemma no_empty_in_non_overlapping:
  assumes "is_non_overlapping p"
  shows "{} \<notin> p"
(* CL: The following takes 36 ms with Isabelle2013-1-RC1:
   by (metis Int_iff all_not_in_conv assms is_non_overlapping_def). MC: possibly useful for TPTP *)
  using assms is_non_overlapping_def by fast

text \<open>@{term P} is a partition of the set @{term A}. The infix notation takes the form ``noun-verb-object''\<close>
definition is_partition_of (infix "partitions" 75)
           where "is_partition_of P A = (\<Union> P = A \<and> is_non_overlapping P)"

text \<open>No partition of a non-empty set is empty.\<close>
lemma non_empty_imp_non_empty_partition:
  assumes "A \<noteq> {}"
      and "P partitions A"
  shows "P \<noteq> {}"
  using assms unfolding is_partition_of_def by fast

text \<open>Every element of a partitioned set ends up in one element in the partition.\<close>
lemma elem_in_partition:
  assumes in_set: "x \<in> A"
      and part: "P partitions A"
  obtains X where "x \<in> X" and "X \<in> P"
  using part in_set unfolding is_partition_of_def is_non_overlapping_def by (auto simp add: UnionE)

text \<open>Every element of the difference of a set @{term A} and another set @{term B} ends up in
  an element of a partition of @{term A}, but not in an element of the partition of @{term "{B}"}.\<close>
lemma diff_elem_in_partition:
  assumes x: "x \<in> A - B"
      and part: "P partitions A"
  shows "\<exists> S \<in> P - { B } . x \<in> S"
(* Sledgehammer in Isabelle2013-1-RC1 can't do this within the default time limit.
MC: possibly useful for TPTP *)
proof -
  from part x obtain X where "x \<in> X" and "X \<in> P"
    by (metis Diff_iff elem_in_partition)
  with x have "X \<noteq> B" by fast
  with \<open>x \<in> X\<close> \<open>X \<in> P\<close> show ?thesis by blast
qed

text \<open>Every element of a partitioned set ends up in exactly one set.\<close>
lemma elem_in_uniq_set:
  assumes in_set: "x \<in> A"
      and part: "P partitions A"
  shows "\<exists>! X \<in> P . x \<in> X"
proof -
  from assms obtain X where *: "X \<in> P \<and> x \<in> X"
    by (rule elem_in_partition) blast
  moreover {
    fix Y assume "Y \<in> P \<and> x \<in> Y"
    then have "Y = X"
      using part in_set *
      unfolding is_partition_of_def is_non_overlapping_def
      by (metis disjoint_iff_not_equal)
  }
  ultimately show ?thesis by (rule ex1I)
qed

text \<open>A non-empty set ``is'' a partition of itself.\<close>
lemma set_partitions_itself:
  assumes "A \<noteq> {}"
  shows "{A} partitions A" unfolding is_partition_of_def is_non_overlapping_def
(* CL: the following takes 48 ms on my machine with Isabelle2013:
   by (metis Sup_empty Sup_insert assms inf_idem singletonE sup_bot_right). MC: possibly useful for TPTP *)
proof
  show "\<Union> {A} = A" by simp
  {
    fix X Y
    assume "X \<in> {A}"
    then have "X = A" by (rule singletonD)
    assume "Y \<in> {A}"
    then have "Y = A" by (rule singletonD)
    from \<open>X = A\<close> \<open>Y = A\<close> have "X \<inter> Y \<noteq> {} \<longleftrightarrow> X = Y" using assms by simp
  }
  then show "\<forall> X \<in> {A} . \<forall> Y \<in> {A} . X \<inter> Y \<noteq> {} \<longleftrightarrow> X = Y" by force
qed

text \<open>The empty set is a partition of the empty set.\<close>
lemma emptyset_part_emptyset1:
  shows "{} partitions {}"
  unfolding is_partition_of_def is_non_overlapping_def by fast

text \<open>Any partition of the empty set is empty.\<close>
lemma emptyset_part_emptyset2:
  assumes "P partitions {}"
  shows "P = {}"
  using assms unfolding is_partition_of_def is_non_overlapping_def
  by fastforce

text \<open>Classical set-theoretical definition of ``all partitions of a set @{term A}''\<close>
definition all_partitions where
"all_partitions A = {P . P partitions A}"

text \<open>The set of all partitions of the empty set only contains the empty set.
  We need this to prove the base case of @{term all_partitions_paper_equiv_alg}.\<close>
lemma emptyset_part_emptyset3:
  shows "all_partitions {} = {{}}"
  unfolding all_partitions_def using emptyset_part_emptyset1 emptyset_part_emptyset2 by fast

text \<open>inserts an element new\_el into a specified set S inside a given family of sets\<close>
definition insert_into_member :: "'a \<Rightarrow> 'a set set \<Rightarrow> 'a set \<Rightarrow> 'a set set"
   where "insert_into_member new_el Sets S = insert (S \<union> {new_el}) (Sets - {S})"

text \<open>Using @{const insert_into_member} to insert a fresh element, which is not a member of the
  set @{term S} being partitioned, into a non-overlapping family of sets yields another
  non-overlapping family.\<close>
lemma non_overlapping_extension2:
  fixes new_el::'a
    and P::"'a set set"
    and X::"'a set"
  assumes non_overlapping: "is_non_overlapping P"
      and class_element: "X \<in> P"
      and new: "new_el \<notin> \<Union> P"
  shows "is_non_overlapping (insert_into_member new_el P X)"
proof -
  let ?Y = "insert new_el X"
  have rest_is_non_overlapping: "is_non_overlapping (P - {X})"
    using non_overlapping subset_is_non_overlapping by blast
  have *: "X \<inter> \<Union> (P - {X}) = {}"
   using non_overlapping class_element by (rule disj_eq_classes)
  from * have non_empty: "?Y \<noteq> {}" by blast
  from * have disjoint: "?Y \<inter> \<Union> (P - {X}) = {}" using new by force
  have "is_non_overlapping (insert ?Y (P - {X}))"
    using rest_is_non_overlapping disjoint non_empty by (rule non_overlapping_extension1)
  then show ?thesis unfolding insert_into_member_def by simp
qed

text \<open>inserts an element into a specified set inside the given list of sets --
   the list variant of @{const insert_into_member}

   The rationale for this variant and for everything that depends on it is:
   While it is possible to computationally enumerate ``all partitions of a set'' as an
   @{typ "'a set set set"}, we need a list representation to apply further computational
   functions to partitions.  Because of the way we construct partitions (using functions
   such as @{term all_coarser_partitions_with} below) it is not sufficient to simply use
   @{typ "'a set set list"}, but we need @{typ "'a set list list"}.  This is because it is hard
   to impossible to convert a set to a list, whereas it is easy to convert a @{type list} to a @{type set}.
\<close>
definition insert_into_member_list :: "'a \<Rightarrow> 'a set list \<Rightarrow> 'a set \<Rightarrow> 'a set list"
  where "insert_into_member_list new_el Sets S = (S \<union> {new_el}) # (remove1 S Sets)"

text \<open>@{const insert_into_member_list} and @{const insert_into_member} are equivalent
  (as in returning the same set).\<close>
lemma insert_into_member_list_equivalence:
  fixes new_el::'a
    and Sets::"'a set list"
    and S::"'a set"
  assumes "distinct Sets"
  shows "set (insert_into_member_list new_el Sets S) = insert_into_member new_el (set Sets) S"
  unfolding insert_into_member_list_def insert_into_member_def using assms by simp

text \<open>an alternative characterization of the set partitioned by a partition obtained by
  inserting an element into an equivalence class of a given partition (if @{term P}
  \emph{is} a partition)\<close>
lemma insert_into_member_partition1:
  fixes elem::'a
    and P::"'a set set"
    and set::"'a set"
  shows "\<Union> (insert_into_member elem P set) = \<Union> (insert (set \<union> {elem}) (P - {set}))"
(* CL: The following takes 12 ms in Isabelle2013-1-RC1:
   by (metis insert_into_member_def). MC: possibly useful for TPTP *)
    unfolding insert_into_member_def
    by fast

text \<open>Assuming that @{term P} is a partition of a set @{term S}, and @{term "new_el \<notin> S"}, the function defined below yields
  all possible partitions of @{term "S \<union> {new_el}"} that are coarser than @{term P}
  (i.e.\ not splitting classes that already exist in @{term P}).  These comprise one partition
  with a class @{term "{new_el}"} and all other classes unchanged,
  as well as all partitions obtained by inserting @{term new_el} into one class of @{term P} at a time. While we use the definition to build coarser partitions of an existing partition P, the definition itself does not require P to be a partition.\<close>
definition coarser_partitions_with ::"'a \<Rightarrow> 'a set set \<Rightarrow> 'a set set set"
  where "coarser_partitions_with new_el P =
    insert
    \<comment> \<open>Let \<open>P\<close> be a partition of a set \<open>Set\<close>,\<close>
    \<comment> \<open>and suppose \<open>new_el \<notin> Set\<close>, i.e. \<open>{new_el} \<notin> P\<close>,\<close>
    \<comment> \<open>then the following constructs a partition of \<open>Set \<union> {new_el}\<close> obtained by\<close>
    \<comment> \<open>inserting a new class \<open>{new_el}\<close> and leaving all previous classes unchanged.\<close>
    (insert {new_el} P)
    \<comment> \<open>Let \<open>P\<close> be a partition of a set \<open>Set\<close>,\<close>
    \<comment> \<open>and suppose \<open>new_el \<notin> Set\<close>,\<close>
    \<comment> \<open>then the following constructs\<close>
    \<comment> \<open>the set of those partitions of \<open>Set \<union> {new_el}\<close> obtained by\<close>
    \<comment> \<open>inserting \<open>new_el\<close> into one class of \<open>P\<close> at a time.\<close>
    ((insert_into_member new_el P) ` P)"

text \<open>the list variant of @{const coarser_partitions_with}\<close>
definition coarser_partitions_with_list ::"'a \<Rightarrow> 'a set list \<Rightarrow> 'a set list list"
  where "coarser_partitions_with_list new_el P =
    \<comment> \<open>Let \<open>P\<close> be a partition of a set \<open>Set\<close>,\<close>
    \<comment> \<open>and suppose \<open>new_el \<notin> Set\<close>, i.e. \<open>{new_el} \<notin> set P\<close>,\<close>
    \<comment> \<open>then the following constructs a partition of \<open>Set \<union> {new_el}\<close> obtained by\<close>
    \<comment> \<open>inserting a new class \<open>{new_el}\<close> and leaving all previous classes unchanged.\<close>
    ({new_el} # P)
    #
    \<comment> \<open>Let \<open>P\<close> be a partition of a set \<open>Set\<close>,\<close>
    \<comment> \<open>and suppose \<open>new_el \<notin> Set\<close>,\<close>
    \<comment> \<open>then the following constructs\<close>
    \<comment> \<open>the set of those partitions of \<open>Set \<union> {new_el}\<close> obtained by\<close>
    \<comment> \<open>inserting \<open>new_el\<close> into one class of \<open>P\<close> at a time.\<close>
    (map ((insert_into_member_list new_el P)) P)"

text \<open>@{const coarser_partitions_with_list} and @{const coarser_partitions_with} are equivalent.\<close>
lemma coarser_partitions_with_list_equivalence:
  assumes "distinct P"
  shows "set (map set (coarser_partitions_with_list new_el P)) =
         coarser_partitions_with new_el (set P)"
proof -
  have "set (map set (coarser_partitions_with_list new_el P)) = set (map set (({new_el} # P) # (map ((insert_into_member_list new_el P)) P)))"
    unfolding coarser_partitions_with_list_def ..
  also have "\<dots> = insert (insert {new_el} (set P)) ((set \<circ> (insert_into_member_list new_el P)) ` set P)"
    by simp
  also have "\<dots> = insert (insert {new_el} (set P)) ((insert_into_member new_el (set P)) ` set P)"
    using assms insert_into_member_list_equivalence by (metis comp_apply)
  finally show ?thesis unfolding coarser_partitions_with_def .
qed

text \<open>Any member of the set of coarser partitions of a given partition, obtained by inserting
  a given fresh element into each of its classes, is non\_overlapping.\<close>
lemma non_overlapping_extension3:
  fixes elem::'a
    and P::"'a set set"
    and Q::"'a set set"
  assumes P_non_overlapping: "is_non_overlapping P"
      and new_elem: "elem \<notin> \<Union> P"
      and Q_coarser: "Q \<in> coarser_partitions_with elem P"
  shows "is_non_overlapping Q"
proof -
  let ?q = "insert {elem} P"
  have Q_coarser_unfolded: "Q \<in> insert ?q (insert_into_member elem P ` P)"
    using Q_coarser
    unfolding coarser_partitions_with_def
    by fast
  show ?thesis
  proof (cases "Q = ?q")
    case True
    then show ?thesis
      using P_non_overlapping new_elem non_overlapping_extension1
      by fastforce
  next
    case False
    then have "Q \<in> (insert_into_member elem P) ` P" using Q_coarser_unfolded by fastforce
    then show ?thesis using non_overlapping_extension2 P_non_overlapping new_elem by fast
  qed
qed

text \<open>Let @{term P} be a partition of a set @{term S}, and @{term elem} an element (which may or may not be
  in @{term S} already).  Then, any member of @{term "coarser_partitions_with elem P"} is a set of sets
  whose union is @{term "S \<union> {elem}"}, i.e.\ it satisfies one of the necessary criteria for being a partition of @{term "S \<union> {elem}"}.
\<close>
lemma coarser_partitions_covers:
  fixes elem::'a
    and P::"'a set set"
    and Q::"'a set set"
  assumes "Q \<in> coarser_partitions_with elem P"
  shows "\<Union> Q = insert elem (\<Union> P)"
proof -
  let ?S = "\<Union> P"
  have Q_cases: "Q \<in> (insert_into_member elem P) ` P \<or> Q = insert {elem} P"
    using assms unfolding coarser_partitions_with_def by fast
  {
    fix eq_class assume eq_class_in_P: "eq_class \<in> P"
    have "\<Union> (insert (eq_class \<union> {elem}) (P - {eq_class})) = ?S \<union> (eq_class \<union> {elem})"
      using insert_into_member_partition1
      by (metis Sup_insert Un_commute Un_empty_right Un_insert_right insert_Diff_single)
    with eq_class_in_P have "\<Union> (insert (eq_class \<union> {elem}) (P - {eq_class})) = ?S \<union> {elem}" by blast
    then have "\<Union> (insert_into_member elem P eq_class) = ?S \<union> {elem}"
      using insert_into_member_partition1
      by (rule subst)
  }
  then show ?thesis using Q_cases by blast
qed

text \<open>Removes the element @{term elem} from every set in @{term P}, and removes from @{term P} any
  remaining empty sets.  This function is intended to be applied to partitions, i.e. @{term elem}
  occurs in at most one set.  @{term "partition_without e"} reverses @{term "coarser_partitions_with e"}.
@{const coarser_partitions_with} is one-to-many, while this is one-to-one, so we can think of a tree relation,
where coarser partitions of a set @{term "S \<union> {elem}"} are child nodes of one partition of @{term S}.\<close>
definition partition_without :: "'a \<Rightarrow> 'a set set \<Rightarrow> 'a set set"
  where "partition_without elem P = (\<lambda>X . X - {elem}) ` P - {{}}"
(* Set comprehension notation { x - {elem} | x . x \<in> P } would look nicer but is harder to do proofs about *)

(* We don't need to define partition_without_list. *)

text \<open>alternative characterization of the set partitioned by the partition obtained
  by removing an element from a given partition using @{const partition_without}\<close>
lemma partition_without_covers:
  fixes elem::'a
    and P::"'a set set"
  shows "\<Union> (partition_without elem P) = (\<Union> P) - {elem}"
proof -
  have "\<Union> (partition_without elem P) = \<Union> ((\<lambda>x . x - {elem}) ` P - {{}})"
    unfolding partition_without_def by fast
  also have "\<dots> = \<Union> P - {elem}" by blast
  finally show ?thesis .
qed

text \<open>Any class of the partition obtained by removing an element @{term elem} from an
  original partition @{term P} using @{const partition_without} equals some
  class of @{term P}, reduced by @{term elem}.\<close>
lemma super_class:
  assumes "X \<in> partition_without elem P"
  obtains Z where "Z \<in> P" and "X = Z - {elem}"
proof -
  from assms have "X \<in> (\<lambda>X . X - {elem}) ` P - {{}}" unfolding partition_without_def .
  then obtain Z where Z_in_P: "Z \<in> P" and Z_sup: "X = Z - {elem}"
    by (metis (lifting) Diff_iff image_iff)
  then show ?thesis ..
qed

text \<open>The class of sets obtained by removing an element from a non-overlapping class is another
  non-overlapping clas.\<close>
lemma non_overlapping_without_is_non_overlapping:
  fixes elem::'a
    and P::"'a set set"
  assumes "is_non_overlapping P"
  shows "is_non_overlapping (partition_without elem P)" (is "is_non_overlapping ?Q")
proof -
  have "\<forall> X1 \<in> ?Q. \<forall> X2 \<in> ?Q. X1 \<inter> X2 \<noteq> {} \<longleftrightarrow> X1 = X2"
  proof
    fix X1 assume X1_in_Q: "X1 \<in> ?Q"
    then obtain Z1 where Z1_in_P: "Z1 \<in> P" and Z1_sup: "X1 = Z1 - {elem}"
      by (rule super_class)
    have X1_non_empty: "X1 \<noteq> {}" using X1_in_Q partition_without_def by fast
    show "\<forall> X2 \<in> ?Q. X1 \<inter> X2 \<noteq> {} \<longleftrightarrow> X1 = X2"
    proof
      fix X2 assume "X2 \<in> ?Q"
      then obtain Z2 where Z2_in_P: "Z2 \<in> P" and Z2_sup: "X2 = Z2 - {elem}"
        by (rule super_class)
      have "X1 \<inter> X2 \<noteq> {} \<longrightarrow> X1 = X2"
      proof
        assume "X1 \<inter> X2 \<noteq> {}"
        then have "Z1 \<inter> Z2 \<noteq> {}" using Z1_sup Z2_sup by fast
        then have "Z1 = Z2" using Z1_in_P Z2_in_P assms unfolding is_non_overlapping_def by fast
        then show "X1 = X2" using Z1_sup Z2_sup by fast
      qed
      moreover have "X1 = X2 \<longrightarrow> X1 \<inter> X2 \<noteq> {}" using X1_non_empty by auto
      ultimately show "(X1 \<inter> X2 \<noteq> {}) \<longleftrightarrow> X1 = X2" by blast
    qed
  qed
  then show ?thesis unfolding is_non_overlapping_def .
qed

text \<open>@{term "coarser_partitions_with elem"} is the ``inverse'' of
  @{term "partition_without elem"}.\<close>
lemma coarser_partitions_inv_without:
  fixes elem::'a
    and P::"'a set set"
  assumes non_overlapping: "is_non_overlapping P"
      and elem: "elem \<in> \<Union> P"
  shows "P \<in> coarser_partitions_with elem (partition_without elem P)"
    (is "P \<in> coarser_partitions_with elem ?Q")
proof -
  let ?remove_elem = "\<lambda>X . X - {elem}" (* function that removes elem out of a set *)
  obtain Y (* the equivalence class of elem *)
    where elem_eq_class: "elem \<in> Y" and elem_eq_class': "Y \<in> P" using elem ..
  let ?elem_neq_classes = "P - {Y}" (* those equivalence classes of which elem is not a member *)
  have P_wrt_elem: "P = ?elem_neq_classes \<union> {Y}" using elem_eq_class' by blast
  let ?elem_eq = "Y - {elem}" (* other elements equivalent to elem *)
  have Y_elem_eq: "?remove_elem ` {Y} = {?elem_eq}" by fast
  (* those classes,of which elem is not a member, form a partition *)
  have elem_neq_classes_part: "is_non_overlapping ?elem_neq_classes"
    using subset_is_non_overlapping non_overlapping
    by blast
  have elem_eq_wrt_P: "?elem_eq \<in> ?remove_elem ` P" using elem_eq_class' by blast

  { (* consider a class W, of which elem is not a member *)
    fix W assume W_eq_class: "W \<in> ?elem_neq_classes"
    then have "elem \<notin> W"
      using elem_eq_class elem_eq_class' non_overlapping is_non_overlapping_def
      by fast
    then have "?remove_elem W = W" by simp
  }
  then have elem_neq_classes_id: "?remove_elem ` ?elem_neq_classes = ?elem_neq_classes" by fastforce

  have Q_unfolded: "?Q = ?remove_elem ` P - {{}}"
    unfolding partition_without_def
    using image_Collect_mem
    by blast
  also have "\<dots> = ?remove_elem ` (?elem_neq_classes \<union> {Y}) - {{}}" using P_wrt_elem by presburger
  also have "\<dots> = ?elem_neq_classes \<union> {?elem_eq} - {{}}"
    using Y_elem_eq elem_neq_classes_id image_Un by metis
  finally have Q_wrt_elem: "?Q = ?elem_neq_classes \<union> {?elem_eq} - {{}}" .

  have "?elem_eq = {} \<or> ?elem_eq \<notin> P"
    using elem_eq_class elem_eq_class' non_overlapping Diff_Int_distrib2 Diff_iff empty_Diff insert_iff
unfolding is_non_overlapping_def by metis
  then have "?elem_eq \<notin> P"
    using non_overlapping no_empty_in_non_overlapping
    by metis
  then have elem_neq_classes: "?elem_neq_classes - {?elem_eq} = ?elem_neq_classes" by fastforce

  show ?thesis
  proof cases
    assume "?elem_eq \<notin> ?Q" (* the class of elem is not a member of ?Q = partition_without elem P *)
    then have "?elem_eq \<in> {{}}"
      using elem_eq_wrt_P Q_unfolded
      by (metis DiffI)
    then have Y_singleton: "Y = {elem}" using elem_eq_class by fast
    then have "?Q = ?elem_neq_classes - {{}}"
      using Q_wrt_elem
      by force
    then have "?Q = ?elem_neq_classes"
      using no_empty_in_non_overlapping elem_neq_classes_part
      by blast
    then have "insert {elem} ?Q = P"
      using Y_singleton elem_eq_class'
      by fast
    then show ?thesis unfolding coarser_partitions_with_def by auto
  next
    assume True: "\<not> ?elem_eq \<notin> ?Q"
    hence Y': "?elem_neq_classes \<union> {?elem_eq} - {{}} = ?elem_neq_classes \<union> {?elem_eq}"
      using no_empty_in_non_overlapping non_overlapping non_overlapping_without_is_non_overlapping
      by force
    have "insert_into_member elem ({?elem_eq} \<union> ?elem_neq_classes) ?elem_eq = insert (?elem_eq \<union> {elem}) (({?elem_eq} \<union> ?elem_neq_classes) - {?elem_eq})"
      unfolding insert_into_member_def ..
    also have "\<dots> = ({} \<union> ?elem_neq_classes) \<union> {?elem_eq \<union> {elem}}" using elem_neq_classes by force
    also have "\<dots> = ?elem_neq_classes \<union> {Y}" using elem_eq_class by blast
    finally have "insert_into_member elem ({?elem_eq} \<union> ?elem_neq_classes) ?elem_eq = ?elem_neq_classes \<union> {Y}" .
    then have "?elem_neq_classes \<union> {Y} = insert_into_member elem ?Q ?elem_eq"
      using Q_wrt_elem Y' partition_without_def
      by force
    then have "{Y} \<union> ?elem_neq_classes \<in> insert_into_member elem ?Q ` ?Q" using True by blast
    then have "{Y} \<union> ?elem_neq_classes \<in> coarser_partitions_with elem ?Q" unfolding coarser_partitions_with_def by simp
    then show ?thesis using P_wrt_elem by simp
  qed
qed

text \<open>Given a set @{term Ps} of partitions, this is intended to compute the set of all coarser
  partitions (given an extension element) of all partitions in @{term Ps}.\<close>
definition all_coarser_partitions_with :: " 'a \<Rightarrow> 'a set set set \<Rightarrow> 'a set set set"
   where "all_coarser_partitions_with elem Ps = \<Union> (coarser_partitions_with elem ` Ps)"

text \<open>the list variant of @{const all_coarser_partitions_with}\<close>
definition all_coarser_partitions_with_list :: " 'a \<Rightarrow> 'a set list list \<Rightarrow> 'a set list list"
  where "all_coarser_partitions_with_list elem Ps =
         concat (map (coarser_partitions_with_list elem) Ps)"

text \<open>@{const all_coarser_partitions_with_list} and @{const all_coarser_partitions_with} are equivalent.\<close>
lemma all_coarser_partitions_with_list_equivalence:
  fixes elem::'a
    and Ps::"'a set list list"
  assumes distinct: "\<forall> P \<in> set Ps . distinct P"
  shows "set (map set (all_coarser_partitions_with_list elem Ps)) = all_coarser_partitions_with elem (set (map set Ps))"
    (is "?list_expr = ?set_expr")
proof -
  have "?list_expr = set (map set (concat (map (coarser_partitions_with_list elem) Ps)))"
    unfolding all_coarser_partitions_with_list_def ..
  also have "\<dots> = set ` (\<Union> x \<in> (coarser_partitions_with_list elem) ` (set Ps) . set x)" by simp
  also have "\<dots> = set ` (\<Union> x \<in> { coarser_partitions_with_list elem P | P . P \<in> set Ps } . set x)"
    by (simp add: image_Collect_mem)
  also have "\<dots> = \<Union> { set (map set (coarser_partitions_with_list elem P)) | P . P \<in> set Ps }" by auto
  also have "\<dots> = \<Union> { coarser_partitions_with elem (set P) | P . P \<in> set Ps }"
    using distinct coarser_partitions_with_list_equivalence by fast
  also have "\<dots> = \<Union> (coarser_partitions_with elem ` (set ` (set Ps)))" by (simp add: image_Collect_mem)
  also have "\<dots> = \<Union> (coarser_partitions_with elem ` (set (map set Ps)))" by simp
  also have "\<dots> = ?set_expr" unfolding all_coarser_partitions_with_def ..
  finally show ?thesis .
qed

text \<open>all partitions of a set (given as list) in form of a set\<close>
fun all_partitions_set :: "'a list \<Rightarrow> 'a set set set"
  where
   "all_partitions_set [] = {{}}" |
   "all_partitions_set (e # X) = all_coarser_partitions_with e (all_partitions_set X)"

text \<open>all partitions of a set (given as list) in form of a list\<close>
fun all_partitions_list :: "'a list \<Rightarrow> 'a set list list"
  where
   "all_partitions_list [] = [[]]" |
   "all_partitions_list (e # X) = all_coarser_partitions_with_list e (all_partitions_list X)"

text \<open>A list of partitions coarser than a given partition in list representation (constructed
  with @{const coarser_partitions_with} is distinct under certain conditions.\<close>
lemma coarser_partitions_with_list_distinct:
  fixes ps
  assumes ps_coarser: "ps \<in> set (coarser_partitions_with_list x Q)"
      and distinct: "distinct Q"
      and partition: "is_non_overlapping (set Q)"
      and new: "{x} \<notin> set Q"
  shows "distinct ps"
proof -
  have "set (coarser_partitions_with_list x Q) = insert ({x} # Q) (set (map (insert_into_member_list x Q) Q))"
    unfolding coarser_partitions_with_list_def by simp
  with ps_coarser have "ps \<in> insert ({x} # Q) (set (map ((insert_into_member_list x Q)) Q))" by blast
  then show ?thesis
  proof
    assume "ps = {x} # Q"
    with distinct and new show ?thesis by simp
  next
    assume "ps \<in> set (map (insert_into_member_list x Q) Q)"
    then obtain X where X_in_Q: "X \<in> set Q" and ps_insert: "ps = insert_into_member_list x Q X" by auto
    from ps_insert have "ps = (X \<union> {x}) # (remove1 X Q)" unfolding insert_into_member_list_def .
    also have "\<dots> = (X \<union> {x}) # (removeAll X Q)" using distinct by (metis distinct_remove1_removeAll)
    finally have ps_list: "ps = (X \<union> {x}) # (removeAll X Q)" .

    have distinct_tl: "X \<union> {x} \<notin> set (removeAll X Q)"
    proof
      from partition have partition': "\<forall>x\<in>set Q. \<forall>y\<in>set Q. (x \<inter> y \<noteq> {}) = (x = y)" unfolding is_non_overlapping_def .
      assume "X \<union> {x} \<in> set (removeAll X Q)"
      with X_in_Q partition show False by (metis partition' inf_sup_absorb member_remove no_empty_in_non_overlapping remove_code(1))
    qed
    with ps_list distinct show ?thesis by (metis (full_types) distinct.simps(2) distinct_removeAll)
  qed
qed

text \<open>The classical definition @{const all_partitions} and the algorithmic (constructive) definition @{const all_partitions_list} are equivalent.\<close>
lemma all_partitions_equivalence':
  fixes xs::"'a list"
  shows "distinct xs \<Longrightarrow>
         ((set (map set (all_partitions_list xs)) =
          all_partitions (set xs)) \<and> (\<forall> ps \<in> set (all_partitions_list xs) . distinct ps))"
proof (induct xs)
  case Nil
  have "set (map set (all_partitions_list [])) = all_partitions (set [])"
    unfolding List.set_simps(1) emptyset_part_emptyset3 by simp
    (* Sledgehammer no longer seems to find this, maybe after we have added the "distinct" part to the theorem statement. *)
  moreover have "\<forall> ps \<in> set (all_partitions_list []) . distinct ps" by fastforce
  ultimately show ?case ..
next
  case (Cons x xs)
  from Cons.prems Cons.hyps
    have hyp_equiv: "set (map set (all_partitions_list xs)) = all_partitions (set xs)" by simp
  from Cons.prems Cons.hyps
    have hyp_distinct: "\<forall> ps \<in> set (all_partitions_list xs) . distinct ps" by simp

  have distinct_xs: "distinct xs" using Cons.prems by simp
  have x_notin_xs: "x \<notin> set xs" using Cons.prems by simp

  have "set (map set (all_partitions_list (x # xs))) = all_partitions (set (x # xs))"
  proof (rule equalitySubsetI) (* -- {* case set \<rightarrow> list *} *)
    fix P::"'a set set" (* a partition *)
    let ?P_without_x = "partition_without x P"
    have P_partitions_exc_x: "\<Union> ?P_without_x = \<Union> P - {x}" using partition_without_covers .

    assume "P \<in> all_partitions (set (x # xs))"
    then have is_partition_of: "P partitions (set (x # xs))" unfolding all_partitions_def ..
    then have is_non_overlapping: "is_non_overlapping P" unfolding is_partition_of_def by simp
    from is_partition_of have P_covers: "\<Union> P = set (x # xs)" unfolding is_partition_of_def by simp

    have "?P_without_x partitions (set xs)"
      unfolding is_partition_of_def
      using is_non_overlapping non_overlapping_without_is_non_overlapping partition_without_covers P_covers x_notin_xs
      by (metis Diff_insert_absorb List.set_simps(2))
    with hyp_equiv have p_list: "?P_without_x \<in> set (map set (all_partitions_list xs))"
      unfolding all_partitions_def by fast
    have "P \<in> coarser_partitions_with x ?P_without_x"
      using coarser_partitions_inv_without is_non_overlapping P_covers
      by (metis List.set_simps(2) insertI1)
    then have "P \<in> \<Union> (coarser_partitions_with x ` set (map set (all_partitions_list xs)))"
      using p_list by blast
    then have "P \<in> all_coarser_partitions_with x (set (map set (all_partitions_list xs)))"
      unfolding all_coarser_partitions_with_def by fast
    then show "P \<in> set (map set (all_partitions_list (x # xs)))"
      using all_coarser_partitions_with_list_equivalence hyp_distinct
      by (metis all_partitions_list.simps(2))
  next (* -- {* case list \<rightarrow> set *} *)
    fix P::"'a set set" (* a partition *)
    assume P: "P \<in> set (map set (all_partitions_list (x # xs)))"

    have "set (map set (all_partitions_list (x # xs))) = set (map set (all_coarser_partitions_with_list x (all_partitions_list xs)))"
      by simp
    also have "\<dots> = all_coarser_partitions_with x (set (map set (all_partitions_list xs)))"
      using distinct_xs hyp_distinct all_coarser_partitions_with_list_equivalence by fast
    also have "\<dots> = all_coarser_partitions_with x (all_partitions (set xs))"
      using distinct_xs hyp_equiv by auto
    finally have P_set: "set (map set (all_partitions_list (x # xs))) = all_coarser_partitions_with x (all_partitions (set xs))" .

    with P have "P \<in> all_coarser_partitions_with x (all_partitions (set xs))" by fast
    then have "P \<in> \<Union> (coarser_partitions_with x ` (all_partitions (set xs)))"
      unfolding all_coarser_partitions_with_def .
    then obtain Y
      where P_in_Y: "P \<in> Y"
        and Y_coarser: "Y \<in> coarser_partitions_with x ` (all_partitions (set xs))" ..
    from Y_coarser obtain Q
      where Q_part_xs: "Q \<in> all_partitions (set xs)"
        and Y_coarser': "Y = coarser_partitions_with x Q" ..
    from P_in_Y Y_coarser' have P_wrt_Q: "P \<in> coarser_partitions_with x Q" by fast
    then have "Q \<in> all_partitions (set xs)" using Q_part_xs by simp
    then have "Q partitions (set xs)" unfolding all_partitions_def ..
    then have "is_non_overlapping Q" and Q_covers: "\<Union> Q = set xs"
      unfolding is_partition_of_def by simp_all
    then have P_partition: "is_non_overlapping P"
      using non_overlapping_extension3 P_wrt_Q x_notin_xs by fast
    have "\<Union> P = set xs \<union> {x}"
      using Q_covers P_in_Y Y_coarser' coarser_partitions_covers by fast
    then have "\<Union> P = set (x # xs)"
      using x_notin_xs P_wrt_Q Q_covers
      by (metis List.set_simps(2) insert_is_Un sup_commute)
    then have "P partitions (set (x # xs))"
      using P_partition unfolding is_partition_of_def by blast
    then show "P \<in> all_partitions (set (x # xs))" unfolding all_partitions_def ..
  qed
  moreover have "\<forall> ps \<in> set (all_partitions_list (x # xs)) . distinct ps"
  proof
    fix ps::"'a set list" assume ps_part: "ps \<in> set (all_partitions_list (x # xs))"

    have "set (all_partitions_list (x # xs)) = set (all_coarser_partitions_with_list x (all_partitions_list xs))"
      by simp
    also have "\<dots> = set (concat (map (coarser_partitions_with_list x) (all_partitions_list xs)))"
      unfolding all_coarser_partitions_with_list_def ..
    also have "\<dots> = \<Union> ((set \<circ> (coarser_partitions_with_list x)) ` (set (all_partitions_list xs)))"
      by simp
    finally have all_parts_unfolded: "set (all_partitions_list (x # xs)) = \<Union> ((set \<circ> (coarser_partitions_with_list x)) ` (set (all_partitions_list xs)))" .
    (* \<dots> = \<Union> { set (coarser_partitions_with_list x ps) | ps . ps \<in> set (all_partitions_list xs) }
       (more readable, but less useful in proofs) *)

    with ps_part obtain qs
      where qs: "qs \<in> set (all_partitions_list xs)"
        and ps_coarser: "ps \<in> set (coarser_partitions_with_list x qs)"
      using UnionE comp_def imageE by auto

    from qs have "set qs \<in> set (map set (all_partitions_list (xs)))" by simp
    with distinct_xs hyp_equiv have qs_hyp: "set qs \<in> all_partitions (set xs)" by fast
    then have qs_part: "is_non_overlapping (set qs)"
      using all_partitions_def is_partition_of_def
      by (metis mem_Collect_eq)
    then have distinct_qs: "distinct qs"
      using qs distinct_xs hyp_distinct by fast

    from Cons.prems have "x \<notin> set xs" by simp
    then have new: "{x} \<notin> set qs"
      using qs_hyp
      unfolding all_partitions_def is_partition_of_def
      by (metis (lifting, mono_tags) UnionI insertI1 mem_Collect_eq)

    from ps_coarser distinct_qs qs_part new
      show "distinct ps" by (rule coarser_partitions_with_list_distinct)
  qed
  ultimately show ?case ..
qed

text \<open>The classical definition @{const all_partitions} and the algorithmic (constructive) definition @{const all_partitions_list} are equivalent.  This is a front-end theorem derived from
  @{thm all_partitions_equivalence'}; it does not make the auxiliary statement about partitions
  being distinct lists.\<close>
theorem all_partitions_paper_equiv_alg:
  fixes xs::"'a list"
  shows "distinct xs \<Longrightarrow> set (map set (all_partitions_list xs)) = all_partitions (set xs)"
  using all_partitions_equivalence' by blast

text \<open>The function that we will be using in practice to compute all partitions of a set,
  a set-oriented front-end to @{const all_partitions_list}\<close>
definition all_partitions_alg :: "'a::linorder set \<Rightarrow> 'a set list list"
  where "all_partitions_alg X = all_partitions_list (sorted_list_of_set X)"

end


\<^marker>\<open>creator "Maximilian P. L. Haslbeck"\<close>
theory QSL_For_Potentials
imports Assertions_With_State
begin

paragraph \<open>Summary\<close>

text \<open>This theory instantiates the Quantitative Separation Logic language with the
        quantale for potentials (ennreal,>=,+,-).

    \<close>

section "showing quantitative separating connectives for ennreal with plus"

lemma INF_ennreal_add_const_local2:
  fixes f g :: "_ \<Rightarrow> ennreal"
  shows "(INF i\<in>A. f i + c) = (INF i\<in>A. f i) + c"
  apply(cases  "A={}")
  subgoal by simp
  subgoal
    using continuous_at_Inf_mono[of "\<lambda>x. x + c" "f`A"]
    using continuous_add[of "at_right (Inf (f ` A))", of "\<lambda>x. x" "\<lambda>x. c"]
    by (auto simp: image_comp mono_def)
  done

lemma INF_ennreal_const_add':
  fixes f g :: "_ \<Rightarrow> ennreal"
  shows "(INF i\<in>I. c + f i) = c + (INF i\<in>I. f i)"
    using   INF_ennreal_add_const_local2[of f c I ] by (simp add: ac_simps)

interpretation ENNREAL_PLUS: quant_sep_con_one Sup Inf sup "(\<ge>)" "(>)" inf bot top "(+)" "(-)" "0::ennreal"
  unfolding quant_sep_con_def quant_sep_con_one_def comm_quantale_def apply safe
  subgoal using dual_complete_lattice .
  subgoal by standard
  subgoal apply standard
    apply(subst INF_ennreal_const_add') by simp
  subgoal apply standard
    subgoal by auto
    subgoal by (simp add: ennreal_minus_mono)
    subgoal by (simp add: ennreal_mono_minus)
    subgoal by (metis add.commute ennreal_minus_le_iff top.not_eq_extremum)
    subgoal by simp
    done
  subgoal apply standard by (auto simp: bot_ennreal)
  done

definition star_pot_method (infixr "\<star>\<^sub>p" 35) where
  "star_pot_method = ENNREAL_PLUS.sep_conj_s_q"

lemma star_pot_method_alt':
  "star_pot_method =
    (\<lambda>P Q a. case a of (s, h) \<Rightarrow> Inf {P (s, x) + Q (s, y) |x y. h = x + y \<and> x ## y})"
  unfolding star_pot_method_def ENNREAL_PLUS.sep_conj_s_q_def ENNREAL_PLUS.sep_conj_q_def
  by (auto )

lemma star_pot_method_alt:
  "(P \<star>\<^sub>p Q) = (\<lambda>(s,h). Inf { P(s,x) + Q(s,y) | x y. h=x+y \<and> x ## y})"
  unfolding star_pot_method_alt' by simp

lemma star_pot_method_alt'':
  "(P \<star>\<^sub>p Q) = (\<lambda>(s,h). INF (x,y)\<in> { (x, y). h=x+y \<and> x ## y}. P(s,x) + Q(s,y) )"
  unfolding star_pot_method_alt'
  by (metis (no_types) ENNREAL_PLUS.sep_conj_q_alt ENNREAL_PLUS.sep_conj_q_def)

definition wand_pot_method (infixr "-\<star>\<^sub>p" 35) where
  "wand_pot_method = ENNREAL_PLUS.sep_impl_s_q"

lemma wand_pot_method_alt':
  "(-\<star>\<^sub>p) = (\<lambda>P Q a. case a of (s, h) \<Rightarrow> SUP h'\<in>{h'. h ## h' \<and> (P (s, h') < top \<or> Q (s, h + h') < top) \<and> (bot < P (s, h') \<or> bot < Q (s, h + h'))}. Q (s, h + h') - P (s, h'))"
  unfolding wand_pot_method_def ENNREAL_PLUS.sep_impl_s_q_def ENNREAL_PLUS.sep_impl_qq_def
  by auto

lemma wand_pot_method_alt:
  "(P -\<star>\<^sub>p Q) = (\<lambda>(s,h). SUP h'\<in> { h'. h ## h' \<and> (bot < P(s,h') \<or> bot < Q(s,h+h') )
                                \<and> ( P(s,h') < top \<or> Q(s,h+h') < top)}.
                                    (Q (s,h + h')) - P (s,h') )"
  unfolding wand_pot_method_alt'    by(force intro: SUP_cong)

definition "emb\<^sub>p \<equiv> (ENNREAL_PLUS.emb)"

lemma emb\<^sub>p_alt:"emb\<^sub>p = (\<lambda>P h. if P h then 0 else top)"
  by (force simp: emb\<^sub>p_def ENNREAL_PLUS.emb_def  )

lemma emb\<^sub>p_alt2: "emb\<^sub>p = (\<lambda>P sh. (if P sh then 0 else \<infinity>))"
  unfolding emb\<^sub>p_def ENNREAL_PLUS.emb_def apply transfer
  unfolding infinity_ennreal_def
  by (auto  )

lemma grr: "(\<lambda>h. emb\<^sub>p P (s, h)) = emb\<^sub>p (\<lambda>h. P (s, h))"
  unfolding emb\<^sub>p_alt by auto

thm ENNREAL_PLUS.sep_conj_q_range

lemma star_pot_method_pred_range: "((emb\<^sub>p P) \<star>\<^sub>p (emb\<^sub>p Q)) h \<in> {\<infinity>, 0}"
  apply(cases h)
  using ENNREAL_PLUS.sep_conj_s_q_range[of P Q]
  unfolding emb\<^sub>p_def star_pot_method_def infinity_ennreal_def
  by simp

lemma wand_pot_method_emb_alt:
  "((emb\<^sub>p P) -\<star>\<^sub>p Q) = (\<lambda>(s, h). SUP h'\<in>{h'. h ## h' \<and> P (s, h')}. Q (s, h + h'))"
  unfolding wand_pot_method_def
  unfolding ENNREAL_PLUS.sep_impl_s_q_def
  unfolding grr
  unfolding emb\<^sub>p_def
  apply(subst ENNREAL_PLUS.sep_impl_q_alt_general'') ..

definition "sep_empty\<^sub>p \<equiv> ENNREAL_PLUS.sep_empty_s_q"

lemma sep_empty\<^sub>p_alt: "sep_empty\<^sub>p = (\<lambda>(s, h). emb\<^sub>p (\<lambda>h. h = 0) h)"
  by (auto simp: sep_empty\<^sub>p_def emb\<^sub>p_def ENNREAL_PLUS.sep_empty_s_q_def
                    ENNREAL_PLUS.sep_empty_q_def  )

definition "pure\<^sub>p \<equiv> ENNREAL_PLUS.pure_q"

lemma wrap: "\<forall>s h1 h2. to_dual_ord (X (s, h1)) = to_dual_ord (X (s, h2))
    \<Longrightarrow> \<forall>s h1 h2. of_dual_ord (to_dual_ord (X (s, h1))) = of_dual_ord (to_dual_ord (X (s, h2)))"
  by metis

lemma pure\<^sub>p_alt: "pure\<^sub>p X \<longleftrightarrow> (\<forall>s h1 h2. X (s,h1) = X (s,h2))"
  unfolding pure\<^sub>p_def ENNREAL_PLUS.pure_q_def by auto

lemmas star_pot_method_commute = ENNREAL_PLUS.sep_conj_s_q_commute[folded star_pot_method_def]
lemmas star_pot_method_neutral =  ENNREAL_PLUS.sep_conj_s_q_neutral [folded star_pot_method_def sep_empty\<^sub>p_def]

lemmas star_pot_method_assoc = ENNREAL_PLUS.sep_conj_s_q_assoc[folded star_pot_method_def]
lemmas star_pot_method_commute_c = ENNREAL_PLUS.sep_conj_q_left_commute_s[folded star_pot_method_def]

lemma fixes P :: "_ * ('a:: sep_algebra) \<Rightarrow> ennreal"
  shows  theorem_3_6_s_1: "(P \<star>\<^sub>p inf Q R) = inf (P \<star>\<^sub>p Q) (P \<star>\<^sub>p R)"
  unfolding inf_fun_def
  using ENNREAL_PLUS.theorem_3_6_s(1)[folded star_pot_method_def, where P=P and Q=Q and R=R  ]
  by simp

lemmas star_pot_method_mono = ENNREAL_PLUS.sep_conj_s_q_mono[folded star_pot_method_def]
lemmas star_pot_method_mono_more = ENNREAL_PLUS.sep_conj_s_q_mono_more[folded star_pot_method_def]

lemmas theorem_3_6_s_2 = ENNREAL_PLUS.theorem_3_6_s(2)[folded star_pot_method_def emb\<^sub>p_def]

lemmas wand_pot_method_mono = ENNREAL_PLUS.sep_impl_s_q_mono[folded wand_pot_method_def sep_empty\<^sub>p_def]

lemmas wand_pot_method_Rmono = ENNREAL_PLUS.sep_impl_s_q_Rmono[folded wand_pot_method_def sep_empty\<^sub>p_def]

lemmas adjoint_general_s = ENNREAL_PLUS.adjoint_general_s[folded wand_pot_method_def star_pot_method_def]
lemmas adjoint_general_s_liberal = ENNREAL_PLUS.adjoint_general_s_liberal[folded wand_pot_method_def star_pot_method_def]
lemma adjoint_general_s':
  "Y \<le> (X \<star>\<^sub>p P) \<longleftrightarrow> (P -\<star>\<^sub>p Y)  \<le> X"
  using adjoint_general_s[of Y X P] unfolding le_fun_def by auto

lemmas quant_modus_ponens_general_s = ENNREAL_PLUS.quant_modus_ponens_general_s[folded wand_pot_method_def star_pot_method_def]

lemma plus_fun': "f + g = (\<lambda>h. f h + g h)"
  apply(rule ext) by simp

lemmas theorem_3_11_1 = ENNREAL_PLUS.theorem_3_11_1[folded pure\<^sub>p_def  star_pot_method_def]

lemmas theorem_3_11_3 = ENNREAL_PLUS.theorem_3_11_3[folded pure\<^sub>p_def star_pot_method_def]

subsection \<open>Experiments for an inverted order on ennreal\<close>

class divide_right_mono = inverse + order +
  assumes divide_right_mono_general: "\<And>a b c::'a. a \<le> b \<Longrightarrow> a / c \<le> b / c"

class SUP_mult_left = complete_lattice + times +
  assumes SUP_mult_left: "c * (SUP i\<in>I. f i) = (SUP i\<in>I. c * f i :: 'a)"
begin

lemma   SUP_mult_right: "(SUP i\<in>I. f i) * c = (SUP i\<in>I. f i * c :: 'a)"
  oops

end

instance ennreal :: SUP_mult_left
  apply standard apply(rule SUP_mult_left_ennreal) .

thm SUP_mult_left_ennreal

datatype ennreal_inv = E (thee: ennreal)

instantiation ennreal_inv :: SUP_mult_left
begin

fun times_ennreal_inv where "times_ennreal_inv (E x1) (E x2) = E (x1 + x2)"
fun Inf_ennreal_inv where "Inf_ennreal_inv A = E (Sup (thee ` A))"
fun Sup_ennreal_inv where "Sup_ennreal_inv A = E (Inf (thee ` A))"
definition bot_ennreal_inv where [simp]: "bot_ennreal_inv = E top"
fun  sup_ennreal_inv where "sup_ennreal_inv (E a) (E b) = E (inf a b)"
definition top_ennreal_inv where  [simp]: "top_ennreal_inv = E bot"
fun  inf_ennreal_inv where "inf_ennreal_inv (E a) (E b) = E (sup a b)"
fun  less_eq_ennreal_inv where "less_eq_ennreal_inv (E a) (E b) = (a \<ge> b)"
fun  less_ennreal_inv where "less_ennreal_inv (E a) (E b) = (a > b)"

lemma thee_times: "thee (a * b) = thee a + thee b"
  apply(cases a; cases b) by auto

instance apply(standard)
  subgoal for x y apply(cases x; cases y) by auto
  subgoal for x  apply(cases x ) by auto
  subgoal for x y z apply(cases x; cases y; cases z) by auto
  subgoal for x y apply(cases x; cases y) by auto
  subgoal for x y apply(cases x; cases y) by auto
  subgoal for x y apply(cases x; cases y) by auto
  subgoal for x y z apply(cases x; cases y; cases z) by auto
  subgoal for x y apply(cases x; cases y) by auto
  subgoal for x y apply(cases x; cases y) by auto
  subgoal for x y z apply(cases x; cases y; cases z) by auto
  subgoal for x A apply(cases x) apply simp
    by (simp add: Sup_upper rev_image_eqI)
  subgoal for A z apply(cases z) apply simp
    by (metis SUP_least ennreal_inv.exhaust_sel less_eq_ennreal_inv.simps)
  subgoal for x A apply(cases x) apply simp
    by (metis INF_lower ennreal_inv.sel)
  subgoal for A z apply(cases z) apply simp
    by (metis INF_greatest ennreal_inv.collapse less_eq_ennreal_inv.simps)
  subgoal   by auto
  subgoal   by auto
  subgoal for c f I apply(cases c) by (simp add: image_comp thee_times INF_ennreal_const_add')
  done
end

instance ennreal_inv :: ab_semigroup_mult
  apply(standard)
  subgoal for a b c apply(cases a; cases b; cases c) by (auto simp: mult.assoc)
  subgoal for a b   apply(cases a; cases b ) by (auto simp: mult.commute)
  done

thm complete_lattice_axioms
term complete_lattice

term "\<infinity> - \<infinity>"
lemma "\<infinity> - \<infinity> = (\<infinity>::ennreal)" by simp

subsection  "more experiments with type classes"

class nogoodname = bot + top + times +
  assumes bot_squared: "bot * bot = bot"
    and  top_squared: "top * top = top"

class nonnegative = zero + order +
  assumes zero_smallest: "\<And>x::'a. 0 \<le> x"

instance ennreal :: nonnegative
  apply(standard) by auto

lemma SUP_times_distrib: "(SUP xA. f x * g x::ennreal) \<le> (SUP xA. f x) * (SUP xA. g x)"
      by (simp add: SUP_least SUP_upper mult_mono)

lemma SUP_times_distrib2: "(SUP (x,y)A. f x y * g x y::ennreal) \<le> (SUP (x, y)A. f x y) * (SUP (x, y)A. g x y)"
  apply(rule Sup_least) apply auto
  apply(rule mult_mono) apply(auto simp: image_image SUP_image intro:  SUP_upper)
  subgoal by (metis ENNREAL_PLUS.INF_lower UNIV_I old.prod.case)
  subgoal
    by (metis ENNREAL_PLUS.INF_lower UNIV_I old.prod.case)
  done

lemma SUP_times_distrib2_general:
  fixes g :: "_\<Rightarrow>_\<Rightarrow>'b::{complete_lattice,ordered_semiring, nonnegative}"
  shows "(SUP (x,y)A. f x y * g x y) \<le> (SUP (x, y)A. f x y) * (SUP (x, y)A. g x y)"
  apply(rule SUP_least)
  apply auto apply(rule mult_mono)
     apply (auto intro: SUP_upper2 simp: SUP_image zero_smallest)
  subgoal by (metis SUP_upper UNIV_I prod.simps(2))
  subgoal by (metis SUP_le_iff UNIV_I case_prod_conv order_refl)
  done

end


theory Demo1 imports Main begin

subsection {* @{text "?thesis"}, @{text this}, \isakeyword{then} *}

lemma "A \<and> B \<longrightarrow> B \<and> A"
proof
  assume "A \<and> B"
  from this show "B \<and> A"
  proof
    assume "A" "B"
    show ?thesis ..
  qed
qed

subsection {* \isakeyword{with} *}

lemma "A \<and> B \<longrightarrow> B \<and> A"
proof
  assume ab: "A \<and> B"
  from ab have a: "A" ..
  from ab have b: "B" ..
  from b a show "B \<and> A" ..
qed

subsection{*Predicate calculus*}

text{* \isakeyword{fix} *}

lemma "\<forall>x. P x \<Longrightarrow> \<forall>x. P(f x)"
proof
  fix a
  assume "\<forall>x. P x"
  then show "P(f a)" ..
qed

lemma "\<exists>x. P(f x) \<Longrightarrow> \<exists>y. P y"
proof -
  assume "\<exists>x. P(f x)"
  then show ?thesis
  proof
    fix x
    assume "P(f x)"
    show ?thesis ..
  qed
qed

text{* \isakeyword{obtain} *}

lemma "\<exists>x. P(f x) \<Longrightarrow> \<exists>y. P y"
proof -
  assume "\<exists>x. P(f x)"
  then obtain x where "P(f x)" ..
  then show "\<exists>y. P y" ..
qed

end


theory prop_32
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun length :: "'a list => Nat" where
  "length (Nil2) = Z"
  | "length (Cons2 y xs) = S (length xs)"
  fun append :: "'a list => 'a list => 'a list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  fun rotate :: "Nat => 'a list => 'a list" where
  "rotate (Z) y = y"
  | "rotate (S z) (Nil2) = Nil2"
  | "rotate (S z) (Cons2 x2 x3) =
       rotate z (append x3 (Cons2 x2 (Nil2)))"
  (*hipster length append rotate *)
(*hipster length append rotate*)
lemma lemma_a [thy_expl]: "append x2 Nil2 = x2"
by (hipster_induct_schemes length.simps append.simps rotate.simps)

lemma lemma_aa [thy_expl]: "rotate x1 Nil2 = Nil2"
by (hipster_induct_schemes length.simps append.simps rotate.simps)

lemma lemma_ab [thy_expl]: "append (append x1 y1) z1 = append x1 (append y1 z1)"
by (hipster_induct_schemes length.simps append.simps rotate.simps)

lemma lemma_ac [thy_expl]: "rotate x2 (Cons2 y2 Nil2) = Cons2 y2 Nil2"
by (hipster_induct_schemes length.simps append.simps rotate.simps)

lemma lemma_ad [thy_expl]: "append (rotate x3 y3) (rotate x3 y3) = rotate x3 (append y3 y3)"
by (hipster_induct_schemes length.simps append.simps rotate.simps)

lemma lemma_ae [thy_expl]: "rotate (length x4) (append x4 y4) = append y4 x4"
by (hipster_induct_schemes length.simps append.simps rotate.simps)

lemma lemma_af [thy_expl]: "rotate (S Z) (rotate x2 y2) = rotate (S x2) y2"
by (hipster_induct_schemes length.simps append.simps rotate.simps)

lemma unknown [thy_expl]: "rotate x (rotate y z) = rotate y (rotate x z)"
oops

lemma unknown [thy_expl]: "length (append x y) = length (append y x)"
oops

lemma unknown [thy_expl]: "length (rotate x y) = length y"
oops

lemma unknown [thy_expl]: "rotate (S x) (rotate y z) = rotate (S y) (rotate x z)"
oops

lemma unknown [thy_expl]: "rotate (length x) (rotate y x) = rotate y x"
oops

  theorem x0 :
    "(rotate (length x) x) = x"
    by (hipster_induct_schemes rotate.simps length.simps)
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


theory NewDat
imports Main
        "../IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
(*datatype_compat list
datatype_compat Nat*)

  fun zip2 :: "'a list => 'b list => ('a * 'b) list" where
  "zip2 (Nil2) y = Nil2"
  | "zip2 (Cons2 z x2) (Nil2) = Nil2"
  | "zip2 (Cons2 z x2) (Cons2 x3 x4) = Cons2 (z, x3) (zip2 x2 x4)"
  fun len :: "'a list => Nat" where
  "len (Nil2) = Z"
  | "len (Cons2 y xs) = S (len xs)"
  fun append :: "'a list => 'a list => 'a list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  fun rev :: "'a list => 'a list" where
  "rev (Nil2) = Nil2"
  | "rev (Cons2 y xs) = append (rev xs) (Cons2 y (Nil2))"
  (*hipster zip2 len append rev *)
  (*hipster rev*)
lemma lemma_a [thy_expl]: "append x2 Nil2 = x2"
by (hipster_induct_schemes rev.simps)

lemma lemma_aa [thy_expl]: "append (append x2 y2) z2 = append x2 (append y2 z2)"
by (hipster_induct_schemes rev.simps)

lemma lemma_ab [thy_expl]: "append (rev x5) (rev y5) = rev (append y5 x5)"
by (hipster_induct_schemes rev.simps)

(*hipster len zip2*)
lemma lemma_ac [thy_expl]: "zip2 Nil2 x1 = zip2 x1 Nil2"
by (hipster_induct_schemes len.simps zip2.simps)

lemma lemma_ad [thy_expl]: "zip2 Nil2 x1 = zip2 y1 Nil2"
by (hipster_induct_schemes len.simps zip2.simps)

(*hipster rev zip2*)
lemma lemma_ae [thy_expl]: "zip2 x2 (append x2 y2) = zip2 x2 x2"
by (hipster_induct_schemes rev.simps zip2.simps)

lemma lemma_af [thy_expl]: "zip2 (append x1 y1) x1 = zip2 x1 x1"
by (hipster_induct_schemes rev.simps zip2.simps)

(*hipster zip2 append*)
lemma lemma_ah [thy_expl]: "zip2 (append x4 x4) (Cons2 y4 Nil2) = zip2 x4 (Cons2 y4 Nil2)"
by (hipster_induct_schemes zip2.simps append.simps)

lemma lemma_ai [thy_expl]: "zip2 (Cons2 x1 Nil2) (append y1 y1) = zip2 (Cons2 x1 Nil2) y1"
by (hipster_induct_schemes zip2.simps append.simps)

(*hipster len rev append*)
lemma lemma_aj [thy_expl]: "rev (rev x3) = x3"
by (hipster_induct_schemes len.simps rev.simps append.simps)

end


theory Timestamp
  imports "HOL-Library.Extended_Nat" "HOL-Library.Extended_Real"
begin

class embed_nat =
  fixes \<iota> :: "nat \<Rightarrow> 'a"

class tfin =
  fixes tfin :: "'a set"

class timestamp = comm_monoid_add + semilattice_sup + embed_nat + tfin +
  assumes \<iota>_mono: "\<And>i j. i \<le> j \<Longrightarrow> \<iota> i \<le> \<iota> j"
    and \<iota>_tfin: "\<And>i. \<iota> i \<in> tfin"
    and \<iota>_progressing: "x \<in> tfin \<Longrightarrow> \<exists>j. \<not>\<iota> j \<le> \<iota> i + x"
    and zero_tfin: "0 \<in> tfin"
    and tfin_closed: "c \<in> tfin \<Longrightarrow> d \<in> tfin \<Longrightarrow> c + d \<in> tfin"
    and add_mono: "c \<le> d \<Longrightarrow> a + c \<le> a + d"
    and add_pos: "a \<in> tfin \<Longrightarrow> 0 < c \<Longrightarrow> a < a + c"
begin

lemma add_mono_comm:
  fixes a :: 'a
  shows "c \<le> d \<Longrightarrow> c + a \<le> d + a"
  by (auto simp: add.commute add_mono)

end

(* Extending time domain with infinity (None). *)

instantiation option :: (timestamp) timestamp
begin

definition tfin_option :: "'a option set" where
  "tfin_option = Some ` tfin"

definition \<iota>_option :: "nat \<Rightarrow> 'a option" where
  "\<iota>_option = Some \<circ> \<iota>"

definition zero_option :: "'a option" where
  "zero_option = Some 0"

definition plus_option :: "'a option \<Rightarrow> 'a option \<Rightarrow> 'a option" where
  "plus_option x y = (case x of None \<Rightarrow> None | Some x' \<Rightarrow> (case y of None \<Rightarrow> None | Some y' \<Rightarrow> Some (x' + y')))"

definition sup_option :: "'a option \<Rightarrow> 'a option \<Rightarrow> 'a option" where
  "sup_option x y = (case x of None \<Rightarrow> None | Some x' \<Rightarrow> (case y of None \<Rightarrow> None | Some y' \<Rightarrow> Some (sup x' y')))"

definition less_option :: "'a option \<Rightarrow> 'a option \<Rightarrow> bool" where
  "less_option x y = (case x of None \<Rightarrow> False | Some x' \<Rightarrow> (case y of None \<Rightarrow> True | Some y' \<Rightarrow> x' < y'))"

definition less_eq_option :: "'a option \<Rightarrow> 'a option \<Rightarrow> bool" where
  "less_eq_option x y = (case x of None \<Rightarrow> x = y | Some x' \<Rightarrow> (case y of None \<Rightarrow> True | Some y' \<Rightarrow> x' \<le> y'))"

instance
  apply standard
                  apply (auto simp: plus_option_def add.assoc split: option.splits)[1]
                 apply (auto simp: plus_option_def add.commute split: option.splits)[1]
                apply (auto simp: zero_option_def plus_option_def split: option.splits)[1]
               apply (auto simp: less_option_def less_eq_option_def split: option.splits)[1]
              apply (auto simp: less_eq_option_def split: option.splits)[3]
           apply (auto simp: sup_option_def less_eq_option_def split: option.splits)[3]
        apply (auto simp: \<iota>_option_def less_eq_option_def intro: \<iota>_mono)[1]
       apply (auto simp: tfin_option_def \<iota>_option_def intro: \<iota>_tfin)[1]
      apply (auto simp: tfin_option_def \<iota>_option_def plus_option_def less_eq_option_def intro: \<iota>_progressing)[1]
     apply (auto simp: tfin_option_def zero_option_def intro: zero_tfin)[1]
    apply (auto simp: tfin_option_def plus_option_def intro: tfin_closed)[1]
   apply (auto simp: plus_option_def less_eq_option_def intro: add_mono split: option.splits)[1]
  apply (auto simp: tfin_option_def zero_option_def plus_option_def less_option_def intro: add_pos split: option.splits)
  done

end

instantiation enat :: timestamp
begin

definition tfin_enat :: "enat set" where
  "tfin_enat = UNIV - {\<infinity>}"

definition \<iota>_enat :: "nat \<Rightarrow> enat" where
  "\<iota>_enat n = n"

instance
  by standard (auto simp add: \<iota>_enat_def tfin_enat_def dest!: leD)

end

instantiation ereal :: timestamp
begin

definition \<iota>_ereal :: "nat \<Rightarrow> ereal" where
  "\<iota>_ereal n = ereal n"

definition tfin_ereal :: "ereal set" where
  "tfin_ereal = UNIV - {-\<infinity>, \<infinity>}"

lemma ereal_add_pos:
  fixes a :: ereal
  shows "a \<in> tfin \<Longrightarrow> 0 < c \<Longrightarrow> a < a + c"
  by (auto simp: tfin_ereal_def) (metis add.right_neutral ereal_add_cancel_left ereal_le_add_self order_less_le)

instance
  by standard (auto simp add: \<iota>_ereal_def tfin_ereal_def add.commute ereal_add_le_add_iff2 not_le
      less_PInf_Ex_of_nat ereal_less_ereal_Ex reals_Archimedean2 intro: ereal_add_pos)

end

class timestamp_total = timestamp +
  assumes timestamp_total: "a \<le> b \<or> b \<le> a"
  assumes timestamp_tfin_le_not_tfin: "0 \<le> a \<Longrightarrow> a \<in> tfin \<Longrightarrow> 0 \<le> b \<Longrightarrow> b \<notin> tfin \<Longrightarrow> a \<le> b"
begin

lemma add_not_tfin: "0 \<le> a \<Longrightarrow> a \<in> tfin \<Longrightarrow> a \<le> c \<Longrightarrow> c \<in> tfin \<Longrightarrow> 0 \<le> b \<Longrightarrow> b \<notin> tfin \<Longrightarrow> c < a + b"
  by (metis add_0_left local.add_mono_comm timestamp_tfin_le_not_tfin dual_order.order_iff_strict dual_order.strict_trans1)

end

instantiation enat :: timestamp_total
begin

instance
  by standard (auto simp: tfin_enat_def)

end

instantiation ereal :: timestamp_total
begin

instance
  by standard (auto simp: tfin_ereal_def)

end

class timestamp_strict = timestamp +
  assumes add_mono_strict: "c < d \<Longrightarrow> a + c < a + d"

class timestamp_total_strict = timestamp_total + timestamp_strict

instantiation nat :: timestamp_total_strict
begin

definition tfin_nat :: "nat set" where
  "tfin_nat = UNIV"

definition \<iota>_nat :: "nat \<Rightarrow> nat" where
  "\<iota>_nat n = n"

instance
  by standard (auto simp: tfin_nat_def \<iota>_nat_def dest!: leD)

end

instantiation real :: timestamp_total_strict
begin

definition tfin_real :: "real set" where "tfin_real = UNIV"

definition \<iota>_real :: "nat \<Rightarrow> real" where "\<iota>_real n = real n"

instance
  by standard (auto simp: tfin_real_def \<iota>_real_def not_le reals_Archimedean2)

end

instantiation prod :: (comm_monoid_add, comm_monoid_add) comm_monoid_add
begin

definition zero_prod :: "'a \<times> 'b" where
  "zero_prod = (0, 0)"

fun plus_prod :: "'a \<times> 'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'a \<times> 'b" where
  "(a, b) + (c, d) = (a + c, b + d)"

instance
  by standard (auto simp: zero_prod_def ac_simps)

end

end


(* Author: Tobias Nipkow *)

subsection "Widening and Narrowing"

theory Abs_Int3
imports Abs_Int2_ivl
begin

class widen =
fixes widen :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infix "\<nabla>" 65)

class narrow =
fixes narrow :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infix "\<triangle>" 65)

class wn = widen + narrow + order +
assumes widen1: "x \<le> x \<nabla> y"
assumes widen2: "y \<le> x \<nabla> y"
assumes narrow1: "y \<le> x \<Longrightarrow> y \<le> x \<triangle> y"
assumes narrow2: "y \<le> x \<Longrightarrow> x \<triangle> y \<le> x"
begin

lemma narrowid[simp]: "x \<triangle> x = x"
by (metis eq_iff narrow1 narrow2)

end

lemma top_widen_top[simp]: "\<top> \<nabla> \<top> = (\<top>::_::{wn,order_top})"
by (metis eq_iff top_greatest widen2)

instantiation ivl :: wn
begin

definition "widen_rep p1 p2 =
  (if is_empty_rep p1 then p2 else if is_empty_rep p2 then p1 else
   let (l1,h1) = p1; (l2,h2) = p2
   in (if l2 < l1 then Minf else l1, if h1 < h2 then Pinf else h1))"

lift_definition widen_ivl :: "ivl \<Rightarrow> ivl \<Rightarrow> ivl" is widen_rep
by(auto simp: widen_rep_def eq_ivl_iff)

definition "narrow_rep p1 p2 =
  (if is_empty_rep p1 \<or> is_empty_rep p2 then empty_rep else
   let (l1,h1) = p1; (l2,h2) = p2
   in (if l1 = Minf then l2 else l1, if h1 = Pinf then h2 else h1))"

lift_definition narrow_ivl :: "ivl \<Rightarrow> ivl \<Rightarrow> ivl" is narrow_rep
by(auto simp: narrow_rep_def eq_ivl_iff)

instance
proof
qed (transfer, auto simp: widen_rep_def narrow_rep_def le_iff_subset \<gamma>_rep_def subset_eq is_empty_rep_def empty_rep_def eq_ivl_def split: if_splits extended.splits)+

end

instantiation st :: ("{order_top,wn}")wn
begin

lift_definition widen_st :: "'a st \<Rightarrow> 'a st \<Rightarrow> 'a st" is "map2_st_rep (\<nabla>)"
by(auto simp: eq_st_def)

lift_definition narrow_st :: "'a st \<Rightarrow> 'a st \<Rightarrow> 'a st" is "map2_st_rep (\<triangle>)"
by(auto simp: eq_st_def)

instance
proof (standard, goal_cases)
  case 1 thus ?case by transfer (simp add: less_eq_st_rep_iff widen1)
next
  case 2 thus ?case by transfer (simp add: less_eq_st_rep_iff widen2)
next
  case 3 thus ?case by transfer (simp add: less_eq_st_rep_iff narrow1)
next
  case 4 thus ?case by transfer (simp add: less_eq_st_rep_iff narrow2)
qed

end

instantiation option :: (wn)wn
begin

fun widen_option where
"None \<nabla> x = x" |
"x \<nabla> None = x" |
"(Some x) \<nabla> (Some y) = Some(x \<nabla> y)"

fun narrow_option where
"None \<triangle> x = None" |
"x \<triangle> None = None" |
"(Some x) \<triangle> (Some y) = Some(x \<triangle> y)"

instance
proof (standard, goal_cases)
  case (1 x y) thus ?case
    by(induct x y rule: widen_option.induct)(simp_all add: widen1)
next
  case (2 x y) thus ?case
    by(induct x y rule: widen_option.induct)(simp_all add: widen2)
next
  case (3 x y) thus ?case
    by(induct x y rule: narrow_option.induct) (simp_all add: narrow1)
next
  case (4 y x) thus ?case
    by(induct x y rule: narrow_option.induct) (simp_all add: narrow2)
qed

end

definition map2_acom :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a acom \<Rightarrow> 'a acom \<Rightarrow> 'a acom"
where
"map2_acom f C1 C2 = annotate (\<lambda>p. f (anno C1 p) (anno C2 p)) (strip C1)"

instantiation acom :: (widen)widen
begin
definition "widen_acom = map2_acom (\<nabla>)"
instance ..
end

instantiation acom :: (narrow)narrow
begin
definition "narrow_acom = map2_acom (\<triangle>)"
instance ..
end

lemma strip_map2_acom[simp]:
 "strip C1 = strip C2 \<Longrightarrow> strip(map2_acom f C1 C2) = strip C1"
by(simp add: map2_acom_def)
(*by(induct f C1 C2 rule: map2_acom.induct) simp_all*)

lemma strip_widen_acom[simp]:
  "strip C1 = strip C2 \<Longrightarrow> strip(C1 \<nabla> C2) = strip C1"
by(simp add: widen_acom_def)

lemma strip_narrow_acom[simp]:
  "strip C1 = strip C2 \<Longrightarrow> strip(C1 \<triangle> C2) = strip C1"
by(simp add: narrow_acom_def)

lemma narrow1_acom: "C2 \<le> C1 \<Longrightarrow> C2 \<le> C1 \<triangle> (C2::'a::wn acom)"
by(simp add: narrow_acom_def narrow1 map2_acom_def less_eq_acom_def size_annos)

lemma narrow2_acom: "C2 \<le> C1 \<Longrightarrow> C1 \<triangle> (C2::'a::wn acom) \<le> C1"
by(simp add: narrow_acom_def narrow2 map2_acom_def less_eq_acom_def size_annos)

subsubsection "Pre-fixpoint computation"

definition iter_widen :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> ('a::{order,widen})option"
where "iter_widen f = while_option (\<lambda>x. \<not> f x \<le> x) (\<lambda>x. x \<nabla> f x)"

definition iter_narrow :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> ('a::{order,narrow})option"
where "iter_narrow f = while_option (\<lambda>x. x \<triangle> f x < x) (\<lambda>x. x \<triangle> f x)"

definition pfp_wn :: "('a::{order,widen,narrow} \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a option"
where "pfp_wn f x =
  (case iter_widen f x of None \<Rightarrow> None | Some p \<Rightarrow> iter_narrow f p)"

lemma iter_widen_pfp: "iter_widen f x = Some p \<Longrightarrow> f p \<le> p"
by(auto simp add: iter_widen_def dest: while_option_stop)

lemma iter_widen_inv:
assumes "!!x. P x \<Longrightarrow> P(f x)" "!!x1 x2. P x1 \<Longrightarrow> P x2 \<Longrightarrow> P(x1 \<nabla> x2)" and "P x"
and "iter_widen f x = Some y" shows "P y"
using while_option_rule[where P = "P", OF _ assms(4)[unfolded iter_widen_def]]
by (blast intro: assms(1-3))

lemma strip_while: fixes f :: "'a acom \<Rightarrow> 'a acom"
assumes "\<forall>C. strip (f C) = strip C" and "while_option P f C = Some C'"
shows "strip C' = strip C"
using while_option_rule[where P = "\<lambda>C'. strip C' = strip C", OF _ assms(2)]
by (metis assms(1))

lemma strip_iter_widen: fixes f :: "'a::{order,widen} acom \<Rightarrow> 'a acom"
assumes "\<forall>C. strip (f C) = strip C" and "iter_widen f C = Some C'"
shows "strip C' = strip C"
proof-
  have "\<forall>C. strip(C \<nabla> f C) = strip C"
    by (metis assms(1) strip_map2_acom widen_acom_def)
  from strip_while[OF this] assms(2) show ?thesis by(simp add: iter_widen_def)
qed

lemma iter_narrow_pfp:
assumes mono: "!!x1 x2::_::wn acom. P x1 \<Longrightarrow> P x2 \<Longrightarrow> x1 \<le> x2 \<Longrightarrow> f x1 \<le> f x2"
and Pinv: "!!x. P x \<Longrightarrow> P(f x)" "!!x1 x2. P x1 \<Longrightarrow> P x2 \<Longrightarrow> P(x1 \<triangle> x2)"
and "P p0" and "f p0 \<le> p0" and "iter_narrow f p0 = Some p"
shows "P p \<and> f p \<le> p"
proof-
  let ?Q = "%p. P p \<and> f p \<le> p \<and> p \<le> p0"
  have "?Q (p \<triangle> f p)" if Q: "?Q p" for p
  proof auto
    note P = conjunct1[OF Q] and 12 = conjunct2[OF Q]
    note 1 = conjunct1[OF 12] and 2 = conjunct2[OF 12]
    let ?p' = "p \<triangle> f p"
    show "P ?p'" by (blast intro: P Pinv)
    have "f ?p' \<le> f p" by(rule mono[OF \<open>P (p \<triangle> f p)\<close>  P narrow2_acom[OF 1]])
    also have "\<dots> \<le> ?p'" by(rule narrow1_acom[OF 1])
    finally show "f ?p' \<le> ?p'" .
    have "?p' \<le> p" by (rule narrow2_acom[OF 1])
    also have "p \<le> p0" by(rule 2)
    finally show "?p' \<le> p0" .
  qed
  thus ?thesis
    using while_option_rule[where P = ?Q, OF _ assms(6)[simplified iter_narrow_def]]
    by (blast intro: assms(4,5) le_refl)
qed

lemma pfp_wn_pfp:
assumes mono: "!!x1 x2::_::wn acom. P x1 \<Longrightarrow> P x2 \<Longrightarrow> x1 \<le> x2 \<Longrightarrow> f x1 \<le> f x2"
and Pinv: "P x"  "!!x. P x \<Longrightarrow> P(f x)"
  "!!x1 x2. P x1 \<Longrightarrow> P x2 \<Longrightarrow> P(x1 \<nabla> x2)"
  "!!x1 x2. P x1 \<Longrightarrow> P x2 \<Longrightarrow> P(x1 \<triangle> x2)"
and pfp_wn: "pfp_wn f x = Some p" shows "P p \<and> f p \<le> p"
proof-
  from pfp_wn obtain p0
    where its: "iter_widen f x = Some p0" "iter_narrow f p0 = Some p"
    by(auto simp: pfp_wn_def split: option.splits)
  have "P p0" by (blast intro: iter_widen_inv[where P="P"] its(1) Pinv(1-3))
  thus ?thesis
    by - (assumption |
          rule iter_narrow_pfp[where P=P] mono Pinv(2,4) iter_widen_pfp its)+
qed

lemma strip_pfp_wn:
  "\<lbrakk> \<forall>C. strip(f C) = strip C; pfp_wn f C = Some C' \<rbrakk> \<Longrightarrow> strip C' = strip C"
by(auto simp add: pfp_wn_def iter_narrow_def split: option.splits)
  (metis (mono_tags) strip_iter_widen strip_narrow_acom strip_while)

locale Abs_Int_wn = Abs_Int_inv_mono where \<gamma>=\<gamma>
  for \<gamma> :: "'av::{wn,bounded_lattice} \<Rightarrow> val set"
begin

definition AI_wn :: "com \<Rightarrow> 'av st option acom option" where
"AI_wn c = pfp_wn (step' \<top>) (bot c)"

lemma AI_wn_correct: "AI_wn c = Some C \<Longrightarrow> CS c \<le> \<gamma>\<^sub>c C"
proof(simp add: CS_def AI_wn_def)
  assume 1: "pfp_wn (step' \<top>) (bot c) = Some C"
  have 2: "strip C = c \<and> step' \<top> C \<le> C"
    by(rule pfp_wn_pfp[where x="bot c"]) (simp_all add: 1 mono_step'_top)
  have pfp: "step (\<gamma>\<^sub>o \<top>) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c C"
  proof(rule order_trans)
    show "step (\<gamma>\<^sub>o \<top>) (\<gamma>\<^sub>c C) \<le>  \<gamma>\<^sub>c (step' \<top> C)"
      by(rule step_step')
    show "... \<le> \<gamma>\<^sub>c C"
      by(rule mono_gamma_c[OF conjunct2[OF 2]])
  qed
  have 3: "strip (\<gamma>\<^sub>c C) = c" by(simp add: strip_pfp_wn[OF _ 1])
  have "lfp c (step (\<gamma>\<^sub>o \<top>)) \<le> \<gamma>\<^sub>c C"
    by(rule lfp_lowerbound[simplified,where f="step (\<gamma>\<^sub>o \<top>)", OF 3 pfp])
  thus "lfp c (step UNIV) \<le> \<gamma>\<^sub>c C" by simp
qed

end

global_interpretation Abs_Int_wn
where \<gamma> = \<gamma>_ivl and num' = num_ivl and plus' = "(+)"
and test_num' = in_ivl
and inv_plus' = inv_plus_ivl and inv_less' = inv_less_ivl
defines AI_wn_ivl = AI_wn
..

subsubsection "Tests"

definition "step_up_ivl n = ((\<lambda>C. C \<nabla> step_ivl \<top> C)^^n)"
definition "step_down_ivl n = ((\<lambda>C. C \<triangle> step_ivl \<top> C)^^n)"

text\<open>For \<^const>\<open>test3_ivl\<close>, \<^const>\<open>AI_ivl\<close> needed as many iterations as
the loop took to execute. In contrast, \<^const>\<open>AI_wn_ivl\<close> converges in a
constant number of steps:\<close>

value "show_acom (step_up_ivl 1 (bot test3_ivl))"
value "show_acom (step_up_ivl 2 (bot test3_ivl))"
value "show_acom (step_up_ivl 3 (bot test3_ivl))"
value "show_acom (step_up_ivl 4 (bot test3_ivl))"
value "show_acom (step_up_ivl 5 (bot test3_ivl))"
value "show_acom (step_up_ivl 6 (bot test3_ivl))"
value "show_acom (step_up_ivl 7 (bot test3_ivl))"
value "show_acom (step_up_ivl 8 (bot test3_ivl))"
value "show_acom (step_down_ivl 1 (step_up_ivl 8 (bot test3_ivl)))"
value "show_acom (step_down_ivl 2 (step_up_ivl 8 (bot test3_ivl)))"
value "show_acom (step_down_ivl 3 (step_up_ivl 8 (bot test3_ivl)))"
value "show_acom (step_down_ivl 4 (step_up_ivl 8 (bot test3_ivl)))"
value "show_acom_opt (AI_wn_ivl test3_ivl)"

text\<open>Now all the analyses terminate:\<close>

value "show_acom_opt (AI_wn_ivl test4_ivl)"
value "show_acom_opt (AI_wn_ivl test5_ivl)"
value "show_acom_opt (AI_wn_ivl test6_ivl)"

subsubsection "Generic Termination Proof"

lemma top_on_opt_widen:
  "top_on_opt o1 X \<Longrightarrow> top_on_opt o2 X \<Longrightarrow> top_on_opt (o1 \<nabla> o2 :: _ st option) X"
apply(induct o1 o2 rule: widen_option.induct)
apply (auto)
by transfer simp

lemma top_on_opt_narrow:
  "top_on_opt o1 X \<Longrightarrow> top_on_opt o2 X \<Longrightarrow> top_on_opt (o1 \<triangle> o2 :: _ st option) X"
apply(induct o1 o2 rule: narrow_option.induct)
apply (auto)
by transfer simp

(* FIXME mk anno abbrv *)
lemma annos_map2_acom[simp]: "strip C2 = strip C1 \<Longrightarrow>
  annos(map2_acom f C1 C2) = map (%(x,y).f x y) (zip (annos C1) (annos C2))"
by(simp add: map2_acom_def list_eq_iff_nth_eq size_annos anno_def[symmetric] size_annos_same[of C1 C2])

lemma top_on_acom_widen:
  "\<lbrakk>top_on_acom C1 X; strip C1 = strip C2; top_on_acom C2 X\<rbrakk>
  \<Longrightarrow> top_on_acom (C1 \<nabla> C2 :: _ st option acom) X"
by(auto simp add: widen_acom_def top_on_acom_def)(metis top_on_opt_widen in_set_zipE)

lemma top_on_acom_narrow:
  "\<lbrakk>top_on_acom C1 X; strip C1 = strip C2; top_on_acom C2 X\<rbrakk>
  \<Longrightarrow> top_on_acom (C1 \<triangle> C2 :: _ st option acom) X"
by(auto simp add: narrow_acom_def top_on_acom_def)(metis top_on_opt_narrow in_set_zipE)

text\<open>The assumptions for widening and narrowing differ because during
narrowing we have the invariant \<^prop>\<open>y \<le> x\<close> (where \<open>y\<close> is the next
iterate), but during widening there is no such invariant, there we only have
that not yet \<^prop>\<open>y \<le> x\<close>. This complicates the termination proof for
widening.\<close>

locale Measure_wn = Measure1 where m=m
  for m :: "'av::{order_top,wn} \<Rightarrow> nat" +
fixes n :: "'av \<Rightarrow> nat"
assumes m_anti_mono: "x \<le> y \<Longrightarrow> m x \<ge> m y"
assumes m_widen: "~ y \<le> x \<Longrightarrow> m(x \<nabla> y) < m x"
assumes n_narrow: "y \<le> x \<Longrightarrow> x \<triangle> y < x \<Longrightarrow> n(x \<triangle> y) < n x"

begin

lemma m_s_anti_mono_rep: assumes "\<forall>x. S1 x \<le> S2 x"
shows "(\<Sum>x\<in>X. m (S2 x)) \<le> (\<Sum>x\<in>X. m (S1 x))"
proof-
  from assms have "\<forall>x. m(S1 x) \<ge> m(S2 x)" by (metis m_anti_mono)
  thus "(\<Sum>x\<in>X. m (S2 x)) \<le> (\<Sum>x\<in>X. m (S1 x))" by (metis sum_mono)
qed

lemma m_s_anti_mono: "S1 \<le> S2 \<Longrightarrow> m_s S1 X \<ge> m_s S2 X"
unfolding m_s_def
apply (transfer fixing: m)
apply(simp add: less_eq_st_rep_iff eq_st_def m_s_anti_mono_rep)
done

lemma m_s_widen_rep: assumes "finite X" "S1 = S2 on -X" "\<not> S2 x \<le> S1 x"
  shows "(\<Sum>x\<in>X. m (S1 x \<nabla> S2 x)) < (\<Sum>x\<in>X. m (S1 x))"
proof-
  have 1: "\<forall>x\<in>X. m(S1 x) \<ge> m(S1 x \<nabla> S2 x)"
    by (metis m_anti_mono wn_class.widen1)
  have "x \<in> X" using assms(2,3)
    by(auto simp add: Ball_def)
  hence 2: "\<exists>x\<in>X. m(S1 x) > m(S1 x \<nabla> S2 x)"
    using assms(3) m_widen by blast
  from sum_strict_mono_ex1[OF \<open>finite X\<close> 1 2]
  show ?thesis .
qed

lemma m_s_widen: "finite X \<Longrightarrow> fun S1 = fun S2 on -X ==>
  ~ S2 \<le> S1 \<Longrightarrow> m_s (S1 \<nabla> S2) X < m_s S1 X"
apply(auto simp add: less_st_def m_s_def)
apply (transfer fixing: m)
apply(auto simp add: less_eq_st_rep_iff m_s_widen_rep)
done

lemma m_o_anti_mono: "finite X \<Longrightarrow> top_on_opt o1 (-X) \<Longrightarrow> top_on_opt o2 (-X) \<Longrightarrow>
  o1 \<le> o2 \<Longrightarrow> m_o o1 X \<ge> m_o o2 X"
proof(induction o1 o2 rule: less_eq_option.induct)
  case 1 thus ?case by (simp add: m_o_def)(metis m_s_anti_mono)
next
  case 2 thus ?case
    by(simp add: m_o_def le_SucI m_s_h split: option.splits)
next
  case 3 thus ?case by simp
qed

lemma m_o_widen: "\<lbrakk> finite X; top_on_opt S1 (-X); top_on_opt S2 (-X); \<not> S2 \<le> S1 \<rbrakk> \<Longrightarrow>
  m_o (S1 \<nabla> S2) X < m_o S1 X"
by(auto simp: m_o_def m_s_h less_Suc_eq_le m_s_widen split: option.split)

lemma m_c_widen:
  "strip C1 = strip C2  \<Longrightarrow> top_on_acom C1 (-vars C1) \<Longrightarrow> top_on_acom C2 (-vars C2)
   \<Longrightarrow> \<not> C2 \<le> C1 \<Longrightarrow> m_c (C1 \<nabla> C2) < m_c C1"
apply(auto simp: m_c_def widen_acom_def map2_acom_def size_annos[symmetric] anno_def[symmetric]sum_list_sum_nth)
apply(subgoal_tac "length(annos C2) = length(annos C1)")
 prefer 2 apply (simp add: size_annos_same2)
apply (auto)
apply(rule sum_strict_mono_ex1)
 apply(auto simp add: m_o_anti_mono vars_acom_def anno_def top_on_acom_def top_on_opt_widen widen1 less_eq_acom_def listrel_iff_nth)
apply(rule_tac x=p in bexI)
 apply (auto simp: vars_acom_def m_o_widen top_on_acom_def)
done

definition n_s :: "'av st \<Rightarrow> vname set \<Rightarrow> nat" ("n\<^sub>s") where
"n\<^sub>s S X = (\<Sum>x\<in>X. n(fun S x))"

lemma n_s_narrow_rep:
assumes "finite X"  "S1 = S2 on -X"  "\<forall>x. S2 x \<le> S1 x"  "\<forall>x. S1 x \<triangle> S2 x \<le> S1 x"
  "S1 x \<noteq> S1 x \<triangle> S2 x"
shows "(\<Sum>x\<in>X. n (S1 x \<triangle> S2 x)) < (\<Sum>x\<in>X. n (S1 x))"
proof-
  have 1: "\<forall>x. n(S1 x \<triangle> S2 x) \<le> n(S1 x)"
      by (metis assms(3) assms(4) eq_iff less_le_not_le n_narrow)
  have "x \<in> X" by (metis Compl_iff assms(2) assms(5) narrowid)
  hence 2: "\<exists>x\<in>X. n(S1 x \<triangle> S2 x) < n(S1 x)"
    by (metis assms(3-5) eq_iff less_le_not_le n_narrow)
  show ?thesis
    apply(rule sum_strict_mono_ex1[OF \<open>finite X\<close>]) using 1 2 by blast+
qed

lemma n_s_narrow: "finite X \<Longrightarrow> fun S1 = fun S2 on -X \<Longrightarrow> S2 \<le> S1 \<Longrightarrow> S1 \<triangle> S2 < S1
  \<Longrightarrow> n\<^sub>s (S1 \<triangle> S2) X < n\<^sub>s S1 X"
apply(auto simp add: less_st_def n_s_def)
apply (transfer fixing: n)
apply(auto simp add: less_eq_st_rep_iff eq_st_def fun_eq_iff n_s_narrow_rep)
done

definition n_o :: "'av st option \<Rightarrow> vname set \<Rightarrow> nat" ("n\<^sub>o") where
"n\<^sub>o opt X = (case opt of None \<Rightarrow> 0 | Some S \<Rightarrow> n\<^sub>s S X + 1)"

lemma n_o_narrow:
  "top_on_opt S1 (-X) \<Longrightarrow> top_on_opt S2 (-X) \<Longrightarrow> finite X
  \<Longrightarrow> S2 \<le> S1 \<Longrightarrow> S1 \<triangle> S2 < S1 \<Longrightarrow> n\<^sub>o (S1 \<triangle> S2) X < n\<^sub>o S1 X"
apply(induction S1 S2 rule: narrow_option.induct)
apply(auto simp: n_o_def n_s_narrow)
done

definition n_c :: "'av st option acom \<Rightarrow> nat" ("n\<^sub>c") where
"n\<^sub>c C = sum_list (map (\<lambda>a. n\<^sub>o a (vars C)) (annos C))"

lemma less_annos_iff: "(C1 < C2) = (C1 \<le> C2 \<and>
  (\<exists>i<length (annos C1). annos C1 ! i < annos C2 ! i))"
by(metis (hide_lams, no_types) less_le_not_le le_iff_le_annos size_annos_same2)

lemma n_c_narrow: "strip C1 = strip C2
  \<Longrightarrow> top_on_acom C1 (- vars C1) \<Longrightarrow> top_on_acom C2 (- vars C2)
  \<Longrightarrow> C2 \<le> C1 \<Longrightarrow> C1 \<triangle> C2 < C1 \<Longrightarrow> n\<^sub>c (C1 \<triangle> C2) < n\<^sub>c C1"
apply(auto simp: n_c_def narrow_acom_def sum_list_sum_nth)
apply(subgoal_tac "length(annos C2) = length(annos C1)")
prefer 2 apply (simp add: size_annos_same2)
apply (auto)
apply(simp add: less_annos_iff le_iff_le_annos)
apply(rule sum_strict_mono_ex1)
apply (auto simp: vars_acom_def top_on_acom_def)
apply (metis n_o_narrow nth_mem finite_cvars less_imp_le le_less order_refl)
apply(rule_tac x=i in bexI)
prefer 2 apply simp
apply(rule n_o_narrow[where X = "vars(strip C2)"])
apply (simp_all)
done

end

lemma iter_widen_termination:
fixes m :: "'a::wn acom \<Rightarrow> nat"
assumes P_f: "\<And>C. P C \<Longrightarrow> P(f C)"
and P_widen: "\<And>C1 C2. P C1 \<Longrightarrow> P C2 \<Longrightarrow> P(C1 \<nabla> C2)"
and m_widen: "\<And>C1 C2. P C1 \<Longrightarrow> P C2 \<Longrightarrow> ~ C2 \<le> C1 \<Longrightarrow> m(C1 \<nabla> C2) < m C1"
and "P C" shows "\<exists>C'. iter_widen f C = Some C'"
proof(simp add: iter_widen_def,
      rule measure_while_option_Some[where P = P and f=m])
  show "P C" by(rule \<open>P C\<close>)
next
  fix C assume "P C" "\<not> f C \<le> C" thus "P (C \<nabla> f C) \<and> m (C \<nabla> f C) < m C"
    by(simp add: P_f P_widen m_widen)
qed

lemma iter_narrow_termination:
fixes n :: "'a::wn acom \<Rightarrow> nat"
assumes P_f: "\<And>C. P C \<Longrightarrow> P(f C)"
and P_narrow: "\<And>C1 C2. P C1 \<Longrightarrow> P C2 \<Longrightarrow> P(C1 \<triangle> C2)"
and mono: "\<And>C1 C2. P C1 \<Longrightarrow> P C2 \<Longrightarrow> C1 \<le> C2 \<Longrightarrow> f C1 \<le> f C2"
and n_narrow: "\<And>C1 C2. P C1 \<Longrightarrow> P C2 \<Longrightarrow> C2 \<le> C1 \<Longrightarrow> C1 \<triangle> C2 < C1 \<Longrightarrow> n(C1 \<triangle> C2) < n C1"
and init: "P C" "f C \<le> C" shows "\<exists>C'. iter_narrow f C = Some C'"
proof(simp add: iter_narrow_def,
      rule measure_while_option_Some[where f=n and P = "%C. P C \<and> f C \<le> C"])
  show "P C \<and> f C \<le> C" using init by blast
next
  fix C assume 1: "P C \<and> f C \<le> C" and 2: "C \<triangle> f C < C"
  hence "P (C \<triangle> f C)" by(simp add: P_f P_narrow)
  moreover then have "f (C \<triangle> f C) \<le> C \<triangle> f C"
    by (metis narrow1_acom narrow2_acom 1 mono order_trans)
  moreover have "n (C \<triangle> f C) < n C" using 1 2 by(simp add: n_narrow P_f)
  ultimately show "(P (C \<triangle> f C) \<and> f (C \<triangle> f C) \<le> C \<triangle> f C) \<and> n(C \<triangle> f C) < n C"
    by blast
qed

locale Abs_Int_wn_measure = Abs_Int_wn where \<gamma>=\<gamma> + Measure_wn where m=m
  for \<gamma> :: "'av::{wn,bounded_lattice} \<Rightarrow> val set" and m :: "'av \<Rightarrow> nat"

subsubsection "Termination: Intervals"

definition m_rep :: "eint2 \<Rightarrow> nat" where
"m_rep p = (if is_empty_rep p then 3 else
  let (l,h) = p in (case l of Minf \<Rightarrow> 0 | _ \<Rightarrow> 1) + (case h of Pinf \<Rightarrow> 0 | _ \<Rightarrow> 1))"

lift_definition m_ivl :: "ivl \<Rightarrow> nat" is m_rep
by(auto simp: m_rep_def eq_ivl_iff)

lemma m_ivl_nice: "m_ivl[l,h] = (if [l,h] = \<bottom> then 3 else
   (if l = Minf then 0 else 1) + (if h = Pinf then 0 else 1))"
unfolding bot_ivl_def
by transfer (auto simp: m_rep_def eq_ivl_empty split: extended.split)

lemma m_ivl_height: "m_ivl iv \<le> 3"
by transfer (simp add: m_rep_def split: prod.split extended.split)

lemma m_ivl_anti_mono: "y \<le> x \<Longrightarrow> m_ivl x \<le> m_ivl y"
by transfer
   (auto simp: m_rep_def is_empty_rep_def \<gamma>_rep_cases le_iff_subset
         split: prod.split extended.splits if_splits)

lemma m_ivl_widen:
  "~ y \<le> x \<Longrightarrow> m_ivl(x \<nabla> y) < m_ivl x"
by transfer
   (auto simp: m_rep_def widen_rep_def is_empty_rep_def \<gamma>_rep_cases le_iff_subset
         split: prod.split extended.splits if_splits)

definition n_ivl :: "ivl \<Rightarrow> nat" where
"n_ivl iv = 3 - m_ivl iv"

lemma n_ivl_narrow:
  "x \<triangle> y < x \<Longrightarrow> n_ivl(x \<triangle> y) < n_ivl x"
unfolding n_ivl_def
apply(subst (asm) less_le_not_le)
apply transfer
by(auto simp add: m_rep_def narrow_rep_def is_empty_rep_def empty_rep_def \<gamma>_rep_cases le_iff_subset
         split: prod.splits if_splits extended.split)

global_interpretation Abs_Int_wn_measure
where \<gamma> = \<gamma>_ivl and num' = num_ivl and plus' = "(+)"
and test_num' = in_ivl
and inv_plus' = inv_plus_ivl and inv_less' = inv_less_ivl
and m = m_ivl and n = n_ivl and h = 3
proof (standard, goal_cases)
  case 2 thus ?case by(rule m_ivl_anti_mono)
next
  case 1 thus ?case by(rule m_ivl_height)
next
  case 3 thus ?case by(rule m_ivl_widen)
next
  case 4 from 4(2) show ?case by(rule n_ivl_narrow)
  \<comment> \<open>note that the first assms is unnecessary for intervals\<close>
qed

lemma iter_winden_step_ivl_termination:
  "\<exists>C. iter_widen (step_ivl \<top>) (bot c) = Some C"
apply(rule iter_widen_termination[where m = "m_c" and P = "%C. strip C = c \<and> top_on_acom C (- vars C)"])
apply (auto simp add: m_c_widen top_on_bot top_on_step'[simplified comp_def vars_acom_def]
  vars_acom_def top_on_acom_widen)
done

lemma iter_narrow_step_ivl_termination:
  "top_on_acom C (- vars C) \<Longrightarrow> step_ivl \<top> C \<le> C \<Longrightarrow>
  \<exists>C'. iter_narrow (step_ivl \<top>) C = Some C'"
apply(rule iter_narrow_termination[where n = "n_c" and P = "%C'. strip C = strip C' \<and> top_on_acom C' (-vars C')"])
apply(auto simp: top_on_step'[simplified comp_def vars_acom_def]
        mono_step'_top n_c_narrow vars_acom_def top_on_acom_narrow)
done

theorem AI_wn_ivl_termination:
  "\<exists>C. AI_wn_ivl c = Some C"
apply(auto simp: AI_wn_def pfp_wn_def iter_winden_step_ivl_termination
           split: option.split)
apply(rule iter_narrow_step_ivl_termination)
apply(rule conjunct2)
apply(rule iter_widen_inv[where f = "step' \<top>" and P = "%C. c = strip C & top_on_acom C (- vars C)"])
apply(auto simp: top_on_acom_widen top_on_step'[simplified comp_def vars_acom_def]
  iter_widen_pfp top_on_bot vars_acom_def)
done

(*unused_thms Abs_Int_init - *)

subsubsection "Counterexamples"

text\<open>Widening is increasing by assumption, but \<^prop>\<open>x \<le> f x\<close> is not an invariant of widening.
It can already be lost after the first step:\<close>

lemma assumes "!!x y::'a::wn. x \<le> y \<Longrightarrow> f x \<le> f y"
and "x \<le> f x" and "\<not> f x \<le> x" shows "x \<nabla> f x \<le> f(x \<nabla> f x)"
nitpick[card = 3, expect = genuine, show_consts, timeout = 120]
(*
1 < 2 < 3,
f x = 2,
x widen y = 3 -- guarantees termination with top=3
x = 1
Now f is mono, x <= f x, not f x <= x
but x widen f x = 3, f 3 = 2, but not 3 <= 2
*)
oops

text\<open>Widening terminates but may converge more slowly than Kleene iteration.
In the following model, Kleene iteration goes from 0 to the least pfp
in one step but widening takes 2 steps to reach a strictly larger pfp:\<close>
lemma assumes "!!x y::'a::wn. x \<le> y \<Longrightarrow> f x \<le> f y"
and "x \<le> f x" and "\<not> f x \<le> x" and "f(f x) \<le> f x"
shows "f(x \<nabla> f x) \<le> x \<nabla> f x"
nitpick[card = 4, expect = genuine, show_consts, timeout = 120]
(*

   0 < 1 < 2 < 3
f: 1   1   3   3

0 widen 1 = 2
2 widen 3 = 3
and x widen y arbitrary, eg 3, which guarantees termination

Kleene: f(f 0) = f 1 = 1 <= 1 = f 1

but

because not f 0 <= 0, we obtain 0 widen f 0 = 0 wide 1 = 2,
which is again not a pfp: not f 2 = 3 <= 2
Another widening step yields 2 widen f 2 = 2 widen 3 = 3
*)
oops

end


theory Lexord_List
imports Main
begin

typedef 'a lexlist = "{xs::'a list. True}"
  morphisms unlex Lex
by auto

definition "lexlist \<equiv> Lex"

lemma lexlist_ext:
  "Lex xs = Lex ys \<Longrightarrow> xs = ys"
by (auto simp: Lex_inject)

lemma Lex_unlex [simp, code abstype]:
  "Lex (unlex lxs) = lxs"
  by (metis unlex_inverse)

lemma unlex_lexlist [simp, code abstract]:
  "unlex (lexlist xs) = xs"
  by (metis lexlist_ext unlex_inverse lexlist_def)

definition list_less :: "'a :: ord list \<Rightarrow> 'a list \<Rightarrow> bool" where
  "list_less xs ys \<longleftrightarrow> (xs, ys) \<in> lexord {(u, v). u < v}"

definition list_le where
  "list_le xs ys \<longleftrightarrow> list_less xs ys \<or> xs = ys"

lemma not_less_Nil [simp]: "\<not> list_less x []"
  by (simp add: list_less_def)

lemma Nil_less_Cons [simp]: "list_less [] (a # x)"
  by (simp add: list_less_def)

lemma Cons_less_Cons [simp]: "list_less (a # x) (b # y) \<longleftrightarrow> a < b \<or> a = b \<and> list_less x y"
  by (simp add: list_less_def)

lemma le_Nil [simp]: "list_le x [] \<longleftrightarrow> x = []"
  unfolding list_le_def by (cases x) auto

lemma Nil_le_Cons [simp]: "list_le [] x"
  unfolding list_le_def by (cases x) auto

lemma Cons_le_Cons [simp]: "list_le (a # x) (b # y) \<longleftrightarrow> a < b \<or> a = b \<and> list_le x y"
  unfolding list_le_def by auto

lemma less_list_code [code]:
  "list_less xs [] \<longleftrightarrow> False"
  "list_less [] (x # xs) \<longleftrightarrow> True"
  "list_less (x # xs) (y # ys) \<longleftrightarrow> x < y \<or> x = y \<and> list_less xs ys"
  by simp_all

instantiation  lexlist :: (ord) ord
begin

definition
  lexlist_less_def: "xs < ys \<longleftrightarrow> list_less (unlex xs) (unlex ys)"

definition
  lexlist_le_def: "(xs :: _ lexlist) \<le> ys \<longleftrightarrow> list_le (unlex xs) (unlex ys)"

instance ..

lemmas lexlist_ord_defs = lexlist_le_def lexlist_less_def list_le_def list_less_def

end

instance lexlist :: (order) order
proof
  fix xs :: "'a lexlist"
  show "xs \<le> xs" by (simp add: lexlist_le_def list_le_def)
next
  fix xs ys zs :: "'a lexlist"
  assume "xs \<le> ys" and "ys \<le> zs"
  then show "xs \<le> zs"
    apply (auto simp add: lexlist_ord_defs)
    apply (rule lexord_trans)
    apply (auto intro: transI)
    done
next
  fix xs ys :: "'a lexlist"
  assume "xs \<le> ys" and "ys \<le> xs"
  then show "xs = ys"
    apply (auto simp add: lexlist_ord_defs)
    apply (rule lexord_irreflexive [THEN notE])
    defer
    apply (rule lexord_trans)
    apply (auto intro: transI simp: unlex_inject)
    done
next
  fix xs ys :: "'a lexlist"
  show "xs < ys \<longleftrightarrow> xs \<le> ys \<and> \<not> ys \<le> xs"
    apply (auto simp add: lexlist_ord_defs)
    defer
    apply (rule lexord_irreflexive [THEN notE])
    apply auto
    apply (rule lexord_irreflexive [THEN notE])
    defer
    apply (rule lexord_trans)
    apply (auto intro: transI)
    done
qed

instance lexlist :: (linorder) linorder
proof
  fix xs ys :: "'a lexlist"
  have "(unlex xs, unlex ys) \<in> lexord {(u, v). u < v} \<or> unlex xs = unlex ys \<or> (unlex ys, unlex xs) \<in> lexord {(u, v). u < v}"
    by (rule lexord_linear) auto
  then show "xs \<le> ys \<or> ys \<le> xs"
    by (auto simp add: lexlist_ord_defs unlex_inject)
qed

end


(*  Title:       Category theory using Isar and Locales
    Author:      Greg O'Keefe, June, July, August 2003
    License: LGPL

Functors: Define functors and prove a trivial example.
*)

header {* Functors *}

theory Functors
imports Cat
begin

subsection {* Definitions *}

record ('o1,'a1,'o2,'a2) "functor" =
  om :: "'o1 \<Rightarrow> 'o2"
  am :: "'a1 \<Rightarrow> 'a2"

abbreviation
  om_syn  ("_ \<^bsub>\<o>\<^esub>" [81]) where
  "F\<^bsub>\<o>\<^esub> \<equiv> om F"

abbreviation
  am_syn  ("_ \<^bsub>\<a>\<^esub>" [81]) where
  "F\<^bsub>\<a>\<^esub> \<equiv> am F"

locale two_cats = AA: category AA + BB: category BB
    for AA :: "('o1,'a1,'m1)category_scheme" (structure)
    and BB :: "('o2,'a2,'m2)category_scheme" (structure) +
  fixes preserves_dom  ::  "('o1,'a1,'o2,'a2)functor \<Rightarrow> bool"
    and preserves_cod  ::  "('o1,'a1,'o2,'a2)functor \<Rightarrow> bool"
    and preserves_id  ::  "('o1,'a1,'o2,'a2)functor \<Rightarrow> bool"
    and preserves_comp  ::  "('o1,'a1,'o2,'a2)functor \<Rightarrow> bool"
  defines "preserves_dom G \<equiv> \<forall>f\<in>Ar\<^bsub>AA\<^esub>. G\<^bsub>\<o>\<^esub> (Dom\<^bsub>AA\<^esub> f) = Dom\<^bsub>BB\<^esub> (G\<^bsub>\<a>\<^esub> f)"
    and "preserves_cod G \<equiv> \<forall>f\<in>Ar\<^bsub>AA\<^esub>. G\<^bsub>\<o>\<^esub> (Cod\<^bsub>AA\<^esub> f) = Cod\<^bsub>BB\<^esub> (G\<^bsub>\<a>\<^esub> f)"
    and "preserves_id G \<equiv> \<forall>A\<in>Ob\<^bsub>AA\<^esub>. G\<^bsub>\<a>\<^esub> (Id\<^bsub>AA\<^esub> A) = Id\<^bsub>BB\<^esub> (G\<^bsub>\<o>\<^esub> A)"
    and "preserves_comp G \<equiv>
      \<forall>f\<in>Ar\<^bsub>AA\<^esub>. \<forall>g\<in>Ar\<^bsub>AA\<^esub>. Cod\<^bsub>AA\<^esub> f = Dom\<^bsub>AA\<^esub> g \<longrightarrow> G\<^bsub>\<a>\<^esub> (g \<bullet>\<^bsub>AA\<^esub> f) = (G\<^bsub>\<a>\<^esub> g) \<bullet>\<^bsub>BB\<^esub> (G\<^bsub>\<a>\<^esub> f)"

locale "functor" = two_cats +
  fixes F (structure)
  assumes F_preserves_arrows: "F\<^bsub>\<a>\<^esub> : Ar\<^bsub>AA\<^esub> \<rightarrow> Ar\<^bsub>BB\<^esub>"
    and F_preserves_objects: "F\<^bsub>\<o>\<^esub> : Ob\<^bsub>AA\<^esub> \<rightarrow> Ob\<^bsub>BB\<^esub>"
    and F_preserves_dom: "preserves_dom F"
    and F_preserves_cod: "preserves_cod F"
    and F_preserves_id: "preserves_id F"
    and F_preserves_comp: "preserves_comp F"
begin

lemmas F_axioms = F_preserves_arrows F_preserves_objects F_preserves_dom
  F_preserves_cod F_preserves_id F_preserves_comp

lemmas func_pred_defs = preserves_dom_def preserves_cod_def preserves_id_def preserves_comp_def

end

text {* This gives us nicer notation for asserting that things are functors. *}

abbreviation
  Functor  ("Functor _ : _ \<longrightarrow> _" [81]) where
  "Functor F : AA \<longrightarrow> BB \<equiv> functor AA BB F"

subsection {* Simple Lemmas *}

text {* For example: *}

lemma (in "functor") "Functor F : AA \<longrightarrow> BB" ..

lemma functors_preserve_arrows [intro]:
  assumes "Functor F : AA \<longrightarrow> BB"
    and "f \<in> ar AA"
  shows "F\<^bsub>\<a>\<^esub> f \<in> ar BB"
proof-
  from `Functor F : AA \<longrightarrow> BB`
  have "F\<^bsub>\<a>\<^esub> : ar AA \<rightarrow> ar BB"
    by (simp add: functor_def functor_axioms_def)
  from this and `f \<in> ar AA`
  show ?thesis by (rule funcset_mem)
qed

lemma (in "functor") functors_preserve_homsets:
  assumes 1: "A \<in> Ob\<^bsub>AA\<^esub>"
  and 2: "B \<in> Ob\<^bsub>AA\<^esub>"
  and 3: "f \<in> Hom\<^bsub>AA\<^esub> A B"
  shows "F\<^bsub>\<a>\<^esub> f \<in> Hom\<^bsub>BB\<^esub> (F\<^bsub>\<o>\<^esub> A) (F\<^bsub>\<o>\<^esub> B)"
proof-
  from 3
  have 4: "f \<in> Ar"
    by (simp add: hom_def)
  with F_preserves_arrows
  have 5: "F\<^bsub>\<a>\<^esub> f \<in> Ar\<^bsub>BB\<^esub>"
    by (rule funcset_mem)
  from 4 and F_preserves_dom
  have "Dom\<^bsub>BB\<^esub> (F\<^bsub>\<a>\<^esub> f) = F\<^bsub>\<o>\<^esub> (Dom\<^bsub>AA\<^esub> f)"
    by (simp add: preserves_dom_def)
  also from 3 have "\<dots> = F\<^bsub>\<o>\<^esub> A"
    by (simp add: hom_def)
  finally have 6: "Dom\<^bsub>BB\<^esub> (F\<^bsub>\<a>\<^esub> f) = F\<^bsub>\<o>\<^esub> A" .
  from 4 and F_preserves_cod
  have "Cod\<^bsub>BB\<^esub> (F\<^bsub>\<a>\<^esub> f) = F\<^bsub>\<o>\<^esub> (Cod\<^bsub>AA\<^esub> f)"
    by (simp add: preserves_cod_def)
  also from 3 have "\<dots> = F\<^bsub>\<o>\<^esub> B"
    by (simp add: hom_def)
  finally have 7: "Cod\<^bsub>BB\<^esub> (F\<^bsub>\<a>\<^esub> f) = F\<^bsub>\<o>\<^esub> B" .
  from 5 and 6 and 7
  show ?thesis
    by (simp add: hom_def)
qed

lemma functors_preserve_objects [intro]:
  assumes "Functor F : AA \<longrightarrow> BB"
    and "A \<in> ob AA"
  shows "F\<^bsub>\<o>\<^esub> A \<in> ob BB"
proof-
  from `Functor F : AA \<longrightarrow> BB`
  have "F\<^bsub>\<o>\<^esub> : ob AA \<rightarrow> ob BB"
    by (simp add: functor_def functor_axioms_def)
  from this and `A \<in> ob AA`
  show ?thesis by (rule funcset_mem)
qed

subsection {* Identity Functor *}

definition
  id_func :: "('o,'a,'m) category_scheme \<Rightarrow> ('o,'a,'o,'a) functor" where
  "id_func CC = \<lparr>om=(\<lambda>A\<in>ob CC. A), am=(\<lambda>f\<in>ar CC. f)\<rparr>"

locale one_cat = two_cats +
  assumes endo: "BB = AA"

lemma (in one_cat) id_func_preserves_arrows:
  shows "(id_func AA)\<^bsub>\<a>\<^esub> : Ar \<rightarrow> Ar"
  by (unfold id_func_def, rule funcsetI, simp)

lemma (in one_cat) id_func_preserves_objects:
  shows "(id_func AA)\<^bsub>\<o>\<^esub> : Ob \<rightarrow> Ob"
  by (unfold id_func_def, rule funcsetI, simp)

lemma (in one_cat) id_func_preserves_dom:
  shows  "preserves_dom (id_func AA)"
unfolding preserves_dom_def endo
proof
  fix f
  assume f: "f \<in> Ar"
  hence lhs: "(id_func AA)\<^bsub>\<o>\<^esub> (Dom f) = Dom f"
    by (simp add: id_func_def) auto
  have "(id_func AA)\<^bsub>\<a>\<^esub> f = f"
    using f by (simp add: id_func_def)
  hence rhs: "Dom (id_func AA)\<^bsub>\<a>\<^esub> f = Dom f"
    by simp
  from lhs and rhs show "(id_func AA)\<^bsub>\<o>\<^esub> (Dom f) = Dom (id_func AA)\<^bsub>\<a>\<^esub> f"
    by simp
qed

lemma (in one_cat) id_func_preserves_cod:
  "preserves_cod (id_func AA)"
apply (unfold preserves_cod_def, simp only: endo)
proof
  fix f
  assume f: "f \<in> Ar"
  hence lhs: "(id_func AA)\<^bsub>\<o>\<^esub> (Cod f) = Cod f"
    by (simp add: id_func_def) auto
  have "(id_func AA)\<^bsub>\<a>\<^esub> f = f"
    using f by (simp add: id_func_def)
  hence rhs: "Cod (id_func AA)\<^bsub>\<a>\<^esub> f = Cod f"
    by simp
  from lhs and rhs show "(id_func AA)\<^bsub>\<o>\<^esub> (Cod f) = Cod (id_func AA)\<^bsub>\<a>\<^esub> f"
    by simp
qed

lemma (in one_cat) id_func_preserves_id:
  "preserves_id (id_func AA)"
unfolding preserves_id_def endo
proof
  fix A
  assume A: "A \<in> Ob"
  hence lhs: "(id_func AA)\<^bsub>\<a>\<^esub> (Id A) = Id A"
    by (simp add: id_func_def) auto
  have "(id_func AA)\<^bsub>\<o>\<^esub> A = A"
    using A by (simp add: id_func_def)
  hence rhs: "Id ((id_func AA)\<^bsub>\<o>\<^esub> A) = Id A"
    by simp
  from lhs and rhs show "(id_func AA)\<^bsub>\<a>\<^esub> (Id A) = Id ((id_func AA)\<^bsub>\<o>\<^esub> A)"
    by simp
qed

lemma (in one_cat) id_func_preserves_comp:
  "preserves_comp (id_func AA)"
unfolding preserves_comp_def endo
proof (intro ballI impI)
  fix f and g
  assume f: "f \<in> Ar" and g: "g \<in> Ar" and "Cod f = Dom g"
  then have "g \<bullet> f \<in> Ar" ..
  hence lhs: "(id_func AA)\<^bsub>\<a>\<^esub> (g \<bullet> f) = g \<bullet> f"
    by (simp add: id_func_def)
  have id_f: "(id_func AA)\<^bsub>\<a>\<^esub> f = f"
    using f by (simp add: id_func_def)
  have id_g: "(id_func AA)\<^bsub>\<a>\<^esub> g = g"
    using g by (simp add: id_func_def)
  hence rhs: "(id_func AA)\<^bsub>\<a>\<^esub> g \<bullet> (id_func AA)\<^bsub>\<a>\<^esub> f = g \<bullet> f"
    by (simp add: id_f id_g)
  from lhs and rhs
  show "(id_func AA)\<^bsub>\<a>\<^esub> (g \<bullet> f) = (id_func AA)\<^bsub>\<a>\<^esub> g \<bullet> (id_func AA)\<^bsub>\<a>\<^esub> f"
    by simp
qed

theorem (in one_cat) id_func_functor:
  "Functor (id_func AA) : AA \<longrightarrow> AA"
proof-
  from id_func_preserves_arrows
    and id_func_preserves_objects
    and id_func_preserves_dom
    and id_func_preserves_cod
    and id_func_preserves_id
    and id_func_preserves_comp
  show ?thesis
    by unfold_locales (simp_all add: endo preserves_dom_def
      preserves_cod_def preserves_id_def preserves_comp_def)
qed

end