;;; - ------------------------------------------------------------------------------ - ;
;;; -                T O O L -  A C M - 3 D P A R C                                  - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - Beschreibung : 3D-Polylinien optisch "abrunden"                                - ;
;;; - Befehle      : ACM-3DPARC                                                      - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - letzte Änderung am : 20.06.2023                                                - ;
;;; -              durch : Thomas Krüger                                             - ;
;;; - ------------------------------------------------------------------------------ - ;
(vl-load-com)
(defun C:ACM-3DPARC(/ OBJ RADIUS SEGMENTE NR PARAMS POINTS
                      ISP? NORM3PKTS RMAX PLSPKTS GETINPUTS
                      ACM-3DPARC
                    )
  (defun ISP?(P) 
    (if(and(=(type P)'LIST)(vl-every 'numberp P)) 
      (cond
        ((= 2 (vl-list-length P))(list(car P)(cadr P) 0.0))
        ((= 3 (vl-list-length P))P)
      )
    )  
  )
  (defun NORM3PKTS (PKT1 PKT2 PKT3 / NORM)
    (if(and(setq PKT1(ISP? PKT1))(setq PKT2(ISP? PKT2))(setq PKT3(ISP? PKT3)))
      (progn
        (foreach P '(PKT2 PKT3)(set P (mapcar '- (eval P) PKT1)))
        (if (inters PKT1 PKT2 PKT1 PKT3)
          (mapcar '(lambda (X) (/ X (distance '(0 0 0) NORM)))
                  (setq NORM (list (-(*(cadr  PKT2)(caddr PKT3))(*(caddr PKT2)(cadr  PKT3)))
                                   (-(*(caddr PKT2)(car   PKT3))(*(car   PKT2)(caddr PKT3)))
                                   (-(*(car   PKT2)(cadr  PKT3))(*(cadr  PKT2)(car   PKT3)))
                             )
                  )
          )
        )
      )
    )
  )
  (defun RMAX( P0 P1 P2 / NV L1 L2 LMIN V1 V2 SKALAR B1 B2 C W )
     (if(and(setq P0(ISP? P0))(setq P1(ISP? P1))(setq P2(ISP? P2))
            (setq NV(NORM3PKTS P0 P1 P2))
            (setq P0 (trans P0 0 NV))(setq P1 (trans P1 0 NV))(setq P2 (trans P2 0 NV))
            (setq L1(distance P0 P1))(setq L2(distance P0 P2))
            (>(setq LMIN (min L1 L2))0)
            (setq V1 (mapcar '- P0 P1))(setq V2 (mapcar '- P2 P0))
            (setq SKALAR (apply '+ (mapcar '* V1 V2)))
            (/=(setq B1 (distance '(0.0 0.0 0.0) V1))0)
            (/=(setq B2 (distance '(0.0 0.0 0.0) V2))0)
            (setq C(/ SKALAR (float B1)(float B2)))
            (cond
              ((equal C 0 1e-300) (setq W(/ PI 2)))
              ((>=  1 C 0)(setq W(atan(/(sqrt(- 1.0 (* C C)))C))))
              ((<= -1 C 0)(+ PI (setq W(atan(/(sqrt(- 1.0 (* C C)))C)))))
            )
            (if (< SKALAR 0)(setq W(- PI W))W)
        )
       (setq R (abs(*(/(sin(* W 0.5))(cos(* W 0.5)))LMIN)))
     )  
  )
  (defun PLSPKTS(PLOBJ PKT / PARAM)               
    (if(and(or(=(type PLOBJ)'VLA-OBJECT)
              (and(=(type PLOBJ)'ENAME)(setq PLOBJ(vlax-ename->vla-object PLOBJ)))
           )
           (=(strcase(vla-get-Objectname PLOBJ)) "ACDB3DPOLYLINE")
           (setq PKT(ISP? PKT))
           (setq PKT  (vlax-curve-getClosestPointTo PLOBJ PKT))
           (setq PARAM(vlax-curve-getparamAtPoint   PLOBJ PKT))
       )                      
      (list (vlax-curve-getPointAtParam PLOBJ (fix PARAM))
	    (vlax-curve-getPointAtParam PLOBJ (1+ (fix PARAM)))
      )
    )
  )
  (defun GETINPUTS( / RADIUS TEMPRADIUS SEMENTE TEMPSEG SEG1 SEG2 
                      SEG1POINTS SEG2POINTS OBJ OK? P0 P1 P2)
    (or(and(setq RADIUS (vl-bb-ref 'ACM3DPARC-R))(numberp RADIUS))
       (setq RADIUS 5.0)
    )
    (or(and(setq SEGMENTE (vl-bb-ref 'ACM3DPARC-SEGS))(=(type SEGMENTE)'INT))
       (setq SEGMENTE 20)
    )
    (prompt (strcat "\nACM-3DPARC: Aktueller Radius: " (rtos RADIUS) "| Ersatzsegmente : "(itoa SEGMENTE)))
    (while (not OK?)
      (initget 1 "Radius Segmente")
      (setq SEG1(entsel "\nErstes Objekt oder [Radius / Segmente] :"))
      (cond
        ((= SEG1 "Radius")
         (setq TEMPRADIUS nil)
          (while (or(not(numberp TEMPRADIUS))(<= TEMPRADIUS 0))
            (initget 4)
            (or(setq TEMPRADIUS(getdist(strcat "\nBogenraius <"(rtos RADIUS)">: ")))
               (setq TEMPRADIUS RADIUS)
            )
          )
          (setq RADIUS TEMPRADIUS)
        )
        ((= SEG1 "Segmente")
          (setq TEMPSEG nil)
          (while (or(/=(type TEMPSEG)'INT)(< TEMPSEG 3))
            (initget 6)
            (or(setq TEMPSEG(getint(strcat "\nSegemente je Bogen <"(itoa SEGMENTE)">: ")))
               (setq TEMPSEG SEGMENTE)
            )
          )
          (setq SEGMENTE TEMPSEG)
        )
        ((and(=(type(car SEG1))'ENAME)(setq OBJ(vlax-ename->vla-object (car SEG1)))
             (setq SEG1POINTS(PLSPKTS OBJ (trans(osnap(cadr SEG1)"_nea")1 0)))
         )
          (setq OK? 'T)
        )
        ('T (prompt "\nKeine 3d-Polylinie gewählt .."))
      )
    )
    (vl-bb-set 'ACM3DPARC-R RADIUS)(vl-bb-set 'ACM3DPARC-SEGS SEGMENTE)
    (while (not SEG2)
      (initget 1 "Alle")
      (setq SEG2 (entsel "\nZweites Segment oder [Alle]: "))
      (if(not(or(= SEG2 "Alle")
                (and(or(=(type(car SEG2))'ENAME)(prompt "\nNichts gewählt.."))
                    (or(eq(car SEG1)(car SEG2))
                       (prompt "\nDas gewählte Objekt ist nicht die ursprünglich gewählte 3d-Polylinie!")
                    )
                    (setq SEG2POINTS(PLSPKTS OBJ (trans(osnap(cadr SEG2)"_nea")1 0)))
                    (or(not(equal SEG1POINTS SEG2POINTS))
                       (prompt "\nGleiches Segment gewählt!")
                    )
                    (setq P0(cond
                              ((equal(distance (car  SEG1POINTS)(car  SEG2POINTS)) 0 1e-9)(car  SEG1POINTS))
                              ((equal(distance (cadr SEG1POINTS)(car  SEG2POINTS)) 0 1e-9)(cadr SEG1POINTS))
                              ((equal(distance (cadr SEG1POINTS)(cadr SEG2POINTS)) 0 1e-9)(cadr SEG1POINTS))
                              ((equal(distance (car  SEG1POINTS)(cadr SEG2POINTS)) 0 1e-9)(car  SEG1POINTS))
                              ('T(prompt "\nKein anschließendes Segment gewählt!"))
                            )
                    )
                    (or(setq P0(inters(car  SEG1POINTS)(cadr  SEG1POINTS)(car  SEG2POINTS)(cadr  SEG2POINTS)nil))
                       (prompt "\nSegmente fluchten, keine Abrundung möglich!")
                    )
                    (setq PARAM(vlax-curve-getparamAtPoint OBJ (vlax-curve-getClosestPointTo OBJ P0)))
                    (if(or(equal PARAM (vlax-curve-getendParam OBJ)  1e-99)
                          (equal PARAM (vlax-curve-getStartParam OBJ)1e-99)
                       )
                      (progn
                        (setq P0 (vlax-curve-getPointAtParam OBJ    (vlax-curve-getStartParam OBJ) ))
                        (setq P1 (vlax-curve-getPointAtParam OBJ (1+(vlax-curve-getStartParam OBJ))))
                        (setq P2 (vlax-curve-getPointAtParam OBJ (1-(vlax-curve-getendParam   OBJ))))     
                      )
                      (progn
                        (setq P0 (vlax-curve-getPointAtParam OBJ     PARAM ))
                        (setq P1 (vlax-curve-getPointAtParam OBJ (1+ PARAM)))
                        (setq P2 (vlax-curve-getPointAtParam OBJ (1- PARAM)))
                      )
                    )
                    (setq NORMALE(NORM3PKTS P0 P1 P2))
                    (or(<= RADIUS(RMAX (trans P0 0 NORMALE)(trans P1 0 NORMALE)(trans P2 0 NORMALE)))
                       (prompt "\nRadius für gewählte Segmente zu groß, keine Abrundung möglich!")
                    )
                )
             )
         )
        (setq SEG2 nil)
      )
    )
    (if(= SEG2 "Alle")
      (list OBJ RADIUS SEGMENTE "ALLE")
      (list OBJ RADIUS SEGMENTE PARAM)
    )
  )
  (defun ACM-3DPARC( OBJ PKT RADIUS SEGMENTE ALLSEGS?
                   / ERR P0 P1 P2 P3 P4 W SPKT RM NORMALE MP COORDS POINTS PLIST PARAM
                     GETSL GETKS
                   )
    (defun GETKS(OBJ / COORDS POINTS)
      (setq COORDS(vlax-safearray->list
                    (vlax-variant-value(vla-get-coordinates OBJ))
                  )
      )
      (repeat (/(length COORDS)3)
             (setq POINTS(cons
                           (list(car COORDS)(cadr COORDS)(caddr COORDS))
                           POINTS
                         )
             )
             (setq COORDS (cdddr COORDS))
      )
      (reverse POINTS)
    )
    (defun GETSL(LST START ANZ / RETURN)
      (if(and(or(and(=(type START)'INT)(>= START 0))(setq START 0))
             (or(< START (1-(length LST)))(setq START(1-(length LST))))
             (or(and(=(type ANZ)'INT)(>= ANZ 0))(setq ANZ (length LST)))
             (or(<=(+ START ANZ)(1-(length LST)))(setq ANZ(-(length LST) START )))
         )
        (progn
          (repeat START(setq LST(cdr LST)))
          (repeat ANZ (setq RETURN(cons (car LST)RETURN))(setq LST(cdr LST)))
          (reverse RETURN)
        )
      )
    )
    (if(and(or(=(type OBJ)'VLA-OBJECT)
              (and(=(type OBJ)'ENAME)(setq OBJ(vlax-ename->vla-object OBJ)))
           )
           (=(strcase(vla-get-Objectname OBJ)) "ACDB3DPOLYLINE")
           (setq PKT(ISP? PKT))
           (setq PARAM(vlax-curve-getparamAtPoint OBJ (vlax-curve-getClosestPointTo OBJ PKT)))
           (setq POINTS(GETKS OBJ))  
           (numberp PARAM)(<=(vlax-curve-getstartparam OBJ)PARAM(vlax-curve-getendparam OBJ))
           (numberp RADIUS)(> RADIUS 0)(=(type SEGMENTE)'INT)(> SEGMENTE 3)
           (if(or(equal PARAM (vlax-curve-getendParam OBJ)  1e-99)
                 (equal PARAM (vlax-curve-getStartParam OBJ)1e-99)
              )
             (progn
               (setq P0 (vlax-curve-getPointAtParam OBJ   (vlax-curve-getStartParam OBJ)                      ))
               (setq P1 (vlax-curve-getPointAtParam OBJ (-(vlax-curve-getendParam   OBJ)(if ALLSEGS? 1.0 1.0))))
               (setq P2 (vlax-curve-getPointAtParam OBJ (+(vlax-curve-getstartParam OBJ)(if ALLSEGS? 1.0 1.0))))     
             )
             (progn
               (setq P0 (vlax-curve-getPointAtParam OBJ      PARAM                      ))
               (setq P1 (vlax-curve-getPointAtParam OBJ   (- PARAM(if ALLSEGS? 1.0 1.0))))
               (setq P2 (vlax-curve-getPointAtParam OBJ   (+ PARAM(if ALLSEGS? 1.0 1.0))))
             )
           )
           (or(setq SPKT(inters P1 P0 P0 P2 nil))(not(setq ERR "Fluchtende Segmente")))
           (setq NORMALE(NORM3PKTS P0 P1 P2))
           (setq P0(trans P0 0 NORMALE))
           (setq P1(trans P1 0 NORMALE))
           (setq P2(trans P2 0 NORMALE))
           (or(>=(RMAX P0 P1 P2) RADIUS)(not(setq ERR "Radius zu groß")))
           (setq MP(inters
                      (polar P0(+(angle P0 P1)(/ pi 2)) RADIUS)
                      (polar P1(+(angle P0 P1)(/ pi 2)) RADIUS)
                      (polar P0(-(angle P0 P2)(/ pi 2)) RADIUS)
                      (polar P2(-(angle P0 P2)(/ pi 2)) RADIUS)
                      nil
                   )
           )
           (setq P3(polar MP(+ (angle P1 P0) (/ pi 2)) RADIUS))
           (setq P4(polar MP(- (angle P2 P0) (/ pi 2)) RADIUS))
           (setq W (-(angle MP P4)(angle MP P3)))
           (if(>(abs W)3.141592654)(setq W(- W(* 6.283185307 (if(< W 0) -1.0 1.0))))W)
       )
      (progn
         (setq DELTA (/ W SEGMENTE))
         (setq N -1)
         (repeat (1+ SEGMENTE)
           (setq PLIST(cons(polar MP(+(angle MP P3)(* DELTA(setq N(1+ N)))) RADIUS) PLIST))
          )
         (if(setq PLIST (mapcar'(lambda(X) (trans X NORMALE 0)) (reverse PLIST)))
           (cond
              ((and(equal PARAM (vlax-curve-getStartParam  OBJ )1e-99)(=(vla-get-closed OBJ) :vlax-true))
                (setq POINTS (append PLIST (GETSL POINTS 1 (-(length POINTS)1))))
              )
              ((and(equal PARAM (vlax-curve-getendParam  OBJ )1e-99)(=(vla-get-closed OBJ) :vlax-true))
                (setq POINTS (append PLIST (GETSL POINTS 1 (-(length POINTS)1))))
              )
              ((and(equal PARAM (1-(vlax-curve-getendParam  OBJ ))1e-99)(=(vla-get-closed OBJ) :vlax-true))
                (setq POINTS (append PLIST (GETSL POINTS 0 (-(length POINTS)1))))
              )
              ('T
                (setq POINTS (append(GETSL POINTS 0 (fix PARAM))
                                    PLIST
                                    (GETSL POINTS (+(fix PARAM)1)nil)
                             )
                )
              )
           )
         )
         (setq POINTS(apply 'append POINTS))
         (not(vl-catch-all-error-p
               (vl-catch-all-apply
                 'vla-put-coordinates
                 (list OBJ
                       (vlax-safearray-fill
                         (vlax-make-safearray
                           vlax-vbdouble
                           (cons 0 (1- (length POINTS)))
                         )
                         POINTS
                       )
                 )
               )
             )
         )
      )
    )
  )

  (if(setq INPUTS(GETINPUTS))
    (progn
      (vla-endundomark  (vla-get-activedocument(vlax-get-acad-object)))
      (vla-startundomark(vla-get-activedocument(vlax-get-acad-object)))
      (setq OBJ (car INPUTS) RADIUS (cadr INPUTS) SEGMENTE (caddr INPUTS))
      (if(=(cadddr INPUTS)"ALLE")
        (progn
          (setq NR 0)
          (repeat(-(fix(vlax-curve-getendparam OBJ))(fix(vlax-curve-getstartparam OBJ))1)
            (setq PARAMS (cons (setq NR (1+ NR)) PARAMS))
          )
          (if(=(vla-get-closed OBJ):vlax-true)
            (setq PARAMS (cons(fix(vlax-curve-getendparam OBJ))PARAMS))
          )
          (setq POINTS(mapcar'(lambda(X)(vlax-curve-getPointAtParam OBJ X))(reverse PARAMS)))
          (mapcar
            '(lambda(X)(ACM-3DPARC OBJ X RADIUS SEGMENTE 'T))
            POINTS
          )
        )
        (ACM-3DPARC OBJ (vlax-curve-getPointAtParam OBJ(cadddr INPUTS)) RADIUS SEGMENTE nil)
      )
      (vla-endundomark  (vla-get-activedocument(vlax-get-acad-object)))
    )
  )
)
;;; - ------------------------------------------------------------------------------- - ;
(defun ACM-3DPARCT:INFO() 
  (mapcar
    'princ
    (list
      "\n\n"
      "\nACM-3DPARC  : 3D-Polylinien optisch \"abrunden\""
      "\n============== "
      "\n(C) Thomas Krüger 2023 (tk@cad-od.de)"
      "\nBefehlszeilenaufrufe : ACM-3DPARC\n"
      "\n"    
    )
  )
  (princ)  
)
;;; - ------------------------------------------------------------------------------ - ;
(ACM-3DPARCT:INFO)
(princ)
