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

(in-package :custom)

(use-package :OLI)

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

(sd-defdialog 'dc4-teil-vervielfaeltigen-pr-dialog
:dialog-title "Vervielf. Punkt/Richtg"
;;:dialog-control :sequential
:after-initialization '(progn (sd-disable-must-variable-check))
:variables
  '(
    ;;local
    (sdirmain-fback :initial-value nil)
    (sdirsec-fback :initial-value nil)
    (zdirmain-fback :initial-value nil)
    (zdirsec-fback :initial-value nil)
    (back-states :initial-value (list (list (sd-set-model-checkpoint) nil nil nil nil nil nil nil nil nil nil)))
    ;;dialog
    (teil ; :value-type :part-assembly
           :selection
              (*sd-object-seltype*)
           :multiple-items t
           :show-select-menu t
           :prompt-text "Teil oder Baugruppe angeben"
           :title "Teil/Bgr"
           ;;:initial-value nil
           :next-variable (seq-input)
           :after-input (after-teil-action)
    )
    (bgr   :value-type :assembly
           :prompt-text "Baugruppe als Besitzer angeben"
           :title "Besitzer"
           :next-variable (seq-input)
    )
    (startp :value-type :point-3d
           :title "Startpunkt"
           :prompt-text "Startpunkt fuer Vervielfaeltigung angeben"
           :next-variable (seq-input)
           :after-input (after-startp-action)
    )
    (sdirmain
            :value-type :measure-direction
            :prompt-text "Hauptbezugsrichtung angeben"
            :title "Hauptbez."
            :initial-direction-negative t
            :built-in-feedback nil
            :next-variable (seq-input)
            :after-input (after-sdirmain-action)
    )
    (sdirsec
            :value-type :measure-direction
            :prompt-text "Zweite Bezugsrichtung angeben"
            :title "Zweitbez."
            :initial-direction-negative nil
            :built-in-feedback nil
            :next-variable (seq-input)
            :after-input (after-sdirsec-action)
    )
    (zielp :value-type :point-3d
           :multiple-items t
           :show-select-menu t
           :prompt-text "Zielpunkt angeben"
           :title "Zielpunkt"
           ;;:initial-value nil
           :next-variable (seq-input)
           :after-input (after-zielp-action)
    )
    (zdirmain
            :value-type :measure-direction
            :prompt-text "Hauptbezugsrichtung angeben"
            :title "Hauptbez."
            :initial-direction-negative t
            :built-in-feedback nil
            :next-variable (seq-input)
            :after-input (after-zdirmain-action)
    )
    (zdirsec
            :value-type :measure-direction
            :prompt-text "Zweite Bezugsrichtung angeben"
            :title "Zweitbez."
            :initial-direction-negative nil
            :built-in-feedback nil
            :next-variable (seq-last-input)
            :after-input (after-zdirsec-action)
    )
    (share :value-type :grouped-boolean
           :title "Exemplar"
           :initial-value t
           :after-input (after-share-action)
    )
    (copy  :value-type :grouped-boolean
           :title "Kopie 1 Eb."
           :initial-value nil
           :after-input (after-share-action)
    )
    (katt  :value-type :boolean
           :title "Attib beh"
           :initial-value t
    )
    (back  :title "Zurueck"
           :push-action (back-action)
    )
   )
