; Fully Ordered Finite Sets
; Copyright (C) 2003-2012 Kookamara LLC
;
; Contact:
;
;   Kookamara LLC
;   11410 Windermere Meadows
;   Austin, TX 78759, USA
;   http://www.kookamara.com/
;
; License: (An MIT/X11-style license)
;
;   Permission is hereby granted, free of charge, to any person obtaining a
;   copy of this software and associated documentation files (the "Software"),
;   to deal in the Software without restriction, including without limitation
;   the rights to use, copy, modify, merge, publish, distribute, sublicense,
;   and/or sell copies of the Software, and to permit persons to whom the
;   Software is furnished to do so, subject to the following conditions:
;
;   The above copyright notice and this permission notice shall be included in
;   all copies or substantial portions of the Software.
;
;   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;   AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;   DEALINGS IN THE SOFTWARE.

;; COI version, modified by Jared Davis, 2014-10, to include std/osets books
;; and only add the new functions and theorems that had been in COI.

;; listsets.lisp - sets of true lists
;; Jared Davis
;;
;;
;; INTRODUCTION
;;
;; In other library books, we often want to reason about sets of true lists,
;; e.g., so that we can work with sets of paths, etc.  In this file, we provide
;; recognizers for sets of true lists, and functions to coerce sets into sets
;; of true lists, e.g., by mapping list::fix across the set.  We build off of
;; the "quantify" and "map" macros in the osets library to do this.  So, even
;; though this function looks small, this file is actually "heavy weight" and
;; introduces a fairly comprehensive theory.
;;
;; bzo - eventually the osets library should switch over to using Adviser to
;; manage its computed hints.  Also, we should be able to not have a whole file
;; for all<true-listp>, by just putting it in an encapsulate where we want it.

(in-package "SET")
(include-book "listsets-base")
(include-book "misc/untranslate-patterns" :dir :system)
(include-book "../lists/basic")
(include-book "../lists/memberp")
(include-book "map")
(set-verify-guards-eagerness 2)

(local (in-theory (enable weak-insert-induction-helper-1)))
(local (in-theory (enable weak-insert-induction-helper-2)))
(local (in-theory (enable weak-insert-induction-helper-3)))

;; (local (in-theory (disable map-subset-helper-2))) ;; speed hint

;; bzo move to sets library
(defthm sfix-when-empty
  (implies (empty x)
           (equal (sfix x)
                  nil))
  :hints(("Goal" :in-theory (enable sfix))))

;; bzo this should be generated by quantify-predicate instead.
(defthm filter<true-listp>-of-insert
  (equal (filter<true-listp> (insert a x))
         (if (true-listp a)
             (insert a (filter<true-listp> x))
           (filter<true-listp> x))))

;; bzo this should be generated by quantify-predicate instead.
(defthm filter<true-listp>-of-union
  (equal (filter<true-listp> (union x y))
         (union (filter<true-listp> x)
                     (filter<true-listp> y))))

;; bzo is this a good rule??  if so, lets have it be generated by
;; quantify-predicate.  But, I'm not convinced that it is good, and it is
;; potentially expensive, although the free variable should help.
(defthm in-when-subset-of-filter<true-listp>s
  (implies (and (subset (filter<true-listp> x)
                        (filter<true-listp> y))
                (true-listp a)
                (in a x))
           (in a y)))

(map-function (list::fix x))

;; bzo it seems like we might not want this rule.  Normally we want rules that
;; rewrite (in a (set-operation ...)) to something we can reason about more
;; easily, so it seems like maybe this *is* a good rule to have.  On the other
;; hand, we have a lot of theorems that let us conlude (in a x) given some
;; hypotheses about other things in the environment, e.g., subset relations and
;; so forth.  And, this seems to interfere with that.  I guess the question is,
;; is the right hand side of this rule nice *enough*?
(in-theory (disable map-in<fix>))

