API tools faq
paste
Guest User

LISP ARTDB - ACAD14

a guest
Jan 4th, 2017
252
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 8.38 KB | None | 0 0
raw download clone embed print report
  1. ;--------------------------------------------------------------------
  2. ; Le programme ARTBD.LSP permet de calculer
  3. ; les A.R.T.B.D d'un arc de cercle aprŠs avoir choisi
  4. ; … l'ecran les droites qui le forment. Tout echelle
  5. ;--------------------------------------------------------------------
  6. (defun c:art ()
  7.  
  8. (graphscr)
  9. (setq pi 3.141592654)
  10. (setq fin 1)
  11.  
  12. (if (= echell nil) (setq echell 1000))
  13. (setq text_ech (strcat "\nL'echelle de sortie <" (rtos echell 2 2) "> : "))
  14. (setq val_ech (getreal text_ech))
  15. (if (/= val_ech nil) (setq echell val_ech))
  16.  
  17. (setq haut(/ (* 1.7 echell) 1000))
  18.  
  19. (setq rac (/ 1000 (* echell)))
  20. (setq rac1 (/ 3.85 (* rac)))
  21. (setq rac2 (/ 3 (* rac)))
  22.  
  23.  
  24. (setq or1 (getangle "\nAngle d'orientation"))
  25.  
  26. ;;;; (if (= anglea nil) (setq anglea 1))
  27. ;;;; (setq or2 (strcat "\nAngle d'orientation <" (rtos anglea 2 2 ) "> : "))
  28. ;;;; (setq or1 (getangle or2))
  29. ;;;; (if (/= or1 nil) (setq anglea or1))
  30.  
  31.  
  32. (while fin
  33.  
  34. (setq or or1)
  35.  
  36. (setq or (* (/ or pi) 180))
  37. (print or)
  38.  
  39. (if (< or 90) (setq gis (- 90 or)))
  40. (if (and (< or 180) (> or 90)) (setq gis (- 450 or)))
  41. (if (and (< or 270) (> or 180)) (setq gis (- 450 or)))
  42. (if (and (< or 360) (> or 270)) (setq gis (- 450 or)))
  43. (print gis)
  44. (setq gis (* (/ gis 180) pi))
  45. ;--------------------------------- selection des droites formant
  46. ; l'arc de cercle
  47. ;
  48. (setq ent1 (entsel))
  49. (setq ab (entget (car ent1)))
  50. (setq pta (cdr (assoc 10 ab)))
  51. (setq ptb (cdr (assoc 11 ab)))
  52. (setq xa (car pta))
  53. (setq ya (cadr pta))
  54. (setq xb (car ptb))
  55. (setq yb (cadr ptb))
  56.  
  57. (setq ent2 (entsel))
  58. (setq cd (entget (car ent2)))
  59. (setq ptc (cdr (assoc 10 cd)))
  60. (setq ptd (cdr (assoc 11 cd)))
  61. (setq xc (car ptc))
  62. (setq yc (cadr ptc))
  63. (setq xd (car ptd))
  64. (setq yd (cadr ptd))
  65.  
  66. ;--------------------------------- calcul du sommet --------------
  67.  
  68. (setq a1 (/ (- ya yb) (- xa xb)))
  69. (setq a2 (/ (- yd yc) (- xd xc)))
  70. (setq b1 (- ya (* a1 xa)))
  71. (setq b2 (- yd (* xd a2)))
  72. (setq xs (/ (- b2 b1) (- a1 a2)))
  73. (setq ys (+ b1 (* a1 xs)))
  74.  
  75. ;-------------------------------- calcul des gisements --------------
  76.  
  77. (setq pi2 (* pi 2))
  78.  
  79. (setq dxsa (- xs xa))
  80. (setq dysa (- ys ya))
  81. (setq dxsb (- xs xb))
  82. (setq dysb (- ys yb))
  83.  
  84. (setq dxsc (- xs xc))
  85. (setq dysc (- ys yc))
  86. (setq dxsd (- xs xd))
  87. (setq dysd (- ys yd))
  88.  
  89.  
  90. (setq dsa (sqrt (+ (expt dxsa 2) (expt dysa 2) )))
  91. (setq dsb (sqrt (+ (expt dxsb 2) (expt dysb 2) )))
  92.  
  93.  
  94. (if (> dsa dsb)
  95. (progn
  96. (setq dx (- xa xs))
  97. (setq dy (- ya ys))
  98. ))
  99.  
  100. (if (< dsa dsb)
  101. (progn
  102. (setq dx (- xb xs))
  103. (setq dy (- yb ys))
  104. ))
  105.  
  106. (setq gd (atan (/ dx dy)))
  107. (if (and (< dx 0) (> dy 0)) (setq gd (+ pi2 gd)))
  108. (if (< dy 0) (setq gd (+ gd pi)))
  109.  
  110.  
  111.  
  112. ;-----------------------------------------------
  113.  
  114. (setq dsc (sqrt (+ (expt dxsc 2) (expt dysc 2) )))
  115. (setq dsd (sqrt (+ (expt dxsd 2) (expt dysd 2) )))
  116.  
  117. (if (> dsc dsd)
  118. (progn
  119. (setq dx (- xc xs))
  120. (setq dy (- yc ys))
  121. ))
  122.  
  123. (if (< dsc dsd)
  124. (progn
  125. (setq dx (- xd xs))
  126. (setq dy (- yd ys))
  127. ))
  128.  
  129. ;(if (/= xs xc) (setq dx (- xc xs)))
  130. ;(if (= xs xc) (setq dx (- xd xs)))
  131. ;(if (/= ys yc) (setq dy (- yc ys)))
  132. ;(if (= ys yc) (setq dy (- yd ys)))
  133.  
  134. (setq ga (atan (/ dx dy)))
  135. (if (and (< dx 0) (> dy 0)) (setq ga (+ pi2 ga)))
  136. (if (< dy 0) (setq ga (+ ga pi)))
  137.  
  138. ;------------------------------ calcul de l'angle A --------------------
  139.  
  140. (setq angletopo (- ga gd))
  141. (if (< angletopo 0) (setq angletopo (+ angletopo pi2)))
  142. ;(if (< angletopo 0) (setq angletopo (+ angletopo pi2)))
  143. (print (/ (* angletopo 200) pi))
  144. (setq angleint (abs (- pi angletopo)))
  145. (print (/ (* angleint 200) pi))
  146.  
  147. ;------------------------------ saisie du rayon -------------------------
  148.  
  149. (setq rayon (getreal "\nEntrez le rayon : "))
  150.  
  151. ;------------------------------ calcul de T B D -------------------------
  152.  
  153. (setq T (* rayon (/ (sin (/ angleint 2)) (cos (/ angleint 2)))))
  154. ;(setq T (abs (T)))
  155. (setq B (- (sqrt (+ (expt T 2) (expt rayon 2))) rayon))
  156. ;(setq B (abs (B)))
  157. (setq D (* rayon angleint))
  158. ;(setq D (abs (D)))
  159.  
  160. ;------------------------- affichage … l'ecran du rectange des ARTBD----
  161.  
  162.  
  163. (setq an ( / (* angletopo 200) pi))
  164. (setq pos1 (getpoint "Point d'insertion : "))
  165. (setq gis1 gis)
  166. (print gis1)
  167. (setq gis2 (+ gis1 (/ pi 2)))
  168. (print gis2)
  169. (setq gis3 (+ gis2 (/ pi 2)))
  170. (print gis3)
  171.  
  172. (setq pos2 (list (+ (car pos1) (* 12 (* haut (sin gis1)))) (+ (cadr pos1) (* 12 (* haut (cos gis1)))) ))
  173.  
  174. (setq pos3 (list (+ (car pos2) (* 10 (* haut (sin gis2)))) (+ (cadr pos2) (* 10 (* haut (cos gis2)))) ))
  175.  
  176. (setq pos4 (list (+ (car pos3) (* 12 (* haut (sin gis3)))) (+ (cadr pos3) (* 12 (* haut (cos gis3)))) ))
  177.  
  178. (command "_line" pos1 pos2 pos3 pos4 pos1 "")
  179.  
  180. ;----------- formation des textes correspondant a ARTBD--------
  181.  
  182. (setq tex (strcat "A = " (rtos an 2 2)))
  183. (setq gis12 (/ (+ gis1 gis2) 2))
  184. (setq posa (list (+ (car pos1) (* rac1 (sin gis12))) (+ (cadr pos1) (* rac1 (cos gis12))) ))
  185. (command "_Text" posa haut or tex)
  186.  
  187. (setq tex (strcat "R = " (rtos rayon 2 0)))
  188. (setq posr (list (+ (car posa) (* rac2 (sin gis2))) (+ (cadr posa) (* rac2 (cos gis2))) ))
  189. (command "_Text" posr haut or tex)
  190.  
  191. (setq tex (strcat "T = " (rtos T 2 2)))
  192. (setq post (list (+ (car posr) (* rac2 (sin gis2))) (+ (cadr posr) (* rac2 (cos gis2))) ))
  193. (command "_Text" post haut or tex)
  194.  
  195. (setq tex (strcat "B = " (rtos B 2 2)))
  196. (setq posb (list (+ (car post) (* rac2 (sin gis2))) (+ (cadr post) (* rac2 (cos gis2))) ))
  197. (command "_Text" posb haut or tex)
  198.  
  199. (setq tex (strcat "D = " (rtos D 2 2)))
  200. (setq posd (list (+ (car posb) (* rac2 (sin gis2))) (+ (cadr posb) (* rac2 (cos gis2))) ))
  201. (command "_Text" posd haut or tex)
  202.  
  203.  
  204.  
  205.  
  206. (setq xsy1 (+ (* rac2 10) xs))
  207. (setq xsy2 (+ (* rac2 15) ys))
  208. (setq xy (list xsy1 xsy2))
  209.  
  210.  
  211. (setq tex (strcat "Y = " (rtos ys 2 2)))
  212. (setq posx (list (+ (car xy) (* rac2 )) (+ (cadr xy) (* rac2 )) ))
  213. (command "_Text" posx haut "0" tex)
  214.  
  215. (setq tex (strcat "X = " (rtos xs 2 2)))
  216. (setq posy (list (+ (car posx) ) (+ (cadr posx) (* rac2) ) ))
  217. (command "_Text" posy haut "0" tex)
  218.  
  219.  
  220. (setq px (+ (* rac2 0.5) xsy1))
  221. (setq py (+ (* rac2 0.5) xsy2))
  222. (setq pos6 (list px py))
  223.  
  224. (setq pos7 (list (+ (car pos6) (* 14 haut)) (+ (cadr pos6)) ))
  225. (setq pos8 (list (+ (car pos7)) (+ (cadr pos7) (* 4.5 haut)) ))
  226. (setq pos9 (list (+ (car pos8) (- (* 14 haut))) (+ (cadr pos8)) ))
  227. (command "_line" pos6 pos7 pos8 pos9 pos6 "")
  228.  
  229.  
  230.  
  231.  
  232. (setq xpt1 (+ xs (* T (sin gd))))
  233. (setq ypt1 (+ ys (* T (cos gd))))
  234. (setq tp1 (list xpt1 ypt1))
  235.  
  236. (setq xpt2 (+ xs (* T (sin ga))))
  237. (setq ypt2 (+ ys (* T (cos ga))))
  238. (setq tp2 (list xpt2 ypt2))
  239.  
  240. (setq r (/ 2 (* rac)))
  241.  
  242. ;; (command "_line" tp1 tp2 "")
  243. (command "_circle" tp1 r "")
  244. (command "_circle" tp2 r "")
  245. (command "_arc" tp1 "_e" tp2 "_r" rayon"")
  246.  
  247. (command "_redraw")
  248.  
  249. ;while
  250. )
  251. ;--------fin du programme--------------------------------------------
  252. )
Advertisement
Add Comment
Please, Sign In to add comment
Public Pastes
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!