Jump to content

Nearest point to a line from a point


wimal

Recommended Posts

  • Replies 25
  • Created
  • Last Reply

Top Posters In This Topic

  • samifox

    7

  • Lee Mac

    6

  • wimal

    5

  • marko_ribar

    3

If you wanted to go the vector route:

;; LM:projectpointtoline

;; Project Point onto Line - Lee Mac

;; Projects pt onto the line defined by p1,p2

nice approach Lee ! i like matrix, thanks :thumbsup:

 

my code same david's idea (if line different in elevation, still looks perpendicular on top view but not nearest projection)

 

8JVszTo.png

 


(defun c:perp (/ e 2p ad d p pp) ;perpendicular to line
;hanhphuc 29.10.15 
 (if (and (setq e (car (entsel "\nPick a LINE.. ")))
   (= (cdr (assoc 0 (setq e (entget e)))) "LINE")
   )
   (while (setq p (getpoint "\nSpecify a POINT.. "))
     (setq 2p (mapcar ''((x) (trans (cdr (assoc x e))0 1) ) '(10 11))
    ad (mapcar '(lambda (f) (apply f (mapcar ''((x) (list (car x) (cadr x))) 2p)))
	       '(angle distance))
    d  (vxv (mapcar '- p (car 2p)) (mapcar ''((f) (f (car ad))) (list cos sin)))
    pp (polar (car 2p) (car ad) d)
    )
     (entmakex
(vl-list* '(0 . "LINE")
	  (mapcar '(lambda (a b) (cons a (trans b 1 0)))
		  '(10 11)
		  (list	p
			(list (car pp)(cadr pp)(+ (* (/ (apply '- (mapcar 'last (reverse 2p))) (cadr ad)) d)
				  (caddr (car 2p)))
			       )
			)
		  )
	  )
)
     )
   )
 (princ)
 )

;; Vector Dot Product  -  Lee Mac
;; Args: u,v - vectors in R^n

(defun vxv ( u v )
   (apply '+ (mapcar '* u v))
)


Edited by hanhphuc
image
Link to comment
Share on other sites

alanjt posted one for me at http://forums.augi.com/showthread.php?149591-Perpendicular-2D-snap-to-line&p=1228990&viewfull=1#post1228990

It's been in my Object Snap Cursor Menu ever since. Works great!

; 2D Perpendicular osnap.
; http://forums.augi.com/showthread.php?149591-Perpendicular-2D-snap-to-line&p=1228966#post1228966#16
; alanjt
;Macro ^P(or PPP (load "PPP.lsp"))(PPP);
(defun PPP (/ ent pnt)
 (if (eq (logand 1 (getvar 'cmdactive)) 1)
   (progn
     (while (progn (setvar 'ERRNO 0)
                   (setq ent (car (entsel "\nSelect curve: ")))
                   (cond ((eq (getvar 'ERRNO) 7) (princ "\nMissed, try again."))
                         ((eq (type ent) 'ENAME)
                          (if (vl-catch-all-error-p
                                (vl-catch-all-apply 'vlax-curve-getEndParam (list ent))
                              )
                            (princ "\nInvalid object!")
                          )
                         )
                   )
            )
     )
     (if (and ent
              (setq pnt (vlax-curve-getClosestPointToProjection
                          ent
                          (trans (getvar 'LASTPOINT) 1 0)
                          '(0 0 1)
                        )
              )
         )
       (command "_non" (trans pnt ent 1))
     )
   )
   (alert "** Command must be executed transparently! **")
 )
 (princ)
)

 

tombu, it has nothing to do with perpendicularity - only that's true if curve is in current UCS plane and picked point belong to UCS... And I'd personally wrote that like this :

 

; 2D Perpendicular osnap.
; http://forums.augi.com/showthread.php?149591-Perpendicular-2D-snap-to-line&p=1228966#post1228966#16
; alanjt mod by M.R.
;Macro ^P(or PPP (load "PPP.lsp"))(PPP);
(defun PPP ( / ent pnt )

 (vl-load-com)

 (if (eq (logand 1 (getvar 'cmdactive)) 1)
   (progn
     (while (progn (setvar 'ERRNO 0)
                   (setq ent (car (entsel "\nSelect curve: ")))
                   (cond ((eq (getvar 'ERRNO) 7) (princ "\nMissed, try again."))
                         ((eq (type ent) 'ENAME)
                          (if (vl-catch-all-error-p
                                (vl-catch-all-apply 'vlax-curve-getEndParam (list ent))
                              )
                            (princ "\nInvalid object!")
                          )
                         )
                   )
            )
     )
     (if (and ent
              (setq pnt (vlax-curve-getClosestPointToProjection
                          ent
                          (trans (getvar 'LASTPOINT) 1 0)
                          [highlight](trans '(0.0 0.0 1.0) 1 0 t)[/highlight]
                        )
              )
         )
       (command "_non" (trans pnt [highlight]0[/highlight] 1))
     )
   )
   (alert "** Command must be executed transparently! **")
 )
 (princ)
)

Link to comment
Share on other sites

FWIW. If you're searching for perpendicularity, try this sub function... It satisfies my needs...

 

;; Perpendicular points from point to curve
;; Marko Ribar, d.i.a.

(defun per ( curve pt / unique unit vxv groupbypa foo *ptol* *tol* par k pa fd pp ve pdotl pdotltrim pdotltrimg pdotltrimgn spa epa r rn rtn rtnn )

 (vl-load-com)

 (defun unique ( l ) ;; unique list with *fuzz* equality tolerance
   (or *fuzz* (setq *fuzz* 1e-7))
   (if l (cons (car l) (unique (vl-remove-if '(lambda ( x ) (equal (car l) x *fuzz*)) (cdr l)))))
 )

 (defun unit ( v / d ) ;; unit vector in R^3
   (if (not (equal (setq d (distance '(0.0 0.0 0.0) v)) 0.0 1e-)
     (mapcar '(lambda ( x ) (/ x d)) v)
     nil
   )
 )

 (defun vxv ( u v ) ;; dot product of 2 vectors in R^n
   (apply '+ (mapcar '* u v))
 )

 (defun groupbypa ( l *ptol* *tol* / gr rr f ff ) ;; l = ((number1 point1 parameter1) (number2 point2 parameter2) ... ) ; *ptol* = parameter difference tolerance ; *tol* = equality tolerance
   (while (car l)
     (if (null ff) (setq ff t) (setq ff nil))
     (if (and (cadr l) (> (abs (caar l)) (abs (caadr l)))) (setq f t) (setq f nil))
     (if (and (cadr l) (equal (- (last (cadr l)) (last (car l))) *ptol* *tol*) f)
       (setq gr (cons (car l) gr) ff nil)
       (if f
         (setq gr (cons (car l) gr) gr (reverse gr) rr (cons gr rr) gr nil)
         (if ff
           (setq gr (cons (car l) gr) gr (if (not (null (cadr l))) (cons (cadr l) gr) gr) gr (reverse gr) rr (cons gr rr) gr nil ff t)
           (setq ff t)
         )
       )
     )
     (setq l (cdr l))
   )
   (reverse rr)
 )

 (defun foo ( l spa epa *ptoln* *toln* / k pa fd pp ve pdotl pdotltrim span epan rn ) ;; l = ((number1 point1 parameter1=spa) ... (numbern pointn parametern=epa)) ; spa = start parameter ; epa = end parameter ; *ptoln* = parameter difference tolerance new - smaller value than previous by 0.1 factor ; *toln* = equality tolerance new - smaller value than previous by 0.1 factor
   (if (null rtnn)
     (progn
       (setq k -1)
       (repeat (fix (/ (- epa spa) *ptoln*))
         (setq pa (+ spa (* *ptoln* (setq k (1+ k)))))
         (setq fd (vlax-curve-getfirstderiv curve pa))
         (setq pp (vlax-curve-getpointatparam curve pa))
         (setq ve (mapcar '- pp pt))
         (setq pdotl (cons (list (vxv (unit ve) fd) pp pa) pdotl))
       )
       (setq pdotl (reverse pdotl))
       (if (equal *toln* 1e-14 1e-15)
         (setq rtnn (list (car (vl-sort pdotl '(lambda ( a b ) (< (abs (car a)) (abs (car b))))))))
         (progn
           (setq pdotltrim (vl-remove-if-not '(lambda ( x ) (equal (car x) 0.0 *toln*)) pdotl))
           (setq pdotltrimgn (groupbypa pdotltrim *ptoln* *toln*))
           (if (and pdotltrimgn (eq (length pdotltrimgn) (length (apply 'append pdotltrimgn))))
             (setq rtnn (apply 'append pdotltrimgn))
             (if pdotltrimgn
               (progn
                 (foreach gn pdotltrimgn
                   (setq span (last (car gn)) epan (last (last gn)))
                   (setq rn (foo gn span epan (* *ptoln* 0.1) (* *toln* 0.1)))
                   (setq rtnn (append rtnn rn))
                 )
                 (setq rtnn (unique rtnn))
               )
             )
           )
         )
       )
     )
     rtnn
   )
 )

 (setq *ptol* 1e-2 *tol* 0.1)
 (setq par (vlax-curve-getendparam curve))
 (setq k -1)
 (repeat (fix (/ par *ptol*))
   (setq pa (* *ptol* (setq k (1+ k))))
   (setq fd (vlax-curve-getfirstderiv curve pa))
   (setq pp (vlax-curve-getpointatparam curve pa))
   (setq ve (mapcar '- pp pt))
   (setq pdotl (cons (list (vxv (unit ve) fd) pp pa) pdotl))
 )
 (setq pdotl (reverse pdotl))
 (setq pdotltrim (vl-remove-if-not '(lambda ( x ) (equal (car x) 0.0 0.25)) pdotl))
 (setq pdotltrimg (groupbypa pdotltrim *ptol* *tol*))
 (if (and pdotltrimg (eq (length pdotltrimg) (length (apply 'append pdotltrimg))))
   (setq rtn (apply 'append pdotltrimg))
   (progn
     (foreach g pdotltrimg
       (if (not (eq (length g) 1))
         (progn
           (setq rtnn nil)
           (setq spa (last (car g)) epa (last (last g)))
           (setq r (foo g spa epa (* *ptol* 0.1) (* *tol* 0.1)))
           (setq rtn (cons r rtn))
         )
       )
     )
     (setq rtn (reverse rtn))
     (setq rtn (vl-remove nil rtn))
     (if (and rtn (eq (length rtn) (length (apply 'append rtn))))
       (setq rtn (apply 'append rtn))
     )
   )
 )
 (mapcar 'cadr rtn)
)

Regards, M.R.

Edited by marko_ribar
Link to comment
Share on other sites

I've updated my last posted sub function once more (found some issues... now fixed...)... Although you can turn on 3D OSNAP PER option I doubt you can find all points... I've tested it on one 3d spline example and no matter how much I orbited around I was able to find 5 points, and my sub function have found 8... So it seems that my effort payed off after all...

 

Regards, M.R.

Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • Create New...