home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p190 / 3.ddi / LSP / HM26.LSP < prev    next >
Encoding:
Text File  |  1990-03-09  |  3.1 KB  |  77 lines
  1. ;***********************************
  2. ;* The program for drawing ring.   *
  3. ;***********************************
  4. (DEFUN RING ()
  5. (SETVAR "CMDECHO" 0)
  6. (SETVAR "BLIPMODE" 0)
  7. (setq schl 0 xchl 0 dgr1 0 angr 0 dgch " " schd 0 xchd 0 lk 1)
  8. (MENUCMD "S=RI1")
  9. (setq lk (getreal "\n╤í ╘± ╗╖ ▓█ └α ╨═(0:├▄╖Γ▓█ 1:╥╗░π▓█):(1) "))
  10. (if (null lk)(setq lk 1))
  11. (setq fpt (getpoint "\n╙├ ╩« ╫╓ ╧▀ ╢¿ ╗╖ ▓█ ╞≡ ╩╝ ├µ:"))
  12. (MENUCMD "S=IN1")
  13. (setq dr1 (getreal "\n╩Σ ╚δ ╗╖ ▓█ ─┌ ▓α ╓▒ ╛╢=: "))
  14. (MENUCMD "S=IN2")
  15. (setq lr (getstring "\n╙╨ ╖± ┼Σ ║╧ ╣½ ▓ε(N)? "))
  16. (MENUCMD "S=IN1")
  17. (if (or (= lr "y") (= lr "Y"))(progn
  18.                               (setq schd (getreal "\n╔╧ ╞½ ▓ε=: "))
  19.                               (setq xchd (getreal "\n╧┬ ╞½ ▓ε=: "))
  20. ))
  21. (if (= lk 0)(progn
  22. (setq b1 (getreal "\n╩Σ ╚δ ╗╖ ▓█ ┐φ=: "))
  23. (setq lr " ")
  24. (MENUCMD "S=IN2")
  25. (setq lr (getstring "\n▓█ ┐φ ╙╨ ╬▐ ╣½ ▓ε(N)? "))
  26. (MENUCMD "S=IN1")
  27. (if (or (= lr "y") (= lr "Y"))(progn
  28.                               (setq angr (getreal "\n╔╧ ╞½ ▓ε=: "))
  29.                               (setq dgr1 (getreal "\n╧┬ ╞½ ▓ε=: "))
  30. ))
  31. ))
  32. (if (= lk 1)(setq dl (getreal "\n╩Σ ╚δ ═Γ ▓α ╓▒ ╛╢=: ") b1 (/ (- dl dr1) 2)))
  33. (setq h1 (getreal "\n╩Σ ╚δ ╗╖ ▓█ ╔ε=:  (╚⌠╗∙├µ╘┌╙╥,╩Σ╕║╓╡) "))
  34. (setq lr "n")
  35. (MENUCMD "S=IN2")
  36. (setq lr (getstring "\n╔ε ╙╨ ╬▐ ╣½ ▓ε(N)? "))
  37. (MENUCMD "S=IN1")
  38. (if (or (= lr "y") (= lr "Y"))(progn
  39.                               (setq schl (getreal "\n╔╧ ╞½ ▓ε=: "))
  40.                               (setq xchl (getreal "\n╧┬ ╞½ ▓ε=: "))
  41. ))
  42. (setq xg (car fpt))
  43. (setq dr (* (/ dr1 2) s) h (* h1 s) dl (+ dr (* b1 s)))
  44. (setq dgl1 (getreal "\n╩Σ ╚δ ╡╣ ╜╟ │ñ ╢╚=(0): "))
  45. (if (null dgl1)(setq dgl1 0))
  46. (if (/= dgl1 0)(setq angl (getreal "\n╩Σ ╚δ ╡╣ ╜╟ ╜╟ ╢╚=: ")))
  47. (setq tg (/ (sin (* (/ 3.1416 180) angl)) (cos (* (/ 3.1416 180) angl))))
  48. (setq dgl (* dgl1 s) atl (* dgl tg))
  49. (setq topl (list xg (+ yb dl atl)) botl (list xg (- (+ yb dr) atl)))
  50. (if (> h 0)(setq tof (list (+ xg dgl) (+ yb dl)) bof (list (+ xg dgl) (+ yb dr))))
  51. (if (< h 0)(setq tof (list (- xg dgl) (+ yb dl)) bof (list (- xg dgl) (+ yb dr))))
  52. (setq toe (list (+ xg h) (+ yb dl)) boe (list (+ xg h) (+ yb dr)))
  53. (setq topr (list (+ xg h) (- yb dr)))
  54. (command "layer" "n" "f9" "s" "f9" "l" "hidden" "" "color" "2" "" "")
  55. (command "line" botl bof tof topl tof toe boe bof boe topr "")
  56. (setq topl (list xg (+ (- yb dr) atl)) botl (list xg (- yb dl atl)))
  57. (if (> h 0)(setq tof (list (+ xg dgl) (- yb dr)) bof (list (+ xg dgl) (- yb dl))))
  58. (if (< h 0)(setq tof (list (- xg dgl) (- yb dr)) bof (list (- xg dgl) (- yb dl))))
  59. (setq boe (list (+ xg h) (- yb dl)))
  60. (command "line" topr boe bof botl bof tof topl tof topr "")
  61. (setq fpt (list xg yb) no (+ no 1) lx (- xg xf) lx (/ lx s))
  62. (if (< h 0)(setq fpt (list (+ xg h) yb)))
  63. (setq dl1 (+ dr1 (* 2 b1)) l1 h1 dgr dgr1)
  64. (attdef2)
  65. (attdef1 "schd1" schd fpt)
  66. (attdef1 "xchd1" xchd fpt)
  67. (attdef1 "ll1" lx fpt)
  68. (attdef1 "lk1" lk fpt)
  69. (attdef1 "gpsz1" "R" fpt)
  70. (setq toe (list (+ xg h) (+ yb dl)))
  71. (command "block" no fpt "w" botl toe "")
  72. (command "insert" no fpt "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "")
  73. ;(redraw)
  74. (MENUCMD "S=SCREEN")
  75. )
  76. (RING)
  77.