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