[编程交流] Lisp查找每1处的值

(defun tbrtos ( txt / cont txt1 txt2 txt3 tx4 txt5 txt6 aux1 aux2 aux3 aux4 aux5 aux6)
 (setq aux1 (strlen txt))
 (setq aux2 0)
 (setq aux3 0)
 (setq aux4 0)
 (setq aux5 0)
 (setq cont 0)
 (repeat aux1
   (setq aux2 (+ 1 aux2))
   (setq txt1 (substr txt aux2 1))
   (if (or (= txt1 ".") (= txt1 ","))
  (SETQ cont (- aux1 aux2))
     ))
   (setq cont cont))
(defun txfix (num dec / aux1 aux2 aux3 txt1 txt2 txt3)
(if (= dec 0)
 (setq txt4 (rtos num 2 dec))
 (progn
 
 (setq aux1 1.0)
 (repeat dec
;  (print aux1)
(setq aux1 (* 10.0 aux1)))
 (setq aux2 (* aux1 num)) ;(print aux2)
 (setq txt1 (rtos aux2 2 0)) ;(print txt1)
 (setq txt2 (substr txt1 1 (- (strlen txt1) dec)))   ;(print txt2)
  
 (setq txt3 (substr txt1 (+ 1  (- (strlen txt1) dec)) dec));  (print txt3)
 (setq txt4 (strcat txt2 "." txt3))
 ))
 
 (setq txt4 txt4)
 )
(defun txtadd ( / diff ss sl sn en data txt1 )
(setq diff (getreal "Enter +/- DELTA: "))
(PRINT "SELECT TXT...........")
(setq ss (ssget))
 (setq sl (sslength ss))
 (while (> sl 0)
   (setq data 0)
   (setq sn (ssname ss (- sl 1)))
   (setq en (entget sn))
   (if (= (cdr (assoc 0 en)) "TEXT")
     (progn
           (setq txt1 (cdr (assoc 1 en)))
           (setq data (atof txt1 ))
           (setq data (+ diff data ))
       (setq txt5 (txfix data (tbrtos txt1) ))
(setq en (subst (cons 1 txt5) (assoc 1 en) en ))
           (entmod en)
))
   (setq sl (- sl 1))
   )
 (command "regenall")
 (print "END ...")
   )
(defun txtmult ( / diff ss sl sn en data txt1 txt5)
(setq diff (getreal "Enter factor: "))
(PRINT "SELECT TXT...........")
(setq ss (ssget))
 (setq sl (sslength ss))
 (while (> sl 0)
   (setq data 0)
   (setq sn (ssname ss (- sl 1)))
   (setq en (entget sn))
   (if (= (cdr (assoc 0 en)) "TEXT")
     (progn
           (setq txt1 (cdr (assoc 1 en)))
           (setq data (atof txt1 ))
           (setq data (* diff data))
(setq txt5 (txfix data (tbrtos txt1) ))
           (setq en (subst (cons 1 txt5) (assoc 1 en) en ))
           (entmod en)
))
   (setq sl (- sl 1))
   )
 (command "regenall")
 (print "END ...")
   )
 
