;在两根曲线的最小间距处画线[WG_MinDistLine].lsp
;; By Joe Burke, Charles Alan Butler and VovKa at theswamp.

;; Bug reports may be sent to me (Joe Burke) directly at 
;; lowercase@hawaii.rr.com

;; Version 1.0 - 5/28/2008.
;;  Find the minimum distance between two vlax-curve objects. 
;;  Supported object types: line, circle, arc, ellipse, polyline and spline.
;;  Shortcut: MD

;; Notes version 1.0:
;;  If two lines are parallel they are reported as such.
;;  If the Z values of the two points found are not equal,
;;  report at command line Z1 = x Z2 = x. When the objects
;;  are not coplanar, the apparent minimum distance will 
;;  usually differ from the actual minimum distance.
;;  There's an option to add a line on the current layer
;;  drawn between the two closest points.
;;  The object types selected are reported at the command line.

;;  Version history:

;;  Version 1.2 beta - 5/31/2008
;;   Added the MinDistLine routine. Shortcut: MDL.
;;   Allows the user to place a line between the last two closest points
;;   calculated by MinDist after it ends. This avoids having to choose
;;   whether a line is placed within MinDist itself. The idea is MinDist
;;   is primarily a measuring tool. As such a minimum distance line is
;;   rarely needed. Note, If the line drawn by MDL is off-screen it is 
;;   selected, otherwise not.

;;  Version 1.3 beta - 6/8/2008
;;   Added support for nested objects in blocks and xrefs.
;;   Added MD:GetXrefs, MD:GetObject, MD:UnlockLayers, MD:RelockLayers 
;;   and MD:XMark sub-functions.
;;   The first object selected is highlighted until the the second
;;   object is selected similar to the fillet tool. If the first object
;;   is contained in an xref it is not highlighted. Rather a temporary 
;;   X mark is placed where the object was selected to indicate the
;;   the object is contained in an xref.

;;  Version 1.4 beta - 6/10/2008
;;   Added error checking for non-uniformly scaled blocks.

;;  Version 1.4a - 6/21/2008
;;   Bug fix for 2D (heavy) and 3D polylines.
;;   Bug fix to avoid error if a dimension is selected.
;;   Revised report when the Z values of the two points are not the same.

;;  Version 1.5 beta - 6/30/2008
;;   Added support for object types point, ray and xline.
;;   If a ray or xline is involved the search for closest point along its 
;;   length is limited by the current view. The search extends beyond the
;;   limits of the current view by a factor of approximately two both ways.

;;  Version 1.5a beta - 7/1/2008
;;   Fixed a bug with rays and xlines.
;;   Both MD and MDL now report when both closest points are off screen.
;;   Revised the MDL routine so it will not draw a very short or zero
;;   length line. Added report for this case.
;;   Added miscellaneous error checking.

;;  Version 1.5b beta - 7/2/2008
;;   Enter at select object prompt ends the routine.
;;   Revised the UniformScale sub-routine to allow operation with objects
;;   nested in dimensions. Thanks to Steve Doman.

  ;; Both routines use the following two functions.


  

(defun c:WG_MinDistLine ( / old_cmd doc blocks units obj1 obj2 typ1 typ2 pkpt p2 sc 
					 div d bd len inc idx resdist dellst res1 res2 pts old_ent
					 old_lock_layer
					 interflag z1 z2 diff MD:PointInside
					 MD:Wait MD:NormalAngle MD:ParallelObjects MD:Pick 
					 MD:GetXrefs MD:GetObject 
					 MD:UniformScale MD:XlineOrRay *mdp1* *mdpt* idx1 idx2
					)

  ;; Arguments: 
  ;;  p1 - WCS or UCS point which defines the first corner of area
  ;;  p2 - WCS or UCS point which defines the second corner of area
  ;;  pt - point translated to UCS.
  ;; Returns: T if pt falls within area.
(defun MD:PointInside (p1 p2 pt / xval yval)
	(and 
		pt
		(setq
			pt (trans pt 0 1)
			xval (car pt)
			yval (cadr pt)
		)
		(< (min (car p1) (car p2)) xval (max (car p1) (car p2)))
		(< (min (cadr p1) (cadr p2)) yval (max (cadr p1) (cadr p2)))
	)
) ;end

(defun MD:GetXrefs ( blklst )
	(vl-remove-if-not
		'(lambda(x)(vlax-property-available-p (vlax-ename->vla-object x) 'Path))
		(mai_ssget_2_list blklst)
	)
) ;end

