Play music file for wtag.

playall.el

;;; playall.el -- Play music file for wtag.
;; Copyright (C) 2023 fubuki

;; Author: fubuki at frill.org
;; Version: @(#)$Revision: 1.28 $
;; Keywords: multimedia

;; 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.

;; 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 GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; * wtag 上の再生機能を拡張します
;; `wtag-view-mode' 上から `数値 P' でそのトラック番号を再生.
;; [fn::表記上スペースで切っていますが実際は不要です]
;; これに加え `0 P' で全曲通して, マイナス値で全曲からシャッフルになります.
;; `- P' のようにマイナスのみで OK です.
;; 再生中は `M-n' で次のトラックに飛び 'C-c C-c' で停止です.

;; プレイヤーの設定は変数 `wtag-music-players' を引き継ぎますが
;; `playall-players' でオーバーライドできます.

;; * 通常ディレクトリからの再生
;; 作ってみて、たれ流したいだけなら wtag 上からじゃなくてもいいじゃんと気づき
;; 通常の directory から実行する `directory-playall' もあります.
;; [fn::もっと云えば(呼び出している)mpg123 だけでいいじゃん...とも云います]

;; マイナーモードになり 停止: `C-c [ k' 次曲: `C-c [ n' 等となります.
;; `wtag-playall' と併用した場合の擦り合せがまだ甘いかもしれないです.

;; : M-x directory-playall
;; : C-u M-x directory-playall ;; Shuffle

;;; Installation:

;; (require 'playall)

;;; Change Log:

;; revision 1.28 date: 2023-04-26 14:12:53+09
;; - add: 非対応ファイルをエラーハンドリングする.
;; - fix: wtag.el の `wtag-writable-tag-hook' で `playall-kill' を実行.
;;  wtag でライトモードにしたとき、そのときの音楽は停止するが、
;;  シェードが剥されなかったり、タイマー待ちの次が再生されたりするバグがあったのをこれで修正.

;;; Code:
(require 'cl-lib)
(require 'wtag)

(defface playall-shade
  '((t :inherit dired-ignored))
  "Wtag playall shade face."
  :group 'wtag-faces)

(define-key wtag-view-mode-map [remap wtag-music-play] #'wtag-playall)
(define-key wtag-view-mode-map [remap wtag-kill-process] #'playall-kill)
(define-key wtag-view-mode-map "\C-c\C-s" #'playall-stop)
(define-key wtag-view-mode-map "\M-n" #'playall-next)

(add-hook 'wtag-view-mode-hook
          #'(lambda ()
              (define-key-after
                (lookup-key wtag-view-mode-map [menu-bar wtag])
                [play-next]
                '(menu-item "Next Play" playall-next :key-sequence "\M-n")
                'wtag-music-play)))

;; (add-hook 'wtag-quit-hook #'playall-kill)
(add-hook 'wtag-writable-tag-hook #'playall-kill)

;; Configurations.
(defvar playall-play-mode-invert nil)
(defvar playall-players
  (if (boundp 'wtag-music-players) wtag-music-players '("\\.mp3\\'" "mpg123")))
(defvar playall-format " `%a - %t (%T)'"
  "Special characters:
%f File Name
%T Play Time (variable `playall-time-format')
%C Codec
%B Bit rate
%A Album Title
%a Artist Name
%t Track Title
%n Track Number
%g Genre
%y Release Year
%% %")
(defvar playall-time-format "%m'%02s\"")

(defvar playall-init-after-hook nil)
(defvar playall-kill-hook       nil)

;; Work Variables.
(defvar playall-style nil)
(defvar playall-title nil)
(put 'playall-title 'risky-local-variable t)
(defvar playall-overlays  nil)
(make-variable-buffer-local 'playall-overlays)

(defun playall-pget (prop)
  "`playall-style' から PROP を得る."
  (plist-get playall-style prop))

(defun playall-pset (prop var)
  "`playall-style' の PROP に VAR をセット.
PROP が既に在れば更新され無ければ作られる."
  (setq playall-style (plist-put playall-style prop var)))

(defun playall-directory-style-p ()
  "`playall-style' のプロパティ :style の値が directory ならば non-nil."
  (eq (playall-pget :style) 'directory))

(defun playall-cancel-timer ()
  "`playall-style' にプロパティ :timer があればそのタイマーをキャンセルする."
  (and (playall-pget :timer) (cancel-timer (playall-pget :timer))))

(defun playall-pget-music-tags (mark)
  "MARK が non-nil ならポイントから *pos を追加して stat プロパティを戻す."
  (let ((stat (get-text-property (point) 'stat)))
  (and mark stat (cons `(*pos nil . ,(point)) stat))))

(defun playall-tags-buffer (mode)
  "`wtag-view-mode' buffer から MODE 番号のトラックのタグリストのリストを戻す.
変数 `wtag-music-play-next' がセットされていれば、
最後に次のトラックへポイントを進める.
MODE が 0 以下ならすべてのファイルのリストを戻す.
すべての場合マークがあればそれのみが対象となる."
  (let ((mark-buff (wtag-buffer-mark-p "*"))
        album files)
    (cond
     ((< mode 1) ;; all files.
      (save-excursion
        (if (zerop mode)
            (beginning-of-line)
          (goto-char (point-min)))
        (while (not (eobp))
          (push (playall-pget-music-tags
                 (or (null mark-buff) (wtag-mark-p "*")))
                files)
          (forward-line))))
     (t
      (goto-char (point-min))
      (while (wtag-common-area-p)
        (forward-line))
      (forward-line -1)
      (while (< 0 mode)
        (forward-line)
        (setq mode (1- mode)))
      (push (playall-pget-music-tags t) files)
      (when wtag-music-play-next
        (when (numberp wtag-music-play-next)
          (sleep-for wtag-music-play-next))
        (forward-line))))
    (reverse (delq nil files))))

(defvar playall-now nil "Work variable.")
(define-fringe-bitmap 'playall-fringe [128 192 224 240 248 252 254 255])
(defface playall-now
  '((t :inherit font-lock-constant-face))
  "Playall now mark face."
  :group 'playall-faces)

(defface playall-mode-line nil
  "Playall mode line face."
  :group 'playall-faces)

(defun playall-shade (pos)
  "POS に日除けをおろす."
  (unless (playall-directory-style-p)
    (save-excursion
      (with-current-buffer (playall-pget :buffer)
        (let (beg end)
          (goto-char pos)
          (setq beg (line-beginning-position)
                end (line-end-position))
          (and playall-now (delete-overlay playall-now))
          (setq playall-now (make-overlay beg (1+ beg)))
          (overlay-put
           playall-now 'before-string
           (propertize "." 'display '(left-fringe playall-fringe playall-now)))
          (overlay-put
           (caar
            (setq playall-overlays
                  (cons
                   (list
                    (make-overlay beg end  (current-buffer))
                    beg end)
                   playall-overlays)))
           'face 'playall-shade))))))

(defun playall-reshade ()
  "日除け位置が壊れたときの再調整."
  (dolist (ov playall-overlays)
    (move-overlay (car ov) (nth 1 ov) (nth 2 ov))))

(defun playall-shuffle (lst)
  "LST をシャッフルした新たなリストを戻す."
  (let (result)
    (random t)
    (while lst
      (push (nth (random (length lst)) lst) result)
      (setq lst (cl-remove (car result) lst :test #'equal :count 1)))
    result))

(defun playall-at-pos ()
  "`wtag-vuew-mode' バッファのポイントが指しているトラック番号を戻す.
トラック位置になければトラック1を戻す."
  (if (wtag-common-area-p)
      1
    (1+ (- (line-number-at-pos) wtag-beginning-line-of-track))))

;;;###autoload
(defun playall-stop ()
  "プロセスを停止するが残りの Play list をクリアしない.
C-u \\[playall-kill] と等価."
  (interactive)
  (playall-kill 'keep))

;;;###autoload
(defun playall-kill (&optional prefix final)
  "`wtag-process-name' の後始末.
PREFIX が在れば再開時継続利用する変数は初期化しない.
FINAL が non-nil なら `playall-kill-hook' を実行する.'"
  (interactive "P")
  (let ((ps wtag-process)
        (kill "Stop"))
    (and (get-process wtag-process-name)
         (delete-process (get-process wtag-process-name)))
    (setq wtag-process nil)
    (playall-cancel-timer)
    (and (memq 'playall-title global-mode-string)
         (setq global-mode-string
               (delq 'playall-title global-mode-string)))
    (setq playall-title nil)
    (playall-pset :timer nil)
    (unless prefix
      (playall-pset :buffer    nil)
      (playall-pset :directory nil)
      (playall-pset :next      nil)
      (dolist (ov playall-overlays)
        (delete-overlay (car ov)))
      (and playall-now (delete-overlay playall-now))
      (setq playall-overlays nil
            kill "Kill"))
    (or (playall-directory-style-p)
        (remove-hook 'wtag-init-hook #'playall-reshade))
    (and final (run-hooks 'playall-kill-hook))
    (and ps (message "%s music play process." kill))))

(defun playall-init (mode)
  "MODE に トラックナンバーを指定しテーブルをイニシャライズ.
0 なら総トラック, 負ならシャッフルで初期化される."
  (let ((mode (if playall-play-mode-invert
                  (cond ((zerop mode) -1) ((< mode 0) 0) (t mode))
                mode))
        (func (if (playall-directory-style-p)
                  #'playall-tags-directory
                #'playall-tags-buffer)))
    ;; (and wtag-process (playall-kill))
    (and (playall-pget :process) (playall-kill))
    (playall-pset :buffer (or (playall-pget :buffer) (current-buffer)))
    (playall-pset :directory (or (playall-pget :directory) default-directory))
    (or (playall-pget :next)
        (playall-pset :next
                     (if (> 0 mode)
                         (playall-shuffle (funcall func mode))
                       (funcall func mode))))
    (or (playall-directory-style-p)
        (add-hook 'wtag-init-hook #'playall-reshade))))

(defun playall-assq-cddr (sym lst)
  "LST 中の SYM の cdr の cdr を返す."
  (cddr (assq sym lst)))

(defun playall-read-tags (file)
  "FILE の tag list を戻す list には `filename' tags が追加される."
  (let ((result (mf-tag-read-alias file (mf-read-size file) t)))
    (cons `(filename nil . ,file) result)))

(defun playall-tags-directory (mode)
  "`mf-lib-suffix-all' にマッチするファイル名をリストで戻す.
MODE を見ている箇所は今は使われていないが暫定的に残されている."
  (let ((result (directory-files
                 default-directory t (mf-re-suffix mf-lib-suffix-all))))
    (if (< 0 mode)
        (catch 'out
          (dolist (a result)
            (if (string-match
                 "\\`0?[0-9][0-9]?[- _]" (file-name-nondirectory a))
                (throw 'out (list a)))))
      result)))

(defun playall-tags-directory-rec (&optional dummy)
  "`playall-tags-directory' の再帰版.
DUMMY はダミー."
  (directory-files-recursively default-directory (mf-re-suffix mf-lib-suffix-all)))

(defun playall-process-buffer ()
  "Process log buffer を開く."
  (interactive)
  (pop-to-buffer wtag-process-name)
  (playall-log-mode))

(defun playall-spec ()
  "`playall-format' にで使うスペシャルキャラのテーブル."
  (with-no-warnings
    `((?f . ,file)
      (?T . ,(wtag-format playall-time-format  time))
      (?C . ,codec)
      (?B . ,brate)
      (?A . ,album)
      (?a . ,artist)
      (?t . ,title)
      (?n . ,track)
      (?g . ,genre)
      (?y . ,year)
      (?% . "%"))))

(defvar playall-id2codec-table
  '(("ID3\1" . "mp3") ("ID3\2" . "mp3") ("ID3\3" . "mp3") ("ea3\3" . "oma")))

(defun playall-id2codec (id)
  "コーデック ID の変名を戻す."
  (or (assoc-default id playall-id2codec-table) id))

(defun playall-music-directory (dir)
  "DIR に `playall-players' に設定された拡張子のファイルが在れば t."
  (and (file-accessible-directory-p dir)
       (catch 'out
         (dolist (regexp (mapcar #'car playall-players))
           (if (directory-files dir t regexp)
               (throw 'out t))))))

;;;###autoload
(defun playall-next ()
  "次のトラックを再生."
  (interactive)
  (playall-cancel-timer)
  (if (playall-pget :next)
      (playall 0)
    (error "No next music")))

;;;###autoload
(defalias 'dpall #'directory-playall)

;;;###autoload
(defun directory-playall (dir &optional prefix)
  "DIR 下の `mf-lib-suffix-all' を Play all.
PREFIX で Shuffle."
  (interactive
   (let* ((dir (playall-pget :directory)))
     (setq dir
           (if (or (null dir) (not (equal dir default-directory)))
               (read-directory-name "Directory: ")
             dir))
     (list dir current-prefix-arg)))
  (when (or (null (playall-pget :next))
            (not (eq (playall-pget :directory) dir)))
    (playall-kill))
  (playall-pset :style 'directory)
  ;; (playall-pset :directory dir)
  (unless (playall-music-directory dir) (error "No music file"))
  (playall-minor-mode 1)
  (playall (if prefix -1 0) t))

;;;###autoload
(defun wtag-playall (prefix)
  "`wtag-view-mode' で Play all.
PREFIX で Shuffle."
  (interactive
   (list (and current-prefix-arg
              (prefix-numeric-value current-prefix-arg))))
  (let ((next (playall-pget :next)))
    (when (or (null next)
              (not (eq (playall-pget :buffer) (current-buffer))))
      (playall-kill)
      (setq next nil))
    (playall-pset :style 'wtag)
    ;; (playall-pset :buffer (current-buffer))
    (when (and next (and prefix (< 1 prefix)))
      (goto-char (point-min))
      (forward-line (+ prefix wtag-beginning-line-of-track)))
    (playall (or (if next 0 prefix) (playall-at-pos)) t)))

(defun playall-filter (prc str)
  "エラーハンドラフィルタ.
PRC 番号と STR."
  (if (string-match "error: .+valid MPEG header" str)
      (progn
        (playall-kill)
        (message "%s had the event '%s'" prc str))
    (when (buffer-live-p (process-buffer prc))
      (with-current-buffer (process-buffer prc)
        (let ((pos (= (point) (process-mark prc)))
              buffer-read-only)
          (save-excursion
            (goto-char (process-mark prc))
            (insert str)
            (set-marker (process-mark prc) (point)))
          (if pos (goto-char (process-mark prc))))))))

;;;###autoload
(defun playall (&optional mode init)
  "`wtag-view-mode' の曲を `playall-players' で設定されたアプリで再生.
MODE 番号のトラックを再生する.省略するとトラック 1になる.
0 ならすべてのトラックを連続再生し、マイナス値ならシャッフルプレイする.
INITが non-nil なら強制的に初期化.
関数起動(つまりノンインタラクティブ)で初期化するために使用する."
      (interactive
       (let ((mode (if (null current-prefix-arg)
                       (playall-at-pos)
                     (prefix-numeric-value current-prefix-arg))))
         (playall-init mode)
         (list mode)))
      (playall-cancel-timer)
      (and init (playall-init mode))
      (run-hooks 'playall-init-after-hook)
      (when global-mode-string
        (or (memq 'playall-title global-mode-string)
            (setq global-mode-string
                  (append global-mode-string (list 'playall-title)))))
      (when (playall-pget :next)
        (let* ((stat   (car (playall-pget :next)))
               (stat   (if (atom stat) (playall-read-tags stat) stat))
               (file   (playall-assq-cddr 'filename stat))
               (time   (car (playall-assq-cddr '*time stat)))
               (codec  (playall-id2codec (playall-assq-cddr '*type stat)))
               (brate  (cadr (playall-assq-cddr '*time stat)))
               (album  (playall-assq-cddr 'album stat))
               (artist (playall-assq-cddr 'artist stat))
               (title  (playall-assq-cddr 'title stat))
               (track  (playall-assq-cddr 'track stat))
               (genre  (playall-assq-cddr 'genre stat))
               (year   (playall-assq-cddr 'year stat))
               (pos    (playall-assq-cddr '*pos stat))
               (app    (assoc-default file playall-players #'string-match))
               (prog   (car app))
               (opt    (cdr app))
               (name   wtag-process-name)
               (now    (format-spec playall-format (playall-spec))))
          (unless app (error "Invalid file `%s'" file))
          (setq playall-title
                (propertize
                 now
                 'face 'playall-mode-line
                 'help-echo now
                 'local-map
                 (make-mode-line-mouse-map 'mouse-1 #'playall-minor-mode-menu-map)
                 'mouse-face 'mode-line-highlight))
          (playall-pset :next (cdr (playall-pget :next)))
          (and (get-process wtag-process-name)
               (delete-process wtag-process-name))
          (setq wtag-process
                (progn
                  (message "%s" playall-title)
                  (and (> 1 mode) (playall-shade pos))
                  (apply #'start-process name name prog (append opt (list file)))))
          (set-process-filter wtag-process #'playall-filter)
          (playall-pset :timer
                       (if (playall-pget :next)
                           (run-with-timer time nil #'playall mode)
                         (run-with-timer time nil #'playall-kill nil 'final))))))


(defvar playall-minor-mode-menu-map
  (let ((menu (make-sparse-keymap "Playall Minor Mode")))
    (define-key menu [playall-process-buffer] '("Log" . playall-process-buffer))
    (define-key menu [playall-kill] '(menu-item "Kill" playall-kill))
    (define-key menu [playall-stop] '(menu-item "Stop" playall-stop))
    (define-key menu [playall-next] '("Next" . playall-next))
    (define-key menu [directory-playall] '("Play" . directory-playall))
    menu))

(fset 'playall-minor-mode-menu-map playall-minor-mode-menu-map)

(defvar playall-minor-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map "\C-c[n" #'playall-next)
    (define-key map "\C-c[s" #'playall-stop)
    (define-key map "\C-c[k" #'playall-kill)
    (define-key map "\C-c[l" #'playall-process-buffer)
    (define-key map "\C-c[p" #'directory-playall)
    (define-key map [menu-bar play] (cons "Playall" playall-minor-mode-menu-map))
    map))

(define-minor-mode playall-minor-mode
  "Playall Minor Mode."
  :global t :group 'music-file :lighter " Playall")

(defvar playall-log-mode-font-lock
  '(("\\([A-Z][a-z]+:\\)[ ]" 1 'link)))

(define-derived-mode playall-log-mode fundamental-mode "Play-log"
  "Play log mode."
  (setq-local font-lock-defaults (list playall-log-mode-font-lock))
  (define-key playall-log-mode-map "q" #'quit-window))

(provide 'playall)
;;; playall.el ends here