
;; By Joe Burke

;; Program notes:

;; The routine is similar to the ExpressTools command MSTRETCH which
;; broke when Autodesk changed how the stretch command works in 2006.
;; It attempts to restore similar functionality in versions 2006 and
;; later. It does not work in versions prior to 2006.

;; Allows multiple crossing selections or a single crossing polygon.
;; The selected areas are displayed with magenta shapes.

;; In some cases it's easier to use multiple selections rather
;; than a complex polygon.

;; Like the mstretch command all selections are treated as crossing
;; regardless of window selection left to right or right to left.
;; This does not apply to the remove objects option, which is the
;; same as how the mstretch command worked.

;; Command line prompts:

;; First prompt: First crossing window or CP for crossing polygon:
;; Either pick crossing windows of enter CP. Enter or spacebar to
;; end multiple window selection. Crossing polygon selection, only
;; one is allowed. It ends automatically when the selection is completed.

;; When selection is done the routine may display a message at the
;; command line when multiple selections are involved.
;; "Some vertices may be stretched more than once in overlapping selections."
;; This does not disallow the operation. It's just a warning something
;; unexpected may happen. The mstretch command worked the same way,
;; without the message.

;; Next prompt:
;; Specify an option [Remove objects/Displacement] <Base point>:
;; Picking a point starts the stretch command. R allows remove objects
;; from those currently selected. D allows enter a displacement such as
;; 5,0 to stretch five units along the X axis.

;; Assuming the stretch is interactive, pick base point and next point
;; and there are multiple selections, only the last selection will
;; dynamically stretch. Again, the same as the mstretch command in older
;; ACAD versions. The other selections will stretch afterwards.

;; Version history:

;; Version 1.0 posted at theswamp 2/24/2009.

;; The shortcut is SM.

