;;;Update profile location and station / elevation text ;;;(SETQ no_stations T) to eliminate station text where stations are not required, e.g. hydraulic profiles. ;;;remember to (SETQ no_stations NIL) to enable stations again during the same session. ;;;Requirements: ;;; Requires UUTILS.LSP and STAIT.LSP to be loaded. ;;; ;;;Drawing must contain: ;;; The profile viewport on layer "*VI01*NPLT*" (preferably "??VI01?NPLT" per CLG) ;;; The profile grid block named "cpp##spl" or "##ppgrid*" or "##spclgrid" or "##spfbgrid" ;;; (#'s are wildcards which must be replaced with digits representing profile horizontal scale) ;;; These profile grid blocks must contain specific attribute tags for stations and elevations, ;;; i.e.: ;;; ;;; left side attribute tags (ordered before right side tags) ;;; LB+0, LB+5, LB+10, etc. ordered from highest LB+## to LB+0; ;;; (The total number of these tags is unlimited) ;;; ;;; right side attribute tags ;;; RB+0, RB+5, RB+10, etc. also ordered from highest RB+## to RB+0; ;;; (The total number of these tags is unlimited) ;;; ;;; station attribute tags ;;; 0, +0; 1, +1; 2, +2; etc. from left to right as many as are required ;;; place these in pairs at scaled 100' increments (english), 50m increments (metric). ;;; integer tags are right justified and +integer tags are left justified so that the first character, ;;; typically a plus sign (+), will lay directly under the grid line. This solves justification related ;;; misalignment of labels. ;;; (The total number of these tags is unlimited) ;;; ;;; Author: ;;; Henry C. Francis ;;; 425 N. Ashe St. ;;; Southern Pines, NC 28387 ;;; ;;; http://www.paracadd.com ;;; All rights reserved. ;;; ;;; Copyright: 1-14-98 ;;; Edited: 8-20-2009 ;;; ;;;**************************************************************************** (IF (EQ (getvar "loginname") "Cooper") (SETQ debug_funs T)) (DEFUN ustael_error (msg /) (PRINC (STRCAT "\nError: " msg ": " (IF debug_funs (STRCAT (IF oldfunname4 (STRCAT oldfunname4 "; ") "") (IF oldfunname3 (STRCAT oldfunname3 "; ") "") (IF oldfunname2 (STRCAT oldfunname2 "; ") "") (IF oldfunname1 (STRCAT oldfunname1 "; ") "") (IF oldfunname0 (STRCAT oldfunname0 "; ") "") (IF funname funname "") ) "" ) ) ) (PRINC "\nCheck vieport lock status. ") (SETQ *error* orig_error) (IF old_ustaelDIMZIN (SETVAR "DIMZIN" old_ustaelDIMZIN) ) ;_ end of IF (PRINC) ) ;_ end of DEFUN ;;;**************************************************************************** (DEFUN c:USTAEL (/ assoc_10_llst assoc_10_rlst attr_ls1 blank_neg_sta cedatb cedatum cedndx csdatc csdatp csdndx cursta curvno cvcntr cvpent cvpllx cvplly cvpss cvscle cvsize cvwdth elevtxt_lst elev_ent fndcnt fndsllen fnd_ss found_splitlbl fslbl_cnt fslbl_len fslbl_ptlst fslbl_symlst grdhgt grdwid insert_ent lbelev_lst left_ellbl lellbllst llattr_ls1 max_fslbl_pt min_fslbl_pt nextdef nextename next_sedata no_stations old_ustaeldimzin orig_error plus_ent pscvcntr rbelev_lst rbelev_lst_n0 rbelev_lst_n1 rellbllst right_ellbl rlattr_ls1 rtview sedat sedata sta#_ent sta0_catxt sta0_tx1 sta0_tx2 stait staval_cnt staval_lst sta_lst sta_lst_n0 sta_lst_n1 sta_pos this_fnd this_max_el this_max_sta this_min_el this_min_sta this_sta this_sta_lst this_sta_txt updatt ustael_split_note viewsta vpscl vpsclint vpscl_tst ) (SETQ oldfunname4 NIL oldfunname3 NIL oldfunname2 NIL oldfunname1 NIL oldfunname0 NIL funname "c:ustael") (VL-LOAD-COM) (SETQ orig_error *error* *error* ustael_error ) ;_ end of SETQ (IF (OR (EQ (GETVAR "tilemode") 1) (NOT (SETQ sedata (SSGET "X" (LIST (CONS -4 "") (CONS 410 (GETVAR "CTAB")) ) ;_ end of LIST ) ;_ end of SSGET ) ;_ end of SETQ ) ;_ end of NOT ) ;_ end of OR (ALERT (STRCAT "USTAEL requires a floating viewport in paper space and a special block with attributes for" "\nstation and elevation labels. The name of the special block must match these patterns:" "\n\n\t##PPGRID*, ###PPGRID*" "\n\t##SPCLGRID, ###SPCLGRID" "\n\nAttributes must be as follows:" "\n\nLeft side attribute tags (ordered before right side tags):" "\n\tLB+0, LB+5, LB+10, etc. ordered from highest LB+## to LB+0;" "\n\t(The total number of these tags is unlimited)" "\n\nRight side attribute tags:" "\n\tRB+0, RB+5, RB+10, etc. also ordered from highest RB+## to RB+0;" "\n\t(The total number of these tags is unlimited)" "\n\nStation attribute tags:" "\n\t0, +0; 1, +1; 2, +2; etc. from left to right as many as are required." "\n\tplace these in pairs at scaled 100' increments (english), 50m increments (metric)." "\n\t# tags are right justified and +# tags are left justified so that the first character," "\n\ttypically a plus sign (+), will lay directly under the grid line. This solves" "\n\tjustification related misalignment of labels." "\n\t(The total number of these tags is unlimited)" ) ;_ end of STRCAT ;_ end of STRCAT ;_ end of STRCAT ) ;_ end of ALERT (PROGN (PRINC "\n\t\t(SETQ no_stations T) to eliminate station text. " ) ;_ end of PRINC (PRINC "\n\t\tIf you do, remember to (SETQ no_stations NIL) when you are done.\n" ) ;_ end of PRINC (PRINC) (SETVAR "DIMZIN" 0) (IF (AND (> (GETVAR "cvport") 1) (EQ (GETVAR "tilemode") 0)) nil (IF (EQ (GETVAR "tilemode") 0) (VLA-PUT-MSPACE (VLA-GET-ACTIVEDOCUMENT (VLAX-GET-ACAD-OBJECT)) :VLAX-TRUE ) ;_ end of vla-put-MSpace ;;; (COMMAND "._mspace") (PRINC "\nPaper space is not active") ) ;_ end of if ) ;_ end of if (IF ukword nil (LOAD "ukword" "\nFile UKWORD.LSP not loaded! ") ) ;_ end of if (SETQ rtview (ukword 1 "continue" "Make the profile view current before continuing." "continue" ) ;_ end of ukword ) ;_ end of setq (COMMAND ".mview" "lock" "off" "all" "") (SETQ curvno (GETVAR "cvport")) ;;; (REGAPP "ACAD") (SETQ cvpss (SSGET "X" (LIST (CONS 410 (GETVAR "CTAB")) (CONS 69 curvno)) ) ;_ end of SSGET ) ;_ end of SETQ (SETQ cvpent (ENTGET (SSNAME cvpss 0) (LIST "ACAD"))) (SETQ vpscl (/ (GETVAR "viewsize") (CDR (ASSOC 41 cvpent)))) (SETQ vpscl_tst (ATOI (RTOS (/ (GETVAR "viewsize") (CDR (ASSOC 41 cvpent))) 2 0 ) ;_ end of RTOS ) ;_ end of ATOI ) ;_ end of SETQ (IF (NOT (EQUAL (IF (EQUAL vpscl vpscl_tst 0.001) (REM vpscl_tst 10.0) (REM vpscl 10.0) ) 0.0 0.001 ) ) (PROGN (PRINC (STRCAT "\nCurrent viewport scale is 1\"=" (RTOS vpscl 2 4) "'" ) ;_ end of STRCAT ) ;_ end of PRINC (IF uint nil (LOAD "uint" "File UINT.LSP not found! ") ) ;_ end of if (SETQ vpsclint (uint 1 "" "New viewport scale" (IF vpsclint vpsclint 100 ) ;_ end of if ) ;_ end of uint ) ;_ end of setq (COMMAND "'.zoom" (STRCAT "1/" (ITOA vpscl_tst) "xp")) (PRINC (STRCAT "\nViewport zoomed 1/" (ITOA vpscl_tst) "XP\n") ;_ end of STRCAT ) ;_ end of PRINC (SETQ vpscl (/ (GETVAR "viewsize") (CDR (ASSOC 41 cvpent)))) ) ;_ end of PROGN ) ;_ end of IF (COND ((OR (EQ (GETVAR "lunits") 1) (EQ (GETVAR "lunits") 5)) (PRINC (STRCAT "Viewport scale is: 1:" (RTOS vpscl 2 4) " (1:" (RTOS vpscl 2 4) ")" ) ;_ end of strcat ) ;_ end of princ ) ((EQ (GETVAR "lunits") 2) (PRINC (STRCAT "Viewport scale is: 1\"=" (RTOS vpscl 2 4) "' (1:" (RTOS vpscl 2 4) ")" ) ;_ end of strcat ) ;_ end of princ ) ((EQ (GETVAR "lunits") 3) (PRINC (STRCAT "Viewport scale is: 1\"=" (RTOS (/ vpscl 12) 2 4) "' (1:" (RTOS vpscl 2 4) ")" ) ;_ end of strcat ) ;_ end of princ ) ((EQ (GETVAR "lunits") 4) (PRINC (STRCAT "Viewport scale is: " (RTOS (/ 12.0000 vpscl) 5 4) "\"=1'-0\" (1:" (RTOS vpscl 2 4) ")" ) ;_ end of strcat ) ;_ end of princ ) ) ;_ end of cond (IF ureal nil (LOAD "ureal" "\nFile UREAL.LSP not loaded! ") ) ;_ end of if (SETQ cvcntr (GETVAR "viewctr") cvsize (GETVAR "viewsize") cvscle (/ cvsize (CDR (ASSOC 41 cvpent))) vrt_scale (ureal 1 "" (STRCAT "Vertical scale " (CHR 40) "1\"=?" (CHR 41)) (IF vrt_scale (FIX vrt_scale) (IF v_fact (FIX (/ cvscle v_fact)) 5 ) ;_ end of IF ) ;_ end of IF ) ;_ end of ureal vrt_fact (/ vpscl vrt_scale) cvwdth (* (CDR (ASSOC 40 cvpent)) cvscle) cvpllx (- (CAR cvcntr) (/ cvwdth 2)) cvplly (/ (- (CADR cvcntr) (/ cvsize 2)) vrt_fact) pscvcntr (CDR (ASSOC 10 cvpent)) ) ;_ end of SETQ (PRINC (STRCAT "\nCurrent Profile Beginning Station = " (RTOS cvpllx 2 2) ) ;_ end of strcat ) ;_ end of princ ;;; (SETQ sedata (SSGET "X" ;;; (LIST (CONS -4 "") ;;; (CONS 410 (GETVAR "CTAB")) ;;; ) ;_ end of LIST ;;; ) ;_ end of SSGET ;;; ) ;_ end of SETQ (IF (AND sedata (> (SSLENGTH sedata) 1)) (PROGN (VLA-PUT-MSPACE (VLA-GET-ACTIVEDOCUMENT (VLAX-GET-ACAD-OBJECT)) :VLAX-FALSE ) ;_ end of vla-put-MSpace ;;; (COMMAND "._pspace") (PRINC "\nSelect profile grid label block to update: ") (SETQ sedata (SSGET (LIST (CONS -4 "") (CONS 410 (GETVAR "CTAB")) ) ;_ end of LIST ) ;_ end of SSGET ) ;_ end of SETQ (VLA-PUT-MSPACE (VLA-GET-ACTIVEDOCUMENT (VLAX-GET-ACAD-OBJECT)) :VLAX-TRUE ) ;_ end of vla-put-MSpace ;;; (COMMAND "._mspace") ) ;_ end of PROGN ) ;_ end of IF (IF sedata (PROGN (SETQ lbelev_lst nil rbelev_lst nil sta_lst NIL ) ;_ end of SETQ (SETQ sedat (ENTNEXT (SSNAME sedata 0)) insert_ent sedat ) ;_ end of SETQ (WHILE (/= (CDR (ASSOC 0 (ENTGET sedat))) "SEQEND") (IF (EQ (CDR (ASSOC 0 (ENTGET sedat))) "ATTRIB") (COND ((EQ (SUBSTR (CDR (ASSOC 2 (ENTGET sedat))) 1 2) "LB") (IF lbelev_lst (SETQ lbelev_lst (APPEND lbelev_lst (LIST sedat))) (SETQ lbelev_lst (LIST sedat)) ) ;_ end of IF (SETQ sedat (ENTNEXT sedat)) ) ((EQ (SUBSTR (CDR (ASSOC 2 (ENTGET sedat))) 1 2) "RB") (IF rbelev_lst (SETQ rbelev_lst (APPEND rbelev_lst (LIST sedat))) (SETQ rbelev_lst (LIST sedat)) ) ;_ end of IF (SETQ sedat (ENTNEXT sedat)) ) ((EQ (TYPE (READ (CDR (ASSOC 2 (ENTGET sedat))))) 'INT) (IF sta_lst (SETQ sta_lst (APPEND sta_lst (LIST (LIST sedat (ENTNEXT sedat))) ) ;_ end of APPEND ) ;_ end of SETQ (SETQ sta_lst (LIST (LIST sedat (ENTNEXT sedat)))) ) ;_ end of IF (SETQ sedat (ENTNEXT (ENTNEXT sedat))) ) ) ;_ end of COND (SETQ sedat (ENTNEXT (ENTNEXT sedat))) ) ;_ end of IF ) ;_ end of WHILE (SETQ this_sta_lst sta_lst) (SETQ staval_lst (MAPCAR '(LAMBDA (x) (LIST (CDR (ASSOC 1 (ENTGET (CAR x)))) (CDR (ASSOC 1 (ENTGET (CADR x)))) ) ;_ end of list ) ;_ end of lambda sta_lst ) ;_ end of mapcar ) ;_ end of SETQ (SETQ staval_cnt 0) (WHILE (AND (< staval_cnt (LENGTH staval_lst)) (OR (EQ (CAR (NTH staval_cnt staval_lst)) "") (EQ (SUBSTR (CAR (NTH staval_cnt staval_lst)) 1 1) "-") ) ;_ end of OR ) ;_ end of AND (SETQ staval_cnt (1+ staval_cnt)) ) ;_ end of WHILE (IF (EQ staval_cnt (LENGTH staval_lst)) (SETQ staval_cnt 0) ) ;_ end of IF (SETQ sta0_tx1 (CAR (NTH staval_cnt staval_lst))) (SETQ sta0_tx2 (CADR (NTH staval_cnt staval_lst))) (IF (AND (EQ (TYPE (READ sta0_tx1)) 'INT) (EQ (SUBSTR sta0_tx2 1 1) "+") (EQ (TYPE (READ (SUBSTR sta0_tx2 2))) 'INT) ) ;_ end of AND (SETQ sta0_catxt (- (+ (* (ATOI sta0_tx1) 100) (ATOI (SUBSTR sta0_tx2 2)) ) ;_ end of + (* staval_cnt (IF (WCMATCH (STRCASE (CDR (ASSOC 2 (ENTGET (SSNAME sedata 0))))) "###PPGRIDB") 1.0 2.0 ) vpscl ) ) ;_ end of - ) ;_ end of SETQ (SETQ sta0_catxt NIL) ) ;_ end of IF (SETQ cursta (ureal 1 "" " Enter Station of 1st Profile Grid Label" (IF sta0_catxt sta0_catxt cvpllx ) ;_ end of IF ) ;_ end of uint ) ;_ end of setq (SETQ viewsta (ureal 1 "" " Enter Station @ Bottom Left Corner of Viewport" (IF (AND cvpllx (OR (EQUAL (REM cvpllx 1.0) 1.0 0.01) (EQUAL (REM cvpllx 1.0) 0.01 0.01) ) ;_ end of OR ) ;_ end of AND (COND ((EQUAL (REM cvpllx 1.0) 1.0 0.01) (FIX (1+ cvpllx)) ) ((EQUAL (REM cvpllx 1.0) 0.01 0.01) (FIX cvpllx) ) (T cvpllx) ) ;_ end of COND cvpllx ) ;_ end of IF ) ;_ end of uint ) ;_ end of setq (PRINC (STRCAT "\nCurrent Profile Base Elevation = " (RTOS cvplly 2 0) ) ;_ end of strcat ) ;_ end of princ (SETQ cedatum (ureal 1 "" " Enter Base Elevation (@ bottom of viewport)" cvplly ) ;_ end of ureal ) ;_ end of SETQ (panprv) (IF lbelev_lst (SETQ lbelev_lst (REVERSE lbelev_lst)) ) ;_ end of if (IF rbelev_lst (SETQ rbelev_lst (REVERSE rbelev_lst)) ) ;_ end of if (COND ((OR (EQ (STRCASE (CDR (ASSOC 2 (ENTGET (SSNAME sedata 0))))) "CPP20SPL" ) ;_ end of EQ (EQ (STRCASE (CDR (ASSOC 2 (ENTGET (SSNAME sedata 0))))) "CMUD20SP" ) ;_ end of EQ (WCMATCH (STRCASE (CDR (ASSOC 2 (ENTGET (SSNAME sedata 0))))) "20PPGRID*" ) ;_ end of EQ (EQ (STRCASE (CDR (ASSOC 2 (ENTGET (SSNAME sedata 0))))) "20SPCLGRID" ) ;_ end of EQ ) ;_ end of OR (SETQ grdwid 2.5) ) ((OR (EQ (STRCASE (CDR (ASSOC 2 (ENTGET (SSNAME sedata 0))))) "CPP30SPL" ) ;_ end of EQ (EQ (STRCASE (CDR (ASSOC 2 (ENTGET (SSNAME sedata 0))))) "CMUD30SP" ) ;_ end of EQ (WCMATCH (STRCASE (CDR (ASSOC 2 (ENTGET (SSNAME sedata 0))))) "30PPGRID*" ) ;_ end of WCMATCH (EQ (STRCASE (CDR (ASSOC 2 (ENTGET (SSNAME sedata 0))))) "30SPCLGRID" ) ;_ end of EQ ) ;_ end of OR (SETQ grdwid 1.66667) ) ((OR (EQ (STRCASE (CDR (ASSOC 2 (ENTGET (SSNAME sedata 0))))) "CPP40SPL" ) ;_ end of EQ (EQ (STRCASE (CDR (ASSOC 2 (ENTGET (SSNAME sedata 0))))) "CMUD40SP" ) ;_ end of EQ (WCMATCH (STRCASE (CDR (ASSOC 2 (ENTGET (SSNAME sedata 0))))) "40PPGRID*" ) ;_ end of WCMATCH (EQ (STRCASE (CDR (ASSOC 2 (ENTGET (SSNAME sedata 0))))) "40SPCLGRID" ) ;_ end of EQ ) ;_ end of OR (SETQ grdwid 2.5) ) ((OR (EQ (STRCASE (CDR (ASSOC 2 (ENTGET (SSNAME sedata 0))))) "CPP50SPL" ) ;_ end of EQ (EQ (STRCASE (CDR (ASSOC 2 (ENTGET (SSNAME sedata 0))))) "CMUD50SP" ) ;_ end of EQ (WCMATCH (STRCASE (CDR (ASSOC 2 (ENTGET (SSNAME sedata 0))))) "50PPGRID*" ) ;_ end of WCMATCH (EQ (STRCASE (CDR (ASSOC 2 (ENTGET (SSNAME sedata 0))))) "50SPCLGRID" ) ;_ end of EQ (EQ (STRCASE (CDR (ASSOC 2 (ENTGET (SSNAME sedata 0))))) "CPP25SPL" ) ;_ end of EQ (EQ (STRCASE (CDR (ASSOC 2 (ENTGET (SSNAME sedata 0))))) "CMUD25SP" ) ;_ end of EQ (WCMATCH (STRCASE (CDR (ASSOC 2 (ENTGET (SSNAME sedata 0))))) "25PPGRID*" ) ;_ end of WCMATCH (EQ (STRCASE (CDR (ASSOC 2 (ENTGET (SSNAME sedata 0))))) "25SPCLGRID" ) ;_ end of EQ ) ;_ end of OR (SETQ grdwid 2.0) ) ((OR (EQ (STRCASE (CDR (ASSOC 2 (ENTGET (SSNAME sedata 0))))) "CPP100SPL" ) ;_ end of EQ (EQ (STRCASE (CDR (ASSOC 2 (ENTGET (SSNAME sedata 0))))) "CMUD100SP" ) ;_ end of EQ (WCMATCH (STRCASE (CDR (ASSOC 2 (ENTGET (SSNAME sedata 0))))) "100PPGRID*" ) ;_ end of WCMATCH (EQ (STRCASE (CDR (ASSOC 2 (ENTGET (SSNAME sedata 0))))) "100SPCLGRID" ) ;_ end of EQ ) ;_ end of OR (SETQ grdwid 1.0) ) ((OR (EQ (STRCASE (CDR (ASSOC 2 (ENTGET (SSNAME sedata 0))))) "CPP60SPL" ) ;_ end of EQ (EQ (STRCASE (CDR (ASSOC 2 (ENTGET (SSNAME sedata 0))))) "CMUD60SP" ) ;_ end of EQ (WCMATCH (STRCASE (CDR (ASSOC 2 (ENTGET (SSNAME sedata 0))))) "60PPGRID*" ) ;_ end of WCMATCH (EQ (STRCASE (CDR (ASSOC 2 (ENTGET (SSNAME sedata 0))))) "60SPCLGRID" ) ;_ end of EQ ) ;_ end of OR (SETQ grdwid 1.66667) ) (T (SETQ grdwid 2.5)) ) ;_ end of COND (SETQ csdndx 0) ; (panprv) (IF stait nil (LOAD "stait" "\nFile STAIT.LSP not found! ") ) ;_ end of if (IF (OR (= (REM (/ vpscl vrt_fact) 1) 0) (= (REM (/ vpscl vrt_fact) 1) 0.5) ) ;_ end of OR (SETQ vrt_prec 0) (IF (= (REM (/ vpscl vrt_fact) 1) 0.25) (SETQ vrt_prec 1) (SETQ vrt_prec 2) ) ;_ end of if ) ;_ end of if (IF (> vrt_prec 0) (ALERT (STRCAT ;"Profile Viewport scale:\t" (RTOS vpscl 2 16) "Vertical Scale factor: \t" (RTOS vrt_fact 2 16) "\nElevation precision: \t" (ITOA vrt_prec) ) ;_ end of STRCAT ) ;_ end of ALERT ) ;_ end of IF (SETQ found_splitlbl (SSGET "x" (LIST (CONS 0 "INSERT") (CONS 2 "##ppbrklbl*,###ppbrklbl*") (CONS 410 (GETVAR "CTAB")) ) ;_ end of LIST ) ;_ end of SSGET ) ;_ end of SETQ (IF found_splitlbl (PROGN ;check whether this intermediate elevation label block belongs with this profile grid or another (SETQ next_sedata (ENTGET (ENTNEXT (SSNAME sedata 0)))) (SETQ this_min_sta (CADR (ASSOC 10 next_sedata)) this_max_sta this_min_sta this_min_el (CADDR (ASSOC 10 next_sedata)) this_max_el (CADR (POLAR (CDR (ASSOC 10 next_sedata)) (/ PI 2.0) 0.5 ) ;_ end of POLAR ) ;_ end of CADR fndsllen (SSLENGTH found_splitlbl) fndcnt 0 fnd_ss (SSADD) ) ;_ end of SETQ (WHILE (NOT (EQ (CDR (ASSOC 0 next_sedata)) "SEQEND")) (SETQ next_sedata (ENTGET (ENTNEXT (CDR (ASSOC -1 next_sedata))) ) ;_ end of ENTGET ) ;_ end of SETQ (IF (AND (ASSOC 2 next_sedata) (WCMATCH (CDR (ASSOC 2 next_sedata)) "+#*") ) ;_ end of AND (SETQ this_max_sta (MAX this_max_sta (CADR (ASSOC 10 next_sedata)) ) ;_ end of MAX ) ;_ end of SETQ ) ;_ end of IF ) ;_ end of WHILE (WHILE (< fndcnt fndsllen) (SETQ this_fnd (ENTGET (SSNAME found_splitlbl fndcnt))) (IF (AND (> (CADR (ASSOC 10 this_fnd)) this_min_sta) ;check that this intermediate label's insertion point lies within this grid's bottom row (< (CADR (ASSOC 10 this_fnd)) this_max_sta) (> (CADDR (ASSOC 10 this_fnd)) this_min_el) (< (CADDR (ASSOC 10 this_fnd)) this_max_el) ) ;_ end of AND (PROGN (SSADD (SSNAME found_splitlbl fndcnt) fnd_ss) ;if it does then include it in the selection set (SETQ ustael_split_note T) ) ;_ end of PROGN ) ;_ end of IF (SETQ fndcnt (1+ fndcnt)) ;otherwise discard it from the selection set ) ;_ end of WHILE (IF (> (SSLENGTH fnd_ss) 0) (SETQ found_splitlbl fnd_ss fnd_ss NIL ) ;_ end of SETQ (SETQ found_splitlbl NIL fnd_ss NIL ) ;_ end of SETQ ) ;_ end of IF ) ;_ end of PROGN ) ;_ end of IF (IF found_splitlbl (PROGN (SETQ fslbl_len (SSLENGTH found_splitlbl) fslbl_cnt 0 fslbl_ptlst NIL ) ;_ end of SETQ (WHILE (< fslbl_cnt fslbl_len) (SETQ fslbl_ptlst (APPEND fslbl_ptlst (LIST (CADR (ASSOC 10 (ENTGET (SSNAME found_splitlbl fslbl_cnt ) ;_ end of SSNAME ) ;_ end of ENTGET ) ;_ end of ASSOC ) ;_ end of CADR ) ;_ end of LIST ) ;_ end of APPEND ) ;_ end of SETQ (SETQ fslbl_cnt (1+ fslbl_cnt)) ) ;_ end of WHILE (SETQ min_fslbl_pt (EVAL (CONS 'MIN (APPEND fslbl_ptlst (LIST (CAR pscvcntr)) ) ;_ end of APPEND ) ;_ end of CONS ) ;_ end of EVAL max_fslbl_pt (EVAL (CONS 'MAX (APPEND fslbl_ptlst (LIST (CAR pscvcntr)) ) ;_ end of APPEND ) ;_ end of CONS ) ;_ end of EVAL ) ;_ end of SETQ ) ;_ end of PROGN ) ;_ end of IF (COND ((NOT found_splitlbl) (SETQ updatt "Both")) ((EQ (CAR pscvcntr) min_fslbl_pt) (SETQ updatt "Left") (IF (EQUAL cursta viewsta 100.0) (ALERT (STRCAT "NOTICE!" "\nYou must also run USTAEL in the right half of the" "\nsplit profile to update the grid elevation labels" "\nalong its right side if this operation changes them" "\nto match the left side!" ) ;_ end of STRCAT ) ;_ end of ALERT ) ;_ end of IF ) ((EQ (CAR pscvcntr) max_fslbl_pt) (SETQ updatt "RIGHT")) (T (SETQ updatt "Middle") ;_ end of setq ) ) ;_ end of COND (IF (OR (EQ (STRCASE updatt) "BOTH") (EQ (STRCASE updatt) "LEFT") ) ;_ end of OR (PROGN (FOREACH n sta_lst (SETQ this_sta (+ (* csdndx grdwid vpscl) cursta) this_sta_txt (stait this_sta 0) sta_pos 1 ) ;_ end of setq (WHILE (NOT (OR (WCMATCH (SUBSTR this_sta_txt sta_pos 2) "-#") (WCMATCH (SUBSTR this_sta_txt sta_pos 2) "#+") ) ;_ end of or ) ;_ end of not (SETQ sta_pos (1+ sta_pos)) ) ;_ end of while (IF ;(OR (< this_sta (CADR (CAR align_lst))) (< this_sta 0) ;) (IF blank_neg_sta NIL (PROGN (IF (AND aln_name (EQ (TYPE aln_name) 'STR)) (PROGN (PRINC (STRCAT "\nCurrent alignment name is: " aln_name " " ) ;_ end of STRCAT ) ;_ end of PRINC (PRINC) ) ;_ end of PROGN ) ;_ end of IF (SETQ blank_neg_sta (ukword 1 "Yes No" "Blank out negative station labels? [Yes/No]" "Yes" ) ;_ end of ukword ) ;_ end of SETQ ) ;_ end of PROGN ) ;_ end of IF ) ;_ end of IF (COND ((AND ;;; (OR (< this_sta (CADR (CAR align_lst))) (< this_sta 0) blank_neg_sta (EQ (STRCASE blank_neg_sta) "YES") ) ;_ end of AND (SETQ csdatc "") (SETQ csdatp "") ;;; (setq blank_neg_sta nil) ) ((EQ no_stations T) (SETQ csdatc "") (SETQ csdatp "") ) (T ;(OR(EQ (STRCASE blank_neg_sta) "NO")(NOT blank_neg_sta)) (SETQ csdatc (SUBSTR this_sta_txt 1 sta_pos)) (SETQ csdatp (SUBSTR this_sta_txt (1+ sta_pos))) ;;; (setq blank_neg_sta nil) ) ) ;_ end of COND (SETQ sta#_ent (ENTGET (CAR n)) plus_ent (ENTGET (CADR n)) ) ;_ end of setq (SETQ sta#_ent (SUBST (CONS 1 csdatc) (ASSOC 1 sta#_ent) sta#_ent ) ;_ end of SUBST ) ;_ end of setq (ENTMOD sta#_ent) (SETQ plus_ent (SUBST (CONS 1 csdatp) (ASSOC 1 plus_ent) plus_ent ) ;_ end of SUBST ) ;_ end of setq (ENTMOD plus_ent) (SETQ csdndx (1+ csdndx)) ) ;_ end of foreach (SETQ blank_neg_sta NIL) (IF (OR (= (REM (/ vpscl vrt_fact) 1) 0) (= (REM (/ vpscl vrt_fact) 1) 0.5) ) ;_ end of OR (SETQ vrt_prec 0) (IF (= (REM (/ vpscl vrt_fact) 1) 0.25) (SETQ vrt_prec 1) (SETQ vrt_prec 2) ) ;_ end of if ) ;_ end of if (SETQ cedndx 0 elevtxt_lst NIL ) ;_ end of SETQ ;(setq grdhgt (ureal 1 "" "Ratio of station label spacing to elevation label spacing" (if grdhgt grdhgt 1.0))) (SETQ sta_lst_n0 (CDR (ASSOC 11 (ENTGET (CAR (NTH 0 sta_lst)))) ) ;_ end of CDR sta_lst_n1 (CDR (ASSOC 11 (ENTGET (CAR (NTH 1 sta_lst)))) ) ;_ end of CDR rbelev_lst_n0 (CDR (ASSOC 11 (ENTGET (NTH 0 rbelev_lst))) ) ;_ end of CDR rbelev_lst_n1 (CDR (ASSOC 11 (ENTGET (NTH 1 rbelev_lst))) ) ;_ end of CDR grdhgt (/ (DISTANCE sta_lst_n0 sta_lst_n1) (DISTANCE rbelev_lst_n0 rbelev_lst_n1) ) ;_ end of / ) ;_ end of setq (FOREACH n lbelev_lst (SETQ cedatb (RTOS ;;; (+ cedatum (* cedndx grdwid (/ vpscl vrt_fact))) (+ cedatum (* cedndx (/ grdwid grdhgt) (/ vpscl (COND ;;; ((MEMBER (ATOI (RTOS VPSCL 2 0)) '(5 10)) ;;; (* vrt_fact 2.0) ;;; ) ;;; ((MEMBER ;;; (ATOI (RTOS VPSCL 2 0)) ;;; '(20 30 40 60 80 200 300 400 600 800) ;;; ) ;_ end of MEMBER ;;; (* vrt_fact 0.5 grdwid) ;;; ) ;;; ((MEMBER (ATOI (RTOS VPSCL 2 0)) ;;; '(50 100 500) ;;; ) ;_ end of MEMBER ;;; vrt_fact ;;; ) (T vrt_fact) ) ;_ end of COND ) ;_ end of / ) ;_ end of * ) ;_ end of + 2 vrt_prec ) ;_ end of RTOS ) ;_ end of SETQ (SETQ elevtxt_lst (APPEND elevtxt_lst (LIST cedatb))) (SETQ elev_ent (ENTGET n)) (SETQ elev_ent (SUBST (CONS 1 cedatb) (ASSOC 1 elev_ent) elev_ent ) ;_ end of SUBST ) ;_ end of setq (ENTMOD elev_ent) (SETQ cedndx (1+ cedndx)) ) ;_ end of foreach (SETQ cedndx 0 elevtxt_lst NIL ) ;_ end of SETQ (FOREACH n rbelev_lst (SETQ cedatb (RTOS ;;; (+ cedatum (* cedndx grdwid (/ vpscl vrt_fact))) (+ cedatum (* cedndx (/ grdwid grdhgt) (/ vpscl (COND ;;; ((MEMBER (ATOI (RTOS VPSCL 2 0)) '(5 10)) ;;; (* vrt_fact 2.0) ;;; ) ;;; ((MEMBER ;;; (ATOI (RTOS VPSCL 2 0)) ;;; '(20 30 40 60 80 200 300 400 600 800) ;;; ) ;_ end of MEMBER ;;; (* vrt_fact 0.5 grdwid) ;;; ) ;;; ((MEMBER (ATOI (RTOS VPSCL 2 0)) ;;; '(50 100 500) ;;; ) ;_ end of MEMBER ;;; vrt_fact ;;; ) (T vrt_fact) ) ;_ end of COND ) ;_ end of / ) ;_ end of * ) ;_ end of + 2 vrt_prec ) ;_ end of RTOS ) ;_ end of SETQ (SETQ elevtxt_lst (APPEND elevtxt_lst (LIST cedatb))) (SETQ elev_ent (ENTGET n)) (SETQ elev_ent (SUBST (CONS 1 cedatb) (ASSOC 1 elev_ent) elev_ent ) ;_ end of SUBST ) ;_ end of setq (ENTMOD elev_ent) (SETQ cedndx (1+ cedndx)) ) ;_ end of foreach (ENTUPD insert_ent) ) ;_ end of PROGN (COND ((EQ (STRCASE updatt) "RIGHT") (SETQ cedndx 0 elevtxt_lst NIL ) ;_ end of SETQ (FOREACH n rbelev_lst (SETQ cedatb (RTOS ;;; (+ cedatum (* cedndx grdwid (/ vpscl vrt_fact))) (+ cedatum (* cedndx (IF (WCMATCH (STRCASE (CDR (ASSOC 2 (ENTGET (SSNAME sedata 0))))) "###PPGRID*") 0.5 1.0 ;(/ grdwid 2.0) ) (/ vpscl (COND ;;; ((MEMBER (ATOI (RTOS VPSCL 2 0)) ;;; '(5 10) ;;; ) ;_ end of MEMBER ;;; (* vrt_fact 2.0) ;;; ) ;;; ((MEMBER ;;; (ATOI (RTOS VPSCL 2 0)) ;;; '(20 30 40 60 80 200 300 400 600 800) ;;; ) ;_ end of MEMBER ;;; (* vrt_fact 0.5 grdwid) ;;; ) ;;; ((MEMBER (ATOI (RTOS VPSCL 2 0)) ;;; '(50 100 500) ;;; ) ;_ end of MEMBER ;;; vrt_fact ;;; ) (T vrt_fact) ) ;_ end of COND ) ;_ end of / ) ;_ end of * ) ;_ end of + 2 vrt_prec ) ;_ end of RTOS ) ;_ end of SETQ (SETQ elevtxt_lst (APPEND elevtxt_lst (LIST cedatb))) (SETQ elev_ent (ENTGET n)) (SETQ elev_ent (SUBST (CONS 1 cedatb) (ASSOC 1 elev_ent) elev_ent ) ;_ end of SUBST ) ;_ end of setq (ENTMOD elev_ent) (SETQ cedndx (1+ cedndx)) ) ;_ end of foreach (ENTUPD insert_ent) (IF debug_ustael (PROGN (PRINC "\nWE DID RIGHT! (1) ") (PRINC)) ) ;_ end of IF ) ((OR (EQ (STRCASE updatt) "LEFT") (EQ (STRCASE updatt) "MIDDLE") ) ;_ end of OR (SETQ cedndx 0 elevtxt_lst NIL ) ;_ end of SETQ (FOREACH n lbelev_lst (SETQ cedatb (RTOS ;;; (+ cedatum (* cedndx grdwid (/ vpscl vrt_fact))) (+ cedatum (* cedndx (/ grdwid grdhgt) (/ vpscl (COND ;;; ((MEMBER (ATOI (RTOS VPSCL 2 0)) ;;; '(5 10) ;;; ) ;_ end of MEMBER ;;; (* vrt_fact 2.0) ;;; ) ;;; ((MEMBER ;;; (ATOI (RTOS VPSCL 2 0)) ;;; '(20 30 40 60 80 200 300 400 600 800) ;;; ) ;_ end of MEMBER ;;; (* vrt_fact 0.5 grdwid) ;;; ) ;;; ((MEMBER (ATOI (RTOS VPSCL 2 0)) ;;; '(50 100 500) ;;; ) ;_ end of MEMBER ;;; vrt_fact ;;; ) (T vrt_fact) ) ;_ end of COND ) ;_ end of / ) ;_ end of * ) ;_ end of + 2 vrt_prec ) ;_ end of RTOS ) ;_ end of SETQ (SETQ elevtxt_lst (APPEND elevtxt_lst (LIST cedatb))) (IF (EQ (STRCASE updatt) "LEFT") (PROGN (SETQ elev_ent (ENTGET n)) (SETQ elev_ent (SUBST (CONS 1 cedatb) (ASSOC 1 elev_ent) elev_ent ) ;_ end of SUBST ) ;_ end of setq (ENTMOD elev_ent) ) ;_ end of PROGN ) ;_ end of IF (SETQ cedndx (1+ cedndx)) ) ;_ end of foreach (IF (EQ (STRCASE updatt) "LEFT") (ENTUPD insert_ent) ) ;_ end of IF (IF debug_ustael (PROGN (PRINC "\nWE DID LEFT OR MIDDLE! (1) ") (PRINC)) ) ;_ end of IF ) ) ;_ end of COND ) ;_ end of IF (IF (AND (OR (EQ (STRCASE updatt) "LEFT") (EQ (STRCASE updatt) "MIDDLE") (EQ (STRCASE updatt) "RIGHT") ) ;_ end of OR found_splitlbl ) ;_ end of AND (PROGN (SETQ fslbl_len (SSLENGTH found_splitlbl)) ;;; (IF (AND (EQ (STRCASE updatt) "MIDDLE") (> fslbl_len 2)) ;;; (vla-put-MSpace (vla-get-Activedocument (vlax-get-Acad-Object)) :vlax-false) ;;; ;;; (PROGN (COMMAND ".pspace") ;;; (PRINC "\nSelect split labels to update") ;;; (SETQ found_splitlbl ;;; (SSGET ;;; '((0 . "INSERT") (2 . "##ppbrklbl")) ;;; ) ;_ end of SSGET ;;; ) ;_ end of SETQ ;;; (COMMAND ".mspace") ;;; ) ;_ end of PROGN ;;; ) ;_ end of IF (SETQ fslbl_len (SSLENGTH found_splitlbl) fslbl_cnt 0 fslbl_symlst NIL lellbllst NIL rellbllst NIL ) ;_ end of SETQ (WHILE (< fslbl_cnt fslbl_len) (SET (READ (STRCAT "ellbl_" (ITOA (1+ fslbl_cnt)))) (ENTGET (SSNAME found_splitlbl fslbl_cnt)) ) ;_ end of SET (SETQ fslbl_symlst (APPEND fslbl_symlst (LIST (READ (STRCAT "ellbl_" (ITOA (1+ fslbl_cnt)) ) ;_ end of STRCAT ) ;_ end of READ ) ;_ end of LIST ) ;_ end of APPEND ) ;_ end of SETQ (SETQ fslbl_cnt (1+ fslbl_cnt)) ) ;_ end of WHILE (FOREACH n fslbl_symlst (IF (< (CADR (ASSOC 10 (EVAL n))) (CAR pscvcntr)) (SETQ lellbllst (APPEND lellbllst (LIST n))) ;_ end of SETQ (SETQ rellbllst (APPEND rellbllst (LIST n))) ;_ end of SETQ ) ;_ end of IF ) ;_ end of FOREACH (SETQ assoc_10_llst (MAPCAR '(LAMBDA (x) (CADR (ASSOC 10 (EVAL x)))) lellbllst ) ;_ end of MAPCAR ) ;_ end of SETQ (SETQ assoc_10_rlst (MAPCAR '(LAMBDA (x) (CADR (ASSOC 10 (EVAL x)))) rellbllst ) ;_ end of MAPCAR ) ;_ end of SETQ (IF lellbllst (SETQ left_ellbl (EVAL (NTH (- (LENGTH assoc_10_llst) (LENGTH (MEMBER (EVAL (CONS 'MAX assoc_10_llst)) assoc_10_llst ) ;_ end of MEMBER ) ;_ end of LENGTH ) ;_ end of - lellbllst ) ;_ end of NTH ) ;_ end of EVAL ) ;_ end of SETQ (SETQ left_ellbl NIL) ) ;_ end of IF (IF rellbllst (SETQ right_ellbl (EVAL (NTH (- (LENGTH assoc_10_rlst) (LENGTH (MEMBER (EVAL (CONS 'MIN assoc_10_rlst)) assoc_10_rlst ) ;_ end of MEMBER ) ;_ end of LENGTH ) ;_ end of - rellbllst ) ;_ end of NTH ) ;_ end of EVAL ) ;_ end of SETQ (SETQ right_ellbl NIL) ) ;_ end of IF ;;; (IF (> (CADR (ASSOC 10 ellbl_0)) (CADR (ASSOC 10 ellbl_1))) ;;; (PROGN (SETQ ellbl_2 ellbl_0)) ;;; (PROGN (SETQ ellbl_2 ellbl_1 ;;; ellbl_1 ellbl_0 ;;; ) ;_ end of SETQ ;;; ) ;_ end of PROGN ;;; ) ;_ end of IF (COND ((EQ (STRCASE updatt) "LEFT") (SETQ nextdef right_ellbl) (IF debug_ustael (PROGN (PRINC "\nWE DID LEFT ") (PRINC)) ) ;_ end of IF ) ((OR (EQ (STRCASE updatt) "RIGHT") (EQ (STRCASE updatt) "MIDDLE") ) ;_ end of OR (SETQ nextdef left_ellbl) (IF debug_ustael (PROGN (PRINC "\nWE DID RIGHT OR MIDDLE! (2)") (PRINC) ) ;_ end of PROGN ) ;_ end of IF ) ) ;_ end of COND (SETQ attr_ls1 NIL) (WHILE (AND nextdef (/= (CDR (ASSOC 0 nextdef)) "SEQEND")) (IF (EQ (CDR (ASSOC 0 nextdef)) "ATTRIB") (SETQ attr_ls1 (APPEND attr_ls1 (LIST (LIST (CDR (ASSOC 2 nextdef)) nextdef) ) ;_ end of LIST ) ;_ end of APPEND ) ;_ end of SETQ ) ;_ end of IF (SETQ nextename (ENTNEXT (CDR (ASSOC -1 nextdef)))) (IF nextename (SETQ nextdef (ENTGET nextename)) (SETQ nextdef NIL) ) ;_ end of IF ) ;_ end of WHILE (SETQ rlattr_ls1 (CDR (MEMBER (ASSOC "MLB+0" attr_ls1) attr_ls1) ) ;right stack on this label block llattr_ls1 (REVERSE (MEMBER (ASSOC "MLB+0" attr_ls1) ;left stack on this label block (REVERSE attr_ls1) ) ;_ end of MEMBER ) ;_ end of REVERSE ) ;_ end of SETQ (COND ((EQ (STRCASE updatt) "LEFT") (MAPCAR '(LAMBDA (x) (ENTMOD x)) (MAPCAR '(LAMBDA (x y) (SUBST (CONS 1 y) (ASSOC 1 (CADR x)) (CADR x)) ;_ end of SUBST ) ;_ end of LAMBDA llattr_ls1 (REVERSE elevtxt_lst) ) ;_ end of MAPCAR ) ;_ end of MAPCAR (MAPCAR '(LAMBDA (x) (ENTUPD (CDAADR x))) llattr_ls1) (IF debug_ustael (PROGN (PRINC "\nWE DID LEFT! (3) ") (PRINC)) ) ;_ end of IF ) ((OR (EQ (STRCASE updatt) "RIGHT") (EQ (STRCASE updatt) "MIDDLE") ) ;_ end of OR (MAPCAR '(LAMBDA (x) (ENTMOD x)) (MAPCAR '(LAMBDA (x y) (SUBST (CONS 1 y) (ASSOC 1 (CADR x)) (CADR x)) ;_ end of SUBST ) ;_ end of LAMBDA rlattr_ls1 (REVERSE elevtxt_lst) ) ;_ end of MAPCAR ) ;_ end of MAPCAR (MAPCAR '(LAMBDA (x) (ENTUPD (CDAADR x))) rlattr_ls1) (IF debug_ustael (PROGN (PRINC "\nWE DID RIGHT OR MIDDLE! (3) ") (PRINC) ) ;_ end of PROGN ) ;_ end of IF ) ) ;_ end of COND (IF (EQ (STRCASE updatt) "MIDDLE") (PROGN (SETQ nextdef right_ellbl attr_ls1 NIL ) ;_ end of SETQ (WHILE (AND nextdef (/= (CDR (ASSOC 0 nextdef)) "SEQEND")) (IF (EQ (CDR (ASSOC 0 nextdef)) "ATTRIB") (SETQ attr_ls1 (APPEND attr_ls1 (LIST (LIST (CDR (ASSOC 2 nextdef)) nextdef ) ;_ end of LIST ) ;_ end of LIST ) ;_ end of APPEND ) ;_ end of SETQ ) ;_ end of IF (SETQ nextename (ENTNEXT (CDR (ASSOC -1 nextdef)))) (IF nextename (SETQ nextdef (ENTGET nextename)) (SETQ nextdef NIL) ) ;_ end of IF ) ;_ end of WHILE (SETQ rlattr_ls1 (CDR (MEMBER (ASSOC "MLB+0" attr_ls1) attr_ls1 ) ;_ end of MEMBER ) ;right stack on this label block llattr_ls1 (REVERSE (MEMBER (ASSOC "MLB+0" attr_ls1) ;left stack on this label block (REVERSE attr_ls1) ) ;_ end of MEMBER ) ;_ end of REVERSE ) ;_ end of SETQ (MAPCAR '(LAMBDA (x) (ENTMOD x)) (MAPCAR '(LAMBDA (x y) (SUBST (CONS 1 y) (ASSOC 1 (CADR x)) (CADR x)) ;_ end of SUBST ) ;_ end of LAMBDA llattr_ls1 (REVERSE elevtxt_lst) ) ;_ end of MAPCAR ) ;_ end of MAPCAR (MAPCAR '(LAMBDA (x) (ENTUPD (CDAADR x))) llattr_ls1) ) ;_ end of PROGN ) ;_ end of IF ) ;_ end of PROGN ) ;_ end of IF ) ;_ end of PROGN ) ;_ end of IF (COMMAND ".mview" "lock" "on" "all" "") (VLA-PUT-MSPACE (VLA-GET-ACTIVEDOCUMENT (VLAX-GET-ACAD-OBJECT)) :VLAX-FALSE ) ;_ end of vla-put-MSpace ;;; (COMMAND ".pspace") (IF old_ustaelDIMZIN (SETVAR "DIMZIN" old_ustaelDIMZIN) ) ;_ end of IF ) ;_ end of PROGN ) ;_ end of IF (SETQ *error* orig_error) (PRINC) ) ;_ end of defun (DEFUN panprv () (SETQ oldfunname4 oldfunname3 oldfunname3 oldfunname2 oldfunname2 oldfunname1 oldfunname1 oldfunname0 oldfunname0 funname funname "pan_prv") (PROGN (SETQ nvctrx (+ viewsta (/ cvwdth 2)) nvctry (+ (* cedatum vrt_fact) (/ cvsize 2)) pxdist (- (CAR cvcntr) nvctrx) pydist (- (CADR cvcntr) nvctry) ) ;_ end of setq (IF debug_panprv (PROGN (PRINC "\nnvctrx = ") (PRINC nvctrx) (PRINC "\nnvctry = ") (PRINC nvctry) (PRINC "\npxdist = ") (PRINC pxdist) (PRINC "\npydist = ") (PRINC pydist) (PRINC "\n") (PRINC) ) ;_ end of PROGN ) ;_ end of IF (PRINC (STRCAT "dX=" (RTOS pxdist) ", dY=" (RTOS pydist))) (COMMAND "._zoom" "c" (STRCAT (RTOS nvctrx) "," (RTOS nvctry)) "" ) ;_ end of command ) ;_ end of progn ) ;_ end of defun ;|«Visual LISP© Format Options» (72 2 40 2 T "end of " 60 9 2 0 1 nil nil nil T) ***Don't add text below the comment!***|;