home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p190 / 4.ddi / LSP2 / HM33.LSP < prev    next >
Encoding:
Text File  |  1990-03-10  |  4.0 KB  |  119 lines
  1. (defun ZGK()
  2. (SETVAR "CMDECHO" 0)
  3. (setvar "blipmode" 0)
  4. (setq fpt1 (getpoint "\n╟δ╩Σ╚δ╗∙╡π: "))
  5. (WHILE(/= FPT1 NIL)
  6.  (MENUCMD "S=ZK1")
  7.  (INITGET "Y N")
  8.  (SETQ YN (GETKWORD "\n╟δ╩Σ╚δ▒Ω╫ó╫°▒Ω╧╡: "))
  9.  (COND ((= YN "")(SETQ YN "Y")))
  10.  (MENUCMD "S=IN1")
  11.  (IF (= YN "Y")
  12.   (PROGN
  13.   (SETQ XPT (GETREAL "\n╟δ╩Σ╚δ▓σ╚δ╡π╛α╗∙╡π╡─╦«╞╜╛α└δ(0): "))
  14.   (COND ((= XPT NIL)(SETQ XPT 0)))
  15.   (SETQ YPT (GETREAL "\n╟δ╩Σ╚δ▓σ╚δ╡π╛α╗∙╡π╡─┤╣╓▒╛α└δ(0): "))
  16.   (COND ((= YPT NIL)(SETQ YPT 0)))
  17.   (SETQ XPT (* XPT S) YPT (* YPT S))
  18.   (SETQ FPT (LIST (+ (CAR FPT1) XPT) (+ (CADR FPT1) YPT)))
  19.   )
  20.   (PROGN
  21.   (SETQ RW (GETREAL "\n╟δ╩Σ╚δ▓σ╚δ╡π╛α╗∙╡π╡─╛α└δ(0): "))
  22.   (COND ((= RW NIL)(SETQ RW 0)))
  23.   (SETQ RW (* RW S))
  24.   (SETQ FPT (LIST (CAR FPT1) (+ (CADR FPT1) RW)))
  25.  ))
  26.  (setq d (getdist "\n╟δ╩Σ╚δ┐╫╡─╓▒╛╢:"))
  27.  (SETQ H (GETREAL "\n╟δ╩Σ╚δ╣Γ┐╫╡─╔ε╢╚: "))
  28.  (SETQ N1 (GETINT "\n╟δ╩Σ╚δ╧α═¼╓▒╛╢╣Γ┐╫╡─╕÷╩²: "))
  29.  (setq d (* d s))
  30.  (setq r (/ d 2)) 
  31.  (SETQ N 1)
  32.  (COND ((= YN "N")
  33.   (setq xc (car fpt) yc (cadr fpt))
  34.   (setq pa (list (- xc r 4) yc))
  35.   (setq pb (list (+ xc r 4) yc))
  36.   (setq pc (list xc (+ yc r 4)))
  37.   (setq pd (list xc (- yc r 4)))
  38.   (SETQ LB (LIST (CAR PA) (CADR PD)))
  39.   (SETQ RT (LIST (CAR PB) (CADR PC)))
  40.   (command "layer" "s" "1" "")
  41.   (command "line" pa pb "")
  42.   (command "line" pc pd "")
  43.   (COND ((/= YN "Y")(COMMAND "CIRCLE" FPT1 RW)))
  44.   (command "layer" "s" "0" "")
  45.   (command "circle" fpt "d" (+ d 0.3))
  46.   (command "circle" fpt "d" d)
  47.   (command "circle" fpt "d" (- d 0.3))
  48.  ))
  49.  (WHILE (AND (<= N N1) (= YN "Y"))
  50.   (setq xc (car fpt) yc (cadr fpt))
  51.   (setq pa (list (- xc r 4) yc))
  52.   (setq pb (list (+ xc r 4) yc))
  53.   (setq pc (list xc (+ yc r 4)))
  54.   (setq pd (list xc (- yc r 4)))
  55.   (SETQ LB (LIST (CAR PA) (CADR PD)))
  56.   (SETQ RT (LIST (CAR PB) (CADR PC)))
  57.   (command "layer" "s" "1" "")
  58.   (command "line" pa pb "")
  59.   (command "line" pc pd "")
  60.   (COND ((/= YN "Y")(COMMAND "CIRCLE" FPT1 RW)))
  61.   (command "layer" "s" "0" "")
  62.   (command "circle" fpt "d" (+ d 0.3))
  63.   (command "circle" fpt "d" d)
  64.   (command "circle" fpt "d" (- d 0.3))
  65.   (COND ((AND (= YPT 0) (/= N 1))
  66.     (SETQ PTBJ (GETPOINT "\n╟δ╩Σ╚δ╦«╞╜│▀┤τ╧▀╡─╬╗╓├: "))
  67.     (SETQ LX (RTOS (ABS (/ XPT S)) 2 0))
  68.     (COMMAND "DIM" "DIMTXT" 0.2 "HOR" PTS FPT2 PTBJ LX "EXIT")
  69.   ))
  70.   (COND ((AND (= XPT 0) (/= N 1))
  71.     (SETQ PTBJ (GETPOINT "\n╟δ╩Σ╚δ┤╣╓▒│▀┤τ╧▀╡─╬╗╓├: "))
  72.     (SETQ LY (RTOS (ABS (/ YPT S)) 2 0))
  73.     (COMMAND "DIM" "DIMTXT" 0.2 "VER" PTS FPT2 PTBJ LY "EXIT")
  74.   ))
  75.   (COND ((/= N N1)
  76.    (SETQ XPT (GETREAL "\n╟δ╩Σ╚δ╧┬╥╗╕÷▓σ╚δ╡π╡─╦«╞╜╛α└δ(0): "))
  77.    (COND ((= XPT NIL)(SETQ XPT 0)))
  78.    (SETQ YPT (GETREAL "\n╟δ╩Σ╚δ╧┬╥╗╕÷▓σ╚δ╡π╡─┤╣╓▒╛α└δ(0): "))
  79.    (COND ((= YPT NIL)(SETQ YPT 0)))
  80.    (SETQ XPT (* XPT S) YPT (* YPT S))
  81.    (SETQ FPT2 (LIST (+ (CAR FPT) XPT) (+ (CADR FPT) YPT)))
  82.    (SETQ PTS FPT)
  83.    (SETQ FPT FPT2)
  84.   ))
  85.   (SETQ N (+ N 1))
  86.  )
  87.  (COND ((/= YN "Y")(COMMAND "ARRAY" "W" LB RT "" "P" FPT1 N1 360 "")))
  88.  (SETQ PT1 (GETPOINT "\n╟δ╩Σ╚δ▒Ω╫ó╧▀╡─╞≡╡π: "))
  89.  (SETQ GMA (ATAN (- (CADR PT1) (CADR FPT)) (- (CAR PT1) (CAR FPT))))
  90.  (SETQ PT2 (POLAR FPT (+ PI GMA) D))
  91.  (COMMAND "LINE" PT1 PT2 "")
  92.  (SETQ PR1 (POLAR FPT GMA R) PR2 (POLAR FPT (+ PI GMA) R))
  93.  (SETQ GMA1 (* (/ GMA PI) 180))
  94.  (COMMAND "INSERT" "DWG/ZITO" PR1 "" "" GMA1)
  95.  (COMMAND "INSERT" "DWG/ZITO" PR2 "" "" (+ GMA1 180))
  96. (COMMAND "STYLE" "HZ" "" "" "" "" "" "")
  97.  (SETQ BJ (STRCAT "%%U"  (ITOA N1) "-" "%%C"  (RTOS (/ D S) 2 0) "╔ε" (RTOS H 2 0)))
  98.  (SETQ PT0 (LIST (CAR PT1) (+ (CADR PT1) 1)))
  99.  (COMMAND "TEXT" PT0 7 0 BJ)
  100.  (COND ((/= YN "Y")
  101.   (SETQ PT0 (LIST (CAR PT1) (- (CADR PT1) 8)))
  102.   (COMMAND "TEXT" PT0 7 0 "╛∙▓╝")
  103.   (COMMAND "STYLE" "STANDARD" "" "" "" "" "" "" "")
  104.   (COMMAND "OSNAP" "NEAREST")
  105.   (SETQ PTW (GETPOINT "\n╟δ╩Σ╚δ┐╫╢¿╬╗╧▀╡─╬╗╓├: "))
  106.   (SETQ DW (* RW 2))
  107.   (SETQ DW (RTOS (/ DW S) 2 0))
  108.   (SETQ BZ (STRCAT "%%C" DW))
  109.   (COMMAND "DIM" "DIMTXT" 0.2 "DIA" PTW BZ "EXIT")
  110.   (COMMAND "OSNAP" "NONE")
  111.  ))
  112.  (COMMAND "STYLE" "STANDARD" "" "" "" "" "" "" "")
  113.  (SETQ  FPT1 (GETPOINT "\n╟δ╩Σ╚δ╧┬╥╗╕÷═¿┐╫╡─╗∙╡π, ╗≥╗╪│╡╜ß╩°: "))
  114. )
  115.  (redraw)
  116.  (MENUCMD "S=SCREEN")
  117. )
  118. (ZGK)
  119.