Author Topic: remove the unnecessary vertices  (Read 3823 times)

0 Members and 1 Guest are viewing this topic.

domenicomaria

  • Swamp Rat
  • Posts: 725
remove the unnecessary vertices
« on: March 17, 2022, 04:09:01 PM »
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


« Last Edit: March 17, 2022, 04:52:25 PM by domenicomaria »

tombu

  • Bull Frog
  • Posts: 289
  • ByLayer=>Not0
Re: remove the unnecessary vertices
« Reply #1 on: March 17, 2022, 06:08:22 PM »
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.
Tom Beauford P.S.M.
Leon County FL Public Works - Windows 7 64 bit AutoCAD Civil 3D

domenicomaria

  • Swamp Rat
  • Posts: 725
Re: remove the unnecessary vertices
« Reply #2 on: March 18, 2022, 12:38:47 AM »
I need a math and geometry solution ...
... not a command to use for a polyline
...
anyway OVERKILL is great !
« Last Edit: March 18, 2022, 03:36:10 AM by domenicomaria »

domenicomaria

  • Swamp Rat
  • Posts: 725
Re: remove the unnecessary vertices
« Reply #3 on: March 18, 2022, 03:13:52 AM »
(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

« Last Edit: March 18, 2022, 03:34:59 AM by domenicomaria »

domenicomaria

  • Swamp Rat
  • Posts: 725
Re: remove the unnecessary vertices
« Reply #4 on: March 18, 2022, 07:12:10 AM »
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 !
« Last Edit: March 18, 2022, 10:03:08 AM by domenicomaria »

kirby

  • Newt
  • Posts: 132
Re: remove the unnecessary vertices
« Reply #5 on: March 18, 2022, 10:08:31 AM »
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

  • Swamp Rat
  • Posts: 725
Re: remove the unnecessary vertices
« Reply #6 on: March 18, 2022, 10:52:56 AM »
thank you kirby

It seems to be interesting

I'll take a look at it later

ciao


domenicomaria

  • Swamp Rat
  • Posts: 725
Re: remove the unnecessary vertices
« Reply #8 on: March 21, 2022, 11:30:11 AM »
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

  • Water Moccasin
  • Posts: 1632
  • Ukraine
Re: remove the unnecessary vertices
« Reply #9 on: March 21, 2022, 12:05:34 PM »
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

  • Swamp Rat
  • Posts: 725
Re: remove the unnecessary vertices
« Reply #10 on: March 21, 2022, 12:29:18 PM »
VovKa my brain is a little burned. . . :lol:
... 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.
« Last Edit: March 21, 2022, 12:35:57 PM by domenicomaria »

domenicomaria

  • Swamp Rat
  • Posts: 725
« Last Edit: March 22, 2022, 12:57:43 AM by domenicomaria »

VovKa

  • Water Moccasin
  • Posts: 1632
  • Ukraine
Re: remove the unnecessary vertices
« Reply #12 on: March 21, 2022, 03:03:20 PM »
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

  • Swamp Rat
  • Posts: 725
Re: remove the unnecessary vertices
« Reply #13 on: March 22, 2022, 01:23:12 AM »
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

  • Water Moccasin
  • Posts: 1632
  • Ukraine
Re: remove the unnecessary vertices
« Reply #14 on: March 22, 2022, 07:53:45 AM »
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 :)

dgpuertas

  • Newt
  • Posts: 80
Re: remove the unnecessary vertices
« Reply #15 on: March 22, 2022, 08:13:10 AM »

Another approach Douglas–Peucker algorithm

Recursive

Code: [Select]


(defun DouglasPeucker_elimPtos (PointList CorridorWidth / p1 p2 distan valmax nn 2lis)

  (if (< (length PointList) 3)
    PointList (progn

  (setq p1 (car PointList)
p2 (last PointList)
distan (mapcar (function (lambda (pt) (PerDist p1 p2 pt))) (reverse (cdr (reverse (cdr PointList)))))
valmax (apply (function max) distan)
)
   (if (> valmax CorridorWidth) (progn

  (setq nn (vl-position valmax distan) ;hay uno menos, se suman 2
2lis (breaklistAt (+ 2 nn) PointList T))
  (append (DouglasPeucker_elimPtos (car 2lis) CorridorWidth)
  (cdr (DouglasPeucker_elimPtos (cadr 2lis) CorridorWidth)))
 
        )
     
      (list p1 p2))

  ))

)




