;;;; TAILORS ;;;; Zusatzmodul für AutoCAD R14, AutoCAD 2000, IntelliCAD 2000 ;;;; Funktionen NÄHEN, SCHNEIDEN, WANDELN, WENDEN, RÜCKSEITE, ;;;; ENTFALTEN ;;;; ;;;; März 2001 Armin Antkowiak, Berlin [info@polyface.de] ;;;; Freie Software [GNU GPL 2+]; ;;;; siehe License.txt , LiesMich.txt , installieren.html ;;;; Modifikationen gegenüber der Version April 2000 ;;;; siehe History.txt ;;;; TAILORS ;;;; function set for AutoCAD R14, AutoCAD 2000, IntelliCAD 2000 ;;;; including functions SEW, XSLICE, LIFT, FLIP, BACKFACE, UNFOLD ;;;; ;;;; March 2001 Armin Antkowiak, Berlin [info@polyface.de] ;;;; Free software [GNU GPL 2+]; ;;;; see License.txt , ReadMe.txt , install.html ;;;; Modifications of the April 2000 version listed in History.txt (if (not (or (wcmatch (ver) "*14*") (wcmatch (ver) "*2000*") (equal (ver) "LISP Release 1.0") ) ) (princ (if (wcmatch (ver) "*(de)") (strcat "\nDiese Software wurde für AutoCAD 14, AutoCAD 2000" " und IntelliCAD 2000 entwickelt." "\nDa Sie ein anderes Programm benutzen," " können Fehler auftreten." ) (strcat "\nThis software was developed" " for AutoCAD 14, AutoCAD 2000, and IntelliCAD 2000." "\nErrors may occur" " because you are using a different program." ) ) ) ) ;_____________________________________________________________________; ;;; Funktion NÄHEN ;;; fügt ein 3d-Polyflächennetz aus gewählten Objekten zusammen. ;;; ;;; Es können Punkte, Linien, 3d-Flächen, ;;; Polygonnetze und Polyflächennetze zusammengefasst werden. ;;; Diese müssen nicht notwendigerweise in räumlichem Zusammenhang ;;; stehen [sie brauchen keine gemeinsamen Eckpunkte, ;;; Kanten oder Flächen zu besitzen]; ;;; ein solcher Zusammenhang wird auch nicht hergestellt. ;;; Alle Komponenten bleiben an ihrer Position. ;;; ;;; Dem erzeugten Netz wird der Layer und die Farbe des ;;; zuerst ausgewählten Objekts zugewiesen ;;; [analog zum AutoCAD-14-Befehl "Vereinig" für Volumenkörper ;;; und zum Befehl "Pedit" für Polylinien]. ;;; ;;; Es können nur Elemente ausgewählt werden, ;;; die keine Objekthöhe besitzen. ;;; Die Anzahl der Teilobjekte für ein Polyflächennetz ist gewissen ;;; Beschränkungen unterworfen. ;;; ;;; Ein Polyflächennetz kann mittels "Ursprung" in seine Bestandteile ;;; zerlegt werden, d. h. in Punkte, Linien und 3d-Flächen. (defun c:nähen ( / s ; Auswahlsatz der zusammenzunähenden Objekte s# ; Anzahl der ausgewählten Objekte f# ; Anzahl aller zusammenzufügenden Teilobjekte ; [Flächen, Linien, Punkte] i# ; Index des aktuell bearbeiteten Objekts id ; Elementdatenliste des aktuell bearbeiteten Objekts it ; Typ des aktuell bearbeiteten Objekts i1 i2 ; Polygonnetz: M- / N-Wert ; [Anzahl der Scheitelpunkte pro Spalte bzw. Zeile] ; Polyflächennetz: ; Anzahl der Scheitelpunkte / Teilobjekte v< ; maximal zu erwartende Anzahl der Scheitelpunkte wm ; warnende Botschaft ; [wird ausgegeben, wenn die Anzahl der Teilobjekte ; und Scheitelpunkte kritische Höhen erreicht] wn ; identifizierende Nummer der geladenen Dialogfelddatei wr ; Benutzerreaktion auf die Warnung wh ; Name und vollständiger Pfad der HTML-Hilfe-Datei tt ; temporäres Testflag r14 ; Flag: Release 14 ger ; Flag: deutsche Version tol ; Toleranz echo ; Systemvariable "cmdecho" [command echo] errr ; systemeigene Fehlerbearbeitungs-Routine ) (standardInitiate) (sewSelect) (sewProcess) (standardTerminate) ) ;;; Function SEW ;;; creates a 3D polyface mesh composed of selected objects. ;;; ;;; Points, lines, 3D faces, polygon meshes and polyface meshes ;;; can be associated. ;;; They don't necessarily have to be in spacial connection ;;; [they do not need to share a common corner, edge, or area]; ;;; such a connention will not be generated by this function. ;;; All components stay on their positions. ;;; ;;; The first selected object determines layer and color ;;; of the mesh created ;;; [similar to AutoCAD 14 "union" command for 3D solids ;;; and "pedit" command for polylines]. ;;; ;;; Objects with a non-zero thickness cannot be selected. ;;; The number of components of a polyface mesh is limited. ;;; ;;; The "explode" command dismantles a polyface mesh ;;; into its components, i. e. points, lines, and 3D faces. (defun c:sew ( / s ; selection set s# ; number of objects selected f# ; number of components to assemble [faces, lines, points] i# ; index of object currently worked on id ; entity data list it ; type of entity i1 i2 ; polygon mesh: M and N value ; [number of vertices per column and per row] ; polyface mesh: number of vertices and components v< ; maximum expected number of vertices wm ; warning message ; [will be launched if critical number ; of vertices or components is reached] wn ; identification number of dialog box file loaded wr ; user's response to warning wh ; name and path of HTML help file tt ; temporary test flag r14 ; flag: release 14 ger ; flag: German version tol ; tolerance echo ; "cmdecho" system variable [command echo] errr ; system's error handling routine ) (standardInitiate) (sewSelect) (sewProcess) (standardTerminate) ) ;;; Unterprogramme 1. Ordnung für NÄHEN ;;; 1st order subroutines for SEW (defun sewSelect ( ) ; The following variables declared in the main routine ; are used within this subroutine: ; get: ger ; set: s s# tt (setq tt t) (while tt (princ (if ger (strcat " - Punkte, Linien," " 3d-Flächen, Polygonnetze, Polyflächennetze -" ) (strcat " - points, lines," " 3D faces, polygon meshes, polyface meshes -" ) ) ) (setq s (ssget '( (-4 . "") (-4 . "") (-4 . "") (-4 . "") (-4 . "") (-4 . "") (-4 . "") (-4 . "") (-4 . "") (-4 . "") (-4 . "") (-4 . "") (-4 . "") (-4 . "") (-4 . "") (-4 . "") (-4 . "") (-4 . "") ; IntelliCAD does not work correctly (-4 . "or>") ; with (-4 . "&") (70 . 80) (39 . 0.0) ; zero thickness ) ) ) (if s (setq s# (sslength s) tt nil ) (princ (if ger "\nEs wurde keine gültige Auswahl getroffen." "\nNo valid selection made." ) ) ) ) ) (defun sewProcess ( ) ; The following variables declared in the main routine ; are used within this subroutine: ; get: s s# ger ; set: v< f# i# id it i1 i2 wm wn wh wr r14 (setq r14 (wcmatch (ver) "*14*")) (if (< 32767 s#) (princ (if ger (strcat "\n" (itoa s#) " Objekte können nicht zusammengefügt werden" " (maximal 32767)." ) (strcat "\n" (itoa s#) " objects cannot be sewn together" " (not more than 32767)." ) ) ) (progn (princ "\n") (setq f# 0 v< 0 i# 0 ) (while (> s# i#) (setq id (entget (ssname s i#)) it (cdr (assoc 0 id)) i# (1+ i#) ) (cond ( (= "POLYLINE" it) ; polygon mesh or polyface mesh (if (zerop (logand 4 (setq it (cdr (assoc 70 id))))) (setq i1 (cdr (assoc 71 id)) ; not surface fit i2 (cdr (assoc 72 id)) ) (setq i1 (cdr (assoc 73 id)) ; surface fit i2 (cdr (assoc 74 id)) ) ) (if (zerop (logand 64 it)) (setq ; polygon mesh f# (+ f# (* (if (zerop (logand 1 it)) (1- i1) ; M open i1 ; M closed ) (if (zerop (logand 32 it)) (1- i2) ; N open i2 ; N closed ) ) ) v< (+ v< (* i1 i2)) ) (setq ; polyface mesh f# (+ f# i2) v< (+ v< (min i1 (lsh i2 2))) ) ; four vertices per face at most ) ) ( (= "3DFACE" it) (setq f# (1+ f#) v< (+ 4 v<) ) ) ( (= "LINE" it) (setq f# (1+ f#) v< (+ 2 v<) ) ) ( t ; (= "POINT" it) (setq f# (1+ f#) v< (1+ v<) ) ) ) ) (cond ( (< 32767 f#) ; too many components (princ (if ger (strcat "Ein Polyflächennetz mit " (itoa f#) " Teilen kann nicht erstellt werden" " (maximal 32767)." ) (strcat "Cannot assemble " (itoa f#) " components to a polyface mesh" " (not more than 32767)." ) ) ) ) ( (< 32767 v<) ; possibly too many vertices (setq wm (if ger (strcat " " (itoa f#) " Teile sollen zusammengefügt werden.\n" " Das kann mehrere Stunden dauern.\n" " Es wird misslingen," " falls das entstehende Netz\n" " mehr als 32767 verschiedene" " Scheitelpunkte besitzt.\n\n" " Soll es trotzdem versucht werden?" ) (strcat " " (itoa f#) " components have to be assembled.\n" " This process may take several hours.\n" " It will fail if the arising mesh\n" " has more than 32767 different vertices.\n\n" " Start a try?" ) ) ) (if (and (findfile ; IntelliCAD requires this (if ger "Tailors/Deutsch/Schneiderei.dcl" "Tailors/English/Tailors.dcl" ) ) (< 0 (setq wn (load_dialog (if ger "Tailors/Deutsch/Schneiderei.dcl" "Tailors/English/Tailors.dcl" ) ) ) ) (new_dialog "warning" wn) ) (progn ; dialog box initiated successfully (set_tile "message" wm) (if (setq wh (findfile (if ger "Tailors/Deutsch/Hilfe/netz.html" "Tailors/English/Help/mesh.html" ) ) ) (action_tile "help" "(done_dialog 2)") (mode_tile "help" 1) ; help file not found ) (action_tile "yes" "(done_dialog 1)") (mode_tile (if (< 16383 f#) "no" "yes") 2) (setq wr (start_dialog)) (unload_dialog wn) (cond ( (= 2 wr) ; "help" (command (if (equal (ver) "LISP Release 1.0") "_.url" ; IntelliCAD "_.browser" ; AutoCAD ) wh ) ) ( (= 1 wr) ; "yes" (sewProcessSet s f# v<) ) ( t ; "no" nil ) ) ) (progn ; dialog box initiation failed (initget (if ger "Ja Nein _Yes No" "Yes No")) (textscr) (terpri) (princ wm) (if (< 16383 f#) (progn (setq wr (getkword (if r14 (if ger "\n Ja/ : " "\n Yes/ : " ) (if ger "\n [Ja/Nein] : " "\n [Yes/No] : " ) ) ) ) (if (not wr) (setq wr "No")) ) (progn (setq wr (getkword (if r14 (if ger "\n /Nein : " "\n /No : " ) (if ger "\n [Ja/Nein] : " "\n [Yes/No] : " ) ) ) ) (if (not wr) (setq wr "Yes")) ) ) (terpri) (graphscr) (if (= "Yes" wr) (sewProcessSet s f# v<)) ) ) ) ( t ; neither too many components nor too many vertices (sewProcessSet s f# v<) ) ) ) ) ) ;;; Unterprogramm 2. Ordnung für sewProcess ;;; [wird auch von xsliceProcessMesh aufgerufen] ;;; 2nd order subroutine for sewProcess ;;; [also called by xsliceProcessMesh] (defun sewProcessSet ( s ; Auswahlsatz der zusammenzunähenden Objekte f# ; Anzahl aller zusammenzufügenden Teilobjekte ; [Flächen, Linien, Punkte] v< ; maximal zu erwartende Anzahl der Scheitelpunkte / s# ; Anzahl der Objekte im Auswahlsatz i# ; Index des aktuell bearbeiteten Objekts in ; Elementname des aktuell bearbeiteten Objekts id ; Elementdatenliste des aktuell bearbeiteten Objekts it ; Typ des aktuell bearbeiteten Objekts ie ; Bitcode: Sichtbarkeit der Kanten i1 i2 ; für Polygonnetz: M- und N-Wert ; [Anzahl der Scheitelpunkte pro Spalte bzw. Zeile] ; für Polyflächennetz: ; Anzahl der Scheitelpunkte und Teilobjekte j1 j2 ; für Polygonnetz: Index der aktuell bearbeiteten ; Zeile bzw. Spalte ; für Polyflächennetz: Index des aktuell bearbeiteten ; Scheitelpunkts bzw. Teilobjekts mo no ; Flags: Polygonnetz ist M-offen bzw. N-offen v^ ; Liste aller Scheitelpunkte v* ; Teilliste der Scheitelpunkte, die noch nicht mit dem ; aktuell bearbeiteten Punkt verglichen wurden v# ; Anzahl der Scheitelpunkte v% ; Anzahl der bisher bearbeiteten Punkte j# ; Index des aktuell bearbeiteten Scheitelpunkts cc ; aktuell bearbeiteter Punkt fr ; Liste der Scheitelpunkt-Zuordnungen ; für das aktuell bearbeitete Objekt bzw. Teilobjekt ff ; Liste der Scheitelpunkt-Zuordnungen ; für alle Zeilen eines Polygonnetzes f- ; Liste der Scheitelpunkt-Zuordnungen für die erste ; der aktuell bearbeiteten Zeilen eines Polygonnetzes f= ; Liste der Scheitelpunkt-Zuordnungen für die zweite ; der aktuell bearbeiteten Zeilen eines Polygonnetzes f1 f2 ; Scheitelpunkt-Zuordnungen für die Eckpunkte f3 f4 ; der aktuell bearbeiteten Teilfläche eines Netzes f^ ; Liste der Scheitelpunkt-Zuordnungen ; für alle Teilobjekte [Flächen, Linien, Punkte] hc ; Datengruppe: ; Farbe des ersten ausgewählten Teilobjekts hd ; Datenliste: ; Layer und Farbe des ersten ausgewählten Teilobjekts ) ;| s ; selection set of objects to be sewn together f# ; total number of components to be sewn together ; [faces, lines, points] v< ; maximum number of vertices anticipated / s# ; number of objects in selection set i# ; index of object currently worked on in ; entity name id ; entity data list it ; type of entity ie ; bit code: visibility of edges i1 i2 ; concerning a polygon mesh: M and N value ; [number of vertices per column and per row] ; concerning a polyface mesh: ; number of vertices and components j1 j2 ; concerning a polygon mesh: ; index of current row and column ; concerning a polyface mesh: ; index of current vertex and component mo no ; flags: polygon mesh is open in M / N direction v^ ; list of all vertices v* ; sublist of all vertices ; that have not been compared with current point yet v# ; total number of vertices v% ; number of points compared already j# ; index of current vertex cc ; current point fr ; face record [list of vertex assignments] ; for current component ff ; list of face records for all rows of a polygon mesh f- ; list of face records for the ; first of the polygon mesh rows currently worked on f= ; list of face records for the ; second of the polygon mesh rows currently worked on f1 f2 ; vertex assignments for the corners f3 f4 ; of a mesh component currently worked on f^ ; list of face records for all components ; [faces, lines, points] hc ; data group: color of first selected component hd ; data list: layer and color of first selected component |; ; The following variable declared in the main routines ; is used within this subroutine: ; get: ger ;; Verarbeitung ;; Processing (setq s# (sslength s) v# 0 v% 0 i# 0 ) (while (> s# i#) (setq in (ssname s i#) id (entget in) it (cdr (assoc 0 id)) i# (1+ i#) fr nil ) (cond ( (= "POLYLINE" it) (if (zerop (logand 4 (setq it (cdr (assoc 70 id))))) (setq i1 (cdr (assoc 71 id)) ; not surface fit i2 (cdr (assoc 72 id)) ) (setq i1 (cdr (assoc 73 id)) ; surface fit i2 (cdr (assoc 74 id)) in (entnext in) ; leap over first frame point ) ; standing between header and ) ; fit points (if (zerop (logand 64 it)) (progn ; polygon mesh (setq mo (zerop (logand 1 it)) no (zerop (logand 32 it)) ff nil ie 0 j1 0 ) (while (> i1 j1) (setq j1 (1+ j1) j2 0 ) (while (> i2 j2) (setq j2 (1+ j2) in (entnext in) id (entget in) ) (foreach kn '(10) (sewProcessTestVertex)) ) (setq ff (cons (if no fr (cons (last fr) fr)) ff) fr nil ) ) (if (not mo) (setq ff (cons (last ff) ff))) (while (setq f- (car ff) ff (cdr ff) f= (car ff) ) (while (setq f3 (car f-) f2 (car f=) f- (cdr f-) ) (setq f= (cdr f=) f4 (car f-) f1 (car f=) f^ (cons (list f4 f3 f2 f1) f^) ) ) ) ) (progn ; polyface mesh (setq ie 0 j1 i1 ) (while (< 0 j1) (setq j1 (1- j1) in (entnext in) id (entget in) ) (foreach kn '(10) (sewProcessTestVertex)) ) (while (> i2 j1) (setq j1 (1+ j1) in (entnext in) id (entget in) f1 (cdr (assoc 71 id)) f2 (cdr (assoc 72 id)) f3 (cdr (assoc 73 id)) f4 (cdr (assoc 74 id)) f^ (cons (list (cond ( (zerop f4) 0 ) ( (minusp f4) (- (nth (+ i1 f4) fr)) ) ( t (nth (- i1 f4) fr) ) ) (cond ( (zerop f3) 0 ) ( (minusp f3) (- (nth (+ i1 f3) fr)) ) ( t (nth (- i1 f3) fr) ) ) (cond ( (zerop f2) 0 ) ( (minusp f2) (- (nth (+ i1 f2) fr)) ) ( t (nth (- i1 f2) fr) ) ) (cond ( (zerop f1) 0 ) ( (minusp f1) (- (nth (+ i1 f1) fr)) ) ( t (nth (- i1 f1) fr) ) ) ) f^ ) ) ) ) ) ) ( (= "3DFACE" it) (setq ie (cdr (assoc 70 id))) (foreach kn '(10 11 12 13) (sewProcessTestVertex)) (setq f^ (cons fr f^)) ) ( (= "LINE" it) (setq ie 0) (foreach kn '(10 11) (sewProcessTestVertex)) (setq f^ (cons (cons 0 (cons 0 fr)) f^)) ) ( t ; (= "POINT" it) (setq ie 0) (foreach kn '(10) (sewProcessTestVertex)) (setq f^ (cons (cons 0 (cons 0 (cons 0 fr))) f^)) ) ) ) ;; Ausgabe ;; Output (if (< 32767 v#) (princ (if ger (strcat "\015" " Ein Polyflächennetz mit " (itoa v#) " Scheitelpunkten kann nicht erstellt werden" " (maximal 32767)." ) (strcat "\015" " Cannot create a polyface mesh with " (itoa v#) " vertices (not more than 32767)." ) ) ) (progn (setq id (entget (ssname s 0)) hc (assoc 62 id) hd (cons (assoc 8 id) (if hc (list hc))) ) ; layer and color of the mesh should correspond (entmake ; to the first of the selected objects (append '((0 . "POLYLINE")) hd (list '(66 . 1) ; "vertex entities follow" flag '(10 0.0 0.0 0.0) ; "dummy" point '(70 . 64) ; "polyface mesh" (cons 71 v#) ; number of vertices (cons 72 f#) ; number of faces ) ) ) (setq j# v#) (while (< 0 j#) (setq j# (1- j#)) (entmake (append '((0 . "VERTEX")) hd ; layer and color (list (cons 10 (nth j# v^)) ; vertex coordinates '(70 . 192) ; "polyface mesh vertex" ) ) ) ) (while (setq fr (car f^)) (setq f^ (cdr f^)) (entmake (append '((0 . "VERTEX")) hd ; layer and color (list '(10 0.0 0.0 0.0) ; "dummy" point '(70 . 128) ; "face record" (cons 71 (cadddr fr)) (cons 72 (caddr fr)) (cons 73 (cadr fr)) ; vertex assignments (cons 74 (car fr)) ; for corners of face ) ) ) ) (entmake (append '((0 . "SEQEND")) ; end of sequence hd ; layer and color ) ) (command "_.erase" s "") (if (< 62 v%) (princ "\015 \015")) ) ) ) ;;; Unterprogramm 3. Ordnung für sewProcessSet ;;; 3rd order subroutine for sewProcessSet (defun sewProcessTestVertex ( ) ; The following variables declared in the main routines ; are used within this subroutine: ; get: ger tol ; The following variables declared in the sewProcessSet ; routine are used within this subroutine: ; get: v< id ie ; kn [declared in (foreach ...) loops] ; set: v^ v% v* v# j# cc fr (if (= 63 (logand 63 v%)) (princ (if ger (strcat "\015" "Netz zu " (itoa (fix (/ (* 100.0 v% v%) v< v<))) "% fertig" ) (strcat "\015" "mesh completed to " (itoa (fix (/ (* 100.0 v% v%) v< v<))) "%" ) ) ; processing time is proportional ) ; to the squared number of vertices ) (setq cc (cdr (assoc kn id)) v% (1+ v%) v* v^ j# v# ) (while (< 0 j#) (if (equal cc (car v*) tol) ; If point is arleady contained (setq ; by vertex list, fr (cons (if (zerop (logand (lsh 1 (- kn 10)) ie)) j# (- j#) ) ; then store number of vertex fr ; in face record; ) j# -1 ) (setq j# (1- j#) v* (cdr v*) ) ) ) (if (= 0 j#) (setq v^ (cons cc v^) ; otherwise add point v# (1+ v#) ; to vertex list fr ; and store number in face record. (cons (if (zerop (logand (lsh 1 (- kn 10)) ie)) v# (- v#) ) fr ) ) ) ) ;_____________________________________________________________________; ;;; Funktion SCHNEIDEN ;;; kappt Linien, Strahlen, Konstruktionslinien, ;;; 3d-Flächen, Polygonnetze und Polyflächennetze an einer Ebene. ;;; ;;; Die Optionen entsprechen denen des AutoCAD-Befehls "Kappen" ;;; für Volumenkörper. ;;; ;;; Wenn es Objekte gibt, die zwar nicht von der Kappebene ;;; geschnitten werden, aber auf der unerwünschten Seite liegen, ;;; dann wird das Löschen dieser Objekte angeboten. ;;; ;;; Objekte mit einer von Null verschiedenen Objekthöhe ;;; können nicht ausgewählt werden. ;;; Objekte auf gesperrten Layern werden nicht geschnitten. ;;; ;;; Die geschnittenen Bestandteile eines Netzes ;;; diesseits bzw. jenseits der Kappebene werden zu jeweils ;;; einem Polyflächennetz zusammengefügt, ;;; sofern ihre Anzahl [pro Seite] nicht 8191 übersteigt. ;;; Andernfalls bleiben die Flächen, Linien bzw. Punkte ;;; als einzelne Objekte bestehen. (defun c:schneiden ( / s ; Auswahlsatz der zu kappenden Objekte u ; Satz der ausgewählten Objekte, ; die gänzlich auf der unerwünschten Seite liegen p1 p2 p3 ; Punkte, welche die Kappebene definieren nv ; Normalenvektor der Kappebene en ; Elementname des ausgewählten schneidenden Objekts ed ; Elementdatenliste des schneidenden Objekts et ; Typ des schneidenden Objekts eh ; Objekthöhe des schneidenden Objekts h* ; Nummer des Ansichtsfensters, das während des ; Markierens des schneidenden Objekts aktuell ist h~ ; Nummer des Ansichtsfensters, das bei der Seitenwahl ; aktuell ist d+ d- ; Flags: Seite mit positivem bzw. negativem Abstand ; von der Kappebene ist erwünscht s# ; Anzahl der Objekte [auf nicht gesperrten Layern] l# ; Anzahl der Objekte auf gesperrten Layern n# ; Anzahl der von der Kappebene nicht geschnittenen ; Objekte u# ; Anzahl der ganz auf der ; unerwünschten Seite liegenden Objekte i# ; Index des aktuell bearbeiteten Objekts in ; Elementname des aktuell bearbeiteten Objekts id ; Elementdatenliste des aktuell bearbeiteten Objekts it ; Typ des aktuell bearbeiteten Objekts ie ; Datengruppe: Sichtbarkeit der Kanten i0 i1 ; Datengruppen, die die Punkte bzw. Richtungsvektoren i2 i3 ; des aktuell bearbeiteten Objekts enthalten c0 c1 ; Eckpunkte der aktuell bearbeiteten 3d-Fläche c2 c3 d0 d1 ; Abstände der Punkte von der Kappebene d2 d3 d< d> ; Maximum bzw. Minimum der Abstände von der Kappebene ip iq ; Schnittpunkte mit der Kappebene ir is b ; Auswahlsatz: Teilobjekte aus Zerlegung eines Netzes b+ b- ; davon auf der positiven bzw. negativen Seite b* ; Systemvariable "splframe" ; vor dem Zerlegen des Netzes b# ; Anzahl der durch Zerlegung entstandenen Teilobjekte j# ; Index des aktuell bearbeiteten Teilobjekts jn ; Elementname des aktuell bearbeiteten Scheitelpunkts jd ; Elementdatenliste des Scheitelpunkts jt ; Datengruppe: Vertex Flags v+ v- ; maximal zu erwartende Anzahl der Scheitelpunkte ; auf der positiven bzw. negativen Seite ld ; Datenliste des aktuell überprüften Layers ll ; Liste aller gesperrten Layer der Zeichnung tt ; temporäres Testflag r14 ; Flag: Release 14 r// ; Flag: AutoCAD 14 oder IntelliCAD 2000 ger ; Flag: deutsche Version tol ; Toleranz echo ; Systemvariable "cmdecho" [command echo] errr ; systemeigene Fehlerbearbeitungs-Routine ) (regenInitiate) (xsliceSelect) (xsliceInput) (lockedFilter) (xsliceProcess) (standardTerminate) ) ;;; Function XSLICE ;;; slices lines, rays, xlines, ;;; 3D faces, polygon meshes, and polyface meshes with a plane. ;;; ;;; Options of XSLICE are similar to those of the AutoCAD "slice" ;;; command for 3D solids. ;;; ;;; If there are objects not intersected by the slicing plane ;;; but situated on the undesired side of the plane, ;;; XSLICE will offer to erase these objects. ;;; ;;; Objects with a non-zero thickness cannot be selected. ;;; Objects on locked layers do not get sliced. ;;; ;;; All the sliced mesh components on the desired side of the plane ;;; are reassembled to a polyface mesh ;;; if their total number does not exceed 8191 [per side]. ;;; Otherwise the faces, lines, and points ;;; will remain individual objects. (defun c:xslice ( / s ; selection set of objects to be sliced u ; set of selected objects situated entirely ; on the undesired side of the slicing plane p1 p2 p3 ; points defining the slicing plane nv ; normal vector of the slicing plane en ; entity name of the object selected to define ; the slicing plane ed ; entity data list of slicing object et ; type of slicing object eh ; thickness of slicing object h* ; number of viewport current when highlighting ; slicing object h~ ; number of viewport current when choosing ; desired side[s] d+ d- ; flags: side with positive or negative distance ; from slicing plane is desired s# ; number of objects [on unlocked layers] l# ; number of objects on locked layers n# ; number of objects not intersected by slicing plane u# ; number of objects situated entirely ; on the undesired side of the slicing plane i# ; index of object currently worked on in ; entity name id ; entity data list it ; type of entity ie ; data group: visibility of edges i0 i1 ; data groups containing points or direction vectors i2 i3 ; of object currently worked on c0 c1 ; corners of 3D face currently worked on c2 c3 d0 d1 ; distance of points from slicing plane d2 d3 d< d> ; maximum and minimum distances from slicing plane ip iq ; intersection points with slicing plane ir is b ; selection set: components of a dismantled mesh b+ b- ; set of components on positive and negative side b* ; "splframe" system variable before dismantling mesh b# ; number of components got by dismantling j# ; index of component currently worked on jn ; entity name of current vertex jd ; entity data list of current vertex jt ; data group: vertex flags v+ v- ; maximum number of vertices anticipated ; on positive and negative side ld ; data list of layer currently tested ll ; list of all locked layers of the drawing tt ; temporary test flag r14 ; flag: release 14 r// ; flag: AutoCAD 14 or IntelliCAD 2000 ger ; flag: German version tol ; tolerance echo ; "cmdecho" system variable [command echo] errr ; system's error handling routine ) (regenInitiate) (xsliceSelect) (xsliceInput) (lockedFilter) (xsliceProcess) (standardTerminate) ) ;;; Unterprogramme 1. Ordnung für SCHNEIDEN ;;; 1st order subroutines for XSLICE (defun xsliceSelect ( ) ; The following variables declared in the main routine ; are used within this subroutine: ; get: ger ; set: s s# tt (setq tt t) (while tt (princ (if ger (strcat " - Linien, Strahlen, Konstruktionslinien," " 3d-Flächen, Polygonnetze, Polyflächennetze -" ) (strcat " - lines, rays, xlines," " 3D faces, polygon meshes, polyface meshes -" ) ) ) (setq s (ssget '( (-4 . "") (-4 . "") (-4 . "") (-4 . "") (-4 . "") (-4 . "") (-4 . "") (-4 . "") (-4 . "") (-4 . "") (-4 . "") (-4 . "") (-4 . "") (-4 . "") (-4 . "") (-4 . "") (-4 . "") (-4 . "") ; IntelliCAD does not work correctly (-4 . "or>") ; with (-4 . "&") (70 . 80) (39 . 0.0) ; zero thickness ) ) ) (if s (setq s# (sslength s) tt nil ) (princ (if ger "\nEs wurde keine gültige Auswahl getroffen." "\nNo valid selection made." ) ) ) ) ) (defun xsliceInput ( ) ; The following variables declared in the main routine ; are used within this subroutine: ; get: ger tol ; set: en ed et eh nv p1 p2 p3 d+ d- h* h~ tt r14 (setq r14 (wcmatch (ver) "*14*")) ;; Kappebene wählen ;; Define slicing plane (initget (if ger (strcat "Objekt ZAchse Ansicht XY YX YZ ZY ZX XZ 3Punkte" " _Object Zaxis View XY YX YZ ZY ZX XZ 3points" ) "Object Zaxis View XY YX YZ ZY ZX XZ 3points" ) ) (setq p1 (getpoint (if ger (if r14 (strcat "\n" "Kappebene von " "Objekt/ZAchse/Ansicht/XY/YZ/ZX/<3Punkte>: " ) (strcat "\n" "Ersten Punkt auf der Kappebene angeben oder " "[Objekt/ZAchse/Ansicht/XY/YZ/ZX/3Punkte] " "<3Punkte>: " ) ) (if r14 (strcat "\n" "Slicing plane by " "Object/Zaxis/View/XY/YZ/ZX/<3points>: " ) (strcat "\n" "Specify first point on slicing plane by " "[Object/Zaxis/View/XY/YZ/ZX/3points] " "<3points>: " ) ) ) ) ) (if (= "Object" p1) (progn (setq tt t) (while tt (setq en (car (entsel (if ger (strcat "\n" "Zweidimensionales Objekt wählen," " das die Kappebene definiert: " ) (strcat "\n" "Select a two-dimensional object" " defining slicing plane: " ) ) ) ) ) (if en (progn (setq ed (entget en) et (cdr (assoc 0 ed)) ) (if (and (or (= "CIRCLE" et) (= "ARC" et) (= "ELLIPSE" et) (= "LWPOLYLINE" et) (and (= "POLYLINE" et) (= 0 (logand 88 (cdr (assoc 70 ed)))) ) ; no 3D polylinie, no mesh (and (= "SPLINE" et) (= 8 (logand 24 (cdr (assoc 70 ed)))) ) ; planar non-linear spline only ) (if (setq eh (cdr (assoc 39 ed))) (= 0.0 eh) ; zero thickness t ; if group 39 exists ) ) (setq tt nil) ; selection succeeded (princ (if ger (strcat "\n" "Ungültige Auswahl;" " Ebene kann nicht extrahiert werden." ) (strcat "\n" "Unable to extract the plane" " of the selected object." ) ) ) ) ) (princ (if ger "\nEs wurde nichts ausgewählt." "\nNothing selected." ) ) ) ) (redraw en 3) ; highlight selected slicing object (setq h* (getvar "cvport") nv (cdr (assoc 210 ed)) ; extrusion direction in WCS p1 (trans (if (= "LWPOLYLINE" et) (list (cadr (assoc 10 ed)) ; first vertex (caddr (assoc 10 ed)) ; as 2D point in OCS; (cdr (assoc 38 ed)) ; elevation in ) ; OCS Z direction (cdr (assoc 10 ed)) ; other types: center, ) ; first control point or en ; "dummy" as 3D point in OCS 0 ; translate from OCS into WCS ) ) ) (progn (cond ( (= "Zaxis" p1) (initget 1) ; not just "Enter" (setq p1 (trans (getpoint (if ger (if r14 "\nPunkt auf der Kappebene: " (strcat "\n" "Punkt auf der Kappebene angeben: " ) ) (if r14 "\nPoint on slicing plane: " (strcat "\n" "Specify a point " "on the slicing plane: " ) ) ) ) 1 0 ) tt t ) (while tt (initget 1) ; not just "Enter" (setq p2 (trans (getpoint (trans p1 0 1) (if ger (if r14 (strcat "\n" "Punkt auf der z-Achse " "(Normale zur Kappebene): " ) (strcat "\n" "Punkt auf der z-Achse " "(Normale zur Kappebene) " "angeben: " ) ) (if r14 (strcat "\n" "Point on Z-axis " "(normal) of the plane: " ) (strcat "\n" "Specify a point on the Z-axis " "(normal) of the plane: " ) ) ) ) 1 0 ) nv (normalize (mapcar '- p2 p1)) ) (if nv (setq tt nil) ; selection succeeded (princ (if ger "\nDie Punkte dürfen nicht identisch sein." "\nThe two points must not be identical." ) ) ) ) ) ( (= "View" p1) (setq nv (trans (normalize (getvar "viewdir")) 1 0 t) p1 (getpoint (if ger (if r14 "\nPunkt auf der Ansichtsebene <0,0,0>: " (strcat "\n" "Punkt auf der aktuellen " "Ansichtsebene angeben <0,0,0>: " ) ) (if r14 "\nPoint on view plane <0,0,0>: " (strcat "\n" "Specify a point on the " "current view plane <0,0,0>: " ) ) ) ) p1 (trans (if p1 p1 '(0.0 0.0 0.0)) 1 0) ) ) ( (or (= "XY" p1) (= "YX" p1)) (setq nv (trans '(0.0 0.0 1.0) 1 0 t) p1 (getpoint (if ger (if r14 (strcat "\n" "Punkt auf der zur xy-Ebene " "parallelen Kappebene <0,0,0>: " ) (strcat "\n" "Punkt auf der " "zur xy-Ebene parallelen " "Kappebene angeben <0,0,0>: " ) ) (if r14 (strcat "\n" "Point on slicing plane " "the latter being parallel " "to the XY plane <0,0,0>: " ) (strcat "\n" "Specify a point " "on the slicing plane " "the latter being parallel " "to the XY-plane <0,0,0>: " ) ) ) ) p1 (trans (if p1 p1 '(0.0 0.0 0.0)) 1 0) ) ) ( (or (= "YZ" p1) (= "ZY" p1)) (setq nv (trans '(1.0 0.0 0.0) 1 0 t) p1 (getpoint (if ger (if r14 (strcat "\n" "Punkt auf der zur yz-Ebene " "parallelen Kappebene <0,0,0>: " ) (strcat "\n" "Punkt auf der " "zur yz-Ebene parallelen " "Kappebene angeben <0,0,0>: " ) ) (if r14 (strcat "\n" "Point on slicing plane " "the latter being parallel " "to the YZ plane <0,0,0>: " ) (strcat "\n" "Specify a point " "on the slicing plane " "the latter being parallel " "to the YZ-plane <0,0,0>: " ) ) ) ) p1 (trans (if p1 p1 '(0.0 0.0 0.0)) 1 0) ) ) ( (or (= "ZX" p1) (= "XZ" p1)) (setq nv (trans '(0.0 1.0 0.0) 1 0 t) p1 (getpoint (if ger (if r14 (strcat "\n" "Punkt auf der zur zx-Ebene " "parallelen Kappebene <0,0,0>: " ) (strcat "\n" "Punkt auf der " "zur zx-Ebene parallelen " "Kappebene angeben <0,0,0>: " ) ) (if r14 (strcat "\n" "Point on slicing plane " "the latter being parallel " "to the ZX plane <0,0,0>: " ) (strcat "\n" "Specify a point " "on the slicing plane " "the latter being parallel " "to the ZX-plane <0,0,0>: " ) ) ) ) p1 (trans (if p1 p1 '(0.0 0.0 0.0)) 1 0) ) ) ( t ; option "3points" (if (/= 'list (type p1)) ; in case the first point (progn ; was not clicked on yet (initget 1) (setq p1 (trans (getpoint (if ger (if r14 "\nErster Punkt der Kappebene: " (strcat "\n" "Ersten Punkt der Kappebene " "angeben: " ) ) (if r14 "\nFirst point on slicing plane: " (strcat "\n" "Specify first point " "on slicing plane: " ) ) ) ) 1 0 ) ) ) (setq p1 (trans p1 1 0)) ) (setq tt t) (while tt (initget 1) ; not just "Enter" (setq p2 (trans (getpoint (trans p1 0 1) (if ger (if r14 "\nZweiter Punkt der Kappebene: " (strcat "\n" "Zweiten Punkt der Kappebene " "angeben: " ) ) (if r14 "\nSecond point on slicing plane: " (strcat "\n" "Specify second point " "on slicing plane: " ) ) ) ) 1 0 ) ) (if (equal p1 p2 tol) (princ (if ger "\nDie Punkte dürfen nicht identisch sein." "\nThe points must not be identical." ) ) (setq tt nil) ; selection succeeded ) ) (setq tt t) (while tt (initget 1) ; not just "Enter" (setq p3 (trans (getpoint (trans p2 0 1) (if ger (if r14 "\nDritter Punkt der Kappebene: " (strcat "\n" "Dritten Punkt der Kappebene " "angeben: " ) ) (if r14 "\nThird point on slicing plane: " (strcat "\n" "Specify third point " "on slicing plane: " ) ) ) ) 1 0 ) nv (normalize (vectorProduct (mapcar '- p2 p1) (mapcar '- p3 p1) ) ) ) (if nv (setq tt nil) ; selection succeeded (princ (if ger "\nDie Punkte dürfen nicht kollinear sein." "\nThe points must not be collinear." ) ) ) ) ) ) ) ) ;; Gewünschte Seite[n] auswählen ;; Choose desired side[s] (setq tt t) (while tt (initget 1 (if ger "Beide _Both" "Both")) (setq d+ (getpoint (if ger (if r14 (strcat "\n" "Beide seiten/: " ) (strcat "\n" "Punkt auf der gewünschten Seite " "der Kappebene angeben oder [Beide]: " ) ) (if r14 (strcat "\n" "Both sides/" ": " ) (strcat "\n" "Specify a point on desired side of the plane " "or [keep Both sides]: " ) ) ) ) ) (if (= "Both" d+) (setq d+ t d- t tt nil ) (progn (setq d+ (scalarProduct nv (mapcar '- (trans d+ 1 0) p1)) ) ; distance between specified point and slicing plane (if (equal 0.0 d+ tol) (princ (if ger (strcat "\n" "Der Punkt darf sich nicht " "auf der Kappebene befinden." ) (strcat "\n" "The point must not be on the slicing plane." ) ) ) (if (minusp d+) (setq d+ nil ; side of negative distances is desired, d- t ; i. e. the side nv does not point at tt nil ) (setq d+ t ; side of positive distances is desired, d- nil ; i. e. the side nv points at tt nil ) ) ) ) ) ) (if h* (progn (setq h~ (getvar "cvport")) (setvar "cvport" h*) (redraw en 4) ; unhighlight slicing object if required (setvar "cvport" h~) ) ) ) (defun xsliceProcess ( ) ; The following variables declared in the main routine ; are used within this subroutine: ; get: s s# nv p1 r14 ger tol ; set: u u# n# i# in id it ie i0 i1 i2 i3 c0 c1 c2 c3 ; d0 d1 d2 d3 d< d> jn jd jt r// (if s (progn (princ "\n") (setq r// (or r14 (equal (ver) "LISP Release 1.0")) u (ssadd) u# 0 n# 0 i# 0 ) (while (> s# i#) (setq in (ssname s i#) id (entget in) it (cdr (assoc 0 id)) ) (cond ( (= "LINE" it) (setq i0 (assoc 10 id) i1 (assoc 11 id) ; data groups of start point and end point d0 (scalarProduct nv (mapcar '- (cdr i0) p1)) d1 (scalarProduct nv (mapcar '- (cdr i1) p1)) ; distances from slicing plane ) (if (or (and (<= tol d0) (>= (- tol) d1)) (and (>= (- tol) d0) (<= tol d1)) ) ; slice only if points are on different sides (xsliceProcessLine) (doNotSlice) ) ) ( (= "RAY" it) (setq i0 (assoc 10 id) i1 (assoc 11 id) ; data groups of start point and direction vector d0 (scalarProduct nv (mapcar '- (cdr i0) p1)) d1 (scalarProduct nv (cdr i1)) ; distance and direction component ; normal to slicing plane ) (if (or (and (<= tol d0) (>= (- tol) d1)) (and (>= (- tol) d0) (<= tol d1)) ) ; slice only if direction vector points at the ; side where the start point is not situated on (xsliceProcessRay) (doNotSlice) ) ) ( (= "XLINE" it) (setq i0 (assoc 10 id) i1 (assoc 11 id) ; data groups of "center" point ; and direction vector d0 (scalarProduct nv (mapcar '- (cdr i0) p1)) d1 (scalarProduct nv (cdr i1)) ; distance and direction component ; normal to slicing plane ) (if (equal 0.0 d1 tol) ; slice only if not parallel to slicing plane (doNotSlice) (xsliceProcessXline) ) ) ( (= "3DFACE" it) (setq c0 (cdr (setq i0 (assoc 10 id))) c1 (cdr (setq i1 (assoc 11 id))) c2 (cdr (setq i2 (assoc 12 id))) c3 (cdr (setq i3 (assoc 13 id))) ; corners d0 (scalarProduct nv (mapcar '- c0 p1)) d1 (scalarProduct nv (mapcar '- c1 p1)) d2 (scalarProduct nv (mapcar '- c2 p1)) d3 (scalarProduct nv (mapcar '- c3 p1)) d< (max d0 d1 d2 d3) d> (min d0 d1 d2 d3) ; distances from slicing plane ie (assoc 70 id) ; visibility of edges ) (if (and (<= tol d<) (>= (- tol) d>)) ; slice only if slicing plane is crossed (xsliceProcessFace) (doNotSlice) ) ) ( (= "POLYLINE" it) ; polygon mesh or polyface mesh (setq jn (entnext in) d< (scalarProduct nv (mapcar '- (cdr (assoc 10 (entget jn))) p1) ) d> d< ) (while (and (setq jt (assoc 70 (setq jd (entget (setq jn (entnext jn)))) ) ) (= 64 (logand 64 (cdr jt))) ) ; test all vertices (setq d0 (scalarProduct nv (mapcar '- (cdr (assoc 10 jd)) p1) ) d< (max d< d0) d> (min d> d0) ) ) (if (and (<= tol d<) (>= (- tol) d>)) ; slice only if slicing plane is crossed (xsliceProcessMesh) (doNotSlice) ) ) ) (setq i# (1+ i#)) ) (if (< 0 n#) (progn (princ (strcat (if ger "Die Kappebene schneidet " "Slicing plane does not intersect " ) (cond ( (= 1 s#) (if ger "das gewählte Objekt nicht." "the selected object." ) ) ( (= n# s#) (if ger "die gewählten Objekte nicht." "the selected objects." ) ) ( t (strcat (itoa n#) (if ger " der gewählten Objekte nicht." " of the selected objects." ) ) ) ) ) ) (if (< 0 u#) (progn (initget (if ger "Ja Nein _Yes No" "Yes No")) (if (/= "No" (getkword (strcat "\n" (if (= 1 u#) (if (= 1 n#) (if ger "Es liegt" "It lies" ) (if ger "1 davon liegt" "1 of them lies" ) ) (if (= u# n#) (if ger "Sie liegen" "They lie" ) (strcat (itoa u#) (if ger " davon liegen" " of them lie" ) ) ) ) (if ger " auf der unerwünschten Seite." " on the undesired side." ) (if ger (if r14 " Löschen? /Nein: " " Löschen? [Ja/Nein] : " ) (if r14 " Delete? /No: " " Delete? [Yes/No] : " ) ) ) ) ) (command "_.erase" u "") (command "_.regen") ; unhighlight objects ) ) ) ) ) ) ) ) ;;; Unterprogramme 2. Ordnung für xsliceProcess ;;; 2nd order subroutines for xsliceProcess (defun xsliceProcessLine ( ) ; The following variables declared in the main routine ; are used within this subroutine: ; get: id i0 i1 d0 d1 d+ d- b* ; set: ip b+ b- v+ v- (setq ip (interPoint (cdr i0) (cdr i1) d0 d1)) (if (minusp d0) (if d- (progn ; start point is on desired side (entmod (subst (cons 11 ip) i1 id)) (if b* (progn (ssadd in b-) (setq v- (+ 2 v-)))) (if d+ (progn ; other side also desired (entmake (subst (cons 10 ip) i0 id)) (if b* (progn (ssadd (entlast) b+) (setq v+ (+ 2 v+))) ) ) ) ) (progn ; only end point is on desired side (entmod (subst (cons 10 ip) i0 id)) (if b* (progn (ssadd in b+) (setq v+ (+ 2 v+)))) ) ) (if d+ (progn ; start point is on desired side (entmod (subst (cons 11 ip) i1 id)) (if b* (progn (ssadd in b+) (setq v+ (+ 2 v+)))) (if d- (progn ; other side also desired (entmake (subst (cons 10 ip) i0 id)) (if b* (progn (ssadd (entlast) b-) (setq v- (+ 2 v-))) ) ) ) ) (progn ; only end point is on desired side (entmod (subst (cons 10 ip) i0 id)) (if b* (progn (ssadd in b-) (setq v- (+ 2 v-)))) ) ) ) ; b* is not nil if the line is a component of a dismantled mesh ) (defun xsliceProcessRay ( ) ; The following variables declared in the main routine ; are used within this subroutine: ; get: in id i0 i1 d0 d1 d+ d- ; set: ip (setq ip (interPoint (cdr i0) (mapcar '+ (cdr i0) (cdr i1)) d0 (+ d0 d1) ) ) (if (if (minusp d0) d- d+) (progn ; start point is on desired side (entmake (subst '(0 . "LINE") '(0 . "RAY") (subst '(100 . "AcDbLine") '(100 . "AcDbRay") (subst (cons 11 ip) i1 id) ) ; line between start point and intersection point ) ) (if (if (minusp d0) d+ d-) (entmod (subst (cons 10 ip) i0 id)) ; both sides desired (entdel in) ; only side of start point desired ) ) (entmod (subst (cons 10 ip) i0 id)) ; start point is on ) ; undesired side ) (defun xsliceProcessXline ( ) ; The following variables declared in the main routine ; are used within this subroutine: ; get: in i0 i1 d0 d1 d+ d- tol ; set: id (setq id (subst '(0 . "RAY") '(0 . "XLINE") (subst '(100 . "AcDbRay") '(100 . "AcDbXline") id ) ) ) (if (not (equal 0.0 d0 tol)) ; If the "center" point (setq id ; is not on the plane yet ... (subst (cons 10 ; ... the intersection point (interPoint ; has to be calculated. (cdr i0) (mapcar '+ (cdr i0) (cdr i1)) d0 (+ d0 d1) ) ) i0 id ) ) ) (if (if (minusp d1) d- d+) ; original direction (entmake id) ) (if (if (minusp d1) d+ d-) ; opposite direction (entmake (subst (cons 11 (mapcar '- (cdr i1))) i1 id)) ) (entdel in) ) (defun xsliceProcessFace ( ) ; The following variables declared in the main routine ; are used within this subroutine: ; get: c0 c1 c2 c3 d0 d1 d2 d3 d+ d- r// tol ; set: ip iq ir is ; 3d-Flächen: AutoCAD 14 und IntelliCAD 2000 - zwei Dreiecke, ; die sich an der "Diagonalen" ; vom ersten zum dritten Eckpunkt berühren ; AutoCAD 2000 - ... an der anderen Diagonalen ... ; Aufschlüsseln der Fälle nach der Lage der Eckpunkte ; bezüglich der Ebene ; [Es ist zwar möglich, die einzelnen Fälle z. B. mittels ; verschachtelter if-Anweisungen weiter zusammenzufassen ; und den Programmcode dadurch zu verkürzen; ; jedoch erhöht dies wohl meist die Bearbeitungszeiten.] ; 3D faces: AutoCAD 14 and IntelliCAD 2000 - two triangles ; touching one another along the "diagonal" ; from the first to the third corner ; AutoCAD 2000 - ... the other diagonal ... ; Division of cases by situation of corners ; relative to the slicing plane ; [If cases were combined e. g. by nested "if" functions ; the program code would be shorter ; but running time would probably be longer.] (if r// (cond ; AutoCAD 14, IntelliCAD 2000 ;; Fälle 1 bis 3: zweiter oder vierter Eckpunkt abgeschnitten ;; Cases 1 to 3: second or fourth corner cut off ( ; 1A +-++ +-+o *14* (and (<= tol d0) (>= (- tol) d1) (<= tol d2) (< (- tol) d3) ) (setq ip (interPoint c0 c1 d0 d1) iq (interPoint c1 c2 d1 d2) ) (if d+ (progn ; pentangle composed of quadrangle and triangle (modFace-1 nil t) (modFace nil c0 nil nil 13 2 t t) (if d- (modFace ip nil iq iq 7 0 t nil) ) ) (modFace ip nil iq iq 7 0 nil nil) ) ) ( ; 1B -+-- -+-o *14* (and (>= (- tol) d0) (<= tol d1) (>= (- tol) d2) (> tol d3) ) (setq ip (interPoint c0 c1 d0 d1) iq (interPoint c1 c2 d1 d2) ) (if d- (progn ; pentangle composed of quadrangle and triangle (modFace-1 nil nil) (modFace nil c0 nil nil 13 2 t nil) (if d+ (modFace ip nil iq iq 7 0 t t) ) ) (modFace ip nil iq iq 7 0 nil t) ) ) ( ; 2A +++- +o+- *14* (and (<= tol d0) (< (- tol) d1) (<= tol d2) (>= (- tol) d3) ) (setq ir (interPoint c2 c3 d2 d3) is (interPoint c3 c0 d3 d0) ) (if d+ (progn ; pentangle composed of quadrangle and triangle (modFace-3 nil t) (modFace nil nil nil c2 7 8 t t) (if d- (modFace is is ir nil 13 0 t nil) ) ) (modFace is is ir nil 13 0 nil nil) ) ) ( ; 2B ---+ -o-+ *14* (and (>= (- tol) d0) (> tol d1) (>= (- tol) d2) (<= tol d3) ) (setq ir (interPoint c2 c3 d2 d3) is (interPoint c3 c0 d3 d0) ) (if d- (progn ; pentangle composed of quadrangle and triangle (modFace-3 nil nil) (modFace nil nil nil c2 7 8 t nil) (if d+ (modFace is is ir nil 13 0 t t) ) ) (modFace is is ir nil 13 0 nil t) ) ) ( ; 3A +-+- *14* (and (<= tol d0) (>= (- tol) d1) (<= tol d2) (>= (- tol) d3) ) (setq ip (interPoint c0 c1 d0 d1) iq (interPoint c1 c2 d1 d2) ir (interPoint c2 c3 d2 d3) is (interPoint c3 c0 d3 d0) ) (if d+ (progn ; hexangle composed of two quadrangles (modFace-1 nil t) (modFace-3 t t) (if d- (progn (modFace ip nil iq iq 7 0 t nil) (modFace is is ir nil 13 0 t nil) ) ) ) (progn (modFace ip nil iq iq 7 0 nil nil) (modFace is is ir nil 13 0 t nil) ) ) ) ( ; 3B -+-+ *14* (and (>= (- tol) d0) (<= tol d1) (>= (- tol) d2) (<= tol d3) ) (setq ip (interPoint c0 c1 d0 d1) iq (interPoint c1 c2 d1 d2) ir (interPoint c2 c3 d2 d3) is (interPoint c3 c0 d3 d0) ) (if d- (progn ; hexangle composed of two quadrangles (modFace-1 nil nil) (modFace-3 t nil) (if d+ (progn (modFace ip nil iq iq 7 0 t t) (modFace is is ir nil 13 0 t t) ) ) ) (progn (modFace ip nil iq iq 7 0 nil t) (modFace is is ir nil 13 0 t t) ) ) ) ;; Fälle 4 bis 7: kein Eckpunkt auf der Kappebene ;; Cases 4 to 7: no corner on the slicing plane ( ; 4A +--+ *14* (and (<= tol d0) (>= (- tol) d1) (>= (- tol) d2) (<= tol d3) ) (setq ip (interPoint c0 c1 d0 d1) iq (interPoint c2 c3 d2 d3) ) (if (coplanar c0 c1 c2 c3) (if d+ (progn (modFace nil ip iq nil 13 0 nil t) (if d- (modFace ip nil nil iq 7 0 t nil) ) ) (modFace ip nil nil iq 7 0 nil nil) ) (progn ; [points are not coplanar, split faces] (setq ir (interPoint c0 c2 d0 d2)) (if d+ (progn (modFace nil ip ir ir 5 8 nil t) (modFace nil ir iq nil 12 1 t t) (if d- (progn (modFace ip nil nil ir 3 4 t nil) (modFace ir ir nil iq 5 2 t nil) ) ) ) (progn (modFace ip nil nil ir 3 4 nil nil) (modFace ir ir nil iq 5 2 t nil) ) ) ) ) ) ( ; 4B -++- *14* (and (>= (- tol) d0) (<= tol d1) (<= tol d2) (>= (- tol) d3) ) (setq ip (interPoint c0 c1 d0 d1) iq (interPoint c2 c3 d2 d3) ) (if (coplanar c0 c1 c2 c3) (if d- (progn (modFace nil ip iq nil 13 0 nil nil) (if d+ (modFace ip nil nil iq 7 0 t t) ) ) (modFace ip nil nil iq 7 0 nil t) ) (progn ; [points are not coplanar, split faces] (setq ir (interPoint c0 c2 d0 d2)) (if d- (progn (modFace nil ip ir ir 5 8 nil nil) (modFace nil ir iq nil 12 1 t nil) (if d+ (progn (modFace ip nil nil ir 3 4 t t) (modFace ir ir nil iq 5 2 t t) ) ) ) (progn (modFace ip nil nil ir 3 4 nil t) (modFace ir ir nil iq 5 2 t t) ) ) ) ) ) ( ; 5A ++-- *14* (and (<= tol d0) (<= tol d1) (>= (- tol) d2) (>= (- tol) d3) ) (setq ip (interPoint c1 c2 d1 d2) iq (interPoint c3 c0 d3 d0) ) (if (coplanar c0 c1 c2 c3) (if d+ (progn (modFace nil nil ip iq 11 0 nil t) (if d- (modFace iq ip nil nil 14 0 t nil) ) ) (modFace iq ip nil nil 14 0 nil nil) ) (progn ; [points are not coplanar, split faces] (setq ir (interPoint c0 c2 d0 d2)) (if d+ (progn (modFace nil ir ir iq 10 1 nil t) (modFace nil nil ip ir 3 8 t t) (if d- (progn (modFace ir ip nil ir 10 4 t nil) (modFace iq ir nil nil 12 2 t nil) ) ) ) (progn (modFace ir ip nil ir 10 4 nil nil) (modFace iq ir nil nil 12 2 t nil) ) ) ) ) ) ( ; 5B --++ *14* (and (>= (- tol) d0) (>= (- tol) d1) (<= tol d2) (<= tol d3) ) (setq ip (interPoint c1 c2 d1 d2) iq (interPoint c3 c0 d3 d0) ) (if (coplanar c0 c1 c2 c3) (if d- (progn (modFace nil nil ip iq 11 0 nil nil) (if d+ (modFace iq ip nil nil 14 0 t t) ) ) (modFace iq ip nil nil 14 0 nil t) ) (progn ; [points are not coplanar, split faces] (setq ir (interPoint c0 c2 d0 d2)) (if d- (progn (modFace nil ir ir iq 10 1 nil nil) (modFace nil nil ip ir 3 8 t nil) (if d+ (progn (modFace ir ip nil ir 10 4 t t) (modFace iq ir nil nil 12 2 t t) ) ) ) (progn (modFace ir ip nil ir 10 4 nil t) (modFace iq ir nil nil 12 2 t t) ) ) ) ) ) ( ; 6A -+++ *14* (and (>= (- tol) d0) (<= tol d1) (<= tol d2) (<= tol d3)) (setq ip (interPoint c0 c1 d0 d1) iq (interPoint c3 c0 d3 d0) ir (interPoint c0 c2 d0 d2) ) (if d+ (progn (modFace ip nil nil ir 3 4 nil t) (modFace iq ir nil nil 12 2 t t) (if d- (modFace nil ip ir iq 9 0 t nil) ) ) (modFace nil ip ir iq 9 0 nil nil) ) ) ( ; 6B +--- *14* (and (<= tol d0) (>= (- tol) d1) (>= (- tol) d2) (>= (- tol) d3) ) (setq ip (interPoint c0 c1 d0 d1) iq (interPoint c3 c0 d3 d0) ir (interPoint c0 c2 d0 d2) ) (if d- (progn (modFace ip nil nil ir 3 4 nil nil) (modFace iq ir nil nil 12 2 t nil) (if d+ (modFace nil ip ir iq 9 0 t t) ) ) (modFace nil ip ir iq 9 0 nil t) ) ) ( ; 7A ++-+ *14* (and (<= tol d0) (<= tol d1) (>= (- tol) d2) (<= tol d3)) (setq ip (interPoint c1 c2 d1 d2) iq (interPoint c2 c3 d2 d3) ir (interPoint c0 c2 d0 d2) ) (if d+ (progn (modFace nil ir iq nil 12 1 nil t) (modFace nil nil ip ir 3 8 t t) (if d- (modFace ir ip nil iq 6 0 t nil) ) ) (modFace ir ip nil iq 6 0 nil nil) ) ) ( ; 7B --+- *14* (and (>= (- tol) d0) (>= (- tol) d1) (<= tol d2) (>= (- tol) d3) ) (setq ip (interPoint c1 c2 d1 d2) iq (interPoint c2 c3 d2 d3) ir (interPoint c0 c2 d0 d2) ) (if d- (progn (modFace nil ir iq nil 12 1 nil nil) (modFace nil nil ip ir 3 8 t nil) (if d+ (modFace ir ip nil iq 6 0 t t) ) ) (modFace ir ip nil iq 6 0 nil t) ) ) ;; Fälle 8 und 9: ;; zwei nicht aufeinander folgende Eckpunkte ;; auf der Kappebene ;; Cases 8 and 9: ;; two non-successive corners on the slicing plane ( ; 8 o+o- o-o+ *14* (and (equal 0.0 d0 tol) (equal 0.0 d2 tol)) (if (minusp d3) (if d+ ; [8A o+o-] (progn (modFace nil nil nil c2 7 0 nil t) (if d- (modFace nil c0 nil nil 13 0 t nil) ) ) (modFace nil c0 nil nil 13 0 nil nil) ) (if d- ; [8B o-o+] (progn (modFace nil nil nil c2 7 0 nil nil) (if d+ (modFace nil c0 nil nil 13 0 t t) ) ) (modFace nil c0 nil nil 13 0 nil t) ) ) ) ( ; 9 +o-o -o+o *14* (and (equal 0.0 d1 tol) (equal 0.0 d3 tol)) (setq ip (interPoint c0 c2 d0 d2)) (if (minusp d2) (if d+ ; [9A +o-o] (progn (modFace nil nil ip nil 9 0 nil t) (if d- (modFace ip nil nil nil 6 0 t nil) ) ) (modFace ip nil nil nil 6 0 nil nil) ) (if d- ; [9B -o+o] (progn (modFace nil nil ip nil 9 0 nil nil) (if d+ (modFace ip nil nil nil 6 0 t t) ) ) (modFace ip nil nil nil 6 0 nil t) ) ) ) ;; Fälle 10 bis 12: erster Eckpunkt auf der Kappebene ;; Cases 10 to 12: first corner on the slicing plane ( (equal 0.0 d0 tol) (cond ( ; 10A o++- oo+- *14* (and (< (- tol) d1) (<= tol d2) (>= (- tol) d3)) (setq ip (interPoint c2 c3 d2 d3)) (if d+ (progn (modFace nil nil nil ip 7 0 nil t) (if d- (modFace nil ip ip nil 14 0 t nil) ) ) (modFace nil ip ip nil 14 0 nil nil) ) ) ( ; 10B o--+ oo-+ *14* (and (> tol d1) (>= (- tol) d2) (<= tol d3)) (setq ip (interPoint c2 c3 d2 d3)) (if d- (progn (modFace nil nil nil ip 7 0 nil nil) (if d+ (modFace nil ip ip nil 14 0 t t) ) ) (modFace nil ip ip nil 14 0 nil t) ) ) ( ; 11A o+-+ *14* (and (<= tol d1) (>= (- tol) d2) (<= tol d3)) (setq ip (interPoint c1 c2 d1 d2) iq (interPoint c2 c3 d2 d3) ) (if d+ (progn (modFace nil nil ip ip 7 0 nil t) (modFace nil iq iq nil 14 0 t t) (if d- (modFace nil ip nil iq 6 0 t nil) ) ) (modFace nil ip nil iq 6 0 nil nil) ) ) ( ; 11B o-+- *14* (and (>= (- tol) d1) (<= tol d2) (>= (- tol) d3)) (setq ip (interPoint c1 c2 d1 d2) iq (interPoint c2 c3 d2 d3) ) (if d- (progn (modFace nil nil ip ip 7 0 nil nil) (modFace nil iq iq nil 14 0 t nil) (if d+ (modFace nil ip nil iq 6 0 t t) ) ) (modFace nil ip nil iq 6 0 nil t) ) ) ( ; 12A o-++ o-+o *14* (and (>= (- tol) d1) (<= tol d2) (< (- tol) d3)) (setq ip (interPoint c1 c2 d1 d2)) (if d+ (progn (modFace nil ip nil nil 14 0 nil t) (if d- (modFace nil nil ip ip 7 0 t nil) ) ) (modFace nil nil ip ip 7 0 nil nil) ) ) ( ; 12B o+-- o+-o *14* (and (<= tol d1) (>= (- tol) d2) (> tol d3)) (setq ip (interPoint c1 c2 d1 d2)) (if d- (progn (modFace nil ip nil nil 14 0 nil nil) (if d+ (modFace nil nil ip ip 7 0 t t) ) ) (modFace nil nil ip ip 7 0 nil t) ) ) ) ) ;; Fälle 13 bis 15: dritter Eckpunkt auf der Kappebene ;; Cases 13 to 15: third corner on the slicing plane ( (equal 0.0 d2 tol) (cond ( ; 13A +-o+ +-oo *14* (and (< (- tol) d3) (<= tol d0) (>= (- tol) d1)) (setq ip (interPoint c0 c1 d0 d1)) (if d+ (progn (modFace nil ip nil nil 13 0 nil t) (if d- (modFace ip nil nil ip 11 0 t nil) ) ) (modFace ip nil nil ip 11 0 nil nil) ) ) ( ; 13B -+o- -+oo *14* (and (> tol d3) (>= (- tol) d0) (<= tol d1)) (setq ip (interPoint c0 c1 d0 d1)) (if d- (progn (modFace nil ip nil nil 13 0 nil nil) (if d+ (modFace ip nil nil ip 11 0 t t) ) ) (modFace ip nil nil ip 11 0 nil t) ) ) ( ; 14A -+o+ *14* (and (<= tol d3) (>= (- tol) d0) (<= tol d1)) (setq ip (interPoint c3 c0 d3 d0) iq (interPoint c0 c1 d0 d1) ) (if d+ (progn (modFace ip ip nil nil 13 0 nil t) (modFace iq nil nil iq 11 0 t t) (if d- (modFace nil ip nil iq 9 0 t nil) ) ) (modFace nil ip nil iq 9 0 nil nil) ) ) ( ; 14B +-o- *14* (and (>= (- tol) d3) (<= tol d0) (>= (- tol) d1)) (setq ip (interPoint c3 c0 d3 d0) iq (interPoint c0 c1 d0 d1) ) (if d- (progn (modFace ip ip nil nil 13 0 nil nil) (modFace iq nil nil iq 11 0 t nil) (if d+ (modFace nil ip nil iq 9 0 t t) ) ) (modFace nil ip nil iq 9 0 nil t) ) ) ( ; 15A ++o- +oo- *14* (and (>= (- tol) d3) (<= tol d0) (< (- tol) d1)) (setq ip (interPoint c3 c0 d3 d0)) (if d+ (progn (modFace nil nil nil ip 11 0 nil t) (if d- (modFace ip ip nil nil 13 0 t nil) ) ) (modFace ip ip nil nil 13 0 nil nil) ) ) ( ; 15B --o+ -oo+ *14* (and (<= tol d3) (>= (- tol) d0) (> tol d1)) (setq ip (interPoint c3 c0 d3 d0)) (if d- (progn (modFace nil nil nil ip 11 0 nil nil) (if d+ (modFace ip ip nil nil 13 0 t t) ) ) (modFace ip ip nil nil 13 0 nil t) ) ) ) ) ;; Fälle 16 und 17: zweiter Eckpunkt auf der Kappebene ;; Cases 16 and 17: second corner on the slicing plane ( (equal 0.0 d1 tol) (cond ( ; 16A -o++ *14* (and (<= tol d2) (<= tol d3) (>= (- tol) d0)) (setq ip (interPoint c3 c0 d3 d0) iq (interPoint c0 c2 d0 d2) ) (if d+ (progn (if (coplanar c0 c1 c2 c3) (modFace ip nil nil nil 14 0 nil t) (progn (modFace iq nil nil iq 10 4 nil t) (modFace ip iq nil nil 12 2 t t) ) ) (if d- (modFace nil nil iq ip 9 0 t nil) ) ) (modFace nil nil iq ip 9 0 nil nil) ) ) ( ; 16B +o-- *14* (and (>= (- tol) d2) (>= (- tol) d3) (<= tol d0)) (setq ip (interPoint c3 c0 d3 d0) iq (interPoint c0 c2 d0 d2) ) (if d- (progn (if (coplanar c0 c1 c2 c3) (modFace ip nil nil nil 14 0 nil nil) (progn (modFace iq nil nil iq 10 4 nil nil) (modFace ip iq nil nil 12 2 t nil) ) ) (if d+ (modFace nil nil iq ip 9 0 t t) ) ) (modFace nil nil iq ip 9 0 nil t) ) ) ( ; 17A +o-+ *14* (and (>= (- tol) d2) (<= tol d3) (<= tol d0)) (setq ip (interPoint c2 c3 d2 d3) iq (interPoint c0 c2 d0 d2) ) (if d+ (progn (if (coplanar c0 c1 c2 c3) (modFace nil nil ip nil 13 0 nil t) (progn (modFace nil nil iq iq 5 8 nil t) (modFace nil iq ip nil 12 1 t t) ) ) (if d- (modFace iq nil nil ip 6 0 t nil) ) ) (modFace iq nil nil ip 6 0 nil nil) ) ) ( ; 17B -o+- *14* (and (<= tol d2) (>= (- tol) d3) (>= (- tol) d0)) (setq ip (interPoint c2 c3 d2 d3) iq (interPoint c0 c2 d0 d2) ) (if d- (progn (if (coplanar c0 c1 c2 c3) (modFace nil nil ip nil 13 0 nil nil) (progn (modFace nil nil iq iq 5 8 nil nil) (modFace nil iq ip nil 12 1 t nil) ) ) (if d+ (modFace iq nil nil ip 6 0 t t) ) ) (modFace iq nil nil ip 6 0 nil t) ) ) ) ) ;; Fälle 18 und 19: vierter Eckpunkt auf der Kappebene ;; Cases 18 and 19: fourth corner on the slicing plane ( (equal 0.0 d3 tol) (cond ( ; 18A ++-o *14* (and (<= tol d0) (<= tol d1) (>= (- tol) d2)) (setq ip (interPoint c1 c2 d1 d2) iq (interPoint c0 c2 d0 d2) ) (if d+ (progn (if (coplanar c0 c1 c2 c3) (modFace nil nil ip nil 11 0 nil t) (progn (modFace nil iq iq nil 10 1 nil t) (modFace nil nil ip iq 3 8 t t) ) ) (if d- (modFace iq ip nil nil 6 0 t nil) ) ) (modFace iq ip nil nil 6 0 nil nil) ) ) ( ; 18B --+o *14* (and (>= (- tol) d0) (>= (- tol) d1) (<= tol d2)) (setq ip (interPoint c1 c2 d1 d2) iq (interPoint c0 c2 d0 d2) ) (if d- (progn (if (coplanar c0 c1 c2 c3) (modFace nil nil ip nil 11 0 nil nil) (progn (modFace nil iq iq nil 10 1 nil nil) (modFace nil nil ip iq 3 8 t nil) ) ) (if d+ (modFace iq ip nil nil 6 0 t t) ) ) (modFace iq ip nil nil 6 0 nil t) ) ) ( ; 19A -++o *14* (and (>= (- tol) d0) (<= tol d1) (<= tol d2)) (setq ip (interPoint c0 c1 d0 d1) iq (interPoint c0 c2 d0 d2) ) (if d+ (progn (if (coplanar c0 c1 c2 c3) (modFace ip nil nil nil 7 0 nil t) (progn (modFace iq iq nil nil 5 2 nil t) (modFace ip nil nil iq 3 4 t t) ) ) (if d- (modFace nil ip iq nil 9 0 t nil) ) ) (modFace nil ip iq nil 9 0 nil nil) ) ) ( ; 19B +--o *14* (and (<= tol d0) (>= (- tol) d1) (>= (- tol) d2)) (setq ip (interPoint c0 c1 d0 d1) iq (interPoint c0 c2 d0 d2) ) (if d- (progn (if (coplanar c0 c1 c2 c3) (modFace ip nil nil nil 7 0 nil nil) (progn (modFace iq iq nil nil 5 2 nil nil) (modFace ip nil nil iq 3 4 t nil) ) ) (if d+ (modFace nil ip iq nil 9 0 t t) ) ) (modFace nil ip iq nil 9 0 nil t) ) ) ) ) ) (cond ; AutoCAD 2000 ;; Fälle 1 bis 3: erster oder dritter Eckpunkt abgeschnitten ;; Cases 1 to 3: first or third corner cut off ( ; 1A -+++ -+o+ (and (>= (- tol) d0) (<= tol d1) (< (- tol) d2) (<= tol d3) ) (setq ip (interPoint c3 c0 d3 d0) iq (interPoint c0 c1 d0 d1) ) (if d+ (progn ; pentangle composed of quadrangle and triangle (modFace-0 nil t) (modFace c3 nil nil nil 14 1 t t) (if d- (modFace nil iq iq ip 11 0 t nil) ) ) (modFace nil iq iq ip 11 0 nil nil) ) ) ( ; 1B +--- +-o- (and (<= tol d0) (>= (- tol) d1) (> tol d2) (>= (- tol) d3) ) (setq ip (interPoint c3 c0 d3 d0) iq (interPoint c0 c1 d0 d1) ) (if d- (progn ; pentangle composed of quadrangle and triangle (modFace-0 nil nil) (modFace c3 nil nil nil 14 1 t nil) (if d+ (modFace nil iq iq ip 11 0 t t) ) ) (modFace nil iq iq ip 11 0 nil t) ) ) ( ; 2A ++-+ o+-+ (and (< (- tol) d0) (<= tol d1) (>= (- tol) d2) (<= tol d3) ) (setq ir (interPoint c1 c2 d1 d2) is (interPoint c2 c3 d2 d3) ) (if d+ (progn ; pentangle composed of quadrangle and triangle (modFace-2 nil t) (modFace nil nil c1 nil 11 4 t t) (if d- (modFace is ir nil is 14 0 t nil) ) ) (modFace is ir nil is 14 0 nil nil) ) ) ( ; 2B --+- o-+- (and (> tol d0) (>= (- tol) d1) (<= tol d2) (>= (- tol) d3) ) (setq ir (interPoint c1 c2 d1 d2) is (interPoint c2 c3 d2 d3) ) (if d- (progn ; pentangle composed of quadrangle and triangle (modFace-2 nil nil) (modFace nil nil c1 nil 11 4 t nil) (if d+ (modFace is ir nil is 14 0 t t) ) ) (modFace is ir nil is 14 0 nil t) ) ) ( ; 3A -+-+ (and (>= (- tol) d0) (<= tol d1) (>= (- tol) d2) (<= tol d3) ) (setq ip (interPoint c3 c0 d3 d0) iq (interPoint c0 c1 d0 d1) ir (interPoint c1 c2 d1 d2) is (interPoint c2 c3 d2 d3) ) (if d+ (progn ; hexangle composed of two quadrangles (modFace-0 nil t) (modFace-2 t t) (if d- (progn (modFace nil iq iq ip 11 0 t nil) (modFace is ir nil is 14 0 t nil) ) ) ) (progn (modFace nil iq iq ip 11 0 nil nil) (modFace is ir nil is 14 0 t nil) ) ) ) ( ; 3B +-+- (and (<= tol d0) (>= (- tol) d1) (<= tol d2) (>= (- tol) d3) ) (setq ip (interPoint c3 c0 d3 d0) iq (interPoint c0 c1 d0 d1) ir (interPoint c1 c2 d1 d2) is (interPoint c2 c3 d2 d3) ) (if d- (progn ; hexangle composed of two quadrangles (modFace-0 nil nil) (modFace-2 t nil) (if d+ (progn (modFace nil iq iq ip 11 0 t t) (modFace is ir nil is 14 0 t t) ) ) ) (progn (modFace nil iq iq ip 11 0 nil t) (modFace is ir nil is 14 0 t t) ) ) ) ;; Fälle 4 bis 7: kein Eckpunkt auf der Kappebene ;; Cases 4 to 7: no corner on the slicing plane ( ; 4A --++ (and (>= (- tol) d0) (>= (- tol) d1) (<= tol d2) (<= tol d3) ) (setq ip (interPoint c3 c0 d3 d0) iq (interPoint c1 c2 d1 d2) ) (if (coplanar c0 c1 c2 c3) (if d+ (progn (modFace ip iq nil nil 14 0 nil t) (if d- (modFace nil nil iq ip 11 0 t nil) ) ) (modFace nil nil iq ip 11 0 nil nil) ) (progn ; [points are not coplanar, split faces] (setq ir (interPoint c1 c3 d1 d3)) (if d+ (progn (modFace ip ir ir nil 10 4 nil t) (modFace ir iq nil nil 6 8 t t) (if d- (progn (modFace nil nil ir ip 9 2 t nil) (modFace ir nil iq ir 10 1 t nil) ) ) ) (progn (modFace nil nil ir ip 9 2 nil nil) (modFace ir nil iq ir 10 1 t nil) ) ) ) ) ) ( ; 4B ++-- (and (<= tol d0) (<= tol d1) (>= (- tol) d2) (>= (- tol) d3) ) (setq ip (interPoint c3 c0 d3 d0) iq (interPoint c1 c2 d1 d2) ) (if (coplanar c0 c1 c2 c3) (if d- (progn (modFace ip iq nil nil 14 0 nil nil) (if d+ (modFace nil nil iq ip 11 0 t t) ) ) (modFace nil nil iq ip 11 0 nil t) ) (progn ; [points are not coplanar, split faces] (setq ir (interPoint c1 c3 d1 d3)) (if d- (progn (modFace ip ir ir nil 10 4 nil nil) (modFace ir iq nil nil 6 8 t nil) (if d+ (progn (modFace nil nil ir ip 9 2 t t) (modFace ir nil iq ir 10 1 t t) ) ) ) (progn (modFace nil nil ir ip 9 2 nil t) (modFace ir nil iq ir 10 1 t t) ) ) ) ) ) ( ; 5A +--+ (and (<= tol d3) (<= tol d0) (>= (- tol) d1) (>= (- tol) d2) ) (setq ip (interPoint c0 c1 d0 d1) iq (interPoint c2 c3 d2 d3) ) (if (coplanar c0 c1 c2 c3) (if d+ (progn (modFace nil ip iq nil 13 0 nil t) (if d- (modFace ip nil nil iq 7 0 t nil) ) ) (modFace ip nil nil iq 7 0 nil nil) ) (progn ; [points are not coplanar, split faces] (setq ir (interPoint c1 c3 d1 d3)) (if d+ (progn (modFace ir ir iq nil 5 8 nil t) (modFace nil ip ir nil 9 4 t t) (if d- (progn (modFace ip nil ir ir 5 2 t nil) (modFace ir nil nil iq 6 1 t nil) ) ) ) (progn (modFace ip nil ir ir 5 2 nil nil) (modFace ir nil nil iq 6 1 t nil) ) ) ) ) ) ( ; 5B -++- (and (>= (- tol) d0) (<= tol d1) (<= tol d2) (>= (- tol) d3) ) (setq ip (interPoint c0 c1 d0 d1) iq (interPoint c2 c3 d2 d3) ) (if (coplanar c0 c1 c2 c3) (if d- (progn (modFace nil ip iq nil 13 0 nil nil) (if d+ (modFace ip nil nil iq 7 0 t t) ) ) (modFace ip nil nil iq 7 0 nil t) ) (progn ; [points are not coplanar, split faces] (setq ir (interPoint c1 c3 d1 d3)) (if d- (progn (modFace ir ir iq nil 5 8 nil nil) (modFace nil ip ir nil 9 4 t nil) (if d+ (progn (modFace ip nil ir ir 5 2 t t) (modFace ir nil nil iq 6 1 t t) ) ) ) (progn (modFace ip nil ir ir 5 2 nil t) (modFace ir nil nil iq 6 1 t t) ) ) ) ) ) ( ; 6A +++- (and (<= tol d0) (<= tol d1) (<= tol d2) (>= (- tol) d3)) (setq ip (interPoint c3 c0 d3 d0) iq (interPoint c2 c3 d2 d3) ir (interPoint c1 c3 d1 d3) ) (if d+ (progn (modFace nil nil ir ip 9 2 nil t) (modFace ir nil nil iq 6 1 t t) (if d- (modFace ip ir iq nil 12 0 t nil) ) ) (modFace ip ir iq nil 12 0 nil nil) ) ) ( ; 6B ---+ (and (>= (- tol) d0) (>= (- tol) d1) (>= (- tol) d2) (<= tol d3) ) (setq ip (interPoint c3 c0 d3 d0) iq (interPoint c2 c3 d2 d3) ir (interPoint c1 c3 d1 d3) ) (if d- (progn (modFace nil nil ir ip 9 2 nil nil) (modFace ir nil nil iq 6 1 t nil) (if d+ (modFace ip ir iq nil 12 0 t t) ) ) (modFace ip ir iq nil 12 0 nil t) ) ) ( ; 7A +-++ (and (<= tol d0) (>= (- tol) d1) (<= tol d2) (<= tol d3)) (setq ip (interPoint c0 c1 d0 d1) iq (interPoint c1 c2 d1 d2) ir (interPoint c1 c3 d1 d3) ) (if d+ (progn (modFace ir iq nil nil 6 8 nil t) (modFace nil ip ir nil 9 4 t t) (if d- (modFace ip nil iq ir 3 0 t nil) ) ) (modFace ip nil iq ir 3 0 nil nil) ) ) ( ; 7B -+-- (and (>= (- tol) d0) (<= tol d1) (>= (- tol) d2) (>= (- tol) d3) ) (setq ip (interPoint c0 c1 d0 d1) iq (interPoint c1 c2 d1 d2) ir (interPoint c1 c3 d1 d3) ) (if d- (progn (modFace ir iq nil nil 6 8 nil nil) (modFace nil ip ir nil 9 4 t nil) (if d+ (modFace ip nil iq ir 3 0 t t) ) ) (modFace ip nil iq ir 3 0 nil t) ) ) ;; Fälle 8 und 9: ;; zwei nicht aufeinander folgende Eckpunkte ;; auf der Kappebene ;; Cases 8 and 9: ;; two non-successive corners on the slicing plane ( ; 8 +o-o -o+o (and (equal 0.0 d1 tol) (equal 0.0 d3 tol)) (if (minusp d2) (if d+ ; [8A +o-o] (progn (modFace nil nil c1 nil 11 0 nil t) (if d- (modFace c3 nil nil nil 14 0 t nil) ) ) (modFace c3 nil nil nil 14 0 nil nil) ) (if d- ; [8B -o+o] (progn (modFace nil nil c1 nil 11 0 nil nil) (if d+ (modFace c3 nil nil nil 14 0 t t) ) ) (modFace c3 nil nil nil 14 0 nil t) ) ) ) ( ; 9 o-o+ o+o- (and (equal 0.0 d0 tol) (equal 0.0 d2 tol)) (setq ip (interPoint c1 c3 d1 d3)) (if (minusp d1) (if d+ ; [9A o-o+] (progn (modFace nil ip nil nil 12 0 nil t) (if d- (modFace nil nil nil ip 3 0 t nil) ) ) (modFace nil nil nil ip 3 0 nil nil) ) (if d- ; [9B o+o-] (progn (modFace nil ip nil nil 12 0 nil nil) (if d+ (modFace nil nil nil ip 3 0 t t) ) ) (modFace nil nil nil ip 3 0 nil t) ) ) ) ;; Fälle 10 bis 12: vierter Eckpunkt auf der Kappebene ;; Cases 10 to 12: fourth corner on the slicing plane ( (equal 0.0 d3 tol) (cond ( ; 10A ++-o o+-o (and (< (- tol) d0) (<= tol d1) (>= (- tol) d2)) (setq ip (interPoint c1 c2 d1 d2)) (if d+ (progn (modFace nil nil ip nil 11 0 nil t) (if d- (modFace ip ip nil nil 7 0 t nil) ) ) (modFace ip ip nil nil 7 0 nil nil) ) ) ( ; 10B --+o o-+o (and (> tol d0) (>= (- tol) d1) (<= tol d2)) (setq ip (interPoint c1 c2 d1 d2)) (if d- (progn (modFace nil nil ip nil 11 0 nil nil) (if d+ (modFace ip ip nil nil 7 0 t t) ) ) (modFace ip ip nil nil 7 0 nil t) ) ) ( ; 11A +-+o (and (<= tol d0) (>= (- tol) d1) (<= tol d2)) (setq ip (interPoint c0 c1 d0 d1) iq (interPoint c1 c2 d1 d2) ) (if d+ (progn (modFace nil ip ip nil 11 0 nil t) (modFace iq iq nil nil 7 0 t t) (if d- (modFace ip nil iq nil 3 0 t nil) ) ) (modFace ip nil iq nil 3 0 nil nil) ) ) ( ; 11B -+-o (and (>= (- tol) d0) (<= tol d1) (>= (- tol) d2)) (setq ip (interPoint c0 c1 d0 d1) iq (interPoint c1 c2 d1 d2) ) (if d- (progn (modFace nil ip ip nil 11 0 nil nil) (modFace iq iq nil nil 7 0 t nil) (if d+ (modFace ip nil iq nil 3 0 t t) ) ) (modFace ip nil iq nil 3 0 nil t) ) ) ( ; 12A -++o -+oo (and (>= (- tol) d0) (<= tol d1) (< (- tol) d2)) (setq ip (interPoint c0 c1 d0 d1)) (if d+ (progn (modFace ip nil nil nil 7 0 nil t) (if d- (modFace nil ip ip nil 11 0 t nil) ) ) (modFace nil ip ip nil 11 0 nil nil) ) ) ( ; 12B +--o +-oo (and (<= tol d0) (>= (- tol) d1) (> tol d2)) (setq ip (interPoint c0 c1 d0 d1)) (if d- (progn (modFace ip nil nil nil 7 0 nil nil) (if d+ (modFace nil ip ip nil 11 0 t t) ) ) (modFace nil ip ip nil 11 0 nil t) ) ) ) ) ;; Fälle 13 bis 15: zweiter Eckpunkt auf der Kappebene ;; Cases 13 to 15: second corner on the slicing plane ( (equal 0.0 d1 tol) (cond ( ; 13A -o++ -oo+ (and (< (- tol) d2) (<= tol d3) (>= (- tol) d0)) (setq ip (interPoint c3 c0 d3 d0)) (if d+ (progn (modFace ip nil nil nil 14 0 nil t) (if d- (modFace nil nil ip ip 13 0 t nil) ) ) (modFace nil nil ip ip 13 0 nil nil) ) ) ( ; 13B +o-- +oo- (and (> tol d2) (>= (- tol) d3) (<= tol d0)) (setq ip (interPoint c3 c0 d3 d0)) (if d- (progn (modFace ip nil nil nil 14 0 nil nil) (if d+ (modFace nil nil ip ip 13 0 t t) ) ) (modFace nil nil ip ip 13 0 nil t) ) ) ( ; 14A +o+- (and (<= tol d2) (>= (- tol) d3) (<= tol d0)) (setq ip (interPoint c2 c3 d2 d3) iq (interPoint c3 c0 d3 d0) ) (if d+ (progn (modFace ip nil nil ip 14 0 nil t) (modFace nil nil iq iq 13 0 t t) (if d- (modFace ip nil iq nil 12 0 t nil) ) ) (modFace ip nil iq nil 12 0 nil nil) ) ) ( ; 14B -o-+ (and (>= (- tol) d2) (<= tol d3) (>= (- tol) d0)) (setq ip (interPoint c2 c3 d2 d3) iq (interPoint c3 c0 d3 d0) ) (if d- (progn (modFace ip nil nil ip 14 0 nil nil) (modFace nil nil iq iq 13 0 t nil) (if d+ (modFace ip nil iq nil 12 0 t t) ) ) (modFace ip nil iq nil 12 0 nil t) ) ) ( ; 15A +o-+ oo-+ (and (>= (- tol) d2) (<= tol d3) (< (- tol) d0)) (setq ip (interPoint c2 c3 d2 d3)) (if d+ (progn (modFace nil nil ip nil 13 0 nil t) (if d- (modFace ip nil nil ip 14 0 t nil) ) ) (modFace ip nil nil ip 14 0 nil nil) ) ) ( ; 15B -o+- oo+- (and (<= tol d2) (>= (- tol) d3) (> tol d0)) (setq ip (interPoint c2 c3 d2 d3)) (if d- (progn (modFace nil nil ip nil 13 0 nil nil) (if d+ (modFace ip nil nil ip 14 0 t t) ) ) (modFace ip nil nil ip 14 0 nil t) ) ) ) ) ;; Fälle 16 und 17: erster Eckpunkt auf der Kappebene ;; Cases 16 and 17: first corner on the slicing plane ( (equal 0.0 d0 tol) (cond ( ; 16A o++- (and (<= tol d1) (<= tol d2) (>= (- tol) d3)) (setq ip (interPoint c2 c3 d2 d3) iq (interPoint c1 c3 d1 d3) ) (if d+ (progn (if (coplanar c0 c1 c2 c3) (modFace nil nil nil ip 7 0 nil t) (progn (modFace nil nil iq iq 5 2 nil t) (modFace iq nil nil ip 6 1 t t) ) ) (if d- (modFace nil iq ip nil 12 0 t nil) ) ) (modFace nil iq ip nil 12 0 nil nil) ) ) ( ; 16B o--+ (and (>= (- tol) d1) (>= (- tol) d2) (<= tol d3)) (setq ip (interPoint c2 c3 d2 d3) iq (interPoint c1 c3 d1 d3) ) (if d- (progn (if (coplanar c0 c1 c2 c3) (modFace nil nil nil ip 7 0 nil nil) (progn (modFace nil nil iq iq 5 2 nil nil) (modFace iq nil nil ip 6 1 t nil) ) ) (if d+ (modFace nil iq ip nil 12 0 t t) ) ) (modFace nil iq ip nil 12 0 nil t) ) ) ( ; 17A o-++ (and (>= (- tol) d1) (<= tol d2) (<= tol d3)) (setq ip (interPoint c1 c2 d1 d2) iq (interPoint c1 c3 d1 d3) ) (if d+ (progn (if (coplanar c0 c1 c2 c3) (modFace nil ip nil nil 14 0 nil t) (progn (modFace nil iq iq nil 10 4 nil t) (modFace iq ip nil nil 6 8 t t) ) ) (if d- (modFace nil nil ip iq 3 0 t nil) ) ) (modFace nil nil ip iq 3 0 nil nil) ) ) ( ; 17B o+-- (and (<= tol d1) (>= (- tol) d2) (>= (- tol) d3)) (setq ip (interPoint c1 c2 d1 d2) iq (interPoint c1 c3 d1 d3) ) (if d- (progn (if (coplanar c0 c1 c2 c3) (modFace nil ip nil nil 14 0 nil nil) (progn (modFace nil iq iq nil 10 4 nil nil) (modFace iq ip nil nil 6 8 t nil) ) ) (if d+ (modFace nil nil ip iq 3 0 t t) ) ) (modFace nil nil ip iq 3 0 nil t) ) ) ) ) ;; Fälle 18 und 19: dritter Eckpunkt auf der Kappebene ;; Cases 18 and 19: third corner on the slicing plane ( (equal 0.0 d2 tol) (cond ( ; 18A +-o+ (and (<= tol d3) (<= tol d0) (>= (- tol) d1)) (setq ip (interPoint c0 c1 d0 d1) iq (interPoint c1 c3 d1 d3) ) (if d+ (progn (if (coplanar c0 c1 c2 c3) (modFace nil ip nil nil 13 0 nil t) (progn (modFace iq iq nil nil 5 8 nil t) (modFace nil ip iq nil 9 4 t t) ) ) (if d- (modFace ip nil nil iq 3 0 t nil) ) ) (modFace ip nil nil iq 3 0 nil nil) ) ) ( ; 18B -+o- (and (>= (- tol) d3) (>= (- tol) d0) (<= tol d1)) (setq ip (interPoint c0 c1 d0 d1) iq (interPoint c1 c3 d1 d3) ) (if d- (progn (if (coplanar c0 c1 c2 c3) (modFace nil ip nil nil 13 0 nil nil) (progn (modFace iq iq nil nil 5 8 nil nil) (modFace nil ip iq nil 9 4 t nil) ) ) (if d+ (modFace ip nil nil iq 3 0 t t) ) ) (modFace ip nil nil iq 3 0 nil t) ) ) ( ; 19A ++o- (and (>= (- tol) d3) (<= tol d0) (<= tol d1)) (setq ip (interPoint c3 c0 d3 d0) iq (interPoint c1 c3 d1 d3) ) (if d+ (progn (if (coplanar c0 c1 c2 c3) (modFace nil nil nil ip 11 0 nil t) (progn (modFace iq nil nil iq 10 1 nil t) (modFace nil nil iq ip 9 2 t t) ) ) (if d- (modFace ip iq nil nil 12 0 t nil) ) ) (modFace ip iq nil nil 12 0 nil nil) ) ) ( ; 19B --o+ (and (<= tol d3) (>= (- tol) d0) (>= (- tol) d1)) (setq ip (interPoint c3 c0 d3 d0) iq (interPoint c1 c3 d1 d3) ) (if d- (progn (if (coplanar c0 c1 c2 c3) (modFace nil nil nil ip 11 0 nil nil) (progn (modFace iq nil nil iq 10 1 nil nil) (modFace nil nil iq ip 9 2 t nil) ) ) (if d+ (modFace ip iq nil nil 12 0 t t) ) ) (modFace ip iq nil nil 12 0 nil t) ) ) ) ) ) ) ) (defun xsliceProcessMesh ( ) ; The following variables declared in the main routine ; are used within this subroutine: ; get: ll nv p1 d+ d- ger tol ; set: b b+ b- b* b# j# v+ v- in id it ie c0 c1 c2 c3 ; d0 d1 d2 d3 d< d> ; dismantle mesh into 3D faces, lines, and points (setq b* (getvar "splframe")) (setvar "splframe" 0) (command "_.explode" in) (setvar "splframe" b*) ; surface fit polygon meshes will not be ; dismantled correctly if splframe=1 (if (= 1 (logand 1 (getvar "qaflags"))) (command "")) ; qaflags=0 [default] - (command "explode") expects a single object ; qaflags=1 - (command "explode") expects complete selection set (setq b (ssget "_p" ll)) ; do not slice components on locked layers (if b (progn (setq b# (sslength b) j# 0 ) (if d+ (setq b+ (ssadd) v+ 0 ) ) (if d- (setq b- (ssadd) v- 0 ) ) (while (> b# j#) (setq in (ssname b j#) id (entget in) it (cdr (assoc 0 id)) ) (cond ( (= "3DFACE" it) (setq c0 (cdr (setq i0 (assoc 10 id))) c1 (cdr (setq i1 (assoc 11 id))) c2 (cdr (setq i2 (assoc 12 id))) c3 (cdr (setq i3 (assoc 13 id))) ; corners d0 (scalarProduct nv (mapcar '- c0 p1)) d1 (scalarProduct nv (mapcar '- c1 p1)) d2 (scalarProduct nv (mapcar '- c2 p1)) d3 (scalarProduct nv (mapcar '- c3 p1)) d< (max d0 d1 d2 d3) d> (min d0 d1 d2 d3) ; distances from slicing plane ie (assoc 70 id) ; visibility of edges ) (cond ( (and (<= tol d<) (>= (- tol) d>)) ; 3D face crosses slicing plane (xsliceProcessFace) ) ( (<= tol d<) ; 3D face is entirely on positive side (if d+ (progn (ssadd in b+) (setq v+ (+ 4 v+))) (entdel in) ) ) ( (>= (- tol) d>) ; 3D face is entirely on negative side (if d- (progn (ssadd in b-) (setq v- (+ 4 v-))) (entdel in) ) ) ( t ; 3D face is entirely on the slicing plane (if d+ (progn (ssadd in b+) (setq v+ (+ 4 v+))) (progn (ssadd in b-) (setq v- (+ 4 v-))) ) ) ) ) ( (= "LINE" it) (setq i0 (assoc 10 id) i1 (assoc 11 id) ; data groups of start point and end point d0 (scalarProduct nv (mapcar '- (cdr i0) p1)) d1 (scalarProduct nv (mapcar '- (cdr i1) p1)) ; distances from slicing plane ) (cond ( (or (and (<= tol d0) (>= (- tol) d1)) (and (>= (- tol) d0) (<= tol d1)) ) ; line crosses slicing plane (xsliceProcessLine) ) ( (or (<= tol d0) (<= tol d1)) ; line is entirely on positive side (if d+ (progn (ssadd in b+) (setq v+ (+ 2 v+))) (entdel in) ) ) ( (or (>= (- tol) d0) (>= (- tol) d1)) ; line is entirely on negative side (if d- (progn (ssadd in b-) (setq v- (+ 2 v-))) (entdel in) ) ) ( t ; line is entirely on the slicing plane (if d+ (progn (ssadd in b+) (setq v+ (+ 2 v+))) (progn (ssadd in b-) (setq v- (+ 2 v-))) ) ) ) ) ( t ; (= "POINT" it) (setq d0 (scalarProduct nv (mapcar '- (cdr (assoc 10 id)) p1) ) ) (cond ( (<= tol d0) ; point is on positive side (if d+ (progn (ssadd in b+) (setq v+ (1+ v+))) (entdel in) ) ) ( (>= (- tol) d0) ; point is on negative side (if d- (progn (ssadd in b-) (setq v- (1+ v-))) (entdel in) ) ) ( t ; point is on the slicing plane (if d+ (progn (ssadd in b+) (setq v+ (1+ v+))) (progn (ssadd in b-) (setq v- (1+ v-))) ) ) ) ) ) (setq j# (1+ j#)) ) (if d+ (if (> 8192 (setq b# (sslength b+))) (sewProcessSet b+ b# v+) (princ (if ger (strcat "Das Zusammenfassen der " (itoa b#) " Teile zu einem Polyflächennetz" " ist nicht möglich (maximal 8191).\n" ) (strcat "Cannot reassemble " (itoa b#) " components to a polyface mesh" " (not more than 8191).\n" ) ) ) ) ) (if d- (if (> 8192 (setq b# (sslength b-))) (sewProcessSet b- b# v-) (princ (if ger (strcat "Das Zusammenfassen der " (itoa b#) " Teile zu einem Polyflächennetz" " ist nicht möglich (maximal 8191).\n" ) (strcat "Cannot reassemble " (itoa b#) " components to a polyface mesh" " (not more than 8191).\n" ) ) ) ) ) ) ) (setq b* nil) ) (defun doNotSlice ( ) ; The following variables declared in the main routine ; are used within this subroutine: ; get: in it d< d> d+ d- tol ; set: u u# n# ; für Objekte, die nicht von der Ebene geschnitten werden ; for objects that are not intersected by the plane (setq n# (1+ n#)) (if (cond ( (= "LINE" it) (or (and (not d+) (or (<= tol d0) (<= tol d1))) (and (not d-) (or (>= (- tol) d0) (>= (- tol) d1))) ) ) ( (or (= "RAY" it) (= "XLINE" it)) (or (and (not d+) (<= tol d0)) (and (not d-) (>= (- tol) d0)) ) ) ( (or (= "3DFACE" it) (= "POLYLINE" it)) (or (and (not d+) (<= tol d<)) (and (not d-) (>= (- tol) d>)) ) ) ) (progn (ssadd in u) ; Objects situated (setq u# (1+ u#)) ; entirely on the undesired side (redraw in 3) ; get highlighted ) ; and prepared for deletion. ) ) ;;; Unterprogramme 3. Ordnung für xsliceProcessFace ;;; zum Modifizieren der Elementdatenliste ;;; einer geschnittenen 3d-Fläche ;;; ;;; Die Schnittkanten sollen in jedem Fall sichtbar sein; ;;; aber diejenigen Kanten sollen unsichtbar werden, welche ;;; bei der eventuell nötigen Aufteilung einer entstehenden Fläche ;;; längs der ursprünglichen Diagonalen nach dem Schnitt ;;; zu einer Außenkante eines neuen Dreiecks oder Vierecks werden. ;;; 3rd order subroutines for xsliceProcessFace ;;; for modifying the entity data list of a sliced 3D face ;;; ;;; Edges generated by slicing should be visible in any case ;;; [with the exception of the former "diagonals" ;;; that did not lie on the slicing plane ;;; but became outer edges of new triangles or quadrangles ;;; created because a pentangle or a hexangle had to be split]. ;;; Edges that retained their places should also retain their ;;; visibility or invisibility. ;; Standard-Routine ;; Standard routine (defun modFace ( cp cq cr cs ; neue Lage der Eckpunkte, falls nicht nil k0 ; Bitcode: ; für Kanten, die sichtbar werden sollen, ; wird das entsprechende Bit auf Null gesetzt k1 ; Bitcode: ; für Kanten, die unsichtbar werden sollen, ; wird das entsprechende Bit auf Eins gesetzt f* ; Flag: Fläche muss neu erzeugt werden f+ ; Flag: Fläche liegt auf der positiven Seite / md ; modifizierte Elementdatenliste ) ;| cp cq cr cs ; new positions of the corners if not nil k0 ; code: bit corresponding to an edge ; that has to become visible is set to zero k1 ; code: bit corresponding to an edge ; that has to become invisible is set to one f* ; flag: face has to be created newly f+ ; flag: face is on positive side / md ; modified entity data list |; ; The following variables declared in the main routine ; are used within this subroutine: ; get: id ie i0 i1 i2 i3 b* ; set: b+ b- v+ v- (setq md (subst (cons 70 (logior k1 (logand k0 (cdr ie)))) ie id)) (if cp (setq md (subst (cons 10 cp) i0 md))) (if cq (setq md (subst (cons 11 cq) i1 md))) (if cr (setq md (subst (cons 12 cr) i2 md))) (if cs (setq md (subst (cons 13 cs) i3 md))) ((if f* entmake entmod) md) (if b* (if f+ (progn (ssadd (if f* (entlast) in) b+) (setq v+ (+ 4 v+))) (progn (ssadd (if f* (entlast) in) b-) (setq v- (+ 4 v-))) ) ) ; b* is not nil if the face is a component of a dismantled mesh ) ;; Modifizieren der Elementdatenliste einer 3d-Fläche, ;; der die zweite Ecke abgeschnitten wird ;; [für AutoCAD 14 und IntelliCAD 2000] ;; [Ausgabe: viereckiger Teil des entstehenden Fünfecks / Sechsecks] ;; Modifying the data list of a 3D face whose second corner is cut ;; [for AutoCAD 14 and IntelliCAD 2000] ;; [Output: quadrilateral part of a new pentangle or hexangle] (defun modFace-1 ( f* ; Flag: Fläche muss neu erzeugt werden f+ ; Flag: Fläche liegt auf der positiven Seite / md ; modifizierte Elementdatenliste ) ;| f* ; flag: face has to be created newly f+ ; flag: face is on positive side / md ; modified entity data list |; ; The following variables declared in the main routine ; are used within this subroutine: ; get: in id ie ip iq i1 i2 i3 c2 b* ; set: b+ b- v+ v- (setq md (subst (cons 70 (logior 8 (logand 1 (cdr ie)) (lsh (logand 2 (cdr ie)) 1)) ) ie ; new edge inserted between first and second edge (subst (cons 13 c2) i3 (subst (cons 12 iq) i2 (subst (cons 11 ip) i1 id)) ) ) ) ((if f* entmake entmod) md) (if b* (if f+ (progn (ssadd (if f* (entlast) in) b+) (setq v+ (+ 4 v+))) (progn (ssadd (if f* (entlast) in) b-) (setq v- (+ 4 v-))) ) ) ; b* is not nil if the face is a component of a dismantled mesh ) ;; Modifizieren der Elementdatenliste einer 3d-Fläche, ;; der die vierte Ecke abgeschnitten wird ;; [für AutoCAD 14 und IntelliCAD 2000] ;; [Ausgabe: viereckiger Teil des entstehenden Fünfecks / Sechsecks] ;; Modifying the data list of a 3D face whose fourth corner is cut ;; [for AutoCAD 14 and IntelliCAD 2000] ;; [Output: quadrilateral part of a new pentangle or hexangle] (defun modFace-3 ( f* ; Flag: Fläche muss neu erzeugt werden f+ ; Flag: Fläche liegt auf der positiven Seite / md ; modifizierte Elementdatenliste ) ;| f* ; flag: face has to be created newly f+ ; flag: face is on positive side / md ; modified entity data list |; ; The following variables declared in the main routine ; are used within this subroutine: ; get: in id ie ir is i1 i2 i3 c2 b* ; set: b+ b- v+ v- (setq md (subst (cons 70 (logior 1 (logand 8 (cdr ie)) (lsh (logand 4 (cdr ie)) -1)) ) ie ; new edge inserted between third and fourth edge (subst (cons 11 c2) i1 (subst (cons 12 ir) i2 (subst (cons 13 is) i3 id)) ) ) ) ((if f* entmake entmod) md) (if b* (if f+ (progn (ssadd (if f* (entlast) in) b+) (setq v+ (+ 4 v+))) (progn (ssadd (if f* (entlast) in) b-) (setq v- (+ 4 v-))) ) ) ; b* is not nil if the face is a component of a dismantled mesh ) ;; Modifizieren der Elementdatenliste einer 3d-Fläche, ;; der die erste Ecke abgeschnitten wird [für AutoCAD 2000] ;; [Ausgabe: viereckiger Teil des entstehenden Fünfecks / Sechsecks] ;; Modifying the data list of a 3D face whose first corner is cut ;; [for AutoCAD 2000] ;; [Output: quadrilateral part of a new pentangle or hexangle] (defun modFace-0 ( f* ; Flag: Fläche muss neu erzeugt werden f+ ; Flag: Fläche liegt auf der positiven Seite / md ; modifizierte Elementdatenliste ) ;| f* ; flag: face has to be created newly f+ ; flag: face is on positive side / md ; modified entity data list |; ; The following variables declared in the main routine ; are used within this subroutine: ; get: in id ie ip iq i0 i1 i2 c1 b* ; set: b+ b- v+ v- (setq md (subst (cons 70 (logior 4 (logand 8 (cdr ie)) (lsh (logand 1 (cdr ie)) 1)) ) ie ; new edge inserted between fourth and first edge (subst (cons 12 c1) i2 (subst (cons 11 iq) i1 (subst (cons 10 ip) i0 id)) ) ) ) ((if f* entmake entmod) md) (if b* (if f+ (progn (ssadd (if f* (entlast) in) b+) (setq v+ (+ 4 v+))) (progn (ssadd (if f* (entlast) in) b-) (setq v- (+ 4 v-))) ) ) ; b* is not nil if the face is a component of a dismantled mesh ) ;; Modifizieren der Elementdatenliste einer 3d-Fläche, ;; der die dritte Ecke abgeschnitten wird [für AutoCAD 2000] ;; [Ausgabe: viereckiger Teil des entstehenden Fünfecks / Sechsecks] ;; Modifying the data list of a 3D face whose third corner is cut ;; [for AutoCAD 2000] ;; [Output: quadrilateral part of a new pentangle or hexangle] (defun modFace-2 ( f* ; Flag: Fläche muss neu erzeugt werden f+ ; Flag: Fläche liegt auf der positiven Seite / md ; modifizierte Elementdatenliste ) ;| f* ; flag: face has to be created newly f+ ; flag: face is on positive side / md ; modified entity data list |; ; The following variables declared in the main routine ; are used within this subroutine: ; get: in id ie ir is i0 i1 i2 c1 b* ; set: b+ b- v+ v- (setq md (subst (cons 70 (logior 8 (logand 4 (cdr ie)) (lsh (logand 2 (cdr ie)) -1)) ) ie ; new edge inserted between third and fourth edge (subst (cons 10 c1) i0 (subst (cons 11 ir) i1 (subst (cons 12 is) i2 id)) ) ) ) ((if f* entmake entmod) md) (if b* (if f+ (progn (ssadd (if f* (entlast) in) b+) (setq v+ (+ 4 v+))) (progn (ssadd (if f* (entlast) in) b-) (setq v- (+ 4 v-))) ) ) ; b* is not nil if the face is a component of a dismantled mesh ) ;_____________________________________________________________________; ;;; Funktion WANDELN ;;; wandelt Punkte in Linien, Linien in 3d-Flächen, ;;; 3d-Flächen in Polyflächennetze sowie ;;; Polylinien in Polygonnetze, ;;; offene Polygonnetze in Gruppen offener Polygonnetze. ;;; ;;; Dies geschieht entlang einer Verschiebung, die Sie ;;; analog zu den Befehlen "schieben", "kopieren" und "strecken" ;;; angeben. ;;; ;;; Die ursprünglichen Punkte, Linien, 3d-Flächen, Polylinien ;;; werden gelöscht, wenn die Systemvariable "delobj" gleich 1 ist. ;;; ;;; Objekte mit einer von Null verschiedenen Objekthöhe ;;; können nicht ausgewählt werden. ;;; Objekte auf gesperrten Layern werden nicht gewandelt. ;;; ;;; Wenn eine Kante einer Original-3d-Fläche unsichtbar ist, ;;; so wird im neuen Polyflächennetz an entsprechender Stelle ;;; keine Seitenfläche erstellt. [Vgl. Befehl "edge".] ;;; ;;; Eine Krümmung ["Ausbuchtung"] von Polylinien-Segmenten ;;; wird beim Erstellen eines Polygonnetzes nicht berücksichtigt ;;; [als wären die Kontrollpunkte durch gerade Linien verbunden]. ;;; Ist das Original ein Polygonnetz, so dient dieses als Grundfläche ;;; und es werden weitere fünf Netze ;;; als Deck- und Seitenflächen erstellt. ;;; Die Netze werden jeweils zu einer Gruppe zusammengefasst ;;; [vgl. AutoCAD-Befehl "Gruppe"; von IntelliCAD nicht unterstützt]. ;;; Der Name der Gruppe beginnt mit "LIFT" ;;; und enthält Datum und Uhrzeit der Erstellung. (defun c:wandeln ( / s ; Auswahlsatz p1 ; erster Punkt der Verschiebung im aktuellen BKS p2 ; zweiter Punkt der Verschiebung im aktuellen BKS vd ; Verschiebungsvektor im WKS tt ; temporäres Testflag r14 ; Flag: Release 14 ger ; Flag: deutsche Version tol ; Toleranz echo ; Systemvariable "cmdecho" [command echo] errr ; systemeigene Fehlerbearbeitungs-Routine ) (standardInitiate) (liftSelect) (liftInput) (lockedFilter) (liftProcess s vd) (standardTerminate) ) ;;; Function LIFT ;;; transforms points to lines, lines to 3D faces, ;;; 3D faces to polyface meshes; ;;; polylines to polygon meshes, ;;; and open polygon meshes to groups of open polygon meshes. ;;; ;;; The displacement gets specified ;;; like in the "move", "copy", and "stretch" commands. ;;; ;;; Original points, lines, 3D faces, and polylines will be erased ;;; if the "delobj" system variable equals 1. ;;; ;;; Objects with a non-zero thickness cannot be selected. ;;; Objects on locked layers do not get lifted. ;;; ;;; If an edge of an original 3D face is invisible, then ;;; the corresponding side face of the new polyface mesh is left out. ;;; [Cf. "edge" command.] ;;; ;;; Bulges of polylines are ignored ;;; [as if the arc segments were straightened; ;;; vertices connected directly by line segments]. ;;; If the original is a polygon mesh, the LIFT function ;;; will create five new meshes serving as "top" and "side" faces. ;;; These meshes are combined to a group ;;; [cf. AutoCAD "group" command; not supported by IntelliCAD]. ;;; The name of the group begins with "LIFT" ;;; and contains date and time of its creation. (defun c:lift ( / s ; selection set p1 ; first point of displacement [current UCS] p2 ; second point of displacement [current UCS] vd ; displacement vector [WCS] tt ; temporary test flag r14 ; flag: release 14 ger ; flag: German version tol ; tolerance echo ; "cmdecho" system variable [command echo] errr ; system's error handling routine ) (standardInitiate) (liftSelect) (liftInput) (lockedFilter) (liftProcess s vd) (standardTerminate) ) ;;; Unterprogramme 1. Ordnung für WANDELN ;;; 1st order subroutines for LIFT (defun liftSelect ( ) ; The following variables declared in the main routine ; are used within this subroutine: ; get: ger ; set: s s# tt (setq tt t) (while tt (princ (if ger (strcat " - Punkte, Linien, 3d-Flächen," " Polylinien, offene Polygonnetze -" ) (strcat " - points, lines, 3D faces," " polylines, open polygon meshes -" ) ) ) (setq s (ssget '( (-4 . "") ; not fit/smooth (-4 . "") ; not fit/smooth (-4 . "") ; not fit/smooth (-4 . "") ; not fit/smooth (-4 . "") ; not fit/smooth (-4 . "") (-4 . "") (-4 . "") (-4 . "") (-4 . "") ; IntelliCAD does not work correctly (-4 . "or>") ; with (-4 . "&") (39 . 0.0) ; zero thickness ) ) ) (if s (setq s# (sslength s) tt nil ) (princ (if ger "\nEs wurde keine gültige Auswahl getroffen." "\nNo valid selection made." ) ) ) ) ) (defun liftInput ( ) ; The following variables declared in the main routine ; are used within this subroutine: ; get: ger ; set: p1 p2 vd r14 (setq r14 (wcmatch (ver) "*14*")) ;; Verschiebungsvektor definieren ;; Define displacement vector (initget 1) ; not just "Enter" (setq p1 (getpoint (if ger (if r14 "\nBasispunkt oder Verschiebung: " "\nBasispunkt oder Verschiebung angeben: " ) (if r14 "\nBase point or displacement: " "\nSpecify base point or displacement: " ) ) ) p2 (getpoint p1 (if ger (if r14 "\nZweiter Punkt der Verschiebung: " (strcat "\n" "Zweiten Punkt der Verschiebung angeben oder " ": " ) ) (if r14 "\nSecond point of displacement: " (strcat "\n" "Specify second point of displacement or " ": " ) ) ) ) vd (trans (if p2 (mapcar '- p2 p1) p1) 1 0 t) ) ) (defun liftProcess ( s ; Auswahlsatz vd ; Verschiebungsvektor [3d, WKS] / s# ; Anzahl der ausgewählten Objekte i# ; Index des aktuell bearbeiteten Objekts in ; Elementname des aktuell bearbeiteten Objekts id ; Datenliste des aktuell bearbeiteten Objekts it ; Typ des aktuell bearbeiteten Objekts ib ; Flag-Bits einer aktuell bearbeiteten Polylinie iv ; Extrusionsrichtung einer aktuell bearbeiteten Polylinie ih ; Erhebung einer aktuell bearbeiteten Polylinie ie ; Bitcode: Sichtbarkeit der Kanten einer 3d-Fläche c0 c1 ; [Eck-, Start-, End-] Punkte im WKS c2 c3 c> ; Liste aller Scheitelpunkte ; [bei Polygonnetzen: zeilenweise zusammengefasst] c< ; umgekehrte / transponierte Liste aller Scheitelpunkte c* ; temporäre Kopie von c> bzw. c< c- ; Scheitelpunkt-Liste der aktuellen Zeile aus c> bzw. c< cn ; Elementname des aktuellen Scheitelpunktes cd ; Elementdatenliste des aktuellen Scheitelpunktes c# ; Anzahl aller Scheitelpunkte m# n# ; M- und N-Wert des Polygonnetzes ; [Anzahl der Scheitelpunkte pro Spalte bzw. Zeile] j# k# ; Index der aktuellen Zeile bzw. Spalte e0 e1 ; Sichtbarkeit einzelner Kanten einer 3d-Fläche e2 e3 md ; Datenliste eines neu zu erstellenden Objekts v^ f^ ; Liste aller Scheitelpunkte bzw. Teilflächen ; eines neu zu erstellenden Polyflächennetzes fr ; Scheitelpunkt-Zuordnungen der aktuellen Teilfläche m^ ; Liste der Elementnamen erstellter Polygonnetze tol ; Toleranz delo ; Systemvariable "delobj" [delete objects] ) ;| s ; selection set vd ; displacement vector [3D, WCS] / s# ; number of objects selected i# ; index of object currently worked on in ; entity name of object currently worked on id ; data list of object currently worked on it ; type of object currently worked on ib ; flag bits of a polylinie currently worked on iv ; extrusion direction of a polylinie currently worked on ih ; elevation of a polylinie currently worked on ie ; bit code: visibility of edges of a 3D face c0 c1 ; [corner, start, end] points in WCS c2 c3 c> ; list of all vertices ; [polygon meshes: every row forms a sublist of c>] c< ; reversed / transposed list of all vertices c* ; temporary copy of c> or c< c- ; vertex list of the current row of c> or c< cn ; entity name of the current vertex cd ; entity data list of the current vertex c# ; number of all vertices m# n# ; M and N value of the polygon mesh ; [number of vertices per row / per column] j# k# ; index of current row / current column e0 e1 ; visibility of single edges of a 3D face e2 e3 md ; data list of an object to be created v^ f^ ; list of all vertices / face records ; of a polyface mesh to be created fr ; current face record m^ ; list of entity names of polygon meshes created tol ; tolerance delo ; "delobj" system variable [delete objects] |; (setq tol 1.0e-012 delo (< 0 (getvar "delobj")) ) (setq s# (sslength s) i# 0 ) (while (> s# i#) (setq in (ssname s i#) id (entget in) it (cdr (assoc 0 id)) i# (1+ i#) ) (cond ( (= "POINT" it) (liftProcessPoint) ) ( (= "LINE" it) (liftProcessLine) ) ( (= "3DFACE" it) (liftProcessFace) ) ( (= "LWPOLYLINE" it) (setq ib (cdr (assoc 70 id))) (liftProcessPolyline) ) ( (= "POLYLINE" it) (setq ib (cdr (assoc 70 id))) (cond ( (and (= 16 (logand 16 ib)) ; polygon mesh (= 0 (logand 39 ib)) ; open, not fit/smooth ) (liftProcessMesh) ) ( (and (= 0 (logand 86 ib)) ; not a mesh, ) ; not fit/smooth (liftProcessPolyline) ) ( t nil ) ) ) ( t nil ) ) ) ) ;;; Unterprogramme 2. Ordnung für liftProcess ;;; 2nd order subroutines for liftProcess (defun liftProcessPoint ( ) ; The following variables declared in liftProcess ; are used within this subroutine: ; get: in id vd delo ; set: c0 md (setq c0 (cdr (assoc 10 id))) (if (setq md (assoc 210 id)) ; extrusion direction (setq md (list md)) ) (setq md (cons (cons 11 (mapcar '+ c0 vd)) md) md (cons (cons 10 c0) md) md (cons '(100 . "AcDbLine") md) md (append (getAssignments) md) md (cons '(0 . "LINE") md) ) (entmake md) (if delo (entdel in)) ) (defun liftProcessLine ( ) ; The following variables declared in liftProcess ; are used within this subroutine: ; get: in id vd delo ; set: c0 c1 md (setq c0 (cdr (assoc 10 id)) c1 (cdr (assoc 11 id)) md '((70 . 0)) ; all edges visible md (cons (cons 13 (mapcar '+ c0 vd)) md) md (cons (cons 12 (mapcar '+ c1 vd)) md) md (cons (cons 11 c1) md) md (cons (cons 10 c0) md) md (cons '(100 . "AcDbFace") md) md (append (getAssignments) md) md (cons '(0 . "3DFACE") md) ) (entmake md) (if delo (entdel in)) ) (defun liftProcessFace ( ) ; The following variables declared in liftProcess ; are used within this subroutine: ; get: in id vd tol delo ; set: c0 c1 c2 c3 ie e0 e1 e2 e3 v^ f^ fr ;; Verarbeitung ;; Processing (setq c0 (cdr (assoc 10 id)) c1 (cdr (assoc 11 id)) c2 (cdr (assoc 12 id)) c3 (cdr (assoc 13 id)) ie (cdr (assoc 70 id)) e0 (zerop (logand 1 ie)) e1 (zerop (logand 2 ie)) e2 (zerop (logand 4 ie)) e3 (zerop (logand 8 ie)) f^ nil ) (if (equal c2 c3 tol) (progn ; triangle (if e3 (setq f^ (cons (list 3 6 4 1) f^))) ; left (if e1 (setq f^ (cons (list 2 5 6 3) f^))) ; right (if e0 (setq f^ (cons (list 1 4 5 2) f^))) ; front (setq f^ ; top (cons (list (if e3 4 -4) (if e1 6 -6) (if e0 5 -5) 0 ) f^ ) f^ ; bottom (cons (list (if e0 1 -1) (if e1 2 -2) (if e3 3 -3) 0 ) f^ ) v^ (list c0 c1 c2 (mapcar '+ c0 vd) (mapcar '+ c1 vd) (mapcar '+ c2 vd) ) ) ) (progn ; quadrangle (if e3 (setq f^ (cons (list 4 8 5 1) f^))) ; left (if e2 (setq f^ (cons (list 3 7 8 4) f^))) ; back (if e1 (setq f^ (cons (list 2 6 7 3) f^))) ; right (if e0 (setq f^ (cons (list 1 5 6 2) f^))) ; front (setq f^ ; top (cons (list (if e3 5 -5) (if e2 8 -8) (if e1 7 -7) (if e0 6 -6) ) f^ ) f^ ; bottom (cons (list (if e0 1 -1) (if e1 2 -2) (if e2 3 -3) (if e3 4 -4) ) f^ ) v^ (list c0 c1 c2 c3 (mapcar '+ c0 vd) (mapcar '+ c1 vd) (mapcar '+ c2 vd) (mapcar '+ c3 vd) ) ) ) ) ;; Ausgabe ;; Output (setq md (getAssignments)) (entmake (append '((0 . "POLYLINE")) md (list '(100 . "AcDbPolyFaceMesh") '(66 . 1) ; vertex subentities follow '(10 0.0 0.0 1.0) ; "dummy" point '(70 . 64) ; polyface mesh '(40 . 0.0) ; start width '(41 . 0.0) ; end width '(210 0.0 0.0 1.0) ; extrusion direction (cons 71 (length v^)) ; number of vertices (cons 72 (length f^)) ; number of component faces '(73 . 0) '(74 . 0) '(75 . 0) ; not fit/smooth ) ) ) (while v^ (entmake (append '((0 . "VERTEX")) md (list '(100 . "AcDbVertex") '(100 . "AcDbPolyFaceMeshVertex") (cons 10 (car v^)) '(40 . 0.0) ; start width '(41 . 0.0) ; end width '(42 . 0.0) ; bulge '(70 . 192) ; polyface mesh vertex '(50 . 0.0) ; X axis angle when point was drawn '(71 . 0) '(72 . 0) '(73 . 0) '(74 . 0) ; not fit/smooth ) ) ) (setq v^ (cdr v^)) ) (while f^ (setq fr (car f^) f^ (cdr f^) ) (entmake (append '((0 . "VERTEX")) md (list '(100 . "AcDbFaceRecord") '(10 0.0 0.0 0.0) ; "dummy" point '(40 . 0.0) ; start width '(41 . 0.0) ; end width '(42 . 0.0) ; bulge '(70 . 128) ; polyface mesh face record '(50 . 0.0) ; X axis angle when point was drawn (cons 71 (car fr)) (cons 72 (cadr fr)) (cons 73 (caddr fr)) (cons 74 (cadddr fr)) ) ) ) ) (entmake (append '((0 . "SEQEND")) md ) ) (if delo (entdel in)) ) (defun liftProcessPolyline ( ) ; The following variables declared in liftProcess ; are used within this subroutine: ; get: in id it ib vd ger delo ; set: iv ih c# c< c> cn cd md (setq iv (cdr (assoc 210 id)) ; extrusion direction c< nil ) (cond ( (= "LWPOLYLINE" it) (setq ih (list (cdr (assoc 38 id))) ; elevation ) (foreach item id (if (= 10 (car item)) (setq c< (cons (trans (append (cdr item) ih) iv 0) c<)) ) ) ) ( (zerop (logand 8 ib)) ; heavy 2D polyline (setq ih (list (cadddr (assoc 10 id))) ; elevation cn (entnext in) cd (entget cn) ) (while (= "VERTEX" (cdr (assoc 0 cd))) (setq c< (cons (trans (append (cdr (assoc 10 cd)) ih) iv 0) c< ) cn (entnext cn) cd (entget cn) ) ) ) ( t ; 3D polyline (setq cn (entnext in) cd (entget cn) ) (while (= "VERTEX" (cdr (assoc 0 cd))) (setq c< (cons (cdr (assoc 10 cd)) c<) cn (entnext cn) cd (entget cn) ) ) ) ) (setq c# (length c<)) ; number of vertices (cond ( (< 16383 c#) (princ (if ger (strcat "\n" " Eine Polylinie mit " (itoa c#) " Scheitelpunkten kann nicht in ein Netz" " verwandelt werden (maximal 16383)." ) (strcat "\n" " Cannot lift a polyline with " (itoa c#) " vertices (not more than 16383)." ) ) ) ) ( (= 1 c#) (entmake (append '((0 . "LINE")) (getAssignments) (list '(100 . "AcDbLine") (cons 10 (car c<)) ; start point (cons 11 (mapcar '+ (car c<) vd)) ; end point (cons 210 iv) ; extrusion direction ) ) ) (if delo (entdel in)) ) ( t ; (and (< 1 c#) (> 16384 c#)) (setq c> (reverse c<) md (getAssignments) ) (entmake (append '((0 . "POLYLINE")) md (list '(100 . "AcDbPolygonMesh") '(66 . 1) ; vertex subentities follow '(10 0.0 0.0 1.0) ; "dummy" point (cons 70 (logior 16 (logand 129 ib))) ; flag bits '(40 . 0.0) ; start width '(41 . 0.0) ; end width '(210 0.0 0.0 1.0) ; extrusion direction (cons 71 c#) ; M value '(72 . 2) ; N value '(73 . 0) '(74 . 0) '(75 . 0) ; not fit/smooth ) ) ) (while c> (entmake (append '((0 . "VERTEX")) md (list '(100 . "AcDbVertex") '(100 . "AcDbPolygonMeshVertex") (cons 10 (car c>)) '(40 . 0.0) ; start width '(41 . 0.0) ; end width '(42 . 0.0) ; bulge '(70 . 64) ; polygon mesh vertex '(50 . 0.0) ; X axis angle when point was drawn '(71 . 0) '(72 . 0) '(73 . 0) '(74 . 0) ; not fit/smooth ) ) ) (entmake (append '((0 . "VERTEX")) md (list '(100 . "AcDbVertex") '(100 . "AcDbPolygonMeshVertex") (cons 10 (mapcar '+ (car c>) vd)) '(40 . 0.0) ; start width '(41 . 0.0) ; end width '(42 . 0.0) ; bulge '(70 . 64) ; polygon mesh vertex '(50 . 0.0) ; X axis angle when point was drawn '(71 . 0) '(72 . 0) '(73 . 0) '(74 . 0) ; not fit/smooth ) ) ) (setq c> (cdr c>)) ) (entmake (append '((0 . "SEQEND")) md ) ) (if delo (entdel in)) ) ) ) (defun liftProcessMesh ( ) ; The following variables declared in liftProcess ; are used within this subroutine: ; get: in id vd m# n# ; set: c> c< c* c- m^ md mr ms mt ;; Verarbeitung ;; Processing (retrievePolygonMesh) (setq c< (transpose c>)) ;; Ausgabe ;; Output ; bottom: original M*N polygon mesh (setq m^ (list in) md (getAssignments) ) ; top: flipped N*M polygon mesh (entmake ; "POLYLINE" header (subst (cons 71 n#) (cons 71 m#) (subst (cons 72 m#) (cons 72 n#) id) ) ) (setq c* c<) (while c* (setq c- (car c*) c* (cdr c*) ) (while c- (entmake (append '((0 . "VERTEX")) md (list '(100 . "AcDbVertex") '(100 . "AcDbPolygonMeshVertex") (cons 10 (mapcar '+ (car c-) vd)) '(40 . 0.0) ; start width '(41 . 0.0) ; end width '(42 . 0.0) ; bulge '(70 . 64) ; polygon mesh vertex '(50 . 0.0) ; X axis angle when point was drawn '(71 . 0) '(72 . 0) '(73 . 0) '(74 . 0) ; not fit/smooth ) ) ) (setq c- (cdr c-)) ) ) (entmake (append '((0 . "SEQEND")) md ) ) (setq m^ (cons (entlast) m^)) ; front: N*2 polygon mesh (entmake ; "POLYLINE" header (subst (cons 71 n#) (cons 71 m#) (subst '(72 . 2) (cons 72 n#) id) ) ) (setq c- (car c>)) (while c- (entmake (append '((0 . "VERTEX")) md (list '(100 . "AcDbVertex") '(100 . "AcDbPolygonMeshVertex") (cons 10 (car c-)) '(40 . 0.0) ; start width '(41 . 0.0) ; end width '(42 . 0.0) ; bulge '(70 . 64) ; polygon mesh vertex '(50 . 0.0) ; X axis angle when point was drawn '(71 . 0) '(72 . 0) '(73 . 0) '(74 . 0) ; not fit/smooth ) ) ) (entmake (append '((0 . "VERTEX")) md (list '(100 . "AcDbVertex") '(100 . "AcDbPolygonMeshVertex") (cons 10 (mapcar '+ (car c-) vd)) '(40 . 0.0) ; start width '(41 . 0.0) ; end width '(42 . 0.0) ; bulge '(70 . 64) ; polygon mesh vertex '(50 . 0.0) ; X axis angle when point was drawn '(71 . 0) '(72 . 0) '(73 . 0) '(74 . 0) ; not fit/smooth ) ) ) (setq c- (cdr c-)) ) (entmake (append '((0 . "SEQEND")) md ) ) (setq m^ (cons (entlast) m^)) ; right: M*2 polygon mesh (entmake (subst '(72 . 2) (cons 72 n#) id)) ; "POLYLINE" header (setq c- (last c<)) (while c- (entmake (append '((0 . "VERTEX")) md (list '(100 . "AcDbVertex") '(100 . "AcDbPolygonMeshVertex") (cons 10 (car c-)) '(40 . 0.0) ; start width '(41 . 0.0) ; end width '(42 . 0.0) ; bulge '(70 . 64) ; polygon mesh vertex '(50 . 0.0) ; X axis angle when point was drawn '(71 . 0) '(72 . 0) '(73 . 0) '(74 . 0) ; not fit/smooth ) ) ) (entmake (append '((0 . "VERTEX")) md (list '(100 . "AcDbVertex") '(100 . "AcDbPolygonMeshVertex") (cons 10 (mapcar '+ (car c-) vd)) '(40 . 0.0) ; start width '(41 . 0.0) ; end width '(42 . 0.0) ; bulge '(70 . 64) ; polygon mesh vertex '(50 . 0.0) ; X axis angle when point was drawn '(71 . 0) '(72 . 0) '(73 . 0) '(74 . 0) ; not fit/smooth ) ) ) (setq c- (cdr c-)) ) (entmake (append '((0 . "SEQEND")) md ) ) (setq m^ (cons (entlast) m^)) ; back: N*2 polygon mesh (entmake ; "POLYLINE" header (subst (cons 71 n#) (cons 71 m#) (subst '(72 . 2) (cons 72 n#) id) ) ) (setq c- (last c>)) (while c- (entmake (append '((0 . "VERTEX")) md (list '(100 . "AcDbVertex") '(100 . "AcDbPolygonMeshVertex") (cons 10 (mapcar '+ (car c-) vd)) '(40 . 0.0) ; start width '(41 . 0.0) ; end width '(42 . 0.0) ; bulge '(70 . 64) ; polygon mesh vertex '(50 . 0.0) ; X axis angle when point was drawn '(71 . 0) '(72 . 0) '(73 . 0) '(74 . 0) ; not fit/smooth ) ) ) (entmake (append '((0 . "VERTEX")) md (list '(100 . "AcDbVertex") '(100 . "AcDbPolygonMeshVertex") (cons 10 (car c-)) '(40 . 0.0) ; start width '(41 . 0.0) ; end width '(42 . 0.0) ; bulge '(70 . 64) ; polygon mesh vertex '(50 . 0.0) ; X axis angle when point was drawn '(71 . 0) '(72 . 0) '(73 . 0) '(74 . 0) ; not fit/smooth ) ) ) (setq c- (cdr c-)) ) (entmake (append '((0 . "SEQEND")) md ) ) (setq m^ (cons (entlast) m^)) ; left: M*2 polygon mesh (entmake (subst '(72 . 2) (cons 72 n#) id)) ; "POLYLINE" header (setq c- (car c<)) (while c- (entmake (append '((0 . "VERTEX")) md (list '(100 . "AcDbVertex") '(100 . "AcDbPolygonMeshVertex") (cons 10 (mapcar '+ (car c-) vd)) '(40 . 0.0) ; start width '(41 . 0.0) ; end width '(42 . 0.0) ; bulge '(70 . 64) ; polygon mesh vertex '(50 . 0.0) ; X axis angle when point was drawn '(71 . 0) '(72 . 0) '(73 . 0) '(74 . 0) ; not fit/smooth ) ) ) (entmake (append '((0 . "VERTEX")) md (list '(100 . "AcDbVertex") '(100 . "AcDbPolygonMeshVertex") (cons 10 (car c-)) '(40 . 0.0) ; start width '(41 . 0.0) ; end width '(42 . 0.0) ; bulge '(70 . 64) ; polygon mesh vertex '(50 . 0.0) ; X axis angle when point was drawn '(71 . 0) '(72 . 0) '(73 . 0) '(74 . 0) ; not fit/smooth ) ) ) (setq c- (cdr c-)) ) (entmake (append '((0 . "SEQEND")) md ) ) (setq m^ (cons (entlast) m^) m^ (reverse m^) ) ; compose group (uniqueGroup m^ "LIFT") ) ;_____________________________________________________________________; ;;; Funktion WENDEN ;;; kehrt die Reihenfolge der Kontrollpunkte von ;;; Linien, 3d-Flächen, Polygonnetzen und Polyflächennetzen um. ;;; ;;; Dadurch werden die Flächen-Normalen invertiert. ;;; ;;; Objekte auf gesperrten Layern werden nicht gewendet. (defun c:wenden ( / s ; Auswahlsatz s# ; Anzahl der Objekte [auf nicht gesperrten Layern] l# ; Anzahl der Objekte auf gesperrten Layern ld ; Datenliste des aktuell überprüften Layers ll ; Liste aller gesperrten Layer der Zeichnung tt ; temporäres Testflag ger ; Flag: deutsche Version tol ; Toleranz echo ; Systemvariable "cmdecho" [command echo] errr ; systemeigene Fehlerbearbeitungs-Routine ) (standardInitiate) (flipSelect) (lockedFilter) (flipProcess s) (standardTerminate) ) ;;; Function FLIP ;;; reverses the order of vertices ;;; of lines, 3D faces, polygon meshes, and polyface meshes. ;;; ;;; Thereby the face normal directions are inverted. ;;; ;;; Objects on locked layers do not get flipped. (defun c:flip ( / s ; selection set s# ; number of objects [on unlocked layers] l# ; number of objects on locked layers ld ; data list of layer currently tested ll ; list of all locked layers of the drawing tt ; temporary test flag ger ; flag: German version tol ; tolerance echo ; "cmdecho" system variable [command echo] errr ; system's error handling routine ) (standardInitiate) (flipSelect) (lockedFilter) (flipProcess s) (standardTerminate) ) ;;; Unterprogramme 1. Ordnung für WENDEN ;;; 1st order subroutines for FLIP (defun flipSelect ( ) ; The following variables declared in the main routine ; are used within this subroutine: ; get: ger ; set: s s# tt (setq tt t) (while tt (princ (if ger (strcat " - Linien, 3d-Flächen," " Polygonnetze, Polyflächennetze -" ) (strcat " - lines, 3D faces," " polygon meshes, polyface meshes -" ) ) ) (setq s (ssget '( (-4 . "") ; not fit/smooth (-4 . "") (-4 . "") (-4 . "") (-4 . "") (-4 . "") (-4 . "") (-4 . "") (-4 . "") (-4 . "") ; IntelliCAD does not work correctly (-4 . "or>") ; with (-4 . "&") (70 . 80) ) ) ) (if s (setq s# (sslength s) tt nil ; selection succeeded ) (princ (if ger "\nEs wurde keine gültige Auswahl getroffen." "\nNo valid selection made." ) ) ) ) ) (defun flipProcess ( s ; Auswahlsatz / s# ; Anzahl der ausgewählten Objekte i# ; Index des aktuell bearbeiteten Objekts in ; Elementname des aktuell bearbeiteten Objekts id ; Datenliste des aktuell bearbeiteten Objekts it ; Typ des aktuell bearbeiteten Objekts ib ; Flag-Bits einer aktuell bearbeiteten Polylinie ie ; Bitcode: Sichtbarkeit der Kanten einer 3d-Fläche c0 c1 ; [Eck-, Start-, End-] Punkte im WKS c2 c3 c> ; Liste aller [zeilenweise zusammengefassten] ; Scheitelpunkte eines Polygonnetzes c- ; Scheitelpunkt-Liste der aktuellen Zeile aus c> cn ; Elementname des aktuellen Scheitelpunktes des Netzes cd ; Elementdatenliste des aktuellen Scheitelpunktes m# n# ; M- und N-Wert des Polygonnetzes ; [Anzahl der Scheitelpunkte pro Spalte bzw. Zeile] j# k# ; Index der aktuellen Zeile bzw. Spalte e0 e1 ; Sichtbarkeit einzelner Kanten einer 3d-Fläche e2 e3 md ; Datenliste eines neu zu erstellenden Objekts me ; Sichtbarkeit der Kanten einer modifizierten 3d-Fläche tol ; Toleranz ) ;| s ; selection set / s# ; number of objects selected i# ; index of object currently worked on in ; entity name of object currently worked on id ; data list of object currently worked on it ; type of object currently worked on ib ; flag bits of a polylinie currently worked on ie ; bit code: visibility of edges of a 3D face c0 c1 ; [corner, start, end] points in WCS c2 c3 c> ; list of all vertices of a polygon mesh ; [every row forms a sublist of c>] c- ; vertex list of the current row of c> cn ; entity name of the current vertex of the mesh cd ; entity data list of the current vertex m# n# ; M and N value of the polygon mesh ; [number of vertices per row / per column] j# k# ; index of current row / current column e0 e1 ; visibility of single edges of a 3D face e2 e3 md ; data list of an object to be created me ; visibility of edges of a modified 3D face tol ; tolerance |; (setq tol 1.0e-012) (if s (progn (setq s# (sslength s) i# 0 ) (while (> s# i#) (setq in (ssname s i#) id (entget in) it (cdr (assoc 0 id)) i# (1+ i#) ) (cond ( (= "LINE" it) (flipProcessLine) ) ( (= "3DFACE" it) (flipProcessFace) ) ( (= "POLYLINE" it) (setq ib (cdr (assoc 70 id))) (cond ( (and (= 16 (logand 16 ib)) ; polygon mesh (= 0 (logand 6 ib)) ; not fit/smooth ) (flipProcessPolygonmesh) ) ( (= 64 (logand 64 ib)) ; polyface mesh (flipProcessPolyfacemesh) ) ( t nil ) ) ) ( t nil ) ) ) ) ) ) ;;; Unterprogramme 2. Ordnung für flipProcess ;;; 2nd order subroutines for flipProcess (defun flipProcessLine ( ) ; The following variables declared in flipProcess ; are used within this subroutine: ; set: id c0 c1 (setq c0 (cdr (assoc 10 id)) c1 (cdr (assoc 11 id)) id (subst (cons 10 c1) (cons 10 c0) id) id (subst (cons 11 c0) (cons 11 c1) id) ) (entmod id) ) (defun flipProcessFace ( ) ; The following variables declared in flipProcess ; are used within this subroutine: ; get: tol ; set: id ie c0 c1 c2 c3 e0 e1 e2 e3 (setq c0 (cdr (assoc 10 id)) c1 (cdr (assoc 11 id)) c2 (cdr (assoc 12 id)) c3 (cdr (assoc 13 id)) ie (cdr (assoc 70 id)) e0 (zerop (logand 1 ie)) e1 (zerop (logand 2 ie)) e2 (zerop (logand 4 ie)) e3 (zerop (logand 8 ie)) me 15 ) (if (equal c2 c3 tol) (progn ; triangle (if e3 (setq me (- me 1))) (if e1 (setq me (- me 2))) (if (or e0 e1) (setq me (- me 4))) (if e0 (setq me (- me 8))) (setq id (subst (cons 11 c2) (cons 11 c1) id) id (subst (cons 12 c1) (cons 12 c2) id) id (subst (cons 13 c1) (cons 13 c3) id) id (subst (cons 70 me) (cons 70 ie) id) ) ) (progn ; quadrangle (if e3 (setq me (- me 1))) (if e2 (setq me (- me 2))) (if e1 (setq me (- me 4))) (if e0 (setq me (- me 8))) (setq id (subst (cons 11 c3) (cons 11 c1) id) id (subst (cons 13 c1) (cons 13 c3) id) id (subst (cons 70 me) (cons 70 ie) id) ) ) ) (entmod id) ) (defun flipProcessPolygonmesh ( ) ; The following variables declared in flipProcess ; are used within this subroutine: ; get: in ib m# n# ; set: id c> c- md (setq c> (transpose (retrievePolygonMesh)) md (getAssignments) ) (cond ( (= 1 (logand 33 ib)) ; flip M closed into N closed (setq id (subst (cons 70 (+ ib 31)) (cons 70 ib) id)) ) ( (= 32 (logand 33 ib)) ; flip N closed into M closed (setq id (subst (cons 70 (- ib 31)) (cons 70 ib) id)) ) ( t nil ) ) (entmake ; "POLYLINE" header (subst (cons 71 n#) (cons 71 m#) (subst (cons 72 m#) (cons 72 n#) id) ) ) (while c> (setq c- (car c>) c> (cdr c>) ) (while c- (entmake (append '((0 . "VERTEX")) md (list '(100 . "AcDbVertex") '(100 . "AcDbPolygonMeshVertex") (cons 10 (car c-)) '(40 . 0.0) ; start width '(41 . 0.0) ; end width '(42 . 0.0) ; bulge '(70 . 64) ; polygon mesh vertex '(50 . 0.0) ; X axis angle when point was drawn '(71 . 0) '(72 . 0) '(73 . 0) '(74 . 0) ; not fit/smooth ) ) ) (setq c- (cdr c-)) ) ) (entmake (append '((0 . "SEQEND")) md ) ) (entdel in) ) (defun flipProcessPolyfacemesh ( ) ; The following variables declared in flipProcess ; are used within this subroutine: ; get: in ; set: cn cd c0 c1 c2 c3 (setq cn (entnext in) cd (entget cn) ) (while (= "VERTEX" (cdr (assoc 0 cd))) (if (= 128 (cdr (assoc 70 cd))) ; modify face records only (progn (setq c0 (cdr (assoc 71 cd)) c1 (cdr (assoc 72 cd)) c2 (cdr (assoc 73 cd)) c3 (cdr (assoc 74 cd)) ) (cond ( (zerop c1) ; point nil ) ( (zerop c2) ; line (setq cd (subst (cons 71 (if (minusp c0) (- (abs c1)) (abs c1)) ) (cons 71 c0) cd ) cd (subst (cons 72 (abs c0)) (cons 72 c1) cd) ) (entmod cd) ) ( (zerop c3) ; triangle (setq cd (subst (cons 71 (if (minusp c2) (- (abs c0)) (abs c0)) ) (cons 71 c0) cd ) cd (subst (cons 72 (if (minusp c1) (- (abs c2)) (abs c2)) ) (cons 72 c1) cd ) cd (subst (cons 73 (if (minusp c0) (- (abs c1)) (abs c1)) ) (cons 73 c2) cd ) ) (entmod cd) ) ( t ; quadrangle (setq cd (subst (cons 71 (if (minusp c3) (- (abs c0)) (abs c0)) ) (cons 71 c0) cd ) cd (subst (cons 72 (if (minusp c2) (- (abs c3)) (abs c3)) ) (cons 72 c1) cd ) cd (subst (cons 73 (if (minusp c1) (- (abs c2)) (abs c2)) ) (cons 73 c2) cd ) cd (subst (cons 74 (if (minusp c0) (- (abs c1)) (abs c1)) ) (cons 74 c3) cd ) ) (entmod cd) ) ) ) ) (setq cn (entnext cn) cd (entget cn) ) ) (entupd in) ) ;_____________________________________________________________________; ;;; Funktion RÜCKSEITE ;;; findet Objekte, deren [mittlere] Flächennormale ;;; einen negativen z-Wert im aktuellen BKS hat ;;; und bietet an, sie zu wenden. (defun c:rückseite ( / s ; Auswahlsatz s# ; Anzahl der Objekte [auf nicht gesperrten Layern] l# ; Anzahl der Objekte auf gesperrten Layern ld ; Datenliste des aktuell überprüften Layers ll ; Liste aller gesperrten Layer der Zeichnung i# ; Index des aktuell bearbeiteten Objekts in ; Elementname des aktuell bearbeiteten Objekts id ; Datenliste des aktuell bearbeiteten Objekts it ; Typ des aktuell bearbeiteten Objekts ib ; Flag-Bits einer aktuell bearbeiteten Polylinie c0 c1 ; Eckpunkte im WKS c2 c3 c> ; Liste aller [zeilenweise zusammengefassten] ; Scheitelpunkte eines Polygonnetzes c- ; Scheitelpunkt-Liste der ersten ; der aktuell bearbeiteten Zeilen aus c> c= ; Scheitelpunkt-Liste der zweiten ; der aktuell bearbeiteten Zeilen aus c> cn ; Elementname des aktuellen Scheitelpunktes des Netzes m# n# ; M- und N-Wert des Polygonnetzes ; [Anzahl der Scheitelpunkte pro Spalte bzw. Zeile] j# k# ; Index der aktuellen Zeile bzw. Spalte nv ; [mittlerer] Normalenvektor des aktuellen Objekts im WKS np ; Schwerpunkt des aktuellen Objekts na ; doppelte Gesamtfläche des aktuellen Objekts b ; Satz aller Objekte, deren [mittlerer] Normalenvektor ; eine negative z-Komponente besitzt b# ; Anzahl der Objekte in b tt ; temporäres Testflag r14 ; Flag: Release 14 r// ; Flag: AutoCAD 14 oder IntelliCAD 2000 ger ; Flag: deutsche Version tol ; Toleranz echo ; Systemvariable "cmdecho" [command echo] errr ; systemeigene Fehlerbearbeitungs-Routine ) (regenInitiate) (normalsSelect) (lockedFilter) (backfaceProcess) (standardTerminate) ) ;;; Function BACKFACE ;;; finds objects whose [average] face normal ;;; has a negative Z value in the current UCS ;;; and offers to flip them. (defun c:backface ( / s ; selection set s# ; number of objects [on unlocked layers] l# ; number of objects on locked layers ld ; data list of layer currently tested ll ; list of all locked layers of the drawing i# ; index of object currently worked on in ; entity name of object currently worked on id ; data list of object currently worked on it ; type of object currently worked on ib ; flag bits of a polylinie currently worked on c0 c1 ; corners in WCS c2 c3 c> ; list of all vertices of a polygon mesh ; [every row forms a sublist of c>] c- ; vertex list of the first of the current rows of c> c= ; vertex list of the second of the current rows of c> cn ; entity name of the current vertex of the mesh m# n# ; M and N value of the polygon mesh ; [number of vertices per row / per column] j# k# ; index of current row / current column nv ; [average] normal vector of current object in WCS np ; center of current face / mesh na ; double area of the face / mesh b ; set of all objects whose [average] normal vector ; has a negative Z component b# ; number of objects in b tt ; temporary test flag r14 ; flag: release 14 r// ; flag: AutoCAD 14 or IntelliCAD 2000 ger ; flag: German version tol ; tolerance echo ; "cmdecho" system variable [command echo] errr ; system's error handling routine ) (regenInitiate) (normalsSelect) (lockedFilter) (backfaceProcess) (standardTerminate) ) ;;; Unterprogramm 1. Ordnung für RÜCKSEITE ;;; 1st order subroutine for BACKFACE (defun backfaceProcess ( ) ; The following variables declared in the main routine ; are used within this subroutine: ; get: s s# ger tol ; set: b b# i# in id it ib na np nv c0 c1 c2 c3 c> c- c= ; r14 r// (setq r14 (wcmatch (ver) "*14*") r// (or r14 (equal (ver) "LISP Release 1.0")) ) (if s (progn (setq b (ssadd) i# 0 ) (while (> s# i#) (setq in (ssname s i#) id (entget in) it (cdr (assoc 0 id)) i# (1+ i#) na 0.0 np '(0.0 0.0 0.0) nv '(0.0 0.0 0.0) ) (cond ( (= "3DFACE" it) (setq c0 (cdr (assoc 10 id)) c1 (cdr (assoc 11 id)) c2 (cdr (assoc 12 id)) c3 (cdr (assoc 13 id)) ) (addNormalVectors) ) ( (= "POLYLINE" it) (setq ib (cdr (assoc 70 id))) (cond ( (and (= 16 (logand 16 ib)) ; polygon mesh (= 0 (logand 39 ib)) ; open, ) ; not fit/smooth (retrievePolygonMesh) (while (setq c- (car c>) c> (cdr c>) c= (car c>) ) (while (setq c0 (car c-) c3 (car c=) c- (cdr c-) ) (setq c= (cdr c=) c1 (car c-) c2 (car c=) ) (addNormalVectors) ) ) ) ( t nil ) ) ) ( t nil ) ) (if (> (- tol) (caddr (trans nv 0 1 t))) (progn (ssadd in b) (redraw in 3)) ; highlight object ) ) (setq b# (sslength b)) (if (= 0 b#) (princ (if ger (strcat "\n" "Kein gewähltes Objekt besitzt " "eine (mittlere) Normale " "mit negativem z-Wert im aktuellen BKS." ) (strcat "\n" "There is no selected object " "whose normal direction (average) " "has a negative Z value in the current UCS." ) ) ) (progn (initget (if ger "Ja Nein _Yes No" "Yes No")) (if (/= "No" (getkword (strcat "\n" (if (= 1 b#) (if (= 1 s#) (if ger "Das gewählte Objekt hat " "The selected object has " ) (if ger "Eines der gewählten Objekte hat " "One of the selected objects has " ) ) (if (= b# s#) (if ger "Die gewählten Objekte haben " "The selected objects have " ) (strcat (itoa b#) (if ger " der gewählten Objeke haben " " of the selected objects have " ) ) ) ) (if ger "eine (mittlere) Normale mit " "a normal direction (average) with " ) (if ger "negativem z-Wert im aktuellen BKS. " "a negative Z value in the current UCS. " ) (if ger (if r14 "Wenden? /Nein: " "Wenden? [Ja/Nein] : " ) (if r14 "Flip? /No: " "Flip? [Yes/No] : " ) ) ) ) ) (flipProcess b) (command "_.regen") ; unhighlight objects ) ) ) ) ) ) ;_____________________________________________________________________; ;;; Funktion NORMALEN ;;; zeichnet die [mittleren] Normalen-Vektoren ;;; von 3d-Flächen und offenen Polygonnetzen. ;;; ;;; Der Block "NORMALS" [Pfeil] wird auf Layer "NORMALS" ;;; in den Schwerpunkten der Flächen bzw. Netze eingefügt. ;;; Die Farbe ist abhängig vom Winkel zur aktuellen BKS-xy-Ebene. ;;; Die Länge eines Pfeils entspricht der ;;; Quadratwurzel des jeweiligen Flächeninhalts. (defun c:normalen ( / s ; Auswahlsatz tt ; temporäres Testflag ger ; Flag: deutsche Version tol ; Toleranz echo ; Systemvariable "cmdecho" [command echo] errr ; systemeigene Fehlerbearbeitungs-Routine ) (standardInitiate) (normalsSelect) (normalsProcess s) (standardTerminate) ) ;;; Function NORMALS ;;; displays the [average] normal vectors ;;; of 3D faces and open polygon meshes. ;;; ;;; Block "NORMALS" [arrow] is inserted on layer "NORMALS". ;;; Insertion points are the centers of the faces / meshes. ;;; The color depends on the angle from the current UCS XY plane. ;;; The length of an arrow is determined by the ;;; square root of the area of the face / mesh. (defun c:normals ( / s ; selection set tt ; temporary test flag ger ; flag: German version tol ; tolerance echo ; "cmdecho" system variable [command echo] errr ; system's error handling routine ) (standardInitiate) (normalsSelect) (normalsProcess s) (standardTerminate) ) ;;; Unterprogramme 1. Ordnung für NORMALEN ;;; 1st order subroutines for NORMALS (defun normalsSelect ; also called by BACKFACE ( ) ; The following variables declared in the main routines ; are used within this subroutine: ; get: ger ; set: s s# tt (setq tt t) (while tt (princ (if ger " - 3d-Flächen, offene Polygonnetze -" " - 3D faces, open polygon meshes -" ) ) (setq s (ssget '( (-4 . "") ; not fit/smooth (-4 . "") ; IntelliCAD does not work correctly (-4 . "or>") ; with (-4 . "&") (70 . 16) ) ) ) (if s (setq s# (sslength s) tt nil ; selection succeeded ) (princ (if ger "\nEs wurde keine gültige Auswahl getroffen." "\nNo valid selection made." ) ) ) ) ) (defun normalsProcess ( s ; Auswahlsatz / s# ; Anzahl der gewählten Objekte i# ; Index des aktuell bearbeiteten Objekts in ; Elementname des aktuell bearbeiteten Objekts id ; Datenliste des aktuell bearbeiteten Objekts it ; Typ des aktuell bearbeiteten Objekts ib ; Flag-Bits einer aktuell bearbeiteten Polylinie c0 c1 ; Eckpunkte im WKS c2 c3 c> ; Liste aller [zeilenweise zusammengefassten] ; Scheitelpunkte eines Polygonnetzes c- ; Scheitelpunkt-Liste der ersten ; der aktuell bearbeiteten Zeilen aus c> c= ; Scheitelpunkt-Liste der zweiten ; der aktuell bearbeiteten Zeilen aus c> cn ; Elementname des aktuellen Scheitelpunktes des Netzes m# n# ; M- und N-Wert des Polygonnetzes ; [Anzahl der Scheitelpunkte pro Spalte bzw. Zeile] j# k# ; Index der aktuellen Zeile bzw. Spalte na ; doppelte Gesamtfläche des aktuellen Objekts np ; Schwerpunkt des aktuellen Objekts nv ; [mittlerer] Normalenvektor des aktuellen Objekts im WKS nz ; z-Komponente von nv im aktuellen BKS nl ; Skalierfaktor des einzufügenden Blocks nc ; Farbe des einzufügenden Blocks r14 ; Flag: Release 14 r// ; Flag: AutoCAD 14 oder IntelliCAD 2000 tol ; Toleranz ) ;| s ; selection set / s# ; number of objects i# ; index of object currently worked on in ; entity name of object currently worked on id ; data list of object currently worked on it ; type of object currently worked on ib ; flag bits of a polylinie currently worked on c0 c1 ; corners in WCS c2 c3 c> ; list of all vertices of a polygon mesh ; [every row forms a sublist of c>] c- ; vertex list of the first of the current rows of c> c= ; vertex list of the second of the current rows of c> cn ; entity name of the current vertex of the mesh m# n# ; M and N value of the polygon mesh ; [number of vertices per row / per column] j# k# ; index of current row / current column na ; double area of the face / mesh np ; center of current face / mesh nv ; [average] normal vector of current object in WCS nz ; Z component of nv in current UCS nl ; scale factor of block to be inserted nc ; color of block to be inserted r14 ; flag: release 14 r// ; flag: AutoCAD 14 or IntelliCAD 2000 tol ; tolerance |; ;; Vorbereitung ;; Preparation (setq r14 (wcmatch (ver) "*14*") r// (or r14 (equal (ver) "LISP Release 1.0")) tol 1.0e-012 ) ; Layer "NORMALS" erstellen ; [dies ist in IntelliCAD erforderlich; hingegen kann ; (entmod ...) in AutoCAD den Layer auch selbständig erzeugen] ; create layer "NORMALS" ; [required in IntelliCAD; ; (entmod ...) may create it automatically in AutoCAD] (if (not (tblsearch "LAYER" "NORMALS")) (command "_.-layer" "_new" "NORMALS" "") ) (command "_.-layer" "_thaw" "NORMALS" "_unlock" "NORMALS" "_on" "NORMALS" "" ) ; multiple (entmod) applied on layers might cause crashes ; Block "NORMALS" definieren ; Define "NORMALS" block (if (not (tblsearch "BLOCK" "NORMALS")) (progn (entmake '( (0 . "BLOCK") (100 . "AcDbEntity") (8 . "0") ; layer (100 . "AcDbBlockBegin") (70 . 0) ; no attributes (10 0.0 0.0 0.0) ; base point (2 . "NORMALS") ; block name ) ) (entmake '( (0 . "LWPOLYLINE") (100 . "AcDbEntity") (8 . "0") ; layer (62 . 0) ; color "ByBlock" (100 . "AcDbPolyline") (90 . 3) ; number of vertices (70 . 0) ; open (43 . 0.0) ; constant width (38 . 0.0) ; elevation (39 . 0.0) ; thickness (10 0.0 0.0) (42 . 0.0) ; no bulge (10 0.0 1.0) (42 . 0.0) ; no bulge (10 0.1 0.8) (42 . 0.0) ; no bulge (210 0.0 -1.0 0.0) ; extrusion direction ) ) (entmake '( (0 . "ENDBLK") (100 . "AcDbEntity") (8 . "0") ; layer (100 . "AcDbBlockEnd") ) ) ) ) ;; Verarbeitung und Ausgabe ;; Processing and Output (setq s# (sslength s) i# 0 ) (while (> s# i#) ; Schwerpunkte, Flächeninhalte und Normalenrichtung ermitteln ; Calculate face centers, areas, and normals (setq in (ssname s i#) id (entget in) it (cdr (assoc 0 id)) i# (1+ i#) na 0.0 np '(0.0 0.0 0.0) nv '(0.0 0.0 0.0) ) (cond ( (= "3DFACE" it) (setq c0 (cdr (assoc 10 id)) c1 (cdr (assoc 11 id)) c2 (cdr (assoc 12 id)) c3 (cdr (assoc 13 id)) ) (addNormalVectors) ) ( (= "POLYLINE" it) (setq ib (cdr (assoc 70 id))) (cond ( (and (= 16 (logand 16 ib)) ; polygon mesh (= 0 (logand 39 ib)) ; open, not fit/smooth ) (retrievePolygonMesh) (while (setq c- (car c>) c> (cdr c>) c= (car c>) ) (while (setq c0 (car c-) c3 (car c=) c- (cdr c-) ) (setq c= (cdr c=) c1 (car c-) c2 (car c=) ) (addNormalVectors) ) ) ) ( t nil ) ) ) ( t nil ) ) ; Block einfügen ; Insert block (setq nv (normalize nv)) (if nv ; non-zero length (progn (setq nl (sqrt (* 0.5 na)) nz (caddr (trans nv 0 1 t)) nc (cond ((< 0.75 nz) 90) ; frontfacing: green ((< 0.5 nz) 80) ((< 0.25 nz) 70) ((< tol nz) 60) ((< (- tol) nz) 50) ; equator: yellow ((< -0.25 nz) 40) ((< -0.5 nz) 30) ((< -0.75 nz) 20) (t 10) ; backfacing: red ) np (trans (mapcar '(lambda (c) (/ c na 3.0)) np) 0 nv) ) (entmake (list '(0 . "INSERT") '(100 . "AcDbEntity") '(8 . "NORMALS") ; layer (cons 62 nc) ; color '(100 . "AcDbBlockReference") '(66 . 0) ; no attributes '(2 . "NORMALS") ; block name (cons 10 np) ; center of face / mesh in OCS (cons 41 nl) ; X scale factor (cons 42 nl) ; Y scale factor (cons 43 nl) ; Z scale factor '(50 . 0.0) ; rotation angle (cons 210 nv) ; extrusion direction ) ) ) ) ) ) ;;; Unterprogramm 2. Ordnung für backfaceProcess und normalsProcess ;;; 2nd order subroutine for backfaceProcess and normalsProcess (defun addNormalVectors ( ; The following variables declared in the parent routines ; are used within this subroutine ; [kept as global variables for the sake of performance]: ; get: c0 c1 c2 c3 r// ; set: nv np na / v< v> ; normal vectors of component triangles p< p> ; center points of component triangles a< a> ; double area of component triangles ) (if r// ; AutoCAD R14 and IntelliCAD 2000: ; quadrangular 3D faces are composed of two triangles ; touching one another along the diagonal ; from the first to the third corner (setq v< (vectorProduct (mapcar '- c1 c0) (mapcar '- c2 c0)) v> (vectorProduct (mapcar '- c3 c2) (mapcar '- c0 c2)) p< (mapcar '+ c0 c1 c2) p> (mapcar '+ c2 c3 c0) ) ; AutoCAD 2000: ; quadrangular 3D faces are composed of two triangles ; touching one another along the diagonal ; from the second to the fourth corner (setq v< (vectorProduct (mapcar '- c1 c0) (mapcar '- c3 c0)) v> (vectorProduct (mapcar '- c3 c2) (mapcar '- c1 c2)) p< (mapcar '+ c3 c0 c1) p> (mapcar '+ c1 c2 c3) ) ) (setq nv (mapcar '+ nv v< v>) a< (distance '(0.0 0.0 0.0) v<) a> (distance '(0.0 0.0 0.0) v>) na (+ na a< a>) p< (mapcar '(lambda (c) (* c a<)) p<) p> (mapcar '(lambda (c) (* c a>)) p>) np (mapcar '+ np p< p>) ; weighted sum ) ) ;_____________________________________________________________________; ;;; Unterprogramme 3. Ordnung für die liftProcess...-, ;;; flipProcess...-, backfaceProcess...-, normalsProcess...-Routinen ;;; 3rd order subroutines for the liftProcess... , ;;; flipProcess... , backfaceProcess... , normalsProcess... routines ;; Koordinaten der Scheitelpunkte eines Polygonnetzes auslesen ;; und abspeichern als Matrix [Liste von Zeilen-Sublisten] ;; Retrieve vertex coordinates of a polygon mesh ;; and store as a matrix [list of row sublists] (defun retrievePolygonMesh ( ) ; The following variables declared in the parent routines ; are used within this subroutine: ; get: id in ; set: m# n# j# k# c> c- cn (setq m# (cdr (assoc 71 id)) n# (cdr (assoc 72 id)) j# 0 cn in c> nil ) (while (> m# j#) (setq k# 0 c- nil ) (while (> n# k#) (setq cn (entnext cn) c- (cons (cdr (assoc 10 (entget cn))) c-) k# (1+ k#) ) ) (setq c> (cons (reverse c-) c>) j# (1+ j#) ) ) (setq c> (reverse c>)) ) ;; Allgemeine Zuweisungen eines Elements auslesen ;; [Layer, Farbe, Linientyp, Linientyp-Skalierfaktor, Linienstärke] ;; Retrieve general assignments of an entity ;; [layer, color, line type, line type scale factor, line weight] (defun getAssignments ( ; The variable 'id' must be set to the (entget) list ; before starting this subroutine. 'id' is kept as a ; global variable for the sake of performance. / ig ; data group from id ad ; data list to be returned ) (if (setq ig (assoc 370 id)) ; line weight (setq ad (cons ig ad)) ) (if (setq ig (assoc 48 id)) ; line type scale factor (setq ad (cons ig ad)) ) (if (setq ig (assoc 6 id)) ; line type (setq ad (cons ig ad)) ) (if (setq ig (assoc 62 id)) ; color (setq ad (cons ig ad)) ) (setq ad (cons (assoc 8 id) ad) ; layer ad (cons '(100 . "AcDbEntity") ad) ) ) ;_____________________________________________________________________; ;;; Funktion ENTFALTEN für Polyflächennetze ;;; ;;; Wenn Sie ein Polyflächennetz auswählen, so wird von seinen ;;; Teilflächen je eine Kopie auf dem Layer "UNFOLDED-F" erstellt. ;;; Dabei werden nur diejenigen Komponenten berücksichtigt, ;;; deren Flächeninhalt größer als Null ist. ;;; Die Kopien werden in der WKS-xy-Ebene entlang der WKS-x-Achse ;;; beginnend am Koordinatenursprung aufgereiht. ;;; Die Eckpunkte der Flächen werden nummeriert, und zwar auf dem ;;; Layer "UNFOLDED-N" [Kopien] bzw. "UNFOLDED-O" [Originale]. ;;; Zusammenfassend wird die Anzahl der kopierten Dreiecke und ;;; Vierecke sowie der gesamte Flächeninhalt des Netzes angezeigt. ;;; ;;; Umwandeln von Volumenkörpern und Regionen in Polyflächennetze: ;;; Export als 3dStudio-Datei und Re-Import dieser Datei ;;; [AutoCAD-Befehle "3dsout", "3dsin"]. ;;; Umwandeln von einzelnen 3d-Flächen und von Polygonnetzen ;;; [welche z. B. mittels "Regelob" oder "Rotob" erstellt wurden] ;;; in Polyflächennetze: mittels der Funktion NÄHEN [siehe oben]. (defun c:entfalten ( / en ; Elementname des Headers des Polyflächennetzes ed ; Elementdatenliste des Headers des Polyflächennetzes v^ ; Liste aller Scheitelpunkte des Polyflächennetzes v# ; Anzahl der Scheitelpunkte des Polyflächennetzes f# ; Anzahl der Teilobjekte des Polyflächennetzes i# ; Index des aktuell bearbeiteten Subelements in ; Name des aktuell bearbeiteten Subelements id ; Datenliste des aktuell bearbeiteten Subelements ic ; Koordinatenliste ; des aktuell bearbeiteten Scheitelpunkts i1 i2 ; Scheitelpunkt-Indizes i3 i4 ; der aktuell bearbeiteten Fläche c1 c2 ; Eckpunkte c3 c4 ; der aktuell bearbeiteten Fläche nv ; Normalenvektor der aktuell bearbeiteten Fläche v2 v3 v4 ; ursprüngliche Kantenvektoren u2 u3 u4 ; Kantenvektoren ; nach Transformation in die WKS-xy-Ebene w1 w2 ; Eckpunkte w3 w4 ; nach Transformation in die WKS-xy-Ebene t# ; Anzahl der nicht leeren Dreiecksflächen q# ; Anzahl der nicht leeren Vierecksflächen af ; Flächeninhalt der aktuell bearbeiteten Fläche ; *mesharea* ; Flächeninhalt des gesamten Netzes ; bleibt als globale Variable ; für weitere Verarbeitung ; nach Beendigung der Funktion erhalten x< x> ; maximale bzw. minimale Koordinaten y< y> ; aller Scheitelpunkte des Netzes z< z> w< w> ; maximale bzw. minimale x-Koordinate ; der transformierten Kantenvektoren einer Fläche nh ; Texthöhe der Nummerierung nd ; Datenliste der aktuell bearbeiteten Nummer nc ; linke untere Ecke der aktuell bearbeiteten Nummer tt ; temporäres Testflag ger ; Flag: deutsche Version r// ; Flag: AutoCAD 14 oder IntelliCAD 2000 tol ; Toleranz echo ; Systemvariable "cmdecho" [command echo] errr ; voreingestellte Fehlerbearbeitungs-Routine ) (standardInitiate) (unfoldSelect) (unfoldProcess) (standardTerminate) ) ;;; Function UNFOLD for polyface meshes ;;; ;;; When a polyface mesh is selected, the program will make a copy ;;; of all non-zero area components on layer "UNFOLDED-F". ;;; The copies get placed on the WCS XY plane and lined up along the ;;; WCS X axis starting from the origin point. ;;; The corners of the faces are numbered ;;; on layer "UNFOLDED-N" [copies] and "UNFOLDED-O" [originals]. ;;; A command line message reports the number of copied triangles / ;;; quadrangles and the total mesh area. ;;; ;;; To convert 3D solids and regions into polyface meshes - ;;; export as 3D studio file and re-import this file ;;; [AutoCAD "3dsout", "3dsin" commands]. ;;; To convert single 3D faces and polygon meshes ;;; [e. g. as created with the "rulesurf" or "revsurf" commands] ;;; into polyface meshes - use the SEW function [see above]. (defun c:unfold ( / en ; entity name of header of polyface mesh ed ; entity data list of header of polyface mesh v^ ; list of all vertices of polyface mesh v# ; number of vertices of polyface mesh f# ; number of components of polyface mesh i# ; index of current subentity in ; name of current subentity id ; data list of current subentity ic ; coordinate list of current vertex i1 i2 ; vertex indices of current face i3 i4 c1 c2 ; corners of current face c3 c4 nv ; normal vector of current face v2 v3 v4 ; original edge vectors u2 u3 u4 ; edge vectors ; after transformation to WCS XY plane w1 w2 ; corners w2 w3 ; after transformation to WCS XY plane t# ; number of triangles with non-zero area q# ; number of quadrangles with non-zero area af ; area of current face ; *mesharea* ; total mesh area ; remains as a global variable ; for further processing ; after "UNFOLD" function has completed its job x< x> ; maximum and minimum coordinates of all mesh vertices y< y> z< z> w< w> ; maximum and minimum X coordinates ; of the transformed edge vectors of a face nh ; text height of numbering nd ; data list of current number nc ; lower left corner of current number tt ; temporary test flag ger ; flag: German version r// ; flag: AutoCAD 14 or IntelliCAD 2000 tol ; tolerance echo ; "cmdecho" system variable [command echo] errr ; preset error handling routine ) (standardInitiate) (unfoldSelect) (unfoldProcess) (standardTerminate) ) ;;; Unterprogramme 1. Ordnung für ENTFALTEN ;;; 1st order subroutines for UNFOLD (defun unfoldSelect ( ) ; The following variables declared in the main routine ; are used within this subroutine: ; get: ger ; set: tt en ed (setq tt t) (while tt (setq en (car (entsel (if ger " Ein Polyflächennetz wählen: " " Select a polyface mesh: " ) ) ) ) (if en (progn (setq ed (entget en)) (if (= "POLYLINE" (cdr (assoc 0 ed))) (cond ( (= 64 (logand 64 (cdr (assoc 70 ed)))) (setq tt nil) ; selection succeeded ) ( (= 16 (logand 16 (cdr (assoc 70 ed)))) (princ (if ger (strcat "\n" "Dies ist ein Polygonnetz. " "Mit der Funktion NÄHEN können Sie es " "in ein Polyflächennetz umwandeln. - " ) (strcat "\n" "This is a polygon mesh. " "The SEW function may convert it " "into a polyface mesh. - " ) ) ) ) ( t (princ (if ger "\nUngültige Auswahl. " "\nInvalid selection. " ) ) ) ) (princ (if ger "\nUngültige Auswahl. " "\nInvalid selection. " ) ) ) ) (princ (if ger "\nEs wurde nichts ausgewählt. " "\nNothing selected. " ) ) ) ) ) (defun unfoldProcess ( ) ; The following variables declared in the main routine ; are used within this subroutine: ; get: ed en ger tol ; set: v# f# i# in id ic v^ x< x> y< y> z< z> nh nd nc ; w1 t# q# af i1 i2 i3 i4 c1 c2 c3 c4 r// ; *mesharea* ;; Layer "UNFOLDED-F", "UNFOLDED-N" und "UNFOLDED-O" erstellen ;; [dies ist in IntelliCAD erforderlich; hingegen kann ;; (entmod ...) in AutoCAD die Layer auch selbständig erzeugen] ;; create layers "UNFOLDED-F", "UNFOLDED-N", and "UNFOLDED-O" ;; [required in IntelliCAD; ;; (entmod ...) may create them automatically in AutoCAD] (if (not (tblsearch "LAYER" "UNFOLDED-F")) (command "_.-layer" "_new" "UNFOLDED-F" "_thaw" "UNFOLDED-F" "_unlock" "UNFOLDED-F" "_on" "UNFOLDED-F" "_color" "7" "UNFOLDED-F" ; white/black "" ) ) (if (not (tblsearch "LAYER" "UNFOLDED-N")) (command "_.-layer" "_new" "UNFOLDED-N" "_thaw" "UNFOLDED-N" "_unlock" "UNFOLDED-N" "_on" "UNFOLDED-N" "_color" "1" "UNFOLDED-N" ; red "" ) ) (if (not (tblsearch "LAYER" "UNFOLDED-O")) (command "_.-layer" "_new" "UNFOLDED-O" "_thaw" "UNFOLDED-O" "_unlock" "UNFOLDED-O" "_on" "UNFOLDED-O" "_color" "5" "UNFOLDED-O" ; blue "" ) ) ;; Liste der Scheitelpunkte des Netzes erstellen ;; retrieve mesh data - make vertex list (setq v# (cdr (assoc 71 ed)) f# (cdr (assoc 72 ed)) i# 0 in en ) (while (> v# i#) (setq in (entnext in) ic (cdr (assoc 10 (entget in))) v^ (cons ic v^) x< (if x< (max x< (car ic)) (car ic)) x> (if x> (min x> (car ic)) (car ic)) y< (if y< (max x< (cadr ic)) (cadr ic)) y> (if y> (min y> (cadr ic)) (cadr ic)) z< (if z< (max z< (caddr ic)) (caddr ic)) z> (if z> (max z> (caddr ic)) (caddr ic)) i# (1+ i#) ) ) ;; Nummerieren der Scheitelpunkte des ursprünglichen Netzes ;; numbering of the vertices of the original mesh (princ (if ger "\nScheitelpunkte nummerieren ...\015" "\nnumbering vertices ...\015" ) ) (setq nh (/ (distance (list x> y> z>) (list x< y< z<)) 2.0 (max 1 f#)) i# 0 ) (while (> v# i#) (setq i# (1+ i#) ic (nth (- v# i#) v^) ) (entmake (list '(0 . "TEXT") '(8 . "UNFOLDED-O") '(10 0.0 0.0 0.0) (cons 40 nh) (cons 1 (strcat (itoa i#) ".")) '(72 . 1) ; horizontal alignment: centered '(73 . 2) ; vertical alignment: middle ) ) (setq nd (entget (entlast)) nc (assoc 10 nd) nd (subst (cons 10 (mapcar '+ ic (cdr nc))) nc nd) nd (subst (cons 11 ic) (assoc 11 nd) nd) ) (entmod nd) ; "entmaking" in place immediately ) ; does not seem to work correctly (princ " \015") ;; Teilflächen erkunden ;; explore component faces (setq r// (or (wcmatch (ver) "*14*") (equal (ver) "LISP Release 1.0")) w1 '(0.0 0.0 0.0) i# 0 t# 0 q# 0 *mesharea* 0.0 ) (while (> f# i#) (setq in (entnext in) id (entget in) i1 (abs (cdr (assoc 71 id))) i2 (abs (cdr (assoc 72 id))) i3 (abs (cdr (assoc 73 id))) i4 (abs (cdr (assoc 74 id))) ) (if (/= 0 i3) (if (= 0 i4) (progn (setq c1 (nth (- v# i1) v^) c2 (nth (- v# i2) v^) c3 (nth (- v# i3) v^) af (areaTriangle c1 c2 c3) ) (if (< tol af) (progn (setq *mesharea* (+ *mesharea* af)) (unfoldProcess3 i1 i2 i3) ) ) ) (progn (setq c1 (nth (- v# i1) v^) c2 (nth (- v# i2) v^) c3 (nth (- v# i3) v^) c4 (nth (- v# i4) v^) ) (if r// ; AutoCAD R14 and IntelliCAD 2000: ; quadrangular 3D face composed of two triangles ; touching one another along the diagonal ; from first to third corner (progn (setq af (areaTriangle c1 c2 c3)) (if (< tol af) (progn (setq *mesharea* (+ *mesharea* af) af (areaTriangle c1 c3 c4) ) (if (< tol af) (progn (setq *mesharea* (+ *mesharea* af)) (if (coplanar c1 c2 c3 c4) (unfoldProcess4 i1 i2 i3 i4) (progn (unfoldProcess3 i1 i2 i3) (unfoldProcess3 i1 i3 i4) ) ) ) (unfoldProcess3 i1 i2 i3) ) ) (progn (setq af (areaTriangle c1 c3 c4)) (if (< tol af) (progn (setq *mesharea* (+ *mesharea* af)) (unfoldProcess3 i1 i3 i4) ) ) ) ) ) ; AutoCAD 2000: ; quadrangular 3D face composed of two triangles ; touching one another along the diagonal ; from second to fourth corner (progn (setq af (areaTriangle c1 c2 c4)) (if (< tol af) (progn (setq *mesharea* (+ *mesharea* af) af (areaTriangle c2 c3 c4) ) (if (< tol af) (progn (setq *mesharea* (+ *mesharea* af)) (if (coplanar c1 c2 c3 c4) (unfoldProcess4 i1 i2 i3 i4) (progn (unfoldProcess3 i1 i2 i4) (unfoldProcess3 i2 i3 i4) ) ) ) (unfoldProcess3 i1 i2 i4) ) ) (progn (setq af (areaTriangle c2 c3 c4)) (if (< tol af) (progn (setq *mesharea* (+ *mesharea* af)) (unfoldProcess3 i2 i3 i4) ) ) ) ) ) ) ) ) ) (setq i# (1+ i#)) (if (= 7 (logand 7 i#)) (princ (if ger (strcat (itoa i#) " von " (itoa f#) " Komponenten untersucht\015" ) (strcat (itoa i#) " of " (itoa f#) " components examined\015" ) ) ) ) ) ;; Zusammenfassung ;; résumé (princ (if ger (strcat " \015" "Dreiecke: " (itoa t#) " Vierecke: " (itoa q#) "\nGesamtfläche: " (rtos *mesharea*) ) (strcat " \015" "triangles: " (itoa t#) " quadrangles: " (itoa q#) "\ntotal mesh area: " (rtos *mesharea*) ) ) ) ) ;;; Unterprogramme 2. Ordnung für unfoldProcess ;;; 2nd order subroutines for unfoldProcess ;; Dreieck kopieren ;; copy triangle (defun unfoldProcess3 ( j1 j2 j3 ; vertex indices of the corners of the triangle / p1 p2 p3 ; corners of the triangle ) ; The following variables declared in the main routine ; are used within this subroutine: ; get: v^ nh ; set: t# v2 v3 nv u2 u3 w< w> w1 w2 w3 (setq t# (1+ t#) p1 (nth (- v# j1) v^) p2 (nth (- v# j2) v^) p3 (nth (- v# j3) v^) v2 (mapcar '- p2 p1) v3 (mapcar '- p3 p1) nv (normalize (vectorProduct v2 v3)) u2 (trans v2 0 nv t) u3 (trans v3 0 nv t) w< (max 0.0 (car u2) (car u3)) w> (min 0.0 (car u2) (car u3)) w1 (mapcar '- w1 (list w> 0.0 0.0)) w2 (mapcar '+ w1 u2) w3 (mapcar '+ w1 u3) ) (entmake (list '(0 . "3DFACE") '(8 . "UNFOLDED-F") (cons 10 w1) (cons 11 w2) (cons 12 w3) (cons 13 w3) '(70 . 0) ) ) (unfoldProcess34Number j1 w1) (unfoldProcess34Number j2 w2) (unfoldProcess34Number j3 w3) (setq w1 (mapcar '+ w1 (list (+ w< (* 5.0 nh)) 0.0 0.0))) ) ;; Viereck kopieren ;; copy quadrangle (defun unfoldProcess4 ( j1 j2 j3 j4 ; vertex indices of the corners of the quadrangle / p1 p2 p3 p4 ; corners of the quadrangle ) ; The following variables declared in the main routine ; are used within this subroutine: ; get: v^ nh ; set: q# v2 v3 v4 nv u2 u3 u4 w< w> w1 w2 w3 w4 (setq q# (1+ q#) p1 (nth (- v# j1) v^) p2 (nth (- v# j2) v^) p3 (nth (- v# j3) v^) p4 (nth (- v# j4) v^) v2 (mapcar '- p2 p1) v3 (mapcar '- p3 p1) v4 (mapcar '- p4 p1) nv (normalize (vectorProduct v2 v3)) u2 (trans v2 0 nv t) u3 (trans v3 0 nv t) u4 (trans v4 0 nv t) w< (max 0.0 (car u2) (car u3) (car u4)) w> (min 0.0 (car u2) (car u3) (car u4)) w1 (mapcar '- w1 (list w> 0.0 0.0)) w2 (mapcar '+ w1 u2) w3 (mapcar '+ w1 u3) w4 (mapcar '+ w1 u4) ) (entmake (list '(0 . "3DFACE") '(8 . "UNFOLDED-F") (cons 10 w1) (cons 11 w2) (cons 12 w3) (cons 13 w4) '(70 . 0) ) ) (unfoldProcess34Number j1 w1) (unfoldProcess34Number j2 w2) (unfoldProcess34Number j3 w3) (unfoldProcess34Number j4 w4) (setq w1 (mapcar '+ w1 (list (+ w< (* 5.0 nh)) 0.0 0.0))) ) ;;; Unterprogramm 3. Ordnung für unfoldProcess3 und unfoldProcess4 ;;; 3rd order subroutine for unfoldProcess3 and unfoldProcess4 (defun unfoldProcess34Number (ni np) ; the number and its position ; The following variables declared in the main routine ; are used within this subroutine: ; get: nh ; set: nd nc (entmake (list '(0 . "TEXT") '(8 . "UNFOLDED-N") '(10 0.0 0.0 0.0) (cons 40 nh) (cons 1 (strcat (itoa ni) ".")) '(72 . 1) ; horizontal alignment: centered '(73 . 2) ; vertical alignment: middle ) ) (setq nd (entget (entlast)) nc (assoc 10 nd) nd (subst (cons 10 (mapcar '+ np (cdr nc))) nc nd) nd (subst (cons 11 np) (assoc 11 nd) nd) ) (entmod nd) ; "entmaking" in place immediately ) ; does not seem to work correctly ;_____________________________________________________________________; ;;; Funktion SCHNEIDERHILFE ;;; zeigt Informationen über die SCHNEIDEREI-Funktionen ;;; mit Hilfe eines Browsers an. (defun c:schneiderhilfe ( / hp ; Name und vollständiger Pfad der HTML-Hilfe-Datei ger ; Flag: deutsche Version echo ; Systemvariable "cmdecho" [command echo] errr ; systemeigene Fehlerbearbeitungs-Routine ) (helpInitiate) (tailorshelpProcess) (standardTerminate) ) ;;; Function TAILORSHELP ;;; displays information about the TAILORS functions ;;; by means of a browser. (defun c:tailorshelp ( / hp ; name and path of HTML help file ger ; flag: German version echo ; "cmdecho" system variable errr ; system's error handling routine ) (helpInitiate) (tailorshelpProcess) (standardTerminate) ) ;;; Unterprogramm 1. Ordnung für SCHNEIDERHILFE ;;; 1st order subroutine for TAILORSHELP (defun tailorshelpProcess ( ) (if (setq hp (findfile (if ger "Tailors/Deutsch/LiesMich.html" "Tailors/English/ReadMe.html" ) ) ) (command (if (equal (ver) "LISP Release 1.0") "_.url" ; IntelliCAD "_.browser" ; AutoCAD ) hp ) (alert (if ger (strcat "Die Datei Tailors/Deutsch/LiesMich.html\n" "wurde nicht gefunden." ) (strcat "Help file Tailors/English/ReadMe.html\n" "was not found." ) ) ) ) ) ;_____________________________________________________________________; ;;; Unterprogramm zum Ausfiltern von Objekten auf gesperrten Layern ;;; ;;; Die Objektwahl und die Wahl möglichst aller benötigten Optionen ;;; müssen dem Aufruf dieses Unterprogramms vorausgehen; außerdem ;;; muss s# bereits auf die Anzahl der Objekte im vorherigen ;;; Auswahlsatz gesetzt worden sein. ;;; "lockedFilter" sollte erst dann ausgeführt werden, wenn der ;;; Befehl "'layer" nicht mehr transparent aufgerufen werden kann. ;;; Subroutine for filtering out objects on locked layers ;;; ;;; Object selection must precede this subroutine. ;;; s# has to be set on the number of objects in previous ;;; selection set before running this subroutine. ;;; "lockedFilter" should not be called until ;;; the "'layer" command cannot be started transparently any more. (defun lockedFilter ( ) ; The following variables declared in the main routines ; are used within this subroutine: ; get: ger ; set: s s# l# ld ll (setq ld (tblnext "layer" t)) (if (= 4 (logand 4 (cdr (assoc 70 ld)))) (setq ll (list (cons 8 (cdr (assoc 2 ld))))) ) (while (setq ld (tblnext "layer")) (if (= 4 (logand 4 (cdr (assoc 70 ld)))) (setq ll (cons (cons 8 (cdr (assoc 2 ld))) ll)) ) ) (if ll (setq ll (append '((-4 . "") (-4 . "not>")) ) ) ) (setq s (ssget "_p" ll)) (if s (progn (setq l# s# s# (sslength s) l# (- l# s#) ) (cond ( (= 1 l#) (princ (if ger (strcat "\n" "Eines der gewählten Objekte " "liegt auf einem gesperrten Layer." ) (strcat "\n" "One of the selected objects " "lies on a locked layer." ) ) ) ) ( (< 1 l#) (princ (if ger (strcat "\n" (itoa l#) " der gewählten Objekte" " liegen auf gesperrten Layern." ) (strcat "\n" (itoa l#) " of the selected objects" " lie on locked layers." ) ) ) ) ) ) (progn (if (= 1 s#) (princ (if ger (strcat "\n" "Das gewählte Objekt " "liegt auf einem gesperrten Layer." ) (strcat "\n" "The selected object lies on a locked layer." ) ) ) (princ (if ger (strcat "\n" "Alle gewählten Objekte " "liegen auf gesperrten Layern." ) (strcat "\n" "All selected objects lie on locked layers." ) ) ) ) ) ) ) ;_____________________________________________________________________; ;;; Unterprogramm zum Erstellen einer Gruppe mit eindeutigem Namen ;;; Subroutine for creating a group with a unique name (defun uniqueGroup ( e^ ; Liste der Elementamen der zu gruppierenden Objekte n< ; Name [Präfix] der zu erstellenden Gruppe / dt ; Datum und Uhrzeit beim Erstellen der Gruppe n> ; Zusatz zu n< zur Wahrung der Eindeutigkeit ) ;| e^ ; list of entity names of objects to group n< ; name [prefix] of the group to be created / dt ; date and time of group creation n> ; appendix to keep the name unique |; (if (not (equal (ver) "LISP Release 1.0")) (progn ; "group" command not supported by IntelliCAD (setq dt (* 1.0e-008 (getvar "cdate")) n< (strcat n< "_" (substr (rtos dt 2 6) 3 4)) ; year dt (* 1.0e004 dt) dt (- dt (fix dt)) n< (strcat n< "-" (substr (rtos dt 2 6) 3 2)) ; month dt (* 1.0e002 dt) dt (- dt (fix dt)) n< (strcat n< "-" (substr (rtos dt 2 6) 3 2)) ; day dt (* 1.0e002 dt) dt (- dt (fix dt)) n< (strcat n< "_" (substr (rtos dt 2 6) 3 2)) ; hour dt (* 1.0e002 dt) dt (- dt (fix dt)) n< (strcat n< "-" (substr (rtos dt 2 6) 3 2)) ; minute dt (* 1.0e002 dt) dt (- dt (fix dt)) n< (strcat n< "-" (substr (rtos dt 2 6) 3 2)) ; second n> "" ) (while (dictsearch (cdr (assoc -1 (dictsearch (namedobjdict) "ACAD_GROUP")) ) (strcat n< n>) ) (if (= "" n>) (setq n< (strcat n< "_"))) (setq n> (str1+ n>)) ) (command "_.-group" "_create" (strcat n< n>) "" ; no description ) (foreach item e^ (command item)) (command "") ) ) ) ;_____________________________________________________________________; ;;; Initialisieren, Terminieren und Fehlerbehandlung ;;; Initiation, termination, and error handling ;; Initialisierende Unterprogramme ;; Initiating subroutines (defun standardInitiate ( ) ; The following variables declared in the main routines ; are used within this subroutine: ; set: ger tol echo errr (setq echo (getvar "cmdecho")) (setvar "cmdecho" 0) (command "_.undo" "_begin") (setq errr *error* *error* standardError ger (wcmatch (ver) "*(de)") tol 1.0e-012 ) ) (defun regenInitiate ( ) ; The following variables declared in the main routine ; are used within this subroutine: ; set: ger tol echo errr (setq echo (getvar "cmdecho")) (setvar "cmdecho" 0) (command "_.undo" "_begin") (setq errr *error* *error* regenError ger (wcmatch (ver) "*(de)") tol 1.0e-012 ) ) (defun helpInitiate ( ) ; The following variables declared in the main routine ; are used within this subroutine: ; set: ger echo errr (setq echo (getvar "cmdecho")) (setvar "cmdecho" 0) (command "_.undo" "_begin") (setq errr *error* *error* standardError ger (wcmatch (ver) "*(de)") ) ) ;; Terminierendes Unterprogramm ;; Terminating subroutine (defun standardTerminate ( ) ; The following variables declared in the main routines ; are used within this subroutine: ; get: echo errr (setq *error* errr) (command "_.undo" "_end") (if (equal (ver) "LISP Release 1.0") (command "_.regen") ; IntelliCAD requires this ) (setvar "cmdecho" echo) (princ) ) ;; Unterprogramme zur Fehlerbehandlung ;; Error handling subroutines (defun standardError (message) ; The following variables declared in the main routines ; are used within this subroutine: ; get: echo errr (princ message) (setq *error* errr) (command "_.undo" "_end") (setvar "cmdecho" echo) (princ) ) (defun regenError (message) ; The following variables declared in the main routine ; are used within this subroutine: ; get: echo errr (princ message) (setq *error* errr) (command "_.undo" "_end") (setvar "cmdecho" echo) (command "_.regen") (princ) ) ;_____________________________________________________________________; ;;; Allgemein verwendbare Unterprogramme ;;; General-purpose subroutines ;; Inkrement einer Zeichenkette [muss aus Großbuchstaben bestehen] ;; Increment of a string [must consist of upper case letters only] (defun str1+ ( uu ; Zeichenkette string / u> ; rechter Teil von uu right part of uu u< ; linker Teil von uu left part of uu u+ ; aktueller Buchstabe aus uu current character of uu ) (setq u> "" u< uu ) (str1+Iterate) (strcat u< u+ u>) ) (defun str1+Iterate ( ) (if (= "" u<) (setq u+ "A") (progn (setq u+ (chr (1+ (ascii (substr u< (strlen u<))))) u< (substr u< 1 (1- (strlen u<))) ) (if (< "Z" u+) (progn (setq u> (strcat "A" u>)) (str1+Iterate) ) ) ) ) ) ;; Transponieren einer Matrix [als Liste von Zeilenvektoren] ;; nach einer Idee von Douglas Wilson, siehe FAQ und Erklärungen: ;; http://xarch.tu-graz.ac.at/autocad/news/faq/autolisp.html.de#10 ;; http://xarch.tu-graz.ac.at/autocad/lisp/transpose.002.html ;; Transpose a matrix [given as a list of row vectors] ;; based upon an idea by Douglas Wilson, see the FAQ and explanations: ;; http://xarch.tu-graz.ac.at/autocad/news/faq/autolisp.html#10 ;; http://xarch.tu-graz.ac.at/autocad/lisp/transpose.002.html (defun transpose (matrix) (apply 'mapcar (cons 'list matrix)) ) ;; Flächeninhalt eines Dreiecks ;; Area of a triangle (defun areaTriangle (p1 p2 p3) ; Eckpunkte [3d-Punkte] corners [3D points] (* 0.5 (distance '(0.0 0.0 0.0) (vectorProduct (mapcar '- p1 p3) (mapcar '- p2 p3)) ) ) ) ;; Durchstoßpunkt der Verbindungslinie zweier 3d-Punkte ;; durch eine Ebene [gemäß Strahlensatz] ;; Die Punkte müssen verschiedene Abstände von der Ebene haben! ;; Intersection point of a plane ;; traversed by a line connecting two 3D points ;; The two points must have different distances from the plane! (defun interPoint ( p1 p2 ; die Punkte the points d1 d2 ; deren Abstände their distances ) ; von der Ebene from the plane (mapcar '+ p1 (mapcar '(lambda (vc) (* (/ d1 (- d1 d2)) vc)) (mapcar '- p2 p1) ) ) ) ;; Prüfen, ob vier 3d-Punkte in derselben Ebene liegen ;; [wenn ja, wird t zurückgegeben; andernfalls nil] ;; Check whether four 3D points are situated on the same plane ;; [if yes, t will be returned; otherwise nil] (defun coplanar ( p1 ; Punkte points p2 p3 p4 / e1 ; Einheitsvektoren vom 4. unit vectors from 4th e2 ; zum 1., 2. und 3. Punkt; to 1st, 2nd, and 3rd point; e3 ; nil, falls die Punkte nil if points ; identisch sind are identical tol ; Toleranz tolerance ) (setq tol 1.0e-012) (if (and (setq e1 (normalize (mapcar '- p1 p4))) (setq e2 (normalize (mapcar '- p2 p4))) (setq e3 (normalize (mapcar '- p3 p4))) ) (equal 0.0 (scalarProduct (vectorProduct e1 e2) e3) tol) t ) ) ;; Normieren eines 3d-Vektors ;; Unter Beibehaltung der Richtung wird die Länge auf 1.0 gesetzt, ;; indem alle drei Komponenten des Vektors ;; durch dessen ursprüngliche Länge dividiert werden. ;; Wird der Nullvektor eingegeben, so wird nil zurückgegeben. ;; Normalize a 3D vector ;; Direction of vector is maintained; its length is set to 1.0 ;; by dividing all three components by original length of vector. ;; The attempt of normalizing a zero vector returns nil. (defun normalize ( v ; Vektor vector / d ; dessen Länge its length tol ; Toleranz tolerance ) (setq tol 1.0e-012 d (distance '(0.0 0.0 0.0) v) ) (if (not (equal 0.0 d tol)) (mapcar '(lambda (c) (/ c d)) v) ) ) ;; Skalarprodukt zweier 3d-Vektoren ;; [ergibt Null genau dann, ;; wenn die Vektoren orthogonal zueinander sind] ;; Scalar product of two 3D vectors ;; [returning zero implies and is implied by ;; both vectors being perpendicular to one another] (defun scalarProduct (v1 v2) (+ (* (car v1) (car v2)) (* (cadr v1) (cadr v2)) (* (caddr v1) (caddr v2)) ) ) ;; Vektorprodukt zweier 3d-Vektoren ;; [ist stets orthogonal zu beiden Vektoren; ;; ist Nullvektor genau dann, wenn beide Vektoren parallel sind] ;; Vector product of two 3D vectors ;; [is always perpendicular to both vectors; ;; returning a zero vector implies and is implied by ;; both vectors being parallel] (defun vectorProduct (v1 v2) (list (- (* (cadr v1) (caddr v2)) (* (caddr v1) (cadr v2))) (- (* (caddr v1) (car v2)) (* (car v1) (caddr v2))) (- (* (car v1) (cadr v2)) (* (cadr v1) (car v2))) ) ) ;_____________________________________________________________________; (princ (if (wcmatch (ver) "*(de)") "\n Schneiderei · Armin Antkowiak · März 2001 " "\n Tailors · Armin Antkowiak · March 2001 " ) ) (princ)