home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p190 / 3.ddi / LSP / HM04.LSP < prev    next >
Encoding:
Text File  |  1991-04-08  |  4.4 KB  |  129 lines
  1. (defun input (sl m)
  2. ;(SETVAR "CMDECHO" 0)
  3.   (MENUCMD "S=IN1")
  4.  (initget (+ 1 2 4))
  5. (setq l (getreal "\n╩Σ ╚δ │ñ ╢╚=: "))
  6.   (if (= sl 1)(setq l (rtos l)))
  7.   (if (= l "t")(setq l "T"))
  8.   (if (and (= sl 1) (/= l "T"))(setq l (atof l)))
  9.   (if (= l "T")(setq l (- m xb) l (/ l s)))
  10.   (if (= l "t")(setq l (- m xb) l (/ l s)))
  11.   (setq schl 0 xchl 0)
  12.   (MENUCMD "S=IN2")
  13.   (setq yn (getstring "\n╙╨ ╣½ ▓ε ╖±(N)? "))
  14.                                  (MENUCMD "S=IN1")
  15.   (if (= yn "")(setq yn "n" schl 0 xchl 0))
  16.   (if (or (= yn "y") (= yn "Y"))(progn
  17.                                  (setq schl (getreal "\n╔╧ ╞½ ▓ε=: "))
  18.                                  (setq xchl (getreal "\n╧┬ ╞½ ▓ε=: "))
  19.                                  )
  20.   )
  21.   (setq angl 0 angr 0)
  22.   (setq dgl (getreal "\n╫≤ ╡╣ ╜╟ │ñ ╢╚=:(0) "))
  23.   (if (null dgl)(setq dgl 0))
  24.   (if (> dgl 0)(setq angl (getreal "\n╫≤ ╡╣ ╜╟=: ")))
  25.   (if (= dgl 0)(progn
  26.   (setq dgl (getreal "\n╫≤ ╡╣ ╘▓ ┴┐=:(0) "))
  27.   (if (null dgl)(setq dgl 0))
  28.   (if (/= dgl 0)(setq dgl (- 0 dgl)))
  29. ))
  30.   (setq dgr (getreal "\n╙╥ ╡╣ ╜╟ │ñ ╢╚=:(0) "))
  31.   (if (null dgr)(setq dgr 0))
  32.   (if (> dgr 0)(setq angr (getreal "\n╙╥ ╡╣ ╜╟=: ")))
  33.   (if (= dgr 0)(progn
  34.   (setq dgr (getreal "\n╙╥ ╡╣ ╘▓ ┴┐=:(0) "))
  35.   (if (null dgr)(setq dgr 0))
  36.   (if (/= dgr 0)(setq dgr (- 0 dgr)))
  37. ))
  38. (setq yn "")
  39.     (MENUCMD "S=SCREEN")
  40. )
  41. ;**************************************
  42. ;*  The fuction for drwing thread.   *
  43. ;*************************************
  44. (defun screw (sl m)
  45. ;(SETVAR "CMDECHO" 0)
  46.   (setq dgch " ")
  47.   (setq da 0 )
  48.   (MENUCMD "S=TH1")
  49.   (initget 1 "m M t T p P")
  50.   (setq sc (getkword "\n╤í ╘± ┬▌ ╬╞ └α ╨═(M ; T ; P): "))
  51.   (if (null sc )(setq sc "M"))
  52.   (if (= sc "m")(setq sc "M"))
  53.   (if (= sc "t")(setq sc "T"))
  54.   (if (or (= sc "p")(= sc "P"))(setq sc "PI"))
  55.   (if (= sc "M")(PROGN
  56.                 (MENUCMD "S=TH2")
  57.           (initget (+ 1 2 4))
  58.                 (setq m1 (getreal "\n╩Σ ╚δ ╓▒ ╛╢=: "))
  59.   ))
  60.   (if (= sc "T")
  61.    (PROGN
  62.    (MENUCMD "S=TH3")
  63.   (initget (+ 1 2 4))
  64.    (setq m1 (getreal "\n╩Σ ╚δ ╓▒ ╛╢=: "))
  65. ;  (SETQ TT (GETREAL "\n╩Σ╚δ┬▌╛α: "))
  66.   ))
  67.   (if (= sc "PI")(progn
  68.                 (MENUCMD "S=TH4")
  69.                   (initget (+ 1 2 4))
  70.                 (setq dgch (getstring "\n╩Σ ╚δ ╓▒ ╛╢=: "))
  71.                 (if (= (strlen dgch) 4)(setq mm (substr dgch 1 1) mm1 (substr dgch 2)))
  72.                 (if (= (strlen dgch) 4)(setq dgch (strcat mm " " mm1)))
  73.                 (setq mm (substr dgch 1 1) mm1 (substr dgch 5))
  74.                 (if (and (< (atof mm1) 1) (< (atof mm) 1))(setq m1 25))
  75.                 (if (and (< (atof mm1) 1) (= (atof mm) 1))(setq m1 33))
  76.                 (if (and (> (atof mm1) 1) (= (atof mm) 1))(setq m1 42))
  77.                 (if (and (< (atof mm1) 1) (= (atof mm) 2))(setq m1 60))
  78.                 (if (and (> (atof mm1) 1) (= (atof mm) 2))(setq m1 75))
  79.                 (if (and (< (atof mm1) 1) (= (atof mm) 3))(setq m1 87))
  80.                 (if (and (> (atof mm1) 1) (= (atof mm) 3))(setq m1 100))
  81.                 (if (and (< (atof mm1) 1) (= (atof mm) 4))(setq m1 113))
  82.                 (if (and (< (atof mm1) 1) (= (atof mm) 5))(setq m1 138))
  83.   ))
  84.   (input sl m)
  85.   (setq dr1 m1 dl1 m1)
  86.   (setq l1 l dgl1 dgl dgr1 dgr)
  87.   (if (< dgl 0)(setq dgl 0))
  88.   (if (< dgr 0)(setq dgr 0))
  89.   (setq l (* l s) dgl (* dgl s) dgr (* dgr s))
  90.   (setq dr (/ (* m1 s) 2) dl dr)
  91.   (setq kd (/ (* (- m1 4) s) 2))
  92.   (dbsa1 xb sl)
  93.   (setq tof (list (+ xb dgl) (+ yb kd)))
  94.   (setq toe (list (- (+ xb l) dgr) (+ yb kd)))
  95.   (setq bof (list (+ xb dgl) (- yb kd)))
  96.   (setq boe (list (- (+ xb l) dgr) (- yb kd)))
  97.   (command "line" tof toe "")
  98.   (command "line" bof boe "")
  99.   (setq fpt (list xb yb))
  100.   (attdef2)
  101.   (attdef1 "gpsz1" sc fpt)
  102.   (attdef1 "dgch1" dgch fpt)
  103. )
  104. ;******************************************
  105. ;*   The function for drawing thread.     *
  106. ;******************************************
  107. (DEFUN THREAD ()
  108. (SETVAR "CMDECHO" 0)
  109. (SETVAR "BLIPMODE" 0)
  110. (screw 0 0)
  111. (FN)
  112.  (if (= nol no)
  113. (command "block" no "Y" fpt "w" (list xb (- yb dr)) (list (+ xb l) (+ yb dr)) "")
  114. (command "block" no fpt "w" (list xb (- yb dr)) (list (+ xb l) (+ yb dr)) "")
  115.   )
  116. (command "insert" no fpt "" "" "" "" "" "" "" "" "" "" "" "" "" "")
  117. (XB1)
  118. (redraw)
  119. (MENUCMD "S=IN2")
  120. (SETQ YN (GETSTRING "\n╩╟╖±╝╠╨°╗¡═Γ▒φ├µ: "))
  121. (IF (OR (= YN "Y") (= YN "y") (= YN ""))
  122.  (PROGN(MENUCMD "I=YY")
  123.        (MENUCMD "I=*")
  124.  )
  125.                (MENUCMD "S=SCREEN")
  126. )
  127. )
  128. (THREAD)
  129.