(defthm all<true-listp>-of-map<fix>
  (all<true-listp> (map<fix> x)))

(defthm all-list<true-listp>-of-map-list<fix>
  (all-list<true-listp> (map-list<fix> list)))

(defthm map<fix>-identity-when-all<true-listp>
  (implies (all<true-listp> x)
           (equal (map<fix> x)
                  (sfix x))))

;; bzo we might want to add rules like these to the set theory library, if we
;; decide to integrate it with the lists library

(defcong list::equiv equal (all-list<true-listp> x) 1
  :hints(("Goal" :induct (list::len-len-induction x list::x-equiv))))

(defcong list::equiv equal (exists-list<true-listp> x) 1
  :hints(("Goal" :induct (list::len-len-induction x list::x-equiv))))

(defcong list::equiv equal (find-list<true-listp> x) 1
  :hints(("Goal" :induct (list::len-len-induction x list::x-equiv))))

(defcong list::equiv equal (filter-list<true-listp> x) 1
  :hints(("Goal" :induct (list::len-len-induction x list::x-equiv))))

(defcong list::equiv equal (all-list<not-true-listp> x) 1
  :hints(("Goal" :induct (list::len-len-induction x list::x-equiv))))

(defcong list::equiv equal (exists-list<not-true-listp> x) 1
  :hints(("Goal" :induct (list::len-len-induction x list::x-equiv))))

(defcong list::equiv equal (find-list<not-true-listp> x) 1
  :hints(("Goal" :induct (list::len-len-induction x list::x-equiv))))

(defcong list::equiv equal (filter-list<not-true-listp> x) 1
  :hints(("Goal" :induct (list::len-len-induction x list::x-equiv))))

(defcong list::equiv equal (map-list<fix> list) 1
  :hints(("Goal" :induct (list::len-len-induction list list::list-equiv))))

(defcong list::equiv equal (all-list<inversep<fix>> x a) 1
  :hints(("Goal" :induct (list::len-len-induction x list::x-equiv))))

(defcong list::equiv equal (exists-list<inversep<fix>> x a) 1
  :hints(("Goal" :induct (list::len-len-induction x list::x-equiv))))

(defcong list::equiv equal (find-list<inversep<fix>> x a) 1
  :hints(("Goal" :induct (list::len-len-induction x list::x-equiv))))

(defcong list::equiv equal (filter-list<inversep<fix>> x a) 1
  :hints(("Goal" :induct (list::len-len-induction x list::x-equiv))))

(defcong list::equiv equal (all-list<not-inversep<fix>> x a) 1
  :hints(("Goal" :induct (list::len-len-induction x list::x-equiv))))

(defcong list::equiv equal (exists-list<not-inversep<fix>> x a) 1
  :hints(("Goal" :induct (list::len-len-induction x list::x-equiv))))

(defcong list::equiv equal (find-list<not-inversep<fix>> x a) 1
  :hints(("Goal" :induct (list::len-len-induction x list::x-equiv))))

(defcong list::equiv equal (filter-list<not-inversep<fix>> x a) 1
  :hints(("Goal" :induct (list::len-len-induction x list::x-equiv))))

;; List Sets
;;
;; An object is a listsetp only when it satisfies (setp x) and also
;; (all<true-listp> x).  Historically, list sets were originally an
;; implementation of "U2 Graphs" for the records library.
;;
;; Any existing references to u2p's in comments should be understood to mean
;; listsetp's. TEMP comments can be removed, they are only there to explain the
;; differences between the previously stubbed out definition of u2 graphs.

(defund listsetp (x)
  (declare (xargs :guard t))
  (and (setp x)
       (all<true-listp> x)))

(defthm setp-when-listsetp
  (implies (listsetp x)
           (setp x))
  :hints(("Goal" :in-theory (enable listsetp))))

(defthm listsetp-when-empty
  (implies (empty x)
           (equal (listsetp x)
                  (setp x)))
  :hints(("Goal" :in-theory (enable listsetp))))

