Topic: remove the unnecessary vertices

[domenicomaria]

Code - Auto/Visual Lisp: [Select]

1. (defun :LWP-EMK-V-LST   (v-lst)
2.    (entmake
3.       (append
4.             (list   '(0 . "LWPOLYLINE")   '(100 . "AcDbEntity")   '(100 . "AcDbPolyline")   (cons 90 (length v-lst) ) )
5.             (apply 'append    (mapcar '(lambda (i) (list (cons 10 i ) ) )  v-lst) )
6.       )
7.    )
8. )
9.  
10. (defun :LST-LAST-1 ( l / l-len) (if (> 1 (- (setq l-len (length l) ) 1) )   nil  (nth (- (- l-len 1) 1) l) ) )
11.  
12. ;   v-lst   CANNOT CONTAIN consecutive coincident points (no ZERO LENGTH SEGMENTS)
13. (defun :GEOM-V-LST-REMOVE-ALIGNED-VERTICES (v-lst ang-fuzz /  ang23 p1 p2 p3 prev-ang r)
14.    ;   (setq v-lst   (vl-list* (:lst-last-1 v-lst) v-lst) )
15.  
16.    (setq p1    (car  v-lst)     p2          (cadr v-lst)
17.          r     (list p1 p2)    prev-ang    (angle p1 p2)
18.          v-lst (cdr  v-lst)
19.    )
20.    (while (cdr v-lst)
21.       (setq p2 (car v-lst)   p3 (cadr v-lst)     ang23 (angle p2 p3)   )
22.       (if(equal prev-ang ang23 ang-fuzz)
23.          (setq r (cons p3 (cdr r) ) )
24.          (setq r (cons p3 r) )
25.       )
26.      
27.       (setq v-lst (cdr  v-lst) prev-ang ang23)
28.    )
29.    (reverse r)
30. )
31.  
32.  
33.  
34.  
35.  
36. (defun c:test ( / r v-lst )
37.    (setq v-lst '((1285.09 272.024 0.0) (1328.19 291.889 0.0) (1371.1 311.668 0.0) (1431.08 339.319 0.0) (1481.62 362.613 0.0) (1463.51 377.038 0.0) (1439.14 396.446 0.0) (1420.56 411.244 0.0) (1392.12 393.476 0.0) (1375.22 382.92 0.0) (1359.5 373.102 0.0) (1351.87 413.152 0.0) (1393.13 428.569 0.0) (1410.92 435.215 0.0) (1453.95 451.294 0.0) (1411.03 470.398 0.0) (1373.22 487.227 0.0) (1331.84 505.647 0.0) (1298.95 481.425 0.0) (1258.69 451.775 0.0) (1223.08 425.548 0.0) (1248.95 361.498 0.0) (1259.27 335.942 0.0) (1268.89 312.131 0.0) (1285.09 272.024 0.0) ) )
38.    (setvar "cecolor" "70") (:LWP-EMK-V-LST v-lst)
39.    (setq r (:GEOM-V-LST-REMOVE-ALIGNED-VERTICES v-lst 0.0174533) )
40.    (setvar "cecolor" "222") (:LWP-EMK-V-LST r)
41. )

I have a list of counterclockwise points

If I draw them, I can see that there are some unnecessary vertices that are aligned and between other "main" vertices

I want to remove the unnecessary vertices, leaving only the main vertices

but something goes wrong

and I can't figure out what

[tombu]

Code: [Select]

(strcat "HKEY_CURRENT_USER\\" (vlax-product-key) "\\Profiles\\" (getvar "cprofile") "\\Dialogs\\Overkill")returns the location of all saved options for the OVERKILL command.

I'd save the existing settings like

Code: [Select]

(vl-registry-read registry "OptimizePolylines")and reset them like

Code: [Select]

(vl-registry-write registry "OptimizePolylines" "1")run the OVERKILL command using command-s then reset the previous settings.

It's a powerful command but pain to simply run at the command line because there's so many settings and they're all stored in the registry.

[domenicomaria]

I need a math and geometry solution ...
... not a command to use for a polyline
...
anyway OVERKILL is great !

[domenicomaria]

(setq p1    (car  v-lst)     p2          (cadr v-lst)
         r     (list p1 p2)    prev-ang    (angle p1 p2)
         v-lst (cdr  v-lst)
)

The red code is wrong.
It must be : (setq r (list p2 p1) )
...
Anyway, it works better, but sometimes, it does not remove 1 unnecessary vertex . . .

I've also tried to modify ang-fuzz,
but still sometimes it doesn't remove an unnecessary vertex

[domenicomaria]

Code - Auto/Visual Lisp: [Select]

1. (defun :LST-REVERSE-CDR (l) (reverse (cdr (reverse l) ) ) )
2.  
3. (defun :GEOM-V-LST-REMOVE-ALIGNED-VERTICES (v-lst ang-fuzz /  ang23 p1 p2 p3 prev-ang first-ang r)
4.    (setq p1    (car  v-lst)     p2         (cadr  v-lst )
5.          r     (list p2 p1)    prev-ang    (angle p1 p2 )   first-ang prev-ang
6.          v-lst (cdr  v-lst)
7.    )
8.    (while (and (setq p2 (car v-lst) ) (setq p3 (cadr v-lst) ) )
9.       (setq ang23 (angle p2 p3) )
10.       (if(equal prev-ang ang23 ang-fuzz)
11.          (setq r (cons p3 (cdr r) ) )
12.          (setq r (cons p3 r) )
13.       )
14.       (setq v-lst (cdr  v-lst) prev-ang ang23)
15.    )
16.    (if (equal prev-ang first-ang ang-fuzz)  (setq r (cdr (:LST-REVERSE-CDR r) ) ) )
17.    (reverse r)
18. )

. . . while this one seems to work well !

[kirby]

Another approach using Douglas-Puecker algorithm, which reduces excess vertices based on a corridor width.  Originally found on Compuserve message board as 'Polyweed.lsp' with no author listed.  I've been using it for 30+ years to reduce digitized polylines, recently refactored it and added a trial mode to test various corridor widths.  My application was waterway/streamline polyline reduction on large rural drainage project, reducing 1000's of bloated polylines and converting them into a hydraulic (SWMM) model.

However, does not handle polyarc segments since most digitizing (or imported shapefiles) only have line segment polylines.

Uses a lot of library routines (and long code...that's just my approach, all added to the included file from libraries).

Really good description here:
https://cartography-playground.gitlab.io/playgrounds/douglas-peucker-algorithm/

Also known as Ramer-Douglas-Peucker
https://en.wikipedia.org/wiki/Ramer%E2%80%93Douglas%E2%80%93Peucker_algorithm

Core routine:

Code - Auto/Visual Lisp: [Select]

1. (defun DouglasPeucker (PointList IsClosed CorridorWidth /
2.                 OutList BPT BP1 BP2 LPT CNT1
3.                 )
4. ; Polyline vertex reduction by Douglas-Peucker method
5. ; c. 1992, Refactored KJM - March 2019
6. ; Uses classic Douglas-Peucker algorithm 1973
7. ;       https://utpjournals.press/doi/10.3138/FM57-6770-U75U-7727
8. ; Input:
9. ;       PointList - (list) list of points (vertices of straight segment polyline)
10. ;       IsClosed - (integer) 0 or nil if polyline is open, 1 if polyline is closed
11. ;       CorridorWidth - (real) width of corridor centred on polyline
12. ;       future addition: StepMode - (integer) 0 or nil = run automatically, 1 = step through and wait for user feedback
13. ; Returns:
14. ;       list of weeded points
15. ; Uses custom functions
16. ;       perdist
17.        
18. (setq OutList nil)
19.  
20. (if PointList
21.   (progn
22.         (if (eq (type PointList) 'LIST)
23.           (progn
24.  
25.                 ; Look at each point in the list
26.                 (setq BPT (nth 0 PointList))
27.                 (setq BP1 (nth 1 PointList))
28.                 (setq BP2 (nth 2 PointList))
29.                 (setq LPT BP1)
30.  
31.                 (setq OutList (cons BPT OutList))
32.  
33.                 (setq CNT1 2)
34.                 (while (nth CNT1 PointList) ;step through list
35.                         ;(prompt "\n CNT1 = ")(princ CNT1)
36.                        
37.                         (cond
38.                                 ((<= (perdist BPT BP1 BP2)  (* 0.5 CorridorWidth))      ;find point where cooridor width exceeded
39.                                   (progn
40.                                         (setq LPT BP2)
41.                                         (setq BP2 (nth (1+ CNT1) PointList))
42.                                         ; (setq weedpts (1+ weedpts))
43.                                   )
44.                                 )
45.  
46.                                 (T              ;BP2 outside of distance
47.                                   (progn
48.                                         (setq OutList (cons LPT OutList))
49.                                         (setq BPT LPT)
50.                                         (setq BP1 BP2)
51.                                         (setq BP2 (nth (1+ CNT1) PointList))
52.                                         (setq LPT BP1)
53.                                   )
54.                                 )
55.                         ) ; close cond
56.                        
57.                         (setq CNT1 (1+ CNT1))
58.                 ) ; close while
59.                
60.                 (setq OutList (cons (last PointList) OutList))
61.                 (setq OutList (reverse OutList))
62.           )
63.         ) ; close if
64.   )
65. ) ; close if    
66.  
67. OutList
68. )
69.  
70.  
71. (defun PerDist (pt1 pt2 pt3 / d1 ang1 ang2 delta)
72. ; Compute perpendiculat distance
73. ; c. 1992 author unknown, Mod KJM 1994
74. ; Input:
75. ;       p1t, pt2 - (points) two points specifying a ling segment
76. ;       pt3 - (point) another point
77. ; Returns:
78. ;       perpendicular distance from pt3 to line segment pt1-pt2
79.    (setq d1 (distance pt1 pt3)
80.          ang1 (angle pt1 pt2)
81.          ang2 (angle pt1 pt3)
82.          ang1 (if (> ang2 ang1)(+ ang1 (* pi 2.0)) ang1)
83.          delta (- ang1 ang2)
84.   )
85.   (abs (* d1 (sin delta)))
86. )
87.  
88.  

[domenicomaria]

thank you kirby

It seems to be interesting

I'll take a look at it later

ciao

[Marc'Antonio Alessi]

Domenico, hai provato questo: http://www.theswamp.org/index.php?topic=19865.msg244892#msg244892

[domenicomaria]

Domenico, hai provato questo: http://www.theswamp.org/index.php?topic=19865.msg244892#msg244892

purge-pline is certainly a great routine. . .
We know that Gile is a guru!
(but you also don't joke) . . .
. . . maybe it is very similar to the OVERKILL command ?
. . .
However,
I am not interested in processing the data of a polyline,
but processing the data of a list of points. . .

And anyway, this latest version that I am attaching
seems to work well!
If someone finds me a situation where it doesn't work,
I will be happy to try to improve it.

Ciao

Code - Auto/Visual Lisp: [Select]

1. ; for a COUNTER-CLOCKWISE list of points, WITHOUT COINCIDENT POINTS (NO ZERO LENGTH SEGMENTS)
2. (defun :GEOM-V-LST-REMOVE-ALIGNED-VERTEXES (v-lst ang-fuzz /  ang23 p1 p2 p3 prev-ang first-ang closed r)
3.    (setq closed (equal (car v-lst) (last v-lst) 1e-9) )
4.  
5.    (setq p1    (car  v-lst)    p2          (cadr  v-lst )
6.          r     (list p2 p1)    prev-ang    (angle p1 p2 )   first-ang prev-ang
7.          v-lst (cdr  v-lst)
8.    )
9.    (while (and (setq p2 (car v-lst) ) (setq p3 (cadr v-lst) ) )
10.       (setq ang23 (angle p2 p3) )
11.       (if(equal prev-ang ang23 ang-fuzz)
12.          (setq r (cons p3 (cdr r) ) )
13.          (setq r (cons p3 r) )
14.       )
15.       (setq v-lst (cdr  v-lst) prev-ang ang23)
16.    )
17.  
18.    (if closed
19.       (if(equal prev-ang first-ang ang-fuzz)
20.          (setq r (cdr (reverse (cdr (reverse r) ) ) ) )
21.       )
22.    )
23.    
24.    (if closed (setq r (append r (list (car r) ) ) ) )
25.  
26.    (reverse r)
27. )
28.  

this is the latest working version !

[VovKa]

If someone finds me a situation where it doesn't work,

Code: [Select]

(setq v-lst '((1192.63 291.385) (1208.37 301.527) (1224.28 311.405) (1240.35 321.018) (1256.58 330.362) (1272.96 339.434) (1289.49 348.233) (1306.16 356.756) (1322.97 365.0) (1339.92 372.964) (1357.0 380.644) (1374.2 388.039) (1391.52 395.148) (1408.96 401.967) (1426.51 408.495) (1444.17 414.73) (1461.93 420.67) (1479.78 426.315) (1497.73 431.661) (1515.76 436.709) (1533.87 441.456) (1552.06 445.9) (1570.32 450.042) (1588.65 453.879) (1607.04 457.411) (1625.49 460.637) (1643.98 463.555) (1662.53 466.165) (1681.11 468.467) (1699.73 470.459) (1718.38 472.141)))


(while (and (setq p2 (car v-lst)) (setq p3 (cadr v-lst)))
    (setq ang23 (angle p2 p3))
    (if (equal prev-ang ang23 ang-fuzz)
      (setq r (cons p3 (cdr r)))
      (setq r (cons p3 r)
    prev-ang ang23 ;fix
      )
    )
    (setq v-lst (cdr v-lst))
  )


[domenicomaria]

VovKa my brain is a little burned. . .
... be clearer ...
to do a test, I draw a polyline made of only segments,
where many consecutive segments have the same angle ...
...
... then I extract all the vertices and pass them to my function ...
and then I draw the new polyline that does not contain consecutive aligned segments ...
...
and it seems to me that it works fine!

The list of points you sent me is made up
of many segments that differ by a very small angle
... just adjust the ang-fuzz value ...
...
I know you never talk nonsense. . . but help me to understand better, please.

[domenicomaria]

before and after

https://drive.google.com/file/d/1hok91u_1chig6IC_1MT2jd_jeGrwRY6H/view?usp=sharing

https://drive.google.com/file/d/1XSg2_AqTgnNkJfSI6JL6TQ9cuYzSSxwV/view?usp=sharing

[VovKa]

of many segments that differ by a very small angle
... just adjust the ang-fuzz value ...

https://imgur.com/a/elMb6Zt
yours to the left, mine to the rigth
i used your fuzz, which i quite small = 1 degree
i believe that this fuzz will be hardcoded in your function and it will not be convenient to change it for every other polygon
the problem with your code is that you compare angles between nonexistent (removed) points

[domenicomaria]

the problem with your code is that you compare angles between nonexistent (removed) points

Code - Auto/Visual Lisp: [Select]

1. (defun :GEOM-V-LST-REMOVE-ALIGNED-VERTEXES (v-lst ang-fuzz /  ang23 p1 p2 p3 prev-ang first-ang closed r)
2.    (setq closed (equal (car v-lst) (last v-lst) 1e-9) )
3.  
4.    (setq p1    (car  v-lst)    p2           (cadr  v-lst )
5.          r     (list p2 p1)    first-ang    (angle p1 p2 )   prev-ang first-ang
6.          v-lst (cdr  v-lst)
7.    )
8.    (while (and (setq p2 (car v-lst) ) (setq p3 (cadr v-lst) ) )
9.       (setq ang23 (angle p2 p3) )
10.       (if(equal prev-ang ang23 ang-fuzz)
11.          (setq r (cons p3 (cdr r) ) )
12.          (setq r (cons p3 r) )
13.       )
14.       (setq v-lst (cdr  v-lst)
15.             prev-ang (angle (cadr r) (car r) ) ;   fixed  
16.       )
17.    )
18.  
19.    (if closed
20.       (if(equal prev-ang first-ang ang-fuzz)
21.          (setq r (cdr (reverse (cdr (reverse r) ) ) ) )
22.       )
23.    )
24.    
25.    (if closed (setq r (append r (list (car r) ) ) ) )
26.  
27.    (reverse r)
28. )
29.  
30.  
31.  
32. (defun :LWP-EMK-V-LST   (v-lst)
33.    (entmake
34.       (append
35.             (list   '(0 . "LWPOLYLINE")   '(100 . "AcDbEntity")   '(100 . "AcDbPolyline")   (cons 90 (length v-lst) ) )
36.             (apply 'append    (mapcar '(lambda (i) (list (cons 10 i ) ) )  v-lst) )
37.       )
38.    )
39. )
40.  
41. (defun c:TEST ( / r v-lst )
42.    (setq v-lst '((1192.63 291.385) (1208.37 301.527) (1224.28 311.405) (1240.35 321.018) (1256.58 330.362) (1272.96 339.434) (1289.49 348.233) (1306.16 356.756) (1322.97 365.0) (1339.92 372.964) (1357.0 380.644) (1374.2 388.039) (1391.52 395.148) (1408.96 401.967) (1426.51 408.495) (1444.17 414.73) (1461.93 420.67) (1479.78 426.315) (1497.73 431.661) (1515.76 436.709) (1533.87 441.456) (1552.06 445.9) (1570.32 450.042) (1588.65 453.879) (1607.04 457.411) (1625.49 460.637) (1643.98 463.555) (1662.53 466.165) (1681.11 468.467) (1699.73 470.459) (1718.38 472.141)))
43.    (setvar "cecolor" "70") (:LWP-EMK-V-LST v-lst)
44.    (setq r (:GEOM-V-LST-REMOVE-ALIGNED-VERTEXES v-lst 0.017) )
45.    ;   (:point (car r) )
46.    (setvar "cecolor" "150") (:LWP-EMK-V-LST r)
47. )

ok VovKa !
Thank you.

This one seems to work well !
Let me know, please.

Ciao

[VovKa]

Let me know, please.

i see that your fix is different from my proposal in https://www.theswamp.org/index.php?topic=57443.msg609304#msg609304
nevertheless it does its job