(defun PerDist (pt1 pt2 pt3 / ang1 ang2)
; Compute perpendiculat distance
; c. 1992 author unknown, Mod KJM 1994
;       perpendicular distance from pt3 to line segment pt1-pt2
   (setq ang1 (angle pt1 pt2)
         ang2 (angle pt1 pt3)
         ang1 (if (> ang2 ang1)(+ ang1 2pi) ang1)
   )
  (abs (* (distance pt1 pt3) (sin (- ang1 ang2))))
)



(defun breaklistAt (n l repeat? / r)
 (while (and l (< 0 n))
   (setq r (cons (car l) r)
  l (cdr l)
  n (1- n)
   )
 )
 (list (reverse r) (if repeat? (cons (car r) l) l))
)


kdub_nz

  • Mesozoic keyThumper
  • SuperMod
  • Water Moccasin
  • Posts: 2143
  • class keyThumper<T>:ILazy<T>
Re: remove the unnecessary vertices
« Reply #16 on: March 22, 2022, 10:51:03 PM »
See if this gives you some ideas ( from gile )

http://www.theswamp.org/index.php?topic=18720.msg234086#msg234086
Called Kerry in my other life
Retired; but they dragged me back in !

I live at UTC + 13.00

---
some people complain about loading the dishwasher.
Sometimes the question is more important than the answer.

kirby

  • Newt
  • Posts: 132
Re: remove the unnecessary vertices
« Reply #17 on: March 23, 2022, 08:13:33 AM »
@dgpuertas
Nice code reduction (Almost too streamlined for my brain).

MatGrebe

  • Mosquito
  • Posts: 16
Re: remove the unnecessary vertices
« Reply #18 on: March 23, 2022, 09:42:29 AM »
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.
Hello Kirby,
i like your attached pweed.lsp, but i'm running into a problem when having bulges in a polyline. In that case there is called a routine FIXANG which isn't in the code. Can you post this snippet ? Maybe it just fixes an angle between 0 and 2pi ?
Thanks
Mathias
« Last Edit: March 23, 2022, 09:55:01 AM by MatGrebe »

kirby

  • Newt
  • Posts: 132
Re: remove the unnecessary vertices
« Reply #19 on: March 23, 2022, 12:07:36 PM »
Hi Mat

The D-P algorithm doesn't support polyarcs so be careful (e.g. it just considers the points so will just assume a polyarc is the long chord between the two segment endpoints).  However, you could replace the curvaceous polyline with another with the polyarcs replaced by short line segments (using either the minimum angle, minimum segment length, or best of all minimum middle ordinate distance).  You could generate the replacement polyline points with (setq MyNewPointsList (pseglist Ent 5)) then build a new poly from the points list.

My bad for not including all the referenced subroutines.  Two missing routines 'fixang' and 'dist2d' shown below.  You are correct, 'Fixang' just corrects an angle to be 0<=angle<2pi.

Code - Auto/Visual Lisp: [Select]
  1. (defun Dist2d (P1 P2 / P1X P1Y P2X P2Y NewP1 NewP2 D)
  2. ; Distance between 2 points in X-Y coordiante system
  3. ; KJM - April 6, 2000
  4.  
  5.         (setq P1X (car P1) P1Y (cadr P1) P2X (car P2) P2Y (cadr P2))
  6.  
  7.         (setq NewP1 (list P1X P1Y 0.0))
  8.         (setq NewP2 (list P2X P2Y 0.0))
  9.  
  10.         ;(if (= Verbose 1)
  11.         ;  (progn
  12.         ;       (prompt "\n    Distance between ")(princ NewP1)(prompt " and ")(princ NewP2)
  13.         ;  )
  14.         ;)
  15.  
  16.         (if (and (equal P1X P2X 0.001) (equal P1Y P2Y 0.001))
  17.                 (setq D 0.0)
  18.                 (setq D (distance NewP1 NewP2))
  19.         )
  20.  
  21.         ;(if (= Verbose 1)
  22.         ;  (progn
  23.         ;       (prompt "\n      equals ")(princ D)
  24.         ;  )
  25.         ;)
  26.  
  27.         D        ; return distance
  28. )
  29.  
  30.  
  31.  
  32. (defun Fixang (Ang / K)
  33. ; Correct angle to lie within 0 and 2*pi
  34. ; KJM - Jan 1988, Mod KJM March 2019
  35. ; Note: now equivalent to 'Unitcircle' function
  36.  
  37. (if (eq 2pi nil) (setq 2pi (* 2.0 pi)))
  38.  
  39. (if (or (equal Ang 0.0 0.0001) (equal Ang 2pi 0.0001))
  40.         (setq Ang 0.0)
  41. )
  42.  
  43. (setq K 1)
  44.         (cond
  45.                 ((>= Ang 2pi)
  46.                         (setq Ang (- Ang 2pi))
  47.                 )
  48.                 ((< Ang 0.0)
  49.                         (setq Ang (+ Ang 2pi))
  50.                 )
  51.         )
  52.         (if (and (>= Ang 0.0) (< Ang 2pi))
  53.                 (setq K nil)
  54.         )
  55. )
  56. Ang     ; return fixed angle
  57. )
  58.  

