theory Pord imports Bogus Okay

begin

(*
 * Typeclass definitions for partial orders and various extensions thereof
 * TODO: these proofs could be cleaned up and ISAR-ified
 *)

(* Comparison function for orderings, not currently used *)
definition ord_leq :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
  where
"ord_leq o1 o2 = (\<forall> x1 x2 . o1 x1 x2 \<longrightarrow> o2 x1 x2)"

lemma ord_leq_refl : "\<And> ord . ord_leq ord ord"
  apply(simp add:ord_leq_def)
  done

lemma ord_leq_trans: "\<And> ox oy oz . ord_leq ox oy \<Longrightarrow> ord_leq oy oz \<Longrightarrow> ord_leq ox oz"
  apply(simp add:ord_leq_def)
  done

lemma ord_leq_antisym : "\<And> ox oy . ord_leq ox oy
 \<Longrightarrow> ord_leq oy ox \<Longrightarrow> ox = oy"
  apply(simp add:ord_leq_def)
  apply(blast)
  done

lemma ord_leq' : "\<And> ox oy a b .
  ord_leq ox oy \<Longrightarrow>
  ox a b \<Longrightarrow>
  oy a b"
  apply(simp add:ord_leq_def)
  done

lemma ord_leq_d : "\<And> ox oy a b .
  ox a b \<Longrightarrow>
  ord_leq ox oy \<Longrightarrow>
  oy a b"
  apply(simp add:ord_leq_def)
  done

(* Pord = "Partial ORDer"
   This name avoids collision with Isabelle's builtin ordering notions
   This version of pord is "weak" because it lacks antisymmetry; the full pord
   typeclass adds antisymmetry.
*)

class Pord_Weak =
  fixes pleq :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl \<open><[\<close> 71)
  assumes
    leq_refl : "pleq a a"
  assumes
    leq_trans : "pleq a b \<Longrightarrow> pleq b c \<Longrightarrow> pleq a c"

