TheSwamp
Code Red => AutoLISP (Vanilla / Visual) => Topic started by: DEVITG on June 01, 2004, 05:02:49 PM
-
I had seen this topic before , but I can not find it.
How can I draw a line from a point perpendicular to a line .
all in Lisp.
pseudocode
select the line by ENTSEL
select the point by GETPOINT
draw a line from point to line perpendicular to the line selected
Thanks in advance.
-
(Defun C:PERPL (/ SA SB SNP OM OS PT1 PT2)
;draws lines perpendicular from a starting point
(setvar "cmdecho" 0)
(setq
SA (getvar "snapang")
SB (getvar "snapbase")
SNP (getvar "snapmode")
OM (getvar "orthomode")
OS (getvar "osmode")
PT1 (osnap (getpoint
"\nPick point on line to draw perpendicular from: "
)
"nea"
)
)
(setvar "osmode" 0)
(setq PT2 (osnap PT1 "end"))
(if (equal PT1 PT2)
(setq PT2 (osnap PT1 "MID"))
)
(command ".snap" "r" PT1 PT2)
(setvar "snapmode" 0)
(setvar "orthomode" 1)
(prompt "\nto point:")
(command ".pline" PT1 pause "")
(setvar "snapang" SA)
(setvar "snapbase" SB)
(setvar "snapmode" SNP)
(setvar "orthomode" OM)
(setvar "osmode" OS)
(setvar "cmdecho" 1)
(princ)
) ; end perpl.lsp
(c:perpl)
-
Hi Ronjop, it is not what I need
In the drawing I pick for the line , and then pick the point
after it I need to draw , no more mouse movement , a line FROM the point to the line in perperndicular
Like I draw from a point to a OSNAP PER to line.
But no pointer movement
:oops:
-
Devitg,
Here's one that does this.
(defun c:prp2ln (/ ANG INTPT LINE PT1 PT2 PT3 PT4)
(setq old-os (getvar "osmode"))
(setvar "osmode" 0)
(and (setq line (entsel "\nSelect line: "))
(setq line (entget (car line)))
(setq pt1 (cdr (assoc 10 line))
pt2 (cdr (assoc 11 line))
)
(setq pt3 (getpoint "\nSelect point to draw perpendicular from: "))
(setq ang (angle pt1 pt2))
(setq pt4 (polar pt3 (+ ang (/ pi 2)) 1))
(setq intPt (inters pt1 pt2 pt3 pt4 nil))
(command "line" pt3 intPt "")
)
(setvar "osmode" old-os)
(princ)
)
Jeff
-
This too:
(defun c:perLinea
(/ vla-linea punto p1 p2 angulo pPer dist seleccion *osmode)
(setq *osmode (getvar "osmode"))
(setq vla-linea (vlax-ename->vla-object
(car (entsel "\nSelecione línea: "))
)
punto (getpoint "\nSelecione punto para perpendicularidad: ")
p1 (vlax-safearray->list
(vlax-variant-value
(vla-get-startpoint vla-linea)
)
)
p2 (vlax-safearray->list
(vlax-variant-value
(vla-get-endpoint vla-linea)
)
)
angulo (angle p1 p2)
pPer (inters
p1
p2
punto
(polar punto (+ angulo (/ pi 2)) 1)
nil
)
dist (distance punto Pper)
)
(vla-addline
(vla-objectidtoobject
(vla-get-document vla-linea)
(vla-get-ownerid vla-linea)
)
(vlax-3d-point punto)
(vlax-3d-point pPer)
)
(setvar "osmode" 512)
(while (and (setq seleccion (getpoint "\nSeleccione linea: "))
(equal (ssname (ssget seleccion) 0)
(vlax-vla-object->ename vla-linea)
)
)
(vla-addline
(vla-objectidtoobject
(vla-get-document vla-linea)
(vla-get-ownerid vla-linea)
)
(vlax-3d-point seleccion)
(vlax-3d-point
(polar seleccion (+ (angle punto pPer) pi) dist)
)
)
) ;_while
(setvar "osmode" *osmode)
) ;_defun
-
Interesting Jeff... that is just about how I would have done it...
-
Actually, Keith, after I posted that I decided that it would be best to entmake the line, removing the need to store, change, reset the osnaps. So here's my revised code:
(defun c:perp2ln (/ ANG INTPT LINE PT1 PT2 PT3 PT4)
(and (setq line (entsel "\nSelect line: "))
(setq line (entget (car line)))
(setq pt1 (cdr (assoc 10 line))
pt2 (cdr (assoc 11 line))
)
(setq pt3 (getpoint "\nSelect point to draw perpendicular from: "))
(setq ang (angle pt1 pt2))
(setq pt4 (polar pt3 (+ ang (/ pi 2)) 1))
(setq intPt (inters pt1 pt2 pt3 pt4 nil))
(entmake (list '(0 . "LINE")
(cons 10 pt3)
(cons 11 intPt)
)
)
)
(princ)
)
Jeff
-
Thanks all you for your help .
:D :) :lol: :o :wink: :idea: :!:
-
I made this change to draw multiple perpendicular lines to a selected line
;;my OS and #oldos FUNcTIONS
(DEFUN OS (VAL) ; A FUNCTION TO CHANGE OSMODE BY "VAL" AS FOLLOW
(setq oldos (getvar "osmode"))
;;;0 NONe
;;;1 ENDpoint
;;;2 MIDpoint
;;;4 CENter
;;;8 NODe
;;;16 QUAdrant
;;;32 INTersection
;;;64 INSertion
;;;128 PERpendicular
;;;256 TANgent
;;;512 NEArest
;;;1024 QUIck
;;;2048 APParent Intersection
;;;4096 EXTension
;;;8192 PARallel
;; IF VAL = 1+2+4 = 7 IT WIL DO END MID AND CENT
(SETVAR "OSMODE" VAL)
) ;_ END OS FUNCTION
(defun #oldos ( )
(setvar "osmode" oldos)
)
;;**********************************************************
(defun c:prp2ln (/ ANG INTPT LINE PT1 PT2 PT3 PT4)
(setq old-os (getvar "osmode"))
(setvar "osmode" 0)
(and (setq line (entsel "\nSelect line: "))
(setq line (entget (car line)))
(setq pt1 (cdr (assoc 10 line))
pt2 (cdr (assoc 11 line))
)
(os 8)
(WHILE
(OS 8)
(setq pt3 (getpoint "\nSelect point to draw perpendicular from: "))
(setq ang (angle pt1 pt2))
(setq pt4 (polar pt3 (+ ang (/ pi 2)) 1))
(setq intPt (inters pt1 pt2 pt3 pt4 nil))
(os 0)
(command "line" pt3 intPt "")
))
(setvar "osmode" old-os)
(princ)
)
(c:prp2ln)
Add the while to select points until need , and the osmode 8 to osnap on node.
-
I created a similar routine about 6 months ago, but Jeff's
code is much better so I adopted his code for my routine.
I use it to create elevations, drawing lines from points on the
plan view to a base line. I rotate the ucs to each elevation so
i needed to include a correction for that condition.
DEVITG
My routine repeats as yours does. Although if you use the ENTMAKE
you will not need to switch OSMODE on and off.
Here it is.
(defun c:LnRay (/ ang intpt ent p1 p2 p3 p4)
(if (setq ent (entsel "\nSelect base line: "))
(if (= "LINE" (cdr (assoc 0 (setq ent (entget (car ent))))))
(progn
(setq p1 (cdr (assoc 10 ent))
p2 (cdr (assoc 11 ent))
ang (angle p1 p2)
)
(while
(setq p3
(getpoint
"\nSelect point to draw perpendicular from, Enter to quit: "
)
)
(setq p3 (trans p3 1 0)) ; adjust for non-World UCS
(setq p4 (polar p3 (+ ang (/ pi 2)) 100))
(setq intpt (inters p1 p2 p3 p4 nil))
(entmake (list '(0 . "LINE")
(cons 10 p3)
(cons 11 intpt)
)
)
) ; end while
) ; progn
(prompt "\nObject is not a LINE.")
) ; endif
(prompt "\nNothing Selected.")
) ; endif
(princ)
)
(prompt "\nElev Lines loaded, type LnRay to run")
(princ)
-
Hi Cab , would you please , explain the pourpouse of using
(setq p3 (trans p3 1 0)) ; adjust for non-World UCS
:oops:
-
Well I'll try. :)
I use this ^C^Cdview;;tw;-90;;_ucs;w;_ucs;z;90;
to rotate the house plan view so that the right side is at the bottom of the
screen. I then draw the right elevation.
The TRANS function returns the correct coordinates for that UCS. It only comes
into play when then UCS is not World. If you don't rotate the ucs you do not need it.
Here (http://theswamp.org/phpBB2/viewtopic.php?t=592&highlight=trans) is the thread with more info.
-
Here's a more mathematical approach, using a dot product to find the perp point. It has the advantage of working in 3D (which INTERS is a bit picky about).
The parameter r can be used for various information (it's the distance ratio where the perpendicular hits the line).
(defun C:P2LINE (/ dist ent entl p1 p2 p3 np up r)
(and (setq ent (car (entsel "Select line: ")))
(setq entl (entget ent))
(= (cdr (assoc 0 entl)) "LINE")
(setq p1 (trans (cdr (assoc 10 entl)) 0 1)
p2 (trans (cdr (assoc 11 entl)) 0 1)
dist (distance p1 p2)
)
(while (setq p3 (getpoint "\nPick a point: "))
(setq r (/ (apply '+ (mapcar (function (lambda (a b c)
(* (- c a) (- b a)))) p1 p2 p3))
(expt dist 2.0)
)
np (mapcar (function (lambda (a b) (+ a (* r (- b a))))) p1 p2)
up (trans np 1 0)
)
(entmake (list '(0 . "LINE") (cons 10 (trans p3 1 0))(cons 11 up)))
(mapcar 'princ (list "\nDistance from point to perp of line: "
(rtos (distance p3 np) 2)
"\nPerpendicular point on line (WCS): "
"\nX = " (car up) "\tY = " (cadr up)
"\tZ = " (caddr up)))
(and (= (getvar "WORLDUCS") 0)
(mapcar 'princ (list "\nIn current UCS:\nX = "
(car np) "\tY = " (cadr np) "\tZ = " (caddr np))))
)
)
(princ)
)
-
that's a thing of beauty Stig.
-
You mean it works? Excellent! :)
-
No I meant the code. <g>
-
Stig,
Good point about the 3D aspect, In my old routine I converted to 2D points
but forgot to here. Here is my revised version.
I my testing points p1 & p2 did not need to be transed, not understanding the
entire process I am not sure why. The results were correct so I did not
trans p1 & p2 but I see you did.
Ugh, your math went by me like an express train with no stop here. WTFWT :shock:
CAB
;; this prg draws a vertical line from a picked point
;; to a picked base line
(defun c:LnRay (/ ang intpt ent p1 p2 p3 p4)
;;Make 2D point from 3D point
(defun 3dP->2dP (3dpt)(list (car 3dpt) (cadr 3dpt)))
(if (setq ent (entsel "\nSelect base line: "))
(if (= "LINE" (cdr (assoc 0 (setq ent (entget (car ent))))))
(progn
(setq p1 (3dP->2dP(cdr (assoc 10 ent)))
p2 (3dP->2dP(cdr (assoc 11 ent)))
ang (angle p1 p2)
)
(while
(setq p3
(getpoint
"\nSelect point to draw perpendicular from, Enter to quit: "
)
)
(setq p3 (3dP->2dP(trans p3 1 0))) ; adjust for non-World UCS
(setq p4 (polar p3 (+ ang (/ pi 2)) 100))
(setq intpt (inters p1 p2 p3 p4 nil))
(entmake (list '(0 . "LINE")
(cons 10 p3)
(cons 11 intpt)
)
)
) ; end while
) ; progn
(prompt "\nObject is not a LINE.")
) ; endif
(prompt "\nNothing Selected.")
) ; endif
(princ)
)
(prompt "\nElev Lines loaded, type LnRay to run")
(princ)
-
Heh Mark :D
CAB, you don't need to convert the line's points to UCS because you're converting p3 to WCS where p1 and p2 is also located. I did it the other way 'round .. a bit more work but indifferent to the result.
The math behind it is explained here (http://www.astronomy.swin.edu.au/~pbourke/geometry/pointline/) if you're interested. Not very complicated.
-
CAB, you don't need to convert the line's points to UCS because you're converting
p3 to WCS where p1 and p2 is also located. I did it the other way 'round .. a bit more work but
indifferent to the result.
Thanks for the explanation.
Another nice Link (http://www.astronomy.swin.edu.au/~pbourke/geometry/), thanks.
Not very complicated.
Easy for you to say, I couldn't fix my rubix cube either. :)
-
Hi Stig , it is a good way to learn about lambda and mapcar,
I shall do !!
I will dig on it, to learn about it.
Thanks for it.
:)
-
My pleasure, DEVITG
I guess it's not a bad example for practicing ones MAPCAR skills.
Take for instance the dot product of two vectors: P1 dot P2. It can be written out as (+ (* x1 x2)(* y1 y2)(* z1 z2)), or without having to assign six different variables:
(+ (* (car p1)(car p2))(* (cadr p1)(cadr p2))(* (caddr p1)(caddr p2)))
That's quite a lot to write. Cos' multiplications happen on same level in two point lists, it can more easily be written as (mapcar '* p1 p2). To add all values in the list of products, simply apply an addition:
(apply '+ (mapcar '* p1 p2))
And so, a dot product function was born.
Of course, in the point-to-perpendicular case we needed to substract vectors before multiplying the coordinates. Written in its entirety it would look something like this:
(+ (* (- (car p3) (car p1))(- (car p2) (car p1))) (* (- (cadr p3) (cadr p1))(- (cadr p2) (cadr p1))) (* (- (caddr p3) (caddr p1)) (- (caddr p2) (caddr p1))))
Like with the simple multiplication above, the exact same things happen on each level. Only thing changing is the operator, which means that '(* p1 p2) should be replaced with '(* (- p3 p1)(- p2 p1)).
If one takes to subtract vectors before multiplying them, it could be written with multiple MAPCAR's:
(apply '+ (mapcar '* (mapcar '- p3 p1)(mapcar '- p2 p1)))
Or it could be stuffed into a LAMBDA function, doing it all in one go:
(apply '+ (mapcar '(lambda (a b c)(* (- c a) (- b a))) p1 p2 p3))
-
Say, i have this theory that Mapcar is a recursive function and foreach is actualy the itterative version of mapcar. In fact in an attempt to "prove it" i spent some time rebuilding the "Map" function. *But anyways.... Im babbling now*
Does anyone know if Mapcar is a recrusive function?
-
Here's a take on writing your own MAPCAR function. As you can see it is recursive:
(defun mapIt (fn lst)
(cond ((null lst) nil)
(T (cons (eval (list fn (car lst))) (mapIt fn (cdr lst))))
)
)
(mapit '(lambda (n)(+ n 5)) '(1 2 3))
(6 7 8 )
(mapit (function (lambda (n)(cons n (chr n)))) '(65 66 97))
((65 . "A") (66 . "B") (97 . "a"))
(mapit 'chr '(65 66 97))
("A" "B" "a")
Most of the functions that we take for granted are recursive .. MEMBER, APPEND, ASSOC, SUBST etc. etc.
For example, here's a simple rebuild of ASSOC:
(defun associate (item lst)
(cond ((equal (caar lst) item) (car lst))
(T (associate item (cdr lst)))
)
)
(setq alist '((0 . "A")(1 . "B")(2 . "C")(3 . "D")))
(associate 2 alist)
(2 . "C")
-
In fact in an attempt to "prove it" i spent some time rebuilding the "Map" function.
How much time was it?? :)
-
Outstanding! Stig you are amazing!
Oh not much. I didnt get very far at all, but i did find this. (I dont know it even works or not ...dosent look like it would. :P)
(defun MapItter (pros lst / cntr nlst lstlength)
(setq cntr 0 lstlength (length lst))
(while (< cntr lstlength)
(setq nlst (cons (pros (nth cntr lst)) nlst))
(setq cntr (1+ cntr)))
(reverse nlst)
)
thanx Stig.
-
Mind if I rename it to MapItcher? :)
Well, it works for non-quoted predefined function names - so you can't pass lambda expressions to it.
I would write it with an evaluater, e.g.
(setq nlst (cons (eval (list pros (nth cntr lst))) nlst))
, or
(setq nlst (cons (apply pros (list (nth cntr lst))) nlst))
-
Just an observation.
Most of us think in English or our native language about lisp
but it appears to me that Stig has internalized lisp and now
"Thinks in LISP" :)
-
Beware of the Knights who say "Nil!"
-
(defun Convo2SMadsen ()
(setq res (how are you?))
(cond
((eq (eval res) 'T)
"Good, I'm glad to hear that")
((eq (eval res) 'nil)
"Awe, too bad. Im sorry to hear that."
)
)
)
-
Nil! Nil!
-
What about:
(defun c:perp2ent (/ entity pt)
(while (setq entity (car (entsel "\nSelect entity: ")))
(while
(setq pt (getpoint "\nSelect point to draw perpendicular from: "))
(entmake
(list '(0 . "LINE")
(cons 10 pt)
(cons 11 (vlax-curve-getClosestPointTo entity pt))
) ;_ list
) ;_ entmake
) ;_ while
) ;_ while
(princ)
) ;_ defun
It can get a little bit funky if you try and draw perps to splines or polylines that curve back in on themselves, but otherwise it works.
-
Oh, and if you're past the end of the line/arc/whatever, it draws a line to the nearest endpoint... I guess that's also why it gets funky if the splines/polylines curve back on themselves...
-
Wow that is cool.
I like it.... 8)
CAB
-
Ooops, one problem.
When i use this to rotate my view
^C^Cdview;;tw;90;;_ucs;w;_ucs;z;270;
It doesn't work. But I still like it.
Nice work.
CAB
-
Ok, it was an easy modification.
Works like a dream....
I replaced my old routine with this.
Thanks again.
CAB
;; by sinc @ the Swamp 07/22/2004
;; Repeatedly draws a line from a pick point perpendicular
;; to a selected object
(defun c:perp2ent (/ entity pt)
(while (setq entity (car (entsel "\nSelect entity: ")))
(while
(setq pt (getpoint "\nSelect point to draw perpendicular from: "))
(entmake (list '(0 . "LINE") (cons 10 (trans pt 1 0))
(cons 11 (vlax-curve-getClosestPointTo entity (trans pt 1 0)))) ;_ list
) ;_ entmake
) ;_ while
) ;_ while
(princ)
) ;_ defun
-
I wasn't sure if sinc's routine was useful but I had saved it anyway. Today I'm doing a spiral stair and it is so much more productive than polar array to just divide & pick the perpendicular points.
Thanks Sinc! (and CAB)
Dan
-
I still use that routine today. :-)
-
That routine is sweet :)...here's my addition to CAB's version, inputs lines on same layer as entity picked.
(defun c:perp2ent (/ entity pt lyr)
(while (setq entity (car (entsel "\nSelect entity: ")))
(while
(setq pt (getpoint "\nSelect point to draw perpendicular from: "))
(entmake
(list '(0 . "LINE")
(cons 8 (cdr (assoc 8 (entget entity))))
(cons 10 (trans pt 1 0))
(cons 11
(vlax-curve-getClosestPointTo entity (trans pt 1 0))
)
)
)
)
)
(princ)
)
-
can you add the distance of the point from that selected line.
i want to check how far that point lies from that selected object.
thanks in advance.
-
Welcome to TheSwamp.
Do you need the distance displayed on the command line or added to the drawing?
-
Hi Ronjonp .
Sad to say that if the point is "OUTSIDE" the line , it will draw the line to the end of the start of the lines.
-
Hi Ronjonp .
Sad to say that if the point is "OUTSIDE" the line , it will draw the line to the end of the start of the lines.
Not very pretty but this works: 8-)
(defun c:perp2ent (/ entity pt lyr ep sp ppt ang1 ang2 obj)
(while (and (setq entity (car (entsel "\nSelect entity: ")))
(setq obj (vlax-ename->vla-object entity))
)
(while (setq pt (getpoint "\nSelect point to draw perpendicular from: "))
(setq sp (vlax-curve-getstartpoint obj)
ep (vlax-curve-getendpoint obj)
ppt (vlax-curve-getclosestpointto entity (trans pt 1 0))
ang1 (angle (vlax-curve-getpointatparam
obj
(+ (vlax-curve-getparamatpoint obj sp) 0.01)
)
sp
)
ang2 (angle (vlax-curve-getpointatparam
obj
(* (vlax-curve-getparamatpoint obj ep) 0.99)
)
ep
)
)
(cond ((equal ppt sp 0.0001)
(setq ppt (inters sp
(polar sp ang1 0.01)
pt
(polar pt (+ ang1 (/ pi 2.)) 0.01)
onseg
)
)
(if (= (vla-get-objectname obj) "AcDbLine")
(vlax-put obj 'startpoint ppt)
)
)
((equal ppt ep 0.0001)
(setq ppt (inters ep
(polar ep ang2 0.01)
pt
(polar pt (+ ang2 (/ pi 2.)) 0.01)
onseg
)
)
(if (= (vla-get-objectname obj) "AcDbLine")
(vlax-put obj 'endpoint ppt)
)
)
)
(entmake (list '(0 . "LINE")
(cons 8 (cdr (assoc 8 (entget entity))))
(cons 10 (trans pt 1 0))
(cons 11 ppt)
)
)
)
)
(princ)
)
-
If work is pretty.
I did not notice that I 'm the original poster , about 4 years ago.
Thanks
-
Welcome to TheSwamp.
Do you need the distance displayed on the command line or added to the drawing?
thanks for your reply admin. i wanted like this one
X cordinate of the point (Northing)
---------------------------------- distance between point and that line (may be polyline or something)
Y co-ordinate of the point (Easting)
like
N-1000.000
----------- 23.52m
E-2000.000
i think if the distance added to drawing will be better.
i use this type of command in our highway design works. if you have time, please try to update the code.
thanks again.
thanks.
-
Kan this be changed so that I can enter a fixed line length.
Kan man das so ändern, das ich eine fixe Linienlänge eingeben kann.
Danke
-
Here you go Hugo :). You can enter a fixed leg length or hit enter to work as before. Just did a re-write because the other version embarrassed me :-D
(defun c:perp2ent (/ ang e ep len onseg p perp ppt pt sp x)
(while
(and (setq e (car (entsel "\nSelect a line: ")))
(= (cdr (assoc 0 (entget e))) "LINE")
(or (setq len (getdist "\Enter fixed leg length [Enter for none]:")) (setq len 0))
)
(while (setq pt (getpoint "\nPick a point to draw perpendicular line: "))
(setq sp (cdr (assoc 10 (entget e)))
ep (cdr (assoc 11 (entget e)))
ppt (vlax-curve-getclosestpointto e pt)
ang (angle '(0 0) (vlax-curve-getfirstderiv e (vlax-curve-getparamatpoint e ppt)))
perp (+ ang (/ pi 2.))
)
(if
(setq p (car (vl-remove-if-not '(lambda (x) (equal x ppt 0.001)) (list sp ep))))
(progn (setq ppt (inters sp (polar sp ang 0.01) pt (polar pt perp 0.01) onseg))
(entmod (mapcar '(lambda (x)
(cond ((equal x (cons 10 p) 0.001) (cons 10 ppt))
((equal x (cons 11 p) 0.001) (cons 11 ppt))
(x)
)
)
(entget e)
)
)
)
)
(entmake (list '(0 . "LINE")
(cons 8 (cdr (assoc 8 (entget e))))
(if (zerop len)
(cons 10 pt)
(cons 10 (polar ppt (angle ppt pt) len))
)
(cons 11 ppt)
)
)
)
)
(princ)
)
-
Its a shame GrRead doesn't make this a viable solution - nice code Ron, I hacked this a bit :|
(defun c:perp2ent ( / ang e ep len onseg p perp ppt pt sp x )
(vl-load-com)
;; By LISP Guru RonJonP, dynamically tweaked by Mr Lee Mac
(while (and (setq e (car (entsel "\nSelect a line: ")))
(= (cdr (assoc 0 (entget e))) "LINE")
(or (setq len (getdist "\Enter fixed leg length [Enter for none]:")) (setq len 0)))
(while (and (vl-position (car (setq gr (grread 't 13 0))) '( 5 3 )) (listp (setq pt (cadr gr))))
(redraw)
(if (= 5 (car gr))
(progn
(setq sp (cdr (assoc 10 (entget e))) ep (cdr (assoc 11 (entget e)))
ppt (vlax-curve-getclosestpointto e pt)
ang (angle '(0. 0.) (vlax-curve-getfirstderiv e (vlax-curve-getparamatpoint e ppt)))
perp (+ ang (/ pi 2.)))
(if (setq p (car (vl-remove-if-not (function (lambda (x) (equal x ppt 0.001))) (list sp ep))))
(progn
(setq ppt (inters sp (polar sp ang 0.01) pt (polar pt perp 0.01) onseg))
(grdraw ppt (car (vl-sort (list sp ep) '(lambda ( a b ) (< (distance a ppt) (distance b ppt))))) 1 1)
)
)
(grdraw (if (zerop len) pt (polar ppt (angle ppt pt) len)) ppt 1 1)
)
(progn
(setq sp (cdr (assoc 10 (entget e))) ep (cdr (assoc 11 (entget e)))
ppt (vlax-curve-getclosestpointto e pt)
ang (angle '(0. 0.) (vlax-curve-getfirstderiv e (vlax-curve-getparamatpoint e ppt)))
perp (+ ang (/ pi 2.)))
(if (setq p (car (vl-remove-if-not (function (lambda (x) (equal x ppt 0.001))) (list sp ep))))
(progn
(setq ppt (inters sp (polar sp ang 0.01) pt (polar pt perp 0.01) onseg))
(entupd
(cdr
(assoc -1
(entmod
(mapcar
(function
(lambda ( x )
(cond
((equal x (cons 10 p) 0.001) (cons 10 ppt))
((equal x (cons 11 p) 0.001) (cons 11 ppt))
( x )
)
)
)
(entget e)
)
)
)
)
)
)
)
(entmake
(list
(cons 0 "LINE")
(cons 8 (cdr (assoc 8 (entget e))))
(if (zerop len)
(cons 10 pt)
(cons 10 (polar ppt (angle ppt pt) len))
)
(cons 11 ppt)
)
)
)
)
)
(redraw)
)
(princ)
)
-
My humble offering.
(defun c:p2e (/ ang intpt ent p1 p2 p3 p4 len)
;; global *LR_elast*
(defun 3dP->2dP (3dpt)(list (car 3dpt) (cadr 3dpt))) ;Make 2D point from 3D point
(setq len (getdist "\Enter fixed leg length [Enter for none]:"))
(if (or (setq ent (entsel "\nSelect base line: "))
(setq ent *LR_elast*))
(if (= "LINE" (cdr (assoc 0 (setq ent (entget (car ent))))))
(progn
(setq *LR_elast* (list (cdr (assoc -1 ent)) 1)) ; save ename in a list
(setq p1 (3dP->2dP(cdr (assoc 10 ent)))
p2 (3dP->2dP(cdr (assoc 11 ent)))
ang (angle p1 p2)
)
(while (setq p3 (getpoint "\nSelect point to draw perpendicular from, Enter to quit: "))
(setq p3 (3dP->2dP(trans p3 1 0))) ; adjust for non-World UCS
(setq p4 (polar p3 (+ ang (/ pi 2)) 100))
(setq intpt (inters p1 p2 p3 p4 nil))
(if len (setq intpt (polar p3 (angle p3 intpt) len)))
(entmake (list '(0 . "LINE") (cons 10 p3) (cons 11 intpt)))
) ; end while
) ; progn
(prompt "\nObject is not a LINE.")
) ; endif
(prompt "\nNothing Selected.")
) ; endif
(princ)
)
-
Its a shame GrRead doesn't make this a viable solution - nice code Ron, I hacked this a bit :|
.....
Nice mod Lee 8-) and thanks for the praise (although I'm just a hacker ;-)) I've kinda given up on grread until osnaps are a workable option. They do have cool factor though :-)
btw ... it's nice to see you may have joined "the darkside" with your code formatting. :lmao:
-
CAB,
I could not get your code to work correctly?
-
Thanks to all
@ Cab
code is not ok.
Danke an alle
@ cab
code ist nicht ok.
-
Alan is celebrating his birthday, so cut the guy some slack, OK !! :wink:
-
Alan is celebrating his birthday, so cut the guy some slack, OK !! :wink:
OK ..I'll let it slide THIS time :P
-
btw ... it's nice to see you may have joined "the darkside" with your code formatting. :lmao:
Haha - yes, peer pressure got the better of me :wink: :-P I think I actually prefer it now lol
-
Thanks Kerry, works for me but no more time to test it. Maybe tonight.
-
I want to play :)....
(defun c:PTL (/ ent dist pt)
;; Alan J. Thompson, 05.28.10
(while (and (setq ent (car (entsel "\nSelect curve: ")))
(eq "LINE" (cdr (assoc 0 (entget ent))))
(setq dist (cond ((getdist "\nSpecify distance <None>: "))
(0.)
)
)
)
(while (setq pt (getpoint "\nSpecify point for line: "))
(setq pt (trans pt 1 0))
((lambda (pol)
(entmake (list '(0 . "LINE")
(cons 10 pol)
(cons 11
(cond ((zerop dist) pt)
((polar pol (angle pol pt) dist))
)
)
)
)
((lambda (lst / lst)
(if (< (apply (function distance) lst)
(distance pol
(car (setq lst
(vl-sort lst
(function (lambda (a b) (> (distance a pol) (distance b pol))))
)
)
)
)
)
(entmod (mapcar (function (lambda (x)
(if (equal (cdr x) (cadr lst))
(cons (car x) pol)
x
)
)
)
(entget ent)
)
)
)
)
(list (vlax-curve-getEndPoint ent) (vlax-curve-getStartPoint ent))
)
)
(vlax-curve-getClosestPointTo ent pt T)
)
)
)
(princ)
)
-
:lol:
(defun c:test (/ ent)
(if (setq ent (entsel "\nSelect curve: "))
(while (vl-cmdf "_.line" "_per" (cadr ent) PAUSE ""))
)
(princ)
)
-
Well I think Hugo has a nice selection to choose from now :-)
-
Well I think Hugo has a nice selection to choose from now :-)
I hope I didn't step on your toes, Ron. I was just joining in on the fun.
-
Well I think Hugo has a nice selection to choose from now :-)
I hope I didn't step on your toes, Ron. I was just joining in on the fun.
Not at all ... I actually enjoy seeing how other people solve problems :)
-
Well I think Hugo has a nice selection to choose from now :-)
I hope I didn't step on your toes, Ron. I was just joining in on the fun.
Not at all ... I actually enjoy seeing how other people solve problems :)
Good deal. I just didn't want to offend. :)
Just for additional fun, here's one that will fix the line to always display text linetypes readable.
(http://www.theswamp.org/screens/alanjt/ptl.gif)
(defun c:PTL (/ ent dist pt dxf)
;; Alan J. Thompson, 05.28.10
(while (and (setq ent (car (entsel "\nSelect curve: ")))
(eq "LINE" (cdr (assoc 0 (entget ent))))
(setq dist (cond ((getdist "\nSpecify distance <None>: "))
(0.)
)
)
)
(while (setq pt (getpoint "\nSpecify point for line: "))
(setq pt (trans pt 1 0))
((lambda (pol)
((lambda (ang)
(if (and (> ang (* pi 0.5)) (< ang (* pi 1.5)))
(setq dxf '(10 11))
(setq dxf '(11 10))
)
)
(angle pol pt)
)
(entmake (list '(0 . "LINE")
(cons (cadr dxf) pol)
(cons (car dxf)
(cond ((zerop dist) pt)
((polar pol (angle pol pt) dist))
)
)
)
)
((lambda (lst / lst)
(if (< (apply (function distance) lst)
(distance pol
(car (setq lst
(vl-sort lst
(function (lambda (a b) (> (distance a pol) (distance b pol))))
)
)
)
)
)
(entmod (mapcar (function (lambda (x)
(if (equal (cdr x) (cadr lst))
(cons (car x) pol)
x
)
)
)
(entget ent)
)
)
)
)
(list (vlax-curve-getEndPoint ent) (vlax-curve-getStartPoint ent))
)
)
(vlax-curve-getClosestPointTo ent pt T)
)
)
)
(princ)
)
-
Thanks to all of you since the best
Danke an alle, ihr seit die Besten
:-) :-) :-)
-
hi , here based on Alan.J.T codes , I add osnap method and used in block
;;; Draw perpendicular line
;;; Alan J. Thompson, 10.15.09
;;; Edited by GSLS(SS) 2011-03-08
(defun c:Lper (/ foo ss-errexit #Ent #Read pt p0 ang ent blk?)
(defun foo (/ is_go lst mid mod)
(setq pt (osnap (cadr #read)
"_end,_mid,_cen,_nod,_int,_tan,_per,_nea"
)
)
(if pt
(progn
(setq is_go T
lst
'("_end" "_mid" "_cen" "_nod" "_int" "_tan" "_per" "_nea")
)
(while (and is_go lst)
(setq mid (car lst)
lst (cdr lst)
)
(if (equal pt (osnap (cadr #read) mid))
(setq mod mid
is_go nil
)
)
)
(if mod
(osMark (list pt mod (cadr #read)))
)
)
)
(or pt (setq pt (cadr #Read)))
(setq pt (trans pt 1 0))
(setq p0 (vlax-curve-getclosestpointto #Ent pt T))
) ;_Add osmark
;;line-ang
;;by Lee Mac
(defun line-ang (p0 ang / ent #read)
(setq ent
(entget
(entmakex (list (cons 0 "LINE") (cons 10 p0) (cons 11 p0)))
)
)
(while (= 5 (car (setq #Read (grread T 13 0))))
(entupd
(cdr
(assoc
-1
(entmod
(list
(assoc -1 ent)
(cons
11
(trans
(polar
p0
ang
((if (minusp
((lambda (n)
(- (caddr (trans (cadr #read) 1 n))
(caddr (trans p0 1 n))
)
)
(polar '(0. 0. 0.) ang 1.)
)
)
-
+
)
(distance p0 (cadr #read))
)
)
1
0
)
)
)
)
)
)
)
)
)
(defun ss-errexit (msg)
(command)
(command)
(if (or (= msg "Function cancelled")
(= msg "quit / exit abort")
)
(princ msg)
(princ (strcat "\n错误: " msg))
)
(if blk?
(entdel #ent)
)
(clos)
)
(svos)
(setq #Ent (ss-Nentsel "\n选择曲线: ")) ;_support block
(setq blk? (last #Ent)
#Ent (car #Ent)
)
(if (and #ent
(vl-position
(cdr (assoc 0 (entget #Ent)))
'("LWPOLYLINE" "ARC" "LINE" "CIRCLE" "ELLIPSE" "SPLINE")
)
)
(while (and (/= 25 (car (setq #Read (grread T 1 1))))
(/= (car #Read) 11)
(/= (car #Read) 2)
)
(princ "\r选择点: ")
(redraw)
(if (vl-consp (cadr #Read))
(foo)
)
(if p0
(grdraw p0
(trans pt 1 0)
1
) ;_ grdraw
) ;_ if
(if (and (eq 3 (car #Read)) (foo))
(if (not (equal pt p0 1e-6))
(entmake
(list
'(0 . "LINE")
(cons 10
p0
)
(cons 11 pt)
) ;_ list
) ;_ entmake
(progn ;_ the part writen by Lee Mac
(setq ang (+ (xyp-get-AngleAtPoint #Ent p0) _pi2))
(line-ang p0 ang)
)
)
) ;_ if
) ;_ while
) ;_ if
(redraw)
(clos)
(princ)
) ;_ defun
;;;save old sysvar
(defun svos ()
(setq #system# '("OSMODE" "ORTHOMODE" "CLAYER"
"CECOLOR" "PLINEWID" "CELTYPE"
"CMDECHO" "ELEVATION" "PICKSTYLE"
)
#vlale# (mapcar 'getvar #system#)
gsls_olderr *error*
*error* ss-errexit
)
(vla-startundomark
(vla-get-activedocument (vlax-get-acad-object))
)
)
;;;---------------------------------------------------------------------;;;
;;;call old sysvar
(defun clos ()
(vla-EndUndoMark
(vla-get-ActiveDocument (vlax-get-acad-object))
)
(MapCar 'setvar #system# #vlale#)
(setq *error* gsls_olderr)
)
;;; Nentsel
;;; function : to nentsel a entity In situ
;;; arg : string to princ in command-line
;;; return : a list ( ename point is-of-block? )
;;; Note : if the ename is of a block , the routine copy a similar entity , so you must entdel it later
;;; by GSLS(SS)
;;;
(defun ss-Nentsel (msg / en en1 pt mat ins mat ent)
(setq en (Nentsel msg))
(if (= (length en) 4)
(progn
(setq en1 (car en)
pt (cadr en)
mat (caddr en)
ins (last mat)
mat (reverse (cdr (reverse mat)))
mat ((append
(mapcar '(lambda (x y)
(append x (list y))
)
mat
ins
)
'((0. 0. 0. 1.))
)
)
)
(setq ent (entget en1 '("*")))
(setq ent (vl-remove (assoc -1 ent) ent))
(setq en1 (entmakex ent)) ;_make a new similar entity !!!
(if en1
(progn
(setq obj (vlax-ename->vla-object en1))
(vla-TransformBy obj (vlax-tmatrix mat))
(setq en1 (vlax-vla-object->ename obj))
)
)
(list en1 pt T)
)
(append en (list nil))
)
)
;;;by xyp1964
(defun xyp-get-AngleAtPoint (ename point / oname p1 v1 pt-ang)
(setq oname (vlax-ename->vla-object ename))
(setq v1 (vlax-curve-getfirstderiv
oname
(vlax-curve-getparamatpoint oname point)
)
p1 (mapcar '+ point v1)
pt-ang (angle point p1)
)
(vlax-release-object oname)
pt-ang
)
;;;osmark by Evgeniy
(defun osMark (o / s drft osGrv)
(setq s (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE")))
o (cons (trans (car o) 1 3) (cdr o))
)
(setq osGrv (osmode-grvecs-lst
(vla-get-AutoSnapMarkerColor
(setq drft (vla-get-drafting
(vla-get-preferences
(vlax-get-acad-object)
)
)
)
)
(vla-get-AutoSnapMarkerSize drft)
)
)
(grvecs (cdr (assoc (cadr o) osGrv))
(list (list s 0. 0. (caar o))
(list 0. s 0. (cadar o))
(list 0. 0. s (caddar o))
(list 0. 0. 0. 1.)
)
)
)
about osmark you can see here
http://www.theswamp.org/index.php?topic=12813.0