Bob Holtzmann Posted October 11, 2010 Share Posted October 11, 2010 (edited) I recently verified that this script works in Vw 2011. It's open source and royalty free. It reduces the vertices of 2D polys. Full script is below this line (do not include the lower signature line): ------------------------------------------------------- {$STRICT 8} {$NAMES 8} {______________________} PROCEDURE SimplifyPolys; { Somewhat Smarter Poly Simplifier - Public Domain - JDW } { Off the top of my head so may be slow and/or stupid algorithm and possibly quite buggy. User beware. VectorScript gurus encouraged to spiff it up. At least one compiler bug found resulting in a more peculiar script to get around it. } { Doesn't work on 3D polys (easy to add tho), doesn't handle polylines with invisible edges nicely. } { Most of these routines assume that the poly handle and other parameters are valid (outer routines check them for inner routines). Be careful if modifying the code or extracting pieces of it. } CONST debug = FALSE; debugWait = FALSE; VAR objType : INTEGER; h, hTemp : HANDLE; tolerance : REAL; str : STRING; degenerate : BOOLEAN; bogus : BOOLEAN; numVerts : INTEGER; PROCEDURE DoWait; BEGIN IF debug AND debugWait THEN Wait(1); END; PROCEDURE RemoveDuplicateVertices2D; { Deletes if degenerate poly. Not sure it handles mixed vertex types well, but don't care enough to think about it. } VAR i : INTEGER; x, y, lastX, lastY : REAL; BEGIN { RemoveDuplicateVertices2D } IF debug THEN BEGIN Message('RemoveDuplicateVertices2D'); DoWait; END; numVerts := GetVertNum(h); IF numVerts > 1 THEN BEGIN GetPolyPt(h, numVerts, lastX, lastY); FOR i := numVerts - 1 DOWNTO 1 DO BEGIN GetPolyPt(h, i, x, y); IF (x = lastX) AND (y = lastY) THEN DelVertex(h, i) ELSE BEGIN lastX := x; lastY := y; END; END; END; { final cleanup } numVerts := GetVertNum(h); IF (numVerts < 2) OR ((numVerts = 2) AND (lastX = x) AND (lastY = y)) THEN degenerate := TRUE; END; { RemoveDuplicateVertices2D } PROCEDURE SimplifyPoly2D; PROCEDURE TryToRemovePointsBetween(startIndex, endIndex : INTEGER); VAR lineStart, lineEnd, lineDir : VECTOR; i : INTEGER; midIndex : INTEGER; keepGoing : BOOLEAN; numVertsRemoved, savedNumVerts, numVerts : INTEGER; FUNCTION PointIsNearlyCollinear2D(index: INTEGER) : BOOLEAN; { Given a line going through lineStart in the direction of the unit vector LineDir, determines if the vertex of the polygon h is less than tolerance away from its projection on the line. } VAR pt, ptOnLine : VECTOR; BEGIN { PointIsNearlyCollinear2D } IF debug THEN BEGIN WriteLn('PointIsNearlyCollinear2D ', index); Message('PointIsNearlyCollinear2D ', index); DoWait; END; pt[3] := 0; GetPolyPt(h, index, pt[1], pt[2]); pt := pt - lineStart; ptOnLine := DotProduct(pt, lineDir) * lineDir; IF Norm(pt - ptOnLine) > tolerance THEN PointIsNearlyCollinear2D := FALSE ELSE PointIsNearlyCollinear2D := TRUE; END; { PointIsNearlyCollinear2D } {--- VW8.5 has a recursion bug which clobbers this; should be fixed in 9 Peculiarly doesn't affect other recursion in this file... FUNCTION PointsAreNearlyCollinear2D(startIndex, endIndex : INTEGER) : BOOLEAN; VAR midIndex, i, span : INTEGER; collinear : BOOLEAN; BEGIN { PointsAreNearlyCollinear2D IF debug THEN BEGIN WriteLn('PointsAreNearlyCollinear2D ', startIndex, ', ', endIndex); Message('PointsAreNearlyCollinear2D ', startIndex, ', ', endIndex); DoWait; END; span := endIndex - startIndex; IF span < 4 THEN BEGIN collinear := TRUE; FOR i := startIndex TO endIndex DO collinear := collinear AND PointIsNearlyCollinear2D(i); PointsAreNearlyCollinear2D := collinear; END ELSE BEGIN { this might fail for large polys.... XXX midIndex := (endIndex + startIndex) / 2; PointsAreNearlyCollinear2D := ( PointsAreNearlyCollinear2D(midIndex, endIndex) AND PointsAreNearlyCollinear2D(startIndex, midIndex - 1) ); END; END; { PointsAreNearlyCollinear2D ---} FUNCTION WorkaroundPointsAreNearlyCollinear2D(startIndex, endIndex : INTEGER) : BOOLEAN; VAR stack : ARRAY[1..32000, 1..2] OF INTEGER; { 32k absurdly more than needed! XXX } i, j, midIndex, span : INTEGER; long : LONGINT; collinear, keepGoing : BOOLEAN; BEGIN { WorkaroundPointsAreNearlyCollinear2D } IF debug THEN BEGIN WriteLn('WorkaroundPointsAreNearlyCollinear2D ', startIndex, ', ', endIndex); Message('WorkaroundPointsAreNearlyCollinear2D ', startIndex, ', ', endIndex); DoWait; END; i := 1; stack[1,1] := startIndex; stack[1,2] := endIndex; collinear := TRUE; WHILE (i > 0) AND collinear DO BEGIN IF debug THEN BEGIN WriteLn('Stack level: ', i, ' '); Message('Stack level: ', i, ' '); DoWait; END; span := stack[i,2] - stack[i,1]; IF span < 4 THEN BEGIN FOR j := stack[i,1] TO stack[i,2] DO collinear := collinear AND PointIsNearlyCollinear2D(j); i := i - 1; IF debug THEN BEGIN WriteLn('Down to level: ', i, ' '); Message('Down to level: ', i, ' '); DoWait; END; { compiler bug? gives array out of bounds index; or did before, maybe that was my bug... WHILE (i > 0) AND (stack[i,1] = -1) DO BEGIN i := i - 1; IF debug THEN BEGIN WriteLn('Down to level: ', i, ' '); Message('Down to level: ', i, ' '); DoWait; END; END; } keepGoing := TRUE; WHILE (i > 0) AND keepGoing DO BEGIN IF stack[i,1] <> -1 THEN keepGoing := FALSE ELSE BEGIN i := i - 1; IF debug THEN BEGIN WriteLn('Down to level: ', i, ' '); Message('Down to level: ', i, ' '); DoWait; END; END; END; {} END ELSE BEGIN long := stack[i,1]; { avoid short int overflow for huge polys } midIndex := (long + stack[i,2]) / 2; IF debug THEN BEGIN WriteLn(i+1, ': ', stack[i,1], '-', midIndex - 1, ' ', i+2, ': ', midIndex, '-', stack[i,2]); Message(i+1, ': ', stack[i,1], '-', midIndex - 1, ' ', i+2, ': ', midIndex, '-', stack[i,2]); DoWait; DoWait; DoWait; END; stack[i+1,1] := stack[i,1]; stack[i+1,2] := midIndex - 1; stack[i+2,1] := midIndex; stack[i+2,2] := stack[i,2]; stack[i,1] := -1; i := i + 2; END; END; WorkaroundPointsAreNearlyCollinear2D := collinear; END; {WorkaroundPointsAreNearlyCollinear2D } BEGIN { TryToRemovePointsBetween } IF debug THEN BEGIN WriteLn('TryToRemovePointsBetween ', startIndex, ', ', endIndex); Message('TryToRemovePointsBetween ', startIndex, ', ', endIndex); IF endIndex > GetVertNum(h) THEN BEGIN WriteLn('INDEX OUT OF RANGE! ', endIndex, ' > ', GetVertNum(h)); Message('INDEX OUT OF RANGE! ', endIndex, ' > ', GetVertNum(h)); END; DoWait; END; lineStart[3] := 0; lineDir[3] := 0; GetPolyPt(h, startIndex, lineStart[1], lineStart[2]); keepGoing := TRUE; WHILE (endIndex - startIndex > 1) AND keepGoing DO BEGIN GetPolyPt(h, endIndex, lineEnd[1], lineEnd[2]); {IF (lineEnd = lineStart) THEN BEGIN - compiler bug ? fails periodically} IF (lineEnd[1] = lineStart[1]) AND (lineEnd[2] = lineStart[2]) THEN BEGIN IF debug THEN BEGIN WriteLn('Skipping zero length segment; i = ', endIndex); Message('Skipping zero length segment; i = ', endIndex); DoWait; END; endIndex := endIndex - 1; END ELSE BEGIN keepGoing := FALSE; IF debug THEN BEGIN WriteLn('keepGoing := FALSE'); Message('keepGoing := FALSE'); DoWait; END; END END; IF (endIndex - startIndex > 1) THEN BEGIN lineDir := UnitVec(lineEnd - lineStart); IF WorkaroundPointsAreNearlyCollinear2D(startIndex, endIndex) THEN BEGIN FOR i := endIndex - 1 DOWNTO startIndex + 1 DO BEGIN IF debug THEN BEGIN WriteLn('Deleting ', i); Message('Deleting ', i); DoWait; END; DelVertex(h, i); END END ELSE IF (endIndex - startIndex > 2) THEN BEGIN IF debug THEN BEGIN WriteLn('Right'); Message('Right'); DoWait; END; { this might fail for large polys.... XXX } { a bit inefficient for small spans but whatever } midIndex := (endIndex + startIndex) / 2; TryToRemovePointsBetween(midIndex, endIndex); IF debug THEN BEGIN WriteLn('Left'); Message('Left'); DoWait; END; savedNumVerts := GetVertNum(h); TryToRemovePointsBetween(startIndex, midIndex); IF debug THEN BEGIN WriteLn('Mid'); Message('Mid'); DoWait; END; numVerts := GetVertNum(h); numVertsRemoved := savedNumVerts - numVerts; midIndex := midIndex - numVertsRemoved; IF (midIndex > 1) AND (midIndex < numVerts) THEN BEGIN TryToRemovePointsBetween(midIndex - 1, midIndex + 1); IF debug THEN BEGIN WriteLn('Mid'); Message('Mid'); DoWait; END; END; END; END; END; { TryToRemovePointsBetween } BEGIN { SimplifyPoly2D } IF debug THEN BEGIN Message('SimplifyPoly2D'); DoWait; END; RemoveDuplicateVertices; IF NOT degenerate THEN BEGIN TryToRemovePointsBetween(1, GetVertNum(h)); END; END; { SimplifyPoly2D } BEGIN { SimplifyPolys } IF debug THEN BEGIN Message('SimplifyPolys'); DoWait; END; h := FSActLayer; str := Num2StrF(0.1); tolerance := DistDialog('Maximum deviation from poly:', str); bogus := FALSE; WHILE (h <> NIL) AND (NOT bogus) DO BEGIN degenerate := FALSE; objType := GetType(h); CASE objType OF 0: BEGIN IF debug THEN BEGIN Message('Term Node!'); DoWait; SysBeep; END; bogus := TRUE; END; 5, 8, 21: { polygon, freehand polygon, polyline } SimplifyPoly2D; END; hTemp := h; h := NextSObj(h); IF degenerate THEN BEGIN DelObject(hTemp); { should give user alert that poly was deleted... but only once } END; END; END; { SimplifyPolys } RUN(SimplifyPolys); Edited October 11, 2010 by Bob-H Quote Link to comment
rDesign Posted October 11, 2010 Share Posted October 11, 2010 Thanks Bob-H! It also works perfectly in Vw2010. Regards, Tim Quote Link to comment
ErichR Posted November 23, 2010 Share Posted November 23, 2010 I don't have any experience with scripts. I did name and save the script into Tools/Scripts/PlugIn Editor. Then imported an image of a floor plan, selected it, and then went to Scripts/Run Script. A window opens for selecting the file. It's not to be found. In the Resources Browser, there seem to be no scripts available. It would help to know how to invoke the script, in what context, and what to expect. Thanks. Quote Link to comment
Ray Libby Posted November 23, 2010 Share Posted November 23, 2010 Scroll down to the bottom. http://techboard.nemetschek.net/ubbthreads.php?ubb=showflat&Number=148677#Post148677 Quote Link to comment
Recommended Posts
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.