(* Notions common to partial orders - upper bounds, lower bounds, infs and sups *)
definition is_lb :: "('a :: Pord_Weak) set \<Rightarrow> 'a \<Rightarrow> bool" where
"is_lb A a =
  (\<forall> x \<in> A . a <[ x)"

definition is_greatest :: "(('a :: Pord_Weak) \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" where
"is_greatest P a =
  (P a \<and>
   (\<forall> a' . P a' \<longrightarrow> pleq a' a))"

definition is_inf :: "('a :: Pord_Weak) set \<Rightarrow> 'a \<Rightarrow> bool" where
"is_inf A a = is_greatest (is_lb A) a"

definition is_ub :: "('a :: Pord_Weak) set \<Rightarrow> 'a \<Rightarrow> bool" where
"is_ub A a =
  (\<forall> x \<in> A . pleq x a)"

definition is_least :: "(('a :: Pord_Weak) \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" where
"is_least P a =
  (P a \<and>
   (\<forall> a' . P a' \<longrightarrow> pleq a a'))"

definition is_sup :: "('a :: Pord_Weak) set \<Rightarrow> 'a \<Rightarrow> bool" where
"is_sup A a =
  is_least (is_ub A) a"

definition has_sup :: "('a :: Pord_Weak) set \<Rightarrow> bool" where
"has_sup A = (\<exists> s . is_sup A s)"

definition has_ub :: "('a :: Pord_Weak) set \<Rightarrow> bool" where
"has_ub A = (\<exists> s . is_ub A s)"

(* A key definition: bub = "Biased Upper Bound". The idea is that for any two objects of type
   a and b of type 'a, bub a b is "the closest we can get" to a common (least) upper bound
   even if one does not exist. bub a b is guaranteed to be greater than a; additionally,
   if by "forgetting information" from b (thinking of this as an information ordering) we arrive
   at bd <[ b such that bd _does_ have a least upper bound, bub a b is guaranteed to be
   greater than said upper bound.

   Bub is thus "biased" towards being forced to be an upper bound of a, while being
   "as close as possible" to b.

   Bsup is the least such bub.

   This definition is key to specifying the mergeable typeclass, an crucial component
   of the overall Gazelle system. It allows us to talk about "merging" in a very general
   context with minimal assumptions (is_bub only requires weak partial orders), yet bsup is provably
   being equivalent to the "true" least upper bound if it exists, assuming completeness;
   that is, where the existence of _any_ upper bound between a and bd guarantees the existence
   of a least upper bound sd.
*)

definition is_bub :: "('a :: Pord_Weak) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
"is_bub a b s =
  (pleq a s \<and>
    ((\<forall> bd sd . pleq bd (b) \<longrightarrow>
                is_sup {a, bd} sd \<longrightarrow>
                pleq sd (s))))"

definition is_bsup :: "('a :: Pord_Weak) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
"is_bsup a b s =
  is_least (is_bub a b) s"

(* Monotonicity for predicates *)
definition is_monop1 :: "(('a :: Pord_Weak) \<Rightarrow> bool) \<Rightarrow> bool" where
"is_monop1 P =
  (\<forall> a b . pleq a b \<longrightarrow> P a \<longrightarrow> P b)"

definition is_monop2 :: "(('a :: Pord_Weak) \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
"is_monop2 P =
  (\<forall> a1 b1 a2 b2 .
    pleq a1 b1 \<longrightarrow>
    pleq a2 b2 \<longrightarrow>
    P a1 a2 \<longrightarrow>
    P b1 b2)"

(* "Contravariant" version of monotonicity *)
definition is_monop2' :: "(('a :: Pord_Weak) \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
"is_monop2' P =
  (\<forall> a1 b1 a2 b2 .
    pleq a1 b1 \<longrightarrow>
    pleq b2 a2 \<longrightarrow>
    P a1 a2 \<longrightarrow>
    P b1 b2)"

(* Monotonicity for functions *)
definition is_mono :: "(('a :: Pord_Weak) \<Rightarrow> 'a) \<Rightarrow> bool" where
"is_mono f =
  (\<forall> a b .
     pleq a b \<longrightarrow>
     pleq (f a) (f b))"

(* Convenience introduction and eliminations for ub/sup/bub/bsup
   (we do not really use inf and lb, so those lemmas are omitted) *)
lemma is_ubI [intro] :
  assumes H : "\<And> x . x \<in> A \<Longrightarrow> pleq x a"
  shows "is_ub A a" using H
  by(auto simp add:is_ub_def)

(* TODO: some of these elim rules could be tagged with [elim]; however, I generally choose
   not to do this as not all of them are complete in the appropriate sense.
*)
lemma is_ubE :
  assumes H1 : "is_ub S ub"
  assumes H2 : "x \<in> S"
  shows "pleq x ub"
  using H1 H2
  by (auto simp add: is_ub_def)

lemma is_supI :
  assumes Hpleq : "\<And> x . x \<in> A \<Longrightarrow> pleq x ub"
  assumes Hleast : "\<And> x' . is_ub A x' \<Longrightarrow> pleq ub x'"
  shows "is_sup A ub" using Hpleq Hleast
  by(auto simp add:is_least_def is_ub_def is_sup_def)

lemma is_supD1 :
  assumes H1 : "is_sup S ub"
  assumes H2 : "x \<in> S"
  shows "pleq x ub"
  using H1 H2
  by (auto simp add: is_ub_def is_least_def is_sup_def)

lemma is_supD2 :
  assumes H1 : "is_sup S ub"
  assumes H2 : "is_ub S ub'"
  shows "pleq ub ub'"
  using H1 H2
  by (auto simp add: is_ub_def is_least_def is_sup_def)

lemma bsup_leq :
  assumes H : "is_bsup a b x"
  shows "pleq a x" using H
  by (auto simp add:is_bsup_def is_bub_def is_least_def)

lemma is_bubI :
  assumes Hpleq : "pleq a bub"
  assumes Hbub :
    "\<And> bd sd . pleq bd b \<Longrightarrow> is_sup {a, bd} sd \<Longrightarrow> pleq sd bub"
  shows "is_bub a b bub" using Hpleq Hbub
  by(auto simp add:is_bub_def)

lemma is_bubD1 :
  assumes H1 : "is_bub a b ub"
  shows "pleq a ub"
  using H1 by (auto simp add:is_bub_def)

lemma is_bubD2 :
  assumes H1 : "is_bub a b ub"
  assumes H2 : "pleq bd (b)"
  assumes H3 : "is_sup {a, bd} sd"
  shows "pleq sd (ub)"
  using H1 H2 H3 by (auto simp add:is_bub_def)

lemma is_bsupI :
  assumes Hpleq : "pleq a bub"
  assumes Hbub :
    "\<And> bd sd . pleq bd b \<Longrightarrow> is_sup {a, bd} sd \<Longrightarrow> pleq sd bub"
  assumes Hleast : "\<And> x' . is_bub a b x' \<Longrightarrow> pleq bub x'"
  shows "is_bsup a b bub" using Hpleq Hbub Hleast
  by(auto simp add:is_bsup_def is_least_def is_bub_def)

lemma is_bsupD1 :
  assumes H1 : "is_bsup a b ub"
  shows "pleq a ub"
  using H1 by (rule bsup_leq)

lemma is_bsupD2 :
  assumes H1 : "is_bsup a b ub"
  assumes H2 : "pleq bd (b)"
  assumes H3 : "is_sup {a, bd} sd"
  shows "pleq sd (ub)"
  using H1 H2 H3 by (auto simp add:is_bub_def is_bsup_def is_least_def)

lemma is_bsupD3 :
  assumes H1 : "is_bsup a b ub"
  assumes H2 : "is_bub a b ub'"
  shows "pleq ub ub'"
  using H1 H2 by (auto simp add:is_bsup_def is_least_def)

class Pord =
    Pord_Weak +
    assumes leq_antisym : "pleq a b \<Longrightarrow> pleq b a \<Longrightarrow> a = b"

(* facts about Pord *)
lemma is_greatest_unique :
  fixes P :: "('a :: Pord) \<Rightarrow> bool"
  fixes a b :: "('a :: Pord)"
  assumes H1 : "is_greatest P a"
  assumes H2 : "is_greatest P b"
  shows "a = b"
proof(-)
  have 0 :  "a <[ b" using H2 H1
    by(auto simp add:is_greatest_def)
  have 1 : "b <[ a" using H1 H2
    by(auto simp add:is_greatest_def)

  thus "a = b" using 0 1 by (auto intro: leq_antisym)
qed

lemma is_least_unique :
  fixes P :: "('a :: Pord) \<Rightarrow> bool"
  fixes a b :: "('a :: Pord)"
  assumes H1 : "is_least P a"
  assumes H2 : "is_least P b"
  shows "a = b"
proof(-)
  have 0 :  "a <[ b" using H2 H1
    by(auto simp add:is_least_def)
  have 1 : "b <[ a" using H1 H2
    by(auto simp add:is_least_def)

  thus "a = b" using 0 1 by (auto intro: leq_antisym)
qed

(* Uniqueness for sup, bsup *)

lemma is_sup_unique :
  fixes P :: "('a :: Pord) set"
  fixes x y :: "'a"
  shows "is_sup P x \<Longrightarrow> is_sup P y \<Longrightarrow> x = y"
proof(auto simp add:is_sup_def is_least_unique)
qed

lemma is_sup_comm2 :
  "is_sup {a, b} x \<Longrightarrow> is_sup {b, a} x"
proof(auto simp add:is_sup_def is_least_def is_ub_def)
qed

lemma sup_extend :
  assumes Hleq : "pleq a x"
  assumes Hlub1 : "is_sup {a, c} u1"
  assumes Hlub2 : "is_sup {x, c} u2"
  shows "pleq u1 u2"
proof(-)
  have 0 :  "pleq x u2" using Hlub2 by (auto simp add:is_sup_def is_ub_def is_least_def)
  have 1 :  "pleq a u2" using leq_trans[OF Hleq 0] by auto
  hence "is_ub {a, c} u2" using Hlub2
    by (auto simp add:is_sup_def is_ub_def is_least_def)

  thus ?thesis using Hlub1
    by (auto simp add:is_sup_def is_ub_def is_least_def)
qed

lemma bsup_unique :
  fixes a b x :: "'a :: Pord"
  assumes H1 : "is_bsup a b x"
  assumes H2 : "is_bsup a b x'"
  shows "x = x'"
  using H1 H2
proof(-)
  have 0 : "is_bub a b x'" using H2
    by(auto simp add:is_bsup_def is_least_def)

  have 1 : "pleq x x'" using 0 H1
    by(auto simp add:is_bsup_def is_least_def)

  have 2 : "is_bub a b x" using H1
    by(auto simp add:is_bsup_def is_least_def)

  have 3 : "pleq x' x" using 2 H2
    by(auto simp add:is_bsup_def is_least_def)

  show ?thesis using leq_antisym 1 3 by auto
qed

(*
Pordps = "PORD + Pairwise Sups"
(this could be phrased as an extension of Pord_Weak, but i don't think
this is that useful)

Here we add the assumption that if any 3 elements have pairwise
sups, all 3 have a sup. This ends up being useful for reasoning about
liftings.

*)

class Pordps =
  Pord +
  assumes pairwise_sup :
    "has_sup {a, b} \<Longrightarrow> has_sup {b, c} \<Longrightarrow> has_sup {a, c} \<Longrightarrow>
     has_sup {a, b, c}"

class Pordok = Pord + Okay

class Pordpsok = Pordok + Pordps +
  assumes pairwise_sup_ok :
  "\<And> a b supr :: ('a :: {Pord, Okay}). a \<in> ok_S \<Longrightarrow> b \<in> ok_S \<Longrightarrow> is_sup {a, b} supr \<Longrightarrow> supr \<in> ok_S"

(* Pordc = "PORD + Completness"
 * Note that this is a rather weak notion of completeness; we only require that
 * pairs with upper bounds have sups. Later we show that this implies completeness for
 * _finite_ sets. In some domain theory contexts completeness is presented as
 * applying to arbitrary sets, including infinite ones; we do not require that here
 * (intuitively, we know we will always be merging a finite number of language components
 * to get our final result)
*)
class Pordc =
  Pord +
  assumes complete2: "has_ub {a, b} \<Longrightarrow> has_sup {a, b}"

(* helper lemmas for our proof that bsup equals sup, in the event sup exists *)

lemma bsup_compare1:
  fixes a b bs_ab a' b' bs_a'b :: "'a :: Pordc"
  assumes Hbsup1 : "is_bsup a b bs_ab"
  assumes Hbsup2 : "is_bsup a' b' bs_a'b'"
  assumes Hleqa : "pleq a a'"
  assumes Hleqa' : "pleq a' bs_ab"
  assumes Hdesc : "\<And> bd sd . pleq bd b \<Longrightarrow> is_sup {a, bd} sd \<Longrightarrow>
                        (pleq bd (b'))" (* can we get away with has_ub here? *)
  shows "pleq (bs_ab) (bs_a'b')"
proof(-)
  have Bub : "is_bub a b bs_a'b'"
  proof(-)

    have Hbub : "\<And> bd sd . pleq bd b \<Longrightarrow> is_sup {a, bd} sd \<Longrightarrow> pleq sd (bs_ab)" using Hbsup1
      by(auto simp add:is_bsup_def is_bub_def is_least_def)

    have Hbub' : "\<And> bd sd . pleq bd (b') \<Longrightarrow> is_sup {a', bd} sd \<Longrightarrow> pleq sd (bs_a'b')" using Hbsup2
      by(auto simp add:is_bsup_def is_bub_def is_least_def)

    have Conc1 : "pleq a (bs_a'b')" using Hleqa
    proof(-)
      have in0 : "pleq a' (bs_a'b')" using bsup_leq Hbsup2 by auto
      thus ?thesis using leq_trans[OF Hleqa in0] by auto
    qed

    have Conc2 : "\<And> bd sd . pleq bd (b) \<Longrightarrow> is_sup {a, bd} sd \<Longrightarrow> pleq sd (bs_a'b')"
    proof(-)
      fix bd sd
      assume Hbd : "pleq bd (b)"
      assume Hsup : "is_sup {a, bd} sd"

      have 0 : "pleq bd (b')" using Hdesc[OF Hbd Hsup] by auto
(*      have 1 : "pleq bd (aug (bsup a' b'))" using Hdesc[OF Hbd Hsup] *)

      have 1 : "pleq bd sd" using Hsup
        by(auto simp add: is_sup_def is_ub_def is_least_def)

      have 2 : "pleq sd (bs_ab)" using Hbub[OF Hbd Hsup] by auto

      have "pleq bd (bs_ab)" using leq_trans[OF 1 2] by auto

      hence 3 : "is_ub {(a'), bd} ((bs_ab))" using Hleqa'
        by(auto simp add:is_ub_def leq_refl)

      hence 4 : "has_ub {(a'), bd}"
        by (auto simp add:has_ub_def)

      hence 5 : "has_sup {(a'), bd}"
        by (auto simp add:complete2)

      then obtain sd' where Hsd' : "is_sup {a', bd} sd'" by (auto simp add:has_sup_def)

      have 6: "pleq sd' (bs_a'b')" using Hbub'[OF 0 Hsd'] by auto

      have 8 : "pleq sd sd'" using sup_extend[OF Hleqa Hsup Hsd'] by auto

      show "pleq sd (bs_a'b')" using leq_trans[OF 8 6] by auto
    qed

    then show ?thesis using Conc1 Conc2 by(simp add:is_bub_def)
  qed
  thus ?thesis using Hbsup1
    by(auto simp add:is_bsup_def is_least_def)
qed

(* TODO: can we merge this with bsup_compare1 somehow? *)
lemma bsup_compare2:
  fixes a b bs_ab a' b' bs_a'b :: "'a :: Pordc"
  assumes Hbsup1 : "is_bsup a' b' bs_a'b'"
 assumes Hbsup2 : "is_bsup a b bs_ab"
 assumes Hleqa' : "pleq a' a"
 assumes Hleqa : "pleq a (bs_a'b')"
  assumes Hdesc : "\<And> bd sd . pleq bd (b) \<Longrightarrow> is_sup {a, bd} sd \<Longrightarrow>
                        (pleq bd (b'))" (* can we get away with has_ub here? *)
  shows "pleq bs_ab bs_a'b'"
proof(-)
  have Bub : "is_bub a b bs_a'b'"
  proof(-)

    have Hbub : "\<And> bd sd . pleq bd (b) \<Longrightarrow> is_sup {a, bd} sd \<Longrightarrow> pleq sd (bs_ab)" using Hbsup2
      by(auto simp add: is_bsup_def is_bub_def is_least_def)

    have Hbub' : "\<And> bd sd . pleq bd (b') \<Longrightarrow> is_sup {a', bd} sd \<Longrightarrow> pleq sd bs_a'b'" using Hbsup1
      by(auto simp add: is_bsup_def is_bub_def is_least_def)

    have Conc1 : "pleq a (bs_a'b')" using Hleqa by auto

    have Conc2 : "\<And> bd sd . pleq bd (b) \<Longrightarrow> is_sup {a, bd} sd \<Longrightarrow> pleq sd (bs_a'b')"
    proof(-)
      fix bd sd
      assume Hbd : "pleq bd (b)"
      assume Hsup : "is_sup {a, bd} sd"

      have 0 : "pleq bd (b')" using Hdesc[OF Hbd Hsup] by auto

      have 1 : "pleq bd sd" using Hsup
        by(auto simp add: is_sup_def is_ub_def is_least_def)

      have 2 : "pleq sd (bs_ab)" using Hbub[OF Hbd Hsup] by auto

      have 3 : "pleq bd (bs_ab)" using leq_trans[OF 1 2] by auto

      have 4 : "pleq a' (bs_ab)" using leq_trans[OF Hleqa' bsup_leq[OF Hbsup2]]
        by auto

      hence 5 : "is_ub {(a'), bd} (bs_ab)" using 3
        by(auto simp add:is_ub_def leq_refl)

      hence 6 : "has_ub {(a'), bd}" by (auto simp add:has_ub_def)

      have 7: "has_sup {a', bd}" using complete2[OF 6] by auto

      have 8 : "pleq bd (b')" using Hdesc[OF Hbd Hsup] by auto

      obtain sd' where Hsd' : "is_sup {a', bd} sd'" using 7 by (auto simp add:has_sup_def)

      have 9 : "pleq sd' (bs_a'b')" using Hbub'[OF 8 Hsd'] by auto

      have 10 : "pleq bd sd'" using Hsd' by (auto simp add:is_sup_def is_least_def is_ub_def)

      have 11 : "pleq bd (bs_a'b')" using leq_trans[OF 10 9] by auto

      have 12 : "is_ub {(a), bd} (bs_a'b')" using Hleqa 11
        by(auto simp add:is_ub_def)

      show "pleq sd (bs_a'b')" using 12 Hsup
        by(auto simp add:is_ub_def is_sup_def is_least_def)
    qed

    then show ?thesis using Conc1 Conc2 by(simp add:is_bub_def)
  qed
  thus ?thesis using Hbsup2
    by(auto simp add:is_bsup_def is_least_def)
qed

lemma bsup_mono2 :
  fixes a b bs_ab a' b' bs_ab' :: "'a :: Pordc"
  assumes H: "pleq b b'"
  assumes Hbsup1 : "is_bsup a b bs_ab"
  assumes Hbsup2 : "is_bsup a b' bs_ab'"
  shows   "pleq (bs_ab) (bs_ab')"

proof(-)

  have Hbound :
     "(\<And>bd sd. pleq bd b \<Longrightarrow> is_sup {a, bd} sd \<Longrightarrow> pleq bd b') "
  proof(-)
    fix bd sd
    assume H1 : "pleq bd b"
    assume H2 : "is_sup {a, bd} sd"

    show "pleq bd b'" using leq_trans[OF H1 H] by auto
  qed

  show ?thesis using bsup_compare1[OF Hbsup1 Hbsup2 leq_refl[of a] bsup_leq[OF Hbsup1] Hbound] by auto
qed

(* One of the key results from this file.
 * A biased supremum is guaranteed to coincide with the "true" supremum, should one exist.
 * This proves very helpful in characterizing and reasoning about bsup, avoiding some of the
 * "lower-level" proofs about bsup performed up to this point.
*)
lemma bsup_sup :
  fixes a b bs_ab :: "'a :: Pordc"
  assumes Hsup : "is_sup {a, b} s_ab"
  assumes Hbsup : "is_bsup a b bs_ab"
  shows "is_sup {a, b} bs_ab"
proof(-)

  have Bub : "is_bub a b s_ab"
  proof(-)
    have Conc1 : "pleq a s_ab" using Hsup
      by(auto simp add:is_sup_def is_least_def is_ub_def)

    have Conc2 :
      "\<And> bd sd . pleq bd b \<Longrightarrow> is_sup {a, bd} sd \<Longrightarrow> pleq sd s_ab"
    proof(-)
      fix bd sd
      assume Hi1 : "pleq bd b"
      assume Hi2 : "is_sup {a, bd} sd"

      have 0 : "pleq bd sd"
        using Hi2 by (auto simp add:is_sup_def is_least_def is_ub_def)

      have 1 : "pleq b s_ab"
        using Hsup by (auto simp add:is_sup_def is_least_def is_ub_def)

      have 2 : "pleq bd s_ab"
        using leq_trans[OF Hi1 1] by auto

      have "is_ub {a, bd} s_ab" using Conc1 2
        by(auto simp add:is_ub_def)

      thus "pleq sd s_ab" using Hi2
        by(auto simp add:is_sup_def is_least_def)
    qed

    show ?thesis using Conc1 Conc2
      by (auto simp add: is_bub_def)
  qed

  have bs_ab_Lt : "pleq bs_ab s_ab" using Bub Hbsup
    by(auto simp add:is_bsup_def is_least_def)

  have Ub : "is_ub {a, b} bs_ab"
  proof(-)
    have Conc1 : "pleq a bs_ab" using Hbsup
      by(auto simp add:is_bsup_def is_bub_def is_least_def)

    have 0 : "pleq b s_ab" using Hsup by (auto simp add:is_supD1)

    have 1 : "pleq s_ab bs_ab" using is_bsupD2[OF Hbsup leq_refl Hsup] by auto

    have Conc2 : "pleq b bs_ab" using leq_trans[OF 0 1] by auto

    show ?thesis using Conc1 Conc2 by
      (auto simp add:is_ub_def)
  qed

  have s_ab_Lt : "pleq s_ab bs_ab" using Ub Hsup
    by(auto simp add: is_sup_def is_least_def)

  show ?thesis using leq_antisym[OF bs_ab_Lt s_ab_Lt] Hsup by auto
qed

lemma leq_completion :
  fixes a a' b x :: "'a :: Pordc"
  assumes Hleq : "pleq a a'"
  assumes Hsup : "is_sup {a', b} x"
  shows "has_sup {a, b}"
proof(-)
  have 0 :  "pleq a' x" using Hsup by (simp add:is_sup_def is_least_def is_ub_def)
  have 1 : "pleq a x" using leq_trans[OF Hleq 0] by auto
  hence 2 : "is_ub {a, b} x" using Hsup by (simp add:is_sup_def is_least_def is_ub_def)
  hence 3 : "has_ub {a, b}" by (auto simp add:has_ub_def)
  thus ?thesis by (auto elim: complete2)
qed

lemma bsup_imp_sup :
  assumes Hbs : "is_bsup a b bs"
  assumes H : "pleq b bs"
  shows "is_sup {a, b} bs"

proof(rule is_supI)
  fix x
  assume Hx : "x \<in> {a, b}"
  show "pleq x bs" using H bsup_leq[OF Hbs] Hx
    by(auto)
next
  fix ub
  assume Hi :  "is_ub {a, b} ub"

  have 0 : "is_bub a b ub"
  proof(rule is_bubI)
    show "pleq a ub" using Hi by (auto simp add:is_ub_def)
  next
    fix bd sd
    assume Hl : "pleq bd b"
    assume Hs : "is_sup {a, bd} sd"

    have 0 : "is_ub {a, bd} ub" using Hi Hl leq_trans[of bd b ub]
      by(auto simp add:is_ub_def)

    show "pleq sd ub" using is_supD2[OF Hs 0] by auto
  qed

  show "pleq bs ub" using is_bsupD3[OF Hbs 0] by auto
qed

(* A consequence of bsup_sup : if we have completeness, a bsup, and an upper bound
 * for a and b, then b must be less than the bsup (i.e. bsup finds a "true supremum")
 *)
lemma bsup_imp_sup_conv :
  fixes a b bs ub :: "'a :: Pordc"
  assumes Hbs : "is_bsup a b bs"
  assumes H : "\<not> pleq b bs"
  assumes Hub : "is_ub {a, b} ub"
  shows False
proof(-)
  obtain lub where Hlub : "is_sup {a, b} lub" using Hub complete2 by(auto simp add:has_ub_def has_sup_def)
  have Hbub : "is_bub a b bs" using Hbs by(auto simp add:is_bsup_def is_least_def)
  have "pleq lub bs" using is_bubD2[OF Hbub leq_refl[of b] Hlub] by auto
  hence "pleq b bs" using Hlub leq_trans[of b lub bs] by (auto simp add:is_sup_def is_least_def is_ub_def)
  thus ?thesis using H by auto
qed

(*
 * Pordb = "Partial ORDer with Bottom. That is, a partial order with the additional requirement
 * that there be a least ("bottom", \<bottom>) element. In the literature such orders are often
 * called "pointed"; however, I wished to avoid confusion since "p" in this acronym already
 * stands for "partial"
 *)

class Pord_Weakb = Pord_Weak +
fixes bot :: "'a" ("\<bottom>")
assumes bot_spec :
  "\<And> (a :: 'a ) .  pleq bot a"

class Pordb =  Pord + Pord_Weakb

class Pordbps = Pordb + Pordps

class Pordpsc = Pordps + Pordc

(* Pordc and Pordb are basically orthogonal extensions to Pord. Often we care about
 * cases where we have both. *)
class Pordbc =  Pordc + Pordb

class Pordbpsc = Pordbc + Pordps

class Pordc_all = Pordc +
  assumes ub2_all : "\<And> a b . has_ub {a, b}"

lemma sup2_all :
  fixes a b :: "'a :: Pordc_all"
  shows "has_sup {a, b}"
  using complete2[OF ub2_all[of a b]]
  by auto

end


theory Auto_Proof_Demo
imports Main
begin

section "Logic and sets"

lemma "ALL x. EX y. x=y"
by auto

lemma "A \<subseteq> B \<inter> C \<Longrightarrow> A \<subseteq> B \<union> C"
by auto

text \<open>Note the bounded quantification notation:\<close>

lemma "\<lbrakk> \<forall>xs \<in> A. \<exists>ys. xs = ys @ ys;  us \<in> A \<rbrakk> \<Longrightarrow> \<exists>n. length us = n+n"
by fastforce

text \<open>Most simple proofs in FOL and set theory are automatic.
Example: if T is total, A is antisymmetric and T is a subset of A, then A is a subset of T.\<close>

lemma AT:
  "\<lbrakk> \<forall>x y. T x y \<or> T y x;
     \<forall>x y. A x y \<and> A y x \<longrightarrow> x = y;
     \<forall>x y. T x y \<longrightarrow> A x y \<rbrakk>
   \<Longrightarrow> \<forall>x y. A x y \<longrightarrow> T x y"
by blast

section "Sledgehammer"

lemma "R^* \<subseteq> (R \<union> S)^*"
oops

text \<open>Find a suitable P and try sledgehammer:\<close>

lemma "a # xs = ys @ [a] \<Longrightarrow> P"
oops

section "Arithmetic"

lemma "\<lbrakk> (a::int) \<le> f x + b; 2 * f x < c \<rbrakk> \<Longrightarrow> 2*a + 1 \<le> 2*b + c"
by arith

lemma "\<forall> (k::nat) \<ge> 8. \<exists> i j. k = 3*i + 5*j"
by arith

lemma "(n::int) mod 2 = 1 \<Longrightarrow> (n+n) mod 2 = 0"
by arith

lemma "(i + j) * (i - j) \<le> i*i + j*(j::int)"
by (simp add: algebra_simps)

lemma "(5::int) ^ 2 = 20+5"
by simp

end


section "Sequents"

theory Sequents
imports Formula
begin

type_synonym sequent = "formula list"

definition
  evalS :: "[model,vbl => object,formula list] => bool" where
  "evalS M phi fs \<longleftrightarrow> (? f : set fs . evalF M phi f = True)"

lemma evalS_nil[simp]: "evalS M phi [] = False"
  by(simp add: evalS_def)

lemma evalS_cons[simp]: "evalS M phi (A # Gamma) = (evalF M phi A | evalS M phi Gamma)"
  by(simp add: evalS_def)

lemma evalS_append: "evalS M phi (Gamma @ Delta) = (evalS M phi Gamma | evalS M phi Delta)"
  by(force simp add: evalS_def)

lemma evalS_equiv[rule_format]: "(equalOn (freeVarsFL Gamma) f g) --> (evalS M f Gamma = evalS M g Gamma)"
  apply (induct Gamma, simp, rule)
  apply(simp add: freeVarsFL_cons)
  apply(drule_tac equalOn_UnD)
  apply(blast dest: evalF_equiv)
  done

definition
  modelAssigns :: "[model] => (vbl => object) set" where
  "modelAssigns M = { phi . range phi <= objects M }"

lemma modelAssignsI: "range f <= objects M \<Longrightarrow> f : modelAssigns M"
  by(simp add: modelAssigns_def)

lemma modelAssignsD: "f : modelAssigns M \<Longrightarrow> range f <= objects M"
  by(simp add: modelAssigns_def)

definition
  validS :: "formula list => bool" where
  "validS fs \<longleftrightarrow> (! M . ! phi : modelAssigns M . evalS M phi fs = True)"

subsection "Rules"

type_synonym rule = "sequent * (sequent set)"

definition
  concR :: "rule => sequent" where
  "concR = (%(conc,prems). conc)"

definition
  premsR :: "rule => sequent set" where
  "premsR = (%(conc,prems). prems)"

definition
  mapRule :: "(formula => formula) => rule => rule" where
  "mapRule = (%f (conc,prems) . (map f conc,(map f) ` prems))"

lemma mapRuleI: "[| A = map f a; B = (map f) ` b |] ==> (A,B) = mapRule f (a,b)"
  by(simp add: mapRule_def)
    \<comment> \<open>FIXME tjr would like symmetric\<close>

subsection "Deductions"

(*FIXME. I don't see why plain Pow_mono is rejected.*)
lemmas Powp_mono [mono] = Pow_mono [to_pred pred_subset_eq]

inductive_set
  deductions  :: "rule set => formula list set"
  for rules :: "rule set"
  (******
   * Given a set of rules,
   *   1. Given a rule conc/prem(i) in rules,
   *       and the prem(i) are deductions from rules,
   *       then conc is a deduction from rules.
   *   2. can derive permutation of any deducible formula list.
   *      (supposed to be multisets not lists).
   ******)
  where
    inferI: "[| (conc,prems) : rules;
               prems : Pow(deductions(rules))
            |] ==> conc : deductions(rules)"
(*
    perms   "[| permutation conc' conc;
                conc' : deductions(rules)
             |] ==> conc : deductions(rules)"
*)

lemma mono_deductions: "[| A <= B |] ==> deductions(A) <= deductions(B)"
  apply(best intro: deductions.inferI elim: deductions.induct) done

(*lemmas deductionsMono = mono_deductions*)

(*
-- "tjr following should be subsetD?"
lemmas deductionSubsetI = mono_deductions[THEN subsetD]
thm deductionSubsetI
*)

(******
 * (f : formula -> formula) extended structurally over rules, deductions etc...
 * (((If f maps rules into themselves then can consider mapping derivation trees.)))
 * (((Is the asm necessary - think not?)))
 * The mapped deductions from the rules are same as
 * the deductions from the mapped rules.
 *
 * WHY:
 *
 * map f `` deductions rules <= deductions (mapRule f `` rules)     (this thm)
 *                           <= deductions rules                    (closed)
 *
 * If rules are closed under f then so are deductions.
 * Can take f = (subst u v) and have application to exercise #1.
 *
 * Q: maybe also make f dual mapping, (what about quantifier side conditions...?).
 ******)

(*
lemma map_deductions: "map f ` deductions rules <= deductions (mapRule f ` rules)"
  apply(rule subsetI)
  apply (erule_tac imageE, simp)
  apply(erule deductions.induct)
  apply(blast intro: deductions.inferI mapRuleI)
  done

lemma deductionsCloseRules: "! (conc,prems) : S . prems <= deductions R --> conc : deductions R ==> deductions (R Un S) = deductions R"
  apply(rule equalityI)
  prefer 2
  apply(rule mono_deductions) apply blast
  apply(rule subsetI)
  apply (erule_tac deductions.induct, simp) apply(erule conjE) apply(thin_tac "prems \<subseteq> deductions (R \<union> S)")
  apply(erule disjE)
  apply(rule inferI) apply assumption apply force
  apply blast
  done
*)

subsection "Basic Rule sets"

definition
  "Axioms  = { z. ? p vs.              z = ([FAtom Pos p vs,FAtom Neg p vs],{}) }"
definition
  "Conjs   = { z. ? A0 A1 Delta Gamma. z = (FConj Pos A0 A1#Gamma @ Delta,{A0#Gamma,A1#Delta}) }"
definition
  "Disjs   = { z. ? A0 A1       Gamma. z = (FConj Neg A0 A1#Gamma,{A0#A1#Gamma}) }"
definition
  "Alls    = { z. ? A x         Gamma. z = (FAll Pos A#Gamma,{instanceF x A#Gamma}) & x ~: freeVarsFL (FAll Pos A#Gamma) }"
definition
  "Exs     = { z. ? A x         Gamma. z = (FAll Neg A#Gamma,{instanceF x A#Gamma})}"
definition
  "Weaks   = { z. ? A           Gamma. z = (A#Gamma,{Gamma})}"
definition
  "Contrs  = { z. ? A           Gamma. z = (A#Gamma,{A#A#Gamma})}"
definition
  "Cuts    = { z. ? C Delta     Gamma. z = (Gamma @ Delta,{C#Gamma,FNot C#Delta})}"
definition
  "Perms   = { z. ? Gamma Gamma'     . z = (Gamma,{Gamma'}) & Gamma <~~> Gamma'}"
definition
  "DAxioms = { z. ? p vs.              z = ([FAtom Neg p vs,FAtom Pos p vs],{}) }"

lemma AxiomI: "[| Axioms <= A |] ==> [FAtom Pos p vs,FAtom Neg p vs] : deductions(A)"
  apply(rule deductions.inferI)
  apply(auto simp add: Axioms_def) done

lemma DAxiomsI: "[| DAxioms <= A |] ==> [FAtom Neg p vs,FAtom Pos p vs] : deductions(A)"
  apply(rule deductions.inferI)
  apply(auto simp add: DAxioms_def) done

lemma DisjI: "[| A0#A1#Gamma : deductions(A); Disjs <= A |] ==> (FConj Neg A0 A1#Gamma) : deductions(A)"
  apply(rule deductions.inferI)
  apply(auto simp add: Disjs_def) done

lemma ConjI: "[| (A0#Gamma) : deductions(A); (A1#Delta) : deductions(A); Conjs <= A |] ==> FConj Pos A0 A1#Gamma @ Delta : deductions(A)"
  apply(rule_tac prems="{A0#Gamma,A1#Delta}" in deductions.inferI)
  apply(auto simp add: Conjs_def) apply force done

lemma AllI: "[| instanceF w A#Gamma : deductions(R); w ~: freeVarsFL (FAll Pos A#Gamma); Alls <= R |] ==> (FAll Pos A#Gamma) : deductions(R)"
  apply(rule_tac prems="{instanceF w A#Gamma}" in deductions.inferI)
  apply(auto simp add: Alls_def) done

lemma ExI: "[| instanceF w A#Gamma : deductions(R); Exs <= R |] ==> (FAll Neg A#Gamma) : deductions(R)"
  apply(rule_tac prems = "{instanceF w A#Gamma}" in deductions.inferI)
  apply(auto simp add: Exs_def) done

lemma WeakI: "[| Gamma : deductions R; Weaks <= R |] ==> A#Gamma : deductions(R)"
  apply(rule_tac prems="{Gamma}" in deductions.inferI)
  apply(auto simp add: Weaks_def) done

lemma ContrI: "[| A#A#Gamma : deductions R; Contrs <= R |] ==> A#Gamma : deductions(R)"
  apply(rule_tac prems="{A#A#Gamma}" in deductions.inferI)
  apply(auto simp add: Contrs_def) done

lemma PermI: "[| Gamma' : deductions R; Gamma <~~> Gamma'; Perms <= R |] ==> Gamma : deductions(R)"
  apply(rule_tac prems="{Gamma'}" in deductions.inferI)
  apply(auto simp add: Perms_def) done

subsection "Derived Rules"

lemma WeakI1: "[| Gamma : deductions(A); Weaks <= A |] ==> (Delta @ Gamma) : deductions(A)"
  apply (induct Delta, simp)
  apply(auto intro: WeakI) done

lemma WeakI2: "[| Gamma : deductions(A); Perms <= A; Weaks <= A |] ==> (Gamma @ Delta) : deductions(A)"
  apply(blast intro: PermI perm_append_swap WeakI1) done

lemma SATAxiomI: "[| Axioms <= A; Weaks <= A; Perms <= A; forms = [FAtom Pos n vs,FAtom Neg n vs] @ Gamma |] ==> forms : deductions(A)"
  apply(simp only:)
  apply(blast intro: WeakI2 AxiomI)
  done

lemma DisjI1: "[| (A1#Gamma) : deductions(A); Disjs <= A; Weaks <= A |] ==> FConj Neg A0 A1#Gamma : deductions(A)"
  apply(blast intro: DisjI WeakI)
  done

lemma DisjI2: "!!A. [| (A0#Gamma) : deductions(A); Disjs <= A; Weaks <= A; Perms <= A |] ==> FConj Neg A0 A1#Gamma : deductions(A)"
  apply(rule DisjI)
  apply(rule PermI[OF _ perm.swap])
  apply(rule WeakI)
  .

    \<comment> \<open>FIXME the following 4 lemmas could all be proved for the standard rule sets using monotonicity as below\<close>
    \<comment> \<open>we keep proofs as in original, but they are slightly ugly, and do not state what is intuitively happening\<close>
lemma perm_tmp4: "Perms \<subseteq> R \<Longrightarrow> A @ (a # list) @ (a # list) : deductions R \<Longrightarrow> (a # a # A) @ list @ list : deductions R"
  apply (rule PermI, auto)
  apply(simp add: perm_count_conv count_append) done

lemma weaken_append[rule_format]: "Contrs <= R ==> Perms <= R ==> !A. A @ Gamma @ Gamma : deductions(R) -->  A @ Gamma : deductions(R)"
  apply (induct_tac Gamma, simp, rule) apply rule
  apply(drule_tac x="a#a#A" in spec)
  apply(erule_tac impE)
  apply(rule perm_tmp4) apply(assumption, assumption)
  apply(thin_tac "A @ (a # list) @ a # list \<in> deductions R")
  apply simp
  apply(frule_tac ContrI) apply assumption
  apply(thin_tac "a # a # A @ list \<in> deductions R")
  apply(rule PermI) apply assumption
  apply(simp add: perm_count_conv count_append)
  by assumption
  \<comment> \<open>FIXME horrible\<close>

lemma ListWeakI: "Perms <= R ==> Contrs <= R ==> x # Gamma @ Gamma : deductions(R) ==> x # Gamma : deductions(R)"
  by(rule weaken_append[of R "[x]" Gamma, simplified])

lemma ConjI': "[| (A0#Gamma) : deductions(A);  (A1#Gamma) : deductions(A); Contrs <= A; Conjs <= A; Perms <= A |] ==> FConj Pos A0 A1#Gamma : deductions(A)"
  apply(rule ListWeakI, assumption, assumption)
  apply(rule ConjI) .

subsection "Standard Rule Sets For Predicate Calculus"

definition
  PC :: "rule set" where
  "PC = Union {Perms,Axioms,Conjs,Disjs,Alls,Exs,Weaks,Contrs,Cuts}"

definition
  CutFreePC :: "rule set" where
  "CutFreePC = Union {Perms,Axioms,Conjs,Disjs,Alls,Exs,Weaks,Contrs}"

lemma rulesInPCs: "Axioms <= PC" "Axioms <= CutFreePC"
  "Conjs  <= PC" "Conjs  <= CutFreePC"
  "Disjs  <= PC" "Disjs  <= CutFreePC"
  "Alls   <= PC" "Alls   <= CutFreePC"
  "Exs    <= PC" "Exs    <= CutFreePC"
  "Weaks  <= PC" "Weaks  <= CutFreePC"
  "Contrs <= PC" "Contrs <= CutFreePC"
  "Perms  <= PC" "Perms  <= CutFreePC"
  "Cuts   <= PC"
  "CutFreePC <= PC"
  by(auto simp: PC_def CutFreePC_def)

subsection "Monotonicity for CutFreePC deductions"

  \<comment> \<open>these lemmas can be used to replace complicated permutation reasoning above\<close>
  \<comment> \<open>essentially if x is a deduction, and set x subset set y, then y is a deduction\<close>

definition
  inDed :: "formula list => bool" where
  "inDed xs \<longleftrightarrow> xs : deductions CutFreePC"

lemma perm: "! xs ys. xs <~~> ys --> (inDed xs = inDed ys)"
  apply(subgoal_tac "! xs ys. xs <~~> ys --> inDed xs --> inDed ys")
  apply (blast intro: perm_sym, clarify)
  apply(simp add: inDed_def)
  apply (rule PermI, assumption)
  apply(rule perm_sym) apply assumption
  by(blast intro!: rulesInPCs)

lemma contr: "! x xs. inDed (x#x#xs) --> inDed (x#xs)"
  apply(simp add: inDed_def)
  apply(blast intro!: ContrI rulesInPCs)
  done

lemma weak: "! x xs. inDed xs --> inDed (x#xs)"
  apply(simp add: inDed_def)
  apply(blast intro!: WeakI rulesInPCs)
  done

lemma inDed_mono[simplified inDed_def]: "inDed x ==> set x <= set y ==> inDed y"
  using perm_weak_contr_mono[OF perm contr weak] .

end


section\<open>Group by Function\<close>
theory GroupF
imports Main
begin

text\<open>Grouping elements of a list according to a function.\<close>

fun groupF ::  "('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'a list list"  where
  "groupF f [] = []" |
  "groupF f (x#xs) = (x#(filter (\<lambda>y. f x = f y) xs))#(groupF f (filter (\<lambda>y. f x \<noteq> f y) xs))"

text\<open>trying a more efficient implementation of @{term groupF}\<close>
context
begin
  private fun select_p_tuple :: "('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> ('a list \<times> 'a list) \<Rightarrow> ('a list \<times> 'a list)"
  where
    "select_p_tuple p x (ts,fs) = (if p x then (x#ts, fs) else (ts, x#fs))"

  private definition partition_tailrec :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> ('a list \<times> 'a list)"
  where
    "partition_tailrec p xs = foldr (select_p_tuple p) xs ([],[])"

  private lemma partition_tailrec: "partition_tailrec f as =  (filter f as,  filter (\<lambda>x. \<not>f x) as)"
  proof -
    {fix ts_accu fs_accu
      have "foldr (select_p_tuple f) as (ts_accu, fs_accu) =
              (filter f as @ ts_accu,  filter (\<lambda>x. \<not>f x) as @ fs_accu)"
      by(induction as arbitrary: ts_accu fs_accu) simp_all
    } thus ?thesis unfolding partition_tailrec_def by simp
  qed

  private lemma
    "groupF f (x#xs) = (let (ts, fs) = partition_tailrec (\<lambda>y. f x = f y) xs in (x#ts)#(groupF f fs))"
  by(simp add: partition_tailrec)

  (*is this more efficient?*)
  private function groupF_code ::  "('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'a list list"  where
    "groupF_code f [] = []" |
    "groupF_code f (x#xs) = (let
                               (ts, fs) = partition_tailrec (\<lambda>y. f x = f y) xs
                             in
                               (x#ts)#(groupF_code f fs))"
  by(pat_completeness) auto

  private termination groupF_code
    apply(relation "measure (\<lambda>(f,as). length (filter (\<lambda>x. (\<lambda>y. f x = f y) x) as))")
     apply(simp; fail)
    apply(simp add: partition_tailrec)
    using le_imp_less_Suc length_filter_le by blast

  lemma groupF_code[code]: "groupF f as = groupF_code f as"
    by(induction f as rule: groupF_code.induct) (simp_all add: partition_tailrec)

  export_code groupF checking SML
end

lemma groupF_concat_set: "set (concat (groupF f xs)) = set xs"
  proof(induction f xs rule: groupF.induct)
  case 2 thus ?case by (simp) blast
  qed(simp)

lemma groupF_Union_set: "(\<Union>x \<in> set (groupF f xs). set x) = set xs"
  proof(induction f xs rule: groupF.induct)
  case 2 thus ?case by (simp) blast
  qed(simp)

lemma groupF_set: "\<forall>X \<in> set (groupF f xs). \<forall>x \<in> set X. x \<in> set xs"
  using groupF_concat_set by fastforce

lemma groupF_equality:
  defines "same f A \<equiv> \<forall>a1 \<in> set A. \<forall>a2 \<in> set A. f a1 = f a2"
  shows "\<forall>A \<in> set (groupF f xs). same f A"
  proof(induction f xs rule: groupF.induct)
    case 1 thus ?case by simp
  next
    case (2 f x xs)
      have groupF_fst:
        "groupF f (x # xs) = (x # [y\<leftarrow>xs . f x = f y]) # groupF f [y\<leftarrow>xs . f x \<noteq> f y]" by force
      have step: " \<forall>A\<in>set [x # [y\<leftarrow>xs . f x = f y]]. same f A" unfolding same_def by fastforce
      with 2 show ?case unfolding groupF_fst by fastforce
  qed

lemma groupF_nequality: "A \<in> set (groupF f xs) \<Longrightarrow> B \<in> set (groupF f xs) \<Longrightarrow> A \<noteq> B \<Longrightarrow>
     \<forall>a \<in> set A. \<forall>b \<in> set B. f a \<noteq> f b"
  proof(induction f xs rule: groupF.induct)
  case 1 thus ?case by simp
  next
  case 2 thus ?case
    apply -
    apply(subst (asm) groupF.simps)+
    using groupF_set by fastforce (*1s*)
  qed

lemma groupF_cong: fixes xs::"'a list" and f1::"'a \<Rightarrow> 'b" and f2::"'a \<Rightarrow> 'c"
  assumes "\<forall>x \<in> set xs. \<forall>y \<in> set xs. (f1 x = f1 y \<longleftrightarrow> f2 x = f2 y)"
  shows "groupF f1 xs = groupF f2 xs"
  using assms proof(induction f1 xs rule: groupF.induct)
    case (2 f x xs) thus ?case using filter_cong[of xs xs "\<lambda>y. f x = f y" "\<lambda>y. f2 x = f2 y"]
                                     filter_cong[of xs xs "\<lambda>y. f x \<noteq> f y" "\<lambda>y. f2 x \<noteq> f2 y"] by auto
  qed (simp)

lemma groupF_empty: "groupF f xs \<noteq> [] \<longleftrightarrow> xs \<noteq> []"
  by(induction f xs rule: groupF.induct) auto
lemma groupF_empty_elem: "x \<in> set (groupF f xs) \<Longrightarrow> x \<noteq> []"
  by(induction f xs rule: groupF.induct) auto

lemma groupF_distinct: "distinct xs \<Longrightarrow> distinct (concat (groupF f xs))"
  proof(induction f xs rule: groupF.induct)
  case (2 f x xs) thus ?case
    apply (simp)
    apply(intro conjI)
     apply (meson filter_is_subset groupF_set subsetCE)
    apply(subgoal_tac "UNION (set (groupF f [a\<leftarrow>xs . f x \<noteq> f a])) set = set [a\<leftarrow>xs . f x \<noteq> f a]")
     prefer 2
     apply (metis (no_types) groupF_concat_set set_concat)
    by auto
  qed(simp)

text\<open>It is possible to use
    @{term "map (map fst) (groupF snd (map (\<lambda>x. (x, f x)) P))"}
  instead of
    @{term "groupF f P"}
  for the following reasons:
    @{const groupF} executes its compare function (first parameter) very often;
    it always tests for @{term "(f x = f y)"}.
    The function @{term f} may be really expensive.
    At least polyML does not share the result of @{term f} but (probably) always recomputes (part of) it.
    The optimization pre-computes @{term f} and tells @{const groupF} to use
    a really cheap function (@{const snd}) to compare.
    The following lemma tells that those are equal.\<close>
  (* is this also faster for Haskell?*)

lemma groupF_tuple: "groupF f xs = map (map fst) (groupF snd (map (\<lambda>x. (x, f x)) xs))"
  proof(induction f xs rule: groupF.induct)
  case (1 f) thus ?case by simp
  next
  case (2 f x xs)
    have g1: "[y\<leftarrow>xs . f x = f y] = map fst [y\<leftarrow>map (\<lambda>x. (x, f x)) xs . f x = snd y]"
      proof(induction xs arbitrary: f x)
      case Cons thus ?case by fastforce
      qed(simp)
    have g2: "(map (\<lambda>x. (x, f x)) [y\<leftarrow>xs . f x \<noteq> f y]) = [y\<leftarrow>map (\<lambda>x. (x, f x)) xs . f x \<noteq> snd y]"
      proof(induction xs)
      case Cons thus ?case by fastforce
      qed(simp)
    from 2 g1 g2 show ?case by simp
  qed
end


(*
  File: OrderTopology.thy
  Author: Bohua Zhan

  Basic results about order topology.
*)

theory OrderTopology
  imports Topology Auto2_FOL.Interval Auto2_FOL.AlgStructure
begin

section \<open>Set with at least two element\<close>

definition card_ge2 :: "i \<Rightarrow> o" where [rewrite]:
  "card_ge2(X) \<longleftrightarrow> (\<exists>a\<in>X. \<exists>b\<in>X. a \<noteq> b)"

lemma card_ge2I [backward2]: "{a,b} \<subseteq> X \<Longrightarrow> a \<noteq> b \<Longrightarrow> card_ge2(X)" by auto2
lemma card_ge2_D1 [resolve]: "card_ge2(X) \<Longrightarrow> \<exists>a\<in>X. \<exists>b\<in>X. a \<noteq> b" by auto2
lemma card_ge2_D2 [resolve]: "card_ge2(X) \<Longrightarrow> a \<in> X \<Longrightarrow> \<exists>b\<in>X. b \<noteq> a" by auto2
setup {* del_prfstep_thm @{thm card_ge2_def} *}

section \<open>Order topology\<close>

definition ord_basis :: "i \<Rightarrow> i" where [rewrite]:
  "ord_basis(X) = ((\<Union>a\<in>.X. \<Union>b\<in>.X. {open_interval(X,a,b)}) \<union>
     (\<Union>a\<in>.X. {less_interval(X,a)}) \<union> (\<Union>a\<in>.X. {greater_interval(X,a)}))"

lemma ord_basisE [forward]:
  "W \<in> ord_basis(X) \<Longrightarrow> (\<exists>a\<in>.X. \<exists>b\<in>.X. W = open_interval(X,a,b)) \<or>
     (\<exists>a\<in>.X. W = less_interval(X,a)) \<or> (\<exists>a\<in>.X. W = greater_interval(X,a))" by auto2

lemma ord_basisI [resolve]:
  "a \<in>. X \<Longrightarrow> b \<in>. X \<Longrightarrow> open_interval(X,a,b) \<in> ord_basis(X)"
  "a \<in>. X \<Longrightarrow> less_interval(X,a) \<in> ord_basis(X)"
  "a \<in>. X \<Longrightarrow> greater_interval(X,a) \<in> ord_basis(X)" by auto2+
setup {* del_prfstep_thm @{thm ord_basis_def} *}

lemma ord_basis_eq_str [rewrite]:
  "eq_str_order(X,Y) \<Longrightarrow> ord_basis(X) = ord_basis(Y)" by auto2

lemma ord_basis_is_basis [forward]:
  "linorder(X) \<Longrightarrow> collection_is_basis(ord_basis(X))"
@proof @let "\<B> = ord_basis(X)" @have "\<forall>U\<in>\<B>. \<forall>V\<in>\<B>. U \<inter> V \<in> \<B>" @qed

lemma ord_basis_union [rewrite]:
  "linorder(X) \<Longrightarrow> card_ge2(carrier(X)) \<Longrightarrow> \<Union>ord_basis(X) = carrier(X)"
@proof
  @have "\<forall>x\<in>.X. x \<in> \<Union>ord_basis(X)" @with
    @obtain "y\<in>.X" where "y \<noteq> x"
    @case "y <\<^sub>X x" @with @have "x \<in> greater_interval(X,y)" @end
    @case "y >\<^sub>X x" @with @have "x \<in> less_interval(X,y)" @end
  @end
@qed

definition order_topology :: "i \<Rightarrow> o" where [rewrite]:
  "order_topology(X) \<longleftrightarrow> (linorder(X) \<and> is_top_space_raw(X) \<and> card_ge2(carrier(X)) \<and>
    open_sets(X) = top_from_basis(ord_basis(X)))"

lemma order_topology_has_basis [forward]:
  "order_topology(X) \<Longrightarrow> top_has_basis(X,ord_basis(X))" by auto2

lemma order_topologyD [forward]:
  "order_topology(X) \<Longrightarrow> linorder(X)"
  "order_topology(X) \<Longrightarrow> is_top_space(X)"
  "order_topology(X) \<Longrightarrow> card_ge2(carrier(X))" by auto2+

lemma order_topologyI [backward]:
  "linorder(X) \<Longrightarrow> is_top_space_raw(X) \<Longrightarrow> card_ge2(carrier(X)) \<Longrightarrow>
   open_sets(X) = top_from_basis(ord_basis(X)) \<Longrightarrow> order_topology(X)" by auto2

lemma order_topology_open_interval [resolve]:
  "order_topology(X) \<Longrightarrow> a \<in>. X \<Longrightarrow> b \<in>. X \<Longrightarrow> is_open(X,open_interval(X,a,b))" by auto2

lemma order_topology_less_interval [resolve]:
  "order_topology(X) \<Longrightarrow> a \<in>. X \<Longrightarrow> is_open(X,less_interval(X,a))" by auto2

lemma order_topology_greater_interval [resolve]:
  "order_topology(X) \<Longrightarrow> a \<in>. X \<Longrightarrow> is_open(X,greater_interval(X,a))" by auto2

lemma order_topology_le_interval [resolve]:
  "order_topology(X) \<Longrightarrow> a \<in>. X \<Longrightarrow> is_closed(X,le_interval(X,a))" by auto2

lemma order_topology_ge_interval [resolve]:
  "order_topology(X) \<Longrightarrow> a \<in>. X \<Longrightarrow> is_closed(X,ge_interval(X,a))" by auto2

lemma order_topology_closed_interval [resolve]:
  "order_topology(X) \<Longrightarrow> a \<in>. X \<Longrightarrow> b \<in>. X \<Longrightarrow> is_closed(X,closed_interval(X,a,b))"
@proof
  @have "closed_interval(X,a,b) = le_interval(X,b) \<inter> ge_interval(X,a)"
@qed

lemma order_top_is_openI [forward]:
  "order_topology(X) \<Longrightarrow> \<forall>x\<in>U. \<exists>a b. x \<in> open_interval(X,a,b) \<and> open_interval(X,a,b) \<subseteq> U \<Longrightarrow> is_open(X,U)" by auto2

lemma order_top_is_openD_gt [backward2]:
  "order_topology(X) \<Longrightarrow> is_open(X,U) \<Longrightarrow> a \<in> U \<Longrightarrow> \<exists>M. M >\<^sub>X a \<Longrightarrow> \<exists>c >\<^sub>X a. closed_open_interval(X,a,c) \<subseteq> U"
@proof
  @obtain "W\<in>ord_basis(X)" where "a \<in> W \<and> W \<subseteq> U"
  @case "\<exists>p\<in>.X. \<exists>q\<in>.X. W = open_interval(X,p,q)"
@qed

lemma order_top_is_openD_lt [backward2]:
  "order_topology(X) \<Longrightarrow> is_open(X,U) \<Longrightarrow> a \<in> U \<Longrightarrow> \<exists>M. M <\<^sub>X a \<Longrightarrow> \<exists>c <\<^sub>X a. open_closed_interval(X,c,a) \<subseteq> U"
@proof
  @obtain "W\<in>ord_basis(X)" where "a \<in> W \<and> W \<subseteq> U"
  @case "\<exists>p\<in>.X. \<exists>q\<in>.X. W = open_interval(X,p,q)"
@qed

lemma order_top_is_openD_unbounded [backward2]:
  "order_topology(X) \<Longrightarrow> order_unbounded(X) \<Longrightarrow>
   is_open(X,U) \<Longrightarrow> x \<in> U \<Longrightarrow> \<exists>a b. x \<in> open_interval(X,a,b) \<and> open_interval(X,a,b) \<subseteq> U"
@proof
  @obtain b where "b >\<^sub>X x" "closed_open_interval(X,x,b) \<subseteq> U"
  @obtain a where "a <\<^sub>X x" "open_closed_interval(X,a,x) \<subseteq> U"
  @have "x \<in> open_interval(X,a,b)"
  @have "open_interval(X,a,b) = open_closed_interval(X,a,x) \<union> closed_open_interval(X,x,b)"
@qed

setup {* fold del_prfstep_thm [@{thm order_topology_has_basis}, @{thm order_topology_def}] *}
setup {* add_resolve_prfstep @{thm order_topology_has_basis} *}

section \<open>Data structure for order topology\<close>

definition is_ord_top_raw :: "i \<Rightarrow> o" where [rewrite]:
  "is_ord_top_raw(R) \<longleftrightarrow> is_top_space_raw(R) \<and> raworder(R)"

lemma is_ord_top_rawD [forward]:
  "is_ord_top_raw(R) \<Longrightarrow> is_top_space_raw(R)"
  "is_ord_top_raw(R) \<Longrightarrow> raworder(R)" by auto2+
setup {* del_prfstep_thm_eqforward @{thm is_ord_top_raw_def} *}

definition ord_top_form :: "i \<Rightarrow> o" where [rewrite]:
  "ord_top_form(R) \<longleftrightarrow> is_ord_top_raw(R) \<and> is_func_graph(R,{carrier_name,open_sets_name,order_graph_name})"

lemma ord_top_form_to_raw [forward]: "ord_top_form(R) \<Longrightarrow> is_ord_top_raw(R)" by auto2

definition OrderTop :: "[i, i, i \<Rightarrow> i \<Rightarrow> o] \<Rightarrow> i" where [rewrite]:
  "OrderTop(S,T,r) = Struct({\<langle>carrier_name,S\<rangle>, \<langle>open_sets_name,T\<rangle>, \<langle>order_graph_name, rel_graph(S,r)\<rangle>})"

lemma OrderTop_is_ord_top_raw [backward]:
  "T \<subseteq> Pow(S) \<Longrightarrow> R = OrderTop(S,T,r) \<Longrightarrow> ord_top_form(R)"
@proof @have "raworder(R)" @qed

lemma OrderTop_eval [rewrite]:
  "carrier(OrderTop(S,T,r)) = S"
  "open_sets(OrderTop(S,T,r)) = T"
  "X = OrderTop(S,T,r) \<Longrightarrow> x \<in>. X \<Longrightarrow> y \<in>. X \<Longrightarrow> x \<le>\<^sub>X y \<longleftrightarrow> r(x,y)" by auto2+

lemma ord_top_eq [backward]:
  "ord_top_form(X) \<Longrightarrow> ord_top_form(Y) \<Longrightarrow> eq_str_order(X,Y) \<Longrightarrow> eq_str_top(X,Y) \<Longrightarrow> X = Y" by auto2

setup {* fold del_prfstep_thm [@{thm ord_top_form_def}, @{thm OrderTop_def}] *}

definition order_top_from_order :: "i \<Rightarrow> i" where [rewrite]:
  "order_top_from_order(X) = OrderTop(carrier(X),top_from_basis(ord_basis(X)),\<lambda>x y. x \<le>\<^sub>X y)"

lemma order_top_from_order_ord_top_form [forward]:
  "raworder(X) \<Longrightarrow> ord_top_form(order_top_from_order(X))" by auto2

lemma order_top_from_order_eq_str:
  "raworder(X) \<Longrightarrow> eq_str_order(X,order_top_from_order(X))" by auto2
setup {* add_forward_prfstep_cond @{thm order_top_from_order_eq_str} [with_term "order_top_from_order(?X)"] *}

lemma order_top_from_order_is_ord_top [backward]:
  "linorder(X) \<Longrightarrow> card_ge2(carrier(X)) \<Longrightarrow> order_topology(order_top_from_order(X))" by auto2
setup {* add_prfstep_check_req ("order_top_from_order(X)", "order_topology(order_top_from_order(X))") *}

section \<open>Defining topology on an ordered ring\<close>

definition OrdRingTop :: "[i, i, i \<Rightarrow> i \<Rightarrow> i, i, i \<Rightarrow> i \<Rightarrow> i, i \<Rightarrow> i \<Rightarrow> o, i] \<Rightarrow> i" where [rewrite]:
  "OrdRingTop(S,z,f,u,g,r,T) = Struct({\<langle>carrier_name,S\<rangle>, \<langle>open_sets_name,T\<rangle>,
      \<langle>order_graph_name, rel_graph(S,r)\<rangle>,
      \<langle>zero_name, z\<rangle>, \<langle>plus_fun_name, binary_fun_of(S,f)\<rangle>,
      \<langle>one_name, u\<rangle>, \<langle>times_fun_name, binary_fun_of(S,g)\<rangle>})"

lemma OrdRingTop_is_ord_ring_raw [backward]:
  "z \<in> S \<Longrightarrow> binary_fun(S,f) \<Longrightarrow> u \<in> S \<Longrightarrow> binary_fun(S,g) \<Longrightarrow>
   R = OrdRingTop(S,z,f,u,g,r,T) \<Longrightarrow> is_ord_ring_raw(R)"
@proof
  @have "is_abgroup_raw(R)"
  @have "is_group_raw(R)"
  @have "is_ring_raw(R)"
  @have "raworder(R)"
@qed

lemma ord_top_ring_eval [rewrite]:
  "carrier(OrdRingTop(S,z,f,u,g,r,T)) = S"
  "zero(OrdRingTop(S,z,f,u,g,r,T)) = z"
  "one(OrdRingTop(S,z,f,u,g,r,T)) = u"
  "open_sets(OrdRingTop(S,z,f,u,g,r,T)) = T"
  "R = OrdRingTop(S,z,f,u,g,r,T) \<Longrightarrow> x \<in>. R \<Longrightarrow> y \<in>. R \<Longrightarrow> is_abgroup_raw(R) \<Longrightarrow> x +\<^sub>R y = f(x,y)"
  "R = OrdRingTop(S,z,f,u,g,r,T) \<Longrightarrow> x \<in>. R \<Longrightarrow> y \<in>. R \<Longrightarrow> is_group_raw(R) \<Longrightarrow> x *\<^sub>R y = g(x,y)"
  "R = OrdRingTop(S,z,f,u,g,r,T) \<Longrightarrow> x \<in>. R \<Longrightarrow> y \<in>. R \<Longrightarrow> x \<le>\<^sub>R y \<longleftrightarrow> r(x,y)" by auto2+
setup {* del_prfstep_thm @{thm OrdRingTop_def} *}

section \<open>Order topology from an ordered ring\<close>

definition ord_ring_top_from_ord_ring :: "i \<Rightarrow> i" where [rewrite]:
  "ord_ring_top_from_ord_ring(R) =
    OrdRingTop(carrier(R), \<zero>\<^sub>R, \<lambda>x y. x +\<^sub>R y, \<one>\<^sub>R, \<lambda>x y. x *\<^sub>R y, \<lambda>x y. x \<le>\<^sub>R y, top_from_basis(ord_basis(R)))"

lemma ord_ring_top_from_ord_ring_is_ord_ring [forward]:
  "is_ord_ring_raw(R) \<Longrightarrow> is_ord_ring_raw(ord_ring_top_from_ord_ring(R))" by auto2

lemma ord_ring_top_from_ord_ring_eq_str:
  "is_ord_ring_raw(R) \<Longrightarrow> A = ord_ring_top_from_ord_ring(R) \<Longrightarrow> eq_str_ord_ring(R,A)" by auto2
setup {* add_forward_prfstep_cond @{thm ord_ring_top_from_ord_ring_eq_str} [with_term "?A"] *}

lemma ord_ring_top_from_ord_ring_is_top_space_raw [forward]:
  "is_ord_ring_raw(R) \<Longrightarrow> linorder(R) \<Longrightarrow> is_ord_top_raw(ord_ring_top_from_ord_ring(R))" by auto2

lemma ord_ring_top_from_ord_ring_is_ord_top [backward]:
  "is_ord_ring_raw(R) \<Longrightarrow> linorder(R) \<Longrightarrow> card_ge2(carrier(R)) \<Longrightarrow>
   order_topology(ord_ring_top_from_ord_ring(R))" by auto2

section \<open>Subspace on order topology\<close>

definition order_convex :: "i \<Rightarrow> i \<Rightarrow> o" where [rewrite]:
  "order_convex(X,A) \<longleftrightarrow> (A \<subseteq> carrier(X) \<and> (\<forall>a\<in>A. \<forall>b\<in>A. closed_interval(X,a,b) \<subseteq> A))"

lemma order_convexD1 [forward]: "order_convex(X,A) \<Longrightarrow> A \<subseteq> carrier(X)" by auto2

lemma order_convexD2a [backward2]:
  "order_convex(X,A) \<Longrightarrow> a \<in> A \<Longrightarrow> b \<in> A \<Longrightarrow> closed_interval(X,a,b) \<subseteq> A" by auto2

lemma order_convexD2b [backward2]:
  "linorder(X) \<Longrightarrow> order_convex(X,A) \<Longrightarrow> a \<in> A \<Longrightarrow> b \<in> A \<Longrightarrow> open_interval(X,a,b) \<subseteq> A"
@proof @have "closed_interval(X,a,b) \<subseteq> A" @qed
setup {* del_prfstep_thm_eqforward @{thm order_convex_def} *}

lemma closed_interval_convex [resolve]:
  "linorder(X) \<Longrightarrow> order_convex(X,closed_interval(X,a,b))" by auto2

definition ord_subspace :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "ord_subspace(X,A) = OrderTop(A, {A \<inter> U. U \<in> open_sets(X)}, \<lambda>x y. x \<le>\<^sub>X y)"

lemma ord_subspace_ord_top_form [forward]: "ord_top_form(ord_subspace(X,A))" by auto2
lemma ord_subspace_carrier: "carrier(ord_subspace(X,A)) = A" by auto2
setup {* add_forward_prfstep_cond @{thm ord_subspace_carrier} [with_term "ord_subspace(?X,?A)"] *}

lemma ord_subspace_eq_str [resolve]:
  "is_top_space(X) \<Longrightarrow> A \<subseteq> carrier(X) \<Longrightarrow> eq_str_top(subspace(X,A),ord_subspace(X,A))"
@proof @have "open_sets(subspace(X,A)) = open_sets(ord_subspace(X,A))" @qed

lemma ord_subspace_is_top_space:
  "is_top_space(X) \<Longrightarrow> A \<subseteq> carrier(X) \<Longrightarrow> is_top_space(ord_subspace(X,A))"
@proof @have "eq_str_top(subspace(X,A),ord_subspace(X,A))" @qed
setup {* add_forward_prfstep_cond @{thm ord_subspace_is_top_space} [with_term "ord_subspace(?X,?A)"] *}

lemma order_top_from_order_finer1 [resolve]:
  "order_topology(X) \<Longrightarrow> card_ge2(A) \<Longrightarrow> order_convex(X,A) \<Longrightarrow>
   Y = order_top_from_order(suborder(X,A)) \<Longrightarrow> is_open(Y, A \<inter> less_interval(X,x))"
@proof
  @case "x \<in> A" @with @have "A \<inter> less_interval(X,x) = less_interval(suborder(X,A),x)" @end
  @have (@rule) "A \<inter> less_interval(X,x) = \<emptyset> \<or> A \<subseteq> less_interval(X,x)" @with
    @contradiction
    @obtain "b \<in> A" where "b \<in> less_interval(X,x)"
    @obtain "c \<in> A" where "c \<notin> less_interval(X,x)"
    @have "closed_interval(X,b,c) \<subseteq> A"
    @have "x \<in> closed_interval(X,b,c)" @end
@qed

lemma order_top_from_order_finer2 [resolve]:
  "order_topology(X) \<Longrightarrow> card_ge2(A) \<Longrightarrow> order_convex(X,A) \<Longrightarrow>
   Y = order_top_from_order(suborder(X,A)) \<Longrightarrow> is_open(Y, A \<inter> greater_interval(X,x))"
@proof
  @case "x \<in> A" @with @have "A \<inter> greater_interval(X,x) = greater_interval(suborder(X,A),x)" @end
  @have (@rule) "A \<inter> greater_interval(X,x) = \<emptyset> \<or> A \<subseteq> greater_interval(X,x)" @with
    @contradiction
    @obtain "b \<in> A" where "b \<in> greater_interval(X,x)"
    @obtain "c \<in> A" where "c \<notin> greater_interval(X,x)"
    @have "closed_interval(X,c,b) \<subseteq> A"
    @have "x \<in> closed_interval(X,c,b)" @end
@qed

lemma order_top_from_order_finer3 [resolve]:
  "order_topology(X) \<Longrightarrow> card_ge2(A) \<Longrightarrow> order_convex(X,A) \<Longrightarrow>
   Y = order_top_from_order(suborder(X,A)) \<Longrightarrow> is_open(Y, A \<inter> open_interval(X,x,y))"
@proof
  @have "open_interval(X,x,y) = less_interval(X,y) \<inter> greater_interval(X,x)"
  @have "A \<inter> open_interval(X,x,y) = (A \<inter> less_interval(X,y)) \<inter> (A \<inter> greater_interval(X,x))"
  @have "is_open(Y, A \<inter> less_interval(X,y))"
@qed

lemma order_top_from_order_eq_sub [backward]:
  "order_topology(X) \<Longrightarrow> card_ge2(A) \<Longrightarrow> order_convex(X,A) \<Longrightarrow>
   eq_str_top(ord_subspace(X,A),order_top_from_order(suborder(X,A)))"
@proof
  @let "Y = order_top_from_order(suborder(X,A))"
  @let "Z = ord_subspace(X,A)"
  @have "top_space_finer(Z,Y)"
  @let "\<B> = {A \<inter> U. U \<in> ord_basis(X)}"
  @have "top_has_basis(Z,\<B>)" @with @have "eq_str_top(subspace(X,A),Z)" @end
  @have "top_space_finer(Y,Z)" @with @have "\<forall>U\<in>\<B>. is_open(Y,U)" @end
@qed

lemma ord_subspace_is_order_top:
  "order_topology(X) \<Longrightarrow> card_ge2(A) \<Longrightarrow> order_convex(X,A) \<Longrightarrow> order_topology(ord_subspace(X,A))"
@proof @have "ord_subspace(X,A) = order_top_from_order(suborder(X,A))"@qed
setup {* add_forward_prfstep_cond @{thm ord_subspace_is_order_top} [with_term "ord_subspace(?X,?A)"] *}

lemma closed_interval_order_topology:
  "order_topology(X) \<Longrightarrow> a <\<^sub>X b \<Longrightarrow> I = closed_interval(X,a,b) \<Longrightarrow> order_topology(ord_subspace(X,I))"
@proof
  @have "card_ge2(I)" @with @have "{a,b} \<subseteq> I" @end
  @have "order_convex(X,I)"
@qed
setup {* add_forward_prfstep_cond @{thm closed_interval_order_topology} [with_term "ord_subspace(?X,?I)"] *}

end


section \<open>Monotone Formulas\<close>

text \<open>We define monotone formulas, i.e., without negation,
  and show that usually the constant TRUE is not required.\<close>

theory Monotone_Formula
  imports Main
begin

subsection \<open>Definition\<close>

datatype 'a mformula =
  TRUE | FALSE |            \<comment> \<open>True and False\<close>
  Var 'a |                  \<comment> \<open>propositional variables\<close>
  Conj "'a mformula" "'a mformula" |  \<comment> \<open>conjunction\<close>
  Disj "'a mformula" "'a mformula"    \<comment> \<open>disjunction\<close>

text \<open>the set of subformulas of a mformula\<close>

fun SUB :: "'a mformula \<Rightarrow> 'a mformula set" where
  "SUB (Conj \<phi> \<psi>) = {Conj \<phi> \<psi>} \<union> SUB \<phi> \<union> SUB \<psi>"
| "SUB (Disj \<phi> \<psi>) = {Disj \<phi> \<psi>} \<union> SUB \<phi> \<union> SUB \<psi>"
| "SUB (Var x) = {Var x}"
| "SUB FALSE = {FALSE}"
| "SUB TRUE = {TRUE}"

text \<open>the variables of a mformula\<close>

fun vars :: "'a mformula \<Rightarrow> 'a set" where
  "vars (Var x) = {x}"
| "vars (Conj \<phi> \<psi>) = vars \<phi> \<union> vars \<psi>"
| "vars (Disj \<phi> \<psi>) = vars \<phi> \<union> vars \<psi>"
| "vars FALSE = {}"
| "vars TRUE = {}"

lemma finite_SUB[simp, intro]: "finite (SUB \<phi>)"
  by (induct \<phi>, auto)

text \<open>The circuit-size of a mformula: number of subformulas\<close>

definition cs :: "'a mformula \<Rightarrow> nat" where
  "cs \<phi> = card (SUB \<phi>)"

text \<open>variable assignments\<close>

type_synonym 'a VAS = "'a \<Rightarrow> bool"

text \<open>evaluation of mformulas\<close>

fun eval :: "'a VAS \<Rightarrow> 'a mformula \<Rightarrow> bool" where
  "eval \<theta> FALSE = False"
| "eval \<theta> TRUE = True"
| "eval \<theta> (Var x) = \<theta> x"
| "eval \<theta> (Disj \<phi> \<psi>) = (eval \<theta> \<phi> \<or> eval \<theta> \<psi>)"
| "eval \<theta> (Conj \<phi> \<psi>) = (eval \<theta> \<phi> \<and> eval \<theta> \<psi>)"

lemma eval_vars: assumes "\<And> x. x \<in> vars \<phi> \<Longrightarrow> \<theta>1 x = \<theta>2 x"
  shows "eval \<theta>1 \<phi> = eval \<theta>2 \<phi>"
  using assms by (induct \<phi>, auto)

subsection \<open>Conversion of mformulas to true-free mformulas\<close>

inductive_set tf_mformula :: "'a mformula set" where
  tf_False: "FALSE \<in> tf_mformula"
| tf_Var: "Var x \<in> tf_mformula"
| tf_Disj: "\<phi> \<in> tf_mformula \<Longrightarrow> \<psi> \<in> tf_mformula \<Longrightarrow> Disj \<phi> \<psi> \<in> tf_mformula"
| tf_Conj: "\<phi> \<in> tf_mformula \<Longrightarrow> \<psi> \<in> tf_mformula \<Longrightarrow> Conj \<phi> \<psi> \<in> tf_mformula"

fun to_tf_formula where
  "to_tf_formula (Disj phi psi) = (let phi' = to_tf_formula phi; psi' = to_tf_formula psi
    in (if phi' = TRUE \<or> psi' = TRUE then TRUE else Disj phi' psi'))"
| "to_tf_formula (Conj phi psi) = (let phi' = to_tf_formula phi; psi' = to_tf_formula psi
    in (if phi' = TRUE then psi' else if psi' = TRUE then phi' else Conj phi' psi'))"
| "to_tf_formula phi = phi"

lemma eval_to_tf_formula: "eval \<theta> (to_tf_formula \<phi>) = eval \<theta> \<phi>"
  by (induct \<phi> rule: to_tf_formula.induct, auto simp: Let_def)

lemma to_tf_formula: "to_tf_formula \<phi> \<noteq> TRUE \<Longrightarrow> to_tf_formula \<phi> \<in> tf_mformula"
  by (induct \<phi>, auto simp: Let_def intro: tf_mformula.intros)

lemma vars_to_tf_formula: "vars (to_tf_formula \<phi>) \<subseteq> vars \<phi>"
  by (induct \<phi> rule: to_tf_formula.induct, auto simp: Let_def)

lemma SUB_to_tf_formula: "SUB (to_tf_formula \<phi>) \<subseteq> to_tf_formula ` SUB \<phi>"
  by (induct \<phi> rule: to_tf_formula.induct, auto simp: Let_def)

lemma cs_to_tf_formula: "cs (to_tf_formula \<phi>) \<le> cs \<phi>"
proof -
  have "cs (to_tf_formula \<phi>) \<le> card (to_tf_formula ` SUB \<phi>)"
    unfolding cs_def by (rule card_mono[OF finite_imageI[OF finite_SUB] SUB_to_tf_formula])
  also have "\<dots> \<le> cs \<phi>" unfolding cs_def
    by (rule card_image_le[OF finite_SUB])
  finally show "cs (to_tf_formula \<phi>) \<le> cs \<phi>" .
qed

lemma to_tf_mformula: assumes "\<not> eval \<theta> \<phi>"
  shows "\<exists> \<psi> \<in> tf_mformula. (\<forall> \<theta>. eval \<theta> \<phi> = eval \<theta> \<psi>) \<and> vars \<psi> \<subseteq> vars \<phi> \<and> cs \<psi> \<le> cs \<phi>"
proof (intro bexI[of _ "to_tf_formula \<phi>"] conjI allI eval_to_tf_formula[symmetric] vars_to_tf_formula to_tf_formula)
  from assms have "\<not> eval \<theta> (to_tf_formula \<phi>)" by (simp add: eval_to_tf_formula)
  thus "to_tf_formula \<phi> \<noteq> TRUE" by auto
  show "cs (to_tf_formula \<phi>) \<le> cs \<phi>" by (rule cs_to_tf_formula)
qed

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_bin_times
imports "../../Test_Base"
begin

datatype Bin = One | ZeroAnd "Bin" | OneAnd "Bin"

fun toNat :: "Bin => int" where
"toNat (One) = 1"
| "toNat (ZeroAnd xs) = (toNat xs) + (toNat xs)"
| "toNat (OneAnd ys) = (1 + (toNat ys)) + (toNat ys)"

fun s :: "Bin => Bin" where
"s (One) = ZeroAnd One"
| "s (ZeroAnd xs) = OneAnd xs"
| "s (OneAnd ys) = ZeroAnd (s ys)"

fun plus :: "Bin => Bin => Bin" where
"plus (One) y = s y"
| "plus (ZeroAnd z) (One) = s (ZeroAnd z)"
| "plus (ZeroAnd z) (ZeroAnd ys) = ZeroAnd (plus z ys)"
| "plus (ZeroAnd z) (OneAnd xs) = OneAnd (plus z xs)"
| "plus (OneAnd x2) (One) = s (OneAnd x2)"
| "plus (OneAnd x2) (ZeroAnd zs) = OneAnd (plus x2 zs)"
| "plus (OneAnd x2) (OneAnd ys2) = ZeroAnd (s (plus x2 ys2))"

fun times :: "Bin => Bin => Bin" where
"times (One) y = y"
| "times (ZeroAnd xs1) y = ZeroAnd (times xs1 y)"
| "times (OneAnd xs12) y = plus (ZeroAnd (times xs12 y)) y"

theorem property0 :
  "((toNat (times x y)) = ((toNat x) * (toNat y)))"
  oops

end


theory Short_Theory
  imports Main
begin

(* syntax  *)
type_synonym vname = string
datatype aexp = N int | V vname | Plus aexp aexp

(* semantics  *)
type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n) s = n" |
"aval (V x) s = s x" |
"aval (Plus a1 a2) s = aval a1 s + aval a2 s"

fun asimp_const :: "aexp \<Rightarrow> aexp" where
"asimp_const (N n) = N n" |
"asimp_const (V x) = V x" |
"asimp_const (Plus a1 a2) =
  (case (asimp_const a1, asimp_const a2) of
    (N n1, N n2) \<Rightarrow> N(n1 + n2) |
    (b1, b2) \<Rightarrow> Plus b1 b2)"

lemma asimp_const_corr[simp]: "aval (asimp_const a) s = aval a s"
  apply(induction a)
  apply(auto split: aexp.split)
  done

(* local optimization *)
fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"plus (N i1) (N i2) = N(i1 + i2)" |
"plus (N i) a = (if i=0 then a else Plus (N i) a)" |
"plus a (N i) = (if i=0 then a else Plus a (N i))" |
"plus a1 a2 = Plus a1 a2"

lemma aval_plus[simp]: "aval (plus a1 a2) s  = aval a1 s + aval a2 s"
  apply(induction a1 a2 rule: plus.induct)
  apply(auto)
  done

(* term traversing *)
fun asimp :: "aexp \<Rightarrow> aexp" where
"asimp (N n) = N n" |
"asimp (V x) = V x" |
"asimp (Plus a1 a2) = plus (asimp a1) (asimp a2)"

lemma asimp_correctness[simp]: "aval (asimp a) s = aval a s"
  apply(induction a)
  apply(auto simp add: aval_plus)
  done

end