;;; ==========================================================================
;;; xpoligono_1.1.lsp
;;; ==========================================================================
;;; Rutina de AutoLISP para buscar automáticamente todos los segmentos
;;; (líneas, arcos, splines y polilíneas) conectados extremo a extremo.
;;; Si forman contornos cerrados, los une. Si son contornos abiertos, ofrece
;;; al usuario cerrarlos todos con una única confirmación.
;;; Permite seleccionar una o más entidades 'semilla' en pantalla, y busca
;;; de forma automática en el dibujo todos los elementos conectados a ellas
;;; en su misma capa.
;;; Utiliza el motor nativo de AutoCAD para la unión de polígonos,
;;; garantizando un rendimiento óptimo en dibujos grandes.
;;; Los mensajes interactivos se muestran en español.
;;; ==========================================================================

(vl-load-com)

(defun c:xpoligono_arqmanes ( / *error* acadObj doc modelSpace ss idx ent layerName layersList
                             assocEntry allPolys hasOpen ans closedCount autoClosedCount
                             openJoinedCount oldCmdecho oldPeditAccept entry entList
                             ssLayer existingPolys lastEnt newPolys nextEnt dxf type
                             activeExistingPolys layerPolys ssJoin activeOriginalPolys fuzz ssOpen selectAns seedPts ptStart ptEnd closestPt
                             hasSpline is-poly-closed is-poly-connected-to-seed)
  
  ;; ------------------------------------------------------------------------
  ;; 1. GESTIÓN DE ERRORES Y RESTAURACIÓN
  ;; ------------------------------------------------------------------------
  (defun *error* (errVal)
    (if oldCmdecho (setvar "CMDECHO" oldCmdecho))
    (if (not (member errVal '("Function cancelled" "quit / exit abort" "Función cancelada" "salir / abortar")))
      (princ (strcat "\n[ERROR] XPOLIGONO_ARQMANES interrumpido: " errVal))
    )
    (vla-EndUndoMark doc)
    (princ)
  )

  ;; ------------------------------------------------------------------------
  ;; DETERMINAR SI UNA POLILÍNEA ESTÁ CERRADA (FÍSICA O LÓGICAMENTE)
  ;; ------------------------------------------------------------------------
  (defun is-poly-closed (poly / startPt endPt)
    (and poly
         (or (vlax-curve-isClosed poly)
             (and (setq startPt (vlax-curve-getStartPoint poly))
                  (setq endPt (vlax-curve-getEndPoint poly))
                  (equal startPt endPt 1e-5)
             )
         )
    )
  )

  ;; ------------------------------------------------------------------------
  ;; COMPROBAR SI UN POLÍGONO RESULTANTE ESTÁ CONECTADO A ALGUNA SEMILLA
  ;; ------------------------------------------------------------------------
  (defun is-poly-connected-to-seed (poly seedPts / closestPt matched)
    (setq matched nil)
    (foreach pt seedPts
      (if (and (null matched) pt)
        (progn
          (setq closestPt (vlax-curve-getClosestPointTo poly pt))
          (if (and closestPt (< (distance pt closestPt) 1e-5))
            (setq matched t)
          )
        )
      )
    )
    matched
  )

  ;; ------------------------------------------------------------------------
  ;; 2. INICIALIZACIÓN
  ;; ------------------------------------------------------------------------
  (setq acadObj (vlax-get-acad-object)
        doc (vla-get-ActiveDocument acadObj)
        modelSpace (vla-get-ModelSpace doc)
  )
  
  (vla-StartUndoMark doc)
  
  (setq oldCmdecho (getvar "CMDECHO"))
  (setvar "CMDECHO" 0)

  ;; ------------------------------------------------------------------------
  ;; 3. SELECCIÓN INTERACTIVA DE ELEMENTOS SEMILLA
  ;; ------------------------------------------------------------------------
  (princ "\nSeleccione una o más líneas, arcos, splines o polilíneas semilla: ")
  (setq ss (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE"))))
  (if (null ss)
    (progn
      (exit)
    )
  )

  ;; Convertir la selección en una lista de entidades
  (setq seedsList nil)
  (setq idx 0)
  (while (< idx (sslength ss))
    (setq seedsList (cons (ssname ss idx) seedsList))
    (setq idx (1+ idx))
  )
  (setq seedsList (reverse seedsList))

  ;; ------------------------------------------------------------------------
  ;; 4. AGRUPACIÓN DE SEMILLAS POR CAPA
  ;; ------------------------------------------------------------------------
  (setq layersList nil)
  (setq idx 0)
  (while (< idx (sslength ss))
    (setq ent (ssname ss idx)
          layerName (cdr (assoc 8 (entget ent)))
          assocEntry (assoc layerName layersList)
    )
    (if assocEntry
      (setq layersList (subst (append assocEntry (list ent)) assocEntry layersList))
      (setq layersList (cons (list layerName ent) layersList))
    )
    (setq idx (1+ idx))
  )

  ;; ------------------------------------------------------------------------
  ;; 5. BÚSQUEDA Y UNIÓN DE CONTORNOS POR CAPA
  ;; ------------------------------------------------------------------------
  (setq allPolys nil)
  (setq oldPeditAccept (getvar "PEDITACCEPT"))
  (setvar "PEDITACCEPT" 1)

  (foreach entry layersList
    (setq layerName (car entry)
          entList (cdr entry)
    )
    
    ;; Coleccionar los puntos extremos de todas las semillas en esta capa
    (setq seedPts nil)
    (foreach ent entList
      (setq ptStart (vlax-curve-getStartPoint ent)
            ptEnd (vlax-curve-getEndPoint ent)
      )
      (if ptStart (setq seedPts (cons ptStart seedPts)))
      (if ptEnd (setq seedPts (cons ptEnd seedPts)))
    )
    
    ;; Seleccionar todos los candidatos en la misma capa y espacio
    (setq ssLayer (ssget "_X" (list '(0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE") 
                                     (cons 8 layerName) 
                                     (cons 410 (getvar "CTAB")))))
    
    (if ssLayer
      (progn
        ;; Comprobar si hay splines en el conjunto de candidatos de esta capa
        (setq hasSpline nil)
        (setq idx 0)
        (while (< idx (sslength ssLayer))
          (setq ent (ssname ssLayer idx))
          (if (= (cdr (assoc 0 (entget ent))) "SPLINE")
            (setq hasSpline t)
          )
          (setq idx (1+ idx))
        )
        
        ;; Filtrar polilíneas existentes en esta capa antes del Join
        (setq existingPolys nil)
        (setq idx 0)
        (while (< idx (sslength ssLayer))
          (setq ent (ssname ssLayer idx))
          (if (member (cdr (assoc 0 (entget ent))) '("LWPOLYLINE" "POLYLINE"))
            (setq existingPolys (cons ent existingPolys))
          )
          (setq idx (1+ idx))
        )
        
        (setq lastEnt (entlast))
        
        ;; Ejecutar la unión nativa de todos los candidatos de la capa
        (if hasSpline
          (command "_.pedit" "_M" ssLayer "" 10 "_J" 0.0 "")
          (command "_.pedit" "_M" ssLayer "" "_J" 0.0 "")
        )
        
        ;; Recolectar nuevas polilíneas creadas por el comando pedit
        (setq newPolys nil)
        (if (null lastEnt)
          (setq nextEnt (entnext))
          (setq nextEnt (entnext lastEnt))
        )
        (while nextEnt
          (setq dxf (entget nextEnt)
                type (cdr (assoc 0 dxf))
          )
          (if (member type '("LWPOLYLINE" "POLYLINE"))
            (setq newPolys (cons nextEnt newPolys))
          )
          (setq nextEnt (entnext nextEnt))
        )
        
        ;; Filtrar polilíneas existentes que aún existan en el dibujo
        (setq activeExistingPolys nil)
        (foreach ent existingPolys
          (if (entget ent)
            (setq activeExistingPolys (cons ent activeExistingPolys))
          )
        )
        
        (setq layerPolys (append newPolys activeExistingPolys))
        
        ;; Filtrar para conservar únicamente los contornos resultantes que conectan con nuestras semillas
        (foreach poly layerPolys
          (if (is-poly-connected-to-seed poly seedPts)
            (if (not (member poly allPolys))
              (setq allPolys (cons poly allPolys))
            )
          )
        )
      )
    )
  )

  (setvar "PEDITACCEPT" oldPeditAccept)

  ;; ------------------------------------------------------------------------
  ;; 6. PREGUNTA DE CIERRE GLOBAL (SI HAY ALGÚN CONTORNO ABIERTO)
  ;; ------------------------------------------------------------------------
  ;; 6. CHEQUEAR SI EXISTEN CONTORNOS ABIERTOS Y PROCESAR
  ;; ------------------------------------------------------------------------
  (setq hasOpen nil)
  (foreach ent allPolys
    (if (and (entget ent) (not (is-poly-closed ent)))
      (setq hasOpen t)
    )
  )

  (if (not hasOpen)
    (progn
      ;; Si no hay abiertos, contamos los cerrados e informamos
      (setq closedCount 0)
      (foreach ent allPolys
        (if (and (entget ent) (is-poly-closed ent))
          (setq closedCount (1+ closedCount))
        )
      )
      (if (> closedCount 0)
        (princ (strcat "\n-> Polígonos cerrados unidos directamente: " (itoa closedCount)))
      )
    )
    (progn
      ;; Si hay abiertos, preguntamos y procesamos
      (initget "Si No Linea _Yes No Line")
      (setq ans (getkword "\n¿Quieres cerrar los polígonos que están abiertos? [Si/No/Linea] <Si>: "))
      (if (null ans) (setq ans "Yes"))

      ;; Si el usuario elige "Sí", intentamos hacer un JOIN previo con tolerancia 0.001 de todas las polilíneas abiertas encontradas
      (if (= ans "Yes")
        (progn
          (setq ssJoin (ssadd))
          (foreach ent allPolys
            (if (and (entget ent) (not (is-poly-closed ent)))
              (ssadd ent ssJoin)
            )
          )
          (if (> (sslength ssJoin) 0)
            (progn
              (setq fuzz 0.001)
              
              (setq oldPeditAccept (getvar "PEDITACCEPT"))
              (setvar "PEDITACCEPT" 1)
              
              (setq lastEnt (entlast))
              ;; Usamos PEDIT Join con tolerancia en lugar de JOIN nativo para controlar la distancia máxima de separación
              (command "_.pedit" "_M" ssJoin "" "_J" fuzz "")
              
              (setvar "PEDITACCEPT" oldPeditAccept)
              
              ;; Recolectar nuevas polilíneas creadas por el comando join
              (setq newPolys nil)
              (if (null lastEnt)
                (setq nextEnt (entnext))
                (setq nextEnt (entnext lastEnt))
              )
              (while nextEnt
                (setq dxf (entget nextEnt)
                      type (cdr (assoc 0 dxf))
                )
                (if (member type '("LWPOLYLINE" "POLYLINE"))
                  (setq newPolys (cons nextEnt newPolys))
                )
                (setq nextEnt (entnext nextEnt))
              )
              
              ;; Filtrar originales que aún existan
              (setq activeOriginalPolys nil)
              (foreach ent allPolys
                (if (entget ent)
                  (setq activeOriginalPolys (cons ent activeOriginalPolys))
                )
              )
              
              ;; Reconstruir allPolys
              (setq allPolys nil)
              (foreach ent (append newPolys activeOriginalPolys)
                (if (not (member ent allPolys))
                  (setq allPolys (cons ent allPolys))
                )
              )
            )
          )
        )
      )

      ;; ------------------------------------------------------------------------
      ;; 7. CIERRE DE POLILÍNEAS SEGÚN RESPUESTA
      ;; ------------------------------------------------------------------------
      (setq closedCount 0
            autoClosedCount 0
            openJoinedCount 0
            ssOpen (ssadd)
      )

      (foreach ent allPolys
        (if (vlax-curve-isClosed ent)
          (setq closedCount (1+ closedCount))
          (if (and (setq startPt (vlax-curve-getStartPoint ent))
                   (setq endPt (vlax-curve-getEndPoint ent))
                   (equal startPt endPt 1e-5))
            (progn
              ;; Físicamente cerrado pero lógicamente abierto, lo cerramos lógicamente
              (vla-put-closed (vlax-ename->vla-object ent) :vlax-true)
              (setq closedCount (1+ closedCount))
            )
            (progn
              ;; Abierto
              (if (and (or (= ans "Yes") (= ans "Line")) (> (vlax-curve-getEndParam ent) 1.0))
                (progn
                  (vla-put-closed (vlax-ename->vla-object ent) :vlax-true)
                  (setq autoClosedCount (1+ autoClosedCount))
                )
                (progn
                  (setq openJoinedCount (1+ openJoinedCount))
                  (ssadd ent ssOpen)
                )
              )
            )
          )
        )
      )

      ;; Informar resultados finales (sin prefijo de depuración)
      (if (> closedCount 0)
        (princ (strcat "\n-> Polígonos cerrados unidos directamente: " (itoa closedCount)))
      )
      (if (> autoClosedCount 0)
        (princ (strcat "\n-> Polígonos abiertos cerrados y unidos: " (itoa autoClosedCount)))
      )
      (if (> openJoinedCount 0)
        (princ (strcat "\n-> Polígonos abiertos unidos sin cerrar: " (itoa openJoinedCount)))
      )

      ;; Si se eligió cerrar y quedaron polígonos abiertos, ofrecer seleccionarlos
      (if (and (or (= ans "Yes") (= ans "Line")) (> openJoinedCount 0))
        (progn
          (initget "Si No _Yes No")
          (setq selectAns (getkword "\n¿Desea seleccionar los polígonos que quedaron abiertos? [Si/No] <No>: "))
          (if (null selectAns) (setq selectAns "No"))
          (if (= selectAns "Yes")
            (progn
              (command "_.select" ssOpen "")
              (sssetfirst nil ssOpen)
              (princ (strcat "\nSe han seleccionado " (itoa openJoinedCount) " polígonos abiertos."))
            )
          )
        )
      )
    )
  )

  (setvar "CMDECHO" oldCmdecho)
  (vla-EndUndoMark doc)
  (princ)
)

(princ "\n====================================================================")
(princ "\nRutina de polígonos cargada. Escriba XPOLIGONO_ARQMANES para iniciar.")
(princ "\n====================================================================\n")
(princ)