Jump to content
Sign in to follow this  
Bob-H

Purge Polys command

Recommended Posts

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 by Bob-H

Share this post


Link to post

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.

Share this post


Link to post

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.

Guest
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

Sign in to follow this  

 

7150 Riverwood Drive, Columbia, Maryland 21046, USA   |   Contact Us:   410-290-5114

 

© 2018 Vectorworks, Inc. All Rights Reserved. Vectorworks, Inc. is part of the Nemetschek Group.

×
×
  • Create New...