关于多段线的有趣有挑战性的问题 - AutoLISP/Visual LISP 编程技术 - AutoCAD论坛 - 明经CAD社区 - 第2页

无痕发表于 2004-3-11 07:51:00

如果有弧段还是差一点啊

龙龙仔 发表于 2004-3-11 12:24:00

本帖最后由作者于 2004-3-11 17:07:54 编辑 alin发表于2004-3-11 6:43:00static/image/common/back.gif;

;;對圓弧還是不行!! ;;By 龍龍仔(LUCAS) ;;程序未優化 (defun massoc_t (key alist /) (apply 'append (mapcar '(lambda (x) (if (eq (car x) key) (list (cdr x)) ) ) alist ) ) )
(defun scanpol (ent / lst pt enti) (setq lst nil enti ent ) (while (/= "SEQEND" (cdr (assoc 0 (entget (setq enti (entnext enti))))) ) (setq pt (cdr (assoc 10 (entget enti))) lst (cons pt lst) ) ) (reverse lst) )
(defun getboundingbox (ent / ll ur) (vla-getboundingbox (vlax-ename->vla-object ent) 'll 'ur) (mapcar 'vlax-safearray->list (list ll ur)) )
(defun inter (pl1 pl2 mode / ipts pts) (setq ipts (vla-intersectwith (vlax-ename->vla-object pl1) (vlax-ename->vla-object pl2) mode ) ipts (vlax-variant-value ipts) ) (if (> (vlax-safearray-get-u-bound ipts 1) 0) (progn (setq ipts (vlax-safearray->list ipts) ) (while (> (length ipts) 0) (setq pts (cons (list (car ipts) (cadr ipts) (caddr ipts) ) pts ) ipts (cdddr ipts) ) ) ) ) pts )
(defun tt (ent / etype) (setq etype (cdr (assoc 0 (entget ent)))) (cond ((= "LWPOLYLINE" etype) (massoc_t 10 (entget ent)) ) ((= "POLYLINE" etype) (scanpol ent) ) ) )
(defun c:ttt (/ holdosmode dist1 dist dist2 ent box ent1 lst2 lst n pt pt2 pt1 lst3 p1 p2 l1 ) (command "_.UNDO" "GROUP") (setq holdosmode (getvar "OSMODE")) (setvar "OSMODE" 0) (setq ent (car (entsel))) (setq box (getboundingbox ent)) ;;(vl-cmdf ".RECTANG" (car box) (cadr box)) (setq dist (abs (- (caar box) (caadr box)))) (command "_.COPY" ent "" "0,0" (polar '(0 0) 0.0 dist)) (setq ent1 (entlast)) (command "_.LINE" (cadr box) (polar (cadr box) (* 0.5 pi) 10.0) "" ) (setq l1 (entlast)) (setq lst1 (inter l1 ent acextendthisentity));對圓弧找不到交點??? (setq lst (inter l1 ent1 acextendthisentity);對圓弧找不到交點??? n 0 dist1 1E99 ) (command "_.ERASE" l1 "") (setq lst (append lst (tt ent1))) (repeat (length lst) (setq pt (nth n lst) dist2 nil ) (if (= (length pt) 2) (setq pt (list (car pt) (cadr pt) 0.0)) ) (command "_.LINE" pt (polar pt 0 10.0) "" ) (setq lst2 (inter (entlast) ent acextendthisentity)) (setq pt2 (vl-sort lst2 '(lambda (p1 p2) (> (car p1) (car p2))) ) ) (command "_.ERASE" (entlast) "") (if (not (equal (nth 0 pt2) pt)) (setq dist2 (abs (distance (nth 0 pt2) pt))) (setq dist2 0) ) (if (and dist2 (> dist1 dist2) ) (setq dist1 dist2) ) (setq n (1+ n)) ) (setq lst1 (append lst1 (tt ent)) n 0 ) (repeat (length lst1) (setq pt (nth n lst1) dist2 nil ) (if (= (length pt) 2) (setq pt (list (car pt) (cadr pt) 0.0)) ) (command "_.LINE" pt (polar pt pi 10.0) "" ) (setq lst2 (inter (entlast) ent1 acextendthisentity)) (setq pt2 (vl-sort lst2 '(lambda (p1 p2) (< (car p1) (car p2))) ) ) (command "_.ERASE" (entlast) "") (if (not (equal (nth 0 pt2) pt)) (setq dist2 (abs (distance (nth 0 pt2) pt))) (setq dist2 0) ) (if (and dist2 (> dist1 dist2) ) (setq dist1 dist2) ) (setq n (1+ n)) ) (command "_.MOVE" ent1 "" "0,0" (polar '(0 0) pi dist1)) (command "_.UNDO" "END") (setvar "OSMODE" holdosmode) (princ) )

龙龙仔 发表于 2004-3-12 08:16:00

match.vlx測試,type match執行

秋枫发表于 2004-3-14 18:56:00

我感觉这个要求类似服装CAD系统的计算机自动布料系统所需要的。

各位有没有服装CAD软件推荐？有没有基于AutoCAD的服装CAD软件？

南子发表于 2004-3-16 12:40:00

1.重合问题,比如矩形偏移

2.交点问题.我们知道点是没有大小的,但又确实存在.比如两条十字线,您剪掉右边线,那么您就无法剪掉左边线.

BDYCAD 发表于 2004-4-23 11:50:00

正如14樓秋楓所說. 我想做一個自動排料系統. 以下是我寫的代碼. 希望可以完善.

我需要自動排的效果如下圖所示

目前程序完成的效果如下圖所示

程序代碼如下.

測試圖如下

龙龙仔 发表于 2004-4-23 12:34:00

自動排是不太可能,半自動一次兩件兩件靠近是可以,類似我提供那種,有需要的話(說一聲)我可以改一下

BDYCAD 发表于 2004-4-23 12:50:00

其實我以前看了你的程序后我就開始想寫一個這樣的功能哦. 我上午看了很久你上面的程序. 不同點是我處理的全是SPLINE曲線 . 你運用的多是VL我有很多看不懂. 現在還是不明明白如何用你上面的去改進. 還望多多指教呢. 還有希望可以看到你是如何實現半自動的. 好吧就先行謝謝您了. 呵呵 : )

龙龙仔 发表于 2004-4-23 14:32:00

BDYCAD:<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:office:office" /><o:p></o:p>

先發個vlx函數給你使用!<o:p></o:p>

;;By 龍龍仔(LUCAS)<o:p></o:p>

;;注意:<指定基準點>靠近移動件,<指定位移方向>指向不動件<o:p></o:p>

;;當兩件沒有接觸點,程序會..........無法停止(按ESC吧!)<o:p></o:p>

;;Usage:(match <選取不動件> <選取移動件> <指定基準點> <指定位移方向>)<o:p></o:p>

(defun C:TT (/ ENT ENT1 PT1 PT2)<o:p></o:p>

 (while (not (setq ENT (car (entsel "\n選取不動件: ")))))<o:p></o:p>

 (while (not (setq ENT1 (car (entsel "\n選取移動件: ")))))<o:p></o:p>

 (setq PT1 (getpoint "\n指定基準點: "))<o:p></o:p>

 (setq PT2 (getpoint PT1 "\n指定位移方向第二點: "))<o:p></o:p>

 (MATCH ENT ENT1 PT1 PT2)<o:p></o:p>

 (princ)<o:p></o:p>

)<o:p></o:p>

zoe 发表于 2004-4-26 19:59:00

14楼所说的正是我现在最需要的，大家可以帮帮忙吗？

页: 1 [2] 3

明经CAD社区's Archiver