;;--------------------------------------------------------------------------*
;;  Copyright 2004  DC4 Technisches Büro GmbH                               *
;;                                                                          *
;;--------------------------------------------------------------------------*

(in-package :custom)

(use-package :OLI)

;;--------------------------------------------------------------------------*
;;     dialogs                                                              *
;;--------------------------------------------------------------------------*

(sd-defdialog 'dc4-anno-senkungen-bemassen-dialog
:dialog-title "Senkungen bem."
:variables
  '(
    (norm   :range ((912 :label "DIN 912") (6912 :label "DIN 6912") (84 :label "DIN 84") (963 :label "DIN 963") (7991 :label "DIN 7991"))
            :prompt-text "Schraubennorm fuer Senkung angeben"
            :title "Norm"
    )
    (ans    :selection *sd-anno-view-seltype*
            :prompt-text "Ansicht fuer SenkungsbemaÞung angeben"
            :title "Ansicht"
            :after-input (after-ans-action)
    )
    (masst  :value-type  :display-only
            :toggle-type :invisible
    )
    (kreis :selection *sd-anno-geo-seltype*
           :prompt-text "Umfangspunkt auf Senkung angeben"
           :title "Senkung"
           :check-function
            #'(lambda (elem)
               (let (tab skdm jn gdm err)
                (setf jn nil)
                (setf skdm 0)
                (if (sd-am-arc-struct-p (sd-am-inq-specific-geo-props elem))
                 (progn
                  (setf skdm (/ (* 2 (sd-am-arc-struct-radius (sd-am-inq-specific-geo-props elem))) masst))
                  (setf skdm (float (/ (round (* skdm 1000)) 1000)))
                  (setf jn t)
                 );;progn
                 (setf err "Nur Kreisboegen erlaubt!")
                );;if
                (if (sd-am-circle-struct-p (sd-am-inq-specific-geo-props elem))
                 (progn
                  (setf skdm (/ (* 2 (sd-am-circle-struct-radius (sd-am-inq-specific-geo-props elem))) masst))
                  (setf skdm (float (/ (round (* skdm 1000)) 1000)))
                  (setf jn t)
                 );;progn
                 (setf err "Nur Kreisboegen erlaubt!")
                );;if
                (setf tab (format nil "dc4-bohrung-logtable"))
                (setf gdm nil)
                (case norm
                 (963 (setf gdm (sd-read-logical-table-cell tab :pList `(:SkdmA ,skdm) :column :gdm)))
                 (7991 (setf gdm (sd-read-logical-table-cell tab :pList `(:SkdmB ,skdm) :column :gdm)))
                 (84 (setf gdm (sd-read-logical-table-cell tab :pList `(:SkdmK ,skdm) :column :gdm)))
                 (912 (setf gdm (sd-read-logical-table-cell tab :pList `(:SkdmK ,skdm) :column :gdm)))
                 (6912 (setf gdm (sd-read-logical-table-cell tab :pList `(:SkdmK ,skdm) :column :gdm)))
                 (t nil)
                );;case
                (if gdm
                 nil
                 (setf err "Senkung nicht erkannt!")
                );;if
                (if (and (equal jn t) (> skdm 0) gdm)
                 :ok
                 (values :error err)
                 );;if
                );;let
               );;lambda
            :after-input (after-kreis-action)
    )
    (gdm    :value-type :display-only
            :toggle-type :invisible
    )
    (gdmtxt :value-type :display-only
            :title "Fuer Gew."
    )
    (next
           :push-action (sd-call-cmds (next-action))
           :next-variable 'kreis
    )
   )
:local-functions
  '(
    (after-ans-action ()
     (let ()
      (setf masst (sd-am-view-struct-scale (sd-am-inq-view ans)))
     );;let
    )
    (after-kreis-action ()
     (let (tab skdm)
      (setf skdm 0)
      (if (sd-am-arc-struct-p (sd-am-inq-specific-geo-props kreis))
       (progn
        (setf skdm (/ (* 2 (sd-am-arc-struct-radius (sd-am-inq-specific-geo-props kreis))) masst))
        (setf skdm (float (/ (round (* skdm 1000)) 1000)))
       );;progn
       nil
      );;if
      (if (sd-am-circle-struct-p (sd-am-inq-specific-geo-props kreis))
       (progn
        (setf skdm (/ (* 2 (sd-am-circle-struct-radius (sd-am-inq-specific-geo-props kreis))) masst))
        (setf skdm (float (/ (round (* skdm 1000)) 1000)))
       );;progn
       nil
      );;if
      (setf tab (format nil "dc4-bohrung-logtable"))
      (setf gdm nil)
      (case norm
       (963 (setf gdm (sd-read-logical-table-cell tab :pList `(:SkdmA ,skdm) :column :gdm)))
       (7991 (setf gdm (sd-read-logical-table-cell tab :pList `(:SkdmB ,skdm) :column :gdm)))
       (84 (setf gdm (sd-read-logical-table-cell tab :pList `(:SkdmK ,skdm) :column :gdm)))
       (912 (setf gdm (sd-read-logical-table-cell tab :pList `(:SkdmK ,skdm) :column :gdm)))
       (6912 (setf gdm (sd-read-logical-table-cell tab :pList `(:SkdmK ,skdm) :column :gdm)))
       (t nil)
      );;case
      (if gdm
       (setf gdmtxt (format nil "M~a" gdm))
       nil
      );;if
     );;let
    )
    (next-action ()
     (dc4-anno-bemasse-senkung kreis norm gdm masst)
     (setf kreis nil)
     (setf gdm nil)
     (setf gdmtxt nil)
    )
   )
