;;--------------------------------------------------------------------------*
;;  Copyright 2003  DC4 Technisches Büro GmbH                               *
;;                                                                          *
;;--------------------------------------------------------------------------*
;;  Dateiname: freistich.lsp
;;  Version  : 1.0
;;  Datum    :
;;  Author   : Gt

(in-package :DC4)

(use-package :OLI)
(use-package :custom)

;;--------------------------------------------------------------------------*

(sd-defdialog 'dc4-freist-schleif-dialog
:dialog-title "Schleiffreistiche"
;;:dialog-control :sequential
:variables
  '(
    ;;lokal
    (back    :initial-value nil)
    (teil)
    (center)
    (normal)
    (start-dir)
    (radius)
    (aussen)
    ;;dialog
    (kkante  :selection *sd-circle-3d-seltype*
             :multiple-items nil
             :modifies :contents
             :prompt-text "Kreisfoermige Kante fuer Schleiffreistich angeben"
             :title "Kreiskante"
             :initial-value nil
             :check-function
              #'(lambda (wert)
                 (let (kreis eig cyllist planelist cylface planeface cyl plane cylprop planeprop kprop p_on_plane p_on_cyl pdiff)
                  (setf kreis nil)
                  (setf eig (sd-inq-parent-obj wert))
                  (when (sd-inq-part-p eig)
                   (setf teil eig)
                  );;when
                  (setf cyllist (sd-call-cmds (get_selection
                                                   :focus_type *sd-cylinder-seltype*
                                                   :select :by_edge_3d wert)))
                  (setf planelist (sd-call-cmds (get_selection
                                                   :focus_type *sd-plane-seltype*
                                                   :select :by_edge_3d wert)))
                  (when (and (= 1 (length cyllist)) (= 1 (length planelist)))
                   (progn
                    (setf cyl (first cyllist))
                    (setf cylprop (sd-inq-geo-props cyl :dest-space :global))
                    (setf plane (first planelist))
                    (setf planeprop (sd-inq-geo-props plane :dest-space :global))
                    (setf kprop (sd-inq-geo-props wert :dest-space :global))
                    (setf normal (sd-plane-normal planeprop))
                    (setf center (sd-circle-center kprop))
                    (setf start-dir (sd-circle-start-dir kprop))
                    (setf radius (sd-circle-radius kprop))
                    (setf p_on_plane (sd-get-pnt-on-face plane :dest-space :global))
                    (setf p_on_cyl (sd-get-pnt-on-face cyl :dest-space :global))
                    (setf pdiff (sd-vec-subtract p_on_cyl p_on_plane))
                    (when (and teil (sd-cylinder-p cylprop) (sd-plane-p planeprop) (> (sd-vec-length (sd-vec-add normal pdiff)) (sd-vec-length pdiff)))
                     (progn
                      (setf kreis t)
                      (setf durchm (* 2 radius))
                      (if (< (sd-vec-length (sd-vec-subtract p_on_plane center)) radius)
                       (setf aussen nil)
                       (setf aussen t)
                      );;if
                     );;progn
                    );;when
                   );;progn
                  );;when
                  (if kreis
                   :ok
                   (values :error "Diese Kante hat nicht die richtigen Nachbarflaechen oder gehoert zu keinem Teil!")
                  );;if
                 );;let
                );;lambda
             :after-input (progn
                           (setf durchm durchm)
                           (if (> durchm 18)
                            (sd-set-variable-status 'bansp :enable t)
                            (sd-set-variable-status 'bansp :enable nil)
                           );;if
                          );;progn
    )
    (durchm  :value-type :display-only
             :title "Durchmesser"
    )
    (form   :range ((0 :label "E") (1 :label "F"))
            :title "Form"
    )
    (bansp  :value-type :boolean
            :toggle-type :wide-toggle
            :title "Erhoehte Beanspruchung"
            :initial-enable nil
    )
    (next
            :push-action (next-action)
            :next-variable 'kkante
    )
   )
:after-initialization
  '()
:local-functions
  '(
    (next-action ()
     (sd-call-cmds (dc4-freist-erzeuge-schleiff teil center normal start-dir radius form bansp aussen))
     (sd-set-variable-status 'bansp :enable nil)
     (setf kkante nil)
    )
   )
:cancel-action
   '()
:ok-action
   '(next-action)
:cleanup-action
   '()
:help-action '(sd-display-url (format nil "~a#Schleiffreistiche" *dc4-hilfe-datei*))
)

;;--------------------------------------------------------------------------*
;;     Funktion: dc4-freist-erzeuge-schleiff                                *
;;               Erzeugt einen Schleiffreistich                             *
;;                                                                          *
;;     Parameter :                                                          *
;;                 teil ... {SEL_ITEM} des Teiles                           *
;;                                                                          *
;;                                                                          *
;;     Returnwert: keiner                                                   *
;;                                                                          *
;;  Geppert 16.05.2002                                                      *
;;-------------------------------------------------------------------------*/

