;;--------------------------------------------------------------
;; TrimLineInside.lsp (2003) John F. Uhden, Cadlantic/CADvantage
;; Dedicated to Mark <aikidoka> 01-18-03
;;--------------------------------------------------------------
;; An example of ActiveX methods to trim a line inside a boundary
;;   without the use of the (command) function.
;; Note that the IntersectWith method requires two graphical objects,
;;   which limits the success of this function to objects being in the
;;   same plane.
;; Arguments:
;;   Boundary - either an entity name or VLA-Object of the trimming object
;;   Line     - either an entity name or VLA-Object of the Line to be trimmed
;; Returns:
;;   T   - if either the Line is already trimmed to the correct intersection,
;;         or a new intersection is applied
;;   nil - if there is any failure
;;
;; This is freeware, intended strictly for educational purposes only,
;  and is not necessarily error free or totally accurate.
;; You're on your own as to its usage and results.
;; Feel free to correct and/or embellish it to your liking/needs.
(defun TrimLineInside (Boundary Line / convert group sort onseg closest layer p1 p2 ips on1 on2)
  (vl-load-com)
  ;; Sub-function to convert an entity name to a VLA-Object
  ;; (if it's not already a VLA-Object),
  ;; or return nil if neither:
  (defun convert (e)
    (cond
      ((= (type e) 'VLA-OBJECT) e)
      ((= (type e) 'ENAME)(vlax-ename->vla-object e))
      (1 (prompt "\nInvalid object."))
    )
  )
  ;; Sub-function to group a list of items into a list of
  ;; multiple lists, each of length N, e.g.
  ;; '(A B C D E F G H I) -> '((A B C)(D E F)(G H I))
  (defun group (lst n / item new)
    (foreach element (reverse lst)
      (setq item (cons element item))
      (if (= (length item) n)
        (setq new (cons item new) item nil)
      )
    )
    new
  )
  ;; Sun-function to sort a list of 2D or 3D points in coordinate order,
  ;; first by the X coordinate and second by the Y coordinate:
  (defun sort (pts)
    (setq pts (vl-sort pts (function (lambda (x y)(< (car x)(car y))))))
    (setq pts (vl-sort pts (function (lambda (x y)(< (cadr x)(cadr y))))))
  )
  ;; Sub-function to determine if a point 'P lies within the segment
  ;; defined by P1 and P2 (all credit due to David Bethel):
  (defun onseg (p p1 p2)
    (equal
      (distance p1 p2)
      (+ (distance p p1)(distance p p2))
      1e-8
    )
  )
  ;; Sub-function to determine the closest 'PT to a given 'P
  ;; within a list of 'PTS:
  (defun closest (p pts / found d dmin pt)
    (while pts
      (setq pt (car pts)
            d (distance p pt)
            pts (cdr pts)
      )
      (if (or (not dmin)(< d dmin))
        (setq dmin d found pt)
      )
    )
    found
  )
  ;; A Stephan Koster approach using a lengthy (and) to
  ;; "evaluate until failure":
  (and
    ;; confirm the Boundary is a VLA-Object
    (setq Boundary (convert Boundary))
    ;; confirm the Line is a VLA-Object
    (setq Line (convert Line))
    ;; Confirm the Boundary is intersectable,
    ;; or prompt that it isn't:
    (or
      (vlax-method-applicable-p Boundary 'IntersectWith)
      (prompt "\nFirst object cannot be intersected.")
    )
    ;; Confirm that the Line is a Line,
    ;; or prompt that it isn't:
    (or
      (= (vlax-get Line 'ObjectName) "AcDbLine")
      (prompt "\nSecond object is not a Line.")
    )
    ;; Obtain the ungrouped list of intersections,
    ;; or prompt that there are none:
    (or
      (setq ips (vlax-invoke Boundary 'Intersectwith Line acExtendOtherEntity))
      (prompt "\nLine does not intersect boundary.")
    )
    ;; Confirm that the Line's layer is unlocked,
    ;; or prompt if it is locked:
    (or
      (=
        (vla-get-lock
          (vlax-ename->vla-object
            (tblobjname "layer" (setq layer (vlax-get Line 'Layer)))
          )
        )
        :vlax-false
      )
      (prompt (strcat "\nLayer " layer " is locked."))
    )
    ;; Group and Sort the intersections into
    ;; consecutive X,Y order:
    (setq ips (sort (group ips 3)))
    ;; Obtain the Line's start point:
    (setq p1  (vlax-get Line 'StartPoint))
    ;; Obtain the Line's end point:
    (setq p2  (vlax-get Line 'EndPoint))
    ;; Because of the (and), treat the following as a collection
    ;; of evaluations ending with T since either of the first
    ;; two evaluations may return nil:
    (progn
      (setq on1 (onseg p1 (car ips)(last ips)))
      (setq on2 (onseg p2 (car ips)(last ips)))
      T
    )
    ;; If the (and) has made it this far, then check the
    ;; possible intersection conditions:
    (cond
      ;; There is only one intersection and it equals
      ;; the Line's start point,
      ;; so return T to indicate the Line is okay:
      ((and (not (cdr ips))(equal (car ips) p1 1e-8))
        T
      )
      ;; There is only one intersection and it equals
      ;; the Line's end point,
      ;; so return T to indicate the Line is okay:
      ((and (not (cdr ips))(equal (car ips) p2 1e-8))
        T
      )
      ;; Equivalent to (= (length IPS) 1), but slightly faster,
      ;; determine that the Line intersects the Boundary only once,
      ;; meaning that there is no way of determining inside vs. outside:
      ((not (cdr ips))
        (prompt "\nLine extension intersects boundary at only one point.")
      )
      ;; Neither end of the Line is inside the Boundary,
      ;; therefor both are outside:
      ((not (or on1 on2))
        (prompt "\nBoth ends of line are outside the boundary.")
      )
      ;; If the Line's start point is inside then modify it
      ;; to the intersection point closest to the end point:
      ((and on1 (not on2))
        (vlax-put Line 'StartPoint (closest p2 ips))
        T
      )
      ;; If the Line's end point is inside then modify it
      ;; to the intersection point closest to the start point:
      ((and on2 (not on1))
        (vlax-put Line 'EndPoint (closest p1 ips))
        T
      )
      ;; Ultimately, if both the Line's start point and end point
      ;; lie on the intersection segment, then both points must be
      ;; on or inside the boundary, so there's nothing to trim:
      (1 (prompt "\nNeither end of the Line is outside boundary."))
    )
  )
)