(defun tblayout        (/     ang0  delta ss0         ss1   ss2   sl0   sl1         sn0
         sn1   sn2   en0   en1         en2   p0    p1           dx         dxacum
         dxtotal     count x0         x1    x2    y0           y1         y2
         ytext p2    p3           p20         p30   ptext dh
        )
 (setq delta 100000.0)
 (setq ALT1 300.0)
 (command "_ucs" "_w" )
 (print "...select reference object......")
 (setq ss0 (ssget))
 (terpri)
 (print "...select tendon......")
 (setq ss1 (ssget))
 (terpri)
 (setq p0 (getpoint "..........First Point........"))
 (terpri)
 (setq p1 (getpoint p0 "..........Last  Point........"))
 (terpri)
 (setq ptext (getpoint p0 "..TEXT LEVEL...."))
 (terpri)
 (terpri)
 (setq dx (getreal "..........typical spacing........"))
 (setvar "osmode" 0)
 (setq ytext (distance p0 ptext))
 (setq sl0 (sslength ss0))
 (setq sn0 (ssname ss0 (- sl0 1)))
 ;; Get entity name
 (setq en0 (entget sn0))
 ;; Get entity structure
 (setq sl1 (sslength ss1))
 (setq sn1 (ssname ss1 (- sl1 1)))
 ;; Get entity name
 (setq en1 (entget sn1))
 ;; Get entity structure
 (setq dxtotal (distance p0 p1))
 (setq x0 (car p0))
 (setq x1 (car p1))
 (setq y0 (min (cadr p0) (cadr p1)))
 (setq ang0 (angle p0 p1))
 (setq p2 (polar p0 (+ ang0 (* 1.5 pi)) delta))
 (setq p3 (polar p0 (+ ang0 (* 0.5 pi)) delta))
 (setq ptext (polar p0 (+ ang0 (* 1.5 pi)) ytext))
 (setq dxacum 0.0)
 (while (not (> dxacum dxtotal))
   (setq p20 (tbinter sn0 p2 p3))
   (setq p30 (tbinter sn1 p2 p3))
   (setq dh (distance p20 p30)) 
   (command "_TEXT"
     "J"
     "BL"
     ptext
     ALT1
     (+ 90.0 (* (/ ang0 pi) 180.0))
     (rtos dh 2 0)
   )
   (command "_TEXT"
     "J"
     "BL"
     (polar ptext (+ ang0 (* 0.5 pi)) (* 10.0 ALT1))
     ALT1
     (+ 90.0 (* (/ ang0 pi) 180.0))
     (rtos (/ dxacum 1000.0) 2 3)
   )
   (setq dxacum (+ dxacum dx))
   (setq p2 (polar p2 ang0 dx))
   (setq p3 (polar p3 ang0 dx))
   (setq ptext (polar ptext ang0 dx))
 )
 (if (not (= dxacum dxtotal))
   (progn
     (setq p2 (polar p1 (+ ang0 (* 1.5 pi)) delta))
     (setq p3 (polar p1 (+ ang0 (* 0.5 pi)) delta))
     (setq p20 (tbinter sn0 p2 p3))
     (setq p30 (tbinter sn1 p2 p3))
     (setq dh (distance p20 p30))
     (setq ptext (polar p1 (+ ang0 (* 1.5 pi)) ytext))
     (command "_TEXT"
       "J"
       "BL"
       ptext
       ALT1
       (+ 90.0 (* (/ ang0 pi) 180.0))
       (rtos dh 2 0)
     )
     (command "_TEXT"
       "J"
       "BL"
       (polar ptext (+ ang0 (* 0.5 pi)) (* 10.0 ALT1))
       ALT1
       (+ 90.0 (* (/ ang0 pi) 180.0))
       (rtos (/ dxtotal 1000.0) 2 3)
     )
   )
   (terpri)
 )
 (terpri)
 (print "........end")
 (terpri)
 (setvar "osmode" 15359)
 (terpri)
)
(defun tbcircle (/ sn0 llx0  x1 y1 x2 y2        x0 y0 sn2 en2 sn3 en3 sn4 en4 p4
        p5 p0)
(setq delta 1000)
 
 (setvar "plinetype" 0)
 
(print "...select tendon...")
(setvar sn0 (ssget))
 (terpri)
 (print "...select 1st point...")
(setvar p1 (getpoint))
 (command "circle" p1 delta "")
 
 (setq sn1 (entlast))
 (command "_trim" sn0 "" (entlast) "")
 (setq sn2 (entlast))
 (setq en2 (entget sn2))
 (setq sn3 (entnext sn2))
 (setq en3 (entget sn3))
 (setq p4 (cdr (assoc 10 en3)))
 (setq sn4 (entnext sn3))
 (setq en4 (entget sn4))
 (setq p5 (cdr (assoc 10 en4)))
 (command "_erase" sn2 "")
 (if (or (and (= (car p4) x1) (= (cadr p4) y1))
  (and (= (car p4) x2) (= (cadr p4) y2))
     )
   (setq p0 p5)
   (setq p0 p4)
 )
 (setq p0 p0)
)
(defun tbinter (sn0 p1 p2 / x1 y1 x2 y2        x0 y0 sn2 en2 sn3 en3 sn4 en4 p4
        p5 p0)
 (setvar "plinetype" 0)
 (setq x1 (car p1))
 (setq x2 (car p2))
 (setq y1 (cadr p1))
 (setq y2 (cadr p2))
 (command "_pline" p1 p2 "")
 (command "_trim" sn0 "" (entlast) "")
 (setq sn2 (entlast))
 (setq en2 (entget sn2))
 (setq sn3 (entnext sn2))
 (setq en3 (entget sn3))
 (setq p4 (cdr (assoc 10 en3)))
 (setq sn4 (entnext sn3))
 (setq en4 (entget sn4))
 (setq p5 (cdr (assoc 10 en4)))
 (command "_erase" sn2 "")
 (if (or (and (= (car p4) x1) (= (cadr p4) y1))
  (and (= (car p4) x2) (= (cadr p4) y2))
     )
   (setq p0 p5)
   (setq p0 p4)
 )
 (setq p0 p0)
)
(defun tbangle (x1 y1 z1 x2 y2 z2 x3 y3        z3 / ppunto temp dx1 dy1 dz1 dd1
        dx2 dy2        dz2 dd2)
 (setq dx1 (- x2 x1))
 (setq dy1 (- y2 y1))
 (setq dz1 (- z2 z1))
 (setq dd1 (sqrt (+ (* dx1 dx1) (* dy1 dy1) (* dz1 dz1))))
 (setq dx1 (/ dx1 dd1))
 (setq dy1 (/ dy1 dd1))
 (setq dz1 (/ dz1 dd1))
 (setq dx2 (- x3 x2))
 (setq dy2 (- y3 y2))
 (setq dz2 (- z3 z2))
 (setq dd2 (sqrt (+ (* dx2 dx2) (* dy2 dy2) (* dz2 dz2))))
 (setq dx2 (/ dx2 dd2))
 (setq dy2 (/ dy2 dd2))
 (setq dz2 (/ dz2 dd2))
 (setq temp (+ (* dx1 dx2) (* dy1 dy2) (* dz1 dz2)))
 (setq ppunto (acos temp))
;..........................  
;(print temp) (print ppunto)
;.........................
 
 (setq ppunto ppunto)
)
(defun tbdist
      (x1 y1 z1 x2 y2 z2 / ppunto dx1 dy1 dz1 dd1 dx2 dy2 dz2 dd2)
 (setq dx1 (- x2 x1))
 (setq dy1 (- y2 y1))
 (setq dz1 (- z2 z1))
 (setq dd1 (sqrt (+ (* dx1 dx1) (* dy1 dy1) (* dz1 dz1))))
 (setq dd1 dd1)
)
(defun tbdataxy        (FICHA /     llx   lly         ang0  delta ss0   ss1         ss2
         sl0   sl1   sn0   sn1         sn2   en0   en1   en2         p0
         p1    dx    dxacum         dxtotal     count x0         x1
         x2    y0    y1           y2 y30         ytext p2    p3           p20         p30
         ptext pref yref dh dxval
        )
 (setq delta 100000.0)
 (setq ALT1 300.0)
 (print "...ELEVATION/PLAN VIEW ......")
;  (terpri)
 (print "...select CG tendon......")
 (setq ss1 (ssget))
 (terpri)
 (setq p0 (getpoint "..........First Point........"))
 (terpri)
 (setq p1 (getpoint p0 "..........Last  Point........"))
 (terpri)
 (setq pref (getpoint  "..........Reference Point........"))
 (terpri)
 
 (setq dx (getreal "..........typical spacing........"))
 (setvar "osmode" 0)
;  (setq sl0 (sslength ss0))
;  (setq sn0 (ssname ss0 (- sl0 1)))
 ;; Get entity name
;  (setq en0 (entget sn0))
 ;; Get entity structure
(setq yref (nth 1 pref))
 (setq sl1 (sslength ss1))
 (setq sn1 (ssname ss1 (- sl1 1)))
 ;; Get entity name
 (setq en1 (entget sn1))
 ;; Get entity structure
; (setq dxtotal (distance p0 p1))
 (setq x0 (car p0))
 (setq x1 (car p1))
 (setq dxval (- x1 x0))
 (setq dxtotal (abs (- x1 x0)))
 
 (setq y0 (min (cadr p0) (cadr p1)))
;  (setq ang0 (angle p0 p1))
  (setq ang0 0.0)
;  (setq p2 (polar p0 (+ ang0 (* 1.5 pi)) delta))
;  (setq p3 (polar p0 (+ ang0 (* 0.5 pi)) delta))
  (setq p2 (list x0 (- (cadr p0) delta)))
  (setq p3 (list x0 (+ (cadr p0) delta)))
 (setq dxacum 0.0)
 (while (not (>  dxacum dxtotal ))
;   (setq p20 (tbinter sn0 p2 p3))
   (setq p30 (tbinter sn1 p2 p3))
     (setq y30 (nth 1 p30))
   (setq dh (- y30 yref))
   (if        (= dh delta)
     (progn
(terpri)
(print
  " xxx NO INTERSECTION OF TENDON WITH REFERENCE OBJECT....PLEASE CHECK FIRST/LAST POINT XXXX"
)
(close FICHA)
(QUIT)
     )
   )
   (if        (= dxacum 0.0)
     (progn
(setq llx (list dxacum))
(setq lly (list dh))
     )
     (progn
(setq ltemp llx)
(setq llx (cons dxacum ltemp))
(setq ltemp lly)
(setq lly (cons dh ltemp))
     )
   )
                                ;        (command "_TEXT" "J" "BL" ptext                                   ALT1 (+ 90.0  (* (/ ang0 pi) 180.0) ) (rtos dh 2 0))
                                ;        (command "_TEXT" "J" "BL" (polar ptext (+ ang0 (* 0.5 pi)) (* 10.0 ALT1))  ALT1 (+ 90.0  (* (/ ang0 pi) 180.0) ) (rtos (/ dxacum 1000.0) 2 3))
   (setq dxacum (+ dxacum dx))
   (setq p2 (polar p2 ang0 (* dx (/ dxval dxtotal))    ))
   (setq p3 (polar p3 ang0 (* dx (/ dxval dxtotal))    ))
 )
 (if (not (= dxacum dxtotal))
   (progn
     (setq p2 (polar p1 (+ ang0 (* 1.5 pi)) delta))
     (setq p3 (polar p1 (+ ang0 (* 0.5 pi)) delta))
;      (setq p20 (tbinter sn0 p2 p3))
     (setq p30 (tbinter sn1 p2 p3))
;      (setq dh (distance p20 p30))
    (setq y30 (nth 1 p30))
    (setq dh (- y30 yref))
     
     (if (= dh delta)
(progn
  (terpri)
  (print
    " xxx NO INTERSECTION OF TENDON WITH REFERENCE OBJECT....PLEASE CHECK FIRST/LAST POINT XXXX"
  )
  (close FICHA)
  (QUIT)
)
     )
     (setq ltemp llx)
     (setq llx (cons dxtotal ltemp))
     (setq ltemp lly)
     (setq lly (cons dh ltemp))
   ))
 (setq llx (reverse llx))
 (setq lly (reverse lly))
 (setvar "osmode" 15359)
 (setq data (list llx lly))
 (setq data data)
)
(defun tbdataz1        (listax listay Radio / x0 y0 z0 nx ltemp count acum)
 (setq nx (length listax))
 (setq count 0)
 (setq y1 (nth count listay))
 (repeat nx
   (setq x0 (nth count listax))
   (setq y0 (nth count listay))
   (setq z0 (* Radio (cos (/ x0 Radio))))
   (if        (= count 0)
     (progn
(setq llz (list z0))
     )
     (progn
(setq ltemp llz)
(setq llz (cons z0 ltemp))
     )
   )
   (setq count (+ 1 count))
 )
 (setq llz (reverse llz))
 (terpri)
 (setq llz llz)
)
(defun tbdataz2        (listax         listay         wslope         offset         duct         /
         x0         y0         z0         nx         ltemp         count
         acum         ycorr
        )
 (setq nx (length listax))
 (setq count 0)
 (setq y1 (nth count listay))
 (repeat nx
   (setq x0 (nth count listax))
   (setq y0 (nth count listay))
   (setq ycorr (- y0 (/ duct 2.0)))
   (setq z0 (+ (tbfiledata wslope offset ycorr) (* -1.0 offset) (* 0.0 (/ duct 2.0))))
   (if        (= count 0)
     (progn
(setq llz (list z0))
     )
     (progn
(setq ltemp llz)
(setq llz (cons z0 ltemp))
     )
   )
   (setq count (+ 1 count))
 )
 (setq llz (reverse llz))
 (terpri)
 (setq llz llz)
)
(defun tbdataz3        (FICHA llx0   /         llx   lly   ang0  delta ss0
         ss1   ss2   sl0   sl1         sn0   sn1   sn2   en0         en1
         en2   p0    p1           dx         dxacum             dxtotal         count
         x0    x1    x2           y0         y1    y2    ytext p2         p3
         p20   p30   ptext dh txt0
        )
 (setq delta 100000.0)
 (setq ALT1 300.0)
 (setq count 0)
 (print "...PLAN VIEW select reference object......")
 (setq ss0 (ssget))
 (terpri)
 (print "...select CG tendon......")
 (setq ss1 (ssget))
 (terpri)
 (setq p0 (getpoint "..........First Point........"))
 (terpri)
 (setq p1 (getpoint p0 "..........Last  Point........"))
 (terpri)
 (setq txt0 (getstring  ".................."))
 (terpri)
 (setvar "osmode" 0)
 (setq sl0 (sslength ss0))
 (setq sn0 (ssname ss0 (- sl0 1)))
 (setq en0 (entget sn0))
 (setq sl1 (sslength ss1))
 (setq sn1 (ssname ss1 (- sl1 1)))
 (setq en1 (entget sn1))
 (setq dxtotal (distance p0 p1))
 (setq x0 (car p0))
 (setq x1 (car p1))
 (setq y0 (min (cadr p0) (cadr p1)))
 (setq ang0 (angle p0 p1))
 (setq p2 (polar p0 (+ ang0 (* 1.5 pi)) delta))
 (setq p3 (polar p0 (+ ang0 (* 0.5 pi)) delta))
 (setq dxacum 0.0)
 (repeat (length llx0)
   (setq p20 (tbinter sn0 p2 p3))
   (setq p30 (tbinter sn1 p2 p3))
   (setq dh (distance p20 p30))
   (if        (= dh delta)
     (progn
(terpri)
(print
  " xxx NO INTERSECTION OF TENDON WITH REFERENCE OBJECT....PLEASE CHECK FIRST/LAST POINT XXXX"
)
(close FICHA)
(QUIT)
     )
   )
   (if        (= dxacum 0.0)
     (progn
(setq lly (list dh))
     )
     (progn
(setq ltemp lly)
(setq lly (cons dh ltemp))
     )
   )
   
   
   (setq count (+ 1 count))
   (if  (<  count (length llx0))
     (setq dx (abs (- (nth count llx0) (nth (- count 1) llx0))))
     (setq dx dx)
   )
   
   (setq dxacum (+ dxacum dx))  
   (setq p2 (polar p2 ang0 dx))
   (setq p3 (polar p3 ang0 dx))
 )
 
 (setq lly (reverse lly))
 (setvar "osmode" 15359) 
 (setq lly lly)
)
(defun tbdataalfa (lx        ly   lz          /    x0   y0         z0   x1   y1        z1
           x2        y2   z2          nx   ltemp         count           lalfa
           n0        n1   n2          alfa
          )
 (setq nx (length lx))
 (setq count 1)
 (setq lalfa (list 0.0))
 (repeat (- nx 2)
   (setq n0 (- count 1))
   (setq n1 (- count 0))
   (setq n2 (+ count 1))
   (setq x0 (nth n0 lx))
   (setq x1 (nth n1 lx))
   (setq x2 (nth n2 lx))
   (setq y0 (nth n0 ly))
   (setq y1 (nth n1 ly))
   (setq y2 (nth n2 ly))
   (setq z0 (nth n0 lz))
   (setq z1 (nth n1 lz))
   (setq z2 (nth n2 lZ))
   (setq alfa (tbangle x0 y0 z0 x1 y1 z1 x2 y2 z2))
   (setq ltemp lalfa)
   (setq lalfa (cons alfa ltemp))
   (setq count (+ 1 count))
 )
 (setq ltemp lalfa)
 (setq lalfa (cons 0.0 ltemp))
 (setq lalfa (reverse lalfa))
 (setq lalfa lalfa)
)
(defun acos (x)
 (cond
   ((equal x 1.0 5.0e-
    0.0
   )
   ((equal x -1.0 5.0e-
    pi
   )
   ((< (abs x) 1.0)
    (- (* pi 0.5) (atan  x
                    (sqrt (- 1.0 (* x x)))   
                 ))
   )
 )
)
(defun tbdatalargo (lx          ly        lz              /        x0    y0
            z0          x1        y1    z1    nx          ltemp        count llargo
            n0          n1        largo lacum
           )
 (setq nx (length lx))
 (setq count 1)
 (setq llargo (list 0.0))
 (setq lacum 0.0)
 (repeat (- nx 1)
   (setq n0 (- count 1))
   (setq n1 (- count 0))
   (setq x0 (nth n0 lx))
   (setq x1 (nth n1 lx))
   (setq y0 (nth n0 ly))
   (setq y1 (nth n1 ly))
(setq z0 (nth n0 lz))
(setq z1 (nth n1 lz))
   (setq largo (tbdist x0 y0 z0 x1 y1 z1))
   (setq lacum (+ lacum largo))
   (setq llargo (cons lacum llargo))
   (setq count (+ 1 count))
 )
 (setq llargo (reverse llargo))
 (setq llargo llargo)
)
(defun tbf0 (largo  alfa   mu          k0         /        l0     l1     alfa0
     nx            ltemp  count  llargo n0        n1     delta  pacum
    )
 (setq nx (length largo))
 (setq count 1)
 (setq pacum 1.0)
 (setq lf0 (list 1.0))
 (repeat (- nx 1)
   (setq n0 (- count 1))
   (setq n1 (- count 0))
   (setq l0 (nth n0 largo))
   (setq l1 (nth n1 largo))
   (setq alfa0 (nth n1 alfa))
   (setq delta
   (exp (* -1.0 (+ (* 0.001 k0 (abs (- l1 l0))) (* mu alfa0))))
   )
   (setq pacum (* delta pacum))
   (setq lf0 (cons pacum lf0))
   (setq count (+ 1 count))
 )
 (setq lf0 (reverse lf0))
 (setq lf0 lf0)
)
(defun tbdelta (largo  force  EP     sigma0 /           ld0          l0         l1
        f0     f1     nx     ltemp  count  llargo n0         n1
        delta  dacum
       )
 (setq nx (length largo))
 (setq count 1)
 (setq dacum 0.0)
 (setq ld0 (list dacum))
 (repeat (- nx 1)
   (setq n0 (- count 1))
   (setq n1 (- count 0))
   (setq l0 (nth n0 largo))
   (setq l1 (nth n1 largo))
   (setq f0 (nth n0 force))
   (setq f1 (nth n1 force))
   (setq delta (* (abs (- l0 l1)) (* 0.5 (+ f0 f1)) (/ sigma0 EP)))
   (setq dacum (+ delta dacum))
   (setq ld0 (cons dacum ld0))
   (setq count (+ 1 count))
 )
 (setq ld0 (reverse ld0))
 (setq ld0 ld0)
)
(defun tbext2 (largo  force1 force2 delta1 delta2 EP         sigma0        /
       p01    p02    p11    p12           elong1 elong2 x0        x1
       x2     f2     f01    f02           f11          f12         nx        ltemp
       count  ld0    n0            n1           delta  delta0 dacum
      )
 (setq nx (length largo))
 (setq count 1)
 (setq ld0 (list 0.0 0.0 0.0))
 (repeat (- nx 1)
   (setq n0 (- count 1))
   (setq n1 (- count 0))
   (setq x0 (nth n0 largo))
   (setq x1 (nth n1 largo))
   (setq f01 (nth n0 force1))
   (setq f02 (nth n1 force1))
   (setq f11 (nth n0 force2))
   (setq f12 (nth n1 force2))
   (setq p01 (list x0 f01))
   (setq p02 (list x1 f02))
   (setq p11 (list x0 f11))
   (setq p12 (list x1 f12))
   (IF        (INTERs p01 p02 p11 p12)
     (progn
(setq x2 (car (INTERs p01 p02 p11 p12)))
(setq f2 (cadr (INTERs p01 p02 p11 p12)))
(setq
  delta        (* (abs (- x0 x2)) (* 0.5 (+ f01 f2)) (/ sigma0 EP))
)
(setq delta (+ delta (nth n0 delta1)))
(setq
  delta0 (* (abs (- x2 x1)) (* 0.5 (+ f12 f2)) (/ sigma0 EP))
)
(setq delta0 (+ delta0 (nth n1 delta2)))
(setq ld0 (list x2 delta delta0 f2))
     )
   )
   (setq count (+ 1 count))
 )
 (setq ld0 ld0)
)
(defun rtosf (num space fix0 / temp cont cont1)
 (setq temp (rtos num 2 fix0))
 (setq cont (strlen temp))
 (setq cont1 (- space cont))
 (repeat cont1
   (setq temp (strcat " " temp))
 )
 (setq temp temp)
)
(defun tbdata (/      title1 title2 title3 Ep          fpu         Ap        Nstrand
       Fjack  mu     k            Radio  stressing         ljack        lista
       ,      ss     sl            sn           en          sn0         sn1        sn2
       sn3    sn4    sn5    sn6           sn7          sn8         sn9        sn10
       sn11   sn12   sn13   sn14   ,          en0         en1        en2
       en3    en4    en5    en6           en7          en8         en9        en10
       en11   en12   en13   en14   ,          let1         let2        let3
       let4   let5   let6   let7   let8          let9         let10        let11
       let12  let13  let14
      )
 (terpri)
 (print "...Select Block with Datas ....")
 (setq ss (ssget))
 ;; Select entities
 (setq sl 1)
 ;; Get # ents selected
 (setq sn (ssname ss (- sl 1)))
 ;; Get entity name
 (setq en (entget sn))
 ;; Get entity structure
 (if (= (cdr (assoc 2 en)) "DATA-CABLE")
   ;; If block entity
   (progn
     (setq sn0 (entnext sn))
     (setq en0 (entget sn0))
     (setq let1 (cdr (assoc 1 en0)))
     (setq sn1 (entnext sn0))
     (setq en1 (entget sn1))
     (setq let2 (cdr (assoc 1 en1)))
     (setq sn2 (entnext sn1))
     (setq en2 (entget sn2))
     (setq let3 (cdr (assoc 1 en2)))
     (setq sn3 (entnext sn2))
     (setq en3 (entget sn3))
     (setq let4 (atof (cdr (assoc 1 en3))))
     (setq sn4 (entnext sn3))
     (setq en4 (entget sn4))
     (setq let5 (atof (cdr (assoc 1 en4))))
     (setq sn5 (entnext sn4))
     (setq en5 (entget sn5))
     (setq let6 (atof (cdr (assoc 1 en5))))
     (setq sn6 (entnext sn5))
     (setq en6 (entget sn6))
     (setq let7 (atof (cdr (assoc 1 en6))))
     (setq sn7 (entnext sn6))
     (setq en7 (entget sn7))
     (setq let8 (atof (cdr (assoc 1 en7))))
     (setq sn8 (entnext sn7))
     (setq en8 (entget sn8))
     (setq let9 (atof (cdr (assoc 1 en8))))
     (setq sn9 (entnext sn8))
     (setq en9 (entget sn9))
     (setq let10 (atof (cdr (assoc 1 en9))))
     (setq sn10 (entnext sn9))
     (setq en10 (entget sn10))
     (setq let11 (atof (cdr (assoc 1 en10))))
     (setq sn11 (entnext sn10))
     (setq en11 (entget sn11))
     (setq let12 (atoi (cdr (assoc 1 en11))))
     (setq sn12 (entnext sn11))
     (setq en12 (entget sn12))
     (setq let13 (atof (cdr (assoc 1 en12))))
     (setq sn13 (entnext sn12))
     (setq en13 (entget sn13))
     (setq let14 (atof (cdr (assoc 1 en13))))
   )
   (PROGN
     (TERPRI)
     (PRINT "...WRONG BLOCK...SHALL BE DATA-CABLE...")
     (TERPRI)
     (QUIT)
   )
 )
 (setq        lista (list let1    let2    let3    let4    let5    let6
            let7    let8    let9    let10   let11   let12
            let13   let14
           )
 )
 (setq lista lista)
)
(defun tbfill ( nelem value0 / ltemp count lista0)
     (setq lista0 ( list value0 ))
(repeat (- nelem 1)
        (setq lista0 (cons value0 lista0))
)
)
(defun tbadd ( ll1 ll2 / ii ltemp count lista0 value0)
       (setq count (length ll1))
         (if (not (= (length ll1) (length ll2))) (quit))
         (setq ii 0)
       (setq value0 (+ (nth ii ll1) (nth ii ll2)))
         (setq lista0 (list value0)) 
(repeat (- count 1)
          (setq ii (+ 1 ii))
          (setq value0 (+ (nth ii ll1) (nth ii ll2)))
        (setq lista0 (cons value0 lista0))
)
         (setq lista0 (reverse lista0))
       (setq lista0 lista0)
)
(defun tbextension (/            cont    title1  title2  title3  Ep
            fpu            Ap            Nstrand Fjack   stressing
            ljack   wslope  let1    let2    let3    llxy
            llx            lly            llz            llz1    llz2    llz3 Radio
            llalfa  llargo  lforce1 ,            lforce2 elong2
            x0            y0            z0            largo0  alfa0   f0
            f1            d0            d1            dj            alfacum datas
            FICHA   offset  duct    ctrlpv
           )
 (SETVAR "CMDECHO" 0)
(command "_ucs" "_w" )
 (setq datas (tbdata))
 (setq title1 (nth 0 datas))
 (setq title2 (nth 1 datas))
 (setq title3 (nth 2 datas))
 (setq Ep (nth 3 datas))
 (setq fpu (nth 4 datas))
 (setq Ap (nth 5 datas))
 (setq Nstrand (nth 6 datas))
 (setq Fjack (nth 7 datas))
 (setq mu (nth 8 datas))
 (setq k (nth 9 datas))
 (setq Radio (nth 10 datas))
 (setq stressing (nth 11 datas))
 (setq ljack (nth 12 datas))
 (setq wslope (nth 13 datas))
 (setq Ep (* Ep 1000.0))
 (setq Radio (* Radio 1000.0))
 (setq ftension (/ (* Fjack 1000.0) (* Nstrand Ap fpu)))
 (setq f0 (* fpu ftension))
 (terpri)
 (setq let1 (getvar "dwgprefix"))
 (setq let2 (getstring T "Output file name   : "))
 (setq let3 (strcat let1 let2 ".prn"))
 (SETQ FICHA (OPEN let3 "w"))
 (terpri)
 (setq offset (getreal "Offset   of duct   : "))
 (terpri)
 (if offset
 (setq duct (getreal "Diameter of duct   : "))
   (setq duct nil))
 (terpri)
;    (setq ctrlpv T)
 (setq ctrlpv (getstring  ".........PLAN VIEW : Y/N...."))
   (if (or (=  ctrlpv "n") (= ctrlpv "N"))
           (setq ctrlpv nil)
       (setq ctrlpv T))
 
 (terpri)
                                ;(setq offset 93)
                                ;  (setq duct 102)
 (setq let2 "            ")
 (write-line let2 FICHA)
 (setq let2 "                                                                               VSL MIDDLE EAST LLC")
 (write-line let2 FICHA)
 (setq let2 "            ")
 (write-line let2 FICHA)
 (setq let2 "          EXTENSION CALCULATION   ")
 (write-line let2 FICHA)
 (setq let2 "            ")
 (write-line let2 FICHA)
 (write-line let2 FICHA)
 (setq let2 "PROJECT     :   ")
 (SETQ let2 (strcat let2 title1))
 (write-line let2 FICHA)
 (setq let2 "STRUCTURE   :   ")
 (SETQ let2 (strcat let2 title2))
 (write-line let2 FICHA)
 (setq let2 "TENDON REF  :   ")
 (SETQ let2 (strcat let2 title3))
 (write-line let2 FICHA)
 (setq let2 "Horiz Radius:   ")
 (if ctrlpv
   (SETQ let2 (strcat let2 "Measured from plan view"))
   (if (= Radio 0.0)
     (SETQ let2 (strcat let2 "Straight"))
     (SETQ let2 (strcat let2 (rtos (/ Radio 1000.0) 2 1) " m")))
   )
 (write-line let2 FICHA)
 (setq let2 "Web Slope   :   1/")
 (SETQ let2 (strcat let2 (rtos wslope 2 2) "  "))
 (write-line let2 FICHA)
 (setq let2 "            ")
 (write-line let2 FICHA)
 (setq let2 "            ")
 (write-line let2 FICHA)
 (setq let2 "Steel References   ")
 (write-line let2 FICHA)
 (setq let2 "    Ultimate Tensile Strength  F's =    ")
 (SETQ let2 (strcat let2 (RTOS fpu 2 0) " MPa"))
 (write-line let2 FICHA)
 (setq let2 "    Young Modulus              Ep  =    ")
 (SETQ let2 (strcat let2 (RTOS (/ Ep 1000) 2 1) " KN/mm2"))
 (write-line let2 FICHA)
 (setq let2 "    Area Strand                As  =    ")
 (SETQ let2 (strcat let2 (RTOS Ap 2 0) " mm2"))
 (write-line let2 FICHA)
 (setq let2 "    Number of Strand           N   =    ")
 (SETQ let2 (strcat let2 (RTOS Nstrand 2 0) " nos"))
 (write-line let2 FICHA)
 (setq let2 "    Tendon Force               Pj  =    ")
 (SETQ let2 (strcat let2 (RTOS Fjack 2 1) " kN"))
 (write-line let2 FICHA)
 (setq let2 "    Stressing Force            sj  =    ")
 (SETQ let2 (strcat let2 (RTOS ftension 2 2) " x fpu"))
 (write-line let2 FICHA)
 (setq let2 "    Length Jack                Lj  =    ")
 (SETQ let2 (strcat let2 (RTOS ljack 2 1) " mm"))
 (write-line let2 FICHA)
 (setq let2 "    Stressing Operation            =    ")
 (IF (= stressing 3)
       (SETQ let2 (strcat let2 (RTOS 2         2 1) " 2 sides not simoultanesly"))
         (SETQ let2 (strcat let2 (RTOS stressing 2 1) " side"))
 )
 (write-line let2 FICHA)
 (setq let2 "            ")
 (write-line let2 FICHA)
 (setq let2 "Friction Constants   ")
 (write-line let2 FICHA)
 (setq let2 "    Curvature Coefficient      u   =    ")
 (SETQ let2 (strcat let2 (RTOS mu 2 5) " /radian"))
 (write-line let2 FICHA)
 (setq let2 "    Wobble Coefficient         k   =    ")
 (SETQ let2 (strcat let2 (RTOS k 2 5) " /m"))
 (write-line let2 FICHA)
 (IF (AND OFFSET DUCT)
           (PROGN
 (setq let2 "            ")
         (write-line let2 FICHA)
         (write-line let2 FICHA)
    (setq let2 "    Offset Web-Duct       Offset   =    ")
    (SETQ let2 (strcat let2 (RTOS offset 2 0) " mm"))
           (write-line let2 FICHA)
            (setq let2 "    Duct Diameter          Ddiam   =    ")
    (SETQ let2 (strcat let2 (RTOS duct 2 0) " mm"))
           (write-line let2 FICHA)
))
 (setq let2 "            ")
 (write-line let2 FICHA)
 (write-line let2 FICHA)
 (write-line let2 FICHA)
 (setq        let2
 "       X(mm)       Y(mm)      Zh(mm)      Zw(mm)      ZT(mm)  Length(mm)   Alfa(rad)       P1/Pj  Delta1(mm)"
 )
 (if (= stressing 2)
   (progn
     (setq let3 "       P2/Pj  Delta2(mm)")
     (setq let2 (strcat let2 let3))
   )
 )
 (write-line let2 FICHA)
 (setq llxy (tbdataxy FICHA))
 (setq llx (car llxy))
 (setq lly (cadr llxy))
 (if (= Radio 0.0)
       (SETQ llz1 (tbfill (length llx) 0.0))
         (setq llz1 (tbdataz1 llx lly Radio))
 )
 (if (and  offset duct)
         (setq llz2 (tbdataz2 llx lly wslope offset duct))
           (SETQ llz2 (tbfill (length llx) 0.0))
   )
 (SETQ llz3 (tbfill (length llx) 0.0))
 (if ctrlpv
                  (if (= Radio 0.0)
          (setq llz1 (cadr (tbdataxy FICHA)))
                   (setq llz1 (tbz3  llx)))
   )
;(print llz1) (print  llz2) (print llz3)
;  (print (length llz1)) (print (length llz2)) (print (length llz3)) 
;  (print (length llx)) (print (length lly)) (print (length llz1)) (print (length llz2)) (print (length llz3)) 
;  (print llx) (print lly) (print llz1) (print llz2) (print llz3) 
 
 (setq llz (tbadd (tbadd llz1 llz2 ) llz3 ))
;  (print llz)
 
 (setq llalfa (tbdataalfa llx lly llz))
 (setq llargo (tbdatalargo llx lly (tbadd llz2 llz3 ) ))
;(print " 2       QUAIS>>> VSL") 
;  (PRINT tbf0) (print llargo) (print llalfa) (print mu) (print k)
 (setq lforce1 (tbf0 llargo llalfa mu k))
;(print " 3       QUAIS>>> VSL")   
 (setq lforce2 (reverse (tbf0 (reverse llargo) (reverse llalfa) mu k)))
;(print " 4       QUAIS>>> VSL")
 
 (setq delta1 (tbdelta llargo lforce1 Ep f0))
 (setq        delta2
 (reverse (tbdelta (reverse llargo) (reverse lforce2) Ep f0))
 )
 (setq elong2 (tbext2 llargo lforce1 lforce2 delta1 delta2 Ep f0))
 (setq cont 0)
 (setq alfacum 0.0)
 (repeat (length llargo)
   (setq x0 (nth cont llx))
   (setq y0 (nth cont lly))
   (setq z0 (nth cont llz))
   (setq z1 (nth cont llz1))
   (setq z2 (nth cont llz2))
   (setq z3 (nth cont llz3))
   (setq largo0 (nth cont llargo))
   (setq alfa0 (nth cont llalfa))
   (setq d0 (nth cont delta1))
   (setq d1 (nth cont delta2))
   (setq f0 (nth cont lforce1))
   (setq f1 (nth cont lforce2))
                                ;            (setq let2 (strcat (rtosf x0 12 0)  (rtosf y0 12 0)  (rtosf z0 12 0)  (rtosf largo0 12 1)  (rtosf alfa0 12 2)  (rtosf f0 12 3) (rtosf d0 12 1)))
   (setq let2 (strcat (rtosf x0 12 0)
               (rtosf y0 12 0)
               (rtosf z1 12 0)
               (rtosf z2 12 0)
;                       (rtosf z3 12 0)
               (rtosf z0 12 0)
               (rtosf largo0 12 1)
               (rtosf alfa0 12 3)
               (rtosf f0 12 3)
               (rtosf d0 12 1)
       )
   )
   (if        (= stressing 2)
     (progn
(setq let1 (strcat (rtosf f1 12 3) (rtosf d1 12 1)))
(setq let2 (strcat let2 let1))
     )
   )
   (write-line let2 FICHA)
   (setq alfacum (+ alfa0 alfacum))
   (setq cont (+ 1 cont))
 )
 (setq let2 "            ")
 (write-line let2 FICHA)
 (write-line let2 FICHA)
 (setq let2 (strcat "Total Length     = " (rtosf largo0 12 1) " mm"))
 (write-line let2 FICHA)
 (setq let2 (strcat "Total Angle      = " (rtosf alfacum 12 2) " rad"))
 (write-line let2 FICHA)
 (if (= stressing 2)
   (progn
     (setq let2 (strcat "Length (P1=P2)   = "
                 (rtosf (nth 0 elong2) 12 1)
                 " mm"
         )
     )
     (write-line let2 FICHA)
     (setq let2 (strcat "Extension 1      = "
                 (rtosf (nth 1 elong2) 12 1)
                 " mm"
         )
     )
     (write-line let2 FICHA)
     (setq let2 (strcat "Extension 2      = "
                 (rtosf (nth 2 elong2) 12 1)
                 " mm"
         )
     )
     (write-line let2 FICHA)
   )
   (progn
     (setq let2 (strcat "Extension 1      = " (rtosf d0 12 1) " mm"))
     (write-line let2 FICHA)
     
(if (= stressing 3)
     (write-line (strcat "Topping up       = " (rtosf (+ (nth 1 elong2) (nth 2 elong2) (* -1.0 d0)) 12 1) " mm") FICHA)
  )
   )
 )
 (setq dj (/ (* 1.02 Fjack ljack 1000.0) (* Ap Ep Nstrand)))
 (setq let2 (strcat "Extension Jack   = " (rtosf dj 12 1) " mm"))
 (write-line let2 FICHA)
 (close FICHA)
 (SETVAR "CMDECHO" 1)
 (terpri) (print "........END OF PROGRAM......") (TERPRI)
)
(defun tbfiledata (slope    offset   yvalue   /               data
           yvalue1  yvalue2  offset1  offset2  FICHA
           ncont    ncont0   ncont1   ncont2   ncont3
           ctrl            cad0     cad1     cad2     cad3
           cad4            let1     let2     let3
          )
 (setq ctrl T)
 (setq ncont 
 (setq ncont0 1)
 (setq ncont1 (+ ncont0 ncont))
 (setq ncont2 (+ ncont1 ncont))
 (setq ncont3 (+ ncont2 ncont))
 (setq yvalue1 0.0)
 (setq yvalue2 0.0)
 (setq offset1 0.0)
 (setq offset2 0.0)
 (setq let1 (getvar "dwgprefix"))
 (setq let2 "zvalue")
 (setq let3 (strcat let1 let2 ".prn"))
 (SETQ FICHA (OPEN let3 "r"))
 (SETQ CAD0 (READ-LINE FICHA))
 (WHILE CTRL
   (IF        (SETQ CAD0 (READ-LINE FICHA))
     (PROGN
(SETQ CAD1 (atof (SUBSTR CAD0 ncont0 ncont)))
(SETQ CAD2 (atof (SUBSTR CAD0 ncont1 ncont)))
(SETQ CAD3 (atof (SUBSTR CAD0 ncont2 ncont)))
(SETQ CAD4 (atof (SUBSTR CAD0 ncont3 ncont)))
(if (and (= cad1 slope) (= cad2 offset))
  (if (not (> cad3 yvalue))
    (progn
      (setq yvalue1 cad3)
      (setq offset1 cad4)
    )
  )
)
(if (and (= cad1 slope) (= cad2 offset))
  (if (and (= yvalue2 0.0) (not (< cad3 yvalue)))
    (progn
      (setq yvalue2 cad3)
      (setq offset2 cad4)
    )
  )
)
(SETQ CTRL T)
     )
     (PROGN
(SETQ CTRL NIL)
     )
   )
 )
 (close FICHA)
 (if (or (= offset1 0.0) (= offset2 0.0))
   (setq data offset)
   (if        (= offset1 offset2)
     (SETQ data offset1)
     (setq data (+ offset1
            (* (/ (- yvalue yvalue1) (- yvalue2 yvalue1))
               (- offset2 offset1)
            )
         )
     )
   )
 )
 (setq data (atoi (rtos data 2 0)))
)
(defun tbz3 ( llx0 / number tol list1 count count1 ctrl  ang ang1 ang2 dh dh1 p0 p10  pini pfin pref p1 p2 p3 p4 p5
         ss1 s1 s2 s3 en1 en2 en3 radio yref )
 
 (setq tol 0.001)
;  (print "...Delta H...")
;  (setq dh (getreal))
 (setq dh (abs (- (nth 1 llx0) (nth 0 llx0))))
 
 (setq number 20.0)
 (setq dh1 (/ dh number))
 (terpri)
 (print "......PLAN VIEW.......")
 (print "...select cg tendon....")
 (setq ss1 (ssget))
 (terpri)
 (print "...first point....")
 (setq pini (getpoint))
 (terpri)
 
 (print "...last point....")
 (setq pfin (getpoint))
 (terpri)
 (print "...reference point....")
 (setq pref (getpoint))
 (terpri)
 (setq yref (nth 1 pref))
 
 (setvar "osmode" 0)
 (setvar "cmdecho" 0)
 (setq s1 (ssname ss1 0))
 (setq en1 (entget s1))
 
 (setq p1 pini)
 (setq p2 pfin)
 (setq count 0) (setq count1 0)
 (setq ctrl T)
 (setq list1 (list (- (nth 1 p1) yref) ))
 (setq ang (angle p1 p2))
 (while ctrl
   
         (setq ang1 (- ang (/ pi 2 )))
         (setq ang2 (+ ang (/ pi 2 )))
   (if (< ang1 0.0) (setq ang1 (+ ang1 (* 2.0 pi))))
   (if (< ang2 0.0) (setq ang2 (+ ang2 (* 2.0 pi))))
 
         (setq p0  (polar p1 ang1 dh1))
         (setq p10 (polar p1 ang2 dh1))
 
         (command "arc" "c" p1 p0 p10 ) 
         (setq s2 (entlast))
         (setq en2 (entget s2))
         (command "trim" s1 "" s2 "")
         (setq s3 (entlast))
         (setq en3 (entget s3))
         (setq ang3 (cdr (assoc 50 en3)))
         (setq ang4 (cdr (assoc 51 en3)))
   
(if  (or (= (length list1) (- (length llx0 ) 1))
         (and (or (> tol (abs (- ang3 ang1)) ) (> tol (abs (- ang3 ang2))))
              (or (> tol (abs (- ang4 ang1)) ) (> tol (abs (- ang4 ang2))))
              )
         )
  (progn
    (setq ctrl nil)
    (setq p3 pfin)
    (setq count (- number 1))
        
    )
  (progn
        (setq ctrl T)
        
                    (if (or (> tol (abs (- ang3 ang1)) )
                (> tol (abs (- ang3 ang2)) ))
                           (setq p3 (polar p1 ang4 dh1))
                           (setq p3 (polar p1 ang3 dh1))
                   )
))
  (command "erase" s3 "")
   
           (setq count (+ 1 count)) 
       (if (= (fix (/ count number)) (/ count number))
  (progn
    (setq count1 (+ 1 count1))
               (setq list1 (cons (- (nth 1 p3) yref) list1))
    ))
            (setq ang (angle p1 p3))
           (setq p1 p3)
   )
  (setq list1 (reverse list1))
 
)
 
(defun tbrecess ( /        cont  largo largo1 datas  factorx factory title1 bw1 bw2 h1 h2 alfaa alfav alfah depth
         alfai alfa alfa1 alfa2 alfa3 x0 x1 y0 y1 z1 z2 z3 zvalue txt0 txt1
         p0  p01 p1 p2 p3 p4 p5 p6 p7 p8 alt1 ptext scale s1 s2 s3 s4 s5 s6 aux0 aux1 aux2 aux3 aux4 aux5 aux6
        beta1 beta2 v1 v2 v3 w1 w2 w3 u1 u2 u3 listw listh hvalue wvalue
         )
 (SETVAR "CMDECHO" 0) 
 (command "_ucs" "_w" )
 
 (setvar "plinetype" 0)
 (setq ALT1 50)
 (setq scale 1)
;  (setq alfa (list  45 135 225 315 ))
 (terpri)                   
 (SETQ p0  (getpoint    "center point of anchorage"))
  (terpri)
 (SETQ p01 (getpoint p0 "center point at the top of anchorage"))
 (setq alfaa (/ (* 180.0 (angle p0 p01)) pi ))
 (setq alfaa (- 90.0 alfaa )) 
 (setq x0 (nth 0 p0))
 (setq y0 (nth 1 p0))
 (setq datas (tbdata2))
 (setq title1 (nth 0 datas))
 (setq bw1    (nth 1 datas))
 (setq bw2    (nth 2 datas))
 (setq h1     (nth 3 datas))
 (setq h2     (nth 4 datas))
 
;  (setq alfaa  (nth 5 datas))
 (setq alfav  (* -1.0 (nth 5 datas)))
 (setq alfah  (* -1.0 (nth 6 datas)))
;(print alfav ) (print alfah)
 
 (setq depth  (nth 7 datas))
 (setq alfai  (nth 8 datas))
  (setq alfa (list        
           
           (/ (* 180 (atan (/ h1 bw2))) pi)                   
           (- 180 (/ (* 180 (atan (/ h1 bw1))) pi))
                  (+ 180 (/ (* 180 (atan (/ h2 bw1))) pi))
           (- 360 (/ (* 180 (atan (/ h2 bw2))) pi))
           ))
 (setq largo (list
        (sqrt (+ (* h1 h1) (* bw2 bw2)))
        (sqrt (+ (* h1 h1) (* bw1 bw1)))
        
        (sqrt (+ (* h2 h2) (* bw1 bw1)))
        (sqrt (+ (* h2 h2) (* bw2 bw2))) ))
 (setq listh (list h1 h1 h2 h2))
 (setq listw (list bw2 bw1 bw1 bw2))
; (print datas) (print alfa) (print largo)
(setq u1 (* 1000 (sin (/ (*  alfah pi ) 180.0))))  
(setq u2 (* 1000 (cos (/ (*  alfah pi ) 180.0)))) 
(setq u3 (/ (* -1.0 u2 (sin (/ (*  alfav pi ) 180.0))) (cos (/ (*  alfav pi ) 180.0)))) 
 (setq aux0 (sqrt (+ (* u1 u1) (* u2 u2) (* u3 u3))))
 (setq u1 (/ u1 aux0))   (setq u2 (/ u2 aux0))   (setq u3 (/ u3 aux0))
(setq v1   (* 1000 (sin (/ (*  alfaa  pi ) 180.0)))) 
(setq v2 0.0)
(setq v3   (* 1000 (cos (/ (*  alfaa  pi ) 180.0)))) 
 (setq aux0 (sqrt (+ (* v1 v1) (* v2 v2) (* v3 v3))))
 (setq v1 (/ v1 aux0))   (setq v2 (/ v2 aux0))   (setq v3 (/ v3 aux0))
(setq w1   (* 1000 (sin (/ (*  (+ 90.0 alfaa)  pi ) 180.0)))) 
(setq w2 0.0)
(setq w3   (* 1000 (cos (/ (*  (+ 90.0 alfaa)  pi ) 180.0)))) 
 (setq aux0 (sqrt (+ (* w1 w1) (* w2 w2) (* w3 w3))))
 (setq w1 (/ w1 aux0))   (setq w2 (/ w2 aux0))   (setq w3 (/ w3 aux0))
(setq aux1 (- (* u2 v3) (* v2 u3)))
(setq aux2 (- (* v1 u3) (* u1 v3)))
(setq aux3 (- (* u1 v2) (* v1 u2)))
 
 (setq aux0 (sqrt (+ (* aux1 aux1) (* aux2 aux2) (* aux3 aux3))))
 (setq aux1 (/ aux1 aux0))   (setq aux2 (/ aux2 aux0))   (setq aux3 (/ aux3 aux0))
(setq aux4 (- (* u2 aux3)  (* aux2 u3) ))
(setq aux5 (- (* aux1 u3)  (* u1 aux3) ))
(setq aux6 (- (* u1 aux2)  (* aux1 u2) ))
 
 (setq aux0 (sqrt (+ (* aux4 aux4) (* aux5 aux5) (* aux6 aux6))))
 (setq aux4 (/ aux4 aux0))   (setq aux5 (/ aux5 aux0))   (setq aux6 (/ aux6 aux0))
 (setq beta1 (tbangle w1 w2 w3 0.0 0.0  0.0 aux1 aux2 aux3))
 (setq beta2 (tbangle v1 v2 v3 0.0 0.0  0.0 aux4 aux5 aux6))
 
 (setq aux0 (/ (/ (sin beta1) (cos beta1)) (cos beta2)  ))
 (setq beta1 (/ (sin beta2) (cos beta2)   ))
 (setq beta2 aux0)
 
;  (print (list u1 u2 u3 v1 v2 v3  w1 w2 w3))
;  (print (list aux1 aux2 aux3 aux4 aux5 aux6))
;  (print (list beta1 beta2))
  
 (setvar "osmode" 0)
 (setq cont 0)
 (repeat 4
   (setq alfa1 (- (nth cont alfa) alfaa))
   
   (setq largo1   (nth cont largo))
   (setq hvalue   (nth cont listh))
   (setq wvalue   (nth cont listw))
   
   (setq x1 (* largo1 (cos (/ (* pi alfa1 ) 180.0))))
   (setq y1 (* largo1 (sin (/ (* pi alfa1 ) 180.0))))
   (if (> y1 0.0) (setq factorx 1.0) (setq factorx -1.0)) 
   (if (> x1 0.0) (setq factory 1.0) (setq factory -1.0))
    (setq z1 (* factorx hvalue beta1  (/ aux5 (abs aux5))    ) )
    (setq z2 (* factory wvalue beta2  (/ aux2 (abs aux2))    ) )
;     (PRINT (LIST  factorx hvalue beta1  (/ aux5 (abs aux5))   Z1 ) )
;     (PRINT (LIST  factory wvalue beta2  (/ aux2 (abs aux2))   Z2 ) )
   (setq z3 (+ z1 z2))
   (setq temp (list x1 y1 z1 z2 z3)) (print temp)
   
   (setq ptext (list (+ x0 x1) (+ y0 y1)))
   (if (= cont 0)
     (setq zvalue  (list (list x1 y1 z3 ptext)))
     (setq zvalue (append  zvalue (list (list  x1 y1 z3 ptext )))))
   (if (> cont 1) (setq txt0 "TC") (setq txt0 "BC"))
   (setq txt1 (strcat "(" (rtos (abs x1) 2 0) "," (rtos (abs y1) 2 0) "," (rtos  z3 2 0) ")") )
   (command "_TEXT"
     "J"
     txt0
     ptext
     ALT1
     0.0
     txt1
   )
   
   (setq cont (+ 1  cont))
   )
 (setq p1 (nth 3 (nth 0 zvalue)))
 (setq p2 (nth 3 (nth 1 zvalue)))
 (setq p3 (nth 3 (nth 2 zvalue)))
 (setq p4 (nth 3 (nth 3 zvalue)))
 
 
 (setq p5 (polar p1 (+ (angle p1 p2) (* pi 0.25)) (* -1.0 (nth 2 (nth 0 zvalue)) scale)))
 (setq p6 (polar p2 (+ (angle p1 p2) (* pi 0.25)) (* -1.0 (nth 2 (nth 1 zvalue)) scale)))
 (setq p7 (polar p3 (+ (angle p4 p3) (* pi 0.25)) (* -1.0 (nth 2 (nth 2 zvalue)) scale)))
 (setq p8 (polar p4 (+ (angle p4 p3) (* pi 0.25)) (* -1.0 (nth 2 (nth 3 zvalue)) scale)))
  (command "pline" p1 p5 p8 p4 p1 "")   ;(command "region" (entlast) "") (setq s1 (entlast))
  (command "pline" p2 p6 p7 p3 p2 "")   ;(command "region" (entlast) "") (setq s2 (entlast))
  (command "pline" p1 p2 p3 p4 p1 "")   ;(command "region" (entlast) "") (setq s3 (entlast))
  (command "pline" p5 p6 p7 p8 p5 "")   ;(command "region" (entlast) "") (setq s4 (entlast))
;   (command "union" s1 s2 s3 s4 "")
 (terpri) (print "........END OF PROGRAM......") (TERPRI)
)
 
(defun tbdata2 (/      title1 title2 title3 Ep          fpu         Ap        Nstrand
       Fjack  mu     k            Radio  stressing         ljack        lista
       ,      ss     sl            sn           en          sn0         sn1        sn2
       sn3    sn4    sn5    sn6           sn7          sn8         sn9        sn10
       sn11   sn12   sn13   sn14   ,          en0         en1        en2
       en3    en4    en5    en6           en7          en8         en9        en10
       en11   en12   en13   en14   ,          let1         let2        let3
       let4   let5   let6   let7   let8          let9         let10        let11
       let12  let13  let14
      )
 (terpri)
 (print "...Select Block with Datas ....")
 (setq ss (ssget))
 (setq sl 1)
 (setq sn (ssname ss (- sl 1)))
 (setq en (entget sn))
 (if (= (cdr (assoc 2 en)) "RECESS-DATA")
   (progn
     (setq sn0 (entnext sn))
     (setq en0 (entget sn0))
     (setq let1 (cdr (assoc 1 en0)))
     (setq sn1 (entnext sn0))
     (setq en1 (entget sn1))
     (setq let2 (atof (cdr (assoc 1 en1))))
     (setq sn2 (entnext sn1))
     (setq en2 (entget sn2))
     (setq let3 (atof (cdr (assoc 1 en2))))
     
     (setq sn3 (entnext sn2))
     (setq en3 (entget sn3))
     (setq let4 (atof (cdr (assoc 1 en3))))
     (setq sn4 (entnext sn3))
     (setq en4 (entget sn4))
     (setq let5 (atof (cdr (assoc 1 en4))))
     (setq sn5 (entnext sn4))
     (setq en5 (entget sn5))
     (setq let6 (atof (cdr (assoc 1 en5))))
     (setq sn6 (entnext sn5))
     (setq en6 (entget sn6))
     (setq let7 (atof (cdr (assoc 1 en6))))
     (setq sn7 (entnext sn6))
     (setq en7 (entget sn7))
     (setq let8 (atof (cdr (assoc 1 en7))))
     (setq sn8 (entnext sn7))
     (setq en8 (entget sn8))
     (setq let9 (atof (cdr (assoc 1 en8))))
     
     
   )
   (PROGN
     (TERPRI)
     (PRINT "...WRONG BLOCK...SHALL BE DATA-CABLE...")
     (TERPRI)
     (QUIT)
   )
 )
 (setq        lista (list let1    let2    let3    let4    let5    let6
            let7  let8 let9
           )
 )
 (setq lista lista)
)

;example by Alan JT modified by me to use a PoinT
(setvar "osmode" 0)
(setq ent (entsel))
(setq pnt (vlax-curve-getclosestpointto (car ent) PT))