Nearest point to a line from a point

[Lee Mac]

how and why (lambda) get its value?

 

The lambda function is passed an argument of -1, this is assigned to the symbol 'r' within the function.

[hanhphuc]

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

 

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

 

 

(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 October 29, 2015 by hanhphuc
image

[marko_ribar]

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)
)

[marko_ribar]

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 November 5, 2015 by marko_ribar

[marko_ribar]

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.

[wimal]

Thanks everybody lots of persons helped me to solve my problem.