0 Members and 1 Guest are viewing this topic.
(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))