;;; --------------------------------------------------------------------------- ;;; RoadLines.lsp ;;; code compiled by YZ August 2026 ;;; --------------------------------------------------------------------------- ;;; ROADS AND RAILWAYS FROM A CENTRELINE ;;; ;;; PURPOSE ;;; Pick a polyline and get a road or a railway built along it. ;;; ;;; ROAD draws kerbs or shoulders either side at a width you give, and ;;; can add a centre line down the middle. ;;; RAILWAY draws two rails and lays sleepers across them at a spacing, ;;; each one square to the track at that point. ;;; ;;; Both follow curves properly, because both work from the curve itself ;;; rather than from its straight segments. ;;; ;;; WHAT WAS FIXED ;;; The road routine could not run at all. Its main loop was written ;;; (while (Cline) ...) - with Cline in the function position, so AutoLISP ;;; tried to CALL the selection as though it were a function and stopped with ;;; "bad function". Even past that, it fed OFFSET a point where the object to ;;; offset belonged, and the second of its two OFFSET calls had an extra ;;; argument that put every later answer in the wrong prompt. ;;; ;;; It also took its road width from LTSCALE, which is a display setting for ;;; dashed lines and has nothing to do with how wide a road is. And it erased ;;; the centreline you picked, without asking. ;;; ;;; The railway routine built a block called "Railroad" from a line, ran ;;; MEASURE to scatter it along the track, and left the block in the drawing. ;;; It split one command across two (command) calls, which works only as long ;;; as nothing interrupts in between. Sleepers are now drawn directly, so ;;; there is no block to clean up afterwards. ;;; ;;; Neither restored BLIPMODE or CMDECHO - both set them to 1 and 0 rather ;;; than to whatever they had been - and REGENMODE was left off by one. ;;; ;;; ROAD - kerbs and shoulders along a centreline ;;; RAILWAY - rails and sleepers along a centreline ;;; --------------------------------------------------------------------------- (vl-load-com) (setq *RoadLines:Width* nil *RoadLines:Gauge* nil *RoadLines:Sleeper* nil) ;;; --------------------------------------------------------------------------- ;;; SUPPORT ;;; --------------------------------------------------------------------------- (defun Road: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 ) (defun Road:Line ( p1 p2 layer ) (entmake (list '(0 . "LINE") (cons 8 layer) (cons 10 p1) (cons 11 p2))) ) ;;; Anything with a length along which points can be found. (defun Road:PickCurve ( prompt / sel ent kind ) (setq ent nil) (while (and (null ent) (setq sel (entsel (strcat "\n" prompt " : ")))) (setq kind (cdr (assoc 0 (entget (car sel))))) (if (member kind '("LWPOLYLINE" "POLYLINE" "LINE" "ARC" "SPLINE" "ELLIPSE")) (setq ent (car sel)) (princ (strcat "\n A " kind " has no centreline to follow.")))) ent ) ;;; Offset a curve to one side and hand back what was made. The side is chosen ;;; by finding a point square to the curve rather than by guessing a direction, ;;; which is what makes this work on a curve that doubles back. (defun Road:Offset ( ent dist side / obj mid tan ang p before after new ) (setq obj (vlax-ename->vla-object ent) mid (vlax-curve-getPointAtParam obj (/ (vlax-curve-getEndParam obj) 2.0)) tan (vlax-curve-getFirstDeriv obj (/ (vlax-curve-getEndParam obj) 2.0)) ang (angle '(0 0 0) tan) p (polar mid (+ ang (* side (/ pi 2.0))) (max dist 1e-6))) (setq before (entlast)) (command "_.OFFSET" dist ent p "") (setq after (entlast)) (if (and after (not (eq after before))) after) ) ;;; --------------------------------------------------------------------------- ;;; ROAD ;;; --------------------------------------------------------------------------- (defun c:ROAD ( / *error* vars vals ent width lay v left right keep centre ) (setq vars '("CMDECHO" "BLIPMODE" "OSMODE" "CLAYER") vals (mapcar 'getvar vars)) (defun Road: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 ) (Road:Restore) (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*"))) (princ (strcat "\n** ROAD error: " msg " **"))) (princ) ) (setvar "CMDECHO" 0) (setvar "BLIPMODE" 0) (setvar "OSMODE" 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") (setq ent (Road:PickCurve "Centreline of the road")) (if (null ent) (princ "\nCancelled.") (progn (initget 6) (setq width (getdist (strcat "\nRoad width, kerb to kerb" (if *RoadLines:Width* (strcat " <" (rtos *RoadLines:Width* 2 3) ">") "") ": "))) (if (null width) (setq width *RoadLines:Width*)) (if (null width) (princ "\nNo width given.") (progn (setq *RoadLines:Width* width lay (Road:Layer "Road" 3)) (setvar "CLAYER" lay) ;; Half the width each side of the centreline. (setq left (Road:Offset ent (/ width 2.0) 1.0) right (Road:Offset ent (/ width 2.0) -1.0)) (initget "Yes No") (setq keep (/= "No" (getkword "\nKeep the centreline [Yes/No] : "))) (if (not keep) (entdel ent) (progn (initget "Yes No") (if (= "Yes" (getkword "\nPut the centreline on its own layer [Yes/No] : ")) (progn (setq centre (Road:Layer "Road-Centreline" 1) v (entget ent)) (entmod (subst (cons 8 centre) (assoc 8 v) v)))))) (princ (strcat "\nRoad " (rtos width 2 3) " wide" (if (and left right) "." " - one side would not offset; the centreline may double back on itself."))) ) ) ) ) (Road:Restore) (princ) ) ;;; --------------------------------------------------------------------------- ;;; RAILWAY ;;; ;;; Sleepers are stepped along the track by DISTANCE rather than by parameter, ;;; so they stay evenly spaced round a curve instead of bunching up on the ;;; inside of it. ;;; --------------------------------------------------------------------------- (defun c:RAILWAY ( / *error* vars vals ent obj gauge spacing lay total d pt tan ang n over v ) (setq vars '("CMDECHO" "BLIPMODE" "OSMODE" "CLAYER") vals (mapcar 'getvar vars)) (defun Rail: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 ) (Rail:Restore) (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*"))) (princ (strcat "\n** RAILWAY error: " msg " **"))) (princ) ) (setvar "CMDECHO" 0) (setvar "BLIPMODE" 0) (setvar "OSMODE" 0) (vl-catch-all-apply '(lambda ( ) (*push-error-using-command*)) '()) (command "_.UNDO" "_Begin") (setq ent (Road:PickCurve "Centreline of the track")) (if (null ent) (princ "\nCancelled.") (progn (initget 6) (setq gauge (getdist (strcat "\nDistance between the rails" (if *RoadLines:Gauge* (strcat " <" (rtos *RoadLines:Gauge* 2 3) ">") "") ": "))) (if (null gauge) (setq gauge *RoadLines:Gauge*)) (if (null gauge) (princ "\nNo gauge given.") (progn (initget 6) (setq spacing (getdist (strcat "\nSleeper spacing <" (rtos (* gauge 0.5) 2 3) ">: "))) (if (null spacing) (setq spacing (* gauge 0.5))) (initget 4) (setq over (getdist (strcat "\nSleeper overhang past each rail <" (rtos (* gauge 0.15) 2 3) ">: "))) (if (null over) (setq over (* gauge 0.15))) (setq *RoadLines:Gauge* gauge *RoadLines:Sleeper* spacing lay (Road:Layer "Railway" 4)) (setvar "CLAYER" lay) ;; The two rails. (Road:Offset ent (/ gauge 2.0) 1.0) (Road:Offset ent (/ gauge 2.0) -1.0) ;; And the sleepers across them. (setq obj (vlax-ename->vla-object ent) total (vlax-curve-getDistAtParam obj (vlax-curve-getEndParam obj)) d 0.0 n 0) (while (<= d total) (setq pt (vlax-curve-getPointAtDist obj d) tan (vlax-curve-getFirstDeriv obj (vlax-curve-getParamAtDist obj d)) ang (+ (angle '(0 0 0) tan) (/ pi 2.0))) (Road:Line (polar pt ang (+ (/ gauge 2.0) over)) (polar pt (+ ang pi) (+ (/ gauge 2.0) over)) lay) (setq n (1+ n) d (+ d spacing))) (princ (strcat "\nTrack " (rtos total 2 3) " long, " (itoa n) " sleeper" (if (= n 1) "" "s") " at " (rtos spacing 2 3) " centres.")) ) ) ) ) (Rail:Restore) (princ) ) (princ)