(defun c:StretchMultiple ( / *error* *acad* doc osm cursize pksty seltyp
							testpt temp p1 p2 p3 p4 pickpts lst ptlst
							rptslst reslst ss lastpt sslst newlst
							zoomflag e testinput input ssall ssxlst
							rdlst remainlst removelst vctr cv x vwpts temppt
							SM:DoubleCross SM:RectanglePts
							SM:GrdrawPts Extents SM:GetScreenCoords
							SM:PointInside SM:CPPointList SM:ZoomPointList
							SM:SelfIntersPoints SM:SSRemoveEnames)

	(vl-load-com)

	;; Next crossing corner: Application ERROR: Console break
	;; can't seem to prevent this if cancel at prompt for selection.
	;; Not fatal.

(defun *error* (msg)
	(cond
		((not msg))
		((wcmatch (strcase msg) "*QUIT*,*CANCEL*,*CONSOLE BREAK*")) ;doesn't help
		(T (princ (strcat "\nError: " msg)))
	)
	(redraw)
	(setvar "cmdecho" 1)
	(setvar "pickstyle" pksty)
	(setvar "osmode" osm)
	(setvar "cursorsize" cursize)
	(foreach msg rdlst (redraw msg 4))
	(vla-EndUndoMark doc)
	;(gc)
	(princ)
) ;end error

;;;; Start sub-functions ;;;;

;; Arguments: selection set and a list of enames.
;; Returns: the selection set with enmes removed,
;; or the original set if none found.
;; Speed tested fast.
(defun SM:SSRemoveEnames (ss lst)
	(setq
		ss (mai_ssget_2_list ss)
		lst (mai_ssget_2_list lst)
	)
	(mai_list_2_ssget (vl-remove-if '(lambda(x)(member x lst)) ss))
) ;end

  ;; Argument: a list of selection sets.
  ;; Returns: T if some ename was selected more than once by different
  ;; selections and those crossing selection areas overlap.
(defun SM:DoubleCross (lst / flag Overlap GetDuplicates TestTwoSelections x i )

	;; Arguments: two crossing type selection sets.
	;; Returns: T if the selection areas overlap.
	(defun Overlap (ss1 ss2 / pts1 pts2)
		(setq
			pts1 (mapcar 'cadr (cdr (last (ssnamex ss1))))
			pts1 (mapcar '(lambda (x) (trans x 0 1)) pts1)
			pts2 (mapcar 'cadr (cdr (last (ssnamex ss2))))
			pts2 (mapcar '(lambda (x) (trans x 0 1)) pts2)
		)
		(or
			(vl-some '(lambda (p) (SM:PointInside (car pts1) (caddr pts1) p)) pts2)
			(vl-some '(lambda (p) (SM:PointInside (car pts2) (caddr pts2) p)) pts1)
			;; This is for case where the selection areas form a cross.
			;; No point of one selection is inside the other.
			;; Test for intersecting diagonals.
			(inters (car pts1) (caddr pts1) (car pts2) (caddr pts2))
		)
	) ;end

	;; Only returns a duplicate once.
	;; IOW, if an item is contained three times the result is
	;; once in the list returned, not two.
	;; (GetDuplicates '(1 1 1 3 4 4 5 1 1 1 6 7)) > (1 4)
	(defun GetDuplicates (lst / nlst dlst)
		(foreach x lst
			(cond
				(	(not (vl-position x nlst))
					(setq nlst (cons x nlst))
				)
				(	(not (vl-position x dlst))
					(setq dlst (cons x dlst))
				)
			)
		)
		(reverse dlst)
	) ;end

	;; Arguments: two selection sets.
	;; Returns: T if the selection areas overlap and both
	;; selections contain a common ename.
	(defun TestTwoSelections (ss1 ss2 / enames)
		(setq
			enames
				(append
					(vl-remove-if 'listp (mapcar 'cadr (ssnamex ss1)))
					(vl-remove-if 'listp (mapcar 'cadr (ssnamex ss2)))
				)
		)
		(and
			(GetDuplicates enames)
			(Overlap ss1 ss2)
		)
	) ;end

	;; Comparing selection sets using the above functions.
	(foreach x lst
		(foreach i (vl-remove x lst)
			(if (TestTwoSelections x i)
				(setq flag T)
			)
		)
	)
	flag
) ;end


;; by Tony Tanzillo
;; Returns the lower left and upper right corners of a point list.
(defun Extents (plist)
	(list
		(apply 'mapcar (cons 'min plist))
		(apply 'mapcar (cons 'max plist))
	)
)

;; Arguments:
;; p1 - point which defines a corner of a rectangular area.
;; p2 - point which defines the other corner.
;; pt - point to test.
;; Returns: T if pt falls within area.
(defun SM:PointInside (p1 p2 pt / x y)
	(and
		(setq x (car pt))
		(setq y (cadr pt))
		(< (min (car p1) (car p2)) x (max (car p1) (car p2)))
		(< (min (cadr p1) (cadr p2)) y (max (cadr p1) (cadr p2)))
	)
) ;end

;; Argument: point list.
;; Returns: the ext variable if zoom happened, otherwise nil.
(defun SM:ZoomPointList (ptlst / sc scp1 scp2 mp p1 p2 ext)
	(setq sc (SM:GetScreenCoords))
	(setq p1 (car sc) p2 (cadr sc))
	(or (vl-every '(lambda (p) (SM:PointInside p1 p2 p)) ptlst)
		(progn
			(setq ext (Extents ptlst))
			(vlax-invoke *acad* 'ZoomWindow
				(trans (car ext) 1 0) (trans (cadr ext) 1 0)
			)
			(vlax-invoke *acad* 'ZoomScaled 0.98 1)
		)
	)
	ext
) ;end

;; Argument: a point list which is treated as a list of connected segments.
;; Like a polyline without arcs.
;; Returns: T if any two non-adjacent segments intersect.
;; Used to test a CP point list.
(defun SM:SelfIntersPoints (ptlst / i p1 p2 p3 p4 lst flag)
	(if (> (length ptlst) 3)
		(progn
		;; Added - testing
			(setq ptlst (append ptlst (list (car ptlst))))

			(while (cdr ptlst)
				(setq
					p1 (car ptlst) p2 (cadr ptlst)
					lst (cons (list p1 p2) lst)
					ptlst (cdr ptlst)
				)
			)
			(setq lst (reverse lst))
			(foreach x lst
				(foreach i (vl-remove x lst)
					(setq
						p1 (car x)
						p2 (cadr x)
						p3 (car i)
						p4 (cadr i)
					)
					(and
						(not (equal p2 p3))
						(not (equal p1 p4))
						(inters p1 p2 p3 p4)
						(setq flag T)
					)
				)
			)
		)
	)
	flag
) ;end

;; Pass two points representing a diagonal.
;; Returns a list of four UCS points.
(defun SM:RectanglePts (p1 p2)
	(list
		p1
		(list (car p2) (cadr p1) '0.0)
		p2
		(list (car p1) (cadr p2) '0.0)
	)
) ;end

;; Arguments: a point list and a color number.
(defun SM:GrdrawPts (plst clr / lst)
	(setq lst (append (cdr plst) (list (car plst))))
	(mapcar
		'(lambda (p1 p2) (grdraw p1 p2 clr -1))
		plst
		lst
	)
)

;; Returns the coordinates of the current view, lower left and upper right.
;; Works in a rotated view. Returns a list of two 2D UCS points.
;; Now returns 3D points... 10/7/2008 for vlisp zoom calls.
(defun SM:GetScreenCoords ( / ViwCen ViwDim ViwSiz VptMin VptMax)
	(setq
		ViwSiz (/ (getvar "VIEWSIZE") 2.0)
		ViwCen (getvar "VIEWCTR")
		ViwDim (list
					(* ViwSiz (apply '/ (getvar "SCREENSIZE")))
					ViwSiz
				)
		VptMin (mapcar '- ViwCen ViwDim)
		VptMax (mapcar '+ ViwCen ViwDim)
	)
	(list (append VptMin '(0.0)) (append VptMax '(0.0)))
) ;end

(defun SM:CPPointList ( / pt data ptlst)
	(if (setq pt (getpoint "\nFirst polygon point: "))
		(progn
			(princ "\nNext point: ")
			(setq ptlst (list pt))
			(while
				(and
					(setq data (grread 5))
					(or (= (car data) 5) ; tracking
						(= (car data) 3) ; pick
					)
				)
				(if (= (car data) 5)
					(progn
						(redraw)
						(SM:GrdrawPts (append ptlst (list (cadr data))) 6)
					)
					(progn
						(setq ptlst (cons (cadr data) ptlst))
						(SM:GrdrawPts ptlst 6)
					)
				)
			) ; while
			(redraw)
			(SM:GrdrawPts ptlst 6)
		)
	)
	ptlst
)

;; Returns nil if either pt1 or pt2 is nil.
;; Tells the calling function to stop calling this function.
;; Otherwise, returns either a list of two points or a list
;; of two points plus a selection set object.
(defun SM:Crossing ( / pt1 pt2 data ss)
	(or testpt
		(princ "\nNext crossing corner: ")
	)
	(while
		(and
			(not pt2)
			(setq data (grread 5))
			(or (= (car data) 5) ;tracking
				(= (car data) 3) ;pick
			)
		)
		;; Fix for redraw selection rectangles when zoom or pan
		;; occur. Added 2/17/2009.
		(or (equal vctr (getvar "viewctr"))
			(progn
				(foreach x rptslst (SM:GrdrawPts x 6))
				(setq vctr (getvar "viewctr"))
			)
		)
		(cond
			;; looks good
			(	testpt
				(setq pt1 testpt testpt nil)
				(initget 32)
				(setq pt2 (getcorner pt1 "\nSecond corner: "))
			)

			(	(and (not pt1) (= (car data) 3))
				(setq pt1 (cadr data))
				(initget 32)
				(setq pt2 (getcorner pt1 "\nSecond corner: "))
			)
			(	(and pt1 (not pt2) (= (car data) 3))
				(setq pt2 (cadr data))
				(redraw)
			)
		)
	) ;while

	;; Interface - return two points even when they don't select objects.
	(if (and pt1 pt2 (setq ss (ssget "_c" pt1 pt2)))
		(list pt1 pt2 ss)
		(list pt1 pt2)
	)
) ;end

	;;;; End sub-functions ;;;;

	;;;; Start main function ;;;;

	(setq *acad* (vlax-get-acad-object))
	(setq doc (vla-get-ActiveDocument *acad*))
	(vla-StartUndoMark doc)

	(setq cursize (getvar "cursorsize"))
	(setvar "cursorsize" 100)

	(setq vctr (getvar "viewctr"))

	;; Groups off.
	(setq pksty (getvar "pickstyle"))
	(setvar "pickstyle" 0)

	;; Testpt doesn't snap as well as getcorner points in SM:Crossing.
	(setq osm (getvar "osmode"))
	(setvar "osmode" 0)

	;; 2006 or later
	(or (>= (atof (getvar "AcadVer")) 16.2)
		(progn
			(princ "AutoCAD 2006 or later required. Exiting... ")
			(exit)
		)
	)

	(sssetfirst nil)

	;; Exit if user hits Enter method.
	(initget "CPolygon")
	(setq testpt (getpoint "\nFirst crossing window or CP for crossing polygon :"))
	(cond
		(	(not testpt) (exit))
		(	(eq testpt "CPolygon")
			(setq seltyp "CPolygon")
		)
		(	T (setq seltyp "Crossing"))
	)

	;; While method. Loop if user hits Enter.
	;(while
	;  (and
	;    (not (initget "CPolygon"))
	;    (not (setq testpt
	;           (getpoint "\nFirst crossing-window or CP for crossing-polygon: ")))
	;  )
	;  (princ "\nPick point or enter CP. ")
	;)
	; (if (eq testpt "CPolygon")
	;   (setq seltyp "CPolygon")
	;   (setq seltyp "Crossing")
	; )

	;; Either crossing or CP selection.
	(if (eq seltyp "Crossing")
		(progn
			(while
				(and
					(setq reslst (SM:Crossing))
					(setq p1 (car reslst))
					(listp p1)
					(setq p2 (cadr reslst))
					(listp p2)
				)
				(and
					(= 3 (length reslst))
					(= (type (caddr reslst)) 'PICKSET)
					(progn
						(setq
							lst (cons reslst lst)
							ss (caddr reslst)
						)
						(foreach e (mai_ssget_2_list ss)
							;; highlight while selecting
							(redraw e 3)
							(or (vl-position e rdlst)
								(setq rdlst (cons e rdlst))
							)
						)
					)
				)
				(setq
					pickpts (cons (list p1 p2) pickpts)
					rptslst (cons (SM:RectanglePts p1 p2) rptslst)
				)
				;; Draw the selection rectangles.
				(foreach p1 rptslst (SM:GrdrawPts p1 6))
			) ;while
			(or lst
				(progn
					(princ "\nNothing selected... exiting. ")
					(exit)
				)
			)
		) ;progn

		;; CROSSING SELECTION DONE

		;; Else CP - maybe loop back to main function rather than exit?
		(progn
			(setq ptlst (SM:CPPointList))
			;; Testing CP point list.
			(cond
				(	(< (length ptlst) 3)
					(princ "\nInvalid selection. ")
					(exit)
				)
				(	(SM:SelfIntersPoints ptlst)
					(princ "\nInvalid point, polygon segments cannot intersect. ")
					(exit)
				)
				(	T
					(setq ss (ssget "cp" ptlst))
					(if ss
						(foreach e (mai_ssget_2_list ss)
							(redraw e 3)
							;; test for vl-position not needed here since only one CP allowed.
							(setq rdlst (cons e rdlst))
						)
						(progn
							(princ "\nNothing selected... exiting. ")
							(exit)
						)
					)
				)
			)
		)
	) ;; end either crossing or CP selection.

	; SELECTIONS DONE

	;; Redraw when selection is done like mstretch.
	(redraw)

	;; Snap needs to be on in case user picks base point.
	(setvar "osmode" osm)

	;; Remove objects option.
	(while
		(or
			(not testinput)
			(and
				(not (eq testinput "Remove"))
				(not (eq testinput "Displacement"))
				(not (listp testinput))
			)
		)
		(initget 128 "Remove Displacement")
		(setq testinput (getpoint "\nSpecify an option [Remove objects/Displacement] <Base point>: "))
		(cond
			(	(eq testinput "Remove")
				(setvar "cmdecho" 0)
				(setq ssall (ssadd))
				(mapcar '(lambda (x) (ssadd x ssall)) rdlst)
				(command "_.select" ssall "_remove" "_auto")
				(setvar "cmdecho" 1)
				(while (> (getvar "cmdactive") 0) (command pause))
				;; seems an error can occur, but I can't reproduce it now.
				;; Later, it can error if there is no previous selection.
				;; But when can that happen other than at launch or open file?
				;(if (ssget "_p")
				(setq ssxlst (ssnamex (ssget "_p")))
				;)
				;; Six is not documented in help under ssnamex.
				(if (vl-every '(lambda (x) (= 6 (car x))) ssxlst)
					(setq remainlst (mapcar 'cadr ssxlst))
					(progn
						(princ "All objects removed... exiting. ")
						(exit)
					)
				)
				(foreach e (mai_ssget_2_list ssall)
					(or (vl-position e remainlst)
						(setq
							removelst (cons e removelst)
							rdlst (vl-remove e rdlst) ;; added 2/20/2009
						)
					)
				)
			)
			(	(eq testinput "Displacement")
				(setq input "_d")
			)
			(	(listp testinput)
				(setq p3 testinput)
				(setq input p3)  ;;; interesting idea??????
			)
			(	T (princ "\nInvalid input. "))
		)
	) ;while
	;; End remove objects option.

	;; These are checks for zoom and DoubleCross selections.
	;; It also removes any objects in ssremove from the
	;; selection sets.
	(cond
		(	(and
				(eq seltyp "Crossing")
				lst
			)
			;; Allow zoom back to last view
			(setq cv (SM:GetScreenCoords))
			;; if zoom occurred, set zoomflag
			(if (SM:ZoomPointList (apply 'append pickpts))
				(setq zoomflag T)
			)
			;; These are the actual selections including anything that was
			;; missed if zoom during selection.
			(foreach x lst
				(setq
					ss nil
					ss (ssget "_c" (car x) (cadr x))
				)
				(if removelst
					(setq ss (SM:SSRemoveEnames ss removelst))
				)
				;; Redraw any items which were missed.
				(foreach e (mai_ssget_2_list ss)
					(redraw e 3)
					(or (vl-position e rdlst)
						(setq rdlst (cons e rdlst))
					)
				)
				(or (zerop (sslength ss))
					(setq
						newlst (cons (list (car x) (cadr x) ss) newlst)
						sslst (cons ss sslst)
					)
				)
			) ;foreach
			(if (SM:DoubleCross sslst)
				;; Changed from alert to command line message 2/17/2009.
				(princ "\nSome vertices may be stretched more than once in overlapping selections.\n")
			)
			;; Zoom back to last view
			(if zoomflag
				(progn
					(vlax-invoke *acad* 'ZoomWindow
					(trans (car cv) 1 0) (trans (cadr cv) 1 0)
					)
					(setq zoomflag nil) ; temp
				)
			)
		)
		(	(and
				(eq seltyp "CPolygon")
				ptlst
			)
			(SM:ZoomPointList ptlst)
		)
	) ;cond

	;; NOW STRETCH ;;

	;; This is needed when the remove option is used because the select command
	;; unhighlights objects which highlighted with (redraw ename 3).
	(if removelst (foreach x rdlst (redraw x 3)))

	(setq newlst (reverse newlst))
	(if (and newlst (eq seltyp "Crossing"))
		(progn
			;; first one which is the last selection
			(setq temp (car newlst))
			(if (and
					(setq p1 (car temp))
					(setq p2 (cadr temp))
					(setq ss (caddr temp))
					;; Double check given error checking above.
					(not (zerop (sslength ss)))
				)
				(progn
					(setvar "cmdecho" 0)
					(if (eq testinput "Remove")
						(progn
							(vl-cmdf "._stretch" ss p1 p2)
							(princ "\nSpecify base point or [Displacement]: ")
							(vl-cmdf "")
						)
						(vl-cmdf "._stretch" ss p1 p2 "")
					)
					(setvar "cmdecho" 1)
					(setvar "osmode" osm)
					(setq lastpt (getvar "lastpoint"))
					(if input
						(command input)
						(command pause)
					)
					;; wondering about this part from before the remove option was available.
					(if (not (equal lastpt (getvar "lastpoint")))
						(progn
							(setq p3 (getvar "lastpoint"))
							(command pause)
							(setvar "osmode" 0)
							(setvar "cmdecho" 0)
							(or (equal p3 (getvar "lastpoint"))
								(setq p4 (getvar "lastpoint"))
							)
						)
						;; Else pause for displacement
						(command pause)
					)
				) ;progn
			) ;if

			(cond
				;; two points picked
				(	(and p3 p4)
					;(print "first cond")
					(setq vwpts (append (apply 'append pickpts) (list p3) (list p4)))
					(SM:ZoomPointList vwpts)
					(foreach x (cdr newlst)
						(and
							(setq p1 (car x))
							(setq p2 (cadr x))
							(setq ss (caddr x))
							(command "._stretch" ss p1 p2 "" p3 p4)
						)
					)
				)
				;; no points picked - reuse displacement input
				(	(and (not p3) (not p4))
					;(print "second cond")
					(setq vwpts (apply 'append pickpts))
					(SM:ZoomPointList vwpts)
					(foreach x (cdr newlst)
						(and
							(setq p1 (car x))
							(setq p2 (cadr x))
							(setq ss (caddr x))
							(command "._stretch" ss p1 p2 "" "d" "")
						)
					)
				)
				;; p3 picked not p4 - <use first point as displacement>:
				(	(and p3 (not p4))
					;(print "third cond")
					(setq vwpts (apply 'append pickpts))  ;;; temppt added
					(setq temppt (polar p3 (angle '(0.0 0.0 0.0) p3) (distance '(0.0 0.0 0.0) p3)))
					(SM:ZoomPointList (cons temppt vwpts))
					(foreach x (cdr newlst)
						(and
							(setq p1 (car x))
							(setq p2 (cadr x))
							(setq ss (caddr x))
							(command "._stretch" ss p1 p2 "" p3 "")
						)
					)
				)
			) ;cond
		) ;progn

		;; Else selection type is CP.
		(if (and
				(eq seltyp "CPolygon")
				(< 2 (length ptlst))
			)
			(progn
				(setq ss (ssget "cp" (reverse ptlst)))
				(if removelst
					(setq ss (SM:SSRemoveEnames ss removelst))
				)
				(command "._stretch" ss "")
				(if input (command input))
				(while (> (getvar "cmdactive") 0) (command pause))
			) ;progn
			; Else
			(if ptlst (princ "\nCrossing polygon must contain three or more points. "))
		)
	) ; end if crossing or CP

	(*error* nil)
)  ;;;; End main function ;;;;

;------------------------------------
;shortcut
; (defun c:SM () (c:StretchMultiple))
;------------------------------------
