大家画下把矩形用正方形填满的图形

newer

输入长、宽参数， 尽可能把矩形用正方形填满。


下面是长667，宽123的矩形，划分后的角部放大图

q3_2006

(defun c:tt ()
  (defun eBox (ent / ll ur)
    (vla-getboundingbox (vlax-ename->vla-object ent) 'll 'ur)
    (mapcar
      'safearray-value
      (list ll ur)
    )
  )
  (defun fgjx (e / box h p1 p2 w)
    (setq box (ebox e)
          p1 (car box)
          p2 (cadr box)
          w (- (car p2) (car p1))
          h (- (cadr p2) (cadr p1))
    )
    (if (/= w h)
      (if (> w h)
        (progn
          (vl-cmdf "rectang" p1 (mapcar
                                  '+
                                  p1
                                  (list h h)
                                )
          )
          (vl-cmdf "rectang" (polar p1 0 h) p2)
          (entdel e)
          (fgjx (entlast))
        )
        (progn
          (vl-cmdf "rectang" p1 (mapcar
                                  '+
                                  p1
                                  (list w w)
                                )
          )
          (vl-cmdf "rectang" (polar p1 (* 0.5 pi) w) p2)
          (entdel e)
          (fgjx (entlast))
        )
      )
    )
  )
  (vl-load-com)
  (setq *ACAD* (vlax-get-acad-object)
        *DOC* (vla-get-ActiveDocument *ACAD*)
  )
  (defun *error* (msg)
    (mapcar
      'setvar
      '("cmdecho" "osmode")
      odlst
    )
    (vlax-invoke-method *DOC* 'EndUndoMark)
    (princ msg)
  )
  (vlax-invoke-method *DOC* 'StartUndoMark)
  (setq odlst (mapcar
                'getvar
                '("cmdecho" "osmode")
              )
  )
  (mapcar
    'setvar
    '("cmdecho" "osmode")
    '(0 0)
  )
  (setq e (car (entsel "\n点取矩形:")))
  (fgjx e)
  (mapcar
    'setvar
    '("cmdecho" "osmode")
    odlst
  )
  (vlax-invoke-method *DOC* 'EndUndoMark)
)

newer

q3_2006 发表于 2016-10-24 21:35

快刀，是现成的，还是现写的？

yoyoho

感谢 q3_2006 大大分享程序!!!!

q3_2006

newer 发表于 2016-10-24 21:43

下线的点..看到简单才写的...如果复杂估计就是今天来研究了...

cable2004

1. (defun c:zz  ( / *cc *kk p0  pts)   (setq pts (apply 'append(mapcar'(lambda ( a ) (if (= 10 (car a))(list (cdr a)))) (entget (car(entsel))))))
   
2.    (setq p0  (car (vl-sort  (cddr (setq pts (vl-sort pts '(lambda (e1 e2) (< (cadr e1) (cadr e2)))))) '(lambda (e1 e2) (< (car e1) (car e2))))))
   
3.    (setq *cc (-(caar pts)(caadr pts)) *kk (- (car(cdaddr pts))(cadadr pts)) )
   
4.    (while (> (min *cc *kk) 0.00001)
   
5.    (if (< *cc *kk)  
   
6.      (repeat (fix(/ *kk *cc))
   
7.               (mk-zfx p0 *cc 1)
   
8.               (setq p0 (polar p0 (* -0.5 pi) *cc)  *kk (- *kk *cc ))
   
9.          )
   
10.      (repeat (fix(/ *cc *kk))
    
11.               (mk-zfx p0 *kk 2)
    
12.              (setq p0 (polar p0 0 *kk) *cc (- *cc *kk))
    
13.          )
    
14.      )
    
15.   )
    
16. (princ))
    
17. 
    
18. (defun mk-zfx(pt l col)
    
19. (entmakex(list (cons 0 "LWPOLYLINE")(cons 100 "AcDbEntity")(cons 100 "AcDbPolyline")(cons 90 4 )(cons 70 1 )(cons 62 col)                                    
    
20.                 (cons 10 pt)            
    
21.                 (cons 10 (polar pt 0 l))            
    
22.                 (cons 10 (polar (polar pt (* -0.5 pi) l) 0 l))            
    
23.                 (cons 10 (polar pt (* -0.5 pi) l))            
    
24.              ))
    
25. )

(defun c:zz  ( / *cc *kk p0  pts)   (setq pts (apply 'append(mapcar'(lambda ( a ) (if (= 10 (car a))(list (cdr a)))) (entget (car(entsel))))))<br />    (setq p0  (car (vl-sort  (cddr (setq pts (vl-sort pts '(lambda (e1 e2) (< (cadr e1) (cadr e2)))))) '(lambda (e1 e2) (< (car e1) (car e2))))))<br />    (setq *cc (-(caar pts)(caadr pts)) *kk (- (car(cdaddr pts))(cadadr pts)) )<br />    (while (> (min *cc *kk) 0.00001)<br />    (if (< *cc *kk)  <br />      (repeat (fix(/ *kk *cc))<br />               (mk-zfx p0 *cc 1)<br />               (setq p0 (polar p0 (* -0.5 pi) *cc)  *kk (- *kk *cc ))<br />          )<br />      (repeat (fix(/ *cc *kk))<br />               (mk-zfx p0 *kk 2)<br />              (setq p0 (polar p0 0 *kk) *cc (- *cc *kk))<br />          )<br />      )<br />   )<br /> (princ))<br /> <br /> (defun mk-zfx(pt l col)<br /> (entmakex(list (cons 0 "LWPOLYLINE")(cons 100 "AcDbEntity")(cons 100 "AcDbPolyline")(cons 90 4 )(cons 70 1 )(cons 62 col)                                    <br />                 (cons 10 pt)            <br />                 (cons 10 (polar pt 0 l))            <br />                 (cons 10 (polar (polar pt (* -0.5 pi) l) 0 l))            <br />                 (cons 10 (polar pt (* -0.5 pi) l))            <br />              ))<br /> )

cable2004

测试一下，行不行

newer

cable2004 发表于 2016-10-25 08:30

我这运行，选择对象后，就结束了，没结果。

cable2004

命令zz，我这里可以！

newer

cable2004 发表于 2016-10-26 00:27

我这还不行，明天我到单位的机器试试。

探讨下：
你求多段线顶点方法挺特别的，

(setq pts (apply
            'append
            (mapcar' (lambda (a)
                       (if (= 10 (car a))
                         (list (cdr a))
                       )
                     ) (entget (car (entsel)))
            )
          )
)

你用APPEND去掉了NIL，改成下面的能好点？

(setq pts (mapcar
            'cdr
            (vl-remove-if-not '(lambda (x)
                                 (= (car x) 10)
                               ) (entget (car (entsel)))
            )
          )
)

或者直接用VL-REMOVE去掉NIL

(setq pts (vl-remove nil (mapcar' (lambda (a)
                                    (if (= 10 (car a))
                                      (cdr a)
                                    )
                                  ) (entget (car (entsel)))
                         )
          )
)

你为了APPEND，强制把点表给加个LIST操作，APPEND不是一个很好的函数，还多余了个LIST。

newer

cable2004 发表于 2016-10-25 08:30

不行，在单位电脑也没反应，按ZZ就结束了。检查下代码吧。

marting

试试

1. (defun c:tt (/ x y s p a q)
   
2.   (if (and
   
3.         (setq x (getint "\n输入矩形X长: "))
   
4.         (setq y (getint "\n输入矩形Y长: "))
   
5.         (setq p (getpoint "\n插入点： "))
   
6.         (setq s        0
   
7.               a        (* x y)
   
8.         )
   
9.       )
   
10.     (while (< s a)
    
11.       (setq q (min x y)
    
12.             s (+ s (* q q))
    
13.       )
    
14.       (command "_rectangle" "_non"  p "_non"
    
15.                (mapcar '+ p (list q q))
    
16.       )
    
17.       (if (= q x)
    
18.         (setq y        (- y x)
    
19.               p        (mapcar  '+ p (list 0 q))
    
20.         )
    
21.         (setq x        (- x y)
    
22.               p        (mapcar  '+  p (list q 0))
    
23.         )
    
24.       )
    
25.     )
    
26.   )
    
27.   (princ)
    
28. )

(defun c:tt (/ x y s p a q)<br />   (if (and<br />         (setq x (getint "\n输入矩形X长: "))<br />         (setq y (getint "\n输入矩形Y长: "))<br />         (setq p (getpoint "\n插入点： "))<br />         (setq s        0<br />               a        (* x y)<br />         )<br />       )<br />     (while (< s a)<br />       (setq q (min x y)<br />             s (+ s (* q q))<br />       )<br />       (command "_rectangle" "_non"  p "_non"<br />                (mapcar '+ p (list q q))<br />       )<br />       (if (= q x)<br />         (setq y        (- y x)<br />               p        (mapcar  '+ p (list 0 q))<br />         )<br />         (setq x        (- x y)<br />               p        (mapcar  '+  p (list q 0))<br />         )<br />       )<br />     )<br />   )<br />   (princ)<br /> )

ll_j

好久不写程序了，看到这个题目有点意思，手痒凑一点，没有前后处理。
切割次序是倒过来的，这样可以简化些。两种方法，递归和当循环，都受系统限制，对数据切割复杂时系统会出问题。
不贴演示了，大家有兴趣可以试试，代码思路也不复杂，很容易看懂的。

(defun mkpl (pt w h)
  (entmake
    (list '(0 . "LWPOLYLINE")
          '(100 . "AcDbEntity")
          '(100 . "AcDbPolyline")
          '(90 . 4)
          '(70 . 1)
          '(43 . 0.0)
          '(38 . 0.0)
          '(39 . 0.0)
          (list 10 (car pt) (cadr pt))
          (list 10 (+ (car pt) w) (cadr pt))
          (list 10 (+ (car pt) w) (+ (cadr pt) h))
          (list 10 (car pt) (+ (cadr pt) h))
          '(210 0.0 0.0 1.0)
    )
  )
)

(defun c:tt(/ d pt w h)  ;使用递归
  (defun d(pt w h)
    (cond
      ((> w h)
       (mkpl (polar pt 0.0 (- w h)) h h) 
       (setq w (- w h))
       (d pt w h)
      )
      ((< w h)
       (mkpl (polar pt (/ pi 2) (- h w)) w w)
       (setq h (- h w))
       (d pt w h)
      )
      (t (mkpl pt w h))
    )
  )
      
  (setq pt(getpoint "\n矩形插入点: ")
        w (getdist pt "\n输入矩形宽: ")
        h (getdist pt "\n输入矩形高: ")
  )
  (mkpl pt w h)
  (d pt w h)
)

(defun c:tt1(/ pt w h)  ;使用当循环
  (setq pt(getpoint "\n矩形插入点: ")
        w (getdist pt "\n输入矩形宽: ")
        h (getdist pt "\n输入矩形高: ")
  )
  (mkpl pt w h)
  (while (/= w h)
    (if (> w h)
      (progn
        (mkpl (polar pt 0.0 (- w h)) h h)
        (setq w (- w h))
      )
      (progn
        (mkpl (polar pt (/ pi 2) (- h w)) w w)
        (setq h (- h w))
      )
    )
  )
  (mkpl pt w h)
)

newer

ll_j 发表于 2016-10-26 16:13

教授，你的代码画出来了，而且放大了好多次还都在画，看不到头啊：）

能否设置个面积的阈值，差不多就终止呢？

newer

marting 发表于 2016-10-26 11:16

很惊奇你这段代码