:ok-action
   '(sd-call-cmds (dc4-anno-bemasse-senkung kreis norm gdm masst))
:help-action '()
)

;;--------------------------------------------------------------------------*
;;     functions                                                            *
;;--------------------------------------------------------------------------*

;; Bemasst Kreise oder Kreisboegen mit passendem Durchmesser als Senkung
;;

(defun dc4-anno-bemasse-senkung (kreis norm gdm masst)
 (let (bemtext p1 cp ret dimvec p2 p3)
  (setf bemtext (format nil "fÏr DIN ~a M~a" norm gdm))
  (if (sd-am-arc-struct-p (sd-am-inq-specific-geo-props kreis))
   (progn
    (setf p1 (sd-am-arc-struct-start-pnt (sd-am-inq-specific-geo-props kreis)))
    (setf cp (sd-am-arc-struct-center (sd-am-inq-specific-geo-props kreis)))
   );;progn
   nil
  );;if
  (if (sd-am-circle-struct-p (sd-am-inq-specific-geo-props kreis))
   (progn
    (setf p1 (sd-am-circle-struct-per-pnt (sd-am-inq-specific-geo-props kreis)))
    (setf cp (sd-am-circle-struct-center (sd-am-inq-specific-geo-props kreis)))
   );;progn
   nil
  );;if
  (setf dimvec (sd-execute-annotator-function :fnc
    (format nil "DC4_am_get_dimension_point ~a,~a" (gpnt2d_x p1) (gpnt2d_y p1))))
  (setf p2 (sd-vec-scale (sd-vec-add cp dimvec) (/ 1 masst)))
  (setf p3 (sd-vec-scale p2 masst))
  (am_create_dim_diamtr :centerline :on p1 p2)
  (am_dim_edit_value :dim_list p3 :underline :off :maintext bemtext :secondtext "")
  (am_dim_delete_fixtext :prefix :on :dim_list p3)
 );;let
)

;;***************************************************************************
;;     LOGTABLES                                                            *
;;***************************************************************************

