;|
SetFunctions.lsp contains the following functions that
operate on AutoLISP sets, ActiveX sets, or both at the same time.
  SetUnion
  SetSubtract
  SetIntersect
  SetComplement
  SetVisibleOnScreen
  SetCopy
  SetPurge
  Set->VL   (VLA-OBJECT set)
  Set->AL   (AutoLISP set)
  DumpSet

and one command-line command:
  HelpSet


by Bill Gilliss
bill at realerthanreal dot com
Comments and suggestions always welcome.

Major thanks to:
  - Some Buddy for the (sset->vlsset) and (vlsset->sset) functions
      to provide two-way ActiveX-to-AutoLISP set translation

No warranty, either expressed or implied, is made as to the fitness of
this information for any particular purpose.  All materials are to be
considered 'as-is', and use thereof should be considered as at your own
risk.

ver 1.0  11/23/2008 - initial release, autodesk.autocad.customization
ver 1.1  11/25/2008 - ActiveX selection set option
ver 1.2  11/27/2008 - transparent, built-in set conversion (!)
ver 1.3  03/07/2010 - SetVisible rename SetVisibleOnScreen

Comments and suggestions always welcome.

========================================

Notes:

1. ss1, ss2, etc., below indicate symbols assigned to AutoLISP or
   ActiveX sets, or both. Set types may be mixed in one parameter list
   without conversion.

2. Each SetXXX function (except Set->VL) returns a new AutoLISP set
   regardless of the type of the set[s] passed as arguments. Convert
   this to an ActiveX set with Set->VL as necessary.

3. The calling routine is responsible for error-checking the set, or
   list of sets, passed to these routines. Empty sets are accepted.

4. In each SetXXX function a new set is returned; the original set[s]
   are not changed. If the new set has no members, an empty set is
   returned, rather than nil.

5. SetXXX functions may call each other in any order:
   (setq newset (SetComplement (SetUnion (list ss1 ss2 (SetVisibleOnScreen)))))


SetUnion
  - Returns a new AutoLISP set containing the union of the sets in the
      parameter list, i.e., all the elements with no duplicates.
  - Syntax: (setq newset (SetUnion (list ss1 [ss2 ss3 ...])))

SetSubtract
  - Returns a new AutoLISP set containing the result of subtracting
      from the first set the elements of the following set[s].
  - Syntax: (setq newset (SetSubtract (list ss1 [ss2 ss3 ...])))

SetIntersect
  - Returns a new AutoLISP set containing the intersection of the sets
      in the list, i.e., only elements present in every set.
  - Syntax: (setq newset (SetIntersect (list ss1 [ss2 ss3 ...])))

SetComplement
  - Returns a new AutoLISP set containing *all* the entities in the
      current space (MS or layout) of the drawing, regardless of layer
      state or visibility, minus the elements of a specified set.
  - Syntax: (setq newset (SetComplement ss1))

SetVisibleOnScreen
  - Returns a new AutoLISP set containing all *visible* entities in the
      current space (MS or layout), including those on locked layers.
  - Syntax: (setq newset (SetVisibleOnScreen))

SetCopy
  - Returns a new AutoLISP set containing the entities in an existing
      set. Note that the original set is not bound to the new symbol,
      as it would have been with (setq newset ss1).
  - Syntax: (setq newset (SetCopy ss1))

SetPurge
  - Returns a new AutoLISP set minus any entities that no longer exist
      in the drawing.
  - Syntax: (SetPurge ss1), typically (setq ss1 (SetPurge ss1))

Set->VL
  - Accepts a symbol assigned to either type of set, returns an
      ActiveX set.
  - Syntax: (setq newVLset (Set->VL ss1))

Set->AL
  - Accepts a symbol assigned to either type of set, returns an
      AutoLISP set.
  - Syntax: (setq newLISPset (Set->AL ss1))

DumpSet
  - Prints the entities in a set to the text screen by entity type,
      layer, and INSERT name if applicable. Other data can be added as
      needed by the user.
  - Does not return a value.
  - Syntax: (DumpSet ss1)

HelpSet
  - Displays an alert box with syntax for the set functions.

|;

