;;--------------------------------------------------------------------------*
;;  Copyright 2004  DC4 Technisches Büro GmbH                               *
;;                                                                          *
;;--------------------------------------------------------------------------*
;;  Dateiname: fritzelack.lsp
;;  Version  : 1.0
;;  Datum    : 23.06.2004
;;  Author   : Gt
;;--------------------------------------------------------------------------*

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

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

(sd-defdialog 'dc4-fritzelack-dialog
:dialog-title "Umfaerben"
;;:dialog-control :sequential
:variables
  '(
    ("alte Farbe")
    (zielf :value-type :face
         :initial-value nil
         :initial-optional t
         :title "von Flaeche"
         :prompt-text "Flaeche, von der die Farbe uebernommen werden soll, angeben"
         :modifies nil
         :after-input (after-zielf-action)
    )
    (zielt :value-type :part
         :initial-value nil
         :initial-optional t
         :title "von Teil"
         :prompt-text "Teil, von dem die Farbe uebernommen werden soll, angeben"
         :modifies nil
         :after-input (after-zielt-action)
    )
    (farbealt :value-type :rgb-color
           :title "alte Farbe"
    )
    ("neue Farbe")
    (quellf :value-type :face
         :initial-value nil
         :initial-optional t
         :title "von Flaeche"
         :prompt-text "Flaeche, von der die Farbe uebernommen werden soll, angeben"
         :modifies nil
         :after-input (after-quellf-action)
    )
    (quellt :value-type :part
         :initial-value nil
         :initial-optional t
         :title "von Teil"
         :prompt-text "Teil, von dem die Farbe uebernommen werden soll, angeben"
         :modifies nil
         :after-input (after-quellt-action)
    )
    (farbeneu :value-type :rgb-color
           :title "neue Farbe"
    )
				("Umfaerben:")
    (ausw  :value-type :boolean
           :toggle-type :wide-toggle
           :title "nur alte Farbe"
           :initial-value t
    )
    (alle  :value-type :boolean
           :toggle-type :wide-toggle
           :title "alles umfaerben"
           :initial-value nil
    )
    (teile  :value-type :part
           :multiple-items t
           :show-select-menu t
           :prompt-text "Teile, die eingefaerbt werden sollen angeben"
           :title "Teile"
           :modifies :instance+parent-contents
           :initial-value nil
           :after-input (after-teile-action)
    )
    (flaechen :value-type :face
           :multiple-items t
           :show-select-menu t
           :prompt-text "Flaechen, die eingefaerbt werden sollen angeben"
           :title "Flaechen"
           :modifies :instance+parent-contents
           :initial-value nil
           :after-input (after-flaechen-action)
    )
   )
    :mutual-exclusion '((zielf zielt) (quellf quellt) (ausw alle))
:local-functions
  '(
    (after-zielf-action ()
     (let ()
      (setf farbealt (sd-inq-face-color zielf))
      (if farbealt
       (progn
        (setf farbealt (sd-rgb-to-color farbealt))
       );;progn
       (progn
        (setf farbealt (sd-inq-part-color (sd-inq-parent-obj zielf)))
        (setf farbealt (sd-rgb-to-color farbealt))
       );;progn
      );;if
      (setf teile nil)
     );;let
    )
    (after-zielt-action ()
     (let ()
      (setf farbealt (sd-inq-part-color zielt))
      (setf farbealt (sd-rgb-to-color farbealt))
      (setf teile nil)
     );;let
    )
    (after-quellf-action ()
     (let ()
      (setf farbeneu (sd-inq-face-color quellf))
      (if farbeneu
       (progn
        (setf farbeneu (sd-rgb-to-color farbeneu))
       );;progn
       (progn
        (setf farbeneu (sd-inq-part-color (sd-inq-parent-obj quellf)))
        (setf farbeneu (sd-rgb-to-color farbeneu))
       );;progn
      );;if
      (setf teile nil)
     );;let
    )
    (after-quellt-action ()
     (let ()
      (setf farbeneu (sd-inq-part-color quellt))
      (setf farbeneu (sd-rgb-to-color farbeneu))
      (setf teile nil)
     );;let
    )
    (after-teile-action ()
     (let (teil tfarb ffarb fllist fl)
      (dolist (teil teile)
       (setf tfarb (sd-inq-part-color teil))
       (setf tfarb (sd-rgb-to-color tfarb))
       (when (or (eql tfarb farbealt) alle)
        (progn
         (sd-call-cmds (set_part_inst_color :parts (sd-inq-obj-pathname teil) :color farbeneu))
        );;progn
       );;when
      );;dolist
      (setf teile nil)
     );;let
    )
    (after-flaechen-action ()
     (let (ffarb fl)
      (dolist (fl flaechen tfarb)
       (setf ffarb (sd-inq-face-color fl))
       (if ffarb
        (progn
         (setf ffarb (sd-rgb-to-color ffarb))
         (when (and (or (eql ffarb farbealt) alle) (not (sd-inq-thread fl)))
          (sd-call-cmds (set_face_color fl farbeneu))
         );;when
        );;progn
        (progn
         (setf tfarb (sd-inq-part-color (sd-inq-parent-obj fl)))
         (setf tfarb (sd-rgb-to-color tfarb))
         (when (and (or (eql tfarb farbealt) alle) (not (sd-inq-thread fl)))
          (sd-call-cmds (set_face_color fl farbeneu))
         );;when
        );;progn
       );;if
      );;dolist
      (setf flaechen nil)
     );;let
    )
   )
:ok-action
   '()
)

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