;;; ---------------------------------------------------------------------------
;;; SkewBox.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; Draws a rectangle from THREE picked points, at any rotation.
;;;
;;; The standard RECTANGLE command only draws rectangles aligned to the current
;;; UCS. To get one at an angle you have to draw it square and then rotate it,
;;; which means knowing the angle in advance.
;;;
;;; Here the first two points define one side - so its direction sets the
;;; rotation - and the third sets the depth, measured perpendicular to that
;;; side. Snap the first two points to existing geometry and the rectangle
;;; aligns to it exactly.
;;;
;;; COMMANDS
;;;   SKEWBOX      - three picks, no preview
;;;   SKEWBOXLIVE  - shows the rectangle updating as you move the third point,
;;;                  with full object snap support
;;;
;;; IN THE LIVE VERSION, WHILE PICKING THE THIRD POINT
;;;   type a number  - sets the depth exactly rather than picking it
;;;   type @x,y      - enters a relative coordinate
;;;   type END, MID  - any object snap name, abbreviated as far as you like
;;;   F3             - toggles running object snaps
;;;   ENTER          - finishes
;;;
;;; Works correctly in any UCS and any view.
;;;
;;; HOW THE GEOMETRY WORKS
;;; A temporary coordinate system is built whose Z axis runs along the first
;;; side. Working in that system, the depth becomes a simple change in one
;;; ordinate - which is what allows the same arithmetic to serve every rotation
;;; and every UCS without special cases.
;;; ---------------------------------------------------------------------------

(vl-load-com)

;; ---------------------------------------------------------------------------
;; SkewBox:Doc  /  SkewBox:App  -  cached COM objects
;; ---------------------------------------------------------------------------
(defun SkewBox:Doc nil
    (eval (list 'defun 'SkewBox:Doc 'nil
                (vla-get-activedocument (vlax-get-acad-object))
          )
    )
    (SkewBox:Doc)
)

