画出如图的蛇形LINE图形

aimisiyou

q3_2006 发表于 2016-10-21 08:30

我一看到英文长、参数多的代码我就头晕……

yoyoho

感谢分享程序,3Q!

cable2004

(defun c:tt (/ i lst lst1 lst2 lst-mid p0 x y z)
  (if (not *rr)
    (setq *rr 100.)
  )
  (if (not *nn)
    (setq *nn 11)
  )
  (if (not *ll)
    (setq *ll 10.)
  )
  (setq *rr (cond
              ((getdist (strcat "\n输入圆半径   <"
                                (vl-princ-to-string *rr) ">: "
                        )
               )
              )
              (*rr)
            )
  )
  (setq *nn (cond
              ((getdist (strcat "\n输入等分数量 <"
                                (vl-princ-to-string *nn) ">: "
                        )
               )
              )
              (*nn)
            )
  )
  (setq *ll (cond
              ((getdist (strcat "\n输入尖角水平距离 <"
                                (vl-princ-to-string *ll) ">: "
                        )
               )
              )
              (*ll)
            )
  )
  (setq p0 (getpoint "\n圆心插入点"))
  (if (and
        *rr
        *nn
        *ll
        p0
      )
    (progn
      (setq lst (dividex (list 0 *rr) (list 0 (* -1 *rr)) *nn)
            i 0
      )
      (setq lst (mapcar' (lambda (x)
                           (list (sqrt (abs (- (* *rr *rr) (* (cadr x)
                                                              (cadr x)
                                                           )
                                            )
                                       )
                                 ) (cadr x)
                           )
                         ) lst
                )
      )
      (setq lst-mid (reverse (cdr (reverse (cdr lst)))))
      (setq lst1 (mapcar' (lambda (x y z)
                            (setq i (1+ i))
                            (cond
                              ((and
                                 (null (equal (cadr x) 0 1e-6))
                                 (< (cadr x) 0)
                                 (= (rem i 2) 0)
                               )
                                (list x (list (* -1 (car y)) (cadr x)))
                              )
                              ((and
                                 (null (equal (cadr x) 0 1e-6))
                                 (< (cadr x) 0)
                                 (= (rem i 2) 1)
                               )
                                (list (list (* -1 (car x)) (cadr x))
                                      (list (car y) (cadr x))
                                )
                              )
                              ((and
                                 (null (equal (cadr x) 0 1e-6))
                                 (> (cadr x) 0)
                                 (= (rem i 2) 0)
                               )
                                (list (list (car z) (cadr x)) (list
                                                                    (* -1
                                                                       (car x)
                                                                    )
                                                                    (cadr x)
                                                              )
                                )
                              )
                              ((and
                                 (null (equal (cadr x) 0 1e-6))
                                 (> (cadr x) 0)
                                 (= (rem i 2) 1)
                               )
                                (list (list (* -1 (car z)) (cadr x)) x)
                              )
                              ((equal (cadr x) 0 1e-6)
                                (list (list *rr 0) (list (* -1 *rr) 0))
                              )
                            )
                          ) lst-mid (append
                                      (cdr lst-mid)
                                      (list (last lst))
                                    ) lst
                 )
      )
      (setq lst (apply
                  'append
                  lst1
                )
      )
      (setq lst1 (append
                   (list (list (caar lst) (* -1 *rr)))
                   lst
                   (list (list (car (last lst)) *rr))
                 )
      )
      (setq lst2 (apply
                   'append
                   (mapcar' (lambda (x)
                              (if (< (caar x) 0)
                                (list (car x) (polar (mid (car x)
                                                          (cadr x)
                                                     ) pi *ll
                                              ) (cadr x)
                                )
                                (list (car x) (polar (mid (car x)
                                                          (cadr x)
                                                     ) 0 *ll
                                              ) (cadr x)
                                )
                              )
                            ) (XD::List:GroupByNum lst1 2)
                   )
                 )
      )
      (if (= (rem *nn 2) 0)
        (setq lst2 (append
                     (list (list *rr (* -1 *rr)))
                     lst2
                     (list (list (* -1 *rr) *rr))
                   )
        )
        (setq lst2 (append
                     (list (list *rr (* -1 *rr)))
                     lst2
                     (list (list *rr *rr))
                   )
        )
      )
      (MK-LWPOLYLINE (mapcar' (lambda (x)
                                (polar x (angle (list 0 0 0) p0)
                                       (distance p0 (list 0 0 0))
                                )
                              ) lst2
                     )
      )
      (mkcir p0 *rr "0")
    )
  )
  (princ)
)
(defun MK-LWPOLYLINE (lst / p)
  (entmakex (append
              (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity")
                    (cons 100 "AcDbPolyline") (cons 90 (length lst))
              )
              (mapcar
                (function (lambda (p)
                            (cons 10 p)
                          )
                )
                lst
              )
            )
  )
)
(defun dividex (s e i / a r sl)
  (setq r (list s)
        a (angle s e)
        sl (/ (distance s e) i)               ;
  )
  (repeat (fix i)
    (setq r (cons (polar (car r) a sl) r))
  )
)

(defun XD::List:GroupByNum (lst num / ls ret)
  (if (= (rem (length lst) num) 0)
    (progn
      (setq ls nil)
      (repeat (/ (length lst) num)
        (repeat num
          (setq ls (cons (car lst) ls)
                lst (cdr lst)
          )
        )
        (setq ret (append
                    ret
                    (list (reverse ls))
                  )
              ls nil
        )
      )
    )
  )
  ret
)

(defun mkcir (pt r la)
  (entmakex (list '(0 . "CIRCLE") (cons 8 la) (cons 10 pt) (cons 40 r)
                  (cons 62 2)
            )
  )
)
(defun mid (p1 p2)
  (mapcar
    (function (lambda (e1 e2)
                (* (+ e1 e2) 0.5)
              )
    )
    p1
    p2
  )
)

aimisiyou

cable2004 发表于 2016-10-23 10:51

友情提示，试试运行半径500、等分40，尖角50的情况。好像当等分数为4的倍数时，会出现不符合要求的图形。

newer

cable2004 发表于 2016-10-23 10:51

等分数20的时候，出现这样的图形。再修改下代码。

st788796

首先这是一个对称图形，只要求1/4的点即可，圆心和半径及高度就可以求点

newer

st788796 发表于 2016-10-23 14:03

ST，试着写个代码啊，看下不同的算法。

cable2004

精度的问题已修改！再看看！

newer

aimisiyou 发表于 2016-10-23 12:15

这个能不能用 递归  写出来？ 试试？

newer

cable2004 发表于 2016-10-23 14:10

可以了，厉害。希望更多的朋友参与，看到不同的算法。

st788796

newer 发表于 2016-10-23 14:17

感觉只要有第一象限就都有了, 基准就是水平的直径

st788796

论坛的代码手机版(标准版)原来的功能还够用，升级后不成了，标准版没了，触屏版没有编辑功能

newer

st788796 发表于 2016-10-23 16:14

是指 贴 代码 吗？ [code... 这个？

st788796

newer 发表于 2016-10-23 16:19

手机版下面的"标准版"，功能够用，现在这个"标准版"飞了！

st788796

现在只能用"触屏版"和"电脑版"