;;; - ------------------------------------------------------------------------------ - ;
;;; -                      A C M - A B R O L L K U R V E N                           - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - Beschreibung : Zeichnen von Zykloiden                                          - ;
;;; - Befehle      : SPIRO ... Abrollkurven auf einem Kreis                          - ;
;;; -                ZYKLO ... Abrollkurven auf beliebigen Leitkurven                - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - letzte Änderung am : 23.05.2024                                                - ;
;;; -              durch : Thomas Krüger                                             - ;
;;; - ------------------------------------------------------------------------------ - ;
(vl-load-com)
;;; - ------------------------------------------------------------------------------ - ;
(defun DT:LWPL-MAKE ( KOORDS COLOR /  PL-ARRAY PL-OBJ SPACE POINTS)
  (or(and(=(type COLOR)'INT)(<= 0 COLOR 255))(setq COLOR 2))
  (if(and(=(type KOORDS)'LIST)
         (not(vl-remove-if
               '(lambda(x) (and(=(type X)'LIST)
                               (=(length X)3)
                               (not(vl-remove-if'(lambda(y)(numberp y))X))
                           )
                )
                KOORDS
              )
         )
         (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)))
                    )
         )
         (foreach K (reverse KOORDS)
           (setq POINTS(cons  (cadr K)POINTS))
           (setq POINTS(cons   (car K)POINTS))             
         )
         (setq POINTS
           (vlax-safearray-fill
             (vlax-make-safearray vlax-vbdouble (cons 0 (1- (length POINTS))))
             POINTS
           )
         )
         (setq PL-OBJ (vla-AddLightweightPolyline SPACE POINTS))
         (vla-put-Color PL-OBJ COLOR)
     )
    PL-OBJ                          
  )
)
(defun DT:LWPL-ADDENDVERTEX ( PL-OBJ POINT /  PL-ARRAY PL-OBJ SPACE POINTS)
  (if(and(setq PL-OBJ(cond                                        
                       ((=(type PL-OBJ) 'VLA-object) PL-OBJ)
                       ((=(type PL-OBJ) 'Ename) (vlax-ename->vla-object PL-OBJ))    
                     )
         )
         (=(type POINT)'LIST)(=(length POINT)3)(vl-every 'numberp POINT)
         (not(vl-catch-all-error-p                                     
               (vl-catch-all-apply
                 'vla-addvertex
                 (list
                   PL-OBJ
                   (1+(fix(vlax-curve-getendparam PL-OBJ)))
                   (vlax-safearray-fill
                     (vlax-make-safearray vlax-vbDouble '(0 . 1))
                     (list (car POINT) (cadr POINT))
                   )
                 )
               )
             )
         )
         (or(vla-update PL-OBJ)'T)
     )
    PL-OBJ                          
  )
)

(defun ANIMATE (PLIST R WAITTICKS / KREIS KOPPEL LWPL P POINTS ENDE index SH)
  (setq SH(1+(fix(/(length PLIST)300))))
  (if(and(setq KREIS(entmakex
                      (list
                        '(0 . "CIRCLE")
                        '(100 . "AcDbEntity")
                        '(67 . 0)
                         (cons 410 (getvar "CTAB"))
                        '(8 . "0")
                        '(62 . 3)
                        '(100 . "AcDbCircle")
                         (cons 10 (car (cadr PLIST))) 
                         (cons 40 R)
                        '(210 0.0 0.0 1.0)
                      )
                    )
         )
         (setq KREIS (vlax-ename->vla-object  KREIS))
     )
    (progn        
      (if(and(setq KOPPEL(entmakex
                           (list
                            '(0 . "LINE")
                            '(100 . "AcDbEntity")
                            '(67 . 0)
                             (cons 410 (getvar "CTAB"))
                            '(8 . "0")
                            '(62 . 1)
                            '(100 . "AcDbLine")
                             (cons 10 (car  (cadr PLIST)))
                             (cons 11 (cadr (cadr PLIST)))
                            '(210 0.0 0.0 1.0)
                           )
                     )
             )
             (setq KOPPEL(vlax-ename->vla-object KOPPEL))
         )
        (progn
          (if(and(setq LWPL(entmakex
                             (list
                               '(0 . "LWPOLYLINE")
                               '(100 . "AcDbEntity")
                               '(67 . 0)  
                                (cons 410 (getvar "CTAB")) 
                                (cons 8  "0")
                                (cons 62  2)
                               '(100 . "AcDbPolyline")
                                (cons 90 2)
                               '(70 . 0)
                               '(43 . 0.0)
                               '(38 . 0.0)
                               '(39 . 0.0)
                                (cons 10 (cadr (car PLIST))) '(40 . 0.0)'(41 . 0.0)'(42 . 0.0)
                                (cons 10 (cadr (car PLIST))) '(40 . 0.0)'(41 . 0.0)'(42 . 0.0)
                               '(210 0.0 0.0 1.0)
                              )   
                            )      
                 )
                 (setq LWPL(vlax-ename->vla-object   LWPL))
             )
            (progn
               (setq INDEX 1)
               (repeat (length PLIST)
                 (if (car PLIST)
                   (progn
                     (setq POINTS(cons (car PLIST)POINTS))
                     (vla-addvertex LWPL
                       (setq INDEX (1+ INDEX))
                       (vlax-safearray-fill
                         (vlax-make-safearray vlax-vbDouble '(0 . 1))
                         (list(car(cadr(car PLIST))) (cadr(cadr(car PLIST))))
                       )
                     )
                     (if(=(/ INDEX (float SH))(fix(/ INDEX (float SH))));nicht jedes Mal animieren
                       (progn
                        (setq ENDE (+(getvar "MILLISECS")WAITTICKS))
                        (vla-put-center KREIS (vlax-3d-point (car(car PLIST))))
                        (vla-put-startpoint KOPPEL (vlax-3d-point (car (car PLIST))))
                        (vla-put-endpoint   KOPPEL (vlax-3d-point (cadr(car PLIST))))
                        (vla-update KREIS)(vla-update KOPPEL)(vla-update LWPL)
                        (While(<(getvar "MILLISECS")ENDE))
                       )
                     )
                     (setq PLIST(cdr PLIST))
                   )
                 )
               )      
            )        
          )
          (vla-delete KOPPEL)
        )  
      )
      (vla-delete KREIS)
    )   
  )
)
(defun C:ZYKLO(/ OBJ CIRCLERADIUS POINTDISTANCE STARTANG PRECISIONFACTOR PLIST
                 ANIMATE? WAITSECS
                 DT:GET-ZPOINTS
              )
  (defun DT:GET-ZPOINTS( CURVOBJ CIRCLERADIUS POINTDISTANCE STARTANG PRECISIONFACTOR
                       / ERRORMSG L DELTAW DELTAS COUNT DIST P1 P2 P3 LLOT PLIST
                       )   
    (if(and(or(and(setq CURVOBJ(cond
                                 ((=(type CURVOBJ) 'VLA-object) CURVOBJ)
                                 ((=(type CURVOBJ) 'ENAME) (vlax-ename->vla-object CURVOBJ))    
                               )
                  )
                  (not(vl-catch-all-error-p
                        (setq START(vl-catch-all-apply
                                     'vlax-curve-getStartPoint
                                     (list CURVOBJ)
                                   )
                        )
                      )
                  )
              )
              (not(setq ERRORMSG "Kein Kurvenobjekt!"))
           )
           (or(vlax-curve-isPlanar CURVOBJ)(not(setq ERRORMSG "Kurve ist nicht planar!")))
           (or(and(not(vl-catch-all-error-p
                        (setq L(vl-catch-all-apply
                                'vlax-curve-getDISTAtPARAM
                                 (list CURVOBJ (vlax-curve-getEndParam CURVOBJ))
                               )
                        )
                      )  
                  )
                  (numberp L)
                  (> L 0)
              )
              (not(setq ERRORMSG "Kurvelänge nicht ermittelbar"))
           )   
           (or(vl-every
                  '(lambda(x) (equal(caddr(vlax-curve-getPointAtDist CURVOBJ (* X L)))0.0))
                  '(0.0641 0.1345 0.27654 0.4312 0.6932 0.7917 0.9341)               
              )
              (not(setq ERRORMSG "Kurve liegt nicht in der WKS-XY-Ebene."))
           )
           (or(and(numberp CIRCLERADIUS)
                  (not(equal CIRCLERADIUS 0.0 0.000000001))
              )
              (not(setq ERRORMSG "Ungültiger Abrollkreisradius."))
           )
           (or(numberp POINTDISTANCE)            
              (not(setq ERRORMSG "Ungültiger Koppelpunktabstand.Wird auf Abrollkreisradius gesetzt."))
              (setq POINTDISTANCE CIRCLERADIUS)
           )
           (or(numberp STARTANG)            
              (not(setq ERRORMSG "Ungültiger Koppelpunktstartwinkel.Wird auf 0 gesetzt."))
              (setq STARTANG 0.0)            
           )
           (or(and(numberp PRECISIONFACTOR)
                  (<= 10 PRECISIONFACTOR 360)
              )                          
              (setq PRECISIONFACTOR  180)
           )  
           (setq DELTAW(/(* 2 PI)PRECISIONFACTOR))
           (setq DELTAS(abs(* CIRCLERADIUS DELTAW)))
           (or (< (* 10 DELTAS) L)
               (not(setq ERRORMSG (strcat "Ungünstiges Verhältnis zwischen Abrollkreisradius"
                                          "Leitkurvenlänge und Genauigkeit"
                                  )
                   )
               )    
           )    
       )
      (progn      
        (setq COUNT(1+(fix(/ L DELTAS 1.0))))
        (setq DIST 0)      
        (setq ANG STARTANG)        
        (repeat COUNT        
          (setq PARAM(vlax-curve-getParamAtDist CURVOBJ DIST))
          (setq P1   (vlax-curve-getPointAtParam  CURVOBJ PARAM))
          (setq P2   (vlax-curve-getFirstDeriv CURVOBJ PARAM))            
          (setq LLOT (/ (distance P2 '(0 0 0))CIRCLERADIUS))            
          (setq P2 (mapcar '/ P2 (list LLOT LLOT LLOT)))        
          (setq P2 (mapcar '+ P1 (list (cadr  P2) (- 0 (car P2)) 0)))
          (if PLIST
              (setq ANG(+ ANG  DELTAW (*(-(angle P1 P2)(angle (car(car PLIST))(cadr(car PLIST))))
                                        (if(< CIRCLERADIUS 0)-1.0 1.0)
                                      )
                       )
              )            
          )
          (setq P3 (mapcar '+ P2 (list
                                   (*(cos(* ANG(if(< CIRCLERADIUS 0)-1.0 1.0)))POINTDISTANCE) 
                                   (*(sin(* ANG(if(< CIRCLERADIUS 0)-1.0 1.0)))POINTDISTANCE)
                                   0.0
                                 )
                   )
          )
          (setq PLIST(cons (list P1 P2 P3) PLIST))        
          (setq DIST (+ DIST DELTAS))                                
        )
        (reverse (mapcar 'cdr PLIST))
      )
      ERRORMSG
    )  
  )
  (if(setq OBJ(car(entsel"\nLeitkurve (Linie,Polylinien,Kreis,Spline usw.) wählen: ")))
    (progn     
      (or(setq CIRCLERADIUS (getreal "\nAbrollkreisradius <20>:"))
         (setq CIRCLERADIUS 20)
      )
      (or(setq POINTDISTANCE(getreal "\nAbstand Abrollkreismittelpunkt-Koppelpunkt <30>:"))
         (setq POINTDISTANCE 30)
      )
      (or(setq STARTANG(getreal "\nStartWinkel der Koppel in Grad <0>:"))
         (setq STARTANG 0)
      )
      (setq STARTANG (* STARTANG 0.017453292))
      (or(setq PRECISIONFACTOR(getint "\nGewünschte Genauigkeit(Punkte je Abrollkreisumdrehung) <60>:"))
         (setq PRECISIONFACTOR 60)
      )
      (initget "Ja Nein")
      (if(setq ANIMATE?(/=(getkword "Zykloidenerzeugung animieren? [JA / Nein]<Ja>: ")"Nein"))
        (or(setq WAITSECS(getint "Verzögerung in MilleSecs <100>: "))
           (setq WAITSECS 100)
        )   
      )  
      (setq PLIST(DT:GET-ZPOINTS OBJ CIRCLERADIUS POINTDISTANCE STARTANG PRECISIONFACTOR))                                
      (cond
        ((=(type PLIST)'LIST)
          (if ANIMATE?
            (ANIMATE(mapcar
                      '(lambda(X)(list (trans (car X) 0 1)(trans (cadr X) 0 1)))
                       PLIST
                    )  
                    (abs CIRCLERADIUS)
                    WAITSECS
            )
            (DT:LWPL-MAKE(mapcar'(lambda(X)(trans (cadr X) 0 1))PLIST) 2)
          )  
        )
        ((=(type PLIST)'STR)(prompt (strcat"\n" PLIST))) 
        ('T(prompt "\nFehler beim Erzeugen der Zykloidenpunktliste."))
      )  
    )  
    (prompt "\nKein Objekt gewählt.Abbruch.")
  )
)
(defun C:SPIRO(/ R1 R2 LP MP MAXANZ PRECISIONFACTOR  ANIMATE? WAITSECS
                 PLIST CIRCLE
                 DT:GET-SPOINTS
              )
  (defun DT:GET-SPOINTS( R1 R2 LP MP MAXANZ PRECISIONFACTOR
                       / ANZ DELTAW ANG P2 P3 ERRORMSG PLIST
                         DT:GGT DT:KGV DT:ROUND2 GET-ANZ
                       )
    (defun DT:GGT (A B / GGTINTERN)
      (defun GGTINTERN ( A B )
        (cond ((< A 1) B)
              ((< B 1) A)
              ('T (GGTINTERN (rem B A) A))
        )
      )  
      (if(and(=(type A)'INT)(=(type B)'INT))
        (progn
          (setq A (abs A))(setq B (abs B))
          (if(or(zerop A)(zerop B))1(GGTINTERN  A B ))
        )  
      )  
    )
    (defun DT:KGV(A B)
      (if(and(=(type A)'INT)(=(type B)'INT)) (/(abs(* A B 1.0)) (DT:GGT A B)))         
    )
    (defun DT:ROUND2 (ZAHL BASIS / TEMP )
      (if (and(numberp ZAHL) (=(numberp BASIS))(> BASIS 0))
        (progn      
          (setq TEMP (/ (abs ZAHL)  BASIS))
          (cond  
            ( (> (- TEMP (fix TEMP)) 0.5) (setq TEMP (+ (fix TEMP) 1)))
            ( (< (- TEMP (fix TEMP)) 0.5) (setq TEMP    (fix TEMP)  ))
            ( (= (- TEMP (fix TEMP)) 0.5)          
              (if (equal (/ (fix TEMP) 2.0) (fix(/ (fix TEMP) 2.0)) 0.001)
                (setq TEMP    (fix TEMP)  )
                (setq TEMP (+ (fix TEMP) 1))
              )  
            )
          )      
          (setq TEMP (* BASIS TEMP (if (< Zahl 0 ) -1.0 1.0)))
        )
      )
      (if (=(type BASIS)'INT) (fix TEMP) TEMP)    
    )
    (defun GET-ANZ(R1 R2 / FUZZY KGV)
      (setq FUZZY 1000)
      (if(and(setq R1 (fix(*(DT:ROUND2 R1(/ 1.0 FUZZY))FUZZY)))
             (setq R2 (fix(*(DT:ROUND2 R2(/ 1.0 FUZZY))FUZZY)))
             (setq KGV(DT:KGV R1 R2))
         )
        (DT:ROUND2(/ KGV R1 1.0)1)
      )  
    )
    (if(and(or(and(numberp R1)(< 0 R1))
              (prompt "\nUngültiger Leitkreisradius.")
           )
           (or(and(numberp R2)(not(equal R2 0.0 0.000000001)))
              (prompt "\nUngültiger Abrollkreisradius.")                        
           )
           (or(not(equal R2 R1 0.000000001))
              (setq R2 (* R2 -1.0))          ;_bei gleichgroßen Kreisen, außen abrollen!
           )   
           (or(numberp LP)
              (prompt "\nUngültiger Koppelpunktabstand.Wird auf Abrollkreisradius gesetzt.")
              (setq L R2)
           )
           (or(<(abs R1)(* 50.0 (abs R2)))
              (prompt "\nUngünstiges Radienverhältnis. R2 wird auf R1/50 gesetzt.")
              (setq R2 (/ R1 1.0 50))
           )     
           (or(<(abs R2)(* 10.0 (abs R1)))
              (prompt "\nUngünstiges Radienverhältnis. R1 wird auf R2/10 gesetzt.")
              (setq R1 (/ R2 1.0 10))
           )
           (or(and(=(type MP)'LIST)
                  (=(vl-list-length MP)3)
                  (vl-every 'numberp MP)
                  (setq MP(list (car MP)(cadr MP) 0))
              )
              (prompt "\Ungültiger Leitkreismittelpunkt.Wird auf (0 0 0) gesetzt.")
              (setq MP '(0 0 0))
           )
       )
      (progn      
        (setq ANZ(GET-ANZ R1(abs R2)))
        (if(and(numberp MAXANZ)(< MAXANZ  ANZ ))(setq ANZ MAXANZ))      
        (setq DELTAW (/(* 2 PI)PRECISIONFACTOR))      
        (setq ANG 0)     
        (repeat (1+(DT:ROUND2 (* PRECISIONFACTOR ANZ (/ R1 (abs R2) 1.0))1))
          (setq P2 (mapcar '+ MP (list
                                   (*(cos (*(/ R2 R1 1.0)ANG))(- R1 R2))
                                   (*(sin (*(/ R2 R1 1.0)ANG))(- R1 R2))
                                   0.0
                                 )
                   )
          )
          (setq P3 (mapcar '+ P2 (list
                                   (*(cos (*(1-(/ R2 R1 1.0))ANG))LP)
                                   (*(sin (*(1-(/ R2 R1 1.0))ANG))LP)
                                   0.0
                                 )
                   )
          )
          (setq PLIST(cons (list P2 P3) PLIST))
          (setq ANG (+ ANG DELTAW))                               
        )
        (reverse PLIST)
      )  
    )
  )
  (or(setq MP(getpoint "\nLeitkreismittelpunkt <(0 0 0)>: "))
     (setq MP '(0 0 0))
  )  
  (or(setq R1 (getdist MP "\nLeitkreisradius <100> : "))
     (setq R1 100)
  )    
  (or(setq R2 (getreal "\nAbrollkreisradius <35>: "))
     (setq R2 35)
  )              
  (or(setq LP(getreal "\nAbstand Abrollkreismittelpunkt-Koppelpunkt <30>:"))
     (setq LP 30)
  )
  (or(setq MAXANZ(getint "\nMaximale Umfahrungen des Leitkreises bei nicht geschlossenen Kurven <20>:"))
     (setq MAXANZ 20)
  )      
  (or(setq PRECISIONFACTOR(getint "\nGewünschte Genauigkeit(Punkte je Abrollkreisumdrehung) <60>:"))
     (setq PRECISIONFACTOR 60)
  )
  (initget "Ja Nein")
  (if(setq ANIMATE?(/=(getkword "Zykloidenerzeugung animieren? [JA / Nein]<Ja>: ")"Nein"))
    (or(setq WAITSECS(getint "Verzögerung in MilleSecs <100>: "))
       (setq WAITSECS 100)
    )   
  )  
  (if(setq PLIST(DT:GET-SPOINTS R1 R2 LP MP MAXANZ PRECISIONFACTOR))
    (if ANIMATE?
       (progn
         (if(entmake              
              (list '(0 . "CIRCLE")
                    '(100 . "AcDbEntity")
                    '(67 . 0)
                     (cons 410 (getvar "CTAB"))
                    '(8 . "0")
                    '(62 . 7)
                    '(100 . "AcDbCircle")
                    (cons 10 MP) 
                    (cons 40 R1)
                    '(210 0.0 0.0 1.0)
              )
            )
           (setq CIRCLE(entlast))
         )  
         (ANIMATE PLIST (abs R2) WAITSECS)
         (if CIRCLE(entdel CIRCLE))  
       )
       (DT:LWPL-MAKE(mapcar 'cadr PLIST) 2)
    )  
    (prompt "\nFehler beim Erzeugen der Zykloidenpunktliste.")
  )  
)  
;;; - ------------------------------------------------------------------------------- - ;
(defun ACM-ABROLLURVEN:INFO() 
  (mapcar
    'princ
    (list
      "\n\n"
      "\nACM-ABROLLURVEN  : Zeichnen von Zykloiden"
      "\n================== "
      "\n(C) Thomas Krüger 2024 (tk@cad-od.de)"
      "\nBefehlszeilenaufrufe : SPIRO  und ZYKLO\n"
      "\n"    
    )
  )
  (princ)  
)
;;; - ------------------------------------------------------------------------------- - ;
(ACM-ABROLLURVEN:INFO)
(princ)
