home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p190 / 3.ddi / LSP / HM09.LSP < prev    next >
Encoding:
Text File  |  1991-04-08  |  5.7 KB  |  173 lines
  1. ;***************************************
  2. ;*   The program for drawing cone gear.*
  3. ;***************************************
  4. (DEFUN CONGEAR ()
  5. (SETVAR "CMDECHO" 0)
  6. (SETVAR "BLIPMODE" 0)
  7. (MENUCMD "S=GE1")
  8.  (initget (+ 1 2 4))
  9. (SETQ M (GETREAL "\n╟δ╩Σ╚δ┤≤╢╦─ú╩²: "))
  10. (MENUCMD "S=IN1")
  11.  (initget (+ 1 2 4))
  12. (SETQ Z1 (GETREAL "\n╟δ╩Σ╚δ│▌┬╓1╡─│▌╩²: "))
  13.  (initget (+ 1 2 4))
  14. (SETQ Z2 (GETREAL "\n╟δ╩Σ╚δ│▌┬╓2╡─│▌╩²: "))
  15. (MENUCMD "S=CG1")
  16. (setq T (getREAL "\n╗µ╓╞│▌┬╓1╗╣╩╟│▌┬╓2(1)? "))
  17. (IF (= T NIL) (SETQ T 1))
  18. (COND ((= T 2) (SETQ Z Z1) (SETQ Z1 Z2) (SETQ Z2 Z)))
  19. (SETQ ALF (GETREAL "\n╩Σ╚δ╤╣┴ª╜╟(20): "))
  20. (if (= ALF NIL)(setq alf 20))
  21. (MENUCMD "S=IN2")
  22. (setq sc (getstring "\n┬▌ ╨² │▌ ┬╓ ╖±(N)? "))
  23. (IF (= SC " ")(SETQ SC "N"))
  24. (if (or (/= sc "y") (/= sc "Y"))(setq bat 0))
  25. (MENUCMD "S=IN1")
  26. (if (or (= sc "y") (= sc "Y"))(setq bat (getreal "\n╩Σ ╚δ ┬▌ ╨² ╜╟=: ")))
  27. (MENUCMD "S=IN2")
  28. (if (/= bat 0)(setq yn (getstring "\n╫≤ ╨²(L) ╗≥ ╙╥ ╨²(R)? ")))
  29. (if (= yn nil)(setq yn "R"))
  30. (SETQ FI (ATAN Z1 Z2))
  31. (SETQ FI1 (+ FI (/ (* 2 (SIN FI)) Z1)))
  32. (SETQ FI2 (- FI (/ (* 2.4 (SIN FI)) Z1)))
  33. (MENUCMD "S=IN1")
  34.  (initget (+ 1 2 4))
  35. (SETQ B (GETREAL "\n╟δ╩Σ╚δ│▌┐φ: "))
  36. (SETQ LL (/ (* M Z1) (* 2 (SIN FI))))
  37. (SETQ LL1 (/ LL (COS (- FI FI2))))
  38. (SETQ L01 (/ (- LL B) (COS (- FI1 FI))))
  39. (SETQ BB1 (- (* LL1 (COS FI2)) (* L01 (COS FI1))))
  40. (GRTEXT -1 (STRCAT "│▌┬╓╢╬╡─┐φ╢╚> " (RTOS BB1 2 2)))
  41. (SETQ L2 (GETREAL "\n╟δ╩Σ╚δ│▌┬╓╢╬╡─┐φ╢╚: "))
  42. (SETQ BB2 (- L2 BB1))
  43. (GRTEXT -1 (STRCAT "▒│╫╢═╣╠¿╡─┐φ╢╚< " (RTOS BB2 2 2)))
  44. (SETQ L0 (GETREAL "\n╟δ╩Σ╚δ▒│╫╢═╣╠¿╡─┐φ╢╚: "))
  45. (SETQ D01 (* 2 (* LL1 (SIN FI2))))
  46. (SETQ DBB (- BB2 L0))
  47. (SETQ D01 (- D01 (* 2 (* DBB (/ (SIN FI) (COS FI))))))
  48. (GRTEXT -1 (STRCAT "▒│╫╢═╣╠¿╡─╓▒╛╢< " (RTOS D01 2 2)))
  49. (SETQ D0 (GETREAL "\n╟δ╩Σ╚δ▒│╫╢═╣╠¿╡─╓▒╛╢: "))
  50. (SETQ L (- L2 L0))
  51. (SETQ BB (LIST XB YB))
  52. (MENUCMD "S=IN2")
  53. (INITGET "Y N")
  54. (SETQ YY (GETKWORD "\n╨í╢╦╩╟╘┌╫≤▒▀┬≡(Y)? "))
  55. (COND ((= YY NIL) (SETQ YY "Y")))
  56. (COND ((= YY "N")(PROGN
  57.                 (SETQ FI (- PI FI))
  58.                 (SETQ FI1 (- PI FI1))
  59.                 (SETQ FI2 (- PI FI2))
  60.                 (SETQ BB (LIST (+ (CAR BB) (* S L2)) (CADR BB)))
  61. )))
  62. (SETQ DGL1 (GETREAL "\n╟δ╩Σ╚δ╡╣╜╟│ñ╢╚(0): "))
  63. (COND ((= DGL1 NIL) (SETQ DGL1 0 ANGL 0)))
  64. (COND ((/= DGL1 0)
  65. (SETQ ANGL (GETREAL "\n╟δ╩Σ╚δ╡╣╜╟╜╟╢╚(0): "))
  66. (COND ((= ANGL NIL) (SETQ ANGL 0)))
  67. ))
  68. (SETQ D (* M Z1))
  69. ;(SETQ BB (LIST XB YB))
  70. (SETQ L (* L S))
  71. (SETQ DGL1 (* DGL1 S))
  72. (SETQ L0 (* L0 S))
  73. (SETQ D0 (* D0 S))
  74. (SETQ L2 (* L2 S))
  75. (SETQ B (* B S))
  76. (SETQ D (* D S))
  77. (SETQ LL (/ (* M Z1) (* 2 (SIN FI))))
  78. (SETQ LL (* LL S))
  79. (SETQ L01 (/ (- LL B) (COS (- FI1 FI))))
  80. (SETQ P0 (LIST (- (CAR BB) (* L01 (COS FI1))) (CADR BB)))
  81. ;(COND ((= YY "N") (SETQ P0 (LIST (- (CAR BB) (* L01 (COS FI1))) (CADR BB)))))
  82. (SETQ P1 (POLAR P0 FI1 L01))
  83. (SETQ L02 (/ LL (COS (- FI1 FI))))
  84. (SETQ P2 (POLAR P0 FI1 L02))
  85. (SETQ P3 (POLAR P0 FI LL))
  86. (SETQ L04 (/ LL (COS (- FI FI2))))
  87. (SETQ P4 (POLAR P0 FI2 L04))
  88. (SETQ L07 (/ (- LL B) (COS (- FI FI2))))
  89. (SETQ P7 (POLAR P0 FI2 L07))
  90. (SETQ DL 0 CT 0 DC -1)
  91. (MENUCMD "S=IN1")
  92. (SETQ CT (ABS (- (CAR P1) (CAR P7))))
  93. (GRTEXT -1 (STRCAT "╟░╫╢╔ε╢╚< " (RTOS CT 2 2)))
  94. (SETQ DL (GETREAL "\n╟δ╩Σ╚δ╟░╫╢╔ε╢╚: "))
  95. (WHILE (< DC 0)
  96.  (SETQ DL (* DL S))
  97.  (SETQ DC (- DL CT))
  98. (COND ((< DC 0)(SETQ DL (GETREAL "\n╟░╫╢╔ε╢╚╠½╨í, ╟δ╓╪╨┬╩Σ╚δ╟░╫╢╔ε╢╚: "))))
  99. )
  100. (GRTEXT)
  101. (SETQ P8 (POLAR P0 FI (- LL B)))
  102. (SETQ P6 (LIST (+ (CAR BB) DL) (- (CADR P7) (* DL (/ (SIN FI) (COS FI))))))
  103. (COND ((= YY "N") 
  104. (SETQ P6 (LIST (- (CAR BB) DL) (+ (CADR P7) (* DL (/ (SIN FI) (COS FI))))))
  105. ))
  106. (SETQ L0B (* L01 (COS FI1)))
  107. (SETQ L0B1 (+ L0B L))
  108. (SETQ L35X (- L0B1 (* LL (COS FI))))
  109. (SETQ L35Y (/ L35X (/ (SIN FI) (COS FI))))
  110. (SETQ P5 (LIST (+ (CAR P3) L35X) (- (CADR P3) L35Y)))
  111. (COND ((= YY "N") (PROGN
  112. (SETQ L0B (* L01 (COS FI1)))
  113. (SETQ L0B1 (- L0B L))
  114. (SETQ L35X (- L0B1 (* LL (COS FI))))
  115. (SETQ L35Y (/ L35X (/ (SIN FI) (COS FI))))
  116. (SETQ P5 (LIST (+ (CAR P3) L35X) (- (CADR P3) L35Y)))
  117. )))
  118. (SETQ B1 (LIST (CAR P6) (CADR P0)))
  119. (SETQ B2 (LIST (CAR P5) (CADR P0)))
  120. (SETQ B3 (LIST (+ (CAR B2) L0) (CADR P0)))
  121. (COND ((= YY "N")(SETQ B3 (LIST (- (CAR B2) L0) (CADR P0)))))
  122. (SETQ P10 (LIST (CAR P5) (+ (CADR P0) (/ D0 2))))
  123. (SETQ P11 (LIST (CAR B3) (CADR P10)))
  124. (SETQ DL1 D DR1 D0 L1 L SCHL L0 XCHL DL)
  125. (SETQ ANGR Z2 DGR1 B)
  126. (SETQ GPSZ1 "CG" DGCH1 "YY" DIR1 "YN")
  127. (command "layer" "n" "f7" "s" "f7" "l" "dashdot" "" "C" "R" "" "")
  128. (command "line" P0 P3 "")
  129. (COMMAND "LINE" P0 BB "")
  130. (COMMAND "LAYER" "N" "F2" "S" "F2" "L" "HIDDEN" "" "C" "G" "" "")
  131. (SETQ P9 (LIST (CAR P7) (CADR P0)))
  132. (COMMAND "LINE" P1 P6 B1 "")
  133. (command "layer" "s" 0 "l" "" "" "")
  134. (COMMAND "LINE" BB P1 P2 P5 B2 "")
  135. (COMMAND "LINE" P10 P11 B3 "")
  136. (SETQ RT (LIST (CAR B3) (CADR P2)))
  137. (COMMAND "MIRROR" "W" P0 RT "" P0 BB "N" )
  138. (FN)
  139. ;(NZ1)
  140. (SETQ DL1 (/ DL1 S) DR1 (/ DR1 S) L2 (/ L2 S) SCHL (/ SCHL S))
  141. (SETQ XCHL (/ XCHL S) DGL1 (/ DGL1 S) DGR1 (/ DGR1 S))
  142. (SETQ L1 L2)
  143. (SETQ L (* L2 S))
  144. ;(SETQ L1 (+ L1 SCHL))
  145. (SETQ SCHD DGL1 XCHD DGR1 DGL1 0 DGR1 0)
  146. (attdef2)
  147. (ATTDEF1 "SCHD1" SCHD FPT)
  148. (ATTDEF1 "XCHD1" XCHD FPT)
  149. (attdef1 "gpsz1" "CG" fpt)
  150. (ATTDEF1 "DGCH1" YY FPT)
  151. (attdef1 "m1" m fpt)
  152. (attdef1 "bf1" bat fpt)
  153. (attdef1 "alf1" alf fpt)
  154. (attdef1 "z11" z1 fpt)
  155. (attdef1 "dir1" YN FPT)
  156. (command "block" no fpt "w" (list xb (- yb (CADR P2))) (list (+ xb l) (+ yb (CADR P2))) "")
  157. (command "insert" no fpt "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "")
  158. (COND ((= YY "N") (SETQ XB (CAR B1))
  159. (SETQ XB (- XB L))))
  160. (XB1)
  161. (COND ((= YY "Y") (CL)))
  162. (MENUCMD "S=SCREEN")
  163. (MENUCMD "S=IN2")
  164. (SETQ YN (GETSTRING "\n╩╟╖±╝╠╨°╗¡═Γ▒φ├µ: "))
  165. (IF (OR (= YN "Y") (= YN "y") (= YN ""))
  166.  (PROGN(MENUCMD "I=YY")
  167.        (MENUCMD "I=*")
  168.  )
  169.                (MENUCMD "S=SCREEN")
  170. )
  171. )
  172. (CONGEAR)
  173.