; HSPLIT v3.0 SAFE
; AutoCAD / AutoCAD LT 2026 (Windows)
;
; TRUE HATCH SPLITTER
;   HSPLIT -> select HATCH -> select OPEN cutter -> done
;
; Safety:
; - Source hatch is NEVER erased until two valid replacement HATCH objects exist.
; - All temporary boundary geometry is moved to _HSPLIT_TMP.
; - Temporary geometry is deleted at the end.
; - Cutter is never modified.
; - If anything fails, any partial new hatch is erased and source hatch remains.
;
; Supports open LINE / LWPOLYLINE / POLYLINE / ARC / SPLINE.
; Preserves source hatch pattern, scale, angle, layer and inner islands when possible.

(vl-load-com)

(defun HS3:safe-getvar (n / r)
  (setq r (vl-catch-all-apply 'getvar (list n)))
  (if (vl-catch-all-error-p r) nil r)
)

(defun HS3:safe-setvar (n v)
  (if (not (null v))
    (vl-catch-all-apply 'setvar (list n v))
  )
)

(defun HS3:entities-after (marker / ss e)
  (setq ss (ssadd))
  (setq e (if marker (entnext marker) (entnext)))
  (while e
    (ssadd e ss)
    (setq e (entnext e))
  )
  ss
)

(defun HS3:delete-ss (ss / i e)
  (if ss
    (progn
      (setq i 0)
      (repeat (sslength ss)
        (setq e (ssname ss i))
        (if (and e (entget e)) (entdel e))
        (setq i (1+ i))
      )
    )
  )
)

(defun HS3:add-ss (src dst / i e)
  (if src
    (progn
      (setq i 0)
      (repeat (sslength src)
        (setq e (ssname src i))
        (if (and e (entget e)) (ssadd e dst))
        (setq i (1+ i))
      )
    )
  )
  dst
)

(defun HS3:ensure-temp-layer (/ doc lays lay r)
  (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))
        lays (vla-get-Layers doc))
  (setq r (vl-catch-all-apply 'vla-Item (list lays "_HSPLIT_TMP")))
  (if (vl-catch-all-error-p r)
    (setq lay (vla-Add lays "_HSPLIT_TMP"))
    (setq lay r)
  )
  (vl-catch-all-apply 'vla-put-LayerOn (list lay :vlax-true))
  (vl-catch-all-apply 'vla-put-Freeze (list lay :vlax-false))
  (vl-catch-all-apply 'vla-put-Lock (list lay :vlax-false))
  (if (vlax-property-available-p lay 'Plottable T)
    (vl-catch-all-apply 'vla-put-Plottable (list lay :vlax-false))
  )
  lay
)

(defun HS3:move-ss-layer (ss lname / i e o)
  (if ss
    (progn
      (setq i 0)
      (repeat (sslength ss)
        (setq e (ssname ss i))
        (if (and e (entget e))
          (progn
            (setq o (vlax-ename->vla-object e))
            (vl-catch-all-apply 'vla-put-Layer (list o lname))
          )
        )
        (setq i (1+ i))
      )
    )
  )
)

(defun HS3:move-entity-layer (e lname / o)
  (if (and e (entget e))
    (progn
      (setq o (vlax-ename->vla-object e))
      (vl-catch-all-apply 'vla-put-Layer (list o lname))
    )
  )
)

(defun HS3:closed-p (e / typ r)
  (if (and e (entget e))
    (progn
      (setq typ (cdr (assoc 0 (entget e))))
      (cond
        ((= typ "CIRCLE") T)
        ((member typ '("LWPOLYLINE" "POLYLINE" "ELLIPSE" "SPLINE"))
         (setq r (vl-catch-all-apply 'vlax-curve-isClosed (list e)))
         (and (not (vl-catch-all-error-p r)) r))
        (T nil)
      )
    )
    nil
  )
)

(defun HS3:open-cutter-p (e / typ r)
  (if (and e (entget e))
    (progn
      (setq typ (cdr (assoc 0 (entget e))))
      (if (not (member typ '("LINE" "ARC" "LWPOLYLINE" "POLYLINE" "SPLINE")))
        nil
        (progn
          (setq r (vl-catch-all-apply 'vlax-curve-isClosed (list e)))
          (if (vl-catch-all-error-p r) T (not r))
        )
      )
    )
    nil
  )
)

(defun HS3:curve-p (e / typ)
  (setq typ (cdr (assoc 0 (entget e))))
  (member typ '("LINE" "ARC" "CIRCLE" "ELLIPSE" "LWPOLYLINE" "POLYLINE" "SPLINE"))
)

(defun HS3:variant->pts (v / data out)
  (setq out '())
  (if (and v (not (vl-catch-all-error-p v)))
    (progn
      (setq data
        (vl-catch-all-apply
          'vlax-safearray->list
          (list (vlax-variant-value v))
        )
      )
      (if (not (vl-catch-all-error-p data))
        (while (>= (length data) 3)
          (setq out (cons (list (car data) (cadr data) (caddr data)) out))
          (setq data (cdddr data))
        )
      )
    )
  )
  (reverse out)
)

(defun HS3:intersections (e1 e2 / o1 o2 r)
  (setq o1 (vlax-ename->vla-object e1)
        o2 (vlax-ename->vla-object e2))
  (setq r (vl-catch-all-apply 'vla-IntersectWith (list o1 o2 0)))
  (HS3:variant->pts r)
)

(defun HS3:dist-on-curve (curve p / cp r)
  (setq cp (vlax-curve-getClosestPointTo curve p))
  (setq r (vl-catch-all-apply 'vlax-curve-getDistAtPoint (list curve cp)))
  (if (vl-catch-all-error-p r) nil r)
)

(defun HS3:unique-dists (lst tol / out d hit x)
  (setq out '())
  (foreach d lst
    (setq hit nil)
    (foreach x out
      (if (<= (abs (- d x)) tol) (setq hit T))
    )
    (if (not hit) (setq out (cons d out)))
  )
  (vl-sort out '<)
)

(defun HS3:collect-crossings (cutter bounds / i be pts p d ds)
  (setq i 0 ds '())
  (repeat (sslength bounds)
    (setq be (ssname bounds i))
    (if (and be (entget be) (HS3:curve-p be))
      (progn
        (setq pts (HS3:intersections cutter be))
        (foreach p pts
          (setq d (HS3:dist-on-curve cutter p))
          (if d (setq ds (cons d ds)))
        )
      )
    )
    (setq i (1+ i))
  )
  (HS3:unique-dists ds 1e-7)
)

(defun HS3:ss-bbox (ss / i e o mn mx pmin pmax xmin ymin xmax ymax)
  (setq i 0 xmin nil ymin nil xmax nil ymax nil)
  (repeat (sslength ss)
    (setq e (ssname ss i))
    (if (and e (entget e))
      (progn
        (setq o (vlax-ename->vla-object e))
        (if
          (not
            (vl-catch-all-error-p
              (vl-catch-all-apply 'vla-GetBoundingBox (list o 'mn 'mx))
            )
          )
          (progn
            (setq pmin (vlax-safearray->list mn)
                  pmax (vlax-safearray->list mx))
            (if (or (null xmin) (< (car pmin) xmin)) (setq xmin (car pmin)))
            (if (or (null ymin) (< (cadr pmin) ymin)) (setq ymin (cadr pmin)))
            (if (or (null xmax) (> (car pmax) xmax)) (setq xmax (car pmax)))
            (if (or (null ymax) (> (cadr pmax) ymax)) (setq ymax (cadr pmax)))
          )
        )
      )
    )
    (setq i (1+ i))
  )
  (if xmin (list xmin ymin xmax ymax) nil)
)

(defun HS3:diag (bb)
  (distance
    (list (nth 0 bb) (nth 1 bb) 0.0)
    (list (nth 2 bb) (nth 3 bb) 0.0)
  )
)

(defun HS3:normal-at-dist (curve dist / par dv dx dy ll)
  (setq par (vlax-curve-getParamAtDist curve dist))
  (setq dv (vlax-curve-getFirstDeriv curve par))
  (setq dx (car dv)
        dy (cadr dv)
        ll (sqrt (+ (* dx dx) (* dy dy))))
  (if (> ll 1e-12)
    (list (/ (- dy) ll) (/ dx ll) 0.0)
    nil
  )
)

(defun HS3:addvec (p v s)
  (list
    (+ (car p) (* (car v) s))
    (+ (cadr p) (* (cadr v) s))
    (+ (if (caddr p) (caddr p) 0.0) (* (caddr v) s))
  )
)

(defun HS3:new-closed-after (marker / ss i e found)
  (setq ss (HS3:entities-after marker)
        i 0
        found nil)
  (while (and (< i (sslength ss)) (null found))
    (setq e (ssname ss i))
    (if (HS3:closed-p e) (setq found e))
    (setq i (1+ i))
  )
  found
)

(defun HS3:boundary-at (pt / marker b)
  (setq marker (entlast))
  (vl-catch-all-apply
    '(lambda () (command "_.-BOUNDARY" pt ""))
  )
  (setq b (HS3:new-closed-after marker))
  (if b (HS3:move-entity-layer b "_HSPLIT_TMP"))
  b
)

(defun HS3:try-auto-boundaries (cutter bounds / ds d1 d2 midD midP n bb dg
                                        factors f off pA pB bA bB done)
  (setq ds (HS3:collect-crossings cutter bounds))
  (if (< (length ds) 2)
    nil
    (progn
      (setq d1 (car ds)
            d2 (car (last ds))
            midD (/ (+ d1 d2) 2.0)
            midP (vlax-curve-getPointAtDist cutter midD)
            n (HS3:normal-at-dist cutter midD)
            bb (HS3:ss-bbox bounds))
      (if (and midP n bb)
        (progn
          (setq dg (HS3:diag bb)
                factors '(0.002 0.004 0.008 0.015 0.03 0.06)
                done nil
                bA nil
                bB nil)
          (foreach f factors
            (if (not done)
              (progn
                (setq off (* dg f)
                      pA (HS3:addvec midP n off)
                      pB (HS3:addvec midP n (- off)))
                (setq bA (HS3:boundary-at pA))
                (setq bB (HS3:boundary-at pB))
                (if (and bA bB (/= bA bB))
                  (setq done T)
                  (progn
                    (if (and bA (entget bA)) (entdel bA))
                    (if (and bB (entget bB)) (entdel bB))
                    (setq bA nil bB nil)
                  )
                )
              )
            )
          )
          (if done (list bA bB) nil)
        )
        nil
      )
    )
  )
)

(defun HS3:curve-area (e / o r)
  (setq o (vlax-ename->vla-object e))
  (setq r (vl-catch-all-apply 'vla-get-Area (list o)))
  (if (vl-catch-all-error-p r) 0.0 (abs r))
)

(defun HS3:largest-curve (ss / i e a best besta)
  (setq i 0 best nil besta -1.0)
  (repeat (sslength ss)
    (setq e (ssname ss i))
    (if (and e (entget e) (HS3:closed-p e))
      (progn
        (setq a (HS3:curve-area e))
        (if (> a besta)
          (setq besta a best e)
        )
      )
    )
    (setq i (1+ i))
  )
  best
)

(defun HS3:point-inside-curve (pt boundary bbox / ray xfar yoff pts count)
  ; Even/odd ray test.
  (setq xfar (+ (nth 2 bbox) (* 5.0 (max 1.0 (- (nth 2 bbox) (nth 0 bbox))))))
  (setq yoff (+ (cadr pt) 1e-7))
  (setq ray
    (entmakex
      (list
        '(0 . "LINE")
        (cons 8 "_HSPLIT_TMP")
        (cons 10 (list (car pt) yoff (if (caddr pt) (caddr pt) 0.0)))
        (cons 11 (list xfar yoff (if (caddr pt) (caddr pt) 0.0)))
      )
    )
  )
  (setq pts (HS3:intersections ray boundary))
  (entdel ray)
  (setq count (length pts))
  (= 1 (rem count 2))
)

(defun HS3:collect-inner-loops-for-side (generated outerGenerated sideBoundary / bb i e p out)
  (setq out '()
        bb (HS3:ss-bbox generated)
        i 0)
  (repeat (sslength generated)
    (setq e (ssname generated i))
    (if (and e
             (entget e)
             (HS3:closed-p e)
             (/= e outerGenerated))
      (progn
        (setq p (vlax-curve-getStartPoint e))
        (if (HS3:point-inside-curve p sideBoundary bb)
          (setq out (cons e out))
        )
      )
    )
    (setq i (1+ i))
  )
  (reverse out)
)

(defun HS3:current-space (doc)
  (cond
    ((= 1 (getvar "TILEMODE")) (vla-get-ModelSpace doc))
    ((> (getvar "CVPORT") 1) (vla-get-ModelSpace doc))
    (T (vla-get-PaperSpace doc))
  )
)

(defun HS3:getprop (o prop fallback / r)
  (setq r (vl-catch-all-apply 'vlax-get-property (list o prop)))
  (if (vl-catch-all-error-p r) fallback r)
)

(defun HS3:setprop-if (o prop val)
  (if (and (not (null val)) (vlax-property-available-p o prop T))
    (vl-catch-all-apply 'vlax-put-property (list o prop val))
  )
)

(defun HS3:append-loop (hObj method ent / arr obj r)
  (setq obj (vlax-ename->vla-object ent))
  (setq arr (vlax-make-safearray vlax-vbObject '(0 . 0)))
  (vlax-safearray-put-element arr 0 obj)
  (setq r (vl-catch-all-apply method (list hObj arr)))
  (not (vl-catch-all-error-p r))
)

(defun HS3:create-hatch (src outer innerList / doc sp srcObj ptype pname hObj ok e
                                sc ang dbl lay col lw trn ent)
  (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))
        sp (HS3:current-space doc)
        srcObj (vlax-ename->vla-object src))

  (setq ptype (HS3:getprop srcObj 'PatternType nil)
        pname (HS3:getprop srcObj 'PatternName nil))

  (if (or (null ptype) (null pname))
    nil
    (progn
      (setq hObj
        (vl-catch-all-apply
          'vla-AddHatch
          (list sp ptype pname :vlax-false)
        )
      )
      (if (vl-catch-all-error-p hObj)
        nil
        (progn
          (setq ok (HS3:append-loop hObj 'vla-AppendOuterLoop outer))
          (if (not ok)
            (progn
              (vl-catch-all-apply 'vla-Delete (list hObj))
              nil
            )
            (progn
              ; Append original islands that belong to this side.
              (foreach e innerList
                (HS3:append-loop hObj 'vla-AppendInnerLoop e)
              )

              ; Copy important appearance properties explicitly.
              (setq sc  (HS3:getprop srcObj 'PatternScale nil)
                    ang (HS3:getprop srcObj 'PatternAngle nil)
                    dbl (HS3:getprop srcObj 'PatternDouble nil)
                    lay (HS3:getprop srcObj 'Layer nil)
                    col (HS3:getprop srcObj 'Color nil)
                    lw  (HS3:getprop srcObj 'Lineweight nil)
                    trn (HS3:getprop srcObj 'EntityTransparency nil))

              (HS3:setprop-if hObj 'PatternScale sc)
              (HS3:setprop-if hObj 'PatternAngle ang)
              (HS3:setprop-if hObj 'PatternDouble dbl)
              (HS3:setprop-if hObj 'Layer lay)
              (HS3:setprop-if hObj 'Color col)
              (HS3:setprop-if hObj 'Lineweight lw)
              (HS3:setprop-if hObj 'EntityTransparency trn)

              (vl-catch-all-apply 'vla-Update (list hObj))
              (setq ent (vlax-vla-object->ename hObj))

              ; HARD validation: resulting entity must really be a HATCH.
              (if (and ent
                       (entget ent)
                       (= "HATCH" (cdr (assoc 0 (entget ent)))))
                ent
                (progn
                  (vl-catch-all-apply 'vla-Delete (list hObj))
                  nil
                )
              )
            )
          )
        )
      )
    )
  )
)

(defun HS3:valid-hatch-p (e / d)
  (and e
       (setq d (entget e))
       (= "HATCH" (cdr (assoc 0 d)))
       (assoc 2 d))
)

(defun HS3:restore ()
  (if *HS3-isolated*
    (progn
      (vl-catch-all-apply
        '(lambda () (command "_.UNISOLATEOBJECTS"))
      )
      (setq *HS3-isolated* nil)
    )
  )
  (HS3:safe-setvar "HPBOUND" *HS3-old-hpbound*)
  (HS3:safe-setvar "HPASSOC" *HS3-old-hpassoc*)
  (HS3:safe-setvar "CMDECHO" *HS3-old-cmdecho*)
)

(defun HS3:cleanup-partials ()
  (if (and *HS3-new1* (entget *HS3-new1*)) (entdel *HS3-new1*))
  (if (and *HS3-new2* (entget *HS3-new2*)) (entdel *HS3-new2*))
  (if *HS3-sidebounds*
    (foreach e *HS3-sidebounds*
      (if (and e (entget e)) (entdel e))
    )
  )
  (if *HS3-generated* (HS3:delete-ss *HS3-generated*))
  (setq *HS3-new1* nil
        *HS3-new2* nil
        *HS3-sidebounds* nil
        *HS3-generated* nil)
)

(defun HS3:error (msg)
  (HS3:restore)
  (HS3:cleanup-partials)
  (if (and msg (/= msg "Function cancelled"))
    (princ (strcat "\nHSPLIT error: " msg))
  )
  (princ)
)

(defun c:HSPLIT (/ *error* doc hatch cutter marker generated isoSS pair
                   b1 b2 outer inner1 inner2 h1 h2)
  (vl-load-com)

  (setq *error* HS3:error)
  (setq *HS3-isolated* nil
        *HS3-generated* nil
        *HS3-sidebounds* nil
        *HS3-new1* nil
        *HS3-new2* nil)

  (setq *HS3-old-hpbound* (HS3:safe-getvar "HPBOUND")
        *HS3-old-hpassoc* (HS3:safe-getvar "HPASSOC")
        *HS3-old-cmdecho* (HS3:safe-getvar "CMDECHO"))

  (setvar "CMDECHO" 0)
  (HS3:safe-setvar "HPBOUND" 1)
  (HS3:safe-setvar "HPASSOC" 0)

  (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
  (HS3:ensure-temp-layer)

  (princ "\nHSPLIT v3.0 SAFE - select hatch, then cutter.")

  (setq hatch (car (entsel "\nSelect HATCH to split: ")))

  (cond
    ((null hatch)
     (princ "\nNothing selected."))

    ((/= "HATCH" (cdr (assoc 0 (entget hatch))))
     (princ "\nSelected object is not a HATCH."))

    (T
     (setq cutter
       (car (entsel "\nSelect OPEN dividing line/polyline/arc/spline: ")))

     (cond
       ((null cutter)
        (princ "\nNo cutter selected."))

       ((not (HS3:open-cutter-p cutter))
        (princ "\nCutter must be an OPEN curve."))

       (T
        ; 1) Generate source hatch boundaries as TEMP geometry.
        (setq marker (entlast))
        (vl-catch-all-apply
          '(lambda () (command "_.HATCHGENERATEBOUNDARY" hatch ""))
        )
        (setq generated (HS3:entities-after marker))
        (setq *HS3-generated* generated)
        (HS3:move-ss-layer generated "_HSPLIT_TMP")

        (if (or (null generated) (= (sslength generated) 0))
          (princ "\nCould not generate source hatch boundary.")
          (progn
            ; 2) Isolate only temp boundaries + cutter.
            (setq isoSS (ssadd))
            (HS3:add-ss generated isoSS)
            (ssadd cutter isoSS)

            (vl-catch-all-apply
              '(lambda () (command "_.ISOLATEOBJECTS" isoSS ""))
            )
            (setq *HS3-isolated* T)

            ; 3) Build two side boundaries automatically.
            (setq pair (HS3:try-auto-boundaries cutter generated))

            (if (and pair (= (length pair) 2))
              (progn
                (setq b1 (car pair)
                      b2 (cadr pair))
                (setq *HS3-sidebounds* pair)

                ; Determine original outer loop and inner islands.
                (setq outer (HS3:largest-curve generated))
                (setq inner1 (HS3:collect-inner-loops-for-side generated outer b1))
                (setq inner2 (HS3:collect-inner-loops-for-side generated outer b2))

                ; Restore drawing visibility before creating final hatch objects.
                (HS3:restore)

                ; 4) Create TWO real hatch objects, source still untouched.
                (setq h1 (HS3:create-hatch hatch b1 inner1))
                (setq *HS3-new1* h1)
                (setq h2 (HS3:create-hatch hatch b2 inner2))
                (setq *HS3-new2* h2)

                ; 5) Commit ONLY if both pass hard validation.
                (if (and (HS3:valid-hatch-p h1)
                         (HS3:valid-hatch-p h2))
                  (progn
                    (entupd h1)
                    (entupd h2)
                    (vl-catch-all-apply 'vla-Regen (list doc 1))

                    ; Original hatch deleted at the final commit point only.
                    (entdel hatch)

                    ; Remove temporary geometry.
                    (if (and b1 (entget b1)) (entdel b1))
                    (if (and b2 (entget b2)) (entdel b2))
                    (setq *HS3-sidebounds* nil)

                    (HS3:delete-ss generated)
                    (setq *HS3-generated* nil)

                    ; New hatches are final, don't let cleanup remove them.
                    (setq *HS3-new1* nil
                          *HS3-new2* nil)

                    (princ
                      "\nSUCCESS: source hatch replaced by TWO real independent HATCH objects."
                    )
                  )
                  (progn
                    (HS3:cleanup-partials)
                    (princ
                      "\nSplit aborted safely: two valid replacement HATCH objects were not created."
                    )
                    (princ
                      "\nOriginal hatch was NOT deleted."
                    )
                  )
                )
              )
              (progn
                (HS3:restore)
                (HS3:cleanup-partials)
                (princ
                  "\nSplit aborted safely: could not form two closed regions automatically."
                )
                (princ
                  "\nOriginal hatch was NOT deleted."
                )
              )
            )
          )
        )
       )
     )
    )
  )

  (HS3:restore)
  (setq *error* nil)
  (princ)
)

(princ "\nHSPLIT v3.0 SAFE loaded. Type HSPLIT.")
(princ)