;在两根曲线的最小间距处画线[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*
                    )

  ;; 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 
                       )
   ;;;; 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.
          (setq bd 
            (distance 
              (setq *mdp1* (vlax-curve-getpointatdist obj1 idx))
              (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))