PM

  • Guest
Re: remove the unnecessary vertices
« Reply #20 on: March 23, 2022, 04:59:23 PM »
Hi i use this code

Code - Auto/Visual Lisp: [Select]
  1. ;;;=======================[ PSimple.lsp ]=======================
  2. ;;; Author: Charles Alan Butler
  3. ;;; Version:  1.1 Nov. 09, 2007
  4. ;;; Purpose: To remove un needed vertex from a pline
  5. ;;;=============================================================
  6.  
  7. ;;  Note, very little testing has been done at this time
  8. (defun c:PSimple (/ doc ent elst vlst idx dir keep result hlst len
  9.                   group_on)
  10.  
  11.   ;; CAB 11/03/07
  12.   ;;  group on the elements of a flat list
  13.   ;;  (group_on '(A B C D E F G) 3)
  14.   ;;  Result  ((A B C) (D E F) (G nil nil)...)
  15.   (defun group_on (inplst gp# / outlst idx subLst)
  16.     (while inplst
  17.       (setq idx -1
  18.             subLst nil
  19.       )
  20.       (while (< (setq idx (1+ idx)) gp#)
  21.         (setq subLst (cons (nth idx inplst) sublst))
  22.       )
  23.       (setq outlst (cons (reverse sublst) outlst))
  24.       (repeat gp#
  25.         (setq inplst (cdr inplst))
  26.       )
  27.     )
  28.     (reverse outlst)
  29.   )
  30.  
  31.  
  32.   (setq ent (car (entsel "\n Select polyline to remove extra vertex: ")))
  33.   (if (and ent
  34.            (setq elst (entget ent))
  35.            (equal (assoc 0 elst) '(0 . "LWPOLYLINE"))
  36.       )
  37.     (progn
  38.       (setq idx 0)
  39.         (cond
  40.           ((null keep)
  41.            (setq keep '(1)
  42.                  dir  (angle '(0 0) (vlax-curve-getFirstDeriv ent 0.0))
  43.            ))
  44.           ((or (null(vlax-curve-getFirstDeriv ent idx))
  45.                (equal dir (setq dir (angle '(0 0)
  46.                              (vlax-curve-getFirstDeriv ent idx))) 0.000001))
  47.            (setq keep (cons 0 keep))
  48.           )
  49.           ((setq keep (cons 1 keep)))
  50.         )
  51.         (setq idx (1+ idx))
  52.       )
  53.       (setq vlst (vl-remove-if-not
  54.                    '(lambda (x) (vl-position (car x) '(40 41 42 10))) elst))
  55.       (setq vlst (group_on vlst 4))
  56.       (setq idx -1
  57.             len (1- (length vlst))
  58.             keep (reverse (cons 1 keep))
  59.       )
  60.       (while (<= (setq idx (1+ idx)) len)
  61.         (cond
  62.           ((not (zerop (cdr(cadddr (nth idx vlst))))) ; keep arcs
  63.            (setq result (cons (nth idx vlst) result))
  64.           )
  65.           ((not (zerop (nth idx keep)))
  66.            (setq result (cons (nth idx vlst) result))
  67.           )
  68.         )
  69.       )
  70.  
  71.       (setq hlst (vl-remove-if
  72.                    '(lambda (x) (vl-position (car x) '(40 41 42 10))) elst))
  73.       (mapcar '(lambda(x) (setq hlst (append hlst x))) (reverse result))
  74.       (setq hlst (subst (cons 90 (length result)) (assoc 90 hlst) hlst))
  75.       (entmod hlst)
  76.     )
  77.   )
  78.  
  79.   (princ)
  80. )
  81. (prompt "\nPline Simplify loaded, PSimple to run.")
  82.  

domenicomaria

  • Swamp Rat
  • Posts: 725
Re: remove the unnecessary vertices
« Reply #21 on: May 20, 2022, 06:14:28 AM »
Domenico, hai provato questo: http://www.theswamp.org/index.php?topic=19865.msg244892#msg244892

I tested the GILE code . . .

It is GREAT !

Thank you for the link, Marco

Ciao