;;**************************************************************************

;;**************************************************************************
(in-package :lpo_vdaps)  ;;; All variables and functions have to belong to 
                         ;;; the package 'lpo_vdaps' 
;;**************************************************************************
;;* 
;;* This function defines the type and the subtype of the created geometry.
;;* The behaviour of the user interface depends on the type and subtype.
;;* 
;;* Following types and subtypes are supported:
;;* 
;;* Type             Subtype      Description
;;* --------------------------------------------------------
;;* VDAPS_PART       REAL         Body  
;;* VDAPS_HOLE       REAL         Machined features (Material removed)
;;* VDAPS_FORM_ADD   REAL         Machined features (Material added)
;;*
;;**************************************************************************
(defun GD00032_control ( mode ) 
  (when (oli::sd-string= "INIT" mode) 
    (lpo_vdaps::api_set_geometry_type "VDAPS_PART" "REAL")
  );;when
);;defun

;;**************************************************************************
;;*
;;* Completepart            : GD00032
;;* Geometry                : Ettinger Abstandsbolzen Innen - Innen
;;* Parameter               : (gepa_list) =
;;*                           Created with GD-00032.TAB line
;;* 
;;* GE,PA,GD00031,G1,G2,SW,L1,A1,A2,MA,F1
;;* C
;;* ZA,MM,9
;;* MM,SM, 1, 10, 1, 1, G1	, 'Gewinde Innen  G1'    		, 'g1',     , T
;;* MM,SM, 1, 20, 1, 1, G2	, 'Gewinde Innen  G2'  	   	, 'g2',     , T
;;* MM,SM, 1, 30, 1, 1, SW	, 'Schlüsselweite SW'  	  	, 'sw', 'mm', Z
;;* MM,SM, 1, 40, 1, 1, L1	, 'Länge L'  								, 'l1', 'mm', Z
;;* MM,SM, 1, 50, 1, 1, A1	, 'Länge Gewinde Innen  A1' , 'a1', 'mm', Z
;;* MM,SM, 1, 60, 1, 1, A2	, 'Länge Gewinde Innen  A2' , 'a2', 'mm', Z
;;* MM,SM, 1, 80, 1, 1, BN  , 'Bestellnummer'      			, 'bn',		  , T
;;* MM,SM, 1, 90, 1, 1, F1  , 'Freistich'      		    	, 'f1',		  , T
;;*
;;**************************************************************************
(defun GD00032 ( gepa_list )
 (progn (sd-call-cmds
  ;; Setze Variablen von 'GE,PA' Liste fuer Komplettteil
  ;;---------------------------------------------------------
  (let ((G1) (G2) (SW) (L1) (A1) (A2)(MA) (F1) (Partname) (Akt_wp))
    ;;-------------------------------------------------------
    ;; Lokale GEO Variablen aus ge_pa Liste zuweisen
    ;;-------------------------------------------------------
    (setf G1 (nth 0 gepa_list)) 
    (setf G2 (nth 1 gepa_list)) 
    (setf SW (nth 2 gepa_list))
    (setf L1 (nth 3 gepa_list))
    (setf A1 (nth 4 gepa_list))
    (setf A2 (nth 5 gepa_list))
    (setf MA (nth 6 gepa_list))
    (setf F1 (nth 7 gepa_list))
    ;;-------------------------------------------------------
    ;;  Partnamen von der SolidLibrary abfragen
    ;;-------------------------------------------------------
    (setf Partname (lpo_vdaps::sl_get_envar :PARTNAME))
    ;;-------------------------------------------------------
    ;; Neue Arbeitsebene erzeugen, sofern keine existiert
    ;;-------------------------------------------------------
    (setf Akt_wp (sd-inq-curr-wp))
    (sd-call-cmds (create_workplane :new :world_origin))
    (sd-call-cmds (delete_2d :current_wp :edge_2d :all_2d) :failure nil)
    ;;-------------------------------------------------------    
    ;;Gewindeparameter definieren
    (let ((G) (GEW_D) (KERN_D_B) (KERN_D_M) (STEIGUNG) (GEW_PROF) (A0) (F_TYP) (E2))
      ;;GEW_D=Gewindenenndurchmesser KERN_D_B=Kerndurchmesser Bolzen KERN_D_M=Kerndurchmesser Mutter
      ;;STEIGUNG=Gewindesteigung GEW_PROF=Gewindeprofil A0=Gewindelänge F_TYP=Freistich-Typ
      ;;E2=Gewindeauslauf E1 x 0.37 E1=Standart Gewindeauslauf
      (cond
       ((string= G1 "M2") 	(setf G "M2"  	GEW_D 2.0   KERN_D_B 1.51 KERN_D_M 1.57 STEIGUNG 0.4  GEW_PROF :M   A0 A1   F_TYP "B"		E2 (* 2.3 0.37)))
       ((string= G1 "M2,5") (setf G "M2,5"  GEW_D 2.5   KERN_D_B 1.95 KERN_D_M 2.01 STEIGUNG 0.45 GEW_PROF :M   A0 A1   F_TYP "B"		E2 (* 2.6 0.37)))
       ((string= G1 "M3")   (setf G "M3"    GEW_D 3.0   KERN_D_B 2.39 KERN_D_M 2.46 STEIGUNG 0.5  GEW_PROF :M   A0 A1   F_TYP "B"		E2 (* 2.8 0.37)))
       ((string= G1 "M4")   (setf G "M4"    GEW_D 4.0   KERN_D_B 3.14 KERN_D_M 3.24 STEIGUNG 0.7  GEW_PROF :M   A0 A1   F_TYP "B"		E2 (* 3.8 0.37)))
       ((string= G1 "M5")   (setf G "M5"    GEW_D 5.0   KERN_D_B 4.02 KERN_D_M 4.13 STEIGUNG 0.8  GEW_PROF :M   A0 A1   F_TYP "A"		E2 (* 4.2 0.37)))
       ((string= G1 "M6")   (setf G "M6"    GEW_D 6.0   KERN_D_B 4.77 KERN_D_M 4.92 STEIGUNG 1.0  GEW_PROF :M   A0 A1   F_TYP "A"		E2 (* 5.1 0.37)))
       ((string= G1 "M8")   (setf G "M8"    GEW_D 8.0   KERN_D_B 6.47 KERN_D_M 6.65 STEIGUNG 1.25 GEW_PROF :M   A0 A1   F_TYP "A"		E2 (* 6.2 0.37)))
      );;cond                                                                                                   
      ;;-------------------------------------------------------
      ;;Arbeitsebene drehen, Sechskant erstellen und Arbeitsebene zurückdrehen
      (GD00032-sechskant-erstellen SW L1 A1 KERN_D_M)
      ;;-------------------------------------------------------
  	  (cond
  	   ((or (= L1 A1) (= L1 (* A1 2))) (GD00032-gewinde-innen-und-fase-erstellen G GEW_D KERN_D_M STEIGUNG GEW_PROF))
  	   (t (progn (GD00032-bohrung-erstellen KERN_D_M A0 E2 L1 A1)
  	             (GD00032-gewinde-innen-erstellen G GEW_D KERN_D_M STEIGUNG GEW_PROF A0)))
      );;cond
    );;let
    ;;-------------------------------------------------------      
    ;;Dichte und Farbe setzen
    (let ((DICHTE) (FARBE))
      (cond
        ((string= MA "St verzinkt")   (setf DICHTE 0.00785  FARBE 0.6,0.6,0.6))
        ((string= MA "St gelbchrom.") (setf DICHTE 0.00785  FARBE 0.6,0.6,0.6))
        ((string= MA "Ms vernickelt") (setf DICHTE 0.0085   FARBE 1,0.8,0))
        ((string= MA "St rostfrei")   (setf DICHTE 0.00785  FARBE 0.6,0.6,0.6))
      );;cond
      (sd-call-cmds (set_part_inst_density :parts (sd-inq-curr-part) :dens DICHTE))
      (sd-call-cmds (set_part_inst_color :parts (sd-inq-curr-part) :color (sd-rgb-to-color FARBE)))
    );;let
    (sd-call-cmds (delete_3d :workplane :current) :failure nil)
    (sd-call-cmds (current_wp Akt_wp) :failure nil)
  );;let
 ));;sd-call-cmds progn
);;defun GD00032

