;; 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 <http://www.gnu.org/licenses/>.
;; musicbrainz supported requests
;; lookup: /<ENTITY_TYPE>/<MBID>?inc=<INC>
;; browse: /<RESULT_ENTITY_TYPE>?<BROWSING_ENTITY_TYPE>=<MBID>&limit=<LIMIT>&offset=<OFFSET>&inc=<INC>
;; search: /<ENTITY_TYPE>?query=<QUERY>&limit=<LIMIT>&offset=<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))
