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

0 Members and 1 Guest are viewing this topic.

dgpuertas

  • Newt
  • Posts: 60
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

  • Mesozoic keyThumper
  • SuperMod
  • Swamp Rat
  • Posts: 1438
  • 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

Sometimes the question is more important than the answer.

I don't really work crazy hours . . I just live at UTC + 12.00
#ridesober

kirby

  • Newt
  • Posts: 96
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: 13
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: 96
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

  • Bull Frog
  • Posts: 351
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.