Create Rectangle using pick point like boundary

[tefached]

Dear almighty programmers,

I made this autolisp with my very little knowledge and i want to optimize it if possible
 

Quote

(defun c:test    (/ *error* os)
  
  (defun *error* ( msg )
        (if os (setvar 'osmode os))
        (if (not (member msg '("Function cancelled" "quit / exit abort")))
            (princ (strcat "\nError: " msg))
        )
        (princ)
    )

  (princ "INPUT TEXT INFORMATION")
  (setq pr (getstring "\nPrefix: "))
  (setq sn (getint "\nStarting Number: "))
  (setq ht (getint "\nText Height: "))
  (setq ben pogi)

  (while (eq ben pogi)
    (princ "SELECT CORNERS")
    (setq p1 (getpoint "\nSpecify first corner point"))
    (setq p2 (getpoint "\nSpecify second corner point"))
    (setq os (getvar "osmode"))
    (command "osmode" 0)
    (command "rectangle" p1 p2)
    (setq x1 (/ (+ (car p1) (car p2)) 2))
    (setq y1 (/ (+ (cadr p1) (cadr p2)) 2))
    (setq z1 0)
    (setq p3 (list x1 y1 z1))
    (command "text"
         "J"
         "M"
         p3
         ht
         0
         (strcat pr (rtos sn 2 0))
         ""
    )
    (setq sn (+ sn 1))
    (command "osmode" os)
  )

  (princ)
)

what it does is to make a rectangle with a prefix and series number if i pick the diagonal corners one by one

is there a way to optimize it and just pick the internal point and the lisp will analyze the boundary and create a rectangle and the ID on center?
i need it to be a rectangle (4 vertices because i have another lisp that works with rectangles) that is why im not using the boundary command because it includes other points and produce a polyline with more vertices.

i attached the cad file for reference thanks in advance

 

AUTO JO.dwg

[Jonathan Handojo]

Yea... this is actually a thing that I find annoying, and because I can't find any programs out there online to do this, I had to make one myself.

 

You can still use the boundary command with the excess vertices being there. After that, call RXV and pass the polyline generated by the boundary command into the function. So for example, after you run (command "-boundary" pause), you can do (RXV (entlast)).

 

;; RXV --> Jonathan Handojo
;; Removes excess vertices in a 2D polyline curve.
;; ent - entity object of the 2D polyline to process.

(defun RXV (ent / *error* a a1 a2 a3 b b1 b2 b3 bul c e e1 e2 e3 enx ewd i m1 p1 p2 p3 pm pmp pts rtn s1 s2 s3 sa ss swd v)
    (setq enx (entget ent)
          pts (vl-remove-if-not '(lambda (x) (= (car x) 10)) enx)
          swd (vl-remove-if-not '(lambda (x) (= (car x) 40)) enx)
          ewd (vl-remove-if-not '(lambda (x) (= (car x) 41)) enx)
          bul (vl-remove-if-not '(lambda (x) (= (car x) 42)) enx)
          pm -0.5
          pmp (mapcar '(lambda (x) (setq pm (1+ pm))) pts)
          rtn (list (car pts) (car swd))
          v -1
    )
    
    ;;  Remove any vertex duplicates as they may interfere with calculations.
    (mapcar
        '(lambda (a b)
            (setq v (1+ v))
            (if (equal (cdr a) (cdr b) 1e-8)
                (setq pts (RXV:RemoveNth v pts)
                        swd (RXV:RemoveNth v swd)
                        ewd (RXV:RemoveNth v ewd)
                        bul (RXV:RemoveNth v bul)
                        pmp (RXV:RemoveNth v pmp)
                        v (1- v)
                )
            )
        )
        pts (cdr pts)
    )
    
    ;; Start calculations.
    (mapcar
        '(lambda (p1 s1 e1 b1 m1 p2 s2 e2 b2 m2 p3 s3 e3 b3 m3 / a1 a2 a3 c e p4 s4 e4 b4)
            (mapcar 'set '(p1 s1 e1 b1 p2 s2 e2 b2 p3 s3 e3 b3) (mapcar 'cdr (list p1 s1 e1 b1 p2 s2 e2 b2 p3 s3 e3 b3)))
            (if
                (not (setq e p3)) 
                (setq p3 (cdar pts)
                    p4 (cdadr pts)
                    s4 (cdadr swd)
                    e4 (cdadr pts)
                    b4 (cdadr pts)
                )
            )
            (cond
                (   (and    ;; If segment is straight
                        (zerop b1)
                        (zerop b2)
                    )
                    (if (not (equal (RXV:vx1 (mapcar '- p1 p2)) (RXV:vx1 (mapcar '- p2 p3)) 1e-8))
                        (setq rtn (append rtn (list (cons 41 e1) '(42 . 0.0) '(91 . 0) (cons 10 p2) (cons 40 s2))))
                    )
                    (if 
                        (not e)
                        (progn
                            (setq rtn (append rtn (list (cons 41 e2) '(42 . 0.0) '(91 . 0))))
                            (if (equal (RXV:vx1 (mapcar '- p2 p3)) (RXV:vx1 (mapcar '- p3 p4)) 1e-8)
                                (setq rtn (member (assoc 10 (cdr rtn)) rtn))
                            )
                        )
                    )
                )
                (   (and    ;; If segment is curved
                        (not (zerop b1))
                        (not (zerop b2))
                    )
                    (setq a1 (RXV:Bulge->Arc p1 p2 b1)
                            a2 (RXV:Bulge->Arc p2 p3 b2)
                            c (not (RXV:Clockwise-p p1 (vlax-curve-getpointatparam ent m1) p2))
                    )
                    (if
                        (not
                            (and
                                (equal (car a1) (car a2) 1e-8)
                                (equal (cadddr a1) (cadddr a2) 1e-8)
                            )
                        )
                        (progn
                            (if c
                                (setq a3 (RXV:Arc->Bulge (car a1) (cond (sa) ((cadr a1))) (caddr a1) (cadddr a1))
                                    rtn (append rtn (list (cons 41 e1) (cons 42 (cadr a3)) '(91 . 0) (cons 10 p2) (cons 40 s2)))
                                    sa nil
                                )
                                (setq a3 (RXV:Arc->Bulge (car a1) (cadr a1) (cond (sa) ((caddr a1))) (cadddr a1))
                                    rtn (append rtn (list (cons 41 e1) (cons 42 (- (cadr a3))) '(91 . 0) (cons 10 p2) (cons 40 s2)))
                                    sa nil
                                )
                            )
                            (if (not e) (setq rtn (append rtn (list (cons 41 e2) (cons 42 b2) '(91 . 0)))))
                        )
                        (progn
                            (if (not sa)
                                (if c 
                                    (setq sa (cadr a1))
                                    (setq sa (caddr a1))
                                )
                            )
                            (if 
                                (not e)
                                (setq rtn
                                    (append rtn
                                        (list 
                                            (cons 41 e2) 
                                            (cons 42
                                                (if
                                                    (= (cdr (assoc 70 enx)) 1)
                                                    (if c
                                                        (cadr (RXV:Arc->Bulge (car a2) sa (caddr a2) (cadddr a2)))
                                                        (- (cadr (RXV:Arc->Bulge (car a2) (cadr a2) sa (cadddr a2))))
                                                    )
                                                    b2
                                                )
                                            )
                                            '(91 . 0)
                                        )
                                    )
                                )
                            )
                        )
                    )
                )
                (   (and    ;; If the previous segment is curved and is not collinear
                        (not (zerop b1))
                        sa e
                    )
                    (setq a1 (RXV:Bulge->Arc p1 p2 b1))
                    (if
                        (not (RXV:Clockwise-p p1 (vlax-curve-getpointatparam ent m1) p2))
                        (setq a2 (RXV:Arc->Bulge (car a1) sa (caddr a1) (cadddr a1))
                                rtn (append rtn (list (cons 41 e1) (cons 42 (cadr a2)) '(91 . 0) (cons 10 p2) (cons 40 s2)))
                                sa nil
                        )
                        (setq a2 (RXV:Arc->Bulge (car a1) (cadr a1) sa (cadddr a1))
                                rtn (append rtn (list (cons 41 e1) (cons 42 (- (cadr a2))) '(91 . 0) (cons 10 p2) (cons 40 s2)))
                                sa nil
                        )
                    )
                )
                (   (setq rtn (append rtn (list (cons 41 e1) (cons 42 b1) '(91 . 0) (cons 10 p2) (cons 40 s2))))
                    (if (not e) (setq rtn (append rtn (list (cons 41 e2) (cons 42 b2) '(91 . 0)))))
                )
            )
        )
        pts swd ewd bul pmp
        (cdr pts) (cdr swd) (cdr ewd) (cdr bul) (cdr pmp)
        (append (cddr pts) '(nil)) 
        (append (cddr swd) (list (car swd))) 
        (append (cddr ewd) (list (car ewd))) 
        (append (cddr bul) (list (car bul))) 
        (append (cddr pmp) (list (car pmp))) 
    )
    (entmod
        (append 
            (vl-remove-if '(lambda (x) (member (car x) '(10 40 41 42 91))) enx)
            rtn 
        )
    )
)
(vl-load-com)

;; Bulge to Arc  -  Lee Mac
;; p1 - start vertex
;; p2 - end vertex
;; b  - bulge
;; Returns: (<center> <start angle> <end angle> <radius>)

(defun RXV:Bulge->Arc ( p1 p2 b / a c r )
    (setq a (* 2 (atan b))
          r (/ (distance p1 p2) 2 (sin a))
          c (polar p1 (+ (- (/ pi 2) a) (angle p1 p2)) r)
    )
    (if (minusp b)
        (list c (angle c p2) (angle c p1) (abs r))
        (list c (angle c p1) (angle c p2) (abs r))
    )
)

;; Arc to Bulge  -  Lee Mac
;; c     - center
;; a1,a2 - start, end angle
;; r     - radius
;; Returns: (<vertex> <bulge> <vertex>)

(defun RXV:arc->bulge ( c a1 a2 r )
    (list
        (polar c a1 r)
        (   (lambda ( a ) (/ (sin a) (cos a)))
            (/ (rem (+ pi pi (- a2 a1)) (+ pi pi)) 4.0)
        )
        (polar c a2 r)
    )
)

;; Clockwise-p  -  Lee Mac
;; Returns T if p1,p2,p3 are clockwise oriented

(defun RXV:Clockwise-p ( p1 p2 p3 )
    (<  (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
        (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
    )
)

;; Unit Vector  -  Lee Mac
;; Args: v - vector in R^2 or R^3

(defun RXV:vx1 ( v )
    (   (lambda ( n ) (if (equal 0.0 n 1e-10) nil (mapcar '/ v (list n n n))))
        (distance '(0.0 0.0 0.0) v)
    )
)

;;----------------------=={ Remove Nth }==--------------------;;
;;                                                            ;;
;;  Removes the item at the nth index in a supplied list      ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  n - index of item to remove (zero based)                  ;;
;;  l - list from which item is to be removed                 ;;
;;------------------------------------------------------------;;
;;  Returns:  List with item at index n removed               ;;
;;------------------------------------------------------------;;

(defun RXV:RemoveNth ( n l / i )
    (setq i -1)
    (vl-remove-if '(lambda ( x ) (= (setq i (1+ i)) n)) l)
)

 

[tefached]

hi Jonathan thank you for the quick response, i tried the lisp and just added
 

(defun c:xxx    ()

  (command "-boundary" pause)
  (RXV (entlast))
  )

if i understand your solution correctly it should create a polyline boundary and remove the excess vertices as i go?
but as i pick my first boundary i get this error

Specify internal point or [Advanced options]: ; error: bad DXF group: nil

it did create the boundary still with extra vertices tho

Edited August 8, 2022 by tefached

[Jonathan Handojo]

My apologies, I didn't test that xxx command. In your case, you'd want something like this:

 

(defun c:xxx ( / ent pt)
    (while (setq pt (getpoint "\nSpecify internal point <exit>: ")) 
        (setq ent (entlast))
        (command "-boundary" pt "")
        (while (setq ent (entnext ent)) (RXV ent))
    )
    (princ)
)

 

[tefached]

oh i figured it out i have to end the boundary command before the rxv i guess i can handle the rest. thank you so much