home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p067 / 2.img / HD / HDD27.LSP < prev    next >
Encoding:
Text File  |  1988-12-10  |  3.6 KB  |  115 lines
  1. (defun hd27 ()
  2.   (setq i (open "data.tat" "r"))
  3.   (read-line i)
  4.   (setq aaa (read (read-line i)))
  5.   (setq p21 (read (read-line i)))
  6.   (setq pg (read (read-line i)))
  7.   (close i)
  8.   (setq pm (car aaa) p (cadr aaa) p1 (nth 2 aaa) ppp (nth 3 aaa))
  9.   (setq n11 (nth 4 aaa) n10 (nth 5 aaa))
  10. ;
  11. ;
  12.  (setq h0 nil h1 nil h2 nil h3 nil)
  13.  (setq p2 (polar p1 0 48) p3 (polar p 0 48))
  14.  (command "line" p1 p2 p3 p "c")
  15.  (setq n1 n10 c1 13 c2 1 c3 1 pt nil n n1 n15 0)
  16.   (setq pt1 nil)
  17.   (setq ppp (reverse ppp))
  18.   (setq j (open "\\house1\\tst\\hd12.tat" "a"))
  19.    (setq p3 (list (car p3) (- (cadr p3) c1)))
  20.    (setq p (list (car p) (- (cadr p) c1)))
  21. ;
  22.   (setq n11 (length p21))
  23.   (setq n13 0)
  24.   (setq n12 0)
  25.   (setq p22 nil)
  26.   (while (< n12 (- n11 1))
  27.          (cond ((= p22 nil) (setq pp (car (nth n12 p21)))))
  28.          (setq p22 (nth n12 p21))
  29.          (if (/= p22 nil) (progn
  30.          (setq pp0 (nth n13 ppp))
  31.          (setq n14 0)
  32.          (while (< n14 (length p22))
  33. ;
  34.          (setq p25 (nth n14 p22))
  35.          (setq pp1 (car pp0))
  36.          (setq pp2 (car (cadr pp0)))
  37.          (setq pp3 (list (car pp1) (- (cadr pp1) (* (- p25 pp) 5))))
  38.          (setq pp4 (list (+ pp2 (* c1 (- n12 n15)))
  39.                    (- (cadr pp1) (* (- p25 pp) 5))))
  40.          (setq p24 (list (car pp4) (cadr p3)))
  41.          (setq p24 (list p25 pp3 pp4 p24))
  42.          (setq n14 (1+ n14))
  43.          (print p24 j)))
  44.          (progn (print nil j) (setq n13 (1+ n13)) (setq n15 (1+ n12))))
  45.          (setq n12 (1+ n12))
  46.   )
  47.   (print "end" j)
  48.  (close j)
  49. ;
  50.  (setq k (open "\\house1\\tst\\hd8.tat" "a") n2 0)
  51.  (while (> n1 0)
  52.    (setq n2 (1+ n2))
  53.   (if (or (= pm "R") (= pm "r")) (progn
  54.    (setq p3 (list (+ (car p3) c1) (cadr p3)))
  55.    (command "pline" (nth (- n1 1) pg) "W" 0.3 0.3 P3 "")
  56.    (setq p23 p3)
  57.   ) (progn
  58.    (setq p (list (- (car p) c1) (cadr p)))
  59.    (command "pline" (nth (- n1 1) pg) "W" 0.3 0.3 P "")
  60.    (setq p23 p)
  61.   ))
  62.    (setq p2 (list (car p23) (- (cadr p23) 5)))
  63.    (setq pw1 (list (car p2) (- (cadr p2) 5)))
  64.    (setq pw2 (list (car p2) (- (cadr p2) 12)))
  65.    (setq pw3 (list (car p2) (- (cadr p2) 16)))
  66.    (command "circle" p2 5)
  67.    (command "pline" pw1 "w" 0 0 pw2 "w" 1.5 0 pw3 "")
  68.    (setq h0 nil h1 nil h2 nil h3 nil)
  69.    (menucmd "s=hd126")
  70.    (setq a1 (getstring 1
  71.    (strcat "\n╩Σ╚δ░▓╫░╡Ñ╬╗║═╡┌< " (itoa n2) " >╕∙╡τ└┬╡─▒α║┼:")))
  72.    (menucmd "s=hd127")
  73.    (setq a2 (getstring 1 "\n╩Σ╚δ╡τ└┬╨═║┼╣µ╕±:"))
  74.    (menucmd "s=screen")
  75.    (setq a3 (getstring 1 "\n╩Σ╚δ╡τ└┬╞≡╡π▒α║┼:"))
  76.    (setq a4 (getstring 1 "\n╩Σ╚δ╡τ└┐╓╒╡π▒α║┼:"))
  77.    (menucmd "s=hd36")
  78.    (setq a5 (getstring 1 "\n╩Σ╚δ╡τ└┐│ñ╢╚:"))
  79.    (setq pt (list a1 a2 a3 a4 a5))
  80.    (print pt k)
  81.    (command "text" "m" p2 3 0 a1)
  82.    (setq n1 (- n1 1) c3 (1+ c3))
  83.  )
  84.  (close k)
  85.  (menucmd "s=hd128")
  86.  (setq b (getstring "\n╨Φ╥¬╔·│╔╡τ└┐▒φ┬≡?<Y/N>: "))
  87.  (if (or (= b "Y") (= b "y")) (progn
  88.      (setq l (open "\\house1\\tst\\hd8.tat" "r"))
  89.      (hh)
  90.      (close l)))
  91. )
  92. (defun hh ()
  93.  (menucmd "s=screen")
  94.  (setq p (getpoint "\n╩Σ╚δ╡τ└┐▒φ╡─▓σ╚δ╡π:"))
  95.  (setq e1 0 p1 p pt 0 p (polar p (/ (* pi 3) 2) 18))
  96.  (command "insert" "jxx28" p1 1 1 0)
  97.  (read-line l)
  98.  (setq pt (read-line l))
  99.  (while (/= pt nil)
  100.    (setq pt (read pt))
  101.    (setq e1 (1+ e1))
  102.    (setq n 0 a1 0)
  103.    (setq a1 (nth 0 pt))
  104.     (if (/= a1 nil) (progn
  105.      (setq a2 (nth 1 pt) a3 (nth 2 pt) a4 (nth 3 pt) a5 (nth 4 pt))
  106.      (command "insert" "jxx29" p 1 1 0 a5 a4 a3 a2 a1 e1)
  107.      (setq p (polar p (/ (* pi 3) 2) 8) n (+ n 5))
  108.     ))
  109.   (setq pt (read-line l))
  110.  )
  111.  (setq p2 (polar p 0 200) p3 (list (car p2) (cadr p1)))
  112.  (command "pline" p "w" 0.3 0.3 p1 p3 p2 "c")
  113. )
  114. (hd27)
  115.