Code Red > XDRX-API
[XDrX-PlugIn(158)] Draw slope lines
(1/1)
xdcad:
1.https://www.cadtutor.net/forum/topic/84274-lisp-for-slope-lines/
2.https://www.cadtutor.net/forum/topic/19901-draw-slope-lines
--- Code: ---(defun c:xdtb_slopeline (/ an anbase arc1 bEnd c_pt cir1 cir2 e e1 e2 ept ept1 ept2
even-list even-pair g int1 ints lastent lastents lst m midp
mLn1 mLn2 mLn3 mode n_pt nearpt1 nearpt2 odd-list p1 p2 pnt
pt r1 r2 spt1 spt2 ss temp temp1 top-pts1 vec1 vec2 x
)
(defun _get-perp-point (crv pnt)
(mapcar
'+
pnt
(xdrx-vector-perpvector (xdrx-curve-getfirstderiv e1 pnt))
)
)
(defun _get-point (e pt / p1)
(setq p1 (_get-perp-point e pt))
(if (setq ints (xdrx-entity-intersectwith (list pt p1) e2 1))
(car ints)
)
)
(defun _get-next-circle-inters ()
(if (and
(setq n_pt (cadr (member c_pt even-list)))
(setq int1 (_get-point e1 n_pt))
)
(progn
(setq r2 (distance n_pt int1)
cir2 (xdrx-circle-make int1 r2)
)
(setq lastents (cons cir2 lastents))
(setq ints (xdrx-entity-intersectwith cir1 cir2))
(setq nearpt2 (xdrx-points-nearpt c_pt ints))
)
(progn
(setq bEnd t
m (xdrx-matrix-setmirror (list c_pt midp))
nearpt2 (xdrx-point-transform nearpt1 m)
)
)
)
)
(defun _get-appropriate-angle ()
(setq vec1 (mapcar
'-
nearpt1
midp
)
vec2 (mapcar
'-
nearpt2
midp
)
)
(setq anbase (angle midp c_pt)
an (xdrx-vector-angle vec2 vec1)
)
(if (> an #xd-var-global-slope-Angle)
(progn
(setq p1 (polar midp (+ anbase (/ #xd-var-global-slope-Angle 2.0))
(distance midp c_pt)
)
temp1 (xdrx-entity-intersectwith (list midp p1) cir1 1)
nearpt1 (xdrx-points-nearpt p1 temp1)
)
(if (not bEnd)
(progn
(setq p2 (polar midp (- anbase (/ #xd-var-global-slope-Angle 2.0))
(distance midp c_pt)
)
temp1 (xdrx-entity-intersectwith (list midp p2) cir1 1)
nearpt2 (xdrx-points-nearpt p2 temp1)
)
)
(setq nearpt2 (xdrx-point-transform nearpt1 m))
)
)
)
)
(defun _draw-slope-line ()
(setq g (xdrx-curve-setinterval cir1 nearpt1 nearpt2))
(setq arc1 (xdrx-entity-make g))
(setq mLn1 (xdrx-line-make temp midp)
mLn2 (xdrx-line-make
midp
(xdrx-curve-getstartpoint arc1)
)
mLn3 (xdrx-line-make
(xdrx-curve-getendpoint arc1)
midp
)
)
(xdrx-curve-join (list mLn1 mLn2 arc1 mLn3))
(if (= #xd-var-global-slope-mode "1")
(progn
(xdrx-polyline-setbulgeat
(entlast)
1
#xd-var-global-bulge
)
(xdrx-polyline-setbulgeat
(entlast)
3
#xd-var-global-bulge
)
)
)
)
(defun _draw-slope-1 ()
(xdrx-line-make (car top-pts1) (xdrx-curve-getstartpoint e2))
(setq lastent (entlast)
lastents (cons lastent lastents)
bEnd nil
)
(mapcar
'(lambda (x)
(setq c_pt x)
(if (setq int1 (_get-point e1 c_pt))
(progn
(setq temp int1
midp (xdrx-line-midp c_pt temp)
)
(setq r1 (distance c_pt int1)
cir1 (xdrx-circle-make int1 r1)
)
(setq lastents (cons cir1 lastents))
(if (setq ints (xdrx-entity-intersectwith cir1 lastent))
(progn
(setq nearpt1 (xdrx-points-nearpt c_pt ints))
(setq nearpt2 (_get-next-circle-inters))
(_get-appropriate-angle)
(_draw-slope-line)
(xdrx-entity-delete cir2)
(setq lastent cir1)
)
)
)
)
)
even-list
)
(xdrx-entity-delete lastents)
)
(defun _draw-short-slope-line (lst)
(mapcar
'(lambda (x)
(setq p1 (_get-perp-point e1 x))
(if (setq ints (xdrx-entity-intersectwith (list x p1) e2 1))
(progn
(xdrx-line-make x (xdrx-line-midp x (car ints)))
)
)
)
lst
)
)
(defun _draw-slope-0 ()
(xdrx-line-make (car top-pts1) (xdrx-curve-getstartpoint e2))
(mapcar
'(lambda (x)
(setq p1 (_get-perp-point e1 x))
(if (setq ints (xdrx-entity-intersectwith (list x p1) e2 1))
(progn
(xdrx-line-make x (car ints))
(setq ept x)
)
)
)
(cdr odd-list)
)
(_draw-short-slope-line even-list)
) ; main
(setq #xd-var-global-bulge -0.2 ; BULGE values of arc segments on
; both sides
#xd-var-global-slope-color 8
#xd-var-global-slope-Angle (/ pi 2.25) ; max angle on both sides;
) ; Modify the color index you need
(if (not #xd-var-global-slope-mode)
(setq #xd-var-global-slope-mode "1")
)
(xdrx-begin)
(xdrx-sysvar-push '("RetEntList" 1))
(xd::doc:getdouble (xdrx-string-multilanguage "\n坡线间距"
"\nSlope Line Gap"
) "#xd-var-global-slope-gap" 10.0
)
(xdrx-initget 0 "0 1 2")
(if (setq mode (getkword (xdrx-string-formatex
(xdrx-string-multilanguage "\n坡度线模式[标准(0)/圆弧(1)/模式(2)]<1>" "\nSlope line mode[standard(0)/arc(1)/mode(2)]<%s>")
#xd-var-global-slope-mode
)
)
)
(setq #xd-var-global-slope-mode mode)
)
(xdrx-initget)
(if (and
(setq e1 (car (xdrx-entsel (xdrx-string-multilanguage "\n拾取坡顶线<退出>:" "\nPick top line<Exit>:")
'((0 . "*polyline,line") (-4 . "<not")
(-4 . "&=")
(70 . 1)
(-4 . "not>")
)
)
)
)
(setq e2 (car (xdrx-entsel (xdrx-string-multilanguage "\n拾取坡底线<退出>:" "\nPick down line<Exit>:")
'((0 . "*polyline,line") (-4 . "<not")
(-4 . "&=")
(70 . 1)
(-4 . "not>")
)
)
)
)
)
(progn
(xdrx-setmark)
(setq spt1 (xdrx-curve-getstartpoint e1)
ept1 (xdrx-curve-getendpoint e1)
spt2 (xdrx-curve-getstartpoint e2)
ept2 (xdrx-curve-getendpoint e2)
)
(if (< (distance spt1 ept1) (distance spt1 spt2))
(xdrx-curve-reverse e2)
)
(setq top-pts1 (xdrx-curve-getpointsatdist e1 (/ #xd-var-global-slope-gap
2.0
)
)
even-list (xd::list:even top-pts1)
even-pair (xd::list:snakepair top-pts1)
odd-list (xd::list:odd top-pts1)
)
(cond
((= #xd-var-global-slope-mode "0")
(_draw-slope-0)
)
(t
(_draw-slope-1)
)
)
(setq ss (xdrx-getss))
(xdrx-entity-setcolor ss #xd-var-global-slope-color)
(xdrx_group_make "*" ss)
)
)
(xdrx-sysvar-pop)
(xdrx-end)
(princ)
)
--- End code ---
Navigation
[0] Message Index
Go to full version