LISP for Slope Lines

[greatsyd]

Does anybody have a LISP for creating slope lines / batter lines?

 

Thank you very much!

[SLW210]

I have moved your thread to the AutoLISP, Visual LISP & DCL Forum. Please post in the most appropriate forum.

[fuccaro]

Years ago there were some posts about this. Read here, maybe you can get some help from:

 

[greatsyd]

Thank you!

[XDSoft]

[XDrX-PlugIn(158)] Draw slope lines (theswamp.org)

https://www.theswamp.org/index.php?topic=59524.0

 

 

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

 

=====================

 

The above code uses XDrx API, download link:

 

https://github.com/xdcad/XDrx-API-zip

https://sourceforge.net/projects/xdrx-api-zip/

Dual version link:

https://github.com/xdcad

Edited May 1, 2024 by XDSoft