;;; --------------------------------------------------------------------------- ;;; ContourInterp.lsp ;;; code compiled by YZ August 2026 ;;; --------------------------------------------------------------------------- ;;; INTERPOLATE LEVELS BETWEEN TWO SPOT HEIGHTS ;;; ;;; PURPOSE ;;; Two survey points with known levels, and a straight fall between them. ;;; This works out where each whole contour crosses that line and marks it - ;;; the donkey work of drawing contours from spot levels. ;;; ;;; Run it along each side of a triangle of survey points and the contour ;;; crossings are all there to be joined up. ;;; ;;; THE ARITHMETIC ;;; The ground is taken as a straight slope between the two points, so a level ;;; L falls at ;;; ;;; distance = span x (L - level1) / (level2 - level1) ;;; ;;; Contours at the interval you choose are stepped through between the two ;;; levels and marked wherever they land inside the span. ;;; ;;; WHAT WAS FIXED ;;; - It used T as a variable to hold the level label - twice: ;;; ;;; (setq t (itoa (fix iev))) ;;; ;;; T is the symbol for true. Overwriting it breaks every test in the ;;; session, including inside AutoCAD's own routines, until the drawing is ;;; closed. ;;; - The label went through (itoa (fix ...)), rounding every level down to a ;;; whole number. A site working in half metres was labelled 12, 12, 13, 13. ;;; - It set the running object snap to NODe on entry and to NONe on exit, ;;; throwing away whatever the user had. ;;; - It could only step in whole units, and only upward: if the second point ;;; was LOWER than the first, the loop condition was false at the start and ;;; nothing was drawn at all. ;;; - CMDECHO and BLIPMODE were set to 1 at the end rather than restored. ;;; - Text was placed with (command "text" "@" "" "" t) - at the last point, ;;; with the height and rotation prompts answered blank, which only works ;;; when the style has a fixed height. ;;; ;;; INTERP - mark contour crossings between two spot levels ;;; --------------------------------------------------------------------------- (setq *Interp:Step* nil) (defun Cont: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 level written to just enough places to tell one contour from the next. (defun Cont:Num ( v step ) (cond ((equal v (float (fix v)) 1e-9) (itoa (fix v))) ((>= step 1.0) (rtos v 2 1)) ((>= step 0.1) (rtos v 2 2)) (t (rtos v 2 3))) ) (defun c:INTERP ( / *error* vars vals p1 p2 l1 l2 step lay layt hgt v span ang lo hi lvl at n mark ) (setq vars '("CMDECHO" "BLIPMODE" "CLAYER") vals (mapcar 'getvar vars)) (defun Cont: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 ) (Cont:Restore) (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*"))) (princ (strcat "\n** INTERP 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") ;; Object snap is left exactly as set - picking survey points is what ;; running snaps are for. (princ "\nPick two survey points with known levels.") (setq p1 (getpoint "\nFirst point: ")) (if p1 (setq p2 (getpoint p1 "\nSecond point: "))) (if (or (null p1) (null p2)) (princ "\nCancelled.") (progn (initget 1) (setq l1 (getreal "\nLevel at the first point: ")) (initget 1) (setq l2 (getreal "\nLevel at the second point: ")) (if (or (null l1) (null l2)) (princ "\nCancelled.") (progn (setq span (distance p1 p2) ang (angle p1 p2)) (cond ((< span 1e-9) (princ "\n** Those two points are in the same place. **")) ((equal l1 l2 1e-9) (princ (strcat "\n** Both points are at " (rtos l1 2 3) " - the ground is flat, so no contour" " crosses this line. **"))) (t (initget 6) (setq step (getdist (strcat "\nContour interval" (if *Interp:Step* (strcat " <" (rtos *Interp:Step* 2 3) ">") "") ": "))) (if (null step) (setq step *Interp:Step*)) (if (null step) (princ "\nNo interval given.") (progn (setq *Interp:Step* step) (setq hgt (getvar "TEXTSIZE")) (if (or (null hgt) (<= hgt 0.0)) (setq hgt (/ span 20.0))) (initget 6) (setq v (getdist (strcat "\nText height <" (rtos hgt 2 3) ">: "))) (if v (setq hgt v)) (initget "Yes No") (setq mark (/= "No" (getkword "\nLabel each crossing [Yes/No] : "))) (setq lay (Cont:Layer "Contour-Points" 3) layt (Cont:Layer "Contour-Text" 7) lo (min l1 l2) hi (max l1 l2) ;; First contour at or above the lower ;; level. Works whichever way the ground ;; falls, which the original did not. lvl (* step (fix (+ (/ lo step) (if (< lo 0.0) -1.0 1.0)))) n 0) (while (< lvl lo) (setq lvl (+ lvl step))) (while (<= lvl hi) ;; Where along the line this level falls. (setq at (* span (/ (- lvl l1) (- l2 l1)))) (if (and (>= at -1e-9) (<= at (+ span 1e-9))) (progn (setq v (polar p1 ang at)) (entmake (list '(0 . "POINT") (cons 8 lay) (cons 10 v))) (if mark (entmake (list '(0 . "TEXT") (cons 8 layt) (cons 10 (polar v (+ ang (/ pi 2.0)) (* hgt 0.6))) (cons 11 (polar v (+ ang (/ pi 2.0)) (* hgt 0.6))) (cons 40 hgt) (cons 1 (Cont:Num lvl step)) '(72 . 1) '(73 . 2)))) (setq n (1+ n)))) (setq lvl (+ lvl step))) (princ (strcat "\n" (itoa n) " contour" (if (= n 1) "" "s") " cross this line, " (rtos l1 2 3) " to " (rtos l2 2 3) " over " (rtos span 2 3) ".")) (if (zerop n) (princ (strcat "\n No multiple of " (rtos step 2 3) " falls between those two levels.")))))))))) ) (Cont:Restore) (princ) ) (princ)