;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;                                               for CoCreate SolidDesigner
;;  Description:
;;      unite an assembly to a single part (most of the time!)
;;
;;  Reference  : https://ww3.cad.de/foren/ubb/Forum29/HTML/004887.shtml
;;  Docu       : https://support.ptc.com/help/creo/ced_modeling/r20.2.0.0/fr/ced_modeling/baggage/documentation/integration_kit/comref/com-sd-int291.html#R-UNITE-3D
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  Filename   : cadde-29-004887.lsp
;;  Version    : 1.0 unites assemblies to one part each as structure minifier
;;  Created    : Fri Sep 30 17:30:42 CEST 2022
;;  Modified   : Sat Sep 30 18:45:04 CEST 2022
;;  Author     : der_Wolfgang@forum@cad.de
;;  Download   : cad.de
;;  SD-Version : developed with PE80
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(in-package :cadde-wt)
(use-package :OLI)

(sd-defdialog 'unite_assy2part
  :dialog-title '(sd-multi-lang-string "Unite asmb to part" :german "Baugruppe zu Teil verschmelzen")
  :toolbox-button :force
  :prompt-text (sd-multi-lang-string "Unite assembly to one part." :german "Baugruppe zu einem Teil verschmelzen.")
  :variables
    '(
      (assemblies
        :value-type :assembly
        :multiple-items t
        :show-select-menu t
        :modifies nil
        :title (sd-multi-lang-string "Assemblies" :german "Baugruppen")
        :gui-value (if (> (length assemblies) 4)
                     (format nil (sd-multi-lang-string "~D selected" :german "~D gewählt") (length assemblies))
                     (format nil "~{~S~^ ~}" (mapcar 'sd-inq-obj-pathname assemblies))
                     )
        :after-input (setq assemblies (delete-if '(lambda (a) (equal "/" (sd-inq-obj-pathname a))) assemblies))
      )
    )
  :ok-action '(let (new-name (postfix "_U") new-path)
               (dolist (a-asmb assemblies)
                 (setq new-name (sd-gen-obj-basename :part
                                  :parent (sd-inq-parent-obj a-asmb)
                                  :prefix (concatenate 'string (sd-inq-obj-basename a-asmb) postfix)
                                  ))
                 (setq new-path
                   (cond
                     ((not (sd-inq-parent-obj a-asmb)) "") ;; fallback = root
                      ((sd-inq-obj-parent-instance-read-only-p a-asmb) "") ;; fallback = root
                      (T (sd-inq-obj-pathname(sd-inq-parent-obj a-asmb))) ;; same parent possible
                     ))
                 (setq new-path (concatenate 'string new-path "/" new-name))
                 ; (pprint new-name) (pprint new-path)
                 (sd-call-cmds
                   (unite_3d :keep_tools :YES :glue :yes
                             :blank new-path
                             :tools :part :recursive :in_assembly a-asmb)
                   :failure (sd-display-error (sd-inq-error-obj :all))
                   )
                 )) ;; end dolist+let
   ) ;; end + dialog for testing