;;; - ------------------------------------------------------------------------------ - ;
;;; -                A C M - V E R T E X R E D U C E                                 - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - Beschreibung : Reduziert -wenn möglich- die Anzahl der Stützpunkte bei den     - ;
;;; -                ausgewählten Polylinien. Die abgefragte Korridorbreite gibt     - ;
;;; -                den maximalen Abstand der neuen Kurve zur alten Kurve an.       - ;
;;; - Befehle      : VREDUCE                                                         - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - letzte Änderung am : 25.03.2023                                                - ;
;;; -              durch : Thomas Krüger                                             - ;
;;; - ------------------------------------------------------------------------------ - ;
(vl-load-com)
;;; - ------------------------------------------------------------------------------ - ;
(defun c:VREDUCE(/ AUSWAHL ABSTAND INDEX DT:VREDUCE DT:UNDOEND DT:UNDOSTART)
  (defun DT:UNDOEND()
    (while(= 8(logand 8 (getvar "undoctl")))
      (vla-endundomark (vla-get-activedocument(vlax-get-acad-object)))
    )      
  )
  (defun DT:UNDOSTART()
    (DT:UNDOEND)
    (vla-startundomark(vla-get-activedocument(vlax-get-acad-object)))
  )
  (defun DT:VREDUCE( VLAOBJ ABSTAND
                   / L CDS PKTS DIST P KL P1 KOORDS LI ARRAY POLY SPACE
                   )  
    (if(and(setq VLAOBJ(cond                                      
                         ((=(type VLAOBJ) 'VLA-object) VLAOBJ)
                         ((=(type VLAOBJ) 'Ename) (vlax-ename->vla-object VLAOBJ))    
                       )
           )
           (member(strcase(vla-get-Objectname VLAOBJ)) 
                   '("ACDB3DPOLYLINE" "ACDBPOLYLINE" "ACDB2DPOLYLINE")
           ) 
           (not(vl-catch-all-error-p
                 (setq L (vl-catch-all-apply
                           'vlax-curve-getDISTAtPARAM
                           (list VLAOBJ (vlax-curve-getEndParam VLAOBJ))
                         )
                 )      
               )
           )
           (or(and(numberp ABSTAND)
                  (> ABSTAND 0)
                  (< (* ABSTAND 4) L)
              )
              (setq ABSTAND (/ L 1000.0))
           )
           (setq CDS(vlax-safearray->list
                      (vlax-variant-value                
                        (vlax-get-property VLAOBJ 'coordinates)
                      )
                    )      
           ) 
           (cond 
             ((=(strcase(vla-get-Objectname VLAOBJ))"ACDBPOLYLINE")        
               (repeat (/(length CDS)2)
                 (setq PKTS(cons(list(car CDS)(cadr CDS)0.0) PKTS))
                 (setq CDS (cddr CDS))
               )
              PKTS
             )
             ((member(strcase(vla-get-Objectname VLAOBJ))
                     '("ACDB3DPOLYLINE" "ACDB2DPOLYLINE")
              ) 
               (repeat (/(length CDS)3)
                 (setq PKTS(cons(list(car CDS)(cadr CDS)(caddr CDS))PKTS))
                 (setq CDS (cdddr CDS))
               )
               PKTS
             )  
           ) 
       )
      (progn      
        (setq KOORDS(cons (vlax-curve-getSTARTPoint VLAOBJ) KOORDS))      
        (setq DIST 0)
        (while (< DIST L)
          (setq P (vlax-curve-getPointatDist VLAOBJ DIST))        
          (setq KL(cons P KL))      
          (setq P1(car(reverse KL)))
          (if (vl-remove-if-not '(lambda(z) (> z ABSTAND))
                (mapcar '(lambda(x / y D12 D13 D23)
                           (setq D12 (distance P1 P))
                           (setq D13 (distance P1 X))
                           (setq D23 (distance P  X))
                           (if (not(zerop D12))
                             (setq y (/(+(* D23 D23)(* D12 D12)(* D13 D13 -1.0))                                                                        
                                       (* 2.0 D12)
                                     )
                             )
                             (setq y 0)
                           )        
                           (sqrt(abs(-(* D23 D23)(* Y Y))))
                         )                           
                         KL
                )
              )
            (progn
               (setq KOORDS(cons (cadr KL)KOORDS))
               (setq KL (list (cadr KL)))
               (setq DIST(- DIST ABSTAND))       
            )
            (setq DIST(+ DIST ABSTAND))  
          )
        )
        (setq KOORDS(cons (vlax-curve-getENDPoint VLAOBJ) KOORDS))
        (if (<(length KOORDS)(length PKTS))
          (progn
            (setq KOORDS
              (mapcar
                '(lambda(x / NEAREST)
                   (setq NEAREST(car(vl-sort
                                      (mapcar'(lambda(y)(list (distance X Y) Y))PKTS)               
                                     '(lambda(E1 E2) (< (car E1)(car E2)))
                                    )  
                                )
                   )
                   (if (< (car NEAREST)ABSTAND)
                     (cadr NEAREST)
                     X
                   )
                 )
                KOORDS
              )
            )
            (cond
              ((=(strcase(vla-get-Objectname VLAOBJ))"ACDBPOLYLINE")
                (foreach K (reverse KOORDS)
                  (setq Li(cons  (cadr K)Li))
                  (setq Li(cons   (car K)Li))
                )              
              )
              ((member(strcase(vla-get-Objectname VLAOBJ))
                      '("ACDB3DPOLYLINE" "ACDB2DPOLYLINE")
               )
                (foreach K (reverse KOORDS)
                  (setq Li(cons (caddr K)Li))
                  (setq Li(cons  (cadr K)Li))
                  (setq Li(cons   (car K)Li))
                )              
              )
            )
            (setq ARRAY
              (vlax-safearray-fill
                (vlax-make-safearray vlax-vbdouble (cons 0 (1- (length Li))))
                Li
              )
            )
            (setq SPACE(if(=(vla-get-activespace
                              (vla-get-activedocument(vlax-get-acad-object))
                            )
                            1
                          )
                          (vla-get-modelspace(vla-get-activedocument(vlax-get-acad-object)))
                          (vla-get-paperspace(vla-get-activedocument(vlax-get-acad-object)))
                       )
            )      
            (if(cond
                 ((=(strcase(vla-get-Objectname VLAOBJ))"ACDBPOLYLINE")
                   (setq POLY (vla-AddLightweightPolyline
                                SPACE                   
                                ARRAY
                             )
                   )
                 )
                 ((=(strcase(vla-get-Objectname VLAOBJ))"ACDB2DPOLYLINE")
                   (setq POLY (vla-AddPolyline
                                SPACE
                                ARRAY
                             )
                   )
                 )
                 ((=(strcase(vla-get-Objectname VLAOBJ))"ACDB3DPOLYLINE")
                   (setq POLY (vla-add3dpoly
                                SPACE
                                ARRAY
                             )
                   )
                 )
               )
              (progn
                (foreach PROP(vl-remove-if '(lambda(X) (= X nil))
                               (mapcar
                                 (function
                                   (lambda (PROPERTY)
                                      (if (not(vl-catch-all-error-p
                                                  (setq PROPS_VALUE(vl-catch-all-apply
                                                                     'vlax-get-property
                                                                     (list VLAOBJ PROPERTY)
                                                                   )
                                                  )
                                              )
                                          )          
                                        (list (strcase(vl-princ-to-string PROPERTY)) PROPS_VALUE)         
                                      )      
                                   )
                                 )
                                '(
                                   Closed    ConstantWidth        Elevation       Layer
                                   Linetype  LinetypeGeneration   LinetypeScale   Lineweight
                                   Normal    PlotStyleName        Thickness       TrueColor
                                   Type      Visible
                                 )
                               )
                             )
                   (if(vlax-property-available-p POLY (car PROP) 'T)       
                     (not(vl-catch-all-error-p
                           (vl-catch-all-apply
                            'vlax-put-property (list POLY (car PROP) (cadr PROP))
                           )
                         )
                     )           
                   )             
                )
                (not(vl-catch-all-error-p   
                       (vl-catch-all-apply
                         'vla-put-Type  (list POLY acSimplePoly)
                       )
                     )
                )
                (not(vl-catch-all-error-p   
                       (vl-catch-all-apply
                         'vla-put-Linetypegeneration (list POLY :vlax-true)
                       )
                     )
                )
                (not(vl-catch-all-error-p
                     (vl-catch-all-apply
                       'vla-delete
                       (list VLAOBJ)
                     )
                  )
                )
              )  
            )
          )  
        )  
      )
    )
  )

  (if(and(or(setq AUSWAHL (ssget "I" '((0 . "*POLYLINE"))))
            (setq AUSWAHL (ssget     '((0 . "*POLYLINE"))))
         )
         (or (initget 6) 'T)
         (if(numberp(setq ABSTAND(vl-bb-ref 'BB-VERTEXREDUCE-ABSTAND)))
           (progn
              (or(setq ABSTAND(getreal (strcat"\nKorridorbreite / max Abweichung <"(rtos ABSTAND 2 3)">:")))
                 (setq ABSTAND (vl-bb-ref 'BB-VERTEXREDUCE-ABSTAND))
              )  
              (vl-bb-set 'BB-VERTEXREDUCE-ABSTAND ABSTAND)
              ABSTAND
           )
           (progn
              (or(setq ABSTAND(getreal "\nKorridorbreite / max Abweichung <0.5>:"))      
                 (setq ABSTAND 0.5)
              )  
              (vl-bb-set 'BB-VERTEXREDUCE-ABSTAND ABSTAND)
              ABSTAND
           )  
         )
     )    
    (progn
      (DT:UNDOSTART)
      (setq INDEX -1)
      (repeat(sslength AUSWAHL)
        (DT:VREDUCE (ssname AUSWAHL(setq INDEX(1+ INDEX))) ABSTAND )
      )
      (DT:UNDOEND)
    )
  )  
)                     
;;; - ------------------------------------------------------------------------------ - ;
(defun ACM-VERTEXREDUCE:INFO() 
  (mapcar
    'princ
    (list
      "\n\n"
      "\nACM-VERTEXREDUCE : Reduzierung von Polylinienstützpunkten"
      "\n================ "
      "\n(C) Thomas Krüger 2023 (tk@cad-od.de)"
      "\nBefehlszeilenaufruf :  VREDUCE\n"
      "\n"    
    )
  )
  (princ)  
)
;;; - ------------------------------------------------------------------------------ - ;
(ACM-VERTEXREDUCE:INFO)
(princ)


