Topic: [XDrX-PlugIn(158)] Draw slope lines

[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: [Select]

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