lisp function not working correctley, help?

You have problems, and we're glad to hear them. Explain the problem, what you have tried, and where you got stuck.
Feel free to share a little info on yourself and the course.
Forum rules
Please respect your teacher's guidelines. Homework is a learning tool. If we just post answers, we aren't actually helping. When you post questions, be sure to show what you have tried or what you don't understand.
Post Reply
rphillips
Posts: 2
Joined: Mon Jun 18, 2012 8:16 am

lisp function not working correctley, help?

Post by rphillips » Mon Jun 18, 2012 8:49 am

This is my first time posting here so if i am in the wrong place pease let me know. I looked at the FAQ in reference to attachments and was not able to find out how i can post a file. I am not a guru but I am able to do some basic code myself. Mostley I take existing code and modify it to do what i need and ask for help when i need it.

I have a code that labels the ex grade and the pipe ie. I have modified the code to work for my needs, but the begining code was something i found on the net. The code ask the user to pick the base elevation, the profile, the label start and end location, and to mirror or move the label. It is all working but for some reason the elevations are not correct, can someone tell me what is wrong? I have a cad file that would help exsplain what it not working if i can post i will. I have tried looking at the main code but do not understand how it gets the elevations and why they are comming out wrong. Please help, Thanks!

Here is the existing code

Code: Select all

;PPL COMMAND THIS CODE WILL LABLE THE EXISTING AND IE ALONG THE PROFILE

;;load ActiveX library
(vl-load-com)

;;// FUNCTIONS
(defun start (curve)
  (vl-catch-all-apply (function (lambda()
  (vlax-curve-getclosestpointto curve
  (vlax-curve-getstartpoint curve
    )
  )
)
    )
  )
  )
;;//
(defun end (curve)
  (vl-catch-all-apply (function (lambda()
  (vlax-curve-getclosestpointto curve
  (vlax-curve-getendpoint curve
    )
  )
)
    )
  )
  )
;;//
(defun pointoncurve (curve pt)
  (vl-catch-all-apply (function (lambda()
  (vlax-curve-getclosestpointto curve
  pt
    )
  )
)
    )
  )
;;//
(defun paramatpoint (curve pt)
  (vl-catch-all-apply (function (lambda()
  (vlax-curve-getparamatpoint curve
  pt
    )
  )
)
    )
  )
;;//
(defun distatpt (curve pt)
  (vl-catch-all-apply (function (lambda()
  (vlax-curve-getdistatpoint curve
    (vlax-curve-getclosestpointto curve pt)
    )
  )
				)
    )
  )
;;//
(defun pointatdist (curve dist)
  (vl-catch-all-apply (function (lambda()
  (vlax-curve-getclosestpointto curve
  (vlax-curve-getpointatdist curve dist)
    )
  )
)
    )
  )
;;//
(defun curvelength (curve)
  (vl-catch-all-apply (function (lambda()
  (vlax-curve-getdistatparam curve
  (- (vlax-curve-getendparam curve)
     (vlax-curve-getstartparam curve)
    )
  )
  )
)
    )
  )
;;//
(defun distatparam (curve param)
  (vl-catch-all-apply (function (lambda()
  (vlax-curve-getdistatparam curve
  param
  )
  )
				)
    )
  )
;;//
(defun statlabel  (num step div)
  ;; num - integer, zero based
  ;; step - double or integer, must be non zero
  
  (strcat
    (itoa (fix (/ num div)))
    "+"
    (if (zerop (rem num div))
      "00"
      (rtos (* (rem num div) step) 2 0))

    )
  )

