萤火虫算法

aimisiyou

不知萤火虫算法是否比遗传算法、蚁群算法收敛更快些？

aimisiyou

;;;编码转路径
(defun BL(lst)
   (mapcar '(lambda (x) (vl-position x (vl-sort (vl-sort-i lst '<) '<))) (vl-sort-i lst '<) )
)
;;;路径转编码
(defun LB(lst)
   (mapcar '(lambda (x) (vl-position x lst)) (vl-sort lst '<))
)
;;;个体间差异度
(defun cy(ea eb)
  (setq nt (length ea))
  (if (= 0 (rem nt 2))
      (progn
         (setq m (* (/ nt 2) (- nt 1)))
         (setq va (/ (apply '+ (mapcar '(lambda (x y) (abs (- x y))) ea eb)) 1.0 m))
      )
      (progn
         (setq m (/ (* (+ nt 1) (- nt 1)) 2))
         (setq va (/ (apply '+ (mapcar '(lambda (x y) (abs (- x y))) ea eb)) 1.0 m))
      )
  )
)

sicky111

学习一下。

aimisiyou

(defun rnd ()
  (*(rem (getvar "cputicks") 1e4) 1e-4)
)
(defun ff (n)
    (setq lst '((0 5 1)(5 10 0)) vlst nil)
    (repeat n
        (setq num (fix (rem (getvar "CPUTICKS") 11)))
        (setq vlst (cons (car (vl-remove nil (mapcar '(lambda (x) (if (<= (car x) num (cadr x)) (last x) nil)) lst))) vlst))
    )
)
(defun dfun (e1 e2)
(apply '+ (mapcar '(lambda (x y) (boole 6 x y)) e1 e2))
)
(defun move (e1 e2)
(setq dis (dfun e1 e2) k (/ (fit e1) 1.0 (fit e2)) p2 0.95)
(mapcar '(lambda (x y) (if (< (setq p (rnd)) (+ (* k 0.4) (/ 1.0 (+ 2.0 dis)))) y (if (< (+ (* k 0.4) (/ 1.0 (+ 2.0 dis))) p p2) x  (boole 7 y (fix (+ 0.5 (rnd))))))) e1 e2)
)

(defun fit (e)
  (apply '+ e)
)
(setq n 600 M 30  plst nil)
(repeat M
  (setq plst (cons (ff n) plst))
)
(setq pest (cdr (car (vl-sort (mapcar '(lambda (x) (cons (fit x) x)) plst)  '(lambda (e1 e2) (> (car e1) (car e2)))))))
(repeat 100
(progn
  (setq plst (mapcar '(lambda (x) (move x pest)) plst))
  (setq pest_new (cdr (car (vl-sort (mapcar '(lambda (x) (cons (fit x) x)) plst)  '(lambda (e1 e2) (> (car e1) (car e2)))))))
  (if (> (fit pest_new) (fit pest)) (setq pest pest_new) (setq pest pest))
  )
)
(fit pest)
600
_$ pest
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)
_$

确实收敛很快，而且收敛到全局最优解。
为了便于查看过程，将n设定为20
_$
(defun rnd ()
  (*(rem (getvar "cputicks") 1e4) 1e-4)
)
(defun ff (n)
    (setq lst '((0 5 1)(5 10 0)) vlst nil)
    (repeat n
        (setq num (fix (rem (getvar "CPUTICKS") 11)))
        (setq vlst (cons (car (vl-remove nil (mapcar '(lambda (x) (if (<= (car x) num (cadr x)) (last x) nil)) lst))) vlst))
    )
)
(defun dfun (e1 e2)
(apply '+ (mapcar '(lambda (x y) (boole 6 x y)) e1 e2))
)
(defun move (e1 e2)
(setq dis (dfun e1 e2) k (/ (fit e1) 1.0 (fit e2)) p2 0.95)
(mapcar '(lambda (x y) (if (< (setq p (rnd)) (+ (* k 0.4) (/ 1.0 (+ 2.0 dis)))) y (if (< (+ (* k 0.4) (/ 1.0 (+ 2.0 dis))) p p2) x  (boole 7 y (fix (+ 0.5 (rnd))))))) e1 e2)
)

(defun fit (e)
  (apply '+ e)
)
(setq n 20 M 30  plst nil)
(repeat M
  (setq plst (cons (ff n) plst))
)
(setq pest (cdr (car (vl-sort (mapcar '(lambda (x) (cons (fit x) x)) plst)  '(lambda (e1 e2) (> (car e1) (car e2)))))))
(repeat 10
(progn
  (setq plst (mapcar '(lambda (x) (move x pest)) plst))
  (setq pest_new (cdr (car (vl-sort (mapcar '(lambda (x) (cons (fit x) x)) plst)  '(lambda (e1 e2) (> (car e1) (car e2)))))))
  (if (> (fit pest_new) (fit pest)) (setq pest pest_new) (setq pest pest))
  )
)
(fit pest)
RND
FF
DFUN
MOVE
FIT
nil
((1 0 1 1 1 0 0 1 1 0 0 0 1 0 1 1 1 0 1 1) (1 0 1 0 1 0 0 0 0 1 1 1 1 1 1 1 0 1 1 0) (0 1 1 1 1 0 1 1 0 0 1 1 0 1 1 0 1 1 0 1) (1 0 0 0 1 0 1 0 1 1 1 1 0 0 0 1 0 0 1 0) (0 0 0 0 1 1 1 0 1 0 1 0 0 0 0 0 0 0 0 1) (1 1 0 0 1 1 1 0 0 0 0 1 0 0 0 1 1 0 0 1) (0 1 0 1 1 1 0 1 1 0 0 1 0 1 1 1 1 1 1 0) (1 1 1 0 1 0 0 1 0 1 1 1 0 1 1 1 0 1 1 1) (1 0 0 0 1 0 1 1 0 0 1 0 0 0 0 1 0 1 1 0) (0 0 1 1 0 1 1 1 1 1 1 1 0 1 0 1 1 1 1 0) (1 0 1 1 1 1 1 0 0 0 0 0 0 0 0 1 0 0 0 1) (0 1 0 0 1 0 0 0 0 1 1 0 1 1 1 0 0 0 0 0) (0 0 1 0 1 0 1 1 1 1 1 0 1 1 0 1 0 0 1 0) (0 0 1 1 0 0 1 1 1 1 0 1 1 0 0 0 0 0 1 1) (1 0 0 1 0 1 1 0 1 1 1 1 0 0 0 1 1 0 1 1) (1 1 1 0 0 1 0 1 1 0 0 1 1 1 1 0 1 0 1 0) (1 1 1 1 1 0 1 1 0 1 0 1 1 0 1 1 0 0 0 0) (1 1 1 0 1 0 0 0 0 0 0 1 1 1 1 1 0 1 1 1) (0 1 0 1 0 1 0 1 0 1 0 1 1 1 1 0 0 0 0 1) (1 1 0 1 1 0 0 0 0 0 1 1 0 0 0 0 0 1 1 1) (0 1 1 0 1 0 1 1 0 1 1 1 0 1 1 1 1 0 0 0) (1 1 1 1 1 1 1 0 0 1 1 1 0 1 1 1 1 0 0 0) (1 0 1 0 1 1 1 1 1 0 0 1 1 1 0 0 1 1 1 0) (1 0 1 0 1 0 1 1 1 1 0 0 1 0 0 0 0 0 0 0) (1 1 0 0 1 1 1 1 0 1 1 0 1 0 0 1 1 0 0 1) (0 1 1 1 1 0 0 1 1 1 0 1 1 0 0 0 1 1 1 1) (1 1 1 0 0 0 1 1 1 1 0 1 0 1 1 0 1 1 0 1) (0 0 0 0 1 0 0 1 0 0 0 1 0 0 1 0 0 0 0 1) (0 0 0 0 1 0 0 1 0 0 1 0 0 0 0 1 1 0 0 1) (1 0 1 1 1 1 1 0 0 0 1 0 1 1 1 1 0 1 0 1))
(1 1 1 0 1 0 0 1 0 1 1 1 0 1 1 1 0 1 1 1)
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)
20
_$
萤火虫个体基因长度为20，初始种群容量为30，初始pest=(1 1 1 0 1 0 0 1 0 1 1 1 0 1 1 1 0 1 1 1)，经过10代后pest=(1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)，为最优解。

aimisiyou

(defun c:tt()
  (setq DB (getint "请输入母材短边DB长度=:"))
  (setq DA (getint "请输入母材长边DA长度=:"))
  (setq a (getint "请输入矩形零件长边a长度=:"))
  (setq b (getint "请输入矩形零件短边b长度=:"))
  (setq n_tol 0)
  (setq slst (list (list 0 0  DB  DA)))
  (entmake
        (list
                '(0 . "LWPOLYLINE")                        
                '(100 . "AcDbEntity")
                '(100 . "AcDbPolyline")
                '(90 . 4)                                 
                '(70 . 1)                                 
                (cons 10 (list (car (car slst)) (cadr (car slst))))
                (cons 10 (list (+ (car (car slst)) (caddr (car slst))) (cadr (car slst)) ))
                (cons 10 (list (+ (car (car slst)) (caddr (car slst))) (+ (cadr (car slst)) (cadddr (car slst))) ))
                (cons 10 (list (car (car slst)) (+ (cadr (car slst)) (cadddr (car slst))) )  )            
                (cons 210 '(0 0 1))   
          )                     
  )
(defun rnd ()
  (*(rem (getvar "cputicks") 1e4) 1e-4)
)

(defun ff (n)
    (setq lst '((0 5 1)(5 10 0)) vlst nil)
    (repeat n
        (setq num (fix (rem (getvar "CPUTICKS") 11)))
        (setq vlst (cons (car (vl-remove nil (mapcar '(lambda (x) (if (<= (car x) num (cadr x)) (last x) nil)) lst))) vlst))
    )
)
(defun dfun (e1 e2)
(apply '+ (mapcar '(lambda (x y) (boole 6 x y)) e1 e2))
)
(defun move (e1 e2)
(setq dis (dfun e1 e2) k (/ (fitfun e1) 1.0 (fitfun e2)) p2 0.95)
(setq p1 (+ (* k 0.4) (/ 1.0 (+ 2.0 dis))))
(mapcar '(lambda (x y) (if (< (setq p (rnd)) p1) y (if (< p1 p p2) x  (boole 7 y (fix (+ 0.5 (rnd))))))) e1 e2)
)
(defun gafun (n_length n_in n_ga)
     (setq poplst nil)
     (repeat n_in
            (setq plst (ff n_length))
            (setq poplst (cons plst poplst))
      )
(setq p_best (cdr(car (vl-sort (mapcar '(lambda (x) (cons (fitfun x) x)) poplst)  '(lambda (e1 e2) (> (car e1) (car e2)))))))
(repeat n_ga
(progn
  (setq plst (mapcar '(lambda (x) (move x p_best)) poplst))
  (setq pest_new (cdr (car (vl-sort (mapcar '(lambda (x) (cons (fitfun x) x)) poplst)  '(lambda (e1 e2) (> (car e1) (car e2)))))))
  (if (> (fitfun p_bestnew) (fitfun p_best)) (setq p_best p_bestnew) (setq p_best p_best))
  )
)
   p_best
)
(defun fenfun (s r)
  (cond
      ((and (= (car r) (car s))
            (= (cadr r) (cadr s))
            (= (caddr r) (caddr s))
            (= (cadddr r) (cadddr s))  
         )      
        (setq va nil)
      )     
      ((and (<= (car r) (car s))
            (<= (cadr r) (cadr s))
            (< (car s) (+ (car r) (caddr r)) (+ (car s) (caddr s)))
            (< (cadr s) (+ (cadr r) (cadddr r)) (+ (cadr s) (cadddr s)))  
          )      
         (setq va (list
                       (list (car s) (+ (cadr r) (cadddr r)) (caddr s) (- (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r))) )
                       (list (+ (car r) (caddr r)) (cadr s)  (- (+ (car s) (caddr s)) (+ (car r) (caddr r))) (cadddr s))
                   )
          )
       )
      ((and (= (car r) (car s))
            (< (cadr r) (cadr s))
            (< (caddr r) (caddr s))
            (< (cadr s) (+ (cadr r) (cadddr r)) (+ (cadr s) (cadddr s)))  
          )
         (setq va (list
                       (list (car s) (+ (cadr r) (cadddr r)) (caddr s) (- (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r))) )
                       (list (+ (car r) (caddr r)) (cadr s)  (- (+ (car s) (caddr s)) (+ (car r) (caddr r))) (cadddr s))
                  )
          )
       )
      ((and (< (car s ) (car r ) (+ (car r) (caddr r)) (+ (car s) (caddr s)))
            (< (cadr r) (cadr s) (+ (cadr r) (cadddr r)) (+ (cadr s) (cadddr s)))  
        )
        (setq va (list
                       (list (car s) (cadr s) (- (car r)(car s)) (cadddr s) )
                       (list (car s) (+ (cadr r) (cadddr r)) (caddr s)  (- (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r))))
                       (list (+ (car r) (caddr r)) (cadr s) (- (+ (car s) (caddr s)) (+ (car r) (caddr r))) (cadddr s))
                  )
          )
       )
      ((and (< (car s ) (car r ) (+ (car s) (caddr s)) )
            (<= (+ (car s) (caddr s)) (+ (car r) (caddr r)) )
            (< (cadr r) (cadr s) (+ (cadr r) (cadddr r)) (+ (cadr s) (cadddr s)))  
        )
        (setq va (list
                       (list (car s) (cadr s) (- (car r) (car s))(cadddr s) )
                       (list (car s) (+ (cadr r) (cadddr r))  (caddr s)  (- (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r))))
                  )
          )
       )
      ((and (= (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r)) )
            (<= (car r ) (car s ) )
            (< (car s)  (+ (car r) (caddr r)) (+ (car s) (caddr s)))
            (<= (cadr r) (cadr s) )  
        )
        (setq va (list
                       (list (+ (car r) (caddr r)) (cadr s) (- (+ (car s) (caddr s)) (+ (car r) (caddr r))) (cadddr s) )
                  )
          )
       )
      ((and (= (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r)) )
            (< (car s ) (car r ) (+ (car r) (caddr r)) (+ (car s) (caddr s)))
            (< (cadr r) (cadr s) )  
        )
        (setq va (list
                       (list (car s ) (cadr s ) (- (car r) (car s))(cadddr s) )
                       (list (+ (car r) (caddr r)) (cadr s) (- (+ (car s) (caddr s)) (+ (car r) (caddr r))) (cadddr s) )
                  )
          )
       )
      ((and (= (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r)) )
            (< (car s ) (car r )  (+ (car s) (caddr s)))
            (<= (cadr s) (+ (car r) (caddr r)))
            (< (cadr r) (cadr s) )  
        )
        (setq va (list
                       (list (car s ) (cadr s ) (- (car r) (car s))(cadddr s) )
                  )
          )
       )
      ((and (< (car s ) (car r )  (+ (car s) (caddr s)) (+ (car r) (caddr r)))
            (< (+ (cadr r) (cadddr r)) (+ (cadr s) (cadddr s)))
            (= (cadr r) (cadr s) )  
        )
        (setq va (list
                       (list (car s ) (cadr s ) (- (car r) (car s))(cadddr s) )
                       (list (car s ) (+ (cadr r)(cadddr r)) (caddr s)(- (cadddr s)(cadddr r)))
                  )
          )
       )
      ((and (<= (car r ) (car s )  (+ (car s) (caddr s)) (+ (car r) (caddr r)))
            (< (+ (cadr r) (cadddr r)) (+ (cadr s) (cadddr s)))
            (= (cadr r) (cadr s) )  
        )
        (setq va (list
                       (list (car s ) (+ (cadr r)(cadddr r)) (caddr s) (- (cadddr s)(cadddr r)))
                  )
          )
       )
      ((and (< (car r ) (car s ) (+ (car r) (caddr r)) (+ (car s) (caddr s)) )
            (< (+ (cadr r) (cadddr r)) (+ (cadr s) (cadddr s)))
            (= (cadr r) (cadr s) )  
        )
        (setq va (list
                       (list (car s ) (+ (cadr r)(cadddr r)) (caddr s) (- (cadddr s)(cadddr r)))
                       (list (+ (car r) (caddr r)) (cadr s ) (- (+ (car s) (caddr s)) (+ (car r) (caddr r))) (cadddr s))
                  )
          )
       )
      ((and (< (car s ) (car r ) (+ (car s) (caddr s)) (+ (car r) (caddr r)) )
            (< (cadr s ) (cadr r ) (+ (cadr r) (cadddr r)) (+ (cadr s) (cadddr s)) )
        )
        (setq va (list
                       (list (car s)(cadr s)(caddr s) (- (cadr r) (cadr s)) )
                       (list (car s)(cadr s) (- (car r) (car s)) (cadddr s))
                       (list (car s)(+ (cadr r) (cadddr r)) (caddr s ) (- (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r))) )
                  )
          )
       )
      ((and (<= (car r ) (car s) (+ (car s) (caddr s)) (+ (car r) (caddr r)) )
            (< (cadr s ) (cadr r ) (+ (cadr r) (cadddr r)) (+ (cadr s) (cadddr s)) )
        )
        (setq va (list
                       (list (car s)(cadr s)(caddr s) (- (cadr r) (cadr s)) )
                       (list (car s)(+ (cadr r) (cadddr r)) (caddr s ) (- (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r))) )
                  )
          )
       )
      ((and (< (car r ) (car s ) (+ (car r) (caddr r)) (+ (car s) (caddr s)) )
            (< (cadr s ) (cadr r ) (+ (cadr r) (cadddr r)) (+ (cadr s) (cadddr s)) )
        )
        (setq va (list
                       (list (car s)(cadr s)(caddr s) (- (cadr r) (cadr s)) )
                       (list (+ (car r)(caddr r)) (cadr s) (- (+ (car s) (caddr s)) (+ (car r) (caddr r))) (cadddr s))
                       (list (car s)(+ (cadr r) (cadddr r)) (caddr s ) (- (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r))) )
                  )
          )
       )
      ((and (< (car s ) (car r )  (+ (car s) (caddr s)) (+ (car r) (caddr r)))
            (< (cadr s ) (cadr r ))
            (= (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r)))
        )
        (setq va (list
                       (list (car s ) (cadr s )(- (car r) (car s))(cadddr s) )
                       (list (car s ) (cadr s )(caddr s)(- (cadr r) (cadr s)) )
                  )
          )
       )
      ((and (<= (car r ) (car s )  (+ (car s) (caddr s)) (+ (car r) (caddr r)))
            (< (cadr s ) (cadr r ))
            (= (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r)))  
        )
        (setq va (list
                       (list (car s ) (cadr s )(caddr s)(- (cadr r) (cadr s)) )
                  )
          )
       )
      ((and (< (car r ) (car s )  (+ (car r) (caddr r)) (+ (car s) (caddr s)))
            (< (cadr s ) (cadr r ))
            (= (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r)))  
        )
        (setq va (list
                       (list (car s ) (cadr s )(caddr s)(- (cadddr s) (cadddr r)) )
                       (list (+ (car r)(caddr r)) (cadr s) (- (+ (cadr s) (cadddr s)) (+ (cadr r) (cadddr r))) (cadddr s) )
                  )
          )
       )
       (t (setq va (list s)))
  )
)
(defun hefun (mlst)
   (setq ih 0 vmlst nil nk (length mlst) )
   (while (< ih nk)
        (setq a_i (nth ih mlst) jh 0 sumh 0 hflag t)
        (while (and hflag (< jh nk))
           (setq b_j (nth jh mlst))
           (if (and (<= (car b_j)  (car a_i) )
                    (<= (cadr b_j) (cadr a_i))
                    (<= (+ (car a_i) (caddr a_i) ) (+ (car b_j) (caddr b_j) ))
                    (<= (+ (cadr a_i) (cadddr a_i) ) (+ (cadr b_j) (cadddr b_j) ))
               )
              (setq sumh (+ 1 sumh))
            )
           (setq jh (+ jh 1))
           (if (> sumh 1) (setq hflag nil))
         )
       (if hflag (setq vmlst (cons a_i vmlst)))
       (setq ih (+ ih 1))
  )
  (reverse vmlst)
)
(defun sortfun (juxlst)
   (vl-sort juxlst
             '(lambda (a b)
                      (if  (= (cadr a) (cadr b))
                           (<= (car a) (car b))
                           (< (cadr a) (cadr b))
                        )
              )
    )
)
(defun drawfun (pt slst ifdraw)
   (setq i 0 n (length slst) flag t  newslst slst)
   (while (and flag (< i n))
           (setq sg (nth i slst))
           (if (and (<= (car pt) (caddr sg)) (<= (cadr pt) (cadddr sg)) )
               (progn
                    (setq flag nil)
                    (setq r (list (car sg) (cadr sg) (car pt) (cadr pt)) vlst nil)
                    (foreach a slst
                             (setq vlst (append  (fenfun a r) vlst))
                     )
                    (setq newslst (sortfun (hefun vlst )))
                     (if ifdraw
                       (entmake
                             (list
                                  '(0 . "LWPOLYLINE")                        
                                  '(100 . "AcDbEntity")
                                  '(100 . "AcDbPolyline")
                                  '(90 . 4)                                 
                                  '(70 . 1)                                 
                                  (cons 10 (list (car sg) (cadr sg)))
                                  (cons 10 (list (+ (car sg) (car pt)) (cadr sg) ))
                                  (cons 10 (list (+ (car sg) (car pt)) (+ (cadr sg) (cadr pt)) ))
                                  (cons 10 (list (car sg) (+ (cadr sg) (cadr pt)) )  )            
                                  (cons 210 '(0 0 1))   
                               )  
                         )
                      )
                     (setq n_tol (+ n_tol 1))
               )
               (setq i (+ 1 i))
           )
   )
  newslst
)
(defun fitfun (en)
  (setq n_tol 0 flag t)
  (setq slst (list (list 0 0 DB DA)))
  (setq ptlst (mapcar '(lambda (x) (if (= x 0)
                                                (list a b)
                                                (list b a)
                                    )
                         )
                       en
               )
   )
  (foreach bb ptlst
             (setq slst (drawfun bb slst ifdraw))
   )
   n_tol
)
  (setq ifdraw nil)
  (setq p_best (gafun (/ (* DB DA) (* a b)) 30 50))
  (setq ifdraw t)
  (fitfun p_best)
)
命令: tt
请输入母材短边DB长度=:47
请输入母材长边DA长度=:39
请输入矩形零件长边a长度=:10
请输入矩形零件短边b长度=:7
22

lsthz

看的晕，得研究研究！
来自: 微社区