;|===============================================================|;
;|       Topo.lsp by Michael Bulatovich, 15th Feb., 2004         |;
;|       www.michaelbulatovich.ca                                |;
;|                                                               |;
;|       Performs a number of functions related to grading       |;
;|       plans. It draws a leader from a high point to a         |;
;|       low point an indicates the slope between them.          |;
;|       It can perform interpolation between given grades,      |;
;|       or it can give grades from a basepoint and a gradient.  |;
;|       It can annotate with simple text, or with a block       |;
;|       with a single attribute when interpolating. Text        |;
;|       and leaders are made using the current styles           |;
;|       for both, and on the current layer. Is capable of       |;
;|       some unit conversion between Metric and Imperial        |;
;|       when indicating slopes or calculating grades,           |;
;|       but will interpolate in units like those it was given.  |;
;|       Topo is capable of gathering grades from either         |;
;|       text, blocks with single attributes, large blocks       |;
;|       or XREFs containing text entities showing grades.       |;
;|                                                               |;
;|       Revised 22nd, Feb., 2004 to add "Calculate" function    |;
;|       error handler, and text rotation ability.               |;
;|                                                               |;
;|       Revised 26th, June  2004 to add fixed textstyle bug.    |;
;|                                                               |;
;|===============================================================|;
(defun c:topo ( / hipoint hinum lopoint lonum dis delta slope vector interpt
	       labelpt lowdis hidis part gradient modelunits gradingunits
	       direction basepoint basegrade newpoint
	       )
  
  (setvar "cmdecho" 0)
  (setq olderror *error*
	oldsnaps (getvar "osmode"))
  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;            Error handler                          ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (defun *topo_error* (msg)
    
  (if  (or (= msg "Function cancelled")(= msg "quit / exit abort"))
    ;(progn
    (princ "\nFunction cancelled by user.")
    (progn
    (princ "\nError: ")
    (princ msg)
    (princ "\nWhatever that means!"))
    )
  
  (setvar "osmode" oldsnaps)
  (setq noprompt nil)
    (if olderror (setq *error* olderror
		       olderror nil
		       ))
    (princ)
    )
(if (not (eq *error* *topo_error*))(setq *error* *topo_error*))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;            Number Isolator                        ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (defun getnumb ( string / c start end numb)
    (setq leng 	(strlen string)
  	li	(list "1" "2" "3" "4" "5" "6" "7" "8" "9" "0" ".")
	c	0)
  (while (not (eq c leng))
    (if (member (substr string (+ c 1) 1) li)
      (progn
	(if (not start)
	  (setq start (+ c 1))
	  (setq end (+ c 1)
		c   (+ c 1)))
	)
      (setq c (+ c 1))
      )
    )
  (setq numb (substr string start (+ 1(- end start))))
  )  
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;            Set Units                              ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   (defun setunits ()
    (initget "Decimal-feet Inches Meters millimeteRs")
    (setq modelunits
	   (getkword "\n\nModel's units are: Decimal-feet, Inches, Meters, millimeteRs")
	  )
    (initget "Decimal-feet Inches Meters")
    (setq gradingunits
	   (getkword "\n\nGrades units are: Decimal-feet, Inches, Meters")
	  )
    (cond
	((eq modelunits gradingunits)(setq scalefac 1))
	((and(eq modelunits "Decimal-feet")(eq gradingunits "Meters"))
	 (setq scalefac (/ (/ 1000 25.4) 12)))
	((and(eq modelunits "Inches")(eq gradingunits "Decimal-feet"))
	 (setq scalefac 12))
	((and(eq modelunits "Inches")(eq gradingunits "Meters"))
	 (setq scalefac (/ 1000 25.4)))
	((and(eq modelunits "millimeteRs")(eq gradingunits "Meters"))
	 (setq scalefac 1000))
	)
    (setq precis (getint "\nSpecify level of precision in decimal places:"))
       (setq setup "Exit"
	  2ndrun t)
    (options)
	 )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;            Set Notation Preferences               ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (defun setnotes ()
    
    (initget "Block Text")
    (setq notetype (getkword "\n\nDo you want to make grades with Text or a Block? T/B:"))
    (initget "Fixed Unspecified")
    (setq textheight (getkword "\n\nIs the current textstyle height Fixed or Unspecified? F/U:"))
    (initget "Pre Suf Both No")
    (setq pre_suffix (getkword "\n\nDo you want a Prefix, Suffix, Both or <Niether>?"))
    (cond
      ((eq pre_suffix "Pre")(setq prefix (getstring "\nSpecify prefix:")))
      ((eq pre_suffix "Suf")(setq suffix (getstring "\nSpecify suffix:")))
      ((eq pre_suffix "Both")(setq prefix (getstring "\nSpecify prefix:")
				   suffix (getstring "\nSpecify suffix:")
				   ))
      ((eq pre_suffix "No")(setq prefix nil
				 suffix nil
				   ))
      )
    (if (eq notetype "Block")
      (setq block (getstring "\nSpecify name of block to use:"))
      (setq textang (getreal "\nSpecify UCS-relative angle for text labels:"))
      )
    (setq setup "Exit"
	  2ndrun t)
    (options)
	 )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;            Data Type Selection                    ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (defun setdatatype ()
    (initget "Text Individual Block Xref")
    (setq data (getkword "Is the grade data to be used\n
    Text, attributes Individual blocks, text in one Block, or text in an Xref? T/I/B/X:"))
    (setq setup "Exit"
	  2ndrun t)
    (options)
	 )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;            Main Options Section                   ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (defun options ()
    (if (not 2ndrun)(progn
		      (textscr)
		      (Prompt "\n\n
********************* Topo.LSP Options ****************************\n
*    You need to set several parameters to get TOPO to work.      *\n
*    You need to set the Units, pick Block or Text annotation,    *\n
*    and specify text/block/xref source data entity type.         *\n
*    Annotation blocks can have only ONE attribute.               *\n
*******************************************************************\n\n\n")
		      ))
    (initget "Units Annotation Source Exit")
    (setq setup 
	   (getkword "\nSet Units, Annotation, Source data type, or Exit options: U/A/S or <E>")
    )
    (cond
      ((eq setup "Units")		(setunits))
      ((eq setup "Annotation")		(setnotes))
      ((eq setup "Source")		(setdatatype))
      ((eq setup "Exit")		(progn
	 				(setq 2ndrun t)
	 				(initget 6 "Slope Interpolate Calculate")
  					(setq funk
	       				(getkword "\nDo you want to label a Slope gradient, Calculate a grade, or Interpolate between two grades?")
	      				noprompt T
	      				)
					(princ)))
      )
    )
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (if (not 2ndrun)(options))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;            Slopes Section                         ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (defun markslope ()
      	(setvar "osmode" 0)
  (command "leader" lopoint hipoint "" "" "n")
  (setq labelpt	(getpoint "\nPick a point for the gradient label:")
	delta	(* scalefac (- hinum lonum))
	slope	(/ delta dis)
	vector	(atof (angtos (angle hipoint lopoint) 0 precis)))
    (if (and(> vector 120)(< vector 300))(setq vector (- vector 180)))
    (if (eq funk "Calculate")
      (setq gradient (strcat(rtos (* 100 gradient) 2 precis)"%"))
      (setq gradient (strcat(rtos (* 100 slope) 2 precis)"%"))
	    )
      (if prefix (setq gradient(strcat prefix " " gradient)))
      (if suffix (setq gradient(strcat gradient " " suffix)))
   
    (cond
      ((eq textheight "Fixed")			(command "text" labelpt vector gradient))
      ((eq textheight "Unspecified")		(command "text" labelpt "" vector gradient))
      )
    (setvar "osmode" oldsnaps)
    (princ)
    )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;            Interpolation Section                  ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (defun interpolate ()
    (setq interpt 	(getpoint "\nPick a point for interpolation:")
	  lowdis	(distance lopoint interpt)
	  hidis		(distance hipoint interpt)
	  delta		(- hinum lonum)
	  part		(rtos (+ lonum (* (/ lowdis dis) delta))2 precis)
	  )
    
      (if prefix (setq part(strcat prefix " " part)))
      (if suffix (setq part(strcat part " " suffix)))
      (if (or (and (> lowdis dis)(> lowdis hidis))
	    (and (> hidis dis)(> hidis lowdis))
	    )
      (alert "Inappropriate point for interpolation:\nExiting routine.")
      (cond
      ((and(eq notetype "Text")(eq funk "Interpolate"))
       				(progn
    				(command "point" interpt)
			     	(setq labelpt(getpoint "\nPick a point for the label:"))
    				(command "text" labelpt "" textang part "")))
      ((and(eq notetype "Block")(eq funk "Interpolate"))
       				(progn
				  ;(setq oldsnaps (getvar "osmode"))
				  (setvar "osmode" 0)
    				(command "insert" block interpt "" "" "" part)
				  (setvar "osmode" oldsnaps)))
      
      ))
    (princ)
    )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;            Calculation Section                    ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (defun calculate ()
    (initget "Up Down")
    (setq direction	(getkword "\nGrade Up or Down from basepoint?: U/D"))
    (setq basepoint  	(getpoint "\nPick base point:")
	  basegrade	(pick "\nPick base point value:")
	  gradient 	(/(getreal "\nSpecify desired gradient in percent:")100)
	  newpoint  	(getpoint "\nPick new point to grade:")
	  dis		(distance basepoint newpoint)
	  delta		(/(* gradient dis) scalefac)
	  
	)
    (cond
      ((eq direction "Up")(setq newgrade(rtos(+ basegrade delta) 2 precis)))
      ((eq direction "Down")(setq newgrade(rtos(- basegrade delta) 2 precis)))
      )
    (cond
      ((eq notetype "Text")	(progn
				(setvar "osmode" 0)
    				(command "point" newpoint)
			     	(setq labelpt(getpoint "\nPick a point for the new grade label:"))
    				(command "text" labelpt "" textang newgrade "")
				  (setvar "osmode" oldsnaps)))
      
      ((eq notetype "Block")	(progn
				(setvar "osmode" 0)
    				(command "insert" block newpoint "" "" "" newgrade)
				(setvar "osmode" oldsnaps)))
            )
    (cond
	((eq direction "Up")(setq lopoint basepoint
				  hipoint newpoint
				  lonum basegrade
				  hinum	(atof newgrade)
				  dis (distance hipoint lopoint)))
	((eq direction "Down")(setq hipoint basepoint
				  lopoint newpoint
				  hinum basegrade
				  lonum	(atof newgrade)
				  dis (distance hipoint lopoint)))
      )
    (markslope)
    (princ)
    )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;            Text Picker                            ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (defun pick (mess / )
    (cond
      ((eq data "Text")		(atof(getnumb (cdr(assoc 1(entget(car(entsel mess))))))))
      ((eq data "Block")	(atof(getnumb (cdr(assoc 1(entget(car(nentsel mess))))))))
      ((eq data "Xref")		(atof(getnumb (cdr(assoc 1(entget(car(nentsel mess))))))))
      ((eq data "Individual")	(atof(getnumb (cdr(assoc 1(entget(car(nentsel mess))))))))
      )
    )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                                                  ;
;         Main Function                            ;
;                                                  ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (initget 6 "Slope Interpolate Calculate Options")
  (if (and noprompt 2ndrun)(setq noprompt nil)
  (setq funk(getkword "\nDo you want to label a Slope gradient, Interpolate between two grades, Calculate a grade, or set Options?")
	noprompt nil)
    )
  (while (eq funk "Options") (options))
  (if (not (eq funk "Calculate"))
  (setq hipoint  (getpoint "\nPick higher point:")
	hinum	(pick "\nPick high point value:")
	lopoint	 (getpoint "\nPick lower point:")
	lonum	(pick "\nPick lower point value:")
	dis	(distance hipoint lopoint)
	)
    )
    (cond
    ((eq funk "Slope") (markslope))
    ((eq funk "Interpolate") (interpolate))
    ((eq funk "Calculate") (calculate))
        )
  (setq noprompt nil)
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (princ)
    )