;; Durchgängiges Gewinde
(defun GD00032-gewinde-innen-und-fase-erstellen (G GEW_D KERN_D_M STEIGUNG GEW_PROF)
  ;;-------------------------------------------------------
  ;; Fase erstellen                                   
  ;;-------------------------------------------------------
  (let (Kanten_liste)
  	(setf Kanten_liste
  		(sd-call-cmds (get_selection	:focus_type *sd-circle-3d-seltype*
  																	:select :in_part (sd-inq-curr-part)))
  	);;setf
  	(dolist (A_kante Kanten_liste)
			(sd-call-cmds (chamfer :distance (/ (- GEW_D KERN_D_M) 2) A_kante))
  	);;dolist
  );;let
  ;;-------------------------------------------------------
  ;; Gewinde erstellen                                   
  ;;-------------------------------------------------------
  (let (A_flaeche RICHTUNG)
    (setf A_flaeche (first (sd-call-cmds (get_selection	:focus_type *sd-cylinder-seltype* :select :in_part (sd-inq-curr-part)))))
    (setf RICHTUNG (sd-cylinder-axis-dir (sd-inq-geo-props A_flaeche :dest-space :global)))
    ;;Gewinde definieren
    (sd-call-cmds
      (sd-define-thread A_flaeche
        :nominal-diameter GEW_D
        :core-diameter KERN_D_M
        :pitch STEIGUNG
        :thread-type :INNER
        :thread-unit :METRIC
        :thread-color (sd-color-to-rgb 16753049)
        :thread-hand :RIGHT-HAND
        :thread-profile GEW_PROF
        :include-chamfer T
        :thread-direction RICHTUNG
        :thread-name G
      );;sd-define-thread
    );;sd-call-cmds
	);;let
);;defun

