;;; --------------------------------------------------------------------------- ;;; Traverse.lsp ;;; code compiled by YZ August 2026 ;;; --------------------------------------------------------------------------- ;;; BOUNDARY AND TRAVERSE FROM BEARINGS AND DISTANCES ;;; ;;; PURPOSE ;;; Draws a boundary, a traverse or a road centreline straight from the way ;;; survey data is written on a deed or in a field book - a bearing and a ;;; distance for each leg, and a radius for each curve. ;;; ;;; TRAVERSE enters the legs and draws them as one polyline ;;; INVERSE the other way round: pick two points and be told the bearing ;;; and distance between them, in surveyor's form ;;; ;;; HOW BEARINGS ARE TYPED ;;; Quadrant bearing, which is what deeds use: ;;; ;;; N45.3015E means N 45 degrees 30 minutes 15 seconds E ;;; S12.0000W means due S 12 degrees W ;;; ;;; The number between the letters is degrees.minutes-seconds run together - ;;; the dd.mmss convention, so 45.3015 is 45 degrees 30 minutes 15 seconds and ;;; NOT 45.3 degrees. Whole degrees can be written plainly: N45E. ;;; ;;; A bare number is read as an azimuth clockwise from north, again in dd.mmss, ;;; so 135.15 is an azimuth of 135 degrees 15 minutes. ;;; ;;; THE CLOSURE CHECK ;;; This is the part worth having, and none of the routines it replaces did it. ;;; ;;; Each leg is split into how far north it goes (its latitude) and how far ;;; east (its departure). Go right round a closed boundary and both should sum ;;; to zero. They never quite do, and how far out they are is the misclosure - ;;; the gap between where the last leg ends and where the first began. ;;; ;;; That gap is reported as a ratio against the total distance walked: a ;;; misclosure of 0.05 on a 2500 foot perimeter is 1 in 50000, which is good. ;;; 1 in 5000 is ordinary. 1 in 500 means a leg has been mistyped, and the ;;; usual culprit is a quadrant letter the wrong way round. ;;; ;;; WHAT WAS FIXED ;;; Four separate routines are folded in here, each of which did part of it: ;;; ;;; - One wrote its answers to a SCRIPT FILE and left you to run it, because in ;;; 1988 that was easier than building the geometry. It also forced AUNITS to ;;; surveyor's units and then set it to 0 afterwards rather than to whatever ;;; you had, so your angle display silently changed to decimal degrees. ;;; It demanded the bearing be exactly seven characters and rejected N45E. ;;; - One inserted a point-number block called "pn" that had to already exist, ;;; and took the point number as a REAL, printing it back with RTOS. ;;; - One ran (setvar "cmdecho" 0) at load time, so merely loading the file ;;; changed the setting for the session. ;;; - One used (command ()) - an empty list where a command argument belonged. ;;; - The fourth extracted point numbers through ATTEXT with a template file; ;;; that job now belongs to ATTHARVEST. ;;; - Between them every variable was global, and none had an error handler. ;;; ;;; TRAVERSE - draw a boundary from bearings and distances ;;; INVERSE - report the bearing and distance between two points ;;; --------------------------------------------------------------------------- ;;; --------------------------------------------------------------------------- ;;; ANGLES ;;; ;;; Three systems are in play and it pays to keep them apart: ;;; dd.mmss how surveyors write an angle down ;;; azimuth clockwise from north, which is how bearings work ;;; AutoCAD counterclockwise from east, which is how POLAR works ;;; --------------------------------------------------------------------------- ;;; Degrees.minutes-seconds to decimal degrees. 45.3015 -> 45.504166 (defun Trav:DmsToDeg ( v / d rest m s ) (setq d (fix v) rest (* (- v d) 100.0) ;; Nudged before truncating, because 45.3015 does not survive the ;; multiplication exactly and comes out a hair under 30.15. m (fix (+ rest 1e-6)) s (* (- rest m) 100.0)) (+ d (/ m 60.0) (/ s 3600.0)) ) ;;; And back again, for reporting. (defun Trav:DegToDms ( deg / d m s neg out ) (setq neg (< deg 0.0) deg (abs deg) d (fix deg) m (fix (* (- deg d) 60.0)) s (* (- (* (- deg d) 60.0) m) 60.0)) ;; Rounding the seconds can carry into the minutes and on into the degrees. (if (>= s 59.5) (setq s 0.0 m (1+ m))) (if (>= m 60) (setq m 0 d (1+ d))) (setq out (strcat (itoa d) "d" (itoa m) "'" (rtos s 2 0) "\"")) (if neg (strcat "-" out) out) ) (defun Trav:Norm ( a ) (while (< a 0.0) (setq a (+ a (* 2.0 pi)))) (while (>= a (* 2.0 pi)) (setq a (- a (* 2.0 pi)))) a ) ;;; An azimuth in radians, clockwise from north, as an AutoCAD angle in radians, ;;; counterclockwise from east. (defun Trav:AzToAcad ( az ) (Trav:Norm (- (/ pi 2.0) az))) ;;; Parse what the user typed into an azimuth in radians, or nil if it makes no ;;; sense. Accepts N45.3015E, S12W, or a bare azimuth in dd.mmss. (defun Trav:ParseBearing ( s / u first lastch mid deg az ) (setq u (strcase s)) (while (and (> (strlen u) 0) (= " " (substr u 1 1))) (setq u (substr u 2))) (while (and (> (strlen u) 0) (= " " (substr u (strlen u) 1))) (setq u (substr u 1 (1- (strlen u))))) (if (= "" u) nil (progn (setq first (substr u 1 1) lastch (substr u (strlen u) 1)) (cond ;; Quadrant bearing: a letter each end, the angle in between. ((and (member first '("N" "S")) (member lastch '("E" "W"))) (setq mid (substr u 2 (- (strlen u) 2))) (if (= "" mid) nil (progn (setq deg (Trav:DmsToDeg (atof mid)) az (cond ((and (= first "N") (= lastch "E")) deg) ((and (= first "S") (= lastch "E")) (- 180.0 deg)) ((and (= first "S") (= lastch "W")) (+ 180.0 deg)) (t (- 360.0 deg)))) (Trav:Norm (/ (* pi az) 180.0))))) ;; Anything else is taken as an azimuth. ((or (wcmatch u "#*") (wcmatch u "`.#*")) (Trav:Norm (/ (* pi (Trav:DmsToDeg (atof u))) 180.0))) ) ) ) ) ;;; An azimuth written the way a deed would write it. (defun Trav:BearingText ( az / deg quad ang ) (setq deg (/ (* 180.0 (Trav:Norm az)) pi)) (cond ((<= deg 90.0) (setq quad '("N" . "E") ang deg)) ((<= deg 180.0) (setq quad '("S" . "E") ang (- 180.0 deg))) ((<= deg 270.0) (setq quad '("S" . "W") ang (- deg 180.0))) (t (setq quad '("N" . "W") ang (- 360.0 deg)))) (strcat (car quad) " " (Trav:DegToDms ang) " " (cdr quad)) ) ;;; --------------------------------------------------------------------------- ;;; DRAWING ;;; --------------------------------------------------------------------------- (defun Trav:Layer ( name colour ) (if (not (tblsearch "LAYER" name)) (entmake (list '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbLayerTableRecord") (cons 2 name) '(70 . 0) (cons 62 colour) '(6 . "Continuous")))) name ) ;;; A polyline from (point . bulge) pairs. (defun Trav:Poly ( pairs layer closed ) (entmake (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") (cons 8 layer) '(100 . "AcDbPolyline") (cons 90 (length pairs)) (cons 70 (if closed 1 0))) (apply 'append (mapcar '(lambda ( pr ) (list (cons 10 (list (car (car pr)) (cadr (car pr)))) (cons 42 (cdr pr)))) pairs)))) ) (defun Trav:Text ( pt hgt rot txt layer ) (entmake (list '(0 . "TEXT") (cons 8 layer) (cons 10 pt) (cons 11 pt) (cons 40 hgt) (cons 1 txt) (cons 50 rot) '(72 . 1) '(73 . 0))) ) ;;; --------------------------------------------------------------------------- ;;; TRAVERSE ;;; --------------------------------------------------------------------------- (defun c:TRAVERSE ( / *error* vars vals start here pairs legs done v az dist rad delta bulge lay layt hgt sumLat sumDep perim mis prec label nxt s half turn ) (setq vars '("CMDECHO" "BLIPMODE" "OSMODE" "CLAYER") vals (mapcar 'getvar vars)) (defun Trav: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 ) (Trav:Restore) (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*"))) (princ (strcat "\n** TRAVERSE error: " msg " **"))) (princ) ) (setvar "CMDECHO" 0) (setvar "BLIPMODE" 0) ;; AutoCAD 2015 and later refuse (command) inside an *error* handler unless ;; the routine says up front that it will use one. (vl-catch-all-apply '(lambda ( ) (*push-error-using-command*)) '()) (command "_.UNDO" "_Begin") (princ "\nTraverse. Bearings as N45.3015E - that is 45 degrees 30 minutes") (princ "\n15 seconds - or a bare number for an azimuth.") (setq start (getpoint "\nStarting point: ")) (if (null start) (princ "\nCancelled.") (progn (setvar "OSMODE" 0) (initget "Yes No") (setq label (/= "No" (getkword "\nLabel each leg [Yes/No] : "))) (setq hgt (getvar "TEXTSIZE")) (if (or (null hgt) (<= hgt 0.0)) (setq hgt 2.5)) (if label (progn (initget 6) (setq v (getdist (strcat "\nText height <" (rtos hgt 2 3) ">: "))) (if v (setq hgt v)))) (setq lay (Trav:Layer "Traverse" 3) layt (Trav:Layer "Traverse-Text" 7) start (list (car start) (cadr start) 0.0) here start pairs (list (cons start 0.0)) legs nil sumLat 0.0 sumDep 0.0 perim 0.0 done nil) ;; --- the legs --------------------------------------------------- (while (not done) (setq s (getstring t (strcat "\nLeg " (itoa (1+ (length legs))) " bearing : "))) (if (= "" s) (setq done t) (if (null (setq az (Trav:ParseBearing s))) (princ "\n Cannot read that. Try N45.3015E, S12W, or 135.15.") (progn (initget 6) (setq dist (getdist "\n Distance: ")) (if dist (progn ;; --- straight leg or curve --------------- (initget "Straight Curve") (setq v (getkword "\n [Straight/Curve] : ")) (setq bulge 0.0) (if (= v "Curve") (progn (initget 6) (setq rad (getdist "\n Radius: ")) (initget "Left Right") (setq turn (getkword "\n Turns [Left/Right] : ")) ;; The distance given is the chord, ;; so the included angle follows from ;; it and the radius: ;; sin(delta/2) = chord / 2R (setq half (/ dist (* 2.0 rad))) (if (> half 1.0) (progn (princ "\n ** That chord is longer than the" " diameter - drawn straight. **") (setq bulge 0.0)) (progn (setq delta (* 2.0 (atan half (sqrt (max 0.0 (- 1.0 (* half half))))))) ;; Bulge is the tangent of a ;; quarter of the included ;; angle; negative turns ;; clockwise, which is a ;; right-hand curve. (setq bulge (/ (sin (/ delta 4.0)) (cos (/ delta 4.0)))) (if (/= turn "Left") (setq bulge (- bulge))))))) ;; --- lay it down -------------------------- (setq nxt (polar here (Trav:AzToAcad az) dist)) ;; Latitude north, departure east - the two ;; halves the closure check adds up. (setq sumLat (+ sumLat (* dist (cos az))) sumDep (+ sumDep (* dist (sin az))) perim (+ perim dist) legs (cons (list az dist here nxt) legs)) ;; A bulge belongs to the segment LEAVING a ;; vertex, so it goes onto the point already ;; at the end of the list, not onto the new ;; one. PAIRS is kept newest-first while it ;; is being built and reversed at the end, ;; which makes that a change to the head. (setq pairs (cons (cons nxt 0.0) (cons (cons (car (car pairs)) bulge) (cdr pairs)))) (setq here nxt) (princ (strcat " -> " (Trav:BearingText az) " " (rtos dist 2 3))))))))) (if (< (length legs) 1) (princ "\nNo legs entered.") (progn (setq legs (reverse legs)) ;; --- close it, or not --------------------------------- (initget "Yes No") (setq v (/= "No" (getkword "\nClose back to the start [Yes/No] : "))) ;; PAIRS was built newest-first so each bulge could be ;; written onto the head; the polyline wants them in order. (Trav:Poly (reverse pairs) lay v) ;; --- labels ------------------------------------------- (if label (foreach lg legs ;; The direction of this leg, as an AutoCAD angle. (setq v (Trav:AzToAcad (car lg)) ;; Turned through half a circle when it would ;; otherwise read upside down. rad (if (and (> v (/ pi 2.0)) (< v (* 1.5 pi))) (+ v pi) v)) (Trav:Text (polar (polar (caddr lg) v (/ (cadr lg) 2.0)) (+ v (/ pi 2.0)) (* hgt 0.6)) hgt rad (strcat (Trav:BearingText (car lg)) " " (rtos (cadr lg) 2 2)) layt))) ;; --- the closure report ------------------------------- (setq mis (sqrt (+ (* sumLat sumLat) (* sumDep sumDep)))) (princ (strcat "\n\n" (itoa (length legs)) " leg" (if (= 1 (length legs)) "" "s") ", perimeter " (rtos perim 2 3))) (princ (strcat "\n Latitudes sum to " (rtos sumLat 2 4) " (north is positive)")) (princ (strcat "\n Departures sum to " (rtos sumDep 2 4) " (east is positive)")) (princ (strcat "\n Misclosure " (rtos mis 2 4))) (if (and (> mis 1e-9) (> perim 0.0)) (progn (setq prec (/ perim mis)) (princ (strcat "\n Precision 1 in " (rtos prec 2 0))) (princ (cond ((> prec 20000.0) " - very good") ((> prec 5000.0) " - acceptable for most work") ((> prec 1000.0) " - loose; check the longest leg") (t " - something is wrong. A quadrant letter the wrong way round is the usual cause.")))) (princ "\n Closes exactly.")) ) ) ) ) (Trav:Restore) (princ) ) ;;; --------------------------------------------------------------------------- ;;; INVERSE - the other direction ;;; --------------------------------------------------------------------------- (defun c:INVERSE ( / *error* vars vals p1 p2 az dist ) (setq vars '("CMDECHO") vals (mapcar 'getvar vars)) (defun *error* ( msg ) (mapcar 'setvar vars vals) (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*"))) (princ (strcat "\n** INVERSE error: " msg " **"))) (princ) ) (setvar "CMDECHO" 0) ;; Nothing is drawn, so there is no undo group and no need to declare that ;; the error handler will use (command). (while (and (setq p1 (getpoint "\nFrom point : ")) (setq p2 (getpoint p1 "\nTo point: "))) ;; AutoCAD measures counterclockwise from east; an azimuth runs ;; clockwise from north, so the same swap converts either way. (setq az (Trav:Norm (- (/ pi 2.0) (angle p1 p2))) dist (distance p1 p2)) (princ (strcat "\n " (Trav:BearingText az) " distance " (rtos dist 2 4) "\n latitude " (rtos (* dist (cos az)) 2 4) " departure " (rtos (* dist (sin az)) 2 4)))) (mapcar 'setvar vars vals) (princ) ) (princ)