home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p067 / 1.img / HY / HY25.LSP < prev    next >
Encoding:
Text File  |  1988-01-04  |  1.1 KB  |  36 lines
  1. (DEFUN HJ01 ()
  2. (setvar "cmdecho" 0)
  3. (setq pt1 (osnap (getpoint "╩Σ╚δ╡┌╥╗╠⌡╧▀╡─╗∙╡π: ") "nea"))
  4. (setq pt2 (osnap (getpoint "╩Σ╚δ╡┌╥╗╠⌡╧▀╡─╜ß╩°╡π: ") "nea"))
  5. (setq pt3 (osnap (getpoint "╩Σ╚δ╡┌╢■╠⌡╧▀╡─╗∙╡π: ") "nea"))
  6. (setq pt4 (osnap (getpoint "╩Σ╚δ╡┌╢■╠⌡╧▀╡─╜ß╩°╡π: ") "nea"))
  7. (setq c1 (/ (- (cadr pt2) (cadr pt1)) (- (CAR Pt2) (CAR PT1))))
  8. (setq c2 (/ (- (cadr pt4) (cadr pt3)) (- (CAR PT4) (CAR PT3))))
  9. (setq c4 (- (car pt2) (car pt1))) (setq c5 (- (car pt4) (car pt3)))
  10. (setq c (- c1 c2))
  11. (setq c3 (* c1 c2))
  12. (setq m (* c1 (car pt1)))
  13. (setq m1 (* c2 (car pt3)))
  14. (setq n (* c1 (cadr pt3)))
  15. (setq n1 (* c2 (cadr pt1)))
  16. (setq n4 (+ n (* c3 (- (car pt1) (car pt3)))))
  17. (setq x (/ (+ (cadr pt3) (- (- m m1) (cadr pt1))) c))
  18. (setq y (/ (- n4 n1) c))
  19. (setq pt (list x y))
  20. (if (= c4 0)
  21.     (progn (setq x (car pt1))
  22.            (setq y (+ (cadr pt3) (* c2 (- x (car pt3)))))
  23.            (setq pt (list x y))
  24.     )
  25. )
  26. (if (= c5 0)
  27.     (progn (setq x (car pt3))
  28.            (setq y (+ (cadr pt1) (* c1 (- x (car pt1)))))
  29.            (setq pt (list x y))
  30.     )
  31. )
  32. (setq c nil c1 nil c2 nil c3 nil x nil y nil c4 nil)
  33. (command "point" pt)
  34. )
  35. (hj01)
  36.