;;//
(defun gettangent (curve pt)
  
	 (setq param (paramatpoint curve pt)
	       ang ((lambda (deriv)
		   (if (zerop (cadr deriv))
		     (/ pi 2)
		     (atan (apply '/ deriv))
		   )
		 )
		  (cdr (reverse
			 (vlax-curve-getfirstderiv curve param)
		       )
		  )
		)
)
  ang
  )

;; Error Handling Function

(defun PPL_Error (msg)
  (command)
  (command "undo" "end")
  ;(vla-endundomark adoc)
  (command "u")
  (setvar "OSMODE" OM)
  (setvar "orthomode" ORTHO)
  (setvar "nomutt" 0);Sets command line to on / on(0)off(1)
  (setvar "cmdecho" CMD)
  (setq *error* OriginalErrorHandling)
  (prompt "\nProgram Error: ")
  (princ)
  )

;;---------------------- main program -----------------------------;;

(defun c:PPL  (/ *error* acdoc acsp adoc cnt dia div dlev dp eltext grad grcoords lay leng lp num osm plev pp prof pt ptlist
		 rot rp startleng startpt step tline tlinept txt x zero)

(vl-load-com)
  
(setq OriginalErrorHandling *error*)
(setq *error* PPL_Error)
(setq cmd (getvar "cmdecho"));Saves current command echo settings
(setvar "cmdecho" 0);Sets command echo to off on(1) off(2)
(command "undo" "begin")
(setq cmd (getvar "cmdecho"));Saves current command echo settings
(command "ucs" "save" "PPL")
(command "ucs" "")
(setq OM (getvar "OSMODE"));Saves current osnap settings
(setq ORTHO (getvar "orthomode"));Saves current or the settings
;(setvar "orthomode" 0);Sets ortho to off on(1) off(0)

  
  (setq adoc (vla-get-activedocument (vlax-get-acad-object))acsp (vla-get-block (vla-get-activelayout adoc)))
  ;(vla-startundomark adoc)
  (setvar "dimzin" 2)
  (setq lay (getvar "clayer"));Saves current layer
  (setq layc (getvar "cecolor"));Saves current color
  (setvar "clayer" "0");Sets current layer
  (setvar "cecolor" "3");Sets current color

  (setq *step* 50)
  (setq *dia* 150)
     (if        
	(and
	  (setvar "nomutt" 0)
       (or (initget 6)
       (setq step (getreal (strcat "\nEnter the station interval <" (rtos *step* 2 0) "> : ")))
       (cond ((not step)(setq step *step*)))
       (setq *step* step))
	  )
	  
	  (and
	  (setvar "nomutt" 0)
       (or (initget 6)
       (setq dia (getreal (strcat "\nEnter the pipe diameter, mm  <" (rtos *dia* 2 0) "> : ")))
       (cond ((not dia)(setq dia *dia*)))
       (setq *dia* dia))
	  )  
	)
    
        (progn

(princ "\nSelect profile base elevation (lower left text): ")
(while (null (setq eltext (ssget ":S:E" (list (cons 0 "*text")(cons 8 "C-ROAD-PROF-TEXT"))))));Get text from user for base elevation CODE WILL NOT CONTINUE UNTILL SELECTION IS MADE
(setvar "OSMODE" 1);Sets osnap to endpoint
(prompt "\nSelect Lower left and upper right corners of profile:")
	(setq p1 (getpoint "\nSpecify first corner: "));Get point from user to use (ssget "W" P1 P2
	(setq p2 (getcorner p1 "\nSpecify opposite corner: "));Get point from user to use (ssget "W" P1 P2
(prompt "\nSelect first and last lable location:")
  	(setq lp1 (getpoint "\nSpecify first text location: "));Get point from user to use (ssget "W" P1 P2
  	(setq lp2 (getpoint "\nSpecify last text location: "))
  (command "line" lp1 lp2 "")
  (setq tline (ssget "_l"))
  (setvar "OSMODE" OM)
  (setq PL (ssget "W" P1 P2 '((8 . "C-ROAD-PROF-TITL,C-ROAD-PROF-TITL-PATT"))));Finds objects in the window applying the filter selection
  (setq ML(getstring "\nDo you want to mirror profile label? No/<Yes>:"));Sets variable from user
  (if (= ML "")(command "._mirror" PL "" "_non" (setq cent (mapcar '*(mapcar '+ P1 P2)'(0.5 0.5 0.5)))"_non" (polar cent 0.0 1.0)"yes"));mirror object from MP
  (if (= ML "y")(command "._mirror" PL "" "_non" (setq cent (mapcar '*(mapcar '+ P1 P2)'(0.5 0.5 0.5)))"_non" (polar cent 0.0 1.0)"yes"))
  (if (= ML "yes")(command "._mirror" PL "" "_non" (setq cent (mapcar '*(mapcar '+ P1 P2)'(0.5 0.5 0.5)))"_non" (polar cent 0.0 1.0)"yes"))
  (if (= ML "Y")(command "._mirror" PL "" "_non" (setq cent (mapcar '*(mapcar '+ P1 P2)'(0.5 0.5 0.5)))"_non" (polar cent 0.0 1.0)"yes"))
  (if (= ML "YES")(command "._mirror" PL "" "_non" (setq cent (mapcar '*(mapcar '+ P1 P2)'(0.5 0.5 0.5)))"_non" (polar cent 0.0 1.0)"yes"))
  (setq grad (ssget "W" P1 P2 (list (cons 0 "lwpolyline")(cons 8 "C-ROAD-PROF"))));selects the gradeline
  (setq prof (ssget "W" P1 P2 (list (cons 0 "lwpolyline")(cons 8 "C-SSWR-FORC"))));selects the forcemain line

(setvar "nomutt" 0)
          (setq grad (ssname grad 0))
          (setq prof (ssname prof 0))
	  (setq tline (ssname tline 0))
	  (setq eltext (ssname eltext 0))
          (setq grcoords (vl-remove-if 'not (mapcar '(lambda (x)(if (= 10 (car x))(cdr x)))(entget grad))))
(setq startpt (trans (car (vl-remove-if '(lambda (x)(< (car a)(car b)))grcoords))  0 1))
         (setq tlinept	 (pointoncurve tline startpt)
	       startleng (distatparam
			   tline
			   (vlax-curve-getparamatpoint tline tlinept))
	       leng	 (- (distatparam tline (vlax-curve-getendparam tline))
			    startleng)
	       num	 (fix (/ leng step))
	       div	 (fix (/ 100. step))
	       )
	
(setvar "clayer" "C-ROAD-PROF-TEXT")
(setvar "cecolor" "bylayer")

(setq cnt 0)

     (repeat (1+ num)
       (setq pt	 (polar (pointatdist tline startleng) (* pi 1.5) 1.75)
	     rot 0.0
	     ptlist (cons pt ptlist)
	     )
       ;REMOVE COMMENTS BELOW TO ADD STATION #S
       ;(setq txt (vla-addtext  acsp (statlabel cnt step div) (vlax-3d-point pt) 3.5))
	     ;(vla-put-alignment txt  acAlignmentTopCenter)
	     ;(vla-put-textalignmentpoint txt (vlax-3d-point pt))
       ;(vla-put-rotation txt rot)
;(vla-put-stylename txt  "HGBD-OPTI1-MS" )
       (setq cnt   (1+ cnt)
	     startleng (+ startleng step))
	     )
;;---------------------------------------------;;
(setq ptlist (reverse ptlist))
(setq zero (atof(vla-get-textstring (vlax-ename->vla-object eltext))))

(foreach p ptlist
  (setq lp  (polar p (* pi 0.75) 2.47)
	rp  (polar p (/ pi 4) 2.47))
  (setq dp (vlax-curve-getclosestpointto grad p)
	pp (vlax-curve-getclosestpointto prof p))
  (setq dlev (cadr dp)
	plev (cadr pp))
  
   (setq txt (vla-addtext  acsp (strcat "E.G. EL="(rtos (+ zero (/ (- dlev(cadr tlinept) ) 10.)) 2 2)) (vlax-3d-point lp) 2.54))
	     (vla-put-alignment txt  acAlignmentMiddleLeft )
	     (vla-put-textalignmentpoint txt (vlax-3d-point lp))
               (vla-put-rotation txt (/ pi 2))
  (vla-put-color txt acred)
  (vla-put-stylename txt  "HGBD-OPTI1-MS" )
  (setq txt (vla-addtext  acsp (strcat "PIPE I.E.="(rtos (+ zero (- (/ (- plev (cadr tlinept) ) 10.) (/ (/ dia 1000.) 2))) 2 2)) (vlax-3d-point rp) 2.54))
	     (vla-put-alignment txt  acAlignmentMiddleLeft )
	     (vla-put-textalignmentpoint txt (vlax-3d-point rp))
               (vla-put-rotation txt (/ pi 2))
  (vla-put-color txt acyellow)
  (vla-put-stylename txt  "HGBD-OPTI1-MS" )
  )
       )
(command "erase" tline "")
(setvar "orthomode" 1);Sets ortho to off on(1) off(0)
(setq ML(getstring "\nDo you want to move profile label? Yes/<No>:"));Sets variable from user
  (if (= ML "") "" "");If user 
  (if (= ML "y")(command "._move" PL "" pause pause))
  (if (= ML "yes")(command "._move" PL "" pause pause))
  (if (= ML "Y")(command "._move" PL "" pause pause))
  (if (= ML "YES")(command "._move" PL "" pause pause))
(setvar "clayer" lay)
(setvar "cecolor" layc)
(command "ucs" "restore" "PPL")
(command "ucs" "delete" "PPL")
(command "undo" "end")
(setvar "cmdecho" CMD)
       (princ)
)

rphillips
Posts: 2
Joined: Mon Jun 18, 2012 8:16 am

Re: lisp function not working correctley, help?

Post by rphillips » Wed Jun 20, 2012 5:26 am

I think i have narrowed it down to this part of the code

(foreach p ptlist
(setq lp (polar p (* pi 0.75) 2.47)
rp (polar p (/ pi 4) 2.47))
(setq dp (vlax-curve-getclosestpointto grad p)
pp (vlax-curve-getclosestpointto prof p))
(setq dlev (cadr dp)
plev (cadr pp))

(setq txt (vla-addtext acsp (strcat "E.G. EL="(rtos (+ zero (/ (- dlev(cadr tlinept) ) 10.)) 2 2)) (vlax-3d-point lp) 2.54))
(vla-put-alignment txt acAlignmentMiddleLeft )
(vla-put-textalignmentpoint txt (vlax-3d-point lp))
(vla-put-rotation txt (/ pi 2))
(vla-put-color txt acred)
(vla-put-stylename txt "HGBD-OPTI1-MS" )
(setq txt (vla-addtext acsp (strcat "PIPE I.E.="(rtos (+ zero (- (/ (- plev (cadr tlinept) ) 10.) (/ (/ dia 1000.) 2))) 2 2)) (vlax-3d-point rp) 2.54))
(vla-put-alignment txt acAlignmentMiddleLeft )
(vla-put-textalignmentpoint txt (vlax-3d-point rp))
(vla-put-rotation txt (/ pi 2))
(vla-put-color txt acyellow)
(vla-put-stylename txt "HGBD-OPTI1-MS" )
)
)

I think it has something to do with the vlax-curve-getclosestpointto function, any ideas? anyone?

Post Reply