;;; ;;; Author: Henry C. Francis ;;; 425 N. Ashe St. ;;; Southern Pines, NC 28387 ;;; ;;; http://www.paracadd.com ;;; All rights reserved. ;;; ;;; Copyright: 11-18-2014 ;;; Edited: 11-18-2014 ;;; (DEFUN C:SLOPEBYTEXT (/ first_ent first_sta_pt first_txt first_txt_lst new_slope_txt second_ent second_sta_pt second_txt second_txt_lst slope_ent slope_sel slope_txt slope_txt_lst text-rise text-run this_slope ) (PRINC "\nSelect first Invert text: ") ;must end in ###.#' (PRINC) (SETQ first_ent (ENTSEL)) (PRINC "\nSelect second Invert text: ") ;;must end in ###.#' (PRINC) (SETQ second_ent (ENTSEL)) (IF first_ent (SETQ first_txt (CDR (ASSOC 1 (ENTGET (CAR first_ent))))) ) ;_ end of IF (IF second_ent (SETQ second_txt (CDR (ASSOC 1 (ENTGET (CAR second_ent))))) ) ;_ end of IF (IF (AND first_txt second_txt) (PROGN (IF check_for_doslib NIL (LOAD "check_for_doslib" "\nFile CHECK_FOR_DOSLIB.LSP not loaded! ") ) ;_ end of IF (check_for_doslib) (IF DOS_STRTOKENS (PROGN (SETQ first_txt_lst (DOS_STRTOKENS first_txt " '")) (SETQ second_txt_lst (DOS_STRTOKENS second_txt " '")) (IF upoint NIL (LOAD "upoint" "\nFile UPOINT.LSP not loaded! ") ) ;_ end of IF (SETQ first_sta_pt (upoint 1 "" "First station point (Y-value is ignored)" NIL NIL)) (SETQ second_sta_pt (upoint 1 "" "Second station point (Y-value is ignored)" NIL NIL)) (SETQ text-run (- (MAX (CAR first_sta_pt) (CAR second_sta_pt)) (MIN (CAR first_sta_pt) (CAR second_sta_pt)))) (COND ((AND (MEMBER "OUT" first_txt_lst) (MEMBER "IN" second_txt_lst)) (SETQ text-rise (- (ATOF (CADR (REVERSE first_txt_lst))) (ATOF (CADR (REVERSE second_txt_lst))))) (PRINC (STRCAT "\nRise = " (CADR (REVERSE first_txt_lst)) "-" (CADR (REVERSE second_txt_lst)) " = " (RTOS text-rise 2 3) ) ;_ end of STRCAT ) ;_ end of PRINC ) ((AND (MEMBER "IN" first_txt_lst) (MEMBER "OUT" second_txt_lst)) (SETQ text-rise (- (ATOF (CADR (REVERSE second_txt_lst))) (ATOF (CADR (REVERSE first_txt_lst))))) (PRINC (STRCAT "\nRise = " (CADR (REVERSE second_txt_lst)) "-" (CADR (REVERSE first_txt_lst)) " = " (RTOS text-rise 2 3) ) ;_ end of STRCAT ) ;_ end of PRINC ) ) ;_ end of COND (PRINC (STRCAT "\nRun = " (RTOS (MAX (CAR first_sta_pt) (CAR second_sta_pt)) 2 3) "-" (RTOS (MIN (CAR first_sta_pt) (CAR second_sta_pt)) 2 3) " = " (RTOS text-run 2 3) ) ;_ end of STRCAT ) ;_ end of PRINC (SETQ this_slope (/ text-rise text-run)) (IF ureal NIL (LOAD "ureal" "\nFile UREAL.LSP not loaded! ") ) ;_ end of IF (IF this_slope_prec NIL (SETQ this_slope_prec (ureal 1 "" "Enter # of slope decimal places" (IF this_slope_prec this_slope_prec 2 ) ;_ end of IF ) ;_ end of ureal ) ;_ end of SETQ ) (PRINC (STRCAT "\nSlope = " (RTOS this_slope 2 5) " = " (RTOS (* this_slope 100.0) 2 this_slope_prec) "%") ) ;_ end of PRINC (PRINC) (PRINC "\nSelect slope text to update: ") (PRINC) (SETQ slope_sel (ENTSEL)) (IF (AND slope_sel (EQ (CDR (ASSOC 0 (ENTGET (CAR slope_sel)))) "TEXT")) (PROGN (SETQ slope_ent (ENTGET (CAR slope_sel))) (SETQ slope_txt (CDR (ASSOC 1 slope_ent))) (WHILE (WCMATCH slope_txt "*%%") (SETQ slope_txt (SUBSTR slope_txt 1 (1- (STRLEN slope_txt)))) ) ;_ end of WHILE (SETQ slope_txt_lst (DOS_STRTOKENS slope_txt " %")) (IF (AND (EQ (TYPE (READ (CADR (REVERSE slope_txt_lst)))) 'REAL) (EQ (CAR (REVERSE slope_txt_lst)) "") (WCMATCH slope_txt "*%") ) ;_ end of AND (PROGN (SETQ slope_txt_lst (MAPCAR '(LAMBDA (x) (STRCAT x " ")) slope_txt_lst)) (SETQ slope_txt_lst (REVERSE (CONS "%" (CONS (RTOS (* this_slope 100.0) 2 this_slope_prec) (CDDR (REVERSE slope_txt_lst)))) ) ;_ end of REVERSE ) ;_ end of SETQ (SETQ new_slope_txt (EVAL (CONS 'STRCAT slope_txt_lst))) (WHILE (WCMATCH new_slope_txt "*%%") (SETQ new_slope_txt (SUBSTR new_slope_txt 1 (1- (STRLEN new_slope_txt)))) ) ;_ end of WHILE (SETQ slope_ent (SUBST (CONS 1 new_slope_txt) (ASSOC 1 slope_ent) slope_ent)) (ENTMOD slope_ent) ) ;_ end of PROGN (PROGN (ALERT "Selected slope text must end in a real followed by a percent sign, e.g., \"#.##%\"") (PRINC "slope_txt_lst=") (PRINC slope_txt_lst) (PRINC "slope_txt=") (PRINC slope_txt) (PRINC) ) ;_ end of PROGN ) ;_ end of IF ) ;_ end of PROGN ) ;_ end of IF ) ;_ end of PROGN (PROGN (ALERT "Download and install DOSLIB from Robert McNeel & Associates to use this program") ) ;_ end of PROGN ) ;_ end of IF ) ;_ end of PROGN (ALERT "You must select two text entites with invert values for the slope you want to calculate.") ) ;_ end of IF (PRINC) ) ;_ end of DEFUN ;;;****************************************************************************** (DEFUN C:RESETRIM (/ cnt col-cnt dot-cnt last-num-cnt mh-ent mh-ent-lay mh-grph-ent new-rim-txt num-cnt rimset_ss rim_pt this-txt this-txt-ent this_rim ) (IF dimscl NIL (LOAD "dimscl" "\nFile DIMSCL.LSP not loaded! ") ) ;_ end of IF (dimscl) (IF ureal NIL (LOAD "ureal" "\nFile UREAL.LSP not loaded! ") ) ;_ end of IF (SETQ this_rim (ureal 1 "" "Enter rim" (IF this_rim this_rim NIL ) ;_ end of IF ) ;_ end of ureal ) ;_ end of SETQ (IF upoint NIL (LOAD "upoint" "\nFile UPOINT.LSP not loaded! ") ) ;_ end of IF (SETQ rim_pt (upoint 1 "" "select current rim point" NIL NIL)) (SETQ mh-grph-ent (SSGET "F" (LIST (POLAR rim_pt PI 0.1) (POLAR rim_pt 0.0 0.1)) '((0 . "POLYLINE")))) (IF mh-grph-ent (PROGN (SETQ mh-ent (ENTGET (SSNAME mh-grph-ent 0))) (SETQ mh-ent-lay (CDR (ASSOC 8 mh-ent))) (IF v_fact (STRCAT "Current vertical scale factor is " (RTOS v_fact 2 2) ".") ; Enter vertical scale factor") (SETQ v_fact (ureal 1 "" (STRCAT "Enter vertical scale factor") 10.0)) ) ;_ end of IF (PRINC "\nSelect the manhole label elements. ") (SETQ rimset_ss (SSGET)) (SETQ cnt 0) (WHILE (< cnt (SSLENGTH rimset_ss)) (IF (AND (SETQ this-txt-ent (ENTGET (SSNAME rimset_ss cnt))) (EQ (CDR (ASSOC 0 this-txt-ent)) "TEXT") (WCMATCH (SETQ this-txt (CDR (ASSOC 1 this-txt-ent))) "*RIM*") ) ;_ end of AND (PROGN (SETQ col-cnt 1) (WHILE (NOT (WCMATCH (SUBSTR this-txt col-cnt) "RIM*")) (SETQ col-cnt (1+ col-cnt)) ) ;_ end of WHILE (SETQ num-cnt col-cnt) (WHILE (NOT (WCMATCH (SUBSTR this-txt num-cnt) "#*")) (SETQ num-cnt (1+ num-cnt)) ) ;_ end of WHILE (SETQ dot-cnt num-cnt) (WHILE (NOT (WCMATCH (SUBSTR this-txt dot-cnt) "`.*")) (SETQ dot-cnt (1+ dot-cnt)) ) ;_ end of WHILE (SETQ last-num-cnt (1+ dot-cnt)) (WHILE (WCMATCH (SUBSTR this-txt last-num-cnt) "#*") (SETQ last-num-cnt (1+ last-num-cnt)) ) ;_ end of WHILE (SETQ new-rim-txt (STRCAT (SUBSTR this-txt 1 (1- num-cnt)) (RTOS this_rim 2 (- last-num-cnt (1+ dot-cnt))) (SUBSTR this-txt last-num-cnt) ) ;_ end of STRCAT ) ;_ end of SETQ (SETQ this-txt-ent (SUBST (CONS 1 new-rim-txt) (ASSOC 1 this-txt-ent) this-txt-ent) ) ;_ end of SETQ (ENTMOD this-txt-ent) ) ;_ end of PROGN ) ;_ end of IF (SETQ cnt (1+ cnt)) ) ;_ end of WHILE (COMMAND "STRETCH" "cp" "non" (POLAR (POLAR rim_pt PI 0.5) (* PI 1.5) 0.5) "non" (POLAR (POLAR rim_pt 0.0 0.5) (* PI 1.5) 0.5) "non" (POLAR (POLAR rim_pt 0.0 0.5) (* PI 0.5) 0.5) "non" (POLAR (POLAR rim_pt PI 0.5) (* PI 0.5) 0.5) "" "r" (SSGET "X" '((-4 . "") ) ) ;_ end of SSGET "" "non" rim_pt "non" (POLAR rim_pt (* PI 0.5) (- (* this_rim v_fact) (CADR rim_pt))) "" "" ) ;_ end of COMMAND (COMMAND "MOVE" rimset_ss "" "non" rim_pt "non" (POLAR rim_pt (* PI 0.5) (- (* this_rim v_fact) (CADR rim_pt))) "" ) ;_ end of COMMAND (PRINC (STRCAT "Moved manhole label elements " (RTOS (- (* this_rim v_fact) (CADR rim_pt)) 2 2))) (PRINC) ) ;_ end of PROGN ) ;_ end of IF (PRINC) ) ;_ end of DEFUN ;|«Visual LISP© Format Options» (120 2 15 2 T "end of " 100 9 0 0 nil nil T nil T) ;*** DO NOT add text below the comment! ***|;