topic Re: Changing Polyline Shape in Visual LISP, AutoLISP and General Customization Forum

Changing Polyline Shape

BSA-Dean — Tue, 31 Jan 2017 13:46:06 GMT

Hi,

Bit of a strange one, but here goes.

I have some contours which have come from Orion in .dwg format.

Over these Contour extents additional Reinforcement bars have to be placed.

As there are hundreds of patches, I'm looking for a LISP that could take an irregular polyline and square it off using the outermost extremities of the polyline (contour shape).

Anybody seen anything that could do this job. Any help much appreciated.

Thanks

Re: Changing Polyline Shape

Kent1Cooper — Tue, 31 Jan 2017 13:57:11 GMT

@BSA-Dean wrote:

... I'm looking for a LISP that could take an irregular polyline and square it off using the outermost extremities of the polyline (contour shape).

Anybody seen anything that could do this job. Any help much appreciated.

....

Try these. One does it upon selection of an individual object; the other lets you choose Multiple objects at once, and then does it [one collective bounding box] around all of them.

They originate from this thread, if you're interested in related considerations.

Re: Changing Polyline Shape

marko_ribar — Tue, 31 Jan 2017 15:28:21 GMT

Is your rebar polyline polygonal (without arcs) and do you need minimal enclosing bounding box, or just orthogonal one from current UCS orientation and current orientation of rebar polyline?

Re: Changing Polyline Shape

Kent1Cooper — Tue, 31 Jan 2017 18:02:22 GMT

@marko_ribar wrote:

... do you need minimal enclosing bounding box, or just orthogonal one ...?

If what's wanted is a minimal, not necessarily orthogonal, surrounding rectangle, here is my take on that, but look through the rest of that thread for other possibilities.

Re: Changing Polyline Shape

marko_ribar — Tue, 31 Jan 2017 18:28:35 GMT

If rebar polyline is polygonal (without arcs), minimal bounding box could be found without rotational increments... The solution can be exact bounding box - it is necessary to be used Graham scan through point list...

Re: Changing Polyline Shape

john.uhden — Tue, 31 Jan 2017 22:37:00 GMT

That's very interesting. Sounds like he is building a wall or maybe slabs sized for a truckload of rebars already bent up. He should have asked for an outline that provides the minimum clearance. :]

Re: Changing Polyline Shape

BSA-Dean — Wed, 01 Feb 2017 08:38:41 GMT

Thanks for your reply. The lisp you have sounds ideal for what I need. 🙂

Unfortunately I can't get it to work 😞

When I select the shape it comes up in the command line 'nil' as attached. Same for the multiple one. Must be doing something daft.

Any more help very much appreciated.

Re: Changing Polyline Shape

marko_ribar — Wed, 01 Feb 2017 10:26:47 GMT

Can you answer on questions I posted in post #3? I already have routines, if the answers are Yes to both questions...

Re: Changing Polyline Shape

marko_ribar — Wed, 01 Feb 2017 13:34:40 GMT

Here are 2 lisp I had in mind... :

First one for WCS bounding box(es) :