;; TEMP (jcd) - I think we don't want this, so I am removing it.
;; (defthm u2p-if
;;   (implies (and (u2p b)
;;                 (u2p c))
;;            (u2p (if a b c)))
;;   :rule-classes (:type-prescription :rewrite))

;; TEMP (jcd) - I think we want this now, so I am leaving it enabled.
;; (in-theory (disable (:type-prescription u2p)))

;; TEMP (jcd) - Although I believe that this is technically true because of the
;; way sets are defined, I don't think we want to prove it, because it is
;; "badly typed" now in that we should not list-fix sets.
;;
;; (defthm u2p-list-fix
;;   (implies
;;    (u2p x)
;;    (u2p (list::list-fix x)))
;;   :rule-classes (:type-prescription :rewrite)
;;   :hints (("goal" :in-theory (enable u2p))))

;; TEMP (jcd) - This was originally u2p of append, but now we should talk about
;; unions since u2's are sets instead of lists.
;;
;; (defthm u2p-of-union
;;   (implies (and (u2p x)
;;                 (u2p y))
;;            (u2p (set::union x y)))
;;   :rule-classes :rewrite
;;   :hints (("goal" :in-theory (enable u2p))))
;;
;; Actually I am taking it out in favor of this stronger rule:

;; TEMP (jcd) - added this rule
(defthm listsetp-of-insert
  (equal (listsetp (insert a x))
         (and (true-listp a)
              (listsetp (sfix x))))
  :hints(("Goal" :in-theory (enable listsetp))))

;; TEMP (jcd) - added this rule
(defthm listsetp-of-union
  (equal (listsetp (union x y))
         (and (listsetp (sfix x))
              (listsetp (sfix y))))
  :hints(("Goal" :in-theory (enable listsetp))))

;; TEMP (jcd) - added this rule
(defthm listsetp-of-delete-when-listsetp
  (implies (listsetp x)
           (listsetp (delete a x)))
  :hints(("Goal" :in-theory (enable listsetp))))

;; TEMP (jcd) - added this rule
(defthm listsetp-of-intersect-when-listsetp-one
  (implies (listsetp x)
           (listsetp (intersect x y)))
  :hints(("Goal" :in-theory (enable listsetp))))

;; TEMP (jcd) - added this rule
(defthm listsetp-of-intersect-when-listsetp-two
  (implies (listsetp y)
           (listsetp (intersect x y)))
  :hints(("Goal" :in-theory (enable listsetp))))

;; TEMP (jcd) - added this rule
(defthm listsetp-of-difference-when-listsetp-one
  (implies (listsetp x)
           (listsetp (difference x y)))
  :hints(("Goal" :in-theory (enable listsetp))))

;; TEMP (jcd) - removing empty-u2, we will just use emptyset.

;; TEMP (jcd) - removing this, we just expand empty-u2 to nil now.
;; (in-theory (disable (empty-u2) (:type-prescription empty-u2)))

;; TEMP (jcd) - removing this, it is already well known in the osets library
;; (defthm union-empty-u2-u2
;;   (equal (union (empty-u2) u2)
;;          (sfix u2)))

;; TEMP (jcd) - removing this, execution should get it now.
;; (defthm listsetp-empty-u2
;;   (listsetp (empty-u2))
;;   :rule-classes (:rewrite :type-prescription)
;;   :hints (("goal" :in-theory (enable listsetp))))

;; TEMP (jcd) - originally we had a function "u2" that was supposed to "smash a
;; regular list into a u2 graph."  I've thought quite a bit about how to adapt
;; this to work with ordered sets. The theorems about u2 were a little odd in
;; the sense that we were told (listsetp (u2 list)) and also that (u2 (u2 list)) =
;; (u2 list).  But, that means that the argument to u2 could be either a list
;; or a set.  I don't like that kind of overloading.  Instead, I have written
;; two versions of the function, one which coerces a list into a listsetp (make-u2),
;; and one which simply "interprets" any ACL2 object as a listsetp (u2fix).