(defun dc4-freist-erzeuge-schleiff (teil center normal start-dir radius form bansp aussen)
 (let (dm r1 t1 f1 t2 akt_wp bog8 fas1 fas2 fas3 p1 p2 p3 p4 p5)
  (setf dm (* 2 radius))
  (if bansp
   (progn
    (cond
     ((<= dm 50)
      (progn
       (setf r1 1)
       (setf t1 0.2)
       (setf f1 2.5)
       (setf t2 0.1)
      );;progn
     )
     ((<= dm 80)
      (progn
       (setf r1 1.6)
       (setf t1 0.3)
       (setf f1 4)
       (setf t2 0.2)
      );;progn
     )
     ((<= dm 125)
      (progn
       (setf r1 2.5)
       (setf t1 0.4)
       (setf f1 5)
       (setf t2 0.3)
      );;progn
     )
     (t
      (progn
       (setf r1 4)
       (setf t1 0.5)
       (setf f1 7)
       (setf t2 0.3)
      );;progn
     )
    );;cond
   );;progn
   (progn
    (cond
     ((<= dm 1.6)
      (progn
       (setf r1 0.1)
       (setf t1 0.1)
       (setf f1 0.5)
       (setf t2 0.1)
      );;progn
     )
     ((<= dm 3)
      (progn
       (setf r1 0.2)
       (setf t1 0.1)
       (setf f1 1)
       (setf t2 0.1)
      );;progn
     )
     ((<= dm 10)
      (progn
       (setf r1 0.4)
       (setf t1 0.2)
       (setf f1 2)
       (setf t2 0.1)
      );;progn
     )
     ((<= dm 18)
      (progn
       (setf r1 0.6)
       (setf t1 0.2)
       (setf f1 2)
       (setf t2 0.1)
      );;progn
     )
     ((<= dm 80)
      (progn
       (setf r1 0.6)
       (setf t1 0.3)
       (setf f1 2.5)
       (setf t2 0.2)
      );;progn
     )
     (t
      (progn
       (setf r1 1)
       (setf t1 0.4)
       (setf f1 4)
       (setf t2 0.3)
      );;progn
     )
    );;cond
   );;progn
  );;if
  (setf akt_wp (sd-inq-curr-wp)) ;; aktuelle Arbeitsebene
  (create_workplane :new)
  (position_wp :current :pt_pt_pt center (sd-vec-add center normal) (sd-vec-add center start-dir))
  (GEOMETRY_MODE :REAL)
  (setf bog8 (/ (* pi 8) 180))
  (setf fas1 (/ t1 (tan (/ (* pi 15) 180))))
  (setf fas2 (-  (+ r1 (* r1 (sin bog8))  (/ (- (+ t2 (* r1 (cos bog8))) r1) (tan bog8))) t1))
  (setf fas3 (* (+ fas2 t1) (tan bog8)))
  (if (= form 0)
   (progn
    (if aussen
     (progn
      (setf p1 (make-gpnt2d :x f1 :y radius))
      (setf p2 (make-gpnt2d :x (- f1 fas1) :y (- radius t1)))
      (setf p3 (make-gpnt2d :x 0 :y (- radius t1)))
      (setf p4 (make-gpnt2d :x 0 :y (+ r1 (- radius t1))))
      (setf p5 (make-gpnt2d :x f1 :y (+ r1 (- radius t1))))
     );;progn
     (progn
      (setf p1 (make-gpnt2d :x f1 :y radius))
      (setf p2 (make-gpnt2d :x (- f1 fas1) :y (+ radius t1)))
      (setf p3 (make-gpnt2d :x 0 :y (+ radius t1)))
      (setf p4 (make-gpnt2d :x 0 :y (- (+ radius t1) r1)))
      (setf p5 (make-gpnt2d :x f1 :y (- (+ radius t1) r1)))
     );;progn
    );;if
   );;progn
   (progn
    (if aussen
     (progn
      (setf p1 (make-gpnt2d :x f1 :y radius))
      (setf p2 (make-gpnt2d :x (- f1 fas1) :y (- radius t1)))
      (setf p3 (make-gpnt2d :x (- 0 fas3) :y (- radius t1)))
      (setf p4 (make-gpnt2d :x 0 :y (+ radius fas2)))
      (setf p5 (make-gpnt2d :x f1 :y (+ radius fas2)))
     );;progn
     (progn
      (setf p1 (make-gpnt2d :x f1 :y radius))
      (setf p2 (make-gpnt2d :x (- f1 fas1) :y (+ radius t1)))
      (setf p3 (make-gpnt2d :x (- 0 fas3) :y (+ radius t1)))
      (setf p4 (make-gpnt2d :x 0 :y (- radius fas2)))
      (setf p5 (make-gpnt2d :x f1 :y (- radius fas2)))
     );;progn
    );;if
   );;progn
  );;if
  (rectangle p3 p5)
  (turn :part (sd-inq-obj-pathname teil) :axis :u :keep_profile :no :keep_wp :yes)
  (polygon p1 p2 p3 p4 p5 :close)
  (fillet :create :fillet_radius r1 p2 p3)
  (bore :parts (sd-inq-obj-pathname teil) :axis :u :keep_wp :no)
  (if akt_wp (current_wp akt_wp) nil)
 );;let
)