;**************************************
    ; Name: PFAST
    ; Description:This routine will help you
    ;     make fast longitudinal profiles of a ter
    ;     rain.
    ; By: Pedro Miguel da Silva Ferreira
    ;
    ; Inputs:The routine will ask you for 2 
    ;     points anywhere in space!
    ;
    ; Returns:The routine will return you a 
    ;     longitudinal profile
    ;
    ; Assumes:You should no, that the terrai
    ;     n must be lwpolylines with different z, 
    ;     and the 2 points whem joined by a line, 
    ;     must intercept the lwpolylines.
    ;
    ;This code is copyrighted and has    ; limited warranties.Please see http://w
    ;     ww.Planet-Source-Code.com/vb/scripts/Sho
    ;     wCode.asp?txtCodeId=69&lngWId;=13    ;for details.    ;**************************************
    
    (defun c:pfast ()
    (setvar "CMDECHO" 0)
    (setvar "FLATLAND" 0)
    (setvar "OSMODE" 0)
    (setvar "ORTHOMODE" 0)
    (setvar "PLINETYPE" 2)
    (setvar "AUPREC" 0)
    (command "layer" "make" "lisp-terreno" "COLOR" "8" "" "")
    (command "layer" "make" "lisp-directriz" "COLOR" "1" "" "")
    (setq f_pt (open "c:\\xy.tmp" "w"))
    (vl-load-com)
    (setq	*modelspace*
    	 (vla-get-modelspace
    	(vla-get-activedocument (vlax-get-acad-object))
    	 )
    )
    ;;;
    (setq	pt1(getpoint "\nPick first point :")
    	pt2(getpoint "\nPick second point :")
    	ptlist (list pt1 pt2)
    )
    (if (not (null pt2))
    (progn
    (command "layer" "set" "lisp-directriz" "")
    (command "pline" pt1 pt2 "")
    (command "layer" "set" "0" "")
    )
    )
    ;;;
    (setq	ldirect
    	 (vlax-ename->vla-object
    	(cdr
    	 (assoc -1
    		(entget (entlast))
    	 )
    	)
    	 )
    )
    (if (= ldirect nil)
    (close f_pt)
    )
    (setq cnivellw (ssget "_f" ptlist '((0 . "lwpolyline"))))
    (if (= cnivellw nil)
    (close f_pt)
    )
    (setq NXcnivellw (sslength cnivellw))
    					;(setq fsob (getreal "\nHow many times do you want y bigger than x (if none 1) :"))
    					;(if (= fsob nil)
    (setq fsob 1)
    					; )
    (setq counter 0)
    (while (< counter nxcnivellw)
    (progn
    (setq
    	cnivelent (vlax-ename->vla-object (ssname cnivellw counter))
    )
    (setq endparam (vlax-curve-getEndParam cnivelent))
    (setq countparam 0)
    (while (< countparam endparam)
    	(progn
    	 (setq aa (vlax-curve-getPointAtParam cnivelent countparam))
    	 (setq	ax (car aa)
    		ay (cadr aa)
    		z (* (caddr aa) fsob)
    		a (list ax ay)
    	 )
    	 (setq countparam (1+ countparam))
    	 (setq bb (vlax-curve-getPointAtParam cnivelent countparam))
    	 (setq	bx (car bb)
    		by (cadr bb)
    		b (list bx by)
    	 )
    	 (setq int nil)
    	 (if (= int nil)
    	(progn
    	 (setq endparam1 (vlax-curve-getEndParam ldirect))
    	 (setq countparam1 0)
    	 (while (< countparam1 endparam1)
    		(progn
    		 (setq	aa1
    			 (vlax-curve-getPointAtParam ldirect countparam1)
    		 )
    		 (setq	ax1 (car aa1)
    			ay1 (cadr aa1)
    			a1 (list ax1 ay1)
    		 )
    		 (setq countparam1 (1+ countparam1))
    		 (setq	bb1
    			 (vlax-curve-getPointAtParam ldirect countparam1)
    		 )
    		 (setq	bx1 (car bb1)
    			by1 (cadr bb1)
    			b1 (list bx1 by1)
    		 )
    		)
    		(setq int (inters a b a1 b1))
    		(if (/= int nil)
    		 (progn
    		(setq x (vlax-curve-getDistAtPoint ldirect int))
    		(setq xy (list x z))
    		(write-line (vl-princ-to-string xy) f_pt)
    		 )
    		)
    	 )
    	)
    	 )
    	)
    )
    )
    (setq counter (1+ counter))
    )
    (close f_pt)
    ;;;
    (setq f_pt (open "c:\\xy.tmp" "r"))
    (setq dados nil)
    (while (not (null (setq linha (read-line f_pt))))
    (setq linha (read linha))
    (setq dados (append dados (list linha)))
    )
    (eval (quote dados))
    (close f_pt)
    (setq	dados-ord (vl-sort dados
    			(function (lambda (e1 e2)
    				(< (car e1) (car e2))
    				 )
    			)
    		 )
    )
    (setq file-dados-ord (open "c:\\xyordenados.tmp" "w"))
    (if (= dados-ord nil)
    (close file-dados-ord)
    )
    (setq num-dados-ord (length dados-ord))
    (setq div-num-dados-ord (/ num-dados-ord 2))
    (setq num 0)
    (princ "(command\"pline\" " file-dados-ord)
    (princ " '" file-dados-ord)
    (repeat num-dados-ord
    (setq ponto-dados-ord (nth num dados-ord))
    (write-line
    (vl-princ-to-string ponto-dados-ord)
    file-dados-ord
    )
    (princ " '" file-dados-ord)
    (setq num (1+ num))
    )
    (princ "\"\" " file-dados-ord)
    (write-char 41 file-dados-ord)
    (close file-dados-ord)
    ;;;
    (command "layer" "set" "lisp-terreno" "")
    (load "c:\\xyordenados.tmp")
    ;;;
    (command "zoom" "e")
    (command "layer" "set" "0" "")
    (princ "\n 'pfast' (by Pedro Ferreira)")
    (princ "\n 'cad.mng@netcabo.pt'")
    (princ)
    )
    (princ "\n Type ' pfast ' and get enter")