Weihnachtsgeschenk: Bool'sche Operationen für Polylinien (Autodesk/Lisp)

Mein Weihnachtsgeschenk an die Lisp-Gemeinde ist dieses Jahr dieses ebenso kleine wie nützliche Programm. Man kann damit Bool'sche Operationen über Polylinien bilden, d.h. man bekommt für zwei oder mehrere Polylinien eine (oder auch mehrere) Polylinie(n), die alle vereinigt, oder bei der eine oder mehrere von einer Polylinie subtrahiert wird, oder die Schnittmenge von Polylinien.

Das Programm sollte mit allen AutoCAD-Versionen ab 2000 und mit BricsCAD ab V10 lauffähig sein. Viel Spaß damit.

Tom Berger

Code:

;;;***************************************************************************
;;;************* START BOOLEAN ***********************************************
;;;***************************************************************************
;;; Bool'sche Operationen für geschlossene Polylinien. Das Programm
;;; arbeitet mit dem ACIS Modellierer, indem es die Polylinien erst in
;;; Regionen umwandelt, dann die Operationen darüber ausübt, die Ergebnisse mit
;;; EXPLODE auflöst, und die Restergebnisse wieder zu Polylinien zusammen
;;; fügt.
;;;
;;; Die ursprünglichen Polylinien werden nicht zerstört.
;;;
;;; Es findet keine Prüfung statt, ob die Polylinien geschlossen sind, oder
;;; ob sie kurvenangeglichen sind.
;;;
;;; Die Hauptfunktionen sind:
;;; - (BOOLEAN-UNION <Liste von PLs>;)
;;; - (BOOLEAN-SUBTRACT <Ename einer PL> <Ename oder Liste mehrerer PLs>;)
;;; - (BOOLEAN-INTERSECT <Liste von PLs>;)
;;; Jede Funktion gibt die aus der Operation erzeugten Entities als
;;; Rückgabewert zurück.
;;;
;;; (c) 2011 Tom Berger
;;; Erlaubnis zur freien Nutzung und Weiterverbreitung nur erlaubt
;;; mit Urheberrechtshinweis
;;;***************************************************************************

;; von einer Polylinie wird entweder eine einzelne andere subtrahiert,
;; oder eine Liste von Subtrahenden
(defun boolean-subtract (pl1 l-pl / lastent en r1 l-r regionset explodeset)
(setq lastent (entlast))
(setq r1 (polyline->region pl1))
(if (= 'ENAME (type l-pl))
(setq l-pl (list l-pl))
)
;;
(setq l-r (mapcar 'polyline->region l-pl))
(if (and r1 l-r)
(command "._subtract" (ssadd r1) "" (list->ss l-r) "")
)
(if (not (equal lastent (entlast)))
(progn
(command "._explode" (entlast))
;;
(while (setq regionset (new-entities lastent '("REGION")))
(foreach en regionset
(if (= "REGION" (cdr (assoc 0 (entget en))))
(command "._explode" en)
)
)
)
;;
(while (setq explodeset (new-entities lastent '("LINE" "ARC")))
(command "._pedit" (car explodeset) "_y" "_j" (list->ss (cdr explodeset)) "" "")
)
)
)
(newset lastent)
)

;; Liste von Polylinien wird vereinigt
(defun boolean-union (l-pl / lastent en l-r regionset explodeset)
(setq lastent (entlast))
(if (= 'ENAME (type l-pl))
(setq l-pl (list l-pl))
)
;;
(setq l-r (mapcar 'polyline->region l-pl))
(if l-r
(command "._union" (list->ss l-r) "")
)
(if (not (equal lastent (entlast)))
(progn
(command "._explode" (entlast))
;;
(while (setq regionset (new-entities lastent '("REGION")))
(foreach en regionset
(if (= "REGION" (cdr (assoc 0 (entget en))))
(command "._explode" en)
)
)
)
;;
(while (setq explodeset (new-entities lastent '("LINE" "ARC")))
(command "._pedit" (car explodeset) "_y" "_j" (list->ss (cdr explodeset)) "" "")
)
)
)
(newset lastent)
)

;; Schnitt-Poly einer Liste von Polylinien
(defun boolean-intersect (l-pl / lastent en l-r regionset explodeset)
(setq lastent (entlast))
(if (= 'ENAME (type l-pl))
(setq l-pl (list l-pl))
)
;;
(setq l-r (mapcar 'polyline->region l-pl))
(if l-r
(command "._intersect" (list->ss l-r) "")
)
(if (not (equal lastent (entlast)))
(progn
(command "._explode" (entlast))
;;
(while (setq regionset (new-entities lastent '("REGION")))
(foreach en regionset
(if (= "REGION" (cdr (assoc 0 (entget en))))
(command "._explode" en)
)
)
)
;;
(while (setq explodeset (new-entities lastent '("LINE" "ARC")))
(command "._pedit" (car explodeset) "_y" "_j" (list->ss (cdr explodeset)) "" "")
)
)
)
(newset lastent)
)
(defun polyline->region (pl / lastent cpl)
(setq lastent (entlast))
(command "._copy" (ssadd pl) "" '(0 0 0) '(0 0 0))
(if (not (equal lastent (entlast)))
(progn
(setq cpl (entlast))
(command "._region" cpl "")
)
)
(if (and cpl (entget cpl))
(entdel cpl)
)
(if (equal lastent (entlast))
nil
(entlast)
)
)
(defun new-entities (en typelist / nset space el)
(setq typelist (mapcar 'strcase typelist))
(if en
(progn (setq space (assoc 410 (entget en)))
(while (and (setq en (entnext en)) (setq el (entget en)) (equal space (assoc 410 el)))
(if (member (cdr (assoc 0 (entget en))) typelist)
(setq nset (cons en nset))
)
)
)
)
(reverse nset)
)
(defun newset (en / nset space el)
(if en
(progn (setq space (assoc 410 (entget en)))
(while (and (setq en (entnext en)) (setq el (entget en)) (equal space (assoc 410 el)))
(if (member (cdr (assoc 0 (entget en))) '("VERTEX" "SEQEND"))
nil
(setq nset (cons en nset))
)
)
)
)
nset
)
(defun list->ss (eset / sset x)
(setq sset (ssadd))
(if (= 'LIST (type eset))
(mapcar '(lambda (x)
(if (= 'ENAME (type x))
(setq sset (ssadd x sset))
)
)
eset
)
)
sset
)
(defun ss->list (sset / eset counter)
(setq counter 0)
(if (= 'PICKSET (type sset))
(repeat (sslength sset)
(setq eset (cons (ssname sset counter) eset)
counter (1+ counter)
)
)
)
eset
)
;;;************* ENDE BOOLEAN ************************************************
;;;***************************************************************************

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP