TheSwamp

Code Red => AutoLISP (Vanilla / Visual) => Topic started by: domenicomaria on March 17, 2022, 04:09:01 PM

Title: remove the unnecessary vertices
Post by: domenicomaria 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


Title: Re: remove the unnecessary vertices
Post by: tombu 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.
Title: Re: remove the unnecessary vertices
Post by: domenicomaria 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 !
Title: Re: remove the unnecessary vertices
Post by: domenicomaria 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

Title: Re: remove the unnecessary vertices
Post by: domenicomaria 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 !
Title: Re: remove the unnecessary vertices
Post by: kirby 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.  
Title: Re: remove the unnecessary vertices
Post by: domenicomaria 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
Title: Re: remove the unnecessary vertices
Post by: Marc'Antonio Alessi on March 21, 2022, 09:55:08 AM
Domenico, hai provato questo: http://www.theswamp.org/index.php?topic=19865.msg244892#msg244892



Title: Re: remove the unnecessary vertices
Post by: domenicomaria on March 21, 2022, 11:30:11 AM
Quote from: Marc'Antonio Alessi on March 21, 2022, 09:55:08 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 !
Title: Re: remove the unnecessary vertices
Post by: VovKa on March 21, 2022, 12:05:34 PM
Quote from: domenicomaria on March 21, 2022, 11:30:11 AM
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))
  )
Title: Re: remove the unnecessary vertices
Post by: domenicomaria 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.
Title: Re: remove the unnecessary vertices
Post by: domenicomaria on March 21, 2022, 12:39:22 PM
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
Title: Re: remove the unnecessary vertices
Post by: VovKa on March 21, 2022, 03:03:20 PM
Quote from: domenicomaria on March 21, 2022, 12:29:18 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
Title: Re: remove the unnecessary vertices
Post by: domenicomaria on March 22, 2022, 01:23:12 AM
Quote from: VovKa on March 21, 2022, 03:03:20 PM
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
Title: Re: remove the unnecessary vertices
Post by: VovKa on March 22, 2022, 07:53:45 AM
Quote from: domenicomaria on March 22, 2022, 01:23:12 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 :)
Title: Re: remove the unnecessary vertices
Post by: dgpuertas 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))
)
Title: Re: remove the unnecessary vertices
Post by: kdub_nz 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
Title: Re: remove the unnecessary vertices
Post by: kirby on March 23, 2022, 08:13:33 AM
@dgpuertas
Nice code reduction (Almost too streamlined for my brain).
Title: Re: remove the unnecessary vertices
Post by: MatGrebe on March 23, 2022, 09:42:29 AM
Quote from: kirby 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.
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
Title: Re: remove the unnecessary vertices
Post by: kirby 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)
  45.         (cond
  46.                 ((>= Ang 2pi)
  47.                         (setq Ang (- Ang 2pi))
  48.                 )
  49.                 ((< Ang 0.0)
  50.                         (setq Ang (+ Ang 2pi))
  51.                 )
  52.         )
  53.         (if (and (>= Ang 0.0) (< Ang 2pi))
  54.                 (setq K nil)
  55.         )
  56. )
  57. Ang     ; return fixed angle
  58. )
  59.  
Title: Re: remove the unnecessary vertices
Post by: PM 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)
  11.  
  12.   ;; CAB 11/03/07
  13.   ;;  group on the elements of a flat list
  14.   ;;  (group_on '(A B C D E F G) 3)
  15.   ;;  Result  ((A B C) (D E F) (G nil nil)...)
  16.   (defun group_on (inplst gp# / outlst idx subLst)
  17.     (while inplst
  18.       (setq idx -1
  19.             subLst nil
  20.       )
  21.       (while (< (setq idx (1+ idx)) gp#)
  22.         (setq subLst (cons (nth idx inplst) sublst))
  23.       )
  24.       (setq outlst (cons (reverse sublst) outlst))
  25.       (repeat gp#
  26.         (setq inplst (cdr inplst))
  27.       )
  28.     )
  29.     (reverse outlst)
  30.   )
  31.  
  32.  
  35.   (setq ent (car (entsel "\n Select polyline to remove extra vertex: ")))
  36.   (if (and ent
  37.            (setq elst (entget ent))
  38.            (equal (assoc 0 elst) '(0 . "LWPOLYLINE"))
  39.       )
  40.     (progn
  41.       (setq idx 0)
  43.         (cond
  44.           ((null keep)
  45.            (setq keep '(1)
  46.                  dir  (angle '(0 0) (vlax-curve-getFirstDeriv ent 0.0))
  47.            ))
  48.           ((or (null(vlax-curve-getFirstDeriv ent idx))
  49.                (equal dir (setq dir (angle '(0 0)
  50.                              (vlax-curve-getFirstDeriv ent idx))) 0.000001))
  51.            (setq keep (cons 0 keep))
  52.           )
  53.           ((setq keep (cons 1 keep)))
  54.         )
  55.         (setq idx (1+ idx))
  56.       )
  57.       (setq vlst (vl-remove-if-not
  58.                    '(lambda (x) (vl-position (car x) '(40 41 42 10))) elst))
  59.       (setq vlst (group_on vlst 4))
  60.       (setq idx -1
  61.             len (1- (length vlst))
  62.             keep (reverse (cons 1 keep))
  63.       )
  64.       (while (<= (setq idx (1+ idx)) len)
  65.         (cond
  66.           ((not (zerop (cdr(cadddr (nth idx vlst))))) ; keep arcs
  67.            (setq result (cons (nth idx vlst) result))
  68.           )
  69.           ((not (zerop (nth idx keep)))
  70.            (setq result (cons (nth idx vlst) result))
  71.           )
  72.         )
  73.       )
  74.  
  75.       (setq hlst (vl-remove-if
  76.                    '(lambda (x) (vl-position (car x) '(40 41 42 10))) elst))
  77.       (mapcar '(lambda(x) (setq hlst (append hlst x))) (reverse result))
  78.       (setq hlst (subst (cons 90 (length result)) (assoc 90 hlst) hlst))
  79.       (entmod hlst)
  80.     )
  81.   )
  83.  
  84.   (princ)
  85. )
  86. (prompt "\nPline Simplify loaded, PSimple to run.")
  88.  
Title: Re: remove the unnecessary vertices
Post by: domenicomaria on May 20, 2022, 06:14:28 AM
Quote from: Marc'Antonio Alessi on March 21, 2022, 09:55:08 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
Title: Re: remove the unnecessary vertices
Post by: Marc'Antonio Alessi on May 20, 2022, 08:33:02 AM
 :-)
Quote from: domenicomaria on May 20, 2022, 06:14:28 AM
Quote from: Marc'Antonio Alessi on March 21, 2022, 09:55:08 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
:-)