(defun MD:Wait (seconds / stop)
	(setq stop (+ (getvar "DATE") (/ seconds 86400.0)))
	(while (> stop (getvar "DATE"))
		(princ)
	)
) ;end

;; Argument: angle in radians, any number including negative.
;; Returns: normalized angle in radians between zero and (* pi 2)
(defun MD:NormalAngle (a)
	(if (numberp a) (angtof (angtos a 0 14) 0))
) ;end

;; Returns T if two lines, rays or xlines are parallel.
(defun MD:ParallelObjects (obj1 obj2 / ang1 ang2)
	(setq
		ang1 (if (eq "AcDbLine" (vlax-get obj1 'ObjectName))
				(vlax-get obj1 'Angle)
				(angle (vlax-get obj1 'BasePoint) (vlax-get obj1 'SecondPoint))
			)
		ang1 (MD:NormalAngle ang1)
		ang2 (if (eq "AcDbLine" (vlax-get obj2 'ObjectName))
				(vlax-get obj2 'Angle)
				(angle (vlax-get obj2 'BasePoint) (vlax-get obj2 'SecondPoint))
			)
		ang2 (MD:NormalAngle ang2)
	)
	(mai_equal_ang ang1 ang2)
) ;end

(defun MD:Pick (msg / typlst e obj typ scflag)
	(setq typlst
			'(	"AcDbLine" "AcDbArc" "AcDbCircle" "AcDbEllipse" 
				"AcDbPolyline" "AcDb2dPolyline" "AcDb2dVertex"
				"AcDb3dPolyline" "AcDb3dPolylineVertex" "AcDbSpline"
				"AcDbRay" "AcDbXline" "AcDbPoint"
			)
	)
	(setvar "errno" 0)
	(while 
		(or
			(not (setq e (nentselp msg)))
			(not (setq obj (vlax-ename->vla-object (car e))))
			(not (vl-position (setq typ (vlax-get obj 'ObjectName)) typlst))
			(and
				(cadddr e)
				(not (apply 'and (mapcar 'MD:UniformScale (last e))))
				(setq scflag T)
			)
		)
		(cond
			(	(= 52 (getvar "errno")) (exit))
			(	(not e) (princ "\nMissed pick. "))
			(	scflag
				(princ "\n选择的是不等比块, 再选一次. ")
				(setq scflag nil)
			)
			(	typ
				(princ (strcat "\n " (substr typ 5) " 被选择，再选."))
				(setq typ nil)
			)
		)
	)
	
	(if (wcmatch typ "AcDb2dVertex,AcDb3dPolylineVertex")
		(setq
			obj (vlax-ename->vla-object (mai_dxf 330 (car e)))
			typ (vlax-get obj 'ObjectName)
		)
	)

	;; Used to mark xref. Point passed to MD:XMark. 
	;; The variable is local in the main routine.
	(setq pkpt (cadr e))
	(if (= 2 (length e))
		(list obj typ)
		(list obj typ (caddr e) (cadddr e))
	)
) ;end


;; Test for uniformly scaled block reference.
(defun MD:UniformScale (obj / x y z)
	(if (= (type obj) 'ENAME)
		(setq obj (vlax-ename->vla-object obj))
	)
	;; Added 7/2/2008.
	(or (wcmatch (vlax-get obj 'ObjectName) "*Dimension")
		(progn
			(setq
				x (abs (vlax-get obj 'XScaleFactor))
				y (abs (vlax-get obj 'YScaleFactor))
				z (abs (vlax-get obj 'ZScaleFactor))
			)
			(and
				(mai_equal x y)
				(mai_equal y z)
			)
		)
	)
) ;end

;; Argument: a list returned by MD:Pick.
;; Returns: a vla-object. The first object in list if the object is
;; not nested. Otherwise a transformed copy of the object. 
(defun MD:GetObject (lst / blkref blk obj)
	(cond
		;; Object is not nested.
		((= 2 (length lst)) (setq obj (car lst)))
		;; Object is nested in an xref. Copy it within the xref database.
		;; The owner is not specified within the CopyObjects function.
		((setq blkref (car (MD:GetXrefs (last lst))))
			(setq
				blk (vla-item blocks (vlax-get blkref 'Name))
				obj (car (vlax-invoke (vlax-get blk 'XRefDatabase) 'CopyObjects (list (car lst))))
			)
			(vla-transformby obj (vlax-tmatrix (caddr lst)))
			(setq dellst (cons obj dellst))
			;; Grdraw X mark on xref where it was selected
			;; if it is the first object selected.
			(or obj1 (mai_point_draw pkpt 1))
		)
		;; Object is nested in a block reference. 
		;; Copy it from the block and highlight in the main 
		;; routine if it is the first object selected.
		(T
			(setq obj (car (vlax-invoke doc 'CopyObjects (list (car lst)) (vlax-get (vla-get-ActiveLayout doc) 'Block))))
			(vla-transformby obj (vlax-tmatrix (caddr lst)))
			(setq dellst (cons obj dellst))
		)
	)
	obj
) ;end

;; Argument: ray or xline vla-object.
;; Returns: a list of two 3D WCS points beyond where the object
;; intersects the edges of the current view.
;; The base point of a ray may be returned depending on its
;; location relative to the view.
;; Revised 6/30/2008.
(defun MD:XlineOrRay ( obj / basept zval secpt lst p pts p2 d typ 
							expt1 expt2 x 
					)
	;;;; End Sub-functions
	(setq
		basept (trans (vlax-get obj 'BasePoint) 0 1)
		zval (caddr basept)
		secpt (trans (vlax-get obj 'SecondPoint) 0 1)
		typ (vlax-get obj 'ObjectName)
	)
	;; two 2D UCS points
	(or sc (setq sc (mai_get_viewpt)))
	(setq
		d (distance (car sc) (cadr sc))
		sc (mapcar '(lambda (x) (append x (list zval))) sc)
		lst (mai_data_corner2 "pline" (list (car sc) (cadr sc)))
		sc nil
	)

	(foreach x lst
		(and
			(setq p (inters basept secpt (car x) (cadr x) nil))
			(inters basept p (car x) (cadr x))
			(setq pts (cons p pts))
		)
	)

	(cond
		(	(eq "AcDbXline" typ)
			(setq
				expt1 (polar (cadr pts) (angle (cadr pts) (car pts)) (* 2 d))
				expt2 (polar (car pts) (angle (car pts) (cadr pts)) (* 2 d))
				pts (list expt1 expt2)
			)
		)
		;; Revised 6/29/2008
		(	(eq "AcDbRay" typ)
			(setq
				expt1 (car (mai_points_dist2point pts basept))
				expt1 (polar expt1 (angle basept secpt) (* 2 d))
				pts (list basept expt1)
			)
			;; If base point is far away attempt to get a closer point 
			;; by testing for param at point.
			(setq expt2 (polar expt1 (angle secpt basept) (* 5 d)))
			(if (vlax-curve-getparamatpoint obj (trans expt2 1 0))
				(setq pts (list expt2 expt1))
			)
		)         
	)
	;; Trans UCS points to WCS as needed.
	(mapcar '(lambda (x) (trans x 1 0)) pts)
) ;end MD:XlineOrRay

  ;;; END SUB-FUNCTIONS ;;;

  ;;; START MAIN FUNCTION ;;;

	(mini_start nil)
	(mai_last_com "WG_MinDistLine")
	(setq
		doc (vla-get-activedocument (vlax-get-acad-object))
		blocks (vla-get-blocks doc)
		old_lock_layer (mai_unlock_alllayer) ;纪录锁定的层
		units (getvar "lunits")
	)
	; (princ "\nSelect line, circle, arc, ellipse, polyline, spline, point, ray or xline.")
	(if 
		(and
			(setq res1 (MD:Pick "\n选择线、园、椭圆、多段线、条样曲线, 构造线和射线，最近距离第一根线:<退出>"))
			(setq typ1 (cadr res1))
			(princ (substr typ1 5))
			(setq obj1 (MD:GetObject res1))
			(progn
				(setq old_ent (vlax-vla-object->ename obj1))
				(redraw old_ent 3)
				T
			)
			;(not (vla-highlight obj1 acTrue))
			;; Get the screen coordinates here in case
			;; the user pans between select objects.
			(or (not (wcmatch typ1 "AcDbRay,AcDbXline"))
				(setq sc (mai_get_viewpt))
			)
			(setq res2 (MD:Pick "\n选择线、园、椭圆、多段线、条样曲线, 构造线和射线，最近距离第二根线:<退出>"))
			(setq typ2 (cadr res2))
			(princ (substr typ2 5))
			(setq obj2 (MD:GetObject res2))
		)
		(progn
			(cond 
				(	(equal obj1 obj2)
					(princ "\n 两根线相同")
					(setq resdist 0.0 interflag T)
				)
				(	(vlax-invoke obj1 'IntersectWith obj2 acExtendNone)
					(princ "\n 两根线相交")
					(setq resdist 0.0 interflag T)
				)
				(	(= typ1 typ2 "AcDbPoint")
					(setq 
						*mdpt* (vlax-get obj1 'Coordinates)
						*mdp1* (vlax-get obj2 'Coordinates)
						d (distance *mdpt* *mdp1*)
					)
				)
				(	(eq typ1 "AcDbPoint")
					(setq
						*mdpt* (vlax-get obj1 'coordinates)
						*mdp1* (vlax-curve-getclosestpointto obj2 *mdpt*)
						d (distance *mdpt* *mdp1*)
					)
				)
				(	(eq typ2 "AcDbPoint")
					(setq 
						*mdpt* (vlax-get obj2 'Coordinates)
						*mdp1* (vlax-curve-getclosestpointto obj1 *mdpt*)
						d (distance *mdpt* *mdp1*)
					)
				)
				;; Core stuff follows.
				(	T
					(if (wcmatch typ2 "AcDbRay,AcDbXline")
						(mapcar 'set '( obj2 obj1) (list obj1 obj2))
					)
			  
					(if (vlax-curve-getendparam obj1)
						(setq len (vlax-curve-getdistatparam obj1 (vlax-curve-getendparam obj1)))
						;; obj1 is an xline or ray.
						(setq
							pts (md:xlineorray obj1)
							len (distance (car pts) (cadr pts))
							idx1 (vlax-curve-getparamatpoint obj1 (car pts))
							idx2 (vlax-curve-getparamatpoint obj1 (cadr pts))
							idx (if (< idx1 idx2) idx idx2)
						)
					)

					(or idx (setq idx 0))

						;; Number of divisions seems more than sufficient.
					(setq
						div 200
						inc (/ len div)

						;; Check first object for the closest point on second object.
						*mdp1* (vlax-curve-getpointatdist obj1 idx)
						bd (distance *mdp1* (vlax-curve-getclosestpointto obj2 *mdp1*))
					)
					(repeat (1+ div)
						(and
							(setq *mdp1* (vlax-curve-getpointatdist obj1 idx))
							(setq p2 (vlax-curve-getclosestpointto obj2 *mdp1*))
							(setq
								d (distance *mdp1* p2)
								idx (+ idx inc)
							)
							(<= d bd)
							(setq bd d *mdpt* *mdp1*)
						)
					)
					;; Refine the minimum distance as needed. Start with closest
					;; point on first object. Bounce the closest points back and
					;; forth between the two objects until delta distance is less
					;; than the fuzz factor.
					(while 
						(not
							(minusp
								(-	(distance *mdpt* (setq *mdp1* (vlax-curve-getclosestpointto obj2 *mdpt*)))
									(setq d (distance *mdp1* (setq *mdpt* (vlax-curve-getclosestpointto obj1 *mdp1*))))
									mai_toler
								)
							)
						)
					)
				)
			) ;cond

			(if (and d *mdpt* *mdp1*)
				(progn
					(setq resdist d)
					(grdraw (trans *mdpt* 0 1) (trans *mdp1* 0 1) -7 1)
					(and
						(wcmatch typ1 "AcDbLine,AcDbXline,AcDbRay")
						(wcmatch typ2 "AcDbLine,AcDbXline,AcDbRay")
						(MD:ParallelObjects obj1 obj2)
						(princ "\n 两根线平行.")
					)
					;; Check the Z values of the two closest points.
					(setq z1 (caddr *mdpt*) z2 (caddr *mdp1*) diff (abs (- z1 z2)))
					(cond
						(	(mai_equal z1 z2))
						;; Units are scientific, decimal or engineering.
						(	(< units 4)
							(princ (strcat "\n 点的Z轴坐标相差: " (rtos diff units 10)))
						)
						;; The maximum display accuracy of architectural or
						;; fractional units is 0.00196. If diff is less, 
						;; change units to decimal.
						(	(and
								(> units 3)
								(< diff 0.00196)
							)
							(princ (strcat "\n 点的Z轴坐标相差y: " (rtos diff (setvar "lunits" 2) 10)))
							(setvar "lunits" units)
						)
						;; Otherwise display diff in architectural or fractional units.
						(	T
							(princ (strcat "\n 点的Z轴坐标相差: " (rtos diff)))
						)
					) ;cond
				) ;progn
			) ;if
		) ;progn
	) ;if

	(if (and resdist *mdpt* *mdp1*)
		(progn
			(princ (strcat "\n 最小间距: " (rtos resdist)))
			(or interflag
				(progn
					(mai_entmake "line" (list (trans *mdp1* 0 1) (trans *mdpt* 0 1)))
					(sssetfirst nil (ssget "L"))
				)
			)
		)
		(princ "\n 无法计算最小间距。")
	)
	(mai_end)
) ;end MinDistLine
;(defun c:MDL () (c:MinDistLine))