(defun SkewBox:App nil
    (eval (list 'defun 'SkewBox:App 'nil (vlax-get-acad-object)))
    (SkewBox:App)
)

;;; ===========================================================================
;;; OBJECT SNAP SUPPORT FOR grread
;;;
;;; grread reads raw input and gives no object snap of its own, so the whole of
;;; this section exists to reinstate it: finding the nearest valid snap point,
;;; drawing the correct marker, and interpreting typed snap names.
;;;
;;; None of it is specific to rectangles - it is a general utility, kept here
;;; so this file stays self-contained.
;;; ===========================================================================

;; ---------------------------------------------------------------------------
;; SkewBox:SnapSymbols
;; ---------------------------------------------------------------------------
;; Returns the vector lists that draw each object snap marker, sized to p
;; pixels: the endpoint square, the midpoint triangle, the centre circle, and
;; so on.
;;
;; Each entry is (snapBitCode point point point point ...), the points being
;; consecutive pairs describing line segments. The circle c is built once as
;; twelve segments and reused by the several markers that need one.
;; ---------------------------------------------------------------------------
(defun SkewBox:SnapSymbols ( p / -p -q -r a c i l q r )
    (setq -p (- p) q (1+  p)
          -q (- q) r (+ 2 p)
          -r (- r) i (/ pi 6.0)
           a 0.0
    )
    (repeat 12
        (setq l (cons (list (* r (cos a)) (* r (sin a))) l)
              a (- a i)
        )
    )
    (setq c (apply 'append (mapcar 'list (cons (last l) l) l)))
    (list
        ;; 1 - endpoint: a square, drawn twice for a heavier line
        (list 1
            (list -p -p) (list p -p) (list p -p) (list p p) (list p p) (list -p p) (list -p p) (list -p -p)
            (list -q -q) (list q -q) (list q -q) (list q q) (list q q) (list -q q) (list -q q) (list -q -q)
        )
        ;; 2 - midpoint: a triangle
        (list 2
            (list -r -q) (list 0  r) (list 0  r) (list r -q)
            (list -p -p) (list p -p) (list p -p) (list 0  p) (list 0  p) (list -p -p)
            (list -q -q) (list q -q) (list q -q) (list 0  q) (list 0  q) (list -q -q)
        )
        (cons 4 c)                                              ; centre: a circle
        (vl-list* 8 (list -r -r) (list r r) (list r -r) (list -r r) c)  ; node: circle and cross
        ;; 16 - quadrant: a diamond
        (list 16
            (list p 0) (list 0 p) (list 0 p) (list -p 0) (list -p 0) (list 0 -p) (list 0 -p) (list p 0)
            (list q 0) (list 0 q) (list 0 q) (list -q 0) (list -q 0) (list 0 -q) (list 0 -q) (list q 0)
            (list r 0) (list 0 r) (list 0 r) (list -r 0) (list -r 0) (list 0 -r) (list 0 -r) (list r 0)
        )
        ;; 32 - intersection: a cross
        (list 32
            (list  r r) (list -r -r) (list  r q) (list -q -r) (list  q r) (list -r -q)
            (list -r r) (list  r -r) (list -q r) (list  r -q) (list -r q) (list  q -r)
        )
        ;; 64 - insertion: interlocking squares
        (list 64
            '( 0  1) (list  0  p) (list  0  p) (list -p  p) (list -p  p) (list -p -1) (list -p -1) '( 0 -1)
            '( 0 -1) (list  0 -p) (list  0 -p) (list  p -p) (list  p -p) (list  p  1) (list  p  1) '( 0  1)
            '( 1  2) (list  1  q) (list  1  q) (list -q  q) (list -q  q) (list -q -2) (list -q -2) '(-1 -2)
            '(-1 -2) (list -1 -q) (list -1 -q) (list  q -q) (list  q -q) (list  q  2) (list  q  2) '( 1  2)
        )
        ;; 128 - perpendicular
        (list 128
            (list (1+ -p) 0) '(0 0) '(0 0) (list 0 (1+ -p))
            (list (1+ -p) 1) '(1 1) '(1 1) (list 1 (1+ -p))
            (list -p q) (list -p -p) (list -p -p) (list q -p)
            (list -q q) (list -q -q) (list -q -q) (list q -q)
        )
        (vl-list* 256 (list -r r) (list r r) (list -r (1+ r)) (list r (1+ r)) c)  ; tangent
        ;; 512 - nearest: an hourglass
        (list 512
            (list -p -p) (list  p -p) (list -p  p) (list p p) (list -q -q) (list  q -q)
            (list  q -q) (list -q  q) (list -q  q) (list q q) (list  q  q) (list -q -q)
        )
        ;; 2048 - apparent intersection: a cross with a dotted extension
        (list 2048
            (list   -p     -p) (list    p      p) (list   -p      p) (list    p     -p)
            (list (+ p 05) -p) (list (+ p 06) -p) (list (+ p 05) -q) (list (+ p 06) -q)
            (list (+ p 09) -p) (list (+ p 10) -p) (list (+ p 09) -q) (list (+ p 10) -q)
            (list (+ p 13) -p) (list (+ p 14) -p) (list (+ p 13) -q) (list (+ p 14) -q)
            (list -p -p) (list p -p) (list p -p) (list p p) (list p p) (list -p p) (list -p p) (list -p -p)
            (list -q -q) (list q -q) (list q -q) (list q q) (list q q) (list -q q) (list -q q) (list -q -q)
        )
        ;; 8192 - parallel: two slashes
        (list 8192 (list r 1) (list -r -q) (list r 0) (list -r -r) (list r q) (list -r -1) (list r r) (list -r 0))
    )
)

;; ---------------------------------------------------------------------------
;; SkewBox:DisplaySnap
;; ---------------------------------------------------------------------------
;; Draws a snap marker at a point, scaled so it stays the same apparent size at
;; any zoom - which is what the ratio of view size to screen size computes.
;; ---------------------------------------------------------------------------
(defun SkewBox:DisplaySnap ( pnt lst col / scl )
    (setq scl (/ (getvar 'viewsize) (cadr (getvar 'screensize)))
          pnt (trans pnt 1 2)
    )
    (grvecs (cons col lst)
        (list (list scl 0.0 0.0 (car  pnt))
              (list 0.0 scl 0.0 (cadr pnt))
              (list 0.0 0.0 scl 0.0)
             '(0.0 0.0 0.0 1.0)
        )
    )
)

;; ---------------------------------------------------------------------------
;; Colour conversion - AutoCAD stores the AutoSnap colour as an OLE value in
;; the registry, but grvecs needs an ACI index.
;; ---------------------------------------------------------------------------