;; "mklistset" is relatively simple, and I haven't given it a whole lot of
;; though.  It coerces a list into a u2 graph, by first list::fix'ing every
;; element in the list, and then sorting the resulting lists in order to create
;; a set.

(defund mklistset (xs)
  (declare (xargs :guard (true-listp xs)))
  (mergesort (map-list<fix> xs)))

(defthm listsetp-of-mklistset
  (listsetp (mklistset xs))
  :hints(("Goal" :in-theory (enable mklistset listsetp))))

(defcong list::equiv equal (mklistset xs) 1
  :hints(("Goal" :in-theory (enable mklistset))))

(defthm in-mklistset
  (equal (in a (mklistset xs))
         (list::memberp a (map-list<fix> xs)))
  :hints(("Goal" :in-theory (enable mklistset))))

;; How do we interpret "bad" U2 graphs?  There are alternatives here, and it is
;; not clear which is best.  To really weigh all the considerations, we need to
;; think about the u2equiv relation that is going to be based upon this.  The
;; u2equiv relation tests whether or not two objects are equivalent when
;; "interpreted" as u2 sets.  In other words, it is written as (equal
;; (listsetfix x) (listsetfix y)).
;;
;; Here are the options as I see them:
;;
;; Option 1.  Define listsetfix as map<fix>, so that any non-set is treated as
;; nil (in accordance with the non-sets convention), and any set will simply
;; have each of its elements list::fix'ed.

;; (defund listsetfix (u2)
;;   (declare (xargs :guard (listsetp u2)
;;                   :verify-guards nil))
;;   (mbe :logic (map<fix> u2)
;;        :exec u2))

;; Option 2.  Define listsetfix as (if (listsetp x) x nil), so that any
;; non-listset is treated as nil and anything else is treated as the empty set.

;; (defund listsetfix (u2)
;;   (declare (xargs :guard (listsetp u2)
;;                   :verify-guards nil))
;;   (mbe :logic (if (listsetp u2) u2 (emptyset))
;;        :exec u2))

;; Option 3.  Define listsetfix as filter<true-listp>, so that any non-set is
;; treated as nil (in accordance to the non-set convention), and any other set
;; will just have all of its non-true-lists "dropped" from it.  This is the
;; option I eventually decided to go with.

(defund listsetfix (x)
  (declare (xargs :guard (listsetp x)
                  :verify-guards nil))
  (mbe :logic (filter<true-listp> x)
       :exec x))

;; Any of these options satisfies the basic requirements for listsetfix --
;; namely, that it should always create a u2 and that it should be the identity
;; on legitimate listsets.

(verify-guards listsetfix
  :hints(("Goal" :in-theory (enable listsetp))))

(defthm listsetp-of-listsetfix
  (listsetp (listsetfix x))
  :hints(("Goal" :in-theory (enable listsetp listsetfix))))

(defthm listsetfix-when-listsetp
  (implies (listsetp x)
           (equal (listsetfix x)
                  x))
  :hints(("Goal" :in-theory (enable listsetp listsetfix))))

;; So which option is better?  Before we address this, we will first define an
;; equivalence relation for u2's, namely u2equiv.  This operation asks if
;; the interpretations of objects x and y as u2 graphs are equivalent, and the
;; proof that it is an equivalence relation is trivial.

(defund listsetequiv (x y)
  (declare (xargs :guard (and (listsetp x)
                              (listsetp y))))
  (equal (listsetfix x)
         (listsetfix y)))

(defequiv listsetequiv
  :hints(("Goal" :in-theory (enable listsetequiv))))