(defun SetUnion (setlist / n ct setname result)
;;by Bill Gilliss
  (setq result (ssadd))
  (setq n 0)
  (while (< n (length setlist))
    (setq ct 0 setname (nth n setlist))
    (if (= (type setname) 'VLA-OBJECT) (setq setname (Set->AL setname)))
    (repeat (sslength setname)
        (ssadd (ssname setname ct) result) (setq ct (1+ ct))
        )
    (setq n (1+ n))
    )
  result
)

(defun SetSubtract (setlist / n ct setname result)
;;by Bill Gilliss
  (setq result (SetCopy (nth 0 setlist)))
  (if (= (type result) 'VLA-OBJECT) (setq result (Set->AL result)))
  (setq n 1)
  (while (< n (length setlist))
    (setq ct 0 setname (nth n setlist))
    (if (= (type setname) 'VLA-OBJECT) (setq setname (Set->AL setname)))
  	(repeat (sslength setname) (ssdel (ssname setname ct) result) (setq ct (1+ ct)))
    (setq n (1+ n))
  )
  result
)

(defun SetIntersect (setlist / n ct setname result origset ent)
;;by Bill Gilliss
  (setq origset (setCopy (nth 0 setlist))) ;returns AutoLISP set
  (setq result origset)
  (setq n 1)
  (while (< n (length setlist))
    (setq ct 0
          result (ssadd)
          setname (nth n setlist)
          )
    (if (= (type setname) 'VLA-OBJECT) (setq setname (Set->AL setname)))
  	(repeat (sslength setname)
  	        (setq ent (ssname setname ct))
  	        (if (ssmemb ent origset)
  	        (ssadd ent result)
  	        )
  	(setq ct (1+ ct))
  	)
  	(if (= 0 (sslength result)) ;;quit on empty set
  	    (setq n (length setlist))
      	(setq origset result)
      	)
    (setq n (1+ n))
    )
  result
)

(defun SetComplement (setname / result)
;;by Bill Gilliss
  (setq result (SetSubtract (list (ssget "X") setname)))
)

(defun SetVisibleOnScreen ( / x y dx dy result *error*)
;;by Bill Gilliss
  (defun *error* ()(command "._ucs" "_p")) ;;expand as needed for your use
  ;; UCS VIEW seems the cleanest way to deal with all possible
  ;; combinations of UCS, WCS, twist, snapang, etc., even if
  ;; there is a screen blink
  (command "._ucs" "_view")
  (setq x (car (getvar "VIEWCTR"))
        y (cadr (getvar "VIEWCTR"))
        dy (/ (getvar "VIEWSIZE") 2.0)
        dx (* dy (/ (car  (getvar "SCREENSIZE"))
                    (cadr (getvar "SCREENSIZE"))
                    1.0))
        result (ssget "C"
                 (list (- x dx) (- y dy)) ;LL
                 (list (+ x dx) (+ y dy)) ;UR
                  )
         )
  (command "._ucs" "_p")
  result
)

(defun SetCopy (setname / n result)
;;by Bill Gilliss
  (if (= (type setname) 'VLA-OBJECT) (setq setname (Set->AL setname)))
  (setq result (ssadd))
  (setq n 0)
  (while (< n (sslength setname))
    (ssadd (ssname setname n) result)
    (setq n (1+ n))
    )
  result
)

(defun SetPurge (setname / n result)
;;by Bill Gilliss
  (if (= (type setname) 'VLA-OBJECT) (setq setname (Set->AL setname)))
  (setq result (ssadd))
  (setq n 0)
  (while (< n (sslength setname))
    (setq en (ssname setname n))
    (if (entupd en) ;;can't update a non-entity
        (ssadd en result)
        )
    (setq n (1+ n))
    )
  result
)

(defun DumpSet (setname / ed space)
;;by Bill Gilliss
  (if (= (type setname) 'VLA-OBJECT) (setq setname (Set->AL setname)))
  (setq n 0)
  (princ "\nEntity               Layer")
  (princ "\n------               -----")
  (while (< n (sslength setname))
    (setq space " ")
      (setq ed (entget (ssname setname n)))
      (princ
        (strcat "\n" (cdr (assoc 0 ed))
                (repeat (max 1 (- 20 (strlen (cdr (assoc 0 ed)))))
                        (setq space (strcat space " "))
                         )
                 (cdr (assoc 8 ed))
                )
              )
      (if (= (cdr (assoc 0 ed)) "INSERT")
          (princ (strcat ", \"" (cdr (assoc 2 ed)) "\""))
          )
      (setq n (1+ n))
     )
  (princ)
)

(defun Set->VL (setname)
;;by Bill Gilliss
  (if (= (type setname) 'PICKSET)
    (sset->vlsset setname)            ;;if AL, new VL set
    (sset->vlsset (SetCopy setname))  ;;if VL, new VL set
  )
)

(defun Set->AL (setname)
;;by Bill Gilliss
  (if (= (type setname) 'VLA-OBJECT)
    (vlsset->sset (vla-get-name setname)) ;;if VL, new AL set
    (SetCopy setname)                     ;;if AL, new AL set
  )
)

;;;=======================================
(defun sset->vlsset  ;;courtesy of Some Buddy
  (argsset / acdoc ssets vlssets assoc_list
              max_vlsset vlsset safe_array index)
  (vl-load-com)

  (setq acdoc (vla-get-activedocument (vlax-get-acad-object)))
  (setq ssets (vla-get-selectionsets acdoc))

  (vlax-for sset ssets
    (if (wcmatch (vla-get-name sset) "*`#VLSSET")
      (setq vlssets (cons (vla-get-name sset) vlssets))
    )
  )

  (foreach element vlssets
    (setq assoc_list
      (cons (cons (atoi element) element) assoc_list)
    )
  )

  (if (zerop (length assoc_list))
    (setq max_vlsset "0#VLSSET")
    (setq max_vlsset
      (cdr
        (car
          (vl-sort
            assoc_list
           '(lambda (x1 x2)(> (car x1) (car x2)))
          )
        )
      )
    )
  )

  (setq vlsset
    (vla-add
      ssets
      (strcat (itoa (1+ (atoi max_vlsset))) "#VLSSET")
    )
  )

  (setq safe_array
    (vlax-make-safearray vlax-vbobject (cons 0 0))
  )

  (setq index 0)
  (repeat (sslength argsset)
    (vlax-safearray-put-element
      safe_array
      0
      (vlax-ename->vla-object (ssname argsset index))
    )
    (vla-additems vlsset safe_array)
    (setq index (1+ index))
  )
  vlsset
)
;;;=======================================

(defun vlsset->sset ;;courtesy of Some Buddy
  (vlsset_name / vlsset sset)
  (vl-load-com)
  (if
    (not
      (vl-catch-all-error-p
        (setq vlsset
          (vl-catch-all-apply
            'vla-item
            (list
              (vla-get-selectionsets
                (vla-get-activedocument
                  (vlax-get-acad-object)
                )
              )
              vlsset_name
            )
          )
        )
      )
    )
    (progn
      (setq sset (ssadd))
      (vlax-for object vlsset
        (ssadd
          (vlax-vla-object->ename object)
          sset
        )
      )
      sset
    )
  )
)
;;;=========================

(defun c:HelpSet ( / alertmsg)
  (setq alertmsg (strcat
    "SetUnion"
    "\n  (setq newset (SetUnion (list ss1 [ss2 ss3 ...])))"
    "\n"

    "\nSetSubtract"
    "\n  (setq newset (SetSubtract (list ss1 [ss2 ss3 ...])))"
    "\n"

    "\nSetIntersect"
    "\n  (setq newset (SetIntersect (list ss1 [ss2 ss3 ...])))"
    "\n"

    "\nSetComplement"
    "\n  (setq newset (SetComplement ss1))"
    "\n"

    "\nSetVisibleOnScreen"
    "\n  (setq newset (SetVisibleOnScreen))"
    "\n"

    "\nSetCopy"
    "\n  (setq newset (SetCopy ss1))"
    "\n"

    "\nSetPurge"
    "\n  (setq newset (SetPurge ss1))"
    "\n"

    "\nSet->VL"
    "\n  (setq newVLset (Set->VL ss1))"
    "\n"

    "\nSet->AL"
    "\n  (setq newALset (Set->AL ss1))"
    "\n"

    "\nDumpSet"
    "\n  (DumpSet ss1)"



    ))
  (alert alertmsg)
)


(princ "\nSetUnion, SetSubtract, SetIntersect, SetComplement, SetCopy,")
(princ "\nSetVisibleOnScreen, SetPurge, Set->VL, Set->AL, and DumpSet loaded.")
(princ "\n   Enter HelpSet to display syntax notes.")
(princ)