(in-package :my-custom)
(use-package :oli)


(sd-defdialog 'rename-shared-parts


 :dialog-title "Change names of parts/assemblies"


 :toolbox-button t


 :variables '(

  (selection
   :title "Part Assembly"
   :selection (*sd-object-seltype*)
   :multiple-items t
   :prompt-text "Select part or assembly to rename."
   :initial-value nil)

  ("-")

  (custom-name
   :title "Custom name:"
   :value-type :string
   :after-input (if custom-name
                 (progn
                  (sd-set-variable-status 'remove-current-suffix :enable nil)
                  (sd-set-variable-status 'contents-name-as-prefix-fc :enable t))
                 (sd-set-variable-status 'contents-name-as-prefix-fc :enable nil))
   :initial-value nil)

  (contents-name-as-prefix-fc
   :title "Contents name as prefix"
   :value-type :boolean
   :initial-enable nil
   :toggle-type :wide-toggle
   :initial-value nil)

  ("-")

  (contents-name-as-prefix
   :title "Add contents name as prefix to instance name"
   :value-type :boolean
   :toggle-type :wide-toggle
   :after-input (if contents-name-as-prefix
                    (progn
                     (sd-set-variable-status 'remove-current-suffix :enable t)
                     (sd-set-variable-status 'contents-name-as-prefix-fc :enable nil))
                    (sd-set-variable-status 'remove-current-suffix :enable nil))
   :initial-value nil)

  (remove-current-suffix
   :title "(Try to) Remove instance name suffix"
   :value-type :boolean
   :toggle-type :wide-toggle
   :initial-enable nil
   :initial-value nil)

  ("-")

  (contents-name
   :title "Contents name"
   :value-type :boolean
   :toggle-type :wide-toggle
   :after-input (when contents-name
                 (sd-set-variable-status 'remove-current-suffix :enable nil)
                 (sd-set-variable-status 'contents-name-as-prefix-fc :enable nil))
   :initial-value nil)

  ("-")

  (one-level
   :title "One level"
   :value-type :boolean
   :toggle-type :wide-toggle
   :initial-value nil))


 :mutual-exclusion '(custom-name contents-name contents-name-as-prefix)


 :local-functions '(

  (next-action ()
   (when remove-current-suffix
    (sd-display-message "Removing existing suffixes could cause wrong names. Please check the names afterwards."))

   (dolist (child selection)
    (rename-to-base-or-custom-name
     :part-assembly child
     :custom-name custom-name
     :contents-name contents-name
     :contents-name-as-prefix contents-name-as-prefix
     :contents-name-as-prefix-fc contents-name-as-prefix-fc
     :one-level one-level
     :remove-current-suffix remove-current-suffix))))


 :ok-action '(sd-call-cmds (next-action))


 :help-action '(
  (display "Change names of Parts/Assemblies:")
  (display " ")
  (display "Changes name(s) of the specified parts and/or assemblies according")
  (display "to their contents name, if it exists or to a custom name.")
  (display " ")))



(defun rename-to-base-or-custom-name (&key
 part-assembly
 custom-name
 contents-name-as-prefix
 contents-name-as-prefix-fc
 contents-name
 one-level
 remove-current-suffix)

 (when
  (or
   (sd-inq-part-p part-assembly)
   (sd-inq-assembly-p part-assembly)
   (sd-inq-container-p part-assembly))

    (setq pathname (sd-inq-obj-pathname part-assembly))

    (when (sd-string/= pathname "/")
     (let (
      new-name
      (part-contents-name (sd-inq-obj-contents-name part-assembly)))

       (cond
        ((and custom-name contents-name-as-prefix-fc part-contents-name)
          (setq new-name (format nil "~a_~a" part-contents-name custom-name)))
        (custom-name
         (setq new-name custom-name))
        ((and part-contents-name contents-name-as-prefix)
          (let (
           (part-instance-name (sd-inq-obj-basename part-assembly)))
            (if remove-current-suffix
             (setq new-name
              (format nil "~a_~a"
               part-contents-name
               (remove-suffix-from-basename
                :item-name part-instance-name)))
             (setq new-name
              (format nil "~a_~a"
               part-contents-name
               part-instance-name)))))
        ((and contents-name part-contents-name)
          (setq new-name part-contents-name))
        (t nil))

       (when new-name
        (let (
         new-name-incl-suffix
         (owner (sd-inq-parent-obj part-assembly)))

          (unless owner
           (setq owner (sd-pathname-to-obj "/")))

          (setq new-name-incl-suffix
           (add-name-suffix
            :owner owner
            :part-assembly part-assembly
            :name new-name))

          (unless (sd-inq-obj-parent-contents-read-only-p part-assembly)
           (sd-call-cmds (change_name_pa :part_asmb pathname :name new-name-incl-suffix)))))

       (unless one-level
        (let (
         (children (sd-inq-obj-children part-assembly)))

         (dolist (child children)
          (rename-to-base-or-custom-name
           :part-assembly child
           :custom-name custom-name
           :contents-name-as-prefix-fc contents-name-as-prefix-fc
           :contents-name contents-name
           :one-level one-level
           :contents-name-as-prefix contents-name-as-prefix
           :remove-current-suffix remove-current-suffix))))))))



(defun add-name-suffix (&key owner part-assembly name)
 (let (
  new-name
  basename
  (index 0)
  (basename-list (list))
  (child-list (sd-inq-obj-children owner)))

   (dolist (child child-list)

    (when
     (or
      (sd-inq-part-p child)
      (sd-inq-assembly-p child)
      (sd-inq-container-p child))

     (unless (equal child part-assembly)
      (setf basename (sd-inq-obj-basename child))
      (setf basename-list (nconc basename-list (list basename))))))

   (loop

    (incf index)

    (setq new-name (format nil "~a.~10,2,'0,'0r" name index))

    (unless (member new-name basename-list :test #'equal)
     (return t)))

    (values new-name)))


(defun remove-suffix-from-basename (&key item-name)
 (let (
  brk
  (new-name-list '())
  (name-splitted-list (sd-string-split item-name ".")))

    (dolist (name-segment (reverse name-splitted-list))

     (when (or (not (integerp (read-from-string name-segment))) brk)
      (setq brk t)
      (push name-segment new-name-list)))

    (if (null new-name-list)
     (first name-splitted-list)
     (format nil "~{~a~^.~}" new-name-list))))