;; TEMP (jcd) - Originally there was a refinement relation here saying that
;; perm is a refinement of u2-equiv.  Even if this is true, I don't want to say
;; it, because we should be thinking now of u2's as sets rather than as bags,
;; so trying to apply bag reasoning to them seems like a type error.

;; With any of our options above, the listsetfix of a valid u2 is the identity
;; function, so regardless of which one we use, we can prove the following
;; rewrite rule:

(defthm listsetfix-under-listsetequiv
  (listsetequiv (listsetfix x)
                x)
  :hints(("Goal" :in-theory (enable listsetequiv))))

;; Similarly, any of the options above are sufficient to prove this congruence,
;; which allows us to conclue that listsetfixes of equivalent u2's are equal.

;; TEMP (jcd) - This seems like a useful fact that I might not have about other
;; fixing functions, such as map::fix or list::fix?

(defcong listsetequiv equal (listsetfix x) 1
  :hints(("Goal" :in-theory (enable listsetequiv))))

;; We now introduce a simple congruence rule for listsetequiv over insert.
;; Either of Options 1 or 3 satisfy this property, but Option 2 does not.  I
;; think this is sufficient cause to rule out Option 2 as a serious contender.
;; To see a counterexample, suppose that x = { (1 2 3 . 4) }, and let y = nil.
;; Using option 2, x and y are considered equivalent.  We would then like to be
;; able to conclude that (insert a x) is equivalent to (insert a y), but this
;; is not the case!  Let a = nil.  Then (insert a x) = { nil, (1 2 3 . 4) } and
;; (insert a y) = { nil }.  But these are not equivalent, because { nil, (1 2 3
;; . 4)} "fixes" to the empty set, while { nil }, being a valid u2, fixes to
;; itself.

;; TEMP (jcd) - changed from cons to insert
(defcong listsetequiv listsetequiv (insert a x) 2
  :hints(("Goal" :in-theory (enable listsetequiv listsetfix))))

;; Options 1 and 3 both seem good for different reasons, and both options
;; support all of the following congruence rules:

;; TEMP (jcd) - changed from append to union
(defcong listsetequiv listsetequiv (union x y) 1
  :hints(("goal" :in-theory (enable listsetequiv listsetfix))))

;; TEMP (jcd) - changed from append to union
(defcong listsetequiv listsetequiv (union x y) 2
  :hints(("Goal" :in-theory (enable listsetequiv listsetfix))))

;; TEMP (jcd) - added this rule
(defcong listsetequiv listsetequiv (sfix x) 1
  :hints(("Goal" :in-theory (enable listsetequiv listsetfix))))

;; TEMP (jcd) - added this rule
(defthm cardinality-of-listsetfix
  (<= (cardinality (listsetfix x))
      (cardinality x))
  :rule-classes :linear
  :hints(("Goal" :in-theory (enable listsetfix))))

;; TEMP (jcd) - added this rule
(defthm sfix-under-listsetequiv
  (listsetequiv (sfix x)
                x)
  :hints(("Goal" :in-theory (enable listsetequiv listsetfix))))

(defthm listsetequiv-union-x-x
  (listsetequiv (union x x)
                x))

;; There are some tradeoffs between Option 1 and Option 3.  Here are some basic
;; theorems that we have when using Option 1:

;; ;; TEMP (jcd) - added this rule
;; (defthm insert-of-listsetfix
;;   (equal (listsetfix (insert a x))
;;          (insert (list::fix a)
;;                       (listsetfix x)))
;;   :hints(("Goal" :in-theory (enable listsetfix))))

;; ;; TEMP (jcd) - added this rule
;; (defthm in-of-listsetfix
;;   (equal (in a (listsetfix x))
;;          (not (all<not-inversep<fix>> x a)))
;;   :hints(("Goal" :in-theory (enable listsetfix))))

;; ;; TEMP (jcd) - added this rule
;; (defthm empty-of-listsetfix
;;   (equal (empty (listsetfix x))
;;          (empty x))
;;   :hints(("Goal" :in-theory (enable listsetfix))))