(defun dc4-gewinde-erzeuge-ltab ()
 (setf *dc4-gewinde-liste*
   '(
       ( 1 "M 1" 1 0.250 1.200 2.400 0 90 2.200 0 0.800 0 0 "metrisch")
       ( 2 "M 1.2" 1.200 0.250 1.400 2.800 0 90 2.500 0 0.900 0 0 "metrisch")
       ( 3 "M 1.6" 1.600 0.350 1.800 3.700 0 90 3.300 0 1.200 0 1.800 "metrisch")
       ( 4 "M 2" 2 0.400 2.400 4.600 0 90 4.300 0 1.600 0 2.300 "metrisch")
       ( 5 "M 2.5" 2.500 0.450 2.900 5.700 0 90 5 0 2 0 2.900 "metrisch")
       ( 6 "M 3" 3 0.500 3.400 6.500 6.600 90 6 0 2.400 0 3.400 "metrisch")
       ( 7 "M 4" 4 0.700 4.500 8.600 9 90 8 0 3.200 3.400 4.600 "metrisch")
       ( 8 "M 5" 5 0.800 5.500 10.400 11 90 10 0 4 4.200 5.700 "metrisch")
       ( 9 "M 6" 6 1 6.600 12.400 13 90 11 0 4.700 4.800 6.800 "metrisch")
       (10 "M 8" 8 1.250 9 16.400 17.200 90 15 0 6 6 9 "metrisch")
       (11 "M 10" 10 1.500 11 20.400 21.500 90 18 0 7 7.500 11 "metrisch")
       (12 "M 12" 12 1.750 14 24.400 26 90 20 16 8 8.500 13 "metrisch")
       (13 "M 16" 16 2 18 32.400 32 90 26 20 10.500 11.500 17.500 "metrisch")
       (14 "M 20" 20 2.500 22 40.400 38 90 33 24 12.500 13.500 21.500 "metrisch")
       (15 "M 24" 24 3 26 0 41 60 40 28 14.500 15.500 25.500 "metrisch")
       (16 "M 30" 30 3.500 33 0 0 0 48 36 0 19.500 32 "metrisch")
       (17 "M 36" 36 4 39 0 0 0 57 42 0 23.500 38 "metrisch")
       (18 "M 42" 42 4.500 45 0 0 0 66 48 0 0 44 "metrisch")
       (19 "M 48" 48 5 52 0 0 0 76 56 0 0 50 "metrisch")
    )
 )
 (sd-create-logical-table "dc4-bohrung-logtable"
   :columnNames '("Zl" "Gewinde" "Gdm" "Gstg" "Bdm" "SkdmA" "SkdmB" "SkwB" "SkdmK" "FdmK" "SktH" "SktJ" "SktK" "Typ")
   :columns     '(:Zl :Bez :Gdm :Gstg :Bdm :SkdmA :SkdmB :SkwB :SkdmK :FdmK :SktH :SktJ :SktK :Typ)
   :types       '(:number :string :number :number :number :number :number :number :number :number :number :number :number :string)
   ;;:units       '(:mm :mm :mm :mm :mm :mm :mm :mm :mm :mm :mm :mm :mm :mm)
   :units       '(nil nil nil nil nil nil nil nil nil nil nil nil nil nil)
   :contents    *dc4-gewinde-liste*
 )
)

(dc4-gewinde-erzeuge-ltab)

(sd-execute-annotator-command :cmd
"DEFINE DC4_am_get_dimension_point
  PARAMETER Center
  LOCAL Dim_pt
  LOCAL Xcord
  LOCAL Ycord
  LOCAL Ang
  LOCAL Dim_vec
  LOCAL Dim_s

  LET Xcord 10.987654321
  LET Ycord 10.123456789
  LET Ang 0
  CATCH PERMANENT NO_VIEWPORT_RANGE 1
  LOOP
    LET Dim_vec (ROT (PNT_XY xcord ycord) Ang)
    LET Dim_pt (Center+ Dim_vec)
    INQ_ELEM Dim_pt
  EXIT_IF (INQ 403 = END)
  EXIT_IF (Ang=360)
    LET Ang (Ang+30)
  END_LOOP
  CATCH PERMANENT NO_VIEWPORT_RANGE 0
  LET Dim_s (STR Dim_vec)
  LET isopen (DOCU_OPEN_CONNECTION_TO_SD)
  LET done (DOCU_ADD_LINE_TO_SD Dim_s)
  LET isclosed (DOCU_CLOSE_CONNECTION_TO_SD)
END_DEFINE")