采用连分数法求单一规格矩形剪切下料问题
本帖最后由 mahuan1279 于 2019-10-1 22:40 编辑;;;剪切下料的毛坯数最大，且剪切刀数最小。
(defun c:tt()
(defun xl (LA LB c d)
(defun LF (c d) ;;;c>d
(setq lst nil)
(if (= (rem c d) 0)
(setq lst (list (/ c d)))
(setq lst (cons (/ c d) (LF d (rem c d))))
)
)
(defun HF (lst)
(if (<= (length lst) 2)
(if (= (length lst) 2)
(setq va (list (+ 1 (* (car lst)(cadr lst))) (cadr lst)))
(setq va (list (car lst) 1))
)
(setq va (list (+ (cadr (HF (cdr lst))) (* (car lst)(car (HF (cdr lst))))) (car (HF (cdr lst)))))
)
)
(defun FCC(k1 k2 c d)
(if (= d 1)
(setq num_cc (* k1 k2 c))
(progn
(if (= (rem (length (LF c d)) 2) 0)
(setq cd (HF (reverse (cdr (reverse (LF c d))))))
(setq cd (HF (reverse (cons (- (last (LF c d)) 1) (cdr (reverse (LF c d)))))))
)
(setq r2 (rem k1 (cadr cd)))
(setq t2 (rem k2 (cadr cd)))
(setq num_cc (+ (* (/ k1 (cadr cd)) k2 (car cd))(* (/ k2 (cadr cd)) r2 (car cd))(FCC r2 t2 (car cd) (cadr cd))))
)
)
)
(defun FDD (k1 k2 c d)
(if (= d 1)
(setq num_cc (max (+ (* k2 (/ k1 c)) (* (rem k1 c) (/ k2 c)))
(+ (* k1 (/ k2 c)) (* (rem k2 c) (/ k1 c)))
)
)
(progn
(if (= (rem (length (LF c d)) 2) 0)
(setq cd (HF (reverse (cons (- (last (LF c d)) 1) (cdr (reverse (LF c d)))))))
(setq cd (HF (reverse (cdr (reverse (LF c d))))))
)
(setq r1 (rem k1 (car cd)))
(setq t1 (rem k2 (car cd)))
(setq num_cc (+ (* (/ k1 (car cd)) k2 (cadr cd))(* (/ k2 (car cd)) r1 (cadr cd))(FDD r1 t1 (car cd) (cadr cd))))
)
)
)
(defun ff (L a b flag)
(setq i 0 flst nil)
(while (<= (* a i) L)
(setq flst (cons (list i (/ (- L (* i a)) b) (rem (- L (* i a)) b)) flst))
(setq i (+ i 1))
)
(setq lst (vl-sort flst '(lambda (x y)(<= (caddr x) (caddr y)) ) ) )
(setq nmin (caddr (car lst)))
(if flag
(progn
(setq flst (vl-remove-if-not '(lambda (x) (= (caddr x) nmin)) lst) )
(setq flst (vl-sort flst '(lambda (x y) (> (car x) (car y)) ) ) )
(setq va (car flst))
(if (= (car va) 0)
(progn
(setq flst (vl-remove-if '(lambda (x) (= (caddr x) nmin)) lst))
(setq nmin (caddr (car flst)))
(setq flst (vl-remove-if-not '(lambda (x) (= (caddr x) nmin)) flst) )
(setq flst (vl-sort flst '(lambda (x y) (> (car x) (car y)) ) ))
(setq va (car flst))
)
)
)
(progn
(setq lst (vl-remove-if-not '(lambda (x) (= (caddr x) nmin)) lst) )
(setq lst (vl-sort lst '(lambda (x y) (> (car x) (car y)) ) ) )
(setq va (car lst))
)
)
va
)
(if (/= (last (ff (rem LA (* c d)) c d nil)) 0)
(if (> LA (* c d))
(progn
(setq na (- (/ LA (* c d)) 1))
(setq lsta (ff (+ (* c d)(rem LA (* c d))) c d nil))
)
(progn
(setq na 0)
(setq lsta (ff LA c d nil))
)
)
(progn
(setq na (/ LA (* c d)))
(setq lsta (ff (rem LA (* c d)) c d nil))
)
)
(if (/= (last (ff (rem LB (* c d)) c d nil)) 0)
(if (> LB (* c d))
(progn
(setq nb (- (/ LB (* c d)) 1))
(setq lstb (ff (+ (* c d)(rem LB (* c d))) c d nil))
)
(progn
(setq nb 0)
(setq lstb (ff LB c d nil))
)
)
(progn
(setq nb (/ LB (* c d)))
(setq lstb (ff (rem LB (* c d)) c d nil))
)
)
(if (or (< (min LA LB) d) (< (max LA LB) c))
(setq num 0)
(setq num (+ (* na nb c d)
(* (car lsta) nb c)
(* (cadr lsta) nb d)
(* (car lstb) na c)
(* (cadr lstb) na d)
(* (car lsta) (cadr lstb))
(* (cadr lsta) (car lstb))
(FCC (car lsta) (car lstb) c d)
(FDD (cadr lsta) (cadr lstb) c d)
)
)
)
)
(defun jq(LA LB a b)
(if (= (rem LA b) (rem LB a) 0)
(setq vat (list 0 0 0))
(progn
(if (< LA a)
(setq vat (list 0 0 0))
(progn
(setq x (- LA (rem LA a)))
(setq flag t)
(while (and flag (>= x 0))
(setq y 0)
(while (and flag (<= y LB))
(if (= (xl LA LB a b)
(max (+ (* (/ x a) (/ LB b)) (* (/ (- LA x) b) (/ (- LB y) a)) (xl (- LA x) (+ y (rem (- LB y) a)) a b))
(+ (* (/ x a) (/ y b)) (* (/ LA b) (/ (- LB y) a)) (xl (- LA x) (+ y (rem (- LB y) a)) a b))
)
)
(progn
(setq flag nil)
(if (>= (+ (* (/ x a) (/ LB b)) (* (/ (- LA x) b) (/ (- LB y) a)))
(+ (* (/ x a) (/ y b)) (* (/ LA b) (/ (- LB y) a)))
)
(setq vat (list x y 1))
(setq vat (list x y 0))
)
)
(if flag (setq y (+ y b)))
)
)
(if flag (setq x (- x a)))
)
)
)
)
)
vat
)
(defun f(pt n a b flag tfx)
(if (= n 1)
(if flag
(entmake
(list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 4)
'(70 . 1)
(cons 10 (list (car pt) (cadr pt)))
(cons 10 (list (+ (car pt) a) (cadr pt)))
(cons 10 (list (+ (car pt) a) (+ (cadr pt) (* b tfx))))
(cons 10 (list (car pt) (+ (cadr pt) (* b tfx))))
)
)
(entmake
(list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 4)
'(70 . 1)
(cons 10 (list (car pt) (cadr pt)))
(cons 10 (list (+ (car pt) b) (cadr pt)))
(cons 10 (list (+ (car pt) b) (+ (cadr pt) (* a tfx))))
(cons 10 (list (car pt) (+ (cadr pt) (* a tfx))))
)
)
)
(progn
(f pt 1 a b flag tfx)
(setq i 1)
(while (< i n)
(setq pt1 (list (car pt) (+ (cadr pt) (* tfx (+ (if flag b a) (* (if flag a b) -1) (* (if flag a b) i))))))
(setq pt2 (list (+ (car pt) (- (if flag a b) (if flag b a)) (* i (if flag b a))) (cadr pt)))
(f pt1 1 a b (not flag) tfx)
(f pt2 1 a b (not flag) tfx)
(setq i (+ i 1))
)
(f (list (+ (car pt) (if flag b a)) (+ (cadr pt) (* (if flag a b) tfx))) (- n 1) a b flag tfx)
)
)
)
(defun drawone (pt a b)
(f pt 1 a b t 1)
)
(defun drawmore (ppt n m a b)
(setq i 0 j 0)
(while (< i n)
(while (< j m)
(drawone (list (+ (car ppt) (* i a)) (+ (cadr ppt) (* j b))) a b)
(setq j (+ j 1))
)
(setq i (+ i 1) j 0)
)
)
(setq pt (getpoint "\n插入点位置："))
(setq LA (getint "母材长边长度\nLA=：")
LB (getint "母材短边长度\nLB=：")
c (getint "构件长边长度\nc=：")
d (getint "构件短边长度\nd=：")
)
(entmake
(list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 4)
'(70 . 1)
(cons 10 (list (car pt) (cadr pt)))
(cons 10 (list (+ (car pt) LA) (cadr pt)))
(cons 10 (list (+ (car pt) LA) (+ (cadr pt) LB)))
(cons 10 (list (car pt) (+ (cadr pt) LB)))
(cons 210 '(0 0 1))
)
)
(while (and (>= (min LA LB) d) (>= (max LA LB) c))
(setq xylst (jq LA LB c d))
(if (= (caddr xylst) 0)
(progn
(drawmore pt (/ (car xylst) c)(/ (cadr xylst) d) c d)
(setq dis1 (rem LA d))
(setq dis2 (rem (- LB (cadr xylst)) c))
(drawmore (polar (polar pt (/ pi 2) (+ (cadr xylst) dis2)) 0 dis1) (/ LA d)(/ (- LB (cadr xylst)) c) d c)
)
(progn
(drawmore pt (/ (car xylst) c)(/ LB d) c d)
(setq dis1 (rem (- LA (car xylst)) d))
(setq dis2 (rem (- LB (cadr xylst)) c))
(drawmore (polar (polar pt (/ pi 2) (+ (cadr xylst) dis2)) 0 (+ (car xylst) dis1)) (/ (- LA (car xylst)) d)(/ (- LB (cadr xylst)) c) d c)
)
)
(setq LA (+ (- LA (car xylst)) (rem (car xylst) c)))
(setq LB (+ (cadr xylst) (rem (- LB (cadr xylst)) c) ))
(setq pt (polar pt 0 (- (car xylst) (rem (car xylst) c))))
)
)
mahuan1279 发表于 2019-10-3 08:58
如果（LA，LB，c ,d）中存在实数，将LA，LB，c，d都扩大10^n使得都变成整数，程序运行后将图形缩小10^n即 ...
这方法好妙，谢谢你的好程序，，，
不过循环似乎有点问题，照你的方法改了一下，现在只能产生第一个“构件”矩形
(defun c:tt ()
(defun xl (LA LB c d)
(defun LF (c d)
;;;c>d
(setq lst nil)
(if (= (rem c d) 0)
(setq lst (list (/ c d)))
(setq lst (cons (/ c d) (LF d (rem c d))))
)
)
(defun HF (lst)
(if (<= (length lst) 2)
(if (= (length lst) 2)
(setq va (list (+ 1 (* (car lst) (cadr lst))) (cadr lst)))
(setq va (list (car lst) 1))
)
(setq va (list (+ (cadr (HF (cdr lst)))
(* (car lst) (car (HF (cdr lst))))
)
(car (HF (cdr lst)))
)
)
)
)
(defun FCC (k1 k2 c d)
(if (= d 1)
(setq num_cc (* k1 k2 c))
(progn
(if (= (rem (length (LF c d)) 2) 0)
(setq cd (HF (reverse (cdr (reverse (LF c d))))))
(setq cd (HF (reverse (cons (- (last (LF c d)) 1)
(cdr (reverse (LF c d)))
)
)
)
)
)
(setq r2 (rem k1 (cadr cd)))
(setq t2 (rem k2 (cadr cd)))
(setq num_cc (+ (* (/ k1 (cadr cd)) k2 (car cd))
(* (/ k2 (cadr cd)) r2 (car cd))
(FCC r2 t2 (car cd) (cadr cd))
)
)
)
)
)
(defun FDD (k1 k2 c d)
(if (= d 1)
(setq num_cc (max (+ (* k2 (/ k1 c)) (* (rem k1 c) (/ k2 c)))
(+ (* k1 (/ k2 c)) (* (rem k2 c) (/ k1 c)))
)
)
(progn
(if (= (rem (length (LF c d)) 2) 0)
(setq cd (HF (reverse (cons (- (last (LF c d)) 1)
(cdr (reverse (LF c d)))
)
)
)
)
(setq cd (HF (reverse (cdr (reverse (LF c d))))))
)
(setq r1 (rem k1 (car cd)))
(setq t1 (rem k2 (car cd)))
(setq num_cc (+ (* (/ k1 (car cd)) k2 (cadr cd))
(* (/ k2 (car cd)) r1 (cadr cd))
(FDD r1 t1 (car cd) (cadr cd))
)
)
)
)
)
(defun ff (L a b flag)
(setq i 0
flst nil
)
(while (<= (* a i) L)
(setq flst
(cons (list i (/ (- L (* i a)) b) (rem (- L (* i a)) b))
flst
)
)
(setq i (+ i 1))
)
(setq lst (vl-sort flst '(lambda (x y) (<= (caddr x) (caddr y)))))
(setq nmin (caddr (car lst)))
(if flag
(progn
(setq flst
(vl-remove-if-not '(lambda (x) (= (caddr x) nmin)) lst)
)
(setq flst (vl-sort flst '(lambda (x y) (> (car x) (car y)))))
(setq va (car flst))
(if (= (car va) 0)
(progn
(setq flst
(vl-remove-if '(lambda (x) (= (caddr x) nmin)) lst)
)
(setq nmin (caddr (car flst)))
(setq flst (vl-remove-if-not
'(lambda (x) (= (caddr x) nmin))
flst
)
)
(setq flst
(vl-sort flst '(lambda (x y) (> (car x) (car y))))
)
(setq va (car flst))
)
)
)
(progn
(setq lst
(vl-remove-if-not '(lambda (x) (= (caddr x) nmin)) lst)
)
(setq lst (vl-sort lst '(lambda (x y) (> (car x) (car y)))))
(setq va (car lst))
)
)
va
)
(if (/= (last (ff (rem LA (* c d)) c d nil)) 0)
(if (> LA (* c d))
(progn
(setq na (- (/ LA (* c d)) 1))
(setq lsta (ff (+ (* c d) (rem LA (* c d))) c d nil))
)
(progn
(setq na 0)
(setq lsta (ff LA c d nil))
)
)
(progn
(setq na (/ LA (* c d)))
(setq lsta (ff (rem LA (* c d)) c d nil))
)
)
(if (/= (last (ff (rem LB (* c d)) c d nil)) 0)
(if (> LB (* c d))
(progn
(setq nb (- (/ LB (* c d)) 1))
(setq lstb (ff (+ (* c d) (rem LB (* c d))) c d nil))
)
(progn
(setq nb 0)
(setq lstb (ff LB c d nil))
)
)
(progn
(setq nb (/ LB (* c d)))
(setq lstb (ff (rem LB (* c d)) c d nil))
)
)
(if (or (< (min LA LB) d) (< (max LA LB) c))
(setq num 0)
(setq num (+ (* na nb c d)
(* (car lsta) nb c)
(* (cadr lsta) nb d)
(* (car lstb) na c)
(* (cadr lstb) na d)
(* (car lsta) (cadr lstb))
(* (cadr lsta) (car lstb))
(FCC (car lsta) (car lstb) c d)
(FDD (cadr lsta) (cadr lstb) c d)
)
)
)
)
(defun jq (LA LB a b)
(if (= (rem LA b) (rem LB a) 0)
(setq vat (list 0 0 0))
(progn
(if (< LA a)
(setq vat (list 0 0 0))
(progn
(setq x (- LA (rem LA a)))
(setq flag t)
(while (and flag (>= x 0))
(setq y 0)
(while (and flag (<= y LB))
(if (= (xl LA LB a b)
(max (+ (* (/ x a) (/ LB b))
(* (/ (- LA x) b) (/ (- LB y) a))
(xl (- LA x) (+ y (rem (- LB y) a)) a b)
)
(+ (* (/ x a) (/ y b))
(* (/ LA b) (/ (- LB y) a))
(xl (- LA x) (+ y (rem (- LB y) a)) a b)
)
)
)
(progn
(setq flag nil)
(if (>= (+ (* (/ x a) (/ LB b))
(* (/ (- LA x) b) (/ (- LB y) a))
)
(+ (* (/ x a) (/ y b))
(* (/ LA b) (/ (- LB y) a))
)
)
(setq vat (list x y 1))
(setq vat (list x y 0))
)
)
(if flag
(setq y (+ y b))
)
)
)
(if flag
(setq x (- x a))
)
)
)
)
)
)
vat
)
(defun f (pt n a b flag tfx)
(if (= n 1)
(if flag
(entmake
(list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 4)
'(70 . 1)
(cons 10 (list (car pt) (cadr pt)))
(cons 10 (list (+ (car pt) (/ a 1000.0)) (cadr pt)))
(cons 10
(list (+ (car pt) (/ a 1000.0))
(+ (cadr pt) (* (/ b 1000.0) tfx))
)
)
(cons 10 (list (car pt) (+ (cadr pt) (* (/ b 1000.0) tfx))))
)
)
(entmake
(list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 4)
'(70 . 1)
(cons 10 (list (car pt) (cadr pt)))
(cons 10 (list (+ (car pt) (/ b 1000.0)) (cadr pt)))
(cons 10
(list (+ (car pt) (/ b 1000.0))
(+ (cadr pt) (* (/ a 1000.0) tfx))
)
)
(cons 10 (list (car pt) (+ (cadr pt) (* (/ a 1000.0) tfx))))
)
)
)
(progn
(f pt 1 a b flag tfx)
(setq i 1)
(while (< i n)
(setq pt1 (list (car pt)
(+ (cadr pt)
(* tfx
(+ (if flag
b
a
)
(* (if flag
a
b
)
-1
)
(* (if flag
a
b
)
i
)
)
)
)
)
)
(setq pt2 (list (+ (car pt)
(- (if flag
a
b
)
(if flag
b
a
)
)
(* i
(if flag
b
a
)
)
)
(cadr pt)
)
)
(f pt1 1 a b (not flag) tfx)
(f pt2 1 a b (not flag) tfx)
(setq i (+ i 1))
)
(f (list (+ (car pt)
(if flag
b
a
)
)
(+ (cadr pt)
(* (if flag
a
b
)
tfx
)
)
)
(- n 1)
a
b
flag
tfx
)
)
)
)
(defun drawone (pt a b)
(f pt 1 a b t 1)
)
(defun drawmore (ppt n m a b)
(setq i 0
j 0
)
(while (< i n)
(while (< j m)
(drawone (list (+ (car ppt) (* i a)) (+ (cadr ppt) (* j b)))
a
b
)
(setq j (+ j 1))
)
(setq i (+ i 1)
j 0
)
)
)
(setq pt (getpoint "\n插入点位置:"))
(setq LA (getreal "母材长边长度\nLA=:")
LB (getreal "母材短边长度\nLB=:")
c(getreal "构件长边长度\nc=:")
d(getreal "构件短边长度\nd=:")
LA (fix (* LA 1000))
LB (fix (* Lb 1000))
c(fix (* c 1000))
d(fix (* d 1000))
)
(entmake
(list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 4)
'(70 . 1)
(cons 10 (list (car pt) (cadr pt)))
(cons 10 (list (+ (car pt) (/ LA 1000.0)) (cadr pt)))
(cons 10
(list (+ (car pt) (/ LA 1000.0))
(+ (cadr pt) (/ Lb 1000.0))
)
)
(cons 10 (list (car pt) (+ (cadr pt) (/ Lb 1000.0))))
(cons 210 '(0 0 1))
)
)
(while (and (>= (min LA LB) d) (>= (max LA LB) c))
(setq xylst (jq LA LB c d))
(if (= (caddr xylst) 0)
(progn
(drawmore pt (/ (car xylst) c) (/ (cadr xylst) d) c d)
(setq dis1 (rem LA d))
(setq dis2 (rem (- LB (cadr xylst)) c))
(drawmore
(polar (polar pt (/ pi 2) (+ (cadr xylst) dis2)) 0 dis1)
(/ LA d)
(/ (- LB (cadr xylst)) c)
d
c
)
)
(progn
(drawmore pt (/ (car xylst) c) (/ LB d) c d)
(setq dis1 (rem (- LA (car xylst)) d))
(setq dis2 (rem (- LB (cadr xylst)) c))
(drawmore (polar (polar pt (/ pi 2) (+ (cadr xylst) dis2))
0
(+ (car xylst) dis1)
)
(/ (- LA (car xylst)) d)
(/ (- LB (cadr xylst)) c)
d
c
)
)
)
(setq LA (+ (- LA (car xylst)) (rem (car xylst) c)))
(setq LB (+ (cadr xylst) (rem (- LB (cadr xylst)) c)))
(setq pt (polar pt 0 (- (car xylst) (rem (car xylst) c))))
)
) mahuan1279 发表于 2019-10-4 20:30
循环没问题啊。你改动哪里呢？
我只改了这些。。。
(setq LA (getreal "母材长边长度\nLA=:")
LB (getreal "母材短边长度\nLB=:")
c(getreal "构件长边长度\nc=:")
d(getreal "构件短边长度\nd=:")
LA (fix (* LA 1000))
LB (fix (* Lb 1000))
c(fix (* c 1000))
d(fix (* d 1000))
)
以及画矩形那三处，如：
(entmake
(list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 4)
'(70 . 1)
(cons 10 (list (car pt) (cadr pt)))
(cons 10 (list (+ (car pt) (/ LA 1000.0)) (cadr pt)))
(cons 10
(list (+ (car pt) (/ LA 1000.0))
(+ (cadr pt) (/ Lb 1000.0))
)
)
(cons 10 (list (car pt) (+ (cadr pt) (/ Lb 1000.0))))
(cons 210 '(0 0 1))
)
)
请你看看，有无弄错？
之前，上面那个回帖，认识有误，确实不是循环问题
现在程序运行结果是：能完整出图，包括大矩形很一众小矩形，只是小矩形彼此间存在间距，间距很大，估计是数值1000产生出来的。
所以，我理解，可能还有一两个变量须除于1000才行，不知是不这样？
本帖最后由 mahuan1279 于 2019-10-6 19:17 编辑
发现存在一些问题，如（3000 2000 80 70）会出现死机（一直处于运行状态）。但（300 200 8 7）却不会。理应两者的布局应相同（毛坯个数相同），仅仅比例大小不一样而已。经检查，（xl300 200 8 7）=1068,而（xl3000 2000 80 70）=950.故while语句一直处于死循环状态，三个分区的毛坯个数之和永远大于整体的毛坯个数。看来连分数法应适用在一定范围内，而不是所有范围。
看来，先要比较下（LA*LB）/(c*d)与（xlLA LB c d）是否相差不大。否则会出现死循环。
大哥，你还在研究呀？ 有思路就继续，没思路就暂放。不能强求一次到位。 争取发展到多种构件就更牛了 本帖最后由 mahuan1279 于 2019-9-29 11:00 编辑
ynhh 发表于 2019-9-29 08:07
争取发展到多种构件就更牛了
目前没有好的高效算法。进化算法、群智能算法用lisp实现难度大，效率低，吃力不讨好。 Thanks for sharing ^^ 本帖最后由 mahuan1279 于 2019-10-1 22:50 编辑
源代码有些纰漏导致运行结果图片不正确，1楼已改正。 要是能支持实数就好了 皇上快溜 发表于 2019-10-3 05:07
要是能支持实数就好了
如果（LA，LB，c ,d）中存在实数，将LA，LB，c，d都扩大10^n使得都变成整数，程序运行后将图形缩小10^n即可。如要求（105.87,234.93,15.831,13.297），都扩大1000倍为（105870,234930,15831,13297），运行后将图形缩小1000倍即可。
页:
[1]
2