;; And here are the corresponding theorems using Option 3:

;; TEMP (jcd) - added this rule
(defthm insert-of-listsetfix
  (equal (listsetfix (insert a x))
         (if (true-listp a)
             (insert a (listsetfix x))
           (listsetfix x)))
  :hints(("Goal" :in-theory (enable listsetfix))))

;; TEMP (jcd) - added this rule
(defthm in-of-listsetfix
  (equal (in a (listsetfix x))
         (and (in a x)
              (true-listp a)))
  :hints(("Goal" :in-theory (enable listsetfix))))

;; TEMP (jcd) - added this rule
(defthm empty-of-listsetfix
  (equal (empty (listsetfix x))
         (all<not-true-listp> x))
  :hints(("Goal" :in-theory (enable listsetfix))))

;; Here is something we cannot not prove using Option 1 (because it is not
;; true):
;;
;;   (defcong listsetequiv listsetequiv (delete a x) 2)
;;
;; A counterexample is this:
;;
;;   if x = '((1 2 3 . 4)) and y = '((1 2 3)), then (listsetequiv x y) was t but
;;   (delete '(1 2 3) x) = '((1 2 3 . 4)), while (delete '(1 2 3) y) = nil, and
;;   these sets are neither equal nor listsetequiv.
;;
;; Basically the problem was that, since "delete" only compares using "equal",
;; it will only delete some of the lists that might be list::equiv to its
;; argument.  We have similar problems for in, subset, and so forth.  However,
;; with Option 3, we can prove all of the following rules:

(defcong listsetequiv listsetequiv (delete a x) 2
  :hints(("Goal" :in-theory (enable listsetequiv listsetfix))))

(defcong listsetequiv listsetequiv (intersect x y) 1
  :hints(("Goal" :in-theory (enable listsetequiv listsetfix))))

(defcong listsetequiv listsetequiv (intersect x y) 2
  :hints(("Goal" :in-theory (enable listsetequiv listsetfix))))

(defcong listsetequiv listsetequiv (difference x y) 1
  :hints(("Goal" :in-theory (enable listsetequiv listsetfix))))

(defcong listsetequiv listsetequiv (difference x y) 2
  :hints(("Goal" :in-theory (enable listsetequiv listsetfix))))

;; TEMP (jcd) - this rule is not necessary, we already know that union is
;; commutative with respect to equal
;;
;; (defthm listsetequiv-union-of-union
;;   (listsetequiv (union x (union y z))
;;                (union y (union x z)))
;;   :hints(("Goal" :in-theory (enable union))))

;; TEMP (jcd) - this rule is not necessary, we already know that union is
;; symmetric with respect to equal
;;
;; (defthm listsetequiv-union-x-y
;;   (listsetequiv (union x y)
;;                (union y x)))

;; TEMP (jcd) - this rule is not necessary, we already know that inserts can be
;; reordered with respect to equal.
;;
;; (defthm listsetequiv-insert-x-insert-y-z
;;   (listsetequiv (insert x (insert y z))
;;                (insert y (insert x z))))

;; TEMP (jcd) - this rule is not necessary, we already know that insert and
;; union can be distributed over one another.  (see union-insert-y)
;;
;; (defthm listsetequiv-union-x-insert-y-z
;;   (listsetequiv (union x (insert y z))
;;                (insert y (union x z))))

;; TEMP (jcd) - this rule is not necessary, we already know this using
;; union-outer-cancel.
;;
;; (defthm listsetequiv-union-x-union-x-y
;;   (listsetequiv (union x (union x y))
;;                (union x y)))

;; TEMP (jcd) - this is similar to map-list<fix>.  We should consider making a
;; macro alias for it, and an untranslate pattern, so that it can have a nicer
;; name.
;;
;; (defun map-list-fix (args)
;;   (declare (type t args))
;;   (if (consp args)
;;       (cons `(list::list-fix ,(car args))
;;             (map-list-fix (cdr args)))
;;     nil))

;; TEMP (jcd) - here was, roughly, the old definition of merge-u2.
;;
;; (defmacro merge-u2 (x y &rest args)
;;   `(mklistset (append (list::list-fix ,x)
;;                     (list::list-fix ,y)
;;                ,@(map-list-fix args))))
;;
;; But now I don't think we need such a function.  In particular, we already
;; have a union function, and given any list of u2's, we should be able to just
;; repeatedly call union on it.  We might still benefit from making union a
;; macro, so that it can take multiple arguments -- in fact, we should surely
;; look into this -- but that should all happen in the set theory library.  So,
;; for now, I am just taking this out.

;; DAG perhaps these could be moved elsewhere in this book?

(defun ordered (a h)
  (or (equal h a)
      (acl2::<< a h)))

(defthmd head-of-insert
  (equal (set::head (set::insert x y))
         (if (set::empty y) x
           (if (ordered x (set::head y)) x
             (set::head y))))
  :otf-flg t
  :hints (("goal" :do-not '(generalize eliminate-destructors)
           :use (:instance SET::INSERT-PRODUCES-SET
                           (acl2::a x)
                           (acl2::x y))
           :expand (set::insert x y)
           :in-theory (e/d (set::head  SET::EMPTY set::sfix)
                           (SET::INSERT-PRODUCES-SET)))
          (and acl2::stable-under-simplificationp
               '(:expand ((SET::SETP (LIST X))
                          (SET::INSERT X NIL))))))

(defthmd tail-of-insert
  (equal (set::tail (set::insert x y))
         (if (set::empty y) (set::emptyset)
           (if (equal x (set::head y)) (set::tail y)
             (if (acl2::<< x (set::head y)) y
               (set::insert x (set::tail y))))))
  :otf-flg t
  :hints (("goal" :do-not '(generalize eliminate-destructors)
           :use (:instance SET::INSERT-PRODUCES-SET
                           (acl2::a x)
                           (acl2::x y))
           :expand (set::insert x y)
           :in-theory (e/d (set::head  set::tail SET::EMPTY set::sfix)
                           (SET::INSERT-PRODUCES-SET)))
          (and acl2::stable-under-simplificationp
               '(:expand ((SET::SETP (LIST X))
                          (SET::INSERT X NIL))))))

