Topic: CLOSED POLYGONS or REGIONS from surrounding LINES ???

[ribarm]

Hi again, I have dwg witch contains set of lines obtained from HATCH... Every 2 vertices are welded to single common one... I am interested if its possible to make closed polygons or regions from these lines... Lines form common adjacent sides of polygons - see attached DWG... So, I need to create somehow many these polygons-regions from these lines... If I erase all lines and leave one rectangular polygon with these line sides, then command REGION works and REGION is created, but if I select all these lines command REGION can't create them...

M.R.

[Stefan]

Hi Marko

I've done something similar here.

[ribarm]

It works, Stefan... This is exactly what I was looking for... Many thanks Stefan, you saved me time for programming this one, for witch I think I would have to go through trials and errors with uncertain results...

I think I'd have to compensate this code for my newest plintav-adv.lsp witch I used to obtaining those lines on this Autodesk hatch pattern witch is unprecise - lines don't touch each other when zoomed in...

So here is my ADV version... Hope you'll like it...
So with your code, this one and this one I posted here :
http://www.theswamp.org/index.php?topic=45751.new#new

we can make nice looking hatch patterns that are colorful...

Code: [Select]

(defun c:plintav-adv ( / intersobj1obj2 LM:Unique AT:GetVertices _reml member-fuzz add_vtx trunc clean_poly
                         ss sslpl sshpl i ent n ent1 ss-ent1 k ent2 intpts intptsall pl plpts restintpts par plv plvl vn plvn pld )

  (vl-load-com)

  (defun intersobj1obj2 ( obj1 obj2 / coords pt ptlst )
    (if (eq (type obj1) 'ENAME) (setq obj1 (vlax-ename->vla-object obj1)))
    (if (eq (type obj2) 'ENAME) (setq obj2 (vlax-ename->vla-object obj2)))
    (setq coords (vl-catch-all-apply 'vlax-safearray->list (list (vl-catch-all-apply 'vlax-variant-value (list (vla-intersectwith obj1 obj2 AcExtendBoth))))))
    (if (vl-catch-all-error-p coords)
      (setq ptlst nil)
      (repeat (/ (length coords) 3)
        (setq pt (list (car coords) (cadr coords) (caddr coords)))
        (setq ptlst (cons pt ptlst))
        (setq coords (cdddr coords))
      )
    )
    ptlst
  ) 

  (defun LM:Unique ( lst )
    (if lst (cons (car lst) (LM:Unique (vl-remove (car lst) (cdr lst)))))
  )

  (defun AT:GetVertices ( e / p l )
    (LM:Unique
      (if e
        (if (eq (setq p (vlax-curve-getEndParam e)) (fix p))
          (repeat (setq p (1+ (fix p)))
            (setq l (cons (vlax-curve-getPointAtParam e (setq p (1- p))) l))
          )
          (list (vlax-curve-getStartPoint e) (vlax-curve-getEndPoint e))
        )
      )
    )
  )

  (defun _reml ( l1 l2 / a n ls )
    (while
      (setq n nil
            a (car l2)
      )
      (while (and l1 (null n))
        (if (equal a (car l1) 1e-8)
          (setq l1 (cdr l1)
                n t
          )
          (setq ls (append ls (list (car l1)))
                l1 (cdr l1)
          )
        )
      )
      (setq l2 (cdr l2))
    )
    (append ls l1)
  )

  (defun member-fuzz ( expr lst fuzz )
    (while (and lst (not (equal (car lst) expr fuzz)))
      (setq lst (cdr lst))
    )
    lst
  )

  (defun add_vtx ( obj add_pt ent_name / bulg sw ew )
      (vla-GetWidth obj (fix add_pt) 'sw 'ew)
      (vla-addVertex
          obj
          (1+ (fix add_pt))
          (vlax-make-variant
              (vlax-safearray-fill
                  (vlax-make-safearray vlax-vbdouble (cons 0 1))
                      (list
                          (car (trans (vlax-curve-getpointatparam obj add_pt) 0 ent_name))
                          (cadr (trans (vlax-curve-getpointatparam obj add_pt) 0 ent_name))
                      )
              )
          )
      )
      (setq bulg (vla-GetBulge obj (fix add_pt)))
      (vla-SetBulge obj
          (fix add_pt)
          (/
              (sin (/ (* 4 (atan bulg) (- add_pt (fix add_pt))) 4))
              (cos (/ (* 4 (atan bulg) (- add_pt (fix add_pt))) 4))
          )
      )
      (vla-SetBulge obj
          (1+ (fix add_pt))
          (/
              (sin (/ (* 4 (atan bulg) (- (1+ (fix add_pt)) add_pt)) 4))
              (cos (/ (* 4 (atan bulg) (- (1+ (fix add_pt)) add_pt)) 4))
          )
      )
      (vla-SetWidth obj (fix add_pt) sw (+ sw (* (- ew sw) (- add_pt (fix add_pt)))))
      (vla-SetWidth obj (1+ (fix add_pt)) (+ sw (* (- ew sw) (- add_pt (fix add_pt)))) ew)
      (vla-update obj)
  )

  (defun trunc ( expr lst )
    (if (and lst
       (not (equal (car lst) expr))
        )
      (cons (car lst) (trunc expr (cdr lst)))
    )
  )

  (defun clean_poly ( ent / e_lst p_lst vtx1 vtx2 )
    (setq e_lst (entget ent))
    (cond
      ((= "LWPOLYLINE" (cdr (assoc 0 e_lst)))
       (setq p_lst (vl-remove-if-not
         '(lambda (x)
            (or (= (car x) 10)
          (= (car x) 40)
          (= (car x) 41)
          (= (car x) 42)
            )
          )
         e_lst
       )
       e_lst (vl-remove-if
         '(lambda (x)
            (member x p_lst)
          )
         e_lst
       )
       )
       (if (= 1 (cdr (assoc 70 e_lst)))
         (while (equal (car p_lst) (assoc 10 (reverse p_lst)))
     (setq p_lst (reverse (cdr (member (assoc 10 (reverse p_lst))
               (reverse p_lst)
             )
              )
           )
     )
         )
       )
       (while p_lst
         (setq e_lst (append e_lst (trunc (assoc 10 (cdr p_lst)) p_lst))
         p_lst (member (assoc 10 (cdr p_lst)) (cdr p_lst))
         )
       )
       (entmod e_lst)
      )
      ((and (= "POLYLINE" (cdr (assoc 0 e_lst)))
      (zerop (logand 240 (cdr (assoc 70 e_lst))))
       )
       (setq e_lst (cons e_lst nil)
       vtx1 (entnext ent)
       vtx2 (entnext vtx1)
       )
       (while (= (cdr (assoc 0 (entget vtx1))) "VERTEX")
         (if (= (cdr (assoc 0 (entget vtx2))) "SEQEND")
     (if
       (or (not
       (equal (assoc 10 (entget vtx1))
        (assoc 10 (last (reverse (cdr (reverse e_lst)))))
       )
           )
           (zerop (logand 1 (cdr (assoc 70 (last e_lst)))))
       )
        (setq e_lst (cons (entget vtx1) e_lst))
     )
     (if
       (not
         (equal (assoc 10 (entget vtx1)) (assoc 10 (entget vtx2)) 1e-9)
       )
        (setq e_lst (cons (entget vtx1) e_lst))
     )
         )
         (setq vtx1 vtx2
         vtx2 (entnext vtx1)
         )
       )
       (setq e_lst (reverse (cons (entget vtx1) e_lst)))
       (entdel ent)
       (mapcar 'entmake e_lst)
      )
      (T (princ "\nEntité non valide."))
    )
    (princ)
  )

  (vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
  (setq ss (ssget "_:L" '((0 . "*POLYLINE") (-4 . "<and") (-4 . "<not") (-4 . "&=") (70 . 8) (-4 . "not>") (-4 . "<") (70 . 130) (-4 . "and>"))))
  (setq sslpl (ssadd) sshpl (ssadd))
  (setq i -1)
  (while (setq ent (ssname ss (setq i (1+ i))))
    (if (eq (cdr (assoc 0 (entget ent))) "LWPOLYLINE")
      (progn
        (entupd ent)
        (vla-update (vlax-ename->vla-object ent))
        (ssadd ent sslpl)
      )
    )
    (if (eq (cdr (assoc 0 (entget ent))) "POLYLINE")
      (ssadd ent sshpl)
    )
  )
  (setq i -1)
  (while (setq ent (ssname sshpl (setq i (1+ i))))
    (command "_.convertpoly" "l" ent "")
    (entupd ent)
    (vla-update (vlax-ename->vla-object ent))
    (ssadd ent sslpl)
  )
  (repeat (setq n (sslength ss))
    (setq ent1 (ssname ss (setq n (1- n))))
    (setq ss-ent1 (ssdel ent1 ss))
    (repeat (setq k (sslength ss-ent1))
      (setq ent2 (ssname ss-ent1 (setq k (1- k))))
      (setq intpts (intersobj1obj2 ent1 ent2))
      (setq intptsall (append intpts intptsall))
    )
  )
  (setq i -1)
  (while (setq pl (ssname sslpl (setq i (1+ i))))
    (setq plpts (AT:GetVertices pl))
    ;;;(setq restintpts (_reml intptsall plpts))
    (setq restintpts (append intptsall plpts))
    (setq restintpts (acet-list-remove-duplicates restintpts 1e-6))
    (foreach pt restintpts
      (if
        (and
          ;;;(not (member-fuzz pt plpts 1e-6))
          (setq par (vlax-curve-getparamatpoint pl (vlax-curve-getclosestpointto pl pt)))
          (not (or (equal par (vlax-curve-getstartparam pl) 1e-6) (equal par (vlax-curve-getendparam pl) 1e-6)))
        )
        (add_vtx (vlax-ename->vla-object pl) par pl)       
      )
    )
  )
  (setq i -1)
  (while (setq pl (ssname sslpl (setq i (1+ i))))
    (setq plv (mapcar 'cdr (acet-list-m-assoc 10 (entget pl))))
    (setq plvl (append plv plvl))
  )
  (setq plvl (acet-list-remove-duplicates plvl 1e-4))
  (setq i -1)
  (while (setq pl (ssname sslpl (setq i (1+ i))))
    (setq plv (mapcar 'cdr (acet-list-m-assoc 10 (entget pl))))
    (foreach v plv
      (setq vn (car (vl-member-if '(lambda ( x ) (equal x v 1e-4)) plvl)))
      (setq plvn (cons vn plvn))
    )
    (setq plvn (reverse plvn))
    (setq pld (entget pl))
    (foreach vn plvn
      (setq pld (subst (cons 10 vn) (car (vl-member-if '(lambda ( x ) (equal (cons 10 vn) x 1e-4)) (acet-list-m-assoc 10 pld))) pld))
    )
    (entmod pld)
    (entupd (cdr (assoc -1 pld)))
  )
  (repeat (setq n (sslength sslpl))
    (clean_poly (ssname sslpl (setq n (1- n))))
  )
  (setq i -1)
  (while (setq ent (ssname sshpl (setq i (1+ i))))
    (command "_.convertpoly" "h" ent "")
  )
  (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
  (princ)
)

M.R.

[ribarm]

Here is one DWG example of using :

[EDIT]
Look for procedure in my later post...
[/EDIT]

Code: [Select]

(defun c:weldplsvertices ( / ss i pl plv plvl vn plvn pld )
  (setq ss (ssget "_:L" '((0 . "LWPOLYLINE"))))
  (setq i -1)
  (while (setq pl (ssname ss (setq i (1+ i))))
    (setq plv (mapcar 'cdr (acet-list-m-assoc 10 (entget pl))))
    (setq plvl (append plv plvl))
  )
  (setq plvl (acet-list-remove-duplicates plvl 1e-4))
  (setq i -1)
  (while (setq pl (ssname ss (setq i (1+ i))))
    (setq plv (mapcar 'cdr (acet-list-m-assoc 10 (entget pl))))
    (foreach v plv
      (setq vn (car (vl-member-if '(lambda ( x ) (equal x v 1e-4)) plvl)))
      (setq plvn (cons vn plvn))
    )
    (setq plvn (reverse plvn))
    (setq pld (entget pl))
    (foreach vn plvn
      (setq pld (subst (cons 10 vn) (car (vl-member-if '(lambda ( x ) (equal (cons 10 vn) x 1e-4)) (acet-list-m-assoc 10 pld))) pld))
    )
    (entmod pld)
    (entupd (cdr (assoc -1 pld)))
  )
  (princ)
)

M.R. (I think that its magnificent...)

[ymg]

Stefan,

I've tried your code on a Voronoi Diagram composed of lines only.

Works nicely!


ymg

[ribarm]

I've figured out how to speed proccess of creating this DWG (no need for step weldplsvertices on exploded pedited multiple projected block between 2 curves - !!! this takes long time):
-hatch (modifying boundaries that hatch can be reproduced multiple times in both directions)
-explode hatch
-pedit "multiple" (ssget "_P")...
-plintav-adv.lsp posted above ...select inner hatch lines and boundary LWPOLYLINE... (note that !!! this hatch needs ADV version as lines inside hatch doesn't touch each other - you can check this when zooming !!! normally you should use plintav.lsp posted here).
-refineboundaryvertices.lsp posted here
-check for match of upper and lower vertices on boundary (use XLINE Vertical and pick lower vertices and then use zc.lsp with zz.lsp posted below inlast post) !!! if vertices doesn't meet in single cross vertex - intersection of XLINE and upper edge boundary LWPOLYLINE, modify them to touch this intersection...
-check lower vertices on boundary (use zc.lsp with zz.lsp posted below inlast post) !!! if vertices doesn't meet in single cross vertex - intersection of XLINE and lower edge boundary LWPOLYLINE, modify them to touch this intersection... Possible to have extra small line passing below lower edge boundary - delete them...
-weldplsvertices.lsp posted above
-explode
-e0l.lsp posted below in last post
-pedit "multiple" select inner lines...
-weldplsvertices.lsp posted above
-explode
-convert inner lines to block
-make side guide lines for next step and erase boundary LWPOLYLINE
-AlignBM.lsp - multiple block align on curves by Gian Paolo Cattaneo (modified AlignHatch.lsp)
 more info here : http://www.cadtutor.net/forum/showthread.php?73335-AlignH-Align-hatch-on-curved-path&highlight=Align+Hatch
-explode
-your code Stefan : intlines2regions.lsp (slower variant - my code posted here should work too and it's much faster and everything is well prepared to this point my version should do the job correct)
-erase outer region boundary(ies)
-2colvalmulthatch.lsp - posted on forum Show Stuff : http://www.theswamp.org/index.php?topic=45751.new#new

Code: [Select]

(defun c:refineboundaryvertices ( / pl vl pll vln vll k vx vy vn vnn vlnl ss i plv plvn pld )
  (while (not pl)
    (setq pl (entsel "\nPick outer boundary LWPOLYLINE"))
    (if (null pl) (prompt "\nMissed, try again...") (setq pl (car pl)))
  )
  (setq vl (acet-list-m-assoc 10 (setq pll (entget pl))))
  (setq vln vl vll vl)
  (setq k -1)
  (repeat (length vl)
    (setq v (nth (setq k (1+ k)) vln))
    (setq vx (cadr v) vy (caddr v))
    (setq vn v vll vl)
    (while (setq vn (vl-member-if '(lambda ( x ) (equal (cadr x) vx 1e-4)) (setq vll (vl-remove vn vll))))
      (progn
        (setq vn (car vn))
        (setq vnn (subst vx (cadr vn) vn))
        (setq vln (subst vnn vn vln))
      )
    )
    (setq vn v vll vl)
    (while (setq vn (vl-member-if '(lambda ( x ) (equal (caddr x) vy 1e-4)) (setq vll (vl-remove vn vll))))
      (progn
        (setq vn (car vn))
        (setq vnn (subst vy (caddr vn) vn))
        (setq vln (subst vnn vn vln))
      )
    )
  )
  (setq vlnl (mapcar '(lambda ( a b ) (list a b)) vln vl))
  (foreach v vlnl
    (setq pll (subst (car v) (cadr v) pll))
  )
  (entmod pll)
  (entupd (cdr (assoc -1 pll)))
  (prompt "\nSelect inner LWPOLYLINES")
  (while (not ss)
    (setq ss (ssget "_:L" '((0 . "LWPOLYLINE"))))
  )
  (setq i -1)
  (while (setq pl (ssname ss (setq i (1+ i))))
    (setq plv (mapcar 'cdr (acet-list-m-assoc 10 (entget pl))))
    (foreach v plv
      (setq vn (car (vl-member-if '(lambda ( x ) (equal x v 1e-4)) (mapcar 'cdr vln))))
      (setq plvn (cons vn plvn))
    )
    (setq plvn (reverse plvn))
    (setq plvn (vl-remove nil plvn))
    (setq pld (entget pl))
    (foreach vn plvn
      (setq pld (subst (cons 10 vn) (car (vl-member-if '(lambda ( x ) (equal (cons 10 vn) x 1e-4)) (acet-list-m-assoc 10 pld))) pld))
    )
    (entmod pld)
    (entupd (cdr (assoc -1 pld)))
  )
  (princ)
)


Code: [Select]

;Create regions in a grid of lines

(defun c:intlines2regions ( / *error* ms ss i lst )
  (vl-load-com)
  (or acDoc (setq acDoc (vla-get-activedocument (vlax-get-acad-object))))
  (setq ms (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace)))
  (vla-startundomark acDoc)
 
  (defun *error* (msg)
    (and
      msg
      (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*EXIT*"))
      (princ (strcat "\nError: " msg))
      )
    (vla-endundomark acDoc)
    (princ)
    )
 
  (if
    (setq ss (ssget '((0 . "LINE"))))
    (progn
      (repeat (setq i (sslength ss))
        (setq lst (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) lst))
      )
      (vlax-invoke ms 'AddRegion lst)
    )
    (princ "\nEmpty selection...Try again...")
  )
  (vla-endundomark acDoc)
  (princ)
)

M.R.

[ribarm]

It took me ab 5 min. for this DWG...

M.R.

[ribarm]

Posted ZIP file is now different and done much faster as above posted procedure changed...

M.R.

(If AlignBM.lsp make mistakes, try picking curve paths from opposite side... All else should be just fine...)

[ymg]

Marko,

Great!, very fast!!!

ymg

[ribarm]

I've just changed plintav-adv.lsp to avoid extending lines to boundary LWPOLYLINE...

Only change is AcExtendNone -> AcExtendBoth in intersectwith sub-function...

It is also advisable that you create boundary in LL point 0,0,0 and pick UR corner while using rectang command... You have to stretch associative hatch to match multiplication pattern you want to use... After that all above stated steps are necessary, and please check upper and lower vertices that match before AlignBM.lsp...

Believe me you want to use this snippet for quick zooming...

Code: [Select]

(defun c:zc ( / c )
  (setq c (getpoint "\nPick center point of maximum zoom"))
  (command "_.zoom" "c" c 0.00000001)
  (princ)
)


Code: [Select]

(defun c:zz nil
  (command "_.zoom" "p")
  (princ)
)

And also this one for erasing 0-length lines :

Code: [Select]

(defun c:e0l ( / ss s i k lin )
  (setq ss (ssget "_:L" '((0 . "LINE"))))
  (setq s (ssadd))
  (setq i -1)
  (setq k 0)
  (while (setq lin (ssname ss (setq i (1+ i))))
    (if (equal (cdr (assoc 10 (entget lin))) (cdr (assoc 11 (entget lin))) 1e-4) (progn (setq k (1+ k)) (entdel lin)))
  )
  (prompt "\nTotal : ")(princ k)(prompt " zero-lines erased")
  (princ)
)

I've put it in my start-up acaddoc.lsp - its so simple, but effective...

Regards, M.R.

[ribarm]

Procedure text updaated - check here :
http://www.theswamp.org/index.php?topic=45754.msg509511#msg509511

M.R.