Jump to content

Help lisp pick Polyline to angle, dim

iSupporter

By iSupporter
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

iSupporter Rookie

iSupporter

Posted
Posted

Hi, everybody.

I have polyline, I want pick to Start polyline to a polyline with turn angle, dim...

Please help me a lisp to routine.

Please view file attacht.

Thank you very much.

Polyline

11.PNG.17076abb393cfcb57a157d6766d1a584.PNG

 

Result want

1.thumb.PNG.c561a140bc453466a936a73f02abc181.PNG

Hel.dwg

Link to comment
Share on other sites
Emmanuel Delay Proficient

Emmanuel Delay

Posted
Posted

Notice that G3 is not 1 vertex, it's 4 vertices on the same point.  It requires extra code to handle that (which I didn't do).

 

Try my code on my attached dwg, it does more or less what you want.  It needs some more work, really.

(polyline edit the lines, and joint them to a polyline.  Set text justify to middle, change layers)

 

command PTA

  

;; https://www.cadtutor.net/forum/topic/18257-entmake-functions/
(defun drawLine (p1 p2 / exv)
  (entmakex (list (cons 0 "LINE")
                 (cons 10 p1)
                 (cons 11 p2)
                 ))
)

(defun Text (pt hgt str)
 (entmakex (list (cons 0 "TEXT")
                 (cons 10  pt)
                 (cons 40 hgt)
                 (cons 1  str)))
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; this does what 2d-coord->pt-lst does, except every third coordinate is ignored
;; @see http://www.cadtutor.net/forum/showthread.php?104740-Automatic-numbering-in-air-flow-order/page3
(defun 3d-coord->pt-lstrjp (lst / r)
  (while lst (setq r (cons (list (car lst) (cadr lst)) r)) (setq lst (cdddr lst)))
  (reverse r)
)

;;; 2d-coord->pt-lst
;; Converts a 2d coordinates flat list into a 2d point list
;;; (2d-coord->pt-lst '(1.0 2.0 3.0 4.0)) -> ((1.0 2.0) (3.0 4.0))
(defun 2d-coord->pt-lst (lst)
  (if lst
    (cons
      (list (car lst) (cadr lst))
      (2d-coord->pt-lst (cddr lst))
    )
  )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; see if a floating point number is more or less zero
(defun zero (a / near_zero)
  (setq near_zero 0.0000001)
  (if (< (abs a) near_zero)
    T
    nil
  )
)

(defun c:PTA ( / ss pt0 pt1 lst pl pts i ang prev_ang near_zero x_needle prev_needle dst trn skip dir g)
 
  ;; user input
  (setq ss (ssget ":S" '((0 . "LWPOLYLINE,POLYLINE"))))
  (setq pt0 (osnap (getpoint "\nSelect the trunk <osnap on the base of the trunk>: \n") "_end"))
  (setq pt1 (getpoint "\nStart point of the horizontal polyline: "))
 
  ;; settings, feel free to change these values
  (setq text_height 8.0)
  (setq text_offset 12.0)  ;; for the angles
  (setq text_offset2 8.0)  ;; for the distance
  (setq turn_size 15.0)  ;;
 
 
  (setq pl (vlax-ename->vla-object (ssname ss 0)))  
  (setq lst (vlax-get pl 'coordinates))             ;; extract the vertices
  (if (= "AcDb2dPolyline" (vla-get-ObjectName pl))  ;; polyline or 2D polyline ?
    (setq pts (3d-coord->pt-lstrjp lst))
      (setq pts (2d-coord->pt-lst lst))
  )
  (if (< (distance pt0 (last pts)) (distance pt0 (nth 0 pts)) )  ;; user picks which side we start
    (setq pts (reverse pts))
  )
 
  (setq i 0)
  (setq g 0)
  (setq prev_ang 0)
  (setq x_needle 0.0)   ;; this keeps the x value of the horizontal pline.  Including the size of the turn symbols (30 long)
  (setq prev_needle 0.0)
 
  (repeat (- (length pts) 1)
    (setq skip nil)
    (setq ang ( * 180 (/ (angle (nth i pts) (nth (+ i 1) pts)) pi)))
    
    ;; if the turn angle is zero, or the distance is zero we will skip that point
    (if (or (zero (setq trn (- ang prev_ang))) (zero (setq dst (distance (nth i pts) (nth (+ i 1) pts)))))
      (progn
        (setq skip T)
      )
      (progn
        (if (< (- ang prev_ang) 0)
          (progn
            (setq dir "right")            
          )  ;;
          (progn
            (setq dir "left")            
          )
        )    
      )
    )
    
    (setq prev_ang ang)
    (setq x_needle (+ x_needle dst))
    
    ;;(if (= skip nil) (progn
      (if (> i 0) (progn    ;; skip the turn before the first line
        
        (if (= dir "right") (progn    ;; right turn
          (drawLine
            (list (+ (nth 0 pt1) prev_needle)    (nth 1 pt1))
            (list (+ (+ (nth 0 pt1) prev_needle) turn_size)    (+ (nth 1 pt1) turn_size ))
          )
          (drawLine
            (list (+ (+ (nth 0 pt1) prev_needle) turn_size)    (+ (nth 1 pt1) turn_size ))
            (list (+ (+ (nth 0 pt1) prev_needle) (* 2.0 turn_size))    (nth 1 pt1) )
          )
          (setq g (+ g 1))
          (Text
            (list (+ (+ (nth 0 pt1) prev_needle) turn_size)    (- (nth 1 pt1) text_offset ))
            text_height
            (strcat "G" (itoa g) " = " (rtos trn 2 4))
          )
        )
        (progn                        ;; left turn
          (drawLine
            (list (+ (nth 0 pt1) prev_needle)    (nth 1 pt1))
            (list (+ (+ (nth 0 pt1) prev_needle) turn_size)    (- (nth 1 pt1) turn_size ))
          )
          (drawLine
            (list (+ (+ (nth 0 pt1) prev_needle) turn_size)    (- (nth 1 pt1) turn_size ))
            (list (+ (+ (nth 0 pt1) prev_needle) (* 2.0 turn_size))    (nth 1 pt1) )
          )
          (setq g (+ g 1))
          (Text
            (list (+ (+ (nth 0 pt1) prev_needle) turn_size)    (+ (nth 1 pt1) text_offset ))
            text_height
            (strcat "G" (itoa g) " = " (rtos trn 2 4))
          )
        ))
        (setq prev_needle (+ prev_needle (* 2.0 turn_size)))
      ))
      ;; draw the line
      (drawLine
        (list (+ (nth 0 pt1) prev_needle) (nth 1 pt1))
        (list (+ (nth 0 pt1) x_needle)    (nth 1 pt1))
      )
      
      (Text
        (list (+ (nth 0 pt1) (/ (+ x_needle prev_needle) 2)  )     (+ (nth 1 pt1) text_offset2 ))
        text_height
        (rtos dst 2 2)
      )
      
    ;;))  // skip
    (setq prev_needle x_needle)
    (setq i (+ i 1))
  )
  ;;(princ pt0)
  ;;(princ pts)
  (princ)
)

 

hel2.dwg

Link to comment
Share on other sites
iSupporter Rookie

iSupporter

Posted
  • Author
Posted (edited)
1 hour ago, Emmanuel Delay said:

Notice that G3 is not 1 vertex, it's 4 vertices on the same point.  It requires extra code to handle that (which I didn't do).

 

Try my code on my attached dwg, it does more or less what you want.  It needs some more work, really.

(polyline edit the lines, and joint them to a polyline.  Set text justify to middle, change layers)

 

command PTA

 

  


;; https://www.cadtutor.net/forum/topic/18257-entmake-functions/
(defun drawLine (p1 p2 / exv)
  (entmakex (list (cons 0 "LINE")
                 (cons 10 p1)
                 (cons 11 p2)
                 ))
)

(defun Text (pt hgt str)
 (entmakex (list (cons 0 "TEXT")
                 (cons 10  pt)
                 (cons 40 hgt)
                 (cons 1  str)))
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; this does what 2d-coord->pt-lst does, except every third coordinate is ignored
;; @see http://www.cadtutor.net/forum/showthread.php?104740-Automatic-numbering-in-air-flow-order/page3
(defun 3d-coord->pt-lstrjp (lst / r)
  (while lst (setq r (cons (list (car lst) (cadr lst)) r)) (setq lst (cdddr lst)))
  (reverse r)
)

;;; 2d-coord->pt-lst
;; Converts a 2d coordinates flat list into a 2d point list
;;; (2d-coord->pt-lst '(1.0 2.0 3.0 4.0)) -> ((1.0 2.0) (3.0 4.0))
(defun 2d-coord->pt-lst (lst)
  (if lst
    (cons
      (list (car lst) (cadr lst))
      (2d-coord->pt-lst (cddr lst))
    )
  )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; see if a floating point number is more or less zero
(defun zero (a / near_zero)
  (setq near_zero 0.0000001)
  (if (< (abs a) near_zero)
    T
    nil
  )
)

(defun c:PTA ( / ss pt0 pt1 lst pl pts i ang prev_ang near_zero x_needle prev_needle dst trn skip dir g)
 
  ;; user input
  (setq ss (ssget ":S" '((0 . "LWPOLYLINE,POLYLINE"))))
  (setq pt0 (osnap (getpoint "\nSelect the trunk <osnap on the base of the trunk>: \n") "_end"))
  (setq pt1 (getpoint "\nStart point of the horizontal polyline: "))
 
  ;; settings, feel free to change these values
  (setq text_height 8.0)
  (setq text_offset 12.0)  ;; for the angles
  (setq text_offset2 8.0)  ;; for the distance
  (setq turn_size 15.0)  ;;
 
 
  (setq pl (vlax-ename->vla-object (ssname ss 0)))  
  (setq lst (vlax-get pl 'coordinates))             ;; extract the vertices
  (if (= "AcDb2dPolyline" (vla-get-ObjectName pl))  ;; polyline or 2D polyline ?
    (setq pts (3d-coord->pt-lstrjp lst))
      (setq pts (2d-coord->pt-lst lst))
  )
  (if (< (distance pt0 (last pts)) (distance pt0 (nth 0 pts)) )  ;; user picks which side we start
    (setq pts (reverse pts))
  )
 
  (setq i 0)
  (setq g 0)
  (setq prev_ang 0)
  (setq x_needle 0.0)   ;; this keeps the x value of the horizontal pline.  Including the size of the turn symbols (30 long)
  (setq prev_needle 0.0)
 
  (repeat (- (length pts) 1)
    (setq skip nil)
    (setq ang ( * 180 (/ (angle (nth i pts) (nth (+ i 1) pts)) pi)))
    
    ;; if the turn angle is zero, or the distance is zero we will skip that point
    (if (or (zero (setq trn (- ang prev_ang))) (zero (setq dst (distance (nth i pts) (nth (+ i 1) pts)))))
      (progn
        (setq skip T)
      )
      (progn
        (if (< (- ang prev_ang) 0)
          (progn
            (setq dir "right")            
          )  ;;
          (progn
            (setq dir "left")            
          )
        )    
      )
    )
    
    (setq prev_ang ang)
    (setq x_needle (+ x_needle dst))
    
    ;;(if (= skip nil) (progn
      (if (> i 0) (progn    ;; skip the turn before the first line
        
        (if (= dir "right") (progn    ;; right turn
          (drawLine
            (list (+ (nth 0 pt1) prev_needle)    (nth 1 pt1))
            (list (+ (+ (nth 0 pt1) prev_needle) turn_size)    (+ (nth 1 pt1) turn_size ))
          )
          (drawLine
            (list (+ (+ (nth 0 pt1) prev_needle) turn_size)    (+ (nth 1 pt1) turn_size ))
            (list (+ (+ (nth 0 pt1) prev_needle) (* 2.0 turn_size))    (nth 1 pt1) )
          )
          (setq g (+ g 1))
          (Text
            (list (+ (+ (nth 0 pt1) prev_needle) turn_size)    (- (nth 1 pt1) text_offset ))
            text_height
            (strcat "G" (itoa g) " = " (rtos trn 2 4))
          )
        )
        (progn                        ;; left turn
          (drawLine
            (list (+ (nth 0 pt1) prev_needle)    (nth 1 pt1))
            (list (+ (+ (nth 0 pt1) prev_needle) turn_size)    (- (nth 1 pt1) turn_size ))
          )
          (drawLine
            (list (+ (+ (nth 0 pt1) prev_needle) turn_size)    (- (nth 1 pt1) turn_size ))
            (list (+ (+ (nth 0 pt1) prev_needle) (* 2.0 turn_size))    (nth 1 pt1) )
          )
          (setq g (+ g 1))
          (Text
            (list (+ (+ (nth 0 pt1) prev_needle) turn_size)    (+ (nth 1 pt1) text_offset ))
            text_height
            (strcat "G" (itoa g) " = " (rtos trn 2 4))
          )
        ))
        (setq prev_needle (+ prev_needle (* 2.0 turn_size)))
      ))
      ;; draw the line
      (drawLine
        (list (+ (nth 0 pt1) prev_needle) (nth 1 pt1))
        (list (+ (nth 0 pt1) x_needle)    (nth 1 pt1))
      )
      
      (Text
        (list (+ (nth 0 pt1) (/ (+ x_needle prev_needle) 2)  )     (+ (nth 1 pt1) text_offset2 ))
        text_height
        (rtos dst 2 2)
      )
      
    ;;))  // skip
    (setq prev_needle x_needle)
    (setq i (+ i 1))
  )
  ;;(princ pt0)
  ;;(princ pts)
  (princ)
)

 

 

hel2.dwg 46.67 kB · 0 downloads

 

Thanks Emmanuel Delay

But I run lisp, coordinate is not Dirgree Minute Second

 

Run lisp

g222.PNG.8c1340e006c3ac9657137f25e2553066.PNG

 

Negative value coordinate

negay.thumb.PNG.365876d33079ae72d74907546c3646da.PNG

I want 

 

G22.PNG.68af6adb8dce2d672235cbd0b9d2bc21.PNG

 

Thank you very much.

 

 

Edited by iSupporter
Link to comment
Share on other sites
Emmanuel Delay Proficient

Emmanuel Delay

Posted
Posted (edited)

I rewrote it a little 

(vl-load-com)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; angle to d°m's'

;; round down, see https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/round-up-numbers/td-p/7241378
(defun floor (x / n)
  (if (or (= (setq n (fix x)) x) (< 0 x))
    n
    (1- n)
  )
)

;; Decimal angle to d°m's'
(defun atd  (a / a2 d m s temp temp2)

  (setq a2 (abs a))  ;; we're not interested in the sign here
  
  (setq d (floor a2))
  (setq temp (- a2 d))
  (setq m (floor (* temp 60)))
  (setq temp2 (- temp (/ m 60.0)))
  (setq s (floor (* temp2 3600)))
  (strcat 
    (itoa d) "°" (itoa m) "'" (itoa s) "''"
  )
)
;; test function for ATD
(defun c:atd  ( / myangle)
  (setq myangle 18.711919)
  (setq myangle 10.886712)
  (atd myangle)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; https://www.cadtutor.net/forum/topic/18257-entmake-functions/
(defun Polyline (lst)
 (entmakex (list (cons 0 "POLYLINE")
                 (cons 10 '(0 0 0))))
 (mapcar
   (function (lambda (p)
               (entmake (list (cons 0 "VERTEX") (cons 10 p))))) lst)
  (entmakex (list (cons 0 "SEQEND")))
)

(defun Text (pt hgt str)
 (entmakex (list (cons 0 "TEXT")
                 (cons 10  pt)
                 (cons 40 hgt)
                 (cons 1  str)))
)
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; this does what 2d-coord->pt-lst does, except every third coordinate is ignored
;; @see http://www.cadtutor.net/forum/showthread.php?104740-Automatic-numbering-in-air-flow-order/page3
(defun 3d-coord->pt-lstrjp (lst / r)
  (while lst (setq r (cons (list (car lst) (cadr lst)) r)) (setq lst (cdddr lst)))
  (reverse r)
)

;;; 2d-coord->pt-lst
;; Converts a 2d coordinates flat list into a 2d point list
;;; (2d-coord->pt-lst '(1.0 2.0 3.0 4.0)) -> ((1.0 2.0) (3.0 4.0))
(defun 2d-coord->pt-lst (lst)
  (if lst
    (cons 
	  (list (car lst) (cadr lst))
      (2d-coord->pt-lst (cddr lst))
    )
  )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; skip useless vertices.  
;;    Vertices too close to each other
;;    Vertices that don't make a bend

;; see if a floating point number is more or less zero
(defun zero (a / near_zero)
  (setq near_zero 0.0000001)
  (if (< (abs a) near_zero)
    T
    nil
  )
)

(defun skip_overkill (pts / lst i)
  (setq lst (list))
  (setq i 0)
  (repeat (length pts)
    (if (or 
          (= i 0) 
          (= (- (length pts) 1) i)
        )
      ;; first point or last point
      (progn
        (setq lst (append lst (list (nth i pts))))
      )  
      ;; next points
      (progn
        (if  (zero (distance (nth (- i 1) pts) (nth i pts)))
          ;; skip
          (progn)
          ;; don't skip
          (progn
            (setq lst (append lst (list (nth i pts))))
          )
        )
      )
    )
    (setq i (+ i 1))
  )
  lst
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun distance_and_angles (pts / result i ang prev_ang trn dst)
  (setq i 0)
  (setq result (list))
  (setq prev_ang nil)  
  (setq trn 0)  
  
  (repeat (- (length pts) 1)
    
    (setq ang (angle (nth i pts) (nth (+ i 1) pts)))
    
    (setq dst (distance (nth i pts) (nth (+ i 1) pts)))
    
    (if prev_ang
      (setq trn (- ang prev_ang))
    )
    
    
    (if (> trn pi)
      (setq trn (- (* pi 2) trn))
    )
    (if (< trn (* pi -1))
      (setq trn (- (* pi -2) trn))
    )
    
    (setq result (append result (list
      (list trn (atd (* (/ trn pi) 180 )) dst )
    )))
    
    (setq prev_ang ang)
    (setq i (+ i 1))
  )
  result
)

(defun c:PTA ( / ss pl lst pts pt1 x y turn_size vertices)
  ;; settings, feel free to change these values
  (setq text_height 8.0)
  (setq text_offset 16.0)  ;; for the angles
  (setq text_offset2 6.0)  ;; for the distance
  (setq turn_size 15.0)

  (setq ss (ssget ":S" '((0 . "LWPOLYLINE,POLYLINE"))))
  (setq pt0 (osnap (getpoint "\nSelect the trunk <osnap on the base of the trunk>: \n") "_end"))
  (setq pt1 (getpoint "\nStart point of the horizontal polyline: "))
  (setq x (nth 0 pt1))
  (setq y (nth 1 pt1))

  (setq pl (vlax-ename->vla-object (ssname ss 0)))  
  (setq lst (vlax-get pl 'coordinates))             ;; extract the vertices
  
  (if (= "AcDb2dPolyline" (vla-get-ObjectName pl))  ;; polyline or 2D polyline ?
    (setq pts (3d-coord->pt-lstrjp lst))
	  (setq pts (2d-coord->pt-lst lst))
  )
  
  (if (< (distance pt0 (last pts)) (distance pt0 (nth 0 pts)) )  ;; user picks which side we start
    (setq pts (reverse pts))
  )
  
  (setq pts (skip_overkill pts))
  
  (setq vertices (list (list x y)))
  (setq g 0)
  (foreach itm (distance_and_angles pts)
    
    (if (not (zero (nth 0 itm))) (progn
      (if (< (nth 0 itm) 0) 
        (progn
          (setq vertices (append vertices (list 
            (list (setq x (+ x turn_size)) (+ y turn_size) )
          )))
          (setq vertices (append vertices (list 
            (list (setq x (+ x turn_size)) y )
          )))
          ;; write turn caption
          (setq g (+ g 1))
          (Text 
            (list (- x (* turn_size 2))  (- y text_offset ))
            text_height 
            (strcat "G" (itoa g) " = " (nth 1 itm) )
          )
        )
        (progn
          (setq vertices (append vertices (list 
            (list (setq x (+ x turn_size)) (- y turn_size) )
          )))
          (setq vertices (append vertices (list 
            (list (setq x (+ x turn_size)) y )
          )))
          ;; write turn caption
          (setq g (+ g 1))
          (Text 
            (list (- x (* turn_size 2))  (+ y text_offset ))
            text_height 
            (strcat "G" (itoa g) " = " (nth 1 itm) )
          )
        )
      )
      ;; take back the size of the turn
      (setq x (- x (* turn_size 2)))
    ))
    
    (setq vertices (append vertices (list 
      (list (setq x (+ x (nth 2 itm))) y )
    )))
    (Text 
      (list (- x (/ (nth 2 itm) 2))  (+ y text_offset2 ))
      text_height 
      (rtos (nth 2 itm) 2 2)
    )

  )
  (Polyline vertices)
  (princ)
)
Edited by Emmanuel Delay
Link to comment
Share on other sites
iSupporter Rookie

iSupporter

Posted
  • Author
Posted
On 5/21/2019 at 5:49 PM, Emmanuel Delay said:

I rewrote it a little 


(vl-load-com)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; angle to d°m's'

;; round down, see https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/round-up-numbers/td-p/7241378
(defun floor (x / n)
  (if (or (= (setq n (fix x)) x) (< 0 x))
    n
    (1- n)
  )
)

;; Decimal angle to d°m's'
(defun atd  (a / a2 d m s temp temp2)

  (setq a2 (abs a))  ;; we're not interested in the sign here
  
  (setq d (floor a2))
  (setq temp (- a2 d))
  (setq m (floor (* temp 60)))
  (setq temp2 (- temp (/ m 60.0)))
  (setq s (floor (* temp2 3600)))
  (strcat 
    (itoa d) "°" (itoa m) "'" (itoa s) "''"
  )
)
;; test function for ATD
(defun c:atd  ( / myangle)
  (setq myangle 18.711919)
  (setq myangle 10.886712)
  (atd myangle)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; https://www.cadtutor.net/forum/topic/18257-entmake-functions/
(defun Polyline (lst)
 (entmakex (list (cons 0 "POLYLINE")
                 (cons 10 '(0 0 0))))
 (mapcar
   (function (lambda (p)
               (entmake (list (cons 0 "VERTEX") (cons 10 p))))) lst)
  (entmakex (list (cons 0 "SEQEND")))
)

(defun Text (pt hgt str)
 (entmakex (list (cons 0 "TEXT")
                 (cons 10  pt)
                 (cons 40 hgt)
                 (cons 1  str)))
)
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; this does what 2d-coord->pt-lst does, except every third coordinate is ignored
;; @see http://www.cadtutor.net/forum/showthread.php?104740-Automatic-numbering-in-air-flow-order/page3
(defun 3d-coord->pt-lstrjp (lst / r)
  (while lst (setq r (cons (list (car lst) (cadr lst)) r)) (setq lst (cdddr lst)))
  (reverse r)
)

;;; 2d-coord->pt-lst
;; Converts a 2d coordinates flat list into a 2d point list
;;; (2d-coord->pt-lst '(1.0 2.0 3.0 4.0)) -> ((1.0 2.0) (3.0 4.0))
(defun 2d-coord->pt-lst (lst)
  (if lst
    (cons 
	  (list (car lst) (cadr lst))
      (2d-coord->pt-lst (cddr lst))
    )
  )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; skip useless vertices.  
;;    Vertices too close to each other
;;    Vertices that don't make a bend

;; see if a floating point number is more or less zero
(defun zero (a / near_zero)
  (setq near_zero 0.0000001)
  (if (< (abs a) near_zero)
    T
    nil
  )
)

(defun skip_overkill (pts / lst i)
  (setq lst (list))
  (setq i 0)
  (repeat (length pts)
    (if (or 
          (= i 0) 
          (= (- (length pts) 1) i)
        )
      ;; first point or last point
      (progn
        (setq lst (append lst (list (nth i pts))))
      )  
      ;; next points
      (progn
        (if  (zero (distance (nth (- i 1) pts) (nth i pts)))
          ;; skip
          (progn)
          ;; don't skip
          (progn
            (setq lst (append lst (list (nth i pts))))
          )
        )
      )
    )
    (setq i (+ i 1))
  )
  lst
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun distance_and_angles (pts / result i ang prev_ang trn dst)
  (setq i 0)
  (setq result (list))
  (setq prev_ang nil)  
  (setq trn 0)  
  
  (repeat (- (length pts) 1)
    
    (setq ang (angle (nth i pts) (nth (+ i 1) pts)))
    
    (setq dst (distance (nth i pts) (nth (+ i 1) pts)))
    
    (if prev_ang
      (setq trn (- ang prev_ang))
    )
    
    
    (if (> trn pi)
      (setq trn (- (* pi 2) trn))
    )
    (if (< trn (* pi -1))
      (setq trn (- (* pi -2) trn))
    )
    
    (setq result (append result (list
      (list trn (atd (* (/ trn pi) 180 )) dst )
    )))
    
    (setq prev_ang ang)
    (setq i (+ i 1))
  )
  result
)

(defun c:PTA ( / ss pl lst pts pt1 x y turn_size vertices)
  ;; settings, feel free to change these values
  (setq text_height 8.0)
  (setq text_offset 16.0)  ;; for the angles
  (setq text_offset2 6.0)  ;; for the distance
  (setq turn_size 15.0)

  (setq ss (ssget ":S" '((0 . "LWPOLYLINE,POLYLINE"))))
  (setq pt0 (osnap (getpoint "\nSelect the trunk <osnap on the base of the trunk>: \n") "_end"))
  (setq pt1 (getpoint "\nStart point of the horizontal polyline: "))
  (setq x (nth 0 pt1))
  (setq y (nth 1 pt1))

  (setq pl (vlax-ename->vla-object (ssname ss 0)))  
  (setq lst (vlax-get pl 'coordinates))             ;; extract the vertices
  
  (if (= "AcDb2dPolyline" (vla-get-ObjectName pl))  ;; polyline or 2D polyline ?
    (setq pts (3d-coord->pt-lstrjp lst))
	  (setq pts (2d-coord->pt-lst lst))
  )
  
  (if (< (distance pt0 (last pts)) (distance pt0 (nth 0 pts)) )  ;; user picks which side we start
    (setq pts (reverse pts))
  )
  
  (setq pts (skip_overkill pts))
  
  (setq vertices (list (list x y)))
  (setq g 0)
  (foreach itm (distance_and_angles pts)
    
    (if (not (zero (nth 0 itm))) (progn
      (if (< (nth 0 itm) 0) 
        (progn
          (setq vertices (append vertices (list 
            (list (setq x (+ x turn_size)) (+ y turn_size) )
          )))
          (setq vertices (append vertices (list 
            (list (setq x (+ x turn_size)) y )
          )))
          ;; write turn caption
          (setq g (+ g 1))
          (Text 
            (list (- x (* turn_size 2))  (- y text_offset ))
            text_height 
            (strcat "G" (itoa g) " = " (nth 1 itm) )
          )
        )
        (progn
          (setq vertices (append vertices (list 
            (list (setq x (+ x turn_size)) (- y turn_size) )
          )))
          (setq vertices (append vertices (list 
            (list (setq x (+ x turn_size)) y )
          )))
          ;; write turn caption
          (setq g (+ g 1))
          (Text 
            (list (- x (* turn_size 2))  (+ y text_offset ))
            text_height 
            (strcat "G" (itoa g) " = " (nth 1 itm) )
          )
        )
      )
      ;; take back the size of the turn
      (setq x (- x (* turn_size 2)))
    ))
    
    (setq vertices (append vertices (list 
      (list (setq x (+ x (nth 2 itm))) y )
    )))
    (Text 
      (list (- x (/ (nth 2 itm) 2))  (+ y text_offset2 ))
      text_height 
      (rtos (nth 2 itm) 2 2)
    )

  )
  (Polyline vertices)
  (princ)
)  

Thank Emmanuel Delay very much.

You take some time to help me change layers.

Good luck for Emmanuel Delay!

 

Link to comment
Share on other sites
Emmanuel Delay Proficient

Emmanuel Delay

Posted
Posted

Now it uses your layers 


(vl-load-com)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; angle to d°m's'

;; round down, see https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/round-up-numbers/td-p/7241378
(defun floor (x / n)
  (if (or (= (setq n (fix x)) x) (< 0 x))
    n
    (1- n)
  )
)

;; Decimal angle to d°m's'
(defun atd  (a / a2 d m s temp temp2)

  (setq a2 (abs a))  ;; we're not interested in the sign here
 
  (setq d (floor a2))
  (setq temp (- a2 d))
  (setq m (floor (* temp 60)))
  (setq temp2 (- temp (/ m 60.0)))
  (setq s (floor (* temp2 3600)))
  (strcat
    (itoa d) "°" (itoa m) "'" (itoa s) "''"
  )
)
;; test function for ATD
(defun c:atd  ( / myangle)
  (setq myangle 18.711919)
  (setq myangle 10.886712)
  (atd myangle)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; https://www.cadtutor.net/forum/topic/18257-entmake-functions/
(defun Polyline (lst lay)
 (entmakex (list (cons 0 "POLYLINE")
                 (cons 8 lay)
                 (cons 10 '(0 0 0))))
 (mapcar
   (function (lambda (p)
               (entmake (list (cons 0 "VERTEX") (cons 10 p))))) lst)
  (entmakex (list (cons 0 "SEQEND")))
)

(defun Text (pt hgt str lay)
 (entmakex (list (cons 0 "TEXT")
                 (cons 10  pt)
                 (cons 40 hgt)
                 (cons 8 lay)
                 (cons 1  str)))
)
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; this does what 2d-coord->pt-lst does, except every third coordinate is ignored
;; @see http://www.cadtutor.net/forum/showthread.php?104740-Automatic-numbering-in-air-flow-order/page3
(defun 3d-coord->pt-lstrjp (lst / r)
  (while lst (setq r (cons (list (car lst) (cadr lst)) r)) (setq lst (cdddr lst)))
  (reverse r)
)

;;; 2d-coord->pt-lst
;; Converts a 2d coordinates flat list into a 2d point list
;;; (2d-coord->pt-lst '(1.0 2.0 3.0 4.0)) -> ((1.0 2.0) (3.0 4.0))
(defun 2d-coord->pt-lst (lst)
  (if lst
    (cons
      (list (car lst) (cadr lst))
      (2d-coord->pt-lst (cddr lst))
    )
  )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; skip useless vertices.  
;;    Vertices too close to each other
;;    Vertices that don't make a bend

;; see if a floating point number is more or less zero
(defun zero (a / near_zero)
  (setq near_zero 0.0000001)
  (if (< (abs a) near_zero)
    T
    nil
  )
)

(defun skip_overkill (pts / lst i)
  (setq lst (list))
  (setq i 0)
  (repeat (length pts)
    (if (or
          (= i 0)
          (= (- (length pts) 1) i)
        )
      ;; first point or last point
      (progn
        (setq lst (append lst (list (nth i pts))))
      )  
      ;; next points
      (progn
        (if  (zero (distance (nth (- i 1) pts) (nth i pts)))
          ;; skip
          (progn)
          ;; don't skip
          (progn
            (setq lst (append lst (list (nth i pts))))
          )
        )
      )
    )
    (setq i (+ i 1))
  )
  lst
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun distance_and_angles (pts / result i ang prev_ang trn dst)
  (setq i 0)
  (setq result (list))
  (setq prev_ang nil)  
  (setq trn 0)  
 
  (repeat (- (length pts) 1)
    
    (setq ang (angle (nth i pts) (nth (+ i 1) pts)))
    
    (setq dst (distance (nth i pts) (nth (+ i 1) pts)))
    
    (if prev_ang
      (setq trn (- ang prev_ang))
    )
    
    
    (if (> trn pi)
      (setq trn (- (* pi 2) trn))
    )
    (if (< trn (* pi -1))
      (setq trn (- (* pi -2) trn))
    )
    
    (setq result (append result (list
      (list trn (atd (* (/ trn pi) 180 )) dst )
    )))
    
    (setq prev_ang ang)
    (setq i (+ i 1))
  )
  result
)

(defun c:PTA ( / ss pl lst pts pt1 x y turn_size vertices cur_lay)
  ;; settings, feel free to change these values
  (setq text_height 8.0)
  (setq text_offset 16.0)  ;; for the angles
  (setq text_offset2 6.0)  ;; for the distance
  (setq turn_size 15.0)

  (setq ss (ssget ":S" '((0 . "LWPOLYLINE,POLYLINE"))))
  (setq pt0 (osnap (getpoint "\nSelect the trunk <osnap on the base of the trunk>: \n") "_end"))
  (setq pt1 (getpoint "\nStart point of the horizontal polyline: "))
  (setq x (nth 0 pt1))
  (setq y (nth 1 pt1))

  (setq pl (vlax-ename->vla-object (ssname ss 0)))  
  (setq lst (vlax-get pl 'coordinates))             ;; extract the vertices
 
  (if (= "AcDb2dPolyline" (vla-get-ObjectName pl))  ;; polyline or 2D polyline ?
    (setq pts (3d-coord->pt-lstrjp lst))
      (setq pts (2d-coord->pt-lst lst))
  )
 
  (if (< (distance pt0 (last pts)) (distance pt0 (nth 0 pts)) )  ;; user picks which side we start
    (setq pts (reverse pts))
  )
 
  (setq pts (skip_overkill pts))
 
  (setq vertices (list (list x y)))
  (setq g 0)
  (foreach itm (distance_and_angles pts)
    
    (if (not (zero (nth 0 itm))) (progn
      (if (< (nth 0 itm) 0)
        (progn
          (setq vertices (append vertices (list
            (list (setq x (+ x turn_size)) (+ y turn_size) )
          )))
          (setq vertices (append vertices (list
            (list (setq x (+ x turn_size)) y )
          )))
          ;; write turn caption
          (setq g (+ g 1))
          (Text
            (list (- x (* turn_size 2))  (- y text_offset ))
            text_height
            (strcat "G" (itoa g) " = " (nth 1 itm) )
            "G"
          )
        )
        (progn
          (setq vertices (append vertices (list
            (list (setq x (+ x turn_size)) (- y turn_size) )
          )))
          (setq vertices (append vertices (list
            (list (setq x (+ x turn_size)) y )
          )))
          ;; write turn caption
          (setq g (+ g 1))
          (Text
            (list (- x (* turn_size 2))  (+ y text_offset ))
            text_height
            (strcat "G" (itoa g) " = " (nth 1 itm) )
            "G"
          )
        )
      )
      ;; take back the size of the turn
      (setq x (- x (* turn_size 2)))
    ))
    
    (setq vertices (append vertices (list
      (list (setq x (+ x (nth 2 itm))) y )
    )))
    (Text
      (list (- x (/ (nth 2 itm) 2))  (+ y text_offset2 ))
      text_height
      (rtos (nth 2 itm) 2 2)
      "DIM"
    )

  )
  (Polyline vertices "DZ")
  (princ)
) 

Link to comment
Share on other sites
iSupporter Rookie

iSupporter

Posted
  • Author
Posted (edited)
32 minutes ago, Emmanuel Delay said:

Now it uses your layers

  


(vl-load-com)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; angle to d°m's'

;; round down, see https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/round-up-numbers/td-p/7241378
(defun floor (x / n)
  (if (or (= (setq n (fix x)) x) (< 0 x))
    n
    (1- n)
  )
)

;; Decimal angle to d°m's'
(defun atd  (a / a2 d m s temp temp2)

  (setq a2 (abs a))  ;; we're not interested in the sign here
 
  (setq d (floor a2))
  (setq temp (- a2 d))
  (setq m (floor (* temp 60)))
  (setq temp2 (- temp (/ m 60.0)))
  (setq s (floor (* temp2 3600)))
  (strcat
    (itoa d) "°" (itoa m) "'" (itoa s) "''"
  )
)
;; test function for ATD
(defun c:atd  ( / myangle)
  (setq myangle 18.711919)
  (setq myangle 10.886712)
  (atd myangle)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; https://www.cadtutor.net/forum/topic/18257-entmake-functions/
(defun Polyline (lst lay)
 (entmakex (list (cons 0 "POLYLINE")
                 (cons 8 lay)
                 (cons 10 '(0 0 0))))
 (mapcar
   (function (lambda (p)
               (entmake (list (cons 0 "VERTEX") (cons 10 p))))) lst)
  (entmakex (list (cons 0 "SEQEND")))
)

(defun Text (pt hgt str lay)
 (entmakex (list (cons 0 "TEXT")
                 (cons 10  pt)
                 (cons 40 hgt)
                 (cons 8 lay)
                 (cons 1  str)))
)
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; this does what 2d-coord->pt-lst does, except every third coordinate is ignored
;; @see http://www.cadtutor.net/forum/showthread.php?104740-Automatic-numbering-in-air-flow-order/page3
(defun 3d-coord->pt-lstrjp (lst / r)
  (while lst (setq r (cons (list (car lst) (cadr lst)) r)) (setq lst (cdddr lst)))
  (reverse r)
)

;;; 2d-coord->pt-lst
;; Converts a 2d coordinates flat list into a 2d point list
;;; (2d-coord->pt-lst '(1.0 2.0 3.0 4.0)) -> ((1.0 2.0) (3.0 4.0))
(defun 2d-coord->pt-lst (lst)
  (if lst
    (cons
      (list (car lst) (cadr lst))
      (2d-coord->pt-lst (cddr lst))
    )
  )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; skip useless vertices.  
;;    Vertices too close to each other
;;    Vertices that don't make a bend

;; see if a floating point number is more or less zero
(defun zero (a / near_zero)
  (setq near_zero 0.0000001)
  (if (< (abs a) near_zero)
    T
    nil
  )
)

(defun skip_overkill (pts / lst i)
  (setq lst (list))
  (setq i 0)
  (repeat (length pts)
    (if (or
          (= i 0)
          (= (- (length pts) 1) i)
        )
      ;; first point or last point
      (progn
        (setq lst (append lst (list (nth i pts))))
      )  
      ;; next points
      (progn
        (if  (zero (distance (nth (- i 1) pts) (nth i pts)))
          ;; skip
          (progn)
          ;; don't skip
          (progn
            (setq lst (append lst (list (nth i pts))))
          )
        )
      )
    )
    (setq i (+ i 1))
  )
  lst
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun distance_and_angles (pts / result i ang prev_ang trn dst)
  (setq i 0)
  (setq result (list))
  (setq prev_ang nil)  
  (setq trn 0)  
 
  (repeat (- (length pts) 1)
    
    (setq ang (angle (nth i pts) (nth (+ i 1) pts)))
    
    (setq dst (distance (nth i pts) (nth (+ i 1) pts)))
    
    (if prev_ang
      (setq trn (- ang prev_ang))
    )
    
    
    (if (> trn pi)
      (setq trn (- (* pi 2) trn))
    )
    (if (< trn (* pi -1))
      (setq trn (- (* pi -2) trn))
    )
    
    (setq result (append result (list
      (list trn (atd (* (/ trn pi) 180 )) dst )
    )))
    
    (setq prev_ang ang)
    (setq i (+ i 1))
  )
  result
)

(defun c:PTA ( / ss pl lst pts pt1 x y turn_size vertices cur_lay)
  ;; settings, feel free to change these values
  (setq text_height 8.0)
  (setq text_offset 16.0)  ;; for the angles
  (setq text_offset2 6.0)  ;; for the distance
  (setq turn_size 15.0)

  (setq ss (ssget ":S" '((0 . "LWPOLYLINE,POLYLINE"))))
  (setq pt0 (osnap (getpoint "\nSelect the trunk <osnap on the base of the trunk>: \n") "_end"))
  (setq pt1 (getpoint "\nStart point of the horizontal polyline: "))
  (setq x (nth 0 pt1))
  (setq y (nth 1 pt1))

  (setq pl (vlax-ename->vla-object (ssname ss 0)))  
  (setq lst (vlax-get pl 'coordinates))             ;; extract the vertices
 
  (if (= "AcDb2dPolyline" (vla-get-ObjectName pl))  ;; polyline or 2D polyline ?
    (setq pts (3d-coord->pt-lstrjp lst))
      (setq pts (2d-coord->pt-lst lst))
  )
 
  (if (< (distance pt0 (last pts)) (distance pt0 (nth 0 pts)) )  ;; user picks which side we start
    (setq pts (reverse pts))
  )
 
  (setq pts (skip_overkill pts))
 
  (setq vertices (list (list x y)))
  (setq g 0)
  (foreach itm (distance_and_angles pts)
    
    (if (not (zero (nth 0 itm))) (progn
      (if (< (nth 0 itm) 0)
        (progn
          (setq vertices (append vertices (list
            (list (setq x (+ x turn_size)) (+ y turn_size) )
          )))
          (setq vertices (append vertices (list
            (list (setq x (+ x turn_size)) y )
          )))
          ;; write turn caption
          (setq g (+ g 1))
          (Text
            (list (- x (* turn_size 2))  (- y text_offset ))
            text_height
            (strcat "G" (itoa g) " = " (nth 1 itm) )
            "G"
          )
        )
        (progn
          (setq vertices (append vertices (list
            (list (setq x (+ x turn_size)) (- y turn_size) )
          )))
          (setq vertices (append vertices (list
            (list (setq x (+ x turn_size)) y )
          )))
          ;; write turn caption
          (setq g (+ g 1))
          (Text
            (list (- x (* turn_size 2))  (+ y text_offset ))
            text_height
            (strcat "G" (itoa g) " = " (nth 1 itm) )
            "G"
          )
        )
      )
      ;; take back the size of the turn
      (setq x (- x (* turn_size 2)))
    ))
    
    (setq vertices (append vertices (list
      (list (setq x (+ x (nth 2 itm))) y )
    )))
    (Text
      (list (- x (/ (nth 2 itm) 2))  (+ y text_offset2 ))
      text_height
      (rtos (nth 2 itm) 2 2)
      "DIM"
    )

  )
  (Polyline vertices "DZ")
  (princ)
) 


 

Thank Emmanuel Delay very much.

But I test file attachment is wrong angle. Because, reverse angle G3, G4.

Please view file attacht.

Thank you very much.

1065253726_reversesteeringangle.PNG.31866e7563d38827e44c225ab54892b8.PNG

reverse angle.dwg

Edited by iSupporter
Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 Share
Go to topic listing
×
×
  • Create New...