;;
;; Here is a rule that I (DAG) find useful in certain situations.
;;

(encapsulate
    ()

  (local (defthm lemma1
           (implies (and (in a x)
                         (in a y)
                         (subset (delete a x)
                                 (delete a y))
                         (in b x))
                    (in b y))))

  (local (defthm lemma2
           (implies (and (in a x)
                         (in a y)
                         (subset (delete a x)
                                 (delete a y)))
                    (subset x y))
           :hints(("Goal" :in-theory (enable subset)))))

  (local (defthm lemma3
           (implies (and (in a x)
                         (in a y)
                         (equal (delete a x)
                                (delete a y)))
                    (equal (equal x y) t))))

  (local (defthm lemma4
           (implies (and (setp x)
                         (setp y))
                    (implies (and (equal (in a x) (in a y))
                                  (equal (delete a x) (delete a y)))
                             (equal (equal x y) t)))
           :hints(("Goal" :cases ((in a x))))))

  (defthmd equal-set-in-reduction
    (implies (and (setp x)
                  (setp y))
             (equal (equal x y)
                    (and (equal (in a x) (in a y))
                         (equal (delete a x) (delete a y)))))
    :hints(("Goal" :in-theory (disable double-containment-expensive))))

  )

(defthm setp-when-listsetp-cheap
  (implies (listsetp x)
           (setp x))
  :rule-classes ((:rewrite :backchain-limit-lst (1)))
  )

(in-theory (disable setp-when-listsetp))
