距离最大点对.lsp

计算几何中的几种lisp语言的算法

(defun C:Maxd ()
  ;;定义错误函数和预处理--------------------
  (setvar "errno" 0)
  (setq olderr *error*)
  (defun *error* (msg)
    (setq en (getvar "errno"))
    (setq errmsg (strcat "errno=" (itoa en) "\nError:" msg))
    (alert errmsg)
    (setq *error* olderr)
  )
  (graphscr)
  (setq oldmode (getvar "osmode"))
  (setq oce (getvar "cmdecho"))
  (setvar "cmdecho" 0)
  ;;****************************************
  ;;程序主段********************************
  (setq m (fix (getint "\n请输入点数目:")))
  (if (< m 3)
    (progn
      (alert "你输入的点的数目太小，请重新输入!")
      (setvar "osmode" oldmode)
      (setvar "cmdecho" oce)
      (princ)
    )
    (progn
      (setq m (1- m))
      ;;定义0-N的有序整数集函数-------------
      (defun listn (a / n x)
	(setq n 1)
	(setq x (list 0))
	(while (<= n a)
	  (setq x (append (list n) x))
	  (setq n (1+ n))
	)
	(reverse x)
      )
      (setq x (listn m))
      ;;取得点集----------------------------
      (setq x (mapcar '(lambda (x) (getpoint "\n输入点: ")) x))
      ;;画点--------------------------------
      (setq pdm (getvar "pdmode"))
      (setq pds (getvar "pdsize"))
      ;;(setvar "pdmode" 32)
      ;;(setvar "pdsize" 0)
      ;;(mapcar '(lambda (x) (command ".circle" x 1)) x)
      (mapcar '(lambda (x) (command ".point" x)) x)
      ;;定义任意两点之间的距离及其序列号函数
      (defun mnp (m n x)
	(list (list (distance (nth m x) (nth n x)) (list m n)))
      )
      ;;定义点集中所有的点的距离的集合的函数
      (defun xxx (i m x / y j)
	(setq j 1)
	(setq y nil)
	(while (<= j (- m i))
	  (setq y (append (mnp i (+ i j) x) y))
	  (setq j (1+ j))
	)
	y
      )
      (setq i 0)
      (setq y nil)
      (while (<= i (1- m))
	(setq y (append (xxx i m x) y))
	(setq i (1+ i))
      )
      ;;求其距离最大值并返回顶点序列--------
      (setq pmax (vl-sort-i y (function (lambda (e1 e2) (> (car e1) (car e2))))))
      (setq pmax (car pmax))
      (setq pp (cadr (nth pmax y)))
      (setq pt1 (nth (car pp) x))
      (setq pt2 (nth (cadr pp) x))
      ;;用红色线条画出该线段----------------
      (command ".line" pt1 pt2 "")
      (setq e1 (entlast))
      (setq elist (entget e1))
      (if (= nil (assoc 62 elist))
	(setq elist (cons (cons 62 1) elist))
	(setq elist (subst (cons 62 1) (assoc 62 elist) elist))
      )
      (entmod elist)
      (setvar "osmode" oldmode)
      ;;(setvar "pdmode" pdm)
      ;;(setvar "pdsize" pds)
      (setvar "cmdecho" oce)
      (princ)
      (list pt1 pt2)
    )
  )
)