home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p190 / 3.ddi / LSP / HM12.LSP < prev    next >
Encoding:
Text File  |  1990-03-09  |  7.2 KB  |  213 lines
  1. ;**************************************
  2. ;*  The fuction for drwing belt wheel *
  3. ;**************************************
  4. (defun BWHEEL ()
  5. ;(SETVAR "CMDECHO" 0)
  6. (SETVAR "BLIPMODE" 0)
  7. (SETQ DGCH "")
  8. ;▓╬╩²╩Σ╚δ:
  9. (MENUCMD "S=IN1")
  10. (SETQ D (GETREAL "\n╟δ╩Σ╚δ╞ñ┤°┬╓╡─╜┌╘▓╓▒╛╢: "))
  11. (MENUCMD "S=BW1")
  12. (PRINC "\n╠ß╩╛:╕├╧ε╩Σ╚δ▒╪╨δ╡π╚í╧α╙ª╡─▓╦╡Ñ: ")
  13. (SETQ XH (GETSTRING "\n╟δ╩Σ╚²╜╟╜║┤°╨═║┼: "))
  14. (SETQ BP (GETREAL))
  15. (SETQ HM (GETREAL))
  16. (SETQ HA (GETREAL))
  17. (SETQ E (GETREAL))
  18. (SETQ F (GETREAL))
  19. (SETQ DLT (GETREAL))
  20. (MENUCMD "S=BW4")
  21. (PRINC "\n╠ß╩╛:╕├╧ε╩Σ╚δ▒╪╨δ╡π╚í╧α╙ª╡─▓╦╡Ñ: ")
  22. (SETQ N (GETREAL "\n╟δ╩Σ╚δ╞ñ┤°╡─╕∙╩²: "))
  23. (COND ((OR (= XH "O") (= XH "A") (= XH "B"))
  24.       (MENUCMD "S=BW2")))
  25. (COND ((OR (= XH "C") (= XH "D") (= XH "E"))
  26.       (MENUCMD "S=BW3")))
  27. (SETQ FI (GETREAL "\n╟δ╩Σ╚δ╞ñ┤°▓█╡─╜╟╢╚: "))
  28. (SETQ FI1 34)
  29. (SETQ FI2 36)
  30. (COND ((= XH "O")
  31. (IF (= FI FI1)(SETQ B0 10)(SETQ B0 10.2))
  32. ))
  33. (COND ((= XH "A")
  34. (IF (= FI FI1)(SETQ B0 13.1)(SETQ B0 13.4))
  35. ))
  36. (COND ((= XH "B")
  37. (IF (= FI FI1)(SETQ B0 17.1)(SETQ B0 17.4))
  38. ))
  39. (COND ((= XH "C")
  40. (IF (= FI FI2)(SETQ B0 22.9)(SETQ B0 23.1))
  41. ))
  42. (COND ((= XH "D")
  43. (IF (= FI FI2)(SETQ B0 32.5)(SETQ B0 32.9))
  44. ))
  45. (COND ((= XH "E")
  46. (IF (= FI FI2)(SETQ B0 38.5)(SETQ B0 38.9))
  47. ))
  48. (COND ((= XH "F")(SETQ B0 50.6)))
  49. (MENUCMD "S=IN1")
  50. (SETQ DGL (GETREAL "\n╟δ╩Σ╚δ┤°┬╓╡╣╜╟│ñ╢╚(0): "))
  51. (COND ((= DGL NIL)(SETQ DGL 0)))
  52. (IF (= DGL 0)(SETQ ANGL 0)
  53.     (SETQ ANGL (GETREAL "\n╟δ╩Σ╚δ┤°┬╓╡╣╜╟: ")))
  54. (GRTEXT -1 (STRCAT "┬╓╘╡╓▒╛╢<= " (RTOS D 2 2)))
  55. (SETQ D1 (GETREAL "\n╟δ╩Σ╚δ┬╓╘╡╡─╓▒╛╢: "))
  56. (SETQ DGR (GETREAL "\n╟δ╩Σ╚δ┬╓╘╡╡╣╜╟│ñ╢╚(0): "))
  57. (COND ((= DGR NIL)(SETQ DGR 0)))
  58. (IF (= DGR 0)(SETQ ANGR 0)
  59.     (SETQ ANGR (GETREAL "\n╟δ╩Σ╚δ┬╓╘╡╡╣╜╟: ")))
  60. (SETQ D (* D S) BP (* BP S) HM (* HM S) HA (* HA S))
  61. (SETQ E (* E S) F (* F S) B0 (* B0 S) D1 (* D1 S))
  62. (SETQ DGL1 (* DGL S) DGR1 (* DGR S))
  63. ;╝╞╦π║═╗µ═╝:
  64. (SETQ DE (+ D (* HA 2)))
  65. (SETQ P1 (LIST XB (+ YB (/ DE 2))))
  66. (SETQ P2 (LIST (+ (CAR P1) (- F (/ E 2))) (CADR P1)))
  67. (SETQ P31 (LIST (+ (CAR P1) (- F (/ B0 2))) (CADR P1)))
  68. (SETQ FII (/ (* FI PI) 180))
  69. (SETQ X4 (* HM (/ (SIN (/ FII 2)) (COS (/ FII 2)))))
  70. (SETQ P41 (LIST (+ (CAR P31) X4) (- (CADR P31) HM)))
  71. (SETQ X5 (- (/ B0 2) X4))
  72. (SETQ P51 (LIST (+ (CAR P41) X5) (CADR P41)))
  73. (SETQ B (LIST XB YB))
  74. (SETQ PB5 (LIST (CAR P51) YB))
  75. (SETQ P3 (LIST (+ (CAR P2) E) (CADR P2)))
  76. (SETQ LB (LIST (CAR P2) (CADR B)))
  77. (SETQ RT P3)
  78. (SETQ P4 (LIST (+ (CAR P3) E) (CADR P2)))
  79. (SETQ P5 (LIST (+ (CAR P4) E) (CADR P2)))
  80. (SETQ P6 (LIST (+ (CAR P5) E) (CADR P2)))
  81. (SETQ P7 (LIST (+ (CAR P6) E) (CADR P2)))
  82. (SETQ P8 (LIST (+ (CAR P7) E) (CADR P2)))
  83. (SETQ P9 (LIST (+ (CAR P8) E) (CADR P2)))
  84. (SETQ P10 (LIST (+ (CAR P9) E) (CADR P2)))
  85. (SETQ P11 (LIST (+ (CAR P10) E) (CADR P2)))
  86. (COND ((= N 1)(SETQ L2 (- (+ (CAR P3) (- F (/ E 2))) XB))))
  87. (COND ((= N 2)(SETQ L2 (- (+ (CAR P4) (- F (/ E 2))) XB))))
  88. (COND ((= N 3)(SETQ L2 (- (+ (CAR P5) (- F (/ E 2))) XB))))
  89. (COND ((= N 4)(SETQ L2 (- (+ (CAR P6) (- F (/ E 2))) XB))))
  90. (COND ((= N 5)(SETQ L2 (- (+ (CAR P7) (- F (/ E 2))) XB))))
  91. (COND ((= N 6)(SETQ L2 (- (+ (CAR P8) (- F (/ E 2))) XB))))
  92. (COND ((= N 7)(SETQ L2 (- (+ (CAR P9) (- F (/ E 2))) XB))))
  93. (COND ((= N 8)(SETQ L2 (- (+ (CAR P10) (- F (/ E 2))) XB))))
  94. (COND ((= N 9)(SETQ L2 (- (+ (CAR P11) (- F (/ E 2))) XB))))
  95. (SETQ L2 (/ L2 S))
  96. (GRTEXT -1 (STRCAT "┤°┬╓╡─┐φ╢╚>= " (RTOS L2 2 2)))
  97. (MENUCMD "S=IN1")
  98. (SETQ L (GETREAL "\n╟δ╩Σ╚δ╞ñ┤°┬╓╡─┐φ╢╚: "))
  99. (SETQ L (* L S))
  100. (GRTEXT)
  101. (MENUCMD "S=IN2")
  102. (INITGET "Y N")
  103. (SETQ YN (GETKWORD "\n╩╟╖±╙╨╣½▓ε(N): "))
  104. (COND ((= YN "Y")
  105.                (MENUCMD "S=IN1")
  106.                (SETQ SCHL (GETREAL "\n╟δ╩Σ╚δ╔╧╞½▓ε(0): "))
  107.                (IF (= SCHL NIL)(SETQ SCHL 0))
  108.                (SETQ XCHL (GETREAL "\n╟δ╩Σ╚δ╧┬╞½▓ε(0): "))
  109.                (IF (= XCHL NIL)(SETQ XCHL 0))
  110. ))
  111. (SETQ P13 (LIST (+ XB L) (+ YB (/ D1 2))))
  112. (SETQ P14 (LIST (+ XB L) YB))
  113. (COMMAND "LINE" B P1 P2 "")
  114. (COMMAND "PLINE" P2 P31 P41 P51 "")
  115. (COMMAND "MIRROR" "L" "" P51 PB5 "N")
  116. (COND ((= N 1)
  117.  (SETQ PE (LIST (+ (CAR P3) (- F (/ E 2))) (CADR P2)))
  118.  (SETQ P12 (LIST (CAR PE) (+ (CADR B) (/ D1 2))))
  119.  (COMMAND "LINE" P3 PE P12 P13 P14 "")
  120. ))
  121. (COND ((= N 2)
  122.  (SETQ PE (LIST (+ (CAR P4) (- F (/ E 2))) (CADR P2)))
  123.  (SETQ P12 (LIST (CAR PE) (+ (CADR B) (/ D1 2))))
  124.  (COMMAND "COPY" "W" LB RT "" "M" P2 P3 "")
  125.  (COMMAND "LINE" P4 PE P12 P13 P14 "")
  126. ))
  127. (COND ((= N 3)
  128.  (SETQ PE (LIST (+ (CAR P5) (- F (/ E 2))) (CADR P2)))
  129.  (SETQ P12 (LIST (CAR PE) (+ (CADR B) (/ D1 2))))
  130.  (COMMAND "COPY" "W" LB RT "" "M" P2 P3 P4 "")
  131.  (COMMAND "LINE" P5 PE P12 P13 P14 "")
  132. ))
  133. (COND ((= N 4)
  134.  (SETQ PE (LIST (+ (CAR P6) (- F (/ E 2))) (CADR P2)))
  135.  (SETQ P12 (LIST (CAR PE) (+ (CADR B) (/ D1 2))))
  136.  (COMMAND "COPY" "W" LB RT "" "M" P2 P3 P4 P5 "")
  137.  (COMMAND "LINE" P6 PE P12 P13 P14 "")
  138. ))
  139. (COND ((= N 5)
  140.  (SETQ PE (LIST (+ (CAR P7) (- F (/ E 2))) (CADR P2)))
  141.  (SETQ P12 (LIST (CAR PE) (+ (CADR B) (/ D1 2))))
  142.  (COMMAND "COPY" "W" LB RT "" "M" P2 P3 P4 P5 P6 "")
  143.  (COMMAND "LINE" P7 PE P12 P13 P14 "")
  144. ))
  145. (COND ((= N 6)
  146.  (SETQ PE (LIST (+ (CAR P8) (- F (/ E 2))) (CADR P2)))
  147.  (SETQ P12 (LIST (CAR PE) (+ (CADR B) (/ D1 2))))
  148.  (COMMAND "COPY" "W" LB RT "" "M" P2 P3 P4 P5 P6 P7 "")
  149.  (COMMAND "LINE" P8 PE P12 P13 P14 "")
  150. ))
  151. (COND ((= N 7)
  152.  (SETQ PE (LIST (+ (CAR P9) (- F (/ E 2))) (CADR P2)))
  153.  (SETQ P12 (LIST (CAR PE) (+ (CADR B) (/ D1 2))))
  154.  (COMMAND "COPY" "W" LB RT "" "M" P2 P3 P4 P5 P6 P7 P8 "")
  155.  (COMMAND "LINE" P9 PE P12 P13 P14 "")
  156. ))
  157. (COND ((= N 8)
  158.  (SETQ PE (LIST (+ (CAR P10) (- F (/ E 2))) (CADR P2)))
  159.  (SETQ P12 (LIST (CAR PE) (+ (CADR B) (/ D1 2))))
  160.  (COMMAND "COPY" "W" LB RT "" "M" P2 P3 P4 P5 P6 P7 P8 P9 "")
  161.  (COMMAND "LINE" P10 PE P12 P13 P14 "")
  162. ))
  163. (COND ((= N 9)
  164.  (SETQ PE (LIST (+ (CAR P11) (- F (/ E 2))) (CADR P2)))
  165.  (SETQ P12 (LIST (CAR PE) (+ (CADR B) (/ D1 2))))
  166.  (COMMAND "COPY" "W" LB RT "" "M" P2 P3 P4 P5 P6 P7 P8 P9 P10 "")
  167.  (COMMAND "LINE" P11 PE P12 P13 P14 "")
  168. ))
  169. (SETQ P15 (LIST (CAR P12) (CADR P14)))
  170. (COMMAND "LINE" P12 P15 "")
  171. (SETQ P2 (LIST XB (+ (CADR B) (/ D 2))))
  172. (SETQ P3 (LIST (CAR PE) (CADR P2)))
  173. (COMMAND "LAYER" "N" "F7" "S" "F7" "L" "DASHDOT" "" "C" "Y" "" "")
  174. (COMMAND "LINE" P2 P3 "")
  175. (SETQ LB B)
  176. (SETQ RT (LIST (CAR P13) (CADR PE)))
  177. (COMMAND "MIRROR" "W" LB RT "" B P14 "N")
  178. (COMMAND "LAYER" "S" 0 "L" "" "" "")
  179. (FN)
  180. (SETQ DL1 D DR1 D1 L1 L SCHD BP XCHD HM LK1 HA LL1 E NZL1 N)
  181. (SETQ M1 F BF1 B0 ALF1 FI)
  182. (SETQ DL1 (/ DL1 S) DR1 (/ DR1 S) L1 (/ L1 S) SCHD (/ SCHD S))
  183. (SETQ XCHD (/ XCHD S) DGL1 (/ DGL1 S) DGR1 (/ DGR1 S))
  184. (SETQ LL1 (/ LL1 S) LK1 (/ LK1 S) NZL1 (/ NZL1 S))
  185. (SETQ M1 (/ M1 S) BF1 (/ BF1 S))
  186. (attdef2)
  187. (ATTDEF1 "SCHD1" SCHD FPT)
  188. (ATTDEF1 "XCHD1" XCHD FPT)
  189. (ATTDEF1 "LK1" LK1 FPT)
  190. (ATTDEF1 "LL1" LL1 FPT)
  191. (ATTDEF1 "NZL1" N FPT)
  192. (ATTDEF1 "GPSZ1" "BW" FPT)
  193. (ATTDEF1 "KTYPE1" XH FPT)
  194. (ATTDEF1 "M1" M1 FPT)
  195. (ATTDEF1 "BF1" BF1 FPT)
  196. (ATTDEF1 "ALF1" FI FPT)
  197. (SETQ LB (LIST (CAR B) (- YB (/ DE 2))))
  198. (SETQ RT (LIST (+ XB L) (+ YB (/ DE 2))))
  199. (command "block" no fpt "w" LB RT "")
  200. (command "insert" no fpt "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "")
  201. (XB1)
  202. ;(redraw)
  203. ;(MENUCMD "S=IN2")
  204. ;(SETQ YN (GETSTRING "\n╩╟╖±╝╠╨°╗¡═Γ▒φ├µ: "))
  205. ;(IF (OR (= YN "Y") (= YN "y"))
  206. ; (PROGN(MENUCMD "I=YY")
  207. ;       (MENUCMD "I=*")
  208. ; )
  209.                (MENUCMD "S=SCREEN")
  210. ;)
  211. )
  212. (BWHEEL)
  213.