;;; --------------------------------------------------------------------------- ;;; GridRef.lsp ;;; code compiled by YZ August 2026 ;;; --------------------------------------------------------------------------- ;;; SURVEY COORDINATE GRID OVER A VIEWPORT ;;; ;;; PURPOSE ;;; Lays a labelled Easting/Northing grid over whatever a layout viewport is ;;; showing - a border round the visible area, tick marks on the border at ;;; every grid interval with their coordinate written beside them, and a small ;;; cross at each grid intersection inside. ;;; ;;; This is what turns a site plan into a drawing someone can set out from. ;;; Without it a contractor has a picture; with it they have coordinates. ;;; ;;; HOW IT WORKS ;;; 1. The viewport tells you everything needed to do this properly. Its DXF ;;; data carries the paper-space width and height, the height of the model ;;; area it is showing, the centre of that area, and the twist angle. From ;;; those five numbers the scale is paper height over model height, and the ;;; visible model rectangle follows. ;;; ;;; The routine this replaces dug those values out of the viewport's ;;; extended entity data by counting along to fixed positions - which breaks ;;; the moment anything else attaches its own data to a viewport. The ;;; standard DXF group codes are read here instead: 40 and 41 for the paper ;;; size, 45 for the model height, 12 for the view centre, 51 for the twist. ;;; ;;; 2. The four corners of the visible area are worked out in model coordinates, ;;; including any twist, so a rotated viewport gets a rotated grid rather ;;; than a grid at odd angles to what it is showing. ;;; ;;; 3. Grid values are found by rounding the extents of that rectangle out to ;;; the next whole interval in each direction, so a grid at 50 m intervals ;;; lands on 1250, 1300, 1350 - never on 1263.4. ;;; ;;; 4. Each grid line is intersected against each of the four border edges. An ;;; intersection that falls within the edge gets a tick and a label. Doing it ;;; by intersection rather than by assuming which edge is which is what lets ;;; a twisted viewport work at all. ;;; ;;; 5. Ticks point outward, away from the centre of the viewport, and labels sit ;;; beyond the ticks rotated to the twist angle - flipped through 180 degrees ;;; when that would otherwise print them upside down. ;;; ;;; SIZING ;;; Tick lengths and text height are specified at PAPER size and divided by the ;;; viewport scale on the way in, so a grid drawn over a 1:500 viewport and one ;;; drawn over a 1:1000 viewport both plot with the same size ticks and text. ;;; ;;; WHERE IT DRAWS ;;; In MODEL space, not on the layout. The grid belongs to the site, so it moves ;;; with the model and shows through any viewport looking at that area. ;;; ;;; GRIDREF - draw a coordinate grid over a viewport ;;; --------------------------------------------------------------------------- ;;; --------------------------------------------------------------------------- ;;; SETTINGS ;;; ;;; All the paper-size values in one place, so an office standard can be set once ;;; here rather than hunted through the code. ;;; --------------------------------------------------------------------------- (if (null *GridRef:Prefs*) (setq *GridRef:Prefs* (list (cons "INTERVAL" nil) ; grid interval in model units (cons "BTICK" 20.0) ; border tick length, paper units (cons "CTICK" 10.0) ; interior cross size, paper units (cons "TXTHGT" 2.5) ; text height, paper units (cons "COLOUR" "7") ; colour for all three grid layers (cons "ESUFFIX" "E") ; suffix on Easting labels (cons "NSUFFIX" "N") ; suffix on Northing labels ) ) ) (defun GridRef:Get ( key ) (cdr (assoc key *GridRef:Prefs*))) (defun GridRef:Put ( key val ) (setq *GridRef:Prefs* (cons (cons key val) (vl-remove-if '(lambda (p) (= (car p) key)) *GridRef:Prefs*))) val ) ;;; Layer names, gathered here so the erase-and-redraw pass and the drawing pass ;;; cannot disagree about what belongs to the grid. (setq GridRef:LBORDER "GRIDREF-BORDER" GridRef:LTICK "GRIDREF-TICK" GridRef:LTEXT "GRIDREF-TEXT") ;;; --------------------------------------------------------------------------- ;;; HELPERS ;;; --------------------------------------------------------------------------- (defun GridRef:Layer ( name colour / ) (if (not (tblsearch "layer" name)) (command "_.LAYER" "_NEW" name "_COLOR" colour name "") (progn (command "_.LAYER" "_ON" name "_THAW" name "_UNLOCK" name ""))) (setvar "CLAYER" name) ) ;;; Round a value out to the next whole multiple of the interval, away from zero ;;; in the given direction. Used to find the first and last grid line that the ;;; visible area needs. ;;; A value already sitting exactly on a grid line belongs to that line, so it is ;;; returned unchanged rather than being pushed to the next one. (defun GridRef:First ( v interval / n ) (setq n (/ v interval)) (if (equal n (float (fix n)) 1e-8) v (* interval (1+ (fix (/ v interval))))) ) ;;; Every grid value between two bounds. The upper end needs no rounding helper ;;; of its own - the loop simply stops when it passes it. (defun GridRef:Series ( lo hi interval / v out ) (setq v (GridRef:First lo interval)) (while (<= v hi) (setq out (cons v out) v (+ v interval))) (reverse out) ) ;;; Draw a line straight into the model space table, bypassing the LINE command. ;;; ENTMAKE is used throughout because it does not care what space is current, ;;; does not disturb LASTPOINT, and cannot be interrupted by a running osnap. (defun GridRef:Line ( a b ) (entmake (list (cons 0 "LINE") (cons 100 "AcDbEntity") (cons 67 0) (cons 8 (getvar "CLAYER")) (cons 100 "AcDbLine") (cons 10 a) (cons 11 b))) ) (defun GridRef:Text ( pt height rot s ) (entmake (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 67 0) (cons 8 (getvar "CLAYER")) (cons 100 "AcDbText") (cons 10 pt) (cons 40 height) (cons 1 s) (cons 50 rot) (cons 72 1) (cons 11 pt) ; horizontally centred (cons 100 "AcDbText") (cons 73 2) ; vertically middle )) ) ;;; Normalise an angle into 0 to 2*pi so the upside-down test below is a simple ;;; range check rather than a set of special cases. (defun GridRef:Norm ( a ) (while (< a 0.0) (setq a (+ a (* pi 2.0)))) (while (>= a (* pi 2.0)) (setq a (- a (* pi 2.0)))) a ) ;;; Is a point inside the twisted viewport rectangle? ;;; ;;; Rotating the whole border to test against it would be fiddly; rotating the ;;; single POINT back by the twist angle is one line of trigonometry. Measure how ;;; far the point is from the centre and at what bearing, subtract the twist from ;;; that bearing, and the along-axis and across-axis distances fall out as the ;;; cosine and sine components. Then it is just two range checks. ;;; ;;; cen centre of the visible area, in model coordinates ;;; twist viewport twist angle ;;; hw, hh half-width and half-height of the visible area (defun GridRef:Inside ( p cen twist hw hh / d a u v ) (setq d (distance cen p) a (- (angle cen p) twist) u (* d (cos a)) v (* d (sin a))) (and (<= (abs u) hw) (<= (abs v) hh)) ) ;;; --------------------------------------------------------------------------- ;;; READING THE VIEWPORT ;;; ;;; Returns ( scale model-width model-height centre-in-WCS twist ) or nil. ;;; --------------------------------------------------------------------------- (defun GridRef:Read ( ename / dat pw ph mh mw twist vid dcs wcen scale ) (setq dat (entget ename)) (if (/= "VIEWPORT" (cdr (assoc 0 dat))) nil (progn (setq pw (cdr (assoc 40 dat)) ; paper-space width ph (cdr (assoc 41 dat)) ; paper-space height mh (cdr (assoc 45 dat)) ; model height being shown dcs (cdr (assoc 12 dat)) ; view centre, display coords twist (cdr (assoc 51 dat)) ; view twist vid (cdr (assoc 69 dat))) ; viewport number (if (null twist) (setq twist 0.0)) (if (or (null pw) (null ph) (null mh) (null dcs) (<= mh 0.0) (<= ph 0.0)) nil (progn (setq scale (/ ph mh) ; paper units per model unit mw (/ pw scale)) ;; The view centre is in the viewport's display coordinates, ;; so it has to be translated through that viewport to get a ;; real world coordinate. That means briefly making it the ;; active viewport. (setq wcen (if vid (progn (command "_.MSPACE") (setvar "CVPORT" vid) (prog1 (trans dcs 2 0) (command "_.PSPACE"))) (list (car dcs) (cadr dcs) 0.0))) (list scale mw mh wcen twist) ) ) ) ) ) ;;; --------------------------------------------------------------------------- ;;; EXISTING GRID ;;; --------------------------------------------------------------------------- (defun GridRef:Existing ( / ss ) (ssget "_X" (list '(-4 . ""))) ) (defun GridRef:Erase ( ss / i ) (if ss (progn (setq i 0) (repeat (sslength ss) (entdel (ssname ss i)) (setq i (1+ i))) (sslength ss)) 0) ) ;;; --------------------------------------------------------------------------- ;;; MAIN COMMAND ;;; --------------------------------------------------------------------------- (defun c:GRIDREF ( / *error* vars vals sel vp scale mw mh cen twist interval btick ctick txth colour hw hh c1 c2 c3 c4 corners minx maxx miny maxy xs ys old opt edges mid ip normal rot lab placed crosses ) (setq vars '("CMDECHO" "CLAYER" "OSMODE" "BLIPMODE" "TILEMODE") vals (mapcar 'getvar vars)) (defun GridRef:Restore ( ) (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 ) (GridRef:Restore) (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*"))) (princ (strcat "\n** GRIDREF error: " msg " **"))) (princ) ) (setvar "CMDECHO" 0) ;; 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") (cond ;; A viewport only exists on a layout, so model space is the one place ;; this command can never work. ((= 1 (getvar "TILEMODE")) (princ "\nSwitch to a layout tab first - GRIDREF works from a viewport.")) (t ;; Offer to clear a previous grid before drawing another over it. (setq old (GridRef:Existing)) (setq opt "Replace") (if old (progn (initget "Replace Append eXit") (setq opt (getkword (strcat "\nA grid already exists (" (itoa (sslength old)) " objects). [Replace/Append/eXit] : "))) (if (null opt) (setq opt "Replace")))) (if (= opt "eXit") (princ "\nLeft alone.") (progn (setq sel (entsel "\nSelect the viewport to grid: ")) (cond ((null sel) (princ "\nNothing selected.")) ((null (setq vp (GridRef:Read (car sel)))) (princ "\nThat is not a viewport, or its view data could not be read.")) (t (setq scale (nth 0 vp) mw (nth 1 vp) mh (nth 2 vp) cen (nth 3 vp) twist (nth 4 vp)) (initget 7) (setq interval (getreal (strcat "\nGrid interval in model units" (if (GridRef:Get "INTERVAL") (strcat " <" (rtos (GridRef:Get "INTERVAL") 2 3) ">") "") ": "))) (if (null interval) (setq interval (GridRef:Get "INTERVAL"))) (GridRef:Put "INTERVAL" interval) ;; Paper sizes converted to model units for this viewport. (setq btick (/ (GridRef:Get "BTICK") scale) ctick (/ (GridRef:Get "CTICK") scale) txth (/ (GridRef:Get "TXTHGT") scale) colour (GridRef:Get "COLOUR")) (if (= opt "Replace") (princ (strcat "\n" (itoa (GridRef:Erase old)) " objects from the previous grid removed."))) (setvar "OSMODE" 0) (setvar "BLIPMODE" 0) ;; --- the four corners of the visible area -------- ;; Built by stepping out from the centre along the ;; twisted axes, so a rotated viewport gives a ;; rotated rectangle. (setq hw (/ mw 2.0) hh (/ mh 2.0) c1 (polar (polar cen twist hw) (+ twist (* pi 0.5)) hh) c2 (polar (polar cen twist hw) (+ twist (* pi 1.5)) hh) c3 (polar (polar cen (+ twist pi) hw) (+ twist (* pi 1.5)) hh) c4 (polar (polar cen (+ twist pi) hw) (+ twist (* pi 0.5)) hh) corners (list c1 c2 c3 c4)) ;; --- border -------------------------------------- (GridRef:Layer GridRef:LBORDER colour) (entmake (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") (cons 67 0) (cons 8 GridRef:LBORDER) '(100 . "AcDbPolyline") '(90 . 4) '(70 . 1)) ; 70 bit 1 = closed (mapcar '(lambda (p) (cons 10 (list (car p) (cadr p)))) corners))) ;; --- which grid values are in view --------------- (setq minx (apply 'min (mapcar 'car corners)) maxx (apply 'max (mapcar 'car corners)) miny (apply 'min (mapcar 'cadr corners)) maxy (apply 'max (mapcar 'cadr corners)) xs (GridRef:Series minx maxx interval) ys (GridRef:Series miny maxy interval) placed 0 crosses 0) ;; --- ticks and labels on every edge -------------- ;; Each grid line is tested against each edge rather ;; than assumed to meet a particular one, which is ;; what makes a twisted viewport work. (setq edges (list (list c1 c2) (list c2 c3) (list c3 c4) (list c4 c1))) (foreach edge edges ;; Outward normal: whichever perpendicular leads ;; away from the centre of the viewport. (setq mid (polar (car edge) (angle (car edge) (cadr edge)) (/ (distance (car edge) (cadr edge)) 2.0)) normal (+ (angle (car edge) (cadr edge)) (* pi 0.5))) (if (< (distance cen (polar mid normal 1.0)) (distance cen (polar mid (- normal pi) 1.0))) (setq normal (- normal pi))) ;; Labels read along the twist, flipped when that ;; would leave them upside down on the sheet. (setq rot (GridRef:Norm twist)) (if (and (> rot (* pi 0.5)) (<= rot (* pi 1.5))) (setq rot (GridRef:Norm (+ rot pi)))) ;; Eastings: vertical grid lines. (foreach x xs (if (setq ip (inters (car edge) (cadr edge) (list x (- miny interval)) (list x (+ maxy interval)))) (progn (GridRef:Layer GridRef:LTICK colour) (GridRef:Line ip (polar ip normal btick)) (GridRef:Layer GridRef:LTEXT colour) (setq lab (strcat (rtos x 2 0) (GridRef:Get "ESUFFIX"))) (GridRef:Text (polar ip normal (+ btick txth)) txth rot lab) (setq placed (1+ placed))))) ;; Northings: horizontal grid lines. (foreach y ys (if (setq ip (inters (car edge) (cadr edge) (list (- minx interval) y) (list (+ maxx interval) y))) (progn (GridRef:Layer GridRef:LTICK colour) (GridRef:Line ip (polar ip normal btick)) (GridRef:Layer GridRef:LTEXT colour) (setq lab (strcat (rtos y 2 0) (GridRef:Get "NSUFFIX"))) (GridRef:Text (polar ip normal (+ btick txth)) txth rot lab) (setq placed (1+ placed))))) ) ;; --- crosses at the interior intersections ------- ;; Only those actually inside the border are drawn, ;; tested by comparing against the untwisted extents ;; measured back along the twist from the centre. (GridRef:Layer GridRef:LTICK colour) (foreach x xs (foreach y ys (setq ip (list x y 0.0)) (if (GridRef:Inside ip cen twist hw hh) (progn (GridRef:Line (polar ip 0.0 (/ ctick 2.0)) (polar ip pi (/ ctick 2.0))) (GridRef:Line (polar ip (* pi 0.5) (/ ctick 2.0)) (polar ip (* pi 1.5) (/ ctick 2.0))) (setq crosses (1+ crosses)))))) (princ (strcat "\nGrid drawn at " (rtos interval 2 3) " intervals - " (itoa placed) " border labels, " (itoa crosses) " intersection crosses.")) ) ) ) ) ) ) (GridRef:Restore) (princ) ) (princ)