(defun GD00032-sechskant-erstellen (SW L1 A1 KERN_D_M)
  ;;Arbeitsebene um 90 Grad drehen
  (sd-call-cmds (position_wp :workplane (sd-inq-curr-wp) :rotate :axis :y :rotation_angle (/ pi 2)))
  ;;Profil für Vieleck erstellen
  (let (RAD_ID ALFAP ALFAS ALFAB ALFAC Counter X0 X1 XP Y0 Y1 YP)
    (sd-call-cmds (geometry_mode :real))
    (setq RAD_ID (/ SW 2))
    (setq ALFAP (/ (- 180 (/ 360 6)) 2))
    (setq ALFAS (/ 360 6))
    (setq ALFAB (+ ALFAP (/ (* 0 360) (* pi 2))))
    (setq RAD_ID (/ RAD_ID (sin (sd-deg-to-rad ALFAP))))
    (dotimes (Counter 6)
      (setq ALFAC (+ ALFAB (* ALFAS Counter)))
      (setq X1 (* RAD_ID (cos (sd-deg-to-rad ALFAC) )))
      (setq Y1 (* RAD_ID (sin (sd-deg-to-rad ALFAC) )))
      (cond
        ((> Counter 0) (line :two_points (make-gpnt2d :x X0 :y Y0) (make-gpnt2d :x X1 :y Y1))) 
        ((= Counter 0) (setq XP X1) (setq YP Y1))
      );;cond
      (setq X0 X1)
      (setq Y0 Y1)
    );;dotimes
    (sd-call-cmds (line :two_points (make-gpnt2d :x X0 :y Y0) (make-gpnt2d :x XP :y YP)))
  );;let
  (if (or (= L1 A1) (= L1 (* A1 2)))
  	(sd-call-cmds (circle :cen_rad 0,0 (/ KERN_D_M 2)))
  );;if
  ;;Vieleck extrudieren
  (sd-call-cmds
    (extrude :wp (sd-inq-curr-wp)
          :part (sd-inq-curr-part)
          :direction :+W :distance L1
          :keep_wp :yes :keep_profile :no)
  );;sd-call-cmds
  ;;Arbeitsebene zurückdrehen
  (sd-call-cmds (position_wp :workplane (sd-inq-curr-wp) :rotate :axis :y :rotation_angle (* -1 (/ pi 2))))
);;defun