:mutual-exclusion '((copy share))
:local-functions
  '(
    (cleanup ()
     (sd-end-feedback sdirmain-fback)
     (sd-end-feedback sdirsec-fback)
     (sd-end-feedback zdirmain-fback)
     (sd-end-feedback zdirsec-fback)
    )
    (seq-input ()
     (if (not teil)
      'teil
      (if (not bgr)
       'bgr
       (if (not startp)
        'startp
        (if (not sdirmain)
         'sdirmain
         (if (not sdirsec)
          'sdirsec
          (if (not zielp)
           'zielp
           (if (not zdirmain)
            'zdirmain
            'zdirsec)))))))
    )
    (seq-last-input ()
     (if (not teil)
      'teil
      (if (not bgr)
       'bgr
       (if (not startp)
        'startp
        (if (not sdirmain)
         'sdirmain
         (if (not sdirsec)
          'sdirsec
          (if (not zielp)
           'zielp
           (if (not zdirmain)
            'zdirmain
            'share)))))))
    )
;;Startbedingungen
    (start-sdirmain-fback ()
     (let ()
      (when (and startp (nth 0 sdirmain))
       (setq sdirmain-fback (sd-start-direction-feedback
                        :point startp
                        :direction (nth 0 sdirmain)
                        :disc t
                        :color 0,1,0)
       )
      );;when
     );;let
    )
    (after-sdirmain-action ()
     (let ()
      (sd-end-feedback sdirmain-fback)
      (sd-end-feedback sdirsec-fback)
      (when sdirsec
#|
		***** funktioniert nur mit OSD V. >=14) *****
       (when (sd-vec-colinear-p (nth 0 sdirmain) (nth 0 sdirsec))
        (progn
         (setf sdirsec nil)
         (sd-display-error "Haupt- und Nebenrichtung sind gleich!")
        );;progn
       );;when
|#

   	(when (sd-vec-null-p (sd-vec-cross-product (sd-vec-normalize (nth 0 sdirmain)) (sd-vec-normalize (nth 0 sdirsec))))
        (progn
         (setf sdirsec nil)
         (sd-display-error "Haupt- und Nebenrichtung sind gleich!")
        );;progn
       );;when


      );;when
      (start-sdirmain-fback)
      (start-sdirsec-fback)
     );;let
    )
    (start-sdirsec-fback ()
     (let (fbvec)
      (when (and startp (nth 0 sdirmain) (nth 0 sdirsec))
       (progn
        (setf fbvec (sd-vec-cross-product (sd-vec-cross-product (nth 0 sdirmain) (nth 0 sdirsec)) (nth 0 sdirmain)))
        (setq sdirsec-fback (sd-start-direction-feedback
                         :point startp
                         :direction fbvec
                         :disc nil
                         :color 0,0.5,0)
        )
       );;progn
      );;when
     );;let
    )

    (after-sdirsec-action ()
     (let ()
      (sd-end-feedback sdirsec-fback)
      (when (and sdirmain sdirsec)
#|
		***** funktioniert nur mit OSD V. >=14) *****
       (if (sd-vec-colinear-p (nth 0 sdirmain) (nth 0 sdirsec))
        (progn
         (setf sdirsec nil)
         (sd-display-error "Haupt- und Nebenrichtung sind gleich!")
        );;progn
       );;when
|#


       (if (sd-vec-null-p (sd-vec-cross-product (sd-vec-normalize (nth 0 sdirmain)) (sd-vec-normalize (nth 0 sdirsec))))
        (progn
         (setf sdirsec nil)
         (sd-display-error "Haupt- und Nebenrichtung sind gleich!")
        );;progn
       );;if


       (start-sdirsec-fback)
      );;if
     );;let
    )

    (after-startp-action ()
     (let ()
      (sd-end-feedback sdirmain-fback)
      (start-sdirmain-fback)
      (sd-end-feedback sdirsec-fback)
      (start-sdirsec-fback)
     );;let
    )
;;Zielbedingungen
    (start-zdirmain-fback ()
     (let (origin)
      (cond
       (zielp
        (setf origin zielp)
       )
       ((nth 4 (first back-states))
        (setf origin (nth 4 (first back-states)))
       )
       (startp
        (setf origin startp)
       )
       (t setf origin nil)
      );;cond
      (when (and origin (nth 0 zdirmain))
       (setq zdirmain-fback (sd-start-direction-feedback
                        :point origin
                        :direction (nth 0 zdirmain)
                        :disc t
                        :color 1,0,0)
       )
      );;when
     );;let
    )
    (after-zdirmain-action ()
     (let ()
      (sd-end-feedback zdirmain-fback)
      (sd-end-feedback zdirsec-fback)
      (when zdirsec
#|
		***** funktioniert nur mit OSD V. >=14) *****
       (when (sd-vec-colinear-p (nth 0 zdirmain) (nth 0 zdirsec))
        (progn
         (setf zdirsec nil)
         (sd-display-error "Haupt- und Nebenrichtung sind gleich!")
        );;progn
       );;when
|#


       (when (sd-vec-null-p (sd-vec-cross-product (sd-vec-normalize (nth 0 zdirmain)) (sd-vec-normalize (nth 0 zdirsec))))
        (progn
         (setf zdirsec nil)
         (sd-display-error "Haupt- und Nebenrichtung sind gleich!")
        );;progn
       );;end when

      );;when
      (start-zdirmain-fback)
      (start-zdirsec-fback)
     );;let
    )
    (start-zdirsec-fback ()
     (let (origin)
      (cond
       (zielp
        (setf origin zielp)
       )
       ((nth 4 (first back-states))
        (setf origin (nth 4 (first back-states)))
       )
       (startp
        (setf origin startp)
       )
       (t setf origin nil)
      );;cond
      (when (and startp (nth 0 zdirmain) (nth 0 zdirsec))
       (progn
        (setf fbvec (sd-vec-cross-product (sd-vec-cross-product (nth 0 zdirmain) (nth 0 zdirsec)) (nth 0 zdirmain)))
        (setq zdirsec-fback (sd-start-direction-feedback
                         :point origin
                         :direction fbvec
                         :disc nil
                         :color 0.5,0,0 )
        )
       );;progn
      );;when
     );;let
    )
    (after-zdirsec-action ()
     (let ()
      (sd-end-feedback zdirsec-fback)
      (when (and zdirmain zdirsec)
#|
		***** funktioniert nur mit OSD V. >=14) *****
       (if (sd-vec-colinear-p (nth 0 zdirmain) (nth 0 zdirsec))
        (progn
         (setf zdirsec nil)
         (sd-display-error "Haupt- und Nebenrichtung sind gleich!")
        );;progn
       );;when
|#


	(if (sd-vec-null-p (sd-vec-cross-product (sd-vec-normalize (nth 0 zdirmain)) (sd-vec-normalize (nth 0 zdirsec))))
        (progn
         (setf zdirsec nil)
         (sd-display-error "Haupt- und Nebenrichtung sind gleich!")
        );;progn
       );;if

       (start-zdirsec-fback)
      );;if
      (when (and teil bgr startp sdirmain sdirsec zielp zdirmain zdirsec)
       (next-action)
      );;when
     );;let
    )
    (after-zielp-action ()
     (let ()
      (sd-end-feedback zdirmain-fback)
      (start-zdirmain-fback)
      (sd-end-feedback zdirsec-fback)
      (start-zdirsec-fback)
      (when (and teil bgr startp sdirmain sdirsec zielp zdirmain zdirsec)
       (next-action)
      );;when
     );;let
    )
;;Variablen modifizieren
    (after-teil-action ()
     (let ()
      (sd-set-variable-status 'bgr :value (sd-inq-parent-obj (first teil)))
     );;let
    )
    (after-share-action ()
     (let ()
      (sd-set-variable-status 'katt :enable share)
     );;let
    )
;;Ausfuehren
    (next-action ()
     (let (et sp2 sp3 zp2 zp3 ka)
      (if katt (setf ka :on) (setf ka :off))
      (if (and teil bgr startp sdirmain sdirsec zielp zdirmain zdirsec)
       (progn
        (cleanup)
        ;; remember current model state:
        (push (list (sd-set-model-checkpoint) startp sdirmain sdirsec zielp zdirmain zdirsec sdirmain-fback sdirsec-fback zdirmain-fback zdirsec-fback) back-states)
        (setf sp2 (sd-vec-add startp (first sdirmain)))
        (setf zp2 (sd-vec-add zielp (first zdirmain)))
        (setf sp3 (sd-vec-add startp (first sdirsec)))
        (setf zp3 (sd-vec-add zielp (first zdirsec)))
        (if share
         (progn
          (dolist (et teil)
           (sd-call-cmds (create_multiple_pa :share
                         :owner (sd-inq-obj-pathname bgr)
                         :source (sd-inq-obj-pathname et)
                         :keep_attr ka
                         :match_three_pts startp zielp sp2 zp2 sp3 zp3
                         )
           )
          );;dolist
         );;progn
         (progn
          (dolist (et teil)
           (sd-call-cmds (create_multiple_pa :copy :onelevel :on
                         :owner (sd-inq-obj-pathname bgr)
                         :source (sd-inq-obj-pathname et)
                         :match_three_pts startp zielp sp2 zp2 sp3 zp3
                         )
           )
          );;dolist
         );;progn
        );;if
       (start-sdirmain-fback)
       (start-sdirsec-fback)
       (start-zdirmain-fback)
       (start-zdirsec-fback)
        (setf zielp nil)
        (when back-states (sd-set-variable-status 'back :enable t))
       );;progn
       (progn
        (sd-display-error "Erst alle Parameter angeben!")
        (setf zielp nil)
       );;progn
      );;if
     );;let
    )
    (back-action ()
     (when back-states
      (let ((state (pop back-states)))
       (cleanup)
       (sd-return-to-model-checkpoint (nth 0 state))
       (setq startp (nth 1 state))
       (setq sdirmain (nth 2 state))
       (setq sdirsec (nth 3 state))
       (setq zielp nil)
       (setq zdirmain (nth 5 state))
       (setq zdirsec (nth 6 state))
       (setq sdirmain-fback (nth 7 state))
       (setq sdirsec-fback (nth 8 state))
       (setq zdirmain-fback (nth 9 state))
       (setq zdirsec-fback (nth 10 state))
       (start-sdirmain-fback)
       (start-sdirsec-fback)
       (start-zdirmain-fback)
       (start-zdirsec-fback)
      );;let
      (unless (nth 1 back-states)
       (sd-set-variable-status 'back :enable nil)
      );;unless
     );;when
    )
   )
:ok-action '(cleanup)
:cancel-action '(cleanup)
:help-action '()
)

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