;; Splits an OLE colour into its red, green and blue components.
(defun SkewBox:OleToRgb ( c )
    (mapcar (function (lambda ( x ) (lsh (lsh (fix c) x) -24))) '(24 16 8))
)

;; Converts RGB to the nearest ACI index, using AutoCAD's own colour object -
;; which is released explicitly, since a COM object left alive persists for the
;; rest of the session.
(defun SkewBox:RgbToAci ( r g b / c o )
    (if (setq o (vla-getinterfaceobject (SkewBox:App)
                    (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))
                )
        )
        (progn
            (setq c (vl-catch-all-apply
                        (function (lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o)))
                    )
            )
            (vlax-release-object o)
            (if (vl-catch-all-error-p c)
                (progn (princ (strcat "\nColour conversion failed: " (vl-catch-all-error-message c))) 1)
                c
            )
        )
        1
    )
)

(defun SkewBox:OleToAci ( c )
    (apply 'SkewBox:RgbToAci (SkewBox:OleToRgb c))
)

;; ---------------------------------------------------------------------------
;; SkewBox:SnapFunction
;; ---------------------------------------------------------------------------
;; Returns a function taking (point osmodeBits) that snaps the point and draws
;; the marker, or returns the point unchanged if nothing snapped.
;;
;; The returned function is BUILT rather than written directly, so that the
;; snap symbol table and the marker colour are computed once when the function
;; is created rather than on every mouse movement - which matters when it is
;; called on every frame of a drag.
;;
;; Every snap mode enabled in the bit code is tried, the results sorted by
;; distance, and the nearest taken - which is how AutoCAD's own behaviour is
;; reproduced. Bit 16384 means snaps are off, in which case the point passes
;; straight through.
;; ---------------------------------------------------------------------------
(defun SkewBox:SnapFunction ( )
    (eval
        (list 'lambda '( p o / q )
            (list 'if '(zerop (logand 16384 o))
                (list 'if
                   '(setq q
                        (cdar
                            (vl-sort
                                (vl-remove-if 'null
                                    (mapcar
                                        (function
                                            (lambda ( a / b )
                                                (if (and (= (car a) (logand (car a) o))
                                                         (setq b (osnap p (cdr a)))
                                                    )
                                                    (list (distance p b) b (car a))
                                                )
                                            )
                                        )
                                       '(
                                            (0001 . "_end") (0002 . "_mid") (0004 . "_cen")
                                            (0008 . "_nod") (0016 . "_qua") (0032 . "_int")
                                            (0064 . "_ins") (0128 . "_per") (0256 . "_tan")
                                            (0512 . "_nea") (2048 . "_app") (8192 . "_par")
                                        )
                                    )
                                )
                               '(lambda ( a b ) (< (car a) (car b)))
                            )
                        )
                    )
                    (list 'SkewBox:DisplaySnap '(car q)
                        (list 'cdr
                            (list 'assoc '(cadr q)
                                (list 'quote
                                    (SkewBox:SnapSymbols
                                        (atoi (cond ((getenv "AutoSnapSize")) ("5")))
                                    )
                                )
                            )
                        )
                        (SkewBox:OleToAci
                            (if (= 1 (getvar 'cvport))
                                (atoi (cond ((getenv "Layout AutoSnap Color")) ("117761")))
                                (atoi (cond ((getenv  "Model AutoSnap Color")) ("104193")))
                            )
                        )
                    )
                )
               '(cond ((car q)) (p))
            )
        )
    )
)

;; ---------------------------------------------------------------------------
;; SkewBox:ParsePoint
;; ---------------------------------------------------------------------------
;; Interprets typed coordinate text, returning a point or nil.
;;
;; Text beginning with @ is relative to the base point; anything else is
;; absolute. Two or three comma-separated numbers are accepted.
;; ---------------------------------------------------------------------------
(defun SkewBox:ParsePoint ( bpt str / SkewBox:Split lst )

    (defun SkewBox:Split ( str / pos )
        (if (setq pos (vl-string-position 44 str))
            (cons (substr str 1 pos) (SkewBox:Split (substr str (+ pos 2))))
            (list str)
        )
    )

    (if (wcmatch str "`@*")
        (setq str (substr str 2))
        (setq bpt '(0.0 0.0 0.0))
    )

    (if (and (setq lst (mapcar 'distof (SkewBox:Split str)))
             (vl-every 'numberp lst)
             (< 1 (length lst) 4)
        )
        (mapcar '+ bpt lst)
    )
)

;; ---------------------------------------------------------------------------
;; SkewBox:SnapMode
;; ---------------------------------------------------------------------------
;; Converts a typed snap name to its bit code, matching on any leading
;; abbreviation - so "e", "end" and "endpoint" all give 1, exactly as at a
;; normal AutoCAD prompt. The matching " of " or " to " is echoed.
;; ---------------------------------------------------------------------------
(defun SkewBox:SnapMode ( str )
    (vl-some
        (function
            (lambda ( x )
                (if (wcmatch (car x) (strcat (strcase str t) "*"))
                    (progn (princ (cadr x)) (caddr x))
                )
            )
        )
       '(
            ("endpoint"      " of " 00001)
            ("midpoint"      " of " 00002)
            ("center"        " of " 00004)
            ("node"          " of " 00008)
            ("quadrant"      " of " 00016)
            ("intersection"  " of " 00032)
            ("insert"        " of " 00064)
            ("perpendicular" " to " 00128)
            ("tangent"       " to " 00256)
            ("nearest"       " to " 00512)
            ("appint"        " of " 02048)
            ("parallel"      " to " 08192)
            ("none"          ""     16384)
        )
    )
)

;;; ===========================================================================
;;; THE COMMAND ITSELF
;;; ===========================================================================

;; ---------------------------------------------------------------------------
;; SkewBox:Run
;; ---------------------------------------------------------------------------
;; dyn - [boolean] T for the live preview version
;; ---------------------------------------------------------------------------
(defun SkewBox:Run ( dyn / *error* vars vals gr1 gr2 len lst msg ocs osf osm
                           pt1 pt2 pt3 pt4 pt5 pt6 str tmp vec )

    (setq vars '("CMDECHO" "OSMODE")
          vals (mapcar 'getvar vars)
    )

    (defun SkewBox:Restore ( )
        (redraw)
        (mapcar 'setvar vars vals)
        (while (= 8 (logand 8 (getvar 'undoctl)))
            (command "_.UNDO" "_End")
            (vl-catch-all-apply '(lambda ( ) (*pop-error-mode*)) '())
        )
        (princ)
    )

    (defun *error* ( msg )
        (SkewBox:Restore)
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** SKEWBOX error: " msg " **"))
        )
        (princ)
    )

    (setvar "CMDECHO" 0)

    (if
        (and
            (setq pt1 (getpoint "\nSpecify first corner: "))
            (setq pt2 (getpoint pt1 "\nSpecify second corner (this side sets the rotation): "))
            (or dyn (setq pt3 (getpoint pt1 "\nSpecify depth: ")))

            ;; ---------------------------------------------------------------
            ;; Build the working coordinate system. vec is the direction of the
            ;; first side, used as the Z axis of a temporary system; ocs is the
            ;; current UCS normal, needed when the polyline is finally created.
            ;;
            ;; In the vec system, moving perpendicular to the first side is
            ;; just a change in the first two ordinates, and the third ordinate
            ;; distinguishes the two ends of that side - which is what makes
            ;; the corner arithmetic below so short.
            ;; ---------------------------------------------------------------
            (setq vec (trans (mapcar '- pt2 pt1) 1 0 t)
                  ocs (trans '(0.0 0.0 1.0) 1 0 t)
                  pt4 (trans pt1 1 vec)
                  pt5 (trans pt2 1 vec)
            )

            (if dyn
                ;; -----------------------------------------------------------
                ;; Live preview loop.
                ;; -----------------------------------------------------------
                (progn
                    (setq osf (SkewBox:SnapFunction)
                          osm (getvar 'osmode)
                          msg "\nSpecify depth, or type a distance: "
                          str ""
                    )
                    (princ msg)
                    (while
                        (progn
                            (setq gr1 (grread t 15 0)
                                  gr2 (cadr gr1)
                                  gr1 (car  gr1)
                            )
                            (cond
                                ;; Mouse moved (5) or clicked (3): snap, then
                                ;; draw the four preview edges.
                                (   (or (= 5 gr1) (= 3 gr1))
                                    (redraw)
                                    (osf gr2 osm)
                                    (setq pt6 (trans gr2 1 vec))
                                    (mapcar (function (lambda ( a b ) (grdraw a b 1 1)))
                                        (setq lst
                                            (list pt1 pt2
                                                (trans (list (car pt6) (cadr pt6) (caddr pt5)) vec 1)
                                                (trans (list (car pt6) (cadr pt6) (caddr pt4)) vec 1)
                                            )
                                        )
                                        (cons (last lst) lst)
                                    )
                                    (= 5 gr1)          ; keep looping on movement, stop on click
                                )

                                ;; A keypress.
                                (   (= 2 gr1)
                                    (cond
                                        ;; F3 toggles running snaps by flipping
                                        ;; OSMODE's 16384 "off" bit.
                                        (   (= 6 gr2)
                                            (if (zerop (logand 16384
                                                        (setq osm (setvar 'osmode (boole 6 16384 (getvar 'osmode))))))
                                                (princ "\n<Osnap on>")
                                                (princ "\n<Osnap off>")
                                            )
                                            (princ msg)
                                        )

                                        ;; Backspace: erase the last character
                                        ;; from the screen and from the buffer.
                                        (   (= 8 gr2)
                                            (if (< 0 (strlen str))
                                                (progn
                                                    (princ "\010\040\010")
                                                    (setq str (substr str 1 (1- (strlen str))))
                                                )
                                            )
                                            t
                                        )

                                        ;; A printable character: echo and buffer.
                                        (   (< 32 gr2 127)
                                            (setq str (strcat str (princ (chr gr2))))
                                        )

                                        ;; Enter or space: interpret what was typed.
                                        (   (member gr2 '(13 32))
                                            (cond
                                                (   (= "" str) nil)

                                                ;; A coordinate.
                                                (   (setq gr2 (SkewBox:ParsePoint pt1 str))
                                                    (setq osm 16384)
                                                    nil
                                                )

                                                ;; A snap mode name.
                                                (   (setq tmp (SkewBox:SnapMode str))
                                                    (setq osm tmp
                                                          str ""
                                                    )
                                                )

                                                ;; A plain distance: scale the
                                                ;; current cursor direction to
                                                ;; that exact length.
                                                (   (and pt6
                                                         (setq len (distof str))
                                                         (setq pt6 (list (car pt6) (cadr pt6) (caddr pt4)))
                                                         (not (equal 0.0 (setq tmp (distance pt4 pt6)) 1e-8))
                                                    )
                                                    (setq gr2 (trans (mapcar (function (lambda ( a b ) (+ b (* len (/ (- a b) tmp)))))
                                                                             pt6 pt4)
                                                                     vec 1)
                                                          osm 16384
                                                    )
                                                    nil
                                                )

                                                (   (setq str "")
                                                    (princ (strcat "\nA point or distance is required." msg))
                                                )
                                            )
                                        )
                                    )
                                )
                            )
                        )
                    )
                    (if (listp gr2)
                        (setq pt6 (trans (osf gr2 osm) 1 vec))
                    )
                )
                (setq pt6 (trans pt3 1 vec))
            )
        )

        (progn
            ;; AutoCAD 2015 and later refuse (command) inside an *error* handler
            ;; unless the routine says up front that it will use one. Restore does,
            ;; to close this undo group. The declaring call is absent on older
            ;; releases, so it is wrapped rather than tested for.
            (vl-catch-all-apply '(lambda ( ) (*push-error-using-command*)) '())
            (command "_.UNDO" "_Begin")
            ;; The two far corners share the third point's first two ordinates
            ;; and take the third ordinate from each end of the first side.
            (entmake
                (list
                   '(000 . "LWPOLYLINE")
                   '(100 . "AcDbEntity")
                   '(100 . "AcDbPolyline")
                   '(090 . 4)
                   '(070 . 1)                     ; closed
                    (cons 038 (caddr (trans pt1 1 ocs)))
                    (cons 010 (trans pt1 1 ocs))
                    (cons 010 (trans pt2 1 ocs))
                    (cons 010 (trans (list (car pt6) (cadr pt6) (caddr pt5)) vec ocs))
                    (cons 010 (trans (list (car pt6) (cadr pt6) (caddr pt4)) vec ocs))
                    (cons 210 ocs)
                )
            )
            (princ "\nRectangle created.")
        )
        (princ "\n*Cancelled*")
    )

    (SkewBox:Restore)
    (princ)
)

;; ---------------------------------------------------------------------------
;; Command wrappers
;; ---------------------------------------------------------------------------
(defun c:SKEWBOX     nil (SkewBox:Run nil))   ; three picks, no preview
(defun c:SKEWBOXLIVE nil (SkewBox:Run   t))   ; live preview with object snap

(princ)