From bef3dad92922fbd261267221df349f3d2569b720 Mon Sep 17 00:00:00 2001 From: Thomas Albers Date: Sun, 24 Jul 2022 12:21:29 +0200 Subject: Initial commit --- autotag.lisp | 187 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 187 insertions(+) create mode 100755 autotag.lisp (limited to 'autotag.lisp') diff --git a/autotag.lisp b/autotag.lisp new file mode 100755 index 0000000..2199203 --- /dev/null +++ b/autotag.lisp @@ -0,0 +1,187 @@ +;; autotag +;; Copyright (C) 2020 Thomas Albers Raviola + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;; musicbrainz supported requests +;; lookup: //?inc= +;; browse: /?=&limit=&offset=&inc= +;; search: /?query=&limit=&offset= + +(in-package #:autotag) + +(defvar *path-replacements* + '(" " "_" + "/" "_")) + +(defvar *title-replacements* + '("…" "..." + "å" "a" + "’" "'" + "ö" "o" + "Ö" "O" + "ä" "a" + "Ä" "A" + "ü" "u" + "Ü" "U")) + +(defun release< (release1 release2) + (let ((t1 (release-title release1)) + (t2 (release-title release2))) + (if (string-not-equal t1 t2) + (or (not (string-equal t1 *album-name*)) + (string-equal t2 *album-name*) + (string> t1 t2)) + (string< (release-date release1) (release-date release2))))) + +(defun select-release (release-list) + (flet ((printer (release) + (format nil "artist: ~A~30Trelease: ~A~70Ttrack count: ~A~76Tdate: ~A" + (release-artist release) + (release-title release) + (release-track-count release) + (release-date release)))) + (setf release-list (sort (copy-seq release-list) #'release<)) + (dmenu release-list + :lines (length release-list) + :printer #'printer + :prompt (format nil "~A (~A files):" *album-name* *npathnames*)))) + +(defun tags-from-release (release) + (let ((global-tag `(:album ,(release-title release) + :date ,(release-date release) + :artist ,(release-artist release)))) + (flet ((tag-from-track (tr) + (apply #'make-tag + `(:title ,(track-title tr) + :track ,(track-position tr) + :keywords ,(track-keywords tr) + ,@global-tag)))) + (mapcar #'tag-from-track (plump:get-elements-by-tag-name release "track"))))) + +(defun choose-tag (pathname tags) + "Choose a tag for a given file, ask user if needed" + (let ((k1 (keywords (pathname-name pathname)))) + (flet ((tag-printer (tag) + (princ-to-string (tag-title tag))) + (tag-key (tg) + (let ((k2 (tag-keywords tg))) + (/ (length (set-difference k2 k1 :test #'string-equal)) + (length k2))))) + (or (find (pathname-name pathname) tags + :key #'tag-title + :test #'string-equal) + (progn (setf tags (sort (copy-seq tags) #'< :key #'tag-key)) + (dmenu tags + :printer #'tag-printer + :lines (length tags) + :prompt (pathname-name pathname))))))) + +(defun rename-file2 (pathname new-pathname) + (info "~&Renaming ~A to ~A~%" pathname new-pathname) + (rename-file pathname (concatenate 'string (pathname-name new-pathname) + "." (pathname-type new-pathname)))) + +(defun sanitize-pathname (pathname) + (str:replace-using + (append *path-replacements* + *title-replacements*) + (remove-if #'(lambda (x) + (member x '(#\? #\* #\{ #\} #\. #\?))) + pathname))) + +(defun apply-tag (pathname tag) + (unless tag + (info "~&No tag could be found for ~A, skipping ...~%" pathname) + (return-from apply-tag nil)) + (when *rename-p* + (let ((new-pathname (make-pathname :directory (pathname-directory pathname) + :name (sanitize-pathname (tag-title tag)) + :type (pathname-type pathname)))) + (if (probe-file new-pathname) + (info "~&File already exists, not renaming: ~A~%" new-pathname) + (setf pathname (rename-file2 pathname new-pathname))))) + (info "~&Writing tags to: ~A~%" pathname) + (write-ogg-tags pathname tag)) + +(defun apply-tags (pathnames tags) + (dolist (pathname pathnames) + (apply-tag pathname (choose-tag pathname tags)))) + +(defun apply-tags-in-order (pathnames tags) + (flet ((tag-position-number (tr) + (parse-integer (track-position tr)))) + (setf tags (sort tags #'< :key #'tag-position-number)) + (loop :for pathname :in pathnames + :for tag :in tags + :do + (apply-tag pathname tag)))) + +(defun get-tags (title artist) + (let* ((release (select-release (search-release title artist)))) + (cond (release + (tags-from-release + (lookup-release + (plump:get-attribute release "id")))) + (t + (info "~&No release for ~A selected, skipping ...~%" + *album-name*) + nil)))) + +(defun expand-directories (pathname) + (if (eq (osicat:file-kind pathname) :directory) + (osicat:list-directory pathname) + (list pathname))) + +(defun autotag (argv) + (multiple-value-bind (options files) + (getopt argv *valid-cmd-line-args*) + (when (assoc :help options) + (help)) + (when (assoc :quiet options) + (setf *quiet-p* t)) + (when (assoc :order options) + (setf *order-p* t)) + (when (assoc :dont-rename options) + (setf *rename-p* nil)) + (when (assoc :album options) + (setf *album-name* (assoc-value options :album))) + (when (assoc :artist options) + (setf *album-artist* (assoc-value options :artist))) + (when (assoc :id options) + (let ((release (select-release (search-release *album-artist* *album-name*)))) + (princ (and release (plump:get-attribute release "id"))) + (terpri))) + (let* ((pathnames (mappend #'expand-directories + (if (null files) + (list *album-name*) + files))) + (*npathnames* (length pathnames)) + (tags (if (assoc :use-id options) + (tags-from-release + (lookup-release (assoc-value options :use-id))) + (get-tags *album-name* *album-artist*)))) + (when tags + (cond (*order-p* + (apply-tags-in-order pathnames tags)) + (*print-tags-p* + (mapc #'print-tag tags)) + (t + (apply-tags pathnames tags))))))) + +(defun main () + (handler-case + (autotag (uiop:command-line-arguments)) + (sb-sys:interactive-interrupt () (uiop:quit))) + (uiop:quit)) -- cgit v1.2.3