;; Beidseitig bohren und Kante aufprägen
(defun GD00032-bohrung-erstellen (KERN_D_M A0 E2 L1 A1)
  (let (BOHR_TIEFE W_FAKT P1 P2 P3 P4)  
    (sd-call-cmds (geometry_mode :real))
    ;;Punkte berechnen
    (setf BOHR_TIEFE (+ A0 E2))
    (setf P1 (gpnt2d -1 0))
    (setf P2 (gpnt2d -1 (/ KERN_D_M 2)))
    (setf P3 (gpnt2d BOHR_TIEFE (/ KERN_D_M 2)))
    (setf W_FAKT (tan (* (/ (* 2 pi) 360.0) 31.0)))
    (setf P4 (gpnt2d (+ BOHR_TIEFE (* (/ KERN_D_M 2.0) W_FAKT)) 0))
     ;;Profil erstellen     
    (sd-call-cmds (polygon P1 P2 P3 P4 P1))
  );;let
  ;; Abdrehen
  (sd-call-cmds (bore :parts (sd-inq-curr-part) :axis :u :rotation_angle (* 2 pi) :keep_wp :yes :keep_profile :yes))
  ;; Arbeitsebene um 180 Grad drehen und um Länge L1 verschieben  
  (sd-call-cmds (position_wp :workplane (sd-inq-curr-wp) :rotate :axis :y :rotation_angle pi))
  (sd-call-cmds (position_wp :workplane (sd-inq-curr-wp) :translate :dir_len :x :len L1))
  ;; Abdrehen
  (sd-call-cmds (bore :parts (sd-inq-curr-part) :axis :u :rotation_angle (* 2 pi) :keep_wp :yes :keep_profile :no))
  ;; Arbeitsebene um 90 Grad drehen und um Länge A1 verschieben  
  (sd-call-cmds (position_wp :workplane (sd-inq-curr-wp) :rotate :axis :v :rotation_angle (/ pi 2)))
  (sd-call-cmds (position_wp :workplane (sd-inq-curr-wp) :translate :dir_len :w :len A1))
  ;;Kreis für Inprint erstellen
  (sd-call-cmds (circle :cen_rad 0,0 (/ KERN_D_M 2)))
  ;;Kreis prägen
  (sd-call-cmds (imprint_linear :auto_direction :yes :imprint_keep_wp :on :imprint_keep_profile :yes
         												:imprint_part (sd-inq-curr-part) :imprint_wp (sd-inq-curr-wp) :imprint_to_part))
  ;; Arbeitsebene um Länge L1 - (* A1 2) verschieben
  (sd-call-cmds (position_wp :workplane (sd-inq-curr-wp) :translate :dir_len :w :len (- L1 (* A1 2))))
  ;;Kreis prägen
  (sd-call-cmds (imprint_linear :auto_direction :yes :imprint_keep_wp :on :imprint_keep_profile :no
         												:imprint_part (sd-inq-curr-part) :imprint_wp (sd-inq-curr-wp) :imprint_to_part))
);;defun

;; Beidseitig Gewinde und Fase erstellen
(defun GD00032-gewinde-innen-erstellen (G GEW_D KERN_D_M STEIGUNG GEW_PROF A0)
  (let (Flaechen_liste)
    	(setf Flaechen_liste
    		(sd-call-cmds (get_selection	:focus_type *sd-cylinder-seltype* :select :in_part (sd-inq-curr-part)))
    	);;setf
    	(dolist (A_flaeche Flaechen_liste)
				(let (Props Kanten)
       		(setf Props (sd-inq-geo-props A_flaeche :dest-space :global))    		
       		(when (sd-cylinder-p Props)
 						(sd-call-cmds (get_selection :focus_type *sd-circle-3d-seltype*
                                       	 :select :by_face A_flaeche)
                                       	 :failure nil
                                      	 :success (setf Kanten *SD-ACTION-RESULT*))
            (unless (null Kanten)
							(let (Neben-flaechen)
                 (dolist (A-Kante Kanten)
                    (sd-call-cmds (get_selection :focus_type *sd-plane-seltype*
                                                 :select :by_edge_3d A-Kante)
                                                 :failure (setf Neben-flaechen nil)
                                                 :success (setf Neben-flaechen *SD-ACTION-RESULT*))
                    (when Neben-flaechen
                      (let (RICHTUNG)
                         (setf RICHTUNG (sd-cylinder-axis-dir (sd-inq-geo-props A_flaeche :dest-space :global)))
                         ;;Gewinde definieren
                         (sd-call-cmds
                           (sd-define-thread A_flaeche
                             :nominal-diameter GEW_D
                             :core-diameter KERN_D_M
                             :pitch STEIGUNG
                             :thread-type :INNER
                             :thread-unit :METRIC
                             :thread-color (sd-color-to-rgb 16753049)
                             :thread-hand :RIGHT-HAND
                             :thread-profile GEW_PROF
                             :include-chamfer T
                             :thread-direction RICHTUNG
                             :thread-name G
                           );;sd-define-thread
                         );;sd-call-cmds
                      );;let
                    	(sd-call-cmds (chamfer :distance (/ (- GEW_D KERN_D_M) 2) A-Kante))
                    );;when
                 );;dolist
              );;let
            );;unless
          );;when
        );;let  		
    	);;dolist
   );;let
);;defun