(defun c:bboxpolygon ( / pl p1 p2 p3 p4 r1 r2 r3 r4 )
  (setq pl (mapcar 'cdr (mapcar (function (lambda ( x ) (append x (list 0.0)))) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget (car (entsel "\nPick closed POLYGON...")))))))
  (setq p1 (car (vl-sort pl (function (lambda ( a b ) (< (cadr a) (cadr b)))))))
  (setq p2 (car (vl-sort pl (function (lambda ( a b ) (< (car a) (car b)))))))
  (setq p3 (car (vl-sort pl (function (lambda ( a b ) (> (car a) (car b)))))))
  (setq p4 (car (vl-sort pl (function (lambda ( a b ) (> (cadr a) (cadr b)))))))
  (setq r1 (inters p1 (polar p1 0.0 1.0) p2 (polar p2 (* 0.5 pi) 1.0) nil))
  (setq r2 (inters p1 (polar p1 0.0 1.0) p3 (polar p3 (* 0.5 pi) 1.0) nil))
  (setq r3 (inters r1 (polar r1 (* 0.5 pi) 1.0) p4 (polar p4 0.0 1.0) nil))
  (setq r4 (inters r2 (polar r2 (* 0.5 pi) 1.0) p4 (polar p4 0.0 1.0) nil))
  (entmake
    (list
      '(0 . "LWPOLYLINE")
      '(100 . "AcDbEntity")
      '(100 . "AcDbPolyline")
      '(90 . 4)
      (cons 70 (1+ (* 128 (getvar 'plinegen))))
      '(38 . 0.0)
      (cons 10 r1)
      (cons 10 r2)
      (cons 10 r4)
      (cons 10 r3)
      '(210 0.0 0.0 1.0)
      '(62 . 3)
    )
  )
  (prompt "\nArea : ") (princ (rtos (* (distance r1 r2) (distance r1 r3)) 2 20))
  (princ)
)

(defun c:bboxpolygons ( / ss i pl p1 p2 p3 p4 r1 r2 r3 r4 )
  (prompt "\nSelect closed POLYGONS...")
  (setq ss (ssget (list '(0 . "LWPOLYLINE") '(-4 . "&=") '(70 . 1) '(-4 . "<not") '(-4 . "<>") '(42 . 0.0) '(-4 . "not>"))))
  (if ss
    (repeat (setq i (sslength ss))
      (setq pl (mapcar 'cdr (mapcar (function (lambda ( x ) (append x (list 0.0)))) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget (ssname ss (setq i (1- i))))))))
      (setq p1 (car (vl-sort pl (function (lambda ( a b ) (< (cadr a) (cadr b)))))))
      (setq p2 (car (vl-sort pl (function (lambda ( a b ) (< (car a) (car b)))))))
      (setq p3 (car (vl-sort pl (function (lambda ( a b ) (> (car a) (car b)))))))
      (setq p4 (car (vl-sort pl (function (lambda ( a b ) (> (cadr a) (cadr b)))))))
      (setq r1 (inters p1 (polar p1 0.0 1.0) p2 (polar p2 (* 0.5 pi) 1.0) nil))
      (setq r2 (inters p1 (polar p1 0.0 1.0) p3 (polar p3 (* 0.5 pi) 1.0) nil))
      (setq r3 (inters r1 (polar r1 (* 0.5 pi) 1.0) p4 (polar p4 0.0 1.0) nil))
      (setq r4 (inters r2 (polar r2 (* 0.5 pi) 1.0) p4 (polar p4 0.0 1.0) nil))
      (entmake
        (list
          '(0 . "LWPOLYLINE")
          '(100 . "AcDbEntity")
          '(100 . "AcDbPolyline")
          '(90 . 4)
          (cons 70 (1+ (* 128 (getvar 'plinegen))))
          '(38 . 0.0)
          (cons 10 r1)
          (cons 10 r2)
          (cons 10 r4)
          (cons 10 r3)
          '(210 0.0 0.0 1.0)
          '(62 . 3)
        )
      )
    )
  )
  (princ)
)

(defun c:bboxpolygons-global ( / ss i pl pll p1 p2 p3 p4 r1 r2 r3 r4 )
  (prompt "\nSelect closed POLYGONS...")
  (setq ss (ssget (list '(0 . "LWPOLYLINE") '(-4 . "&=") '(70 . 1) '(-4 . "<not") '(-4 . "<>") '(42 . 0.0) '(-4 . "not>"))))
  (if ss
    (repeat (setq i (sslength ss))
      (setq pl (mapcar 'cdr (mapcar (function (lambda ( x ) (append x (list 0.0)))) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget (ssname ss (setq i (1- i))))))))
      (setq pll (append pl pll))
    )
  )
  (if pll
    (progn
      (setq p1 (car (vl-sort pll (function (lambda ( a b ) (< (cadr a) (cadr b)))))))
      (setq p2 (car (vl-sort pll (function (lambda ( a b ) (< (car a) (car b)))))))
      (setq p3 (car (vl-sort pll (function (lambda ( a b ) (> (car a) (car b)))))))
      (setq p4 (car (vl-sort pll (function (lambda ( a b ) (> (cadr a) (cadr b)))))))
      (setq r1 (inters p1 (polar p1 0.0 1.0) p2 (polar p2 (* 0.5 pi) 1.0) nil))
      (setq r2 (inters p1 (polar p1 0.0 1.0) p3 (polar p3 (* 0.5 pi) 1.0) nil))
      (setq r3 (inters r1 (polar r1 (* 0.5 pi) 1.0) p4 (polar p4 0.0 1.0) nil))
      (setq r4 (inters r2 (polar r2 (* 0.5 pi) 1.0) p4 (polar p4 0.0 1.0) nil))
      (entmake
        (list
          '(0 . "LWPOLYLINE")
          '(100 . "AcDbEntity")
          '(100 . "AcDbPolyline")
          '(90 . 4)
          (cons 70 (1+ (* 128 (getvar 'plinegen))))
          '(38 . 0.0)
          (cons 10 r1)
          (cons 10 r2)
          (cons 10 r4)
          (cons 10 r3)
          '(210 0.0 0.0 1.0)
          '(62 . 3)
        )
      )
      (prompt "\nArea global : ") (princ (rtos (* (distance r1 r2) (distance r1 r3)) 2 20))
    )
  )
  (princ)
)

(prompt "\nInvoke with : (c:bboxpolygon) for single closed POLYGON input, or with : (C:bboxpolygons) for multiple closed POLYGONS input, or with : (C:bboxpolygons-global) for multiple closed POLYGONS input and single bbox output...")
(princ)

The second one is for calculation of minimal bounding box(es) :

; transptucs & transptwcs by M.R. (Marko Ribar, d.i.a.)
; arguments : 
; pt - point to be transformed from WCS to imaginary UCS with transptucs and from imaginary UCS to WCS with transptwcs
; pt1 - origin of imaginary UCS
; pt2 - point to define X axis of imaginary UCS (vector pt1-pt2 represents X axis)
; pt3 - point to define Y axis of imaginary UCS (vector pt1-pt3 represents Y axis)
; important note : angle between X and Y axises of imaginary UCS must always be 90 degree for correct transformation calculation

;; Unit Vector - M.R.
;; Args: v - vector in R^n

(defun unit ( v / d )
  (mapcar '(lambda ( x y ) (/ x y)) v (list (setq d (distance '(0.0 0.0 0.0) v)) d d))
)

;; Matrix x Vector - Vladimir Nesterovsky
;; Args: m - nxn matrix, v - vector in R^n

(defun mxv ( m v )
  (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)

;; Vector Cross Product - Lee Mac
;; Args: u,v - vectors in R^3

(defun v^v ( u v )
  (list
    (- (* (cadr u) (caddr v)) (* (caddr u) (cadr v)))
    (- (* (caddr u) (car v)) (* (car u) (caddr v)))
    (- (* (car u) (cadr v)) (* (cadr u) (car v)))
  )
)

(defun transptucs ( pt p1 p2 p3 / ux uy uz )
  (setq uz (unit (v^v (mapcar '- p2 p1) (mapcar '- p3 p1))))
  (setq ux (unit (mapcar '- p2 p1)))
  (setq uy (unit (mapcar '- p3 p1)))
  
  (mxv (list ux uy uz) (mapcar '- pt p1))
)

(defun transptwcs ( pt pt1 pt2 pt3 / pt1n pt2n pt3n )
  (setq pt1n (transptucs '(0.0 0.0 0.0) pt1 pt2 pt3))
  (setq pt2n (transptucs '(1.0 0.0 0.0) pt1 pt2 pt3))
  (setq pt3n (transptucs '(0.0 1.0 0.0) pt1 pt2 pt3))
  (transptucs pt pt1n pt2n pt3n)
)

;; Convex Hull  -  Lee Mac
;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
 
(defun LM:ConvexHull ( lst / ch p0 )
    (cond
        (   (< (length lst) 4) lst)
        (   (setq p0 (car lst))
            (foreach p1 (cdr lst)
                (if (or (< (cadr p1) (cadr p0))
                        (and (equal (cadr p1) (cadr p0) 1e-8) (< (car p1) (car p0)))
                    )
                    (setq p0 p1)
                )
            )
            (setq lst (vl-remove p0 lst))
            (setq lst (append (list p0) lst))
            (setq lst
                (vl-sort lst
                    (function
                        (lambda ( a b / c d )
                            (if (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-8)
                                (< (distance p0 a) (distance p0 b))
                                (< (if (equal c (* 2.0 pi) 1e-8) 0.0 c) (if (equal d (* 2.0 pi) 1e-8) 0.0 d))
                            )
                        )
                    )
                )
            )
            (setq ch (list (caddr lst) (cadr lst) (car lst)))
            (foreach pt (cdddr lst)
                (setq ch (cons pt ch))
                (while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt))
                    (setq ch (cons pt (cddr ch)))
                )
            )
            (reverse ch)
        )
    )
)
 
;; Clockwise-p  -  Lee Mac
;; Returns T if p1,p2,p3 are clockwise oriented or collinear
                 
(defun LM:Clockwise-p ( p1 p2 p3 )
    (<  (-  (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
            (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
        )
        1e-8
    )
)

(defun minarearec ( ccwchullpts / edges p1 p2 pts r1 r2 pp r3 r4 ar arlst rtn )
  (setq edges (mapcar (function (lambda ( a b ) (list a b))) ccwchullpts (cdr (reverse (cons (car ccwchullpts) (reverse ccwchullpts))))))
  (foreach edge edges
    (setq p1 (car edge) p2 (cadr edge))
    (setq pts (mapcar (function (lambda ( x ) (transptucs x p1 p2 (polar p1 (+ (angle p1 p2) (* 0.5 pi)) 1.0)))) ccwchullpts))
    (setq r1 (transptwcs (list (car (car (vl-sort pts (function (lambda ( a b ) (< (car a) (car b))))))) 0.0 0.0) p1 p2 (polar p1 (+ (angle p1 p2) (* 0.5 pi)) 1.0)))
    (setq r2 (transptwcs (list (car (car (vl-sort pts (function (lambda ( a b ) (> (car a) (car b))))))) 0.0 0.0) p1 p2 (polar p1 (+ (angle p1 p2) (* 0.5 pi)) 1.0)))
    (setq pp (transptwcs (car (vl-sort pts (function (lambda ( a b ) (> (abs (cadr a)) (abs (cadr b))))))) p1 p2 (polar p1 (+ (angle p1 p2) (* 0.5 pi)) 1.0)))
    (setq r3 (inters r1 (polar r1 (+ (angle r1 r2) (* 0.5 pi)) 1.0) pp (polar pp (angle r1 r2) 1.0) nil))
    (setq r4 (inters r2 (polar r2 (+ (angle r1 r2) (* 0.5 pi)) 1.0) pp (polar pp (angle r1 r2) 1.0) nil))
    (setq ar (* (distance r1 r2) (distance r1 r3)))
    (setq arlst (cons (cons (list r1 r2 r4 r3) ar) arlst))
  )
  (setq rtn (car (vl-sort arlst (function (lambda ( a b ) (< (cdr a) (cdr b)))))))
  rtn
)

(defun c:minbboxpolygon ( / pl rtn )
  (setq pl (mapcar 'cdr (mapcar (function (lambda ( x ) (append x (list 0.0)))) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget (car (entsel "\nPick closed POLYGON...")))))))
  (setq rtn (minarearec (LM:ConvexHull pl)))
  (entmake
    (list
      '(0 . "LWPOLYLINE")
      '(100 . "AcDbEntity")
      '(100 . "AcDbPolyline")
      '(90 . 4)
      (cons 70 (1+ (* 128 (getvar 'plinegen))))
      '(38 . 0.0)
      (cons 10 (car (car rtn)))
      (cons 10 (cadr (car rtn)))
      (cons 10 (caddr (car rtn)))
      (cons 10 (cadddr (car rtn)))
      '(210 0.0 0.0 1.0)
      '(62 . 3)
    )
  )
  (prompt "\nMinimal area : ") (princ (rtos (cdr rtn) 2 20))
  (princ)
)

(defun c:minbboxpolygons ( / ss i pl rtn )
  (prompt "\nSlect closed POLYGONS...")
  (setq ss (ssget (list '(0 . "LWPOLYLINE") '(-4 . "&=") '(70 . 1) '(-4 . "<not") '(-4 . "<>") '(42 . 0.0) '(-4 . "not>"))))
  (if ss
    (repeat (setq i (sslength ss))
      (setq pl (mapcar 'cdr (mapcar (function (lambda ( x ) (append x (list 0.0)))) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget (ssname ss (setq i (1- i))))))))
      (setq rtn (minarearec (LM:ConvexHull pl)))
      (entmake
        (list
          '(0 . "LWPOLYLINE")
          '(100 . "AcDbEntity")
          '(100 . "AcDbPolyline")
          '(90 . 4)
          (cons 70 (1+ (* 128 (getvar 'plinegen))))
          '(38 . 0.0)
          (cons 10 (car (car rtn)))
          (cons 10 (cadr (car rtn)))
          (cons 10 (caddr (car rtn)))
          (cons 10 (cadddr (car rtn)))
          '(210 0.0 0.0 1.0)
          '(62 . 3)
        )
      )
    )
  )
  (princ)
)

(defun c:minbboxpolygons-global ( / ss i pl pll rtn )
  (prompt "\nSlect closed POLYGONS...")
  (setq ss (ssget (list '(0 . "LWPOLYLINE") '(-4 . "&=") '(70 . 1) '(-4 . "<not") '(-4 . "<>") '(42 . 0.0) '(-4 . "not>"))))
  (if ss
    (repeat (setq i (sslength ss))
      (setq pl (mapcar 'cdr (mapcar (function (lambda ( x ) (append x (list 0.0)))) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget (ssname ss (setq i (1- i))))))))
      (setq pll (append pl pll))
    )
  )
  (if pll
    (progn
      (setq rtn (minarearec (LM:ConvexHull pll)))
      (entmake
        (list
          '(0 . "LWPOLYLINE")
          '(100 . "AcDbEntity")
          '(100 . "AcDbPolyline")
          '(90 . 4)
          (cons 70 (1+ (* 128 (getvar 'plinegen))))
          '(38 . 0.0)
          (cons 10 (car (car rtn)))
          (cons 10 (cadr (car rtn)))
          (cons 10 (caddr (car rtn)))
          (cons 10 (cadddr (car rtn)))
          '(210 0.0 0.0 1.0)
          '(62 . 3)
        )
      )
      (prompt "\nMinimal global area : ") (princ (rtos (cdr rtn) 2 20))
    )
  )
  (princ)
)

(prompt "\nInvoke with : (c:minbboxpolygon) for single closed POLYGON input, or with : (C:minbboxpolygons) for multiple closed POLYGONS input, or with : (C:minbboxpolygons-global) for multiple closed POLYGONS input and single bbox output...")
(princ)

HTH., M.R.

If answer satisfies your requirements, mark the answer as solution to your question...

Regards...

Re: Changing Polyline Shape

BSA-Dean — Wed, 01 Feb 2017 13:42:20 GMT

Marko,

Yeah the polyline has no arcs, and looking to put bounding box ortho to the world UCS.

Re: Changing Polyline Shape

BSA-Dean — Wed, 01 Feb 2017 14:03:46 GMT

Marko!

BBOXPOLYGON!!!! You my friend are a frickin' LEGEND!

Saved me hours as I have a 150x45m Plan area with loads of contours!!

Thanks! 🙂

Re: Changing Polyline Shape

Kent1Cooper — Wed, 01 Feb 2017 15:26:09 GMT

@BSA-Dean wrote:

....

When I select the shape it comes up in the command line 'nil' as attached. Same for the multiple one. Must be doing something daft.

....

Zoom to the Extents, and you should see it. In your image, you're not in the World Coordinate System. The routine could be made to account for that, if necessary [and also to suppress the display of that nil when it's done, which is just the return from any (command) function]. But you already have another solution that does what it seems you're after, including [not the one you name in Post 11, but another in Post 9] selecting a lot of them at once [which DBB doesn't do, though it could also be adjusted to allow that], so I won't rush to edit it.

Re: Changing Polyline Shape

Kent1Cooper — Wed, 01 Feb 2017 16:56:25 GMT

@Kent1Cooper wrote:

... I won't rush to edit it.

But I did anyway. The attached contains both DBB and DBBM commands in the two functions I attached earlier, but DBB now allows selecting multiple objects [for individual rectangles around each]. Compared to marko's routines, they don't report the collective area for the DBBM multiple-object collective-box one, and they don't make them green [unless the current Layer and entity-properties settings do so]. But they work on all entity types, and Polylines don't need to be either of only line segments or closed. [And it's a heck of a lot less code.]

And they work in a non-World UCS with an origin different from 0,0,0, as long as its orientation is the same, so the problem you had with DBB before shouldn't occur. [I may fiddle with how to compensate for other orientations, but it's going to complicated, if it's achievable at all.]

As I think was mentioned on the other thread I linked to earlier, Splines and Mtext and rotated Blocks can have bounding boxes that go beyond their visible extents -- I don't think that can easily be compensated for, either, just because of the nature of the get-bounding-box operation relative to the characteristics of those objects.