Category Archives: 未分類

2023-04-13 Emacs

image-diredの改善

(2023-08-08追記: Emacs 29.1に合わせてコードを修正しました)

皆さんはimage-dired使ってますか？　私は使っていませんでした。だって大量の画像を扱える専門のソフトがあるのにわざわざEmacsでやる必要なんて無いじゃないですか。Diredから外部ビューアを起動して後はそっちでやっていたのです。

しかし有名なビューアをいくつか使ってきましたが常にどこか不満を感じていました。似たようなソフトが沢山乱立している状況を見るに、それだけ皆を満足させるのは難しいということなのかもしれません。

やりたいことは、大量の画像(数千枚で似たような画像も沢山ある)の中から良さそうなものを選び出し、タグ付けしたりコメントを書いたりして整理する作業です。その後にその情報を使用してレポートを作ったりするわけです。単に画像が見られれば良いのではありません。もちろんそのような機能を持つビューアはあります。しかし自分に合ったキー操作で効率的にできるものはなかなか見つかりません。ほんの些細な機能が無くて不満を抱くケースも多いです。

自分で作れば良いのかもしれませんが(単に見るだけの特定の用途のためのものなら以前作りました)、編集機能を有するものを0から作るのもなかなか大変です。

色々な方法があるとは思いますが、今の私が一番気軽に扱えるのは結局Emacsなのでimage-diredを改良して少しは使いやすくなればと思い色々いじってみました。

Windowsでの設定
(dired内)サムネイルの幅を揃えて、右に空白を入れ、境界線を引く
(dired内)サムネイルを一括で表示/非表示する
(dired内)dired-details-rのレイアウトが乱れるのを直す
(dired内)ファイルの削除や移動でサムネイルが消えずに残るのを直す
(dired内)C-t iで開いたウィンドウを簡単に閉じる
(dired内)全画像ファイルをサムネイルバッファで表示する
(サムネイルバッファ内)Uでマークを全解除する
外部ツールで表示するときにw32-shell-executeを使う
(dired内)ファイルに対応するサムネイルバッファ内の位置へジャンプする
コードまとめ

Windowsでの設定

image-diredを使うにはImageMagickが必要です。WindowsではCygwinなりMSYS2なり公式ビルドなりwingetなり好きな方法でインストールすることが可能でしょう。私はデスクトップPCではCygwin、ノートではMSYS2のものを使っています。

ここで良くあるトラブルが間違ったconvertコマンドを参照してしまうということです。Windowsには c:/Windows/System32/convert.exe というコマンドがあるのでPATHの設定次第ではそちらが優先されてしまいます。

絶対パスで指定し直しても良いのですが、私は次のようにしてconvertコマンドの代わりにmagickコマンドを使うようにしてみました。

(when (eq system-type 'windows-nt)
  (with-eval-after-load "image-dired"
    (setq image-dired-cmd-create-thumbnail-program "magick"
          image-dired-cmd-create-temp-image-program "magick")
    (unless (equal (car image-dired-cmd-create-thumbnail-options) "convert")
      (push "convert" image-dired-cmd-create-thumbnail-options))
    (unless (equal (car image-dired-cmd-create-temp-image-options) "convert")
      (push "convert" image-dired-cmd-create-temp-image-options))))

magick convert と magick はImageMagickのv6構文とv7構文の違いらしくそこまで大きく変わらないらしいので単に～-programを magick にするだけでも大丈夫なのかもしれませんが、念のため～-optionsの頭に convert を追加しています。

それにしてもWindowsにせよImageMagickにせよconvertというコマンド名はなかなか酷いですね。コマンドラインなんてだいたいの処理は何かしら変換するものでしょうに。ちなみにWindowsのconvertコマンドはFATボリュームをNTFSにするんだそうです。私は一回も使ったことがありません。

(dired内)サムネイルの幅を揃えて、右に空白を入れ、境界線を引く

image-diredはdiredバッファの中に直接サムネイルを表示できます。画像ファイルの上で(または複数マークしてから)C-t C-tと押すとファイル名の直前にサムネイル画像が表示されます。

仕組みとしては、まずサムネイル画像を参照するオーバーレイをDiredバッファに挿入してから(黒い正方形の四角が表示される)、非同期でサムネイルを作成するプロセスを起動し、完了したらEmacsの画像キャッシュをフラッシュすることで正しいサムネイルが表示されるという流れになっています。サムネイルはデフォルトでは ~/.emacs.d/image-dired/ 以下に作られるようです。最初から既にサムネイルがある場合はすぐに表示されます。

やってみると分かるのですが、確かにサムネイルは表示されるのですがサムネイル画像の幅が揃っていません。また、その後に続くファイル名との間に空白が無く完全にくっついてしまっています。そして境界線が無いので、Emacs内の背景色と同じ色(私の場合黒)が主体の画像だと画像の輪郭が把握できません。

次のコードはそれを解決するものです。

(defun my-image-dired-dired-toggle-marked-thumbs (&optional arg)
  ;; Derived from `image-dired-dired-toggle-marked-thumbs'
  "Toggle thumbnails in front of file names in the Dired buffer.
If no marked file could be found, insert or hide thumbnails on the
current line.  ARG, if non-nil, specifies the files to use instead
of the marked files.  If ARG is an integer, use the next ARG (or
previous -ARG, if ARG<0) files."
  (interactive "P")
  (dired-map-over-marks
   (my-image-dired-dired-set-thumb-visibility 'toggle) ;;ファイル毎の処理を分離
   arg             ; Show or hide image on ARG next files.
   'show-progress) ; Update dired display after each image is updated.
  (add-hook 'dired-after-readin-hook
            'image-dired-dired-after-readin-hook nil t))

(defun my-image-dired-dired-set-thumb-visibility (visibility)
  ;; Derived from `image-dired-dired-toggle-marked-thumbs'
  (let ((image-pos  (dired-move-to-filename))
        (image-file (dired-get-filename nil t)))
    (when (and image-file
               (string-match-p (image-dired--file-name-regexp) image-file)) ;; Emacs28までは(image-file-name-regexp)
      (let* ((thumb-file
              ;; Emacs 28まで
              ;;(image-dired-get-thumbnail-image image-file)
              ;; Emacs 29から
              (create-image
               (image-dired--get-create-thumbnail-file image-file)))
             (thumb-ov (cl-loop for ov in (overlays-in (point) (1+ (point)))
                                if (overlay-get ov 'thumb-file) return ov)))
        ;; 後述の改良のためにトグル以外もできるようにした
        (if thumb-ov
            (when (memq visibility '(nil toggle))
              (delete-overlay thumb-ov))
          (when (memq visibility '(t toggle))
            (my-image-dired-dired-create-thumbnail-overlay
             image-pos image-file thumb-file)))))))

(defun my-image-dired-dired-create-thumbnail-overlay (image-pos image-file thumb-file)
  ;; Derived from `image-dired-dired-toggle-marked-thumbs'
  (let ((overlay (put-image
                  ;; 枠線を付加
                  (append thumb-file (list :relief 1))
                  image-pos)))
    (overlay-put overlay 'image-file image-file)
    (overlay-put overlay 'thumb-file thumb-file)
    ;; 幅を揃える
    (my-image-dired-dired-update-thumbnail-overlay overlay thumb-file)
    overlay))

(defun my-image-dired-dired-update-thumbnail-overlay (ov image)
  (when-let ((image-file (plist-get (cdr image) :file)))
    (let* ((image-exists-p (file-exists-p image-file))
           (image-size (image-size image t)) ;;float?
           (space-w
            (if image-exists-p
                ;; Emacs 28まで
                ;;(- image-dired-thumb-width (car image-size))
                ;; Emacs 29から
                (- image-dired-thumb-size (car image-size))
              0))
           (space-left (ceiling (/ space-w 2)))
           (space-right (+ 10 ;;space after thumbnail
                           (- space-w space-left))))
      (overlay-put ov 'before-string
                   ;; 元々のbefore-stringの前後にマージン(スペース)を入れる
                   (concat
                    (propertize "_" 'display `(space :width (,space-left)))
                    (overlay-get ov 'before-string)
                    (propertize "_" 'display `(space :width (,space-right))))))))

(with-eval-after-load "dired"
  (define-key dired-mode-map [remap image-dired-dired-toggle-marked-thumbs] 'my-image-dired-dired-toggle-marked-thumbs))

元の image-dired-dired-toggle-marked-thumbs は、サムネイル画像の取得からオーバーレイの作成、削除までをすべてこの中だけで行ってしまいます。オーバーレイ作成部分だけを書き替えるのは難しいため、大人しく関数全体を独自のものに差し替えて解決することにしました。

(dired内)サムネイルを一括で表示/非表示する

C-t C-tは現在のポイントにあるファイルか、またはマークしたファイルをサムネイル表示します。全ての画像を一括で表示するにはいちいち全マークしなければなりません。それにこれはtoggle動作です。一部をすでにサムネイル表示した後に全画像をマークしてC-t C-tすると今表示されているものは消えてしまいます。単純に全画像ファイルのサムネイルを一括で表示したり消したりしたいです。

次のコードはそれを実現するための三つ(全表示、全消去、トグル)のコマンドを定義します。

(defun my-image-dired-dired-toggle-all-thumbs ()
  (interactive)
  (if (cl-loop for ov in (overlays-in (point-min) (point-max))
               when (overlay-get ov 'thumb-file) return t)
      (my-image-dired-dired-hide-all-thumbs)
    (my-image-dired-dired-show-all-thumbs)))

(defun my-image-dired-dired-hide-all-thumbs ()
  (interactive)
  (cl-loop for ov in (overlays-in (point-min) (point-max))
           when (overlay-get ov 'thumb-file)
           do (delete-overlay ov)))

(defun my-image-dired-dired-show-all-thumbs (&optional hide)
  (interactive "P")
  (if hide
      (my-image-dired-dired-hide-all-thumbs)
    (add-hook 'dired-after-readin-hook
              'image-dired-dired-after-readin-hook nil t)
    (if (my-image-dired-confirm-generate-thumbs (my-image-dired-dired-all-image-files))
        (save-excursion
          (goto-char (point-min))
          (while (< (point) (point-max))
            (my-image-dired-dired-set-thumb-visibility t)
            (forward-line 1)))
      (message "Canceled."))))

(defun my-image-dired-dired-all-image-files ()
  (when (derived-mode-p 'dired-mode)
    (save-excursion
      (goto-char (point-min))
      (let ((image-regexp (image-dired--file-name-regexp)) ;; Emacs28までは(image-file-name-regexp)
            files)
        (while (< (point) (point-max))
          (let ((file (dired-get-filename nil t)))
            (when (and file
                       (string-match-p image-regexp file))
              (push file files)))
          (forward-line 1))
        (nreverse files)))))

(defun my-image-dired-confirm-generate-thumbs (files)
  (let* ((no-thumb-files (seq-filter (lambda (file)
                                       (not (file-exists-p
                                             (image-dired-thumb-name file))))
                                     files))
         (num-no-thumb-files (length no-thumb-files)))
    (or (<= num-no-thumb-files image-dired-show-all-from-dir-max-files)
        (y-or-n-p
         (format
          "Generate %s new thumbnails. Proceed? "
          num-no-thumb-files)))))

(with-eval-after-load "dired"
  (define-key dired-mode-map (kbd "C-t C-a") 'my-image-dired-dired-toggle-all-thumbs))

実際には全表示用の一つのコマンドだけ C-t C-a に割り当てました。C-u プレフィックスを付けると全消去になります。

また、沢山のサムネイル生成が必要なときは警告を出して確認するようにしました。全ての画像が既にサムネイル化されている場合は何も聞かずに処理します。

(dired内)dired-details-rのレイアウトが乱れるのを直す

私はファイルの詳細情報(サイズやタイムスタンプ)をファイル名の右側に表示して使用していますが、サムネイルを表示させるとその分だけ詳細情報も含めた行全体が右にずれてしまいます。

これについては先日「dired-details-r.elの更新」として書きました。

(dired内)ファイルの削除や移動でサムネイルが消えずに残るのを直す

見た目的にはかなり露骨なバグです。こういうのが当たり前のように転がっているのがEmacsの世界です。

ただこれはdiredバッファに何かを追加するEmacs Lispで良くあることです。私がdired-details-rを作っている時にも経験しましたしall-the-icons-diredでもありました。

diredはファイルの削除や移動を外部から捕捉できるようにするフックを提供していないのでちゃんと実装するのが難しいのです。私が思いつく対処方法としては次の二つがあります。

行が消えるときに自動的に追加したものも一緒に消えるようにしておく(overlayのevaporateプロパティを使う等)
dired-remove-entry等の削除に関わる関数にadviceを追加する

最初はサムネイルのオーバーレイに1文字分の範囲を覆わせてevaporateプロパティをtにすることで自動的に消えるようにしようと思いました(今の実装はファイル名直前の空の範囲を覆わせてbefore-stringでサムネイルを表示しているので、そのままevaporateをtにすると即時消えてしまう)。しかしよく調べてみると、image-diredはバッファ全体の更新時(dired-after-readin-hookのタイミング)にバッファ内に存在するオーバーレイを正しい位置に再配置していました。つまり、消してから作り直すのでは無く、使い回す設計になっていました。どちらが速いのかは計測してみなければ分かりませんが今より遅くなっては困るのでその設計は尊重して、adviceを使ってdiredで削除したり移動したりするときだけ明示的にオーバーレイを削除するようにしてみました。

(defun my-image-dired-dired-remove-entry-around (orig-fun file &rest args)
  (save-excursion
    (when (dired-goto-file file)
      (cl-loop for ov in (overlays-in (line-beginning-position)
                                      (line-end-position))
               when (and (overlay-get ov 'put-image)
                         (overlay-get ov 'thumb-file))
               do (delete-overlay ov))))
  (apply orig-fun file args))

(advice-add #'dired-remove-entry :around
            #'my-image-dired-dired-remove-entry-around)

(dired内)C-t iで開いたウィンドウを簡単に閉じる

image-diredには C-t i で現在のポイントにある画像ファイルを別ウィンドウで表示してくれる機能があります。この機能の特筆すべき点は、ちゃんと適切なサイズに縮小した一時ファイルを作ってからEmacsで開いてくれるというところです。解像度の高い巨大な画像でも安心して開けるわけです。

それは良いのですが、開いたウィンドウを簡単に閉じることができません。もちろん C-x o q (バッファも削除したいならC-x o C-u q) で閉じられますが、もう一歩、別ウィンドウに移動しなくても閉じられるようにしたいところです。チラ見してすぐに閉じるような手軽さが欲しいわけです。

ひとまず次のようにしてDiredから C-t q で閉じるようにしてみました。

(defun my-image-dired-quit-display-window (&optional kill)
  (interactive "P")
  (when-let ((window (image-dired-display-window)))
    (quit-window kill window)))

(with-eval-after-load "dired"
  (define-key dired-mode-map (kbd "C-t q") 'my-image-dired-quit-display-window))

さらにもう一歩進めるなら、 q でimage-diredのウィンドウを先にquitして、無ければdiredをquitするというのはどうでしょう。

(defun my-image-dired-dired-quit-window (&optional kill)
  (interactive "P")
  (if-let ((window (or (image-dired-display-window)
                       (image-dired-thumbnail-window))))
      (quit-window kill window)
    (quit-window kill)))

(with-eval-after-load "dired"
  (define-key dired-mode-map (kbd "q") 'my-image-dired-dired-quit-window))

(dired内)全画像ファイルをサムネイルバッファで表示する

image-diredにはサムネイルだけを専用のバッファで一覧表示する機能があります。あるというよりも、おそらくこちらが本来の使い方なのだと思います。

この方法は良くあるビューアに慣れていると最初はギョッとしますが、Diredの中に表示をさせたものと比較すると無駄な余白が少なく一度に多くのサムネイルとファイル情報を表示できるのが利点です(まぁ、実際の理由はDiredバッファ内にサムネイルを表示するのは今回対策しているように色々問題が多いからなのかもしれません)。

画像をサムネイル専用バッファで表示するには、C-t d、C-t .、C-t aあたりを使います。C-t dは現在またはマークした画像だけを表示し(ウィンドウ移動も含む)、C-t .は現在の画像だけを表示し(選択ウィンドウはそのまま)、C-t aは現在またはマークした画像を追加します(選択ウィンドウはそのまま)。これはこれで有用なケースはあると思いますが、とりあえず欲しいのは開いているディレクトリの全画像を一括でサムネイル専用バッファに表示するコマンドではないでしょうか。一応そのようなコマンドはあります。

特定のディレクトリ下にある画像を一括でサムネイル表示するには M-x image-dired とします。ディレクトリを尋ねられるのでそのままカレントディレクトリを指定すればOKです。50個以上の画像があると警告が表示されます。

しかしこれには次のような不満もあります。

Diredにキー割り当てがない
いちいちディレクトリを尋ねられる
Dired側で全ての画像ファイルがマークされる(マーク状態が変わってしまう)

その辺りを次のコードで解決しました。

(defun my-image-dired-dired-show-all-images ()
  ;; Derived from `image-dired-show-all-from-dir'
  (interactive)
  (unless (derived-mode-p 'dired-mode)
    (error "Not dired buffer"))
  (let* ((image-regexp (image-dired--file-name-regexp)) ;; Emacs28までは(image-file-name-regexp)
         ;; カレントディレクトリにある全画像ファイルを求める
         (files (seq-filter (lambda (file) (string-match-p image-regexp file))
                            (directory-files "." t))))
    (if (my-image-dired-confirm-generate-thumbs files) ;;生成数が多いときは確認する
        ;; Emacs 28まで
        ;; (progn
        ;;   (my-image-dired-display-thumbs files (current-buffer))
        ;;   (image-dired-thumb-update-marks) ;;マークを同期する
        ;;   (pop-to-buffer image-dired-thumbnail-buffer))
        ;; Emacs 29から
        (progn
          (my-image-dired-display-thumbs files (current-buffer))
          (image-dired--thumb-update-marks) ;;マークを同期する
          (pop-to-buffer image-dired-thumbnail-buffer)
          (image-dired--update-header-line))
      (message "Canceled."))))

(defun my-image-dired-display-thumbs (files dired-buf
                                            &optional append do-not-pop)
  ;; Derived from `image-dired-display-thumbs'
  (setq image-dired--generate-thumbs-start  (current-time))
  (let ((buf (image-dired-create-thumbnail-buffer)))
    (with-current-buffer buf
      ;; Emacs 28まで
      ;; (let ((inhibit-read-only t))
      ;;   (if append (goto-char (point-max)) (erase-buffer))
      ;;   (dolist (curr-file files)
      ;;     (let ((thumb-name (image-dired-thumb-name curr-file)))
      ;;       (unless (file-exists-p thumb-name)
      ;;         (image-dired-create-thumb curr-file thumb-name))
      ;;       (image-dired-insert-thumbnail thumb-name curr-file dired-buf)))
      ;;   (if do-not-pop
      ;;       (display-buffer buf)
      ;;     (pop-to-buffer buf))
      ;;   (image-dired--line-up-with-method))
      ;; Emacs 29から
      (let ((inhibit-read-only t))
        (if (not append)
            (progn
              (setq image-dired--number-of-thumbnails 0)
              (erase-buffer))
          (goto-char (point-max)))
        (dolist (file files)
          (when (string-match-p (image-dired--file-name-regexp) file)
            (image-dired-insert-thumbnail
             (image-dired--get-create-thumbnail-file file) file dired-buf
             (cl-incf image-dired--number-of-thumbnails))))))))

(with-eval-after-load "dired"
  (define-key dired-mode-map (kbd "C-t C-d") 'my-image-dired-dired-show-all-images))

my-image-dired-dired-show-all-images は image-dired-show-all-from-dir (image-diredコマンドはこれの別名) が元になっていますが、次の点が異なります。

diredから呼ばれることが前提
diredで開いているディレクトリが対象 (いちいち聞きません)
diredのマーク状態を一切変更せずに直接サムネイルバッファに追加する
diredでマークしている画像は始めからサムネイルバッファでもマークする
サムネイル化されていない画像が多い場合は警告する (画像の数では無く、新たに生成しなければならないサムネイルの数で判断します)

(サムネイルバッファ内)Uでマークを全解除する

(2023-08-08追記: Emacs 29.1からは標準で同等のコマンドがUに割り当てられているため不要です)

M-x image-diredを実行してみるとすぐに気がつくのがUで全てのマークを解除できないことではないでしょうか。M-x image-diredを実行するとdiredバッファ上で全ての画像ファイルがマークされてしまいます。慌ててUを押して全てのマークを解除しようとしても、サムネイルバッファの方に移動してしまっているので効きません。

サムネイルバッファ内ではmやuでマークしたり解除したりできますが、Uで全解除はできません。

次のコードはそれを出来るようにします。

;; Emacs 29.1からは不要。標準で image-dired-unmark-all-marks がある。
(defun my-image-dired-unmark-all ()
  (interactive)
  (when-let ((dired-buf (image-dired-associated-dired-buffer)))
    (with-current-buffer dired-buf
      (dired-unmark-all-marks))) ;;TODO: サムネイルバッファ内にあるファイルだけに限定すべき？
  ;; きちんとサムネイルバッファ内のマークも更新するのがポイント。
  (image-dired-thumb-update-marks))

(with-eval-after-load "image-dired"
  (define-key image-dired-thumbnail-mode-map "U" 'my-image-dired-unmark-all))

他にもdiredがサポートしている様々なマーク操作をサムネイルバッファ上でも行えるようになっていた方が良いかもしれません。特にマークのトグルは欲しいのですが(U tと押せば全マークできるので)、tキーがタグのために使われているので保留。

また、本来はサムネイルバッファ内にあるファイルだけマーク解除すべきかもしれません。その辺りはマークがちゃんと同期されていないという問題と一緒に考えた方がいいかもしれません。

外部ツールで表示するときにw32-shell-executeを使う

(2024-09-15追記: Emacs30からはimage-dired-external-viewerにnilを指定すればw32-shell-executeを使用するようになったので、これは不要)

特定のツールを直接指定するのも良いのですが、Windowsなので関連付けされているアプリを呼び出すのが普通でしょう。そのためにはw32-shell-execute関数を使用します。

diredにはすでにそのような機能を自分で追加してあるのでimage-diredで対応する必要はあまりないのですが、一応対策しておきます。

(defun my-image-dired-thumbnail-display-external-w32 ()
  ;; Derived from `image-dired-thumbnail-display-external'
  (interactive)
  (let ((file (image-dired-original-file-name)))
    (if (not (image-dired-image-at-point-p))
        (message "No thumbnail at point")
      (if (not file)
          (message "No original file name found")
        ;; ここを変更
        (w32-shell-execute "open" file)))))

(defun my-image-dired-dired-display-external-w32 ()
  ;; Derived from `image-dired-dired-display-external'
  (interactive)
  (let ((file (dired-get-filename)))
    ;; ここを変更
    (w32-shell-execute "open" file)))

(with-eval-after-load "dired"
  (define-key dired-mode-map [remap image-dired-dired-display-external] 'my-image-dired-dired-display-external-w32))

(with-eval-after-load "image-dired"
  (define-key image-dired-thumbnail-mode-map [remap image-dired-thumbnail-display-external] 'my-image-dired-thumbnail-display-external-w32))

何か別のソフト、ビューアではなく編集ソフト等を指定するのもありかもしれません。ビューアが立ち上がればそこから編集ソフトも起動できるようにはしてあるのであまり必要性はありません。

(dired内)ファイルに対応するサムネイルバッファ内の位置へジャンプする

C-t jでサムネイルバッファへジャンプしますが、対応するファイルへはジャンプしません。サムネイルバッファからDiredバッファの対応するファイルへはTABでジャンプできるので、この逆バージョンが欲しい所です。C-t TABに割り当ててみました。

(defun my-image-dired-dired-jump-thumbnail-buffer ()
  (interactive)
  (let ((file (dired-get-filename)))
    ;; Display thumbnail buffer
    (if (image-dired-thumbnail-window)
        (image-dired-jump-thumbnail-buffer)
      (if (buffer-live-p (get-buffer image-dired-thumbnail-buffer))
          (pop-to-buffer image-dired-thumbnail-buffer)
        (message "No thumbnail buffer")))
    ;; Jump
    (my-image-dired-goto-file file)))

(defun my-image-dired-goto-file (file)
  (let ((pos (save-excursion
               (goto-char (point-min))
               (when-let ((match (text-property-search-forward 'original-file-name file t)))
                 (prop-match-beginning match)))))
    (when pos
      (goto-char pos))))

(with-eval-after-load "dired"
  (define-key dired-mode-map (kbd "C-t TAB") 'my-image-dired-dired-jump-thumbnail-buffer))

コードまとめ

沢山修正したのでひとまずこのあたりでまとめます。

(require 'cl-lib)
(require 'text-property-search)
(require 'image-dired)

;;;; image-dired-dired-toggle-marked-thumbsを分解する

(defun my-image-dired-dired-toggle-marked-thumbs (&optional arg)
  ;; Derived from `image-dired-dired-toggle-marked-thumbs'
  "Toggle thumbnails in front of file names in the Dired buffer.
If no marked file could be found, insert or hide thumbnails on the
current line.  ARG, if non-nil, specifies the files to use instead
of the marked files.  If ARG is an integer, use the next ARG (or
previous -ARG, if ARG<0) files."
  (interactive "P")
  (dired-map-over-marks
   (my-image-dired-dired-set-thumb-visibility 'toggle)
   arg             ; Show or hide image on ARG next files.
   'show-progress) ; Update dired display after each image is updated.
  (add-hook 'dired-after-readin-hook
            'image-dired-dired-after-readin-hook nil t))

(defun my-image-dired-dired-set-thumb-visibility (visibility)
  ;; Derived from `image-dired-dired-toggle-marked-thumbs'
  (let ((image-pos  (dired-move-to-filename))
        (image-file (dired-get-filename nil t)))
    (when (and image-file
               (string-match-p (image-dired--file-name-regexp) image-file)) ;; Emacs28までは(image-file-name-regexp)
      (let* ((thumb-file
              (thumb-file
               ;; Emacs 28まで
               ;;(image-dired-get-thumbnail-image image-file)
               ;; Emacs 29から
               (create-image
                (image-dired--get-create-thumbnail-file image-file))))
             (thumb-ov (cl-loop for ov in (overlays-in (point) (1+ (point)))
                                if (overlay-get ov 'thumb-file) return ov)))
        (if thumb-ov
            (when (memq visibility '(nil toggle))
              (delete-overlay thumb-ov))
          (when (memq visibility '(t toggle))
            (my-image-dired-dired-create-thumbnail-overlay
             image-pos image-file thumb-file)))))))

;;;; Diredバッファ内でのサムネイルの表示を改善

(defun my-image-dired-dired-create-thumbnail-overlay (image-pos image-file thumb-file)
  ;; Derived from `image-dired-dired-toggle-marked-thumbs'
  (let ((overlay (put-image
                  ;; 枠線で囲む
                  (append thumb-file (list :relief 1))
                  image-pos)))
    (overlay-put overlay 'image-file image-file)
    (overlay-put overlay 'thumb-file thumb-file)
    (my-image-dired-dired-update-thumbnail-overlay overlay thumb-file)
    overlay))

(defun my-image-dired-dired-update-thumbnail-overlay (ov image)
  (when-let ((image-file (plist-get (cdr image) :file)))
    (let* ((image-exists-p (file-exists-p image-file))
           (image-size (image-size image t)) ;;float?
           (space-w
            (if image-exists-p
                ;; Emacs 28まで
                ;;(- image-dired-thumb-width (car image-size))
                ;; Emacs 29から
                (- image-dired-thumb-size (car image-size))
              0))
           (space-left (ceiling (/ space-w 2)))
           (space-right (+ 10 ;; サムネイルの後に空白を入れる
                           (- space-w space-left))))
      ;; 幅を揃える
      (overlay-put ov 'before-string
                   (concat
                    (propertize "_" 'display `(space :width (,space-left)))
                    (overlay-get ov 'before-string)
                    (propertize "_" 'display `(space :width (,space-right))))))))

;;;; Diredバッファ内にサムネイルを一括表示する

(defun my-image-dired-dired-toggle-all-thumbs ()
  (interactive)
  (if (cl-loop for ov in (overlays-in (point-min) (point-max))
               when (overlay-get ov 'thumb-file) return t)
      (my-image-dired-dired-hide-all-thumbs)
    (my-image-dired-dired-show-all-thumbs)))

(defun my-image-dired-dired-hide-all-thumbs ()
  (interactive)
  (cl-loop for ov in (overlays-in (point-min) (point-max))
           when (overlay-get ov 'thumb-file)
           do (delete-overlay ov)))

(defun my-image-dired-dired-show-all-thumbs (&optional hide)
  (interactive "P")
  (if hide
      (my-image-dired-dired-hide-all-thumbs)
    (add-hook 'dired-after-readin-hook
              'image-dired-dired-after-readin-hook nil t)
    (if (my-image-dired-confirm-generate-thumbs (my-image-dired-dired-all-image-files))
        (save-excursion
          (goto-char (point-min))
          (while (< (point) (point-max))
            (my-image-dired-dired-set-thumb-visibility t)
            (forward-line 1)))
      (message "Canceled."))))

(defun my-image-dired-dired-all-image-files ()
  (when (derived-mode-p 'dired-mode)
    (save-excursion
      (goto-char (point-min))
      (let ((image-regexp (image-dired--file-name-regexp)) ;; Emacs28までは(image-file-name-regexp)
            files)
        (while (< (point) (point-max))
          (let ((file (dired-get-filename nil t)))
            (when (and file
                       (string-match-p image-regexp file))
              (push file files)))
          (forward-line 1))
        (nreverse files)))))

(defun my-image-dired-confirm-generate-thumbs (files)
  (let* ((no-thumb-files (seq-filter (lambda (file)
                                       (not (file-exists-p
                                             (image-dired-thumb-name file))))
                                     files))
         (num-no-thumb-files (length no-thumb-files)))
    (or (<= num-no-thumb-files image-dired-show-all-from-dir-max-files)
        (y-or-n-p
         (format
          "Generate %s new thumbnails. Proceed? "
          num-no-thumb-files)))))

;;;; ファイル削除時にサムネイルを削除

(defun my-image-dired-dired-remove-entry-around (orig-fun file &rest args)
  (save-excursion
    (when (dired-goto-file file)
      (cl-loop for ov in (overlays-in (line-beginning-position)
                                      (line-end-position))
               when (and (overlay-get ov 'put-image)
                         (overlay-get ov 'thumb-file))
               do (delete-overlay ov))))
  (apply orig-fun file args))

(advice-add #'dired-remove-entry :around
            #'my-image-dired-dired-remove-entry-around)

;;;; Diredバッファからimage-dired関連ウィンドウを閉じる

(defun my-image-dired-quit-display-window (&optional kill)
  (interactive "P")
  (when-let ((window (image-dired-display-window)))
    (quit-window kill window)))

(defun my-image-dired-dired-quit-window (&optional kill)
  (interactive "P")
  (if-let ((window (or (image-dired-display-window)
                       (image-dired-thumbnail-window))))
      (quit-window kill window)
    (quit-window kill)))

;;;; Diredバッファから全画像ファイルを一括でサムネイルバッファに表示する

(defun my-image-dired-dired-show-all-images ()
  ;; Derived from `image-dired-show-all-from-dir'
  (interactive)
  (unless (derived-mode-p 'dired-mode)
    (error "Not dired buffer"))
  (let* ((image-regexp (image-dired--file-name-regexp)) ;; Emacs28までは(image-file-name-regexp)
         (files (seq-filter (lambda (file) (string-match-p image-regexp file))
                            (directory-files "." t))))
    (if (my-image-dired-confirm-generate-thumbs files)
        ;; Emacs 28まで
        ;; (progn
        ;;   (my-image-dired-display-thumbs files (current-buffer))
        ;;   (image-dired-thumb-update-marks) ;;マークを同期する
        ;;   (pop-to-buffer image-dired-thumbnail-buffer))
        ;; Emacs 29から
        (progn
          (my-image-dired-display-thumbs files (current-buffer))
          (image-dired--thumb-update-marks) ;;マークを同期する
          (pop-to-buffer image-dired-thumbnail-buffer)
          (image-dired--update-header-line))
      (message "Canceled."))))

(defun my-image-dired-display-thumbs (files dired-buf
                                            &optional append do-not-pop)
  ;; Derived from `image-dired-display-thumbs'
  (setq image-dired--generate-thumbs-start  (current-time))
  (let ((buf (image-dired-create-thumbnail-buffer)))
    (with-current-buffer buf
      ;; Emacs 28まで
      ;; (let ((inhibit-read-only t))
      ;;   (if append (goto-char (point-max)) (erase-buffer))
      ;;   (dolist (curr-file files)
      ;;     (let ((thumb-name (image-dired-thumb-name curr-file)))
      ;;       (unless (file-exists-p thumb-name)
      ;;         (image-dired-create-thumb curr-file thumb-name))
      ;;       (image-dired-insert-thumbnail thumb-name curr-file dired-buf)))
      ;;   (if do-not-pop
      ;;       (display-buffer buf)
      ;;     (pop-to-buffer buf))
      ;;   (image-dired--line-up-with-method))
      ;; Emacs 29から
      (let ((inhibit-read-only t))
        (if (not append)
            (progn
              (setq image-dired--number-of-thumbnails 0)
              (erase-buffer))
          (goto-char (point-max)))
        (dolist (file files)
          (when (string-match-p (image-dired--file-name-regexp) file)
            ;; Emacs 29まで
            ;; (image-dired-insert-thumbnail
            ;;  (image-dired--get-create-thumbnail-file file) file dired-buf
            ;;  (cl-incf image-dired--number-of-thumbnails))
            ;; Emacs 30から(引数が一つ減った)
            (image-dired-insert-thumbnail
             (image-dired--get-create-thumbnail-file file) file dired-buf)
            (cl-incf image-dired--number-of-thumbnails)
          ))))))

;;;; サムネイルバッファ内から全マークの解除

;; Emacs 29.1からは不要。標準で image-dired-unmark-all-marks がある。
(defun my-image-dired-unmark-all ()
  (interactive)
  (when-let ((dired-buf (image-dired-associated-dired-buffer)))
    (with-current-buffer dired-buf
      (dired-unmark-all-marks)))
  (image-dired-thumb-update-marks))

;;;; 外部ツールで表示

(defun my-image-dired-thumbnail-display-external-w32 ()
  ;; Derived from `image-dired-thumbnail-display-external'
  (interactive)
  (let ((file (image-dired-original-file-name)))
    (if (not (image-dired-image-at-point-p))
        (message "No thumbnail at point")
      (if (not file)
          (message "No original file name found")
        ;; Use shell execute!
        (w32-shell-execute "open" file)))))

(defun my-image-dired-dired-display-external-w32 ()
  ;; Derived from `image-dired-dired-display-external'
  (interactive)
  (let ((file (dired-get-filename)))
    ;; Use shell execute!
    (w32-shell-execute "open" file)))

;;;; Diredからサムネイルバッファの対応するファイルへジャンプ

(defun my-image-dired-dired-jump-thumbnail-buffer ()
  (interactive)
  (let ((file (dired-get-filename)))
    ;; Display thumbnail buffer
    (if (image-dired-thumbnail-window)
        (image-dired-jump-thumbnail-buffer)
      (if (buffer-live-p (get-buffer image-dired-thumbnail-buffer))
          (pop-to-buffer image-dired-thumbnail-buffer)
        (message "No thumbnail buffer")))
    ;; Jump
    (my-image-dired-goto-file file)))

(defun my-image-dired-goto-file (file)
  (let ((pos (save-excursion
               (goto-char (point-min))
               (when-let ((match (text-property-search-forward 'original-file-name file t)))
                 (prop-match-beginning match)))))
    (when pos
      (goto-char pos))))

;;;; 設定

(with-eval-after-load "image-dired"
  (when (eq system-type 'windows-nt)
    (setq image-dired-cmd-create-thumbnail-program "magick"
          image-dired-cmd-create-temp-image-program "magick")
    (unless (equal (car image-dired-cmd-create-thumbnail-options) "convert")
      (push "convert" image-dired-cmd-create-thumbnail-options))
    (unless (equal (car image-dired-cmd-create-temp-image-options) "convert")
      (push "convert" image-dired-cmd-create-temp-image-options))
    (define-key image-dired-thumbnail-mode-map [remap image-dired-thumbnail-display-external] 'my-image-dired-thumbnail-display-external-w32))
  ;; Emacs 29.1からは不要。標準で image-dired-unmark-all-marks がある。
  ;;(define-key image-dired-thumbnail-mode-map "U" 'my-image-dired-unmark-all)
  )

(with-eval-after-load "dired"
  (define-key dired-mode-map [remap image-dired-dired-toggle-marked-thumbs] 'my-image-dired-dired-toggle-marked-thumbs)
  (define-key dired-mode-map (kbd "C-t C-a") 'my-image-dired-dired-toggle-all-thumbs)
  (define-key dired-mode-map (kbd "q") 'my-image-dired-dired-quit-window)
  (define-key dired-mode-map (kbd "C-t q") 'my-image-dired-quit-display-window)
  (define-key dired-mode-map (kbd "C-t C-d") 'my-image-dired-dired-show-all-images)
  (define-key dired-mode-map (kbd "C-t TAB") 'my-image-dired-dired-jump-thumbnail-buffer)
  (when (eq system-type 'windows-nt)
    (define-key dired-mode-map [remap image-dired-dired-display-external] 'my-image-dired-dired-display-external-w32)))

その他の問題

サムネイル生成を中断する方法が無い
サムネイル生成の進行状況を確認する方法が無い
サムネイル生成が終わったのにサムネイルが更新されないことがある
サムネイル生成が終わった後にdired-details-rのレイアウトが崩れる
サムネイル生成の高速化
Diredバッファとサムネイルバッファの間のマークの同期が不完全
サムネイルバッファ内でのマーク操作が不足している(全トグル等)
サムネイル画像の量を調べたり削除したりする機能が無い

とりあえず

とりあえずすぐに目に付いたものを修正してみましたが、まだまだ直すべき所は沢山ありそうです。

image-diredは本家の方でも継続的に改良されているみたいなので(GitHubのEmacsミラーをチラ見した限り)、最新版はまた状況が異なるかもしれません。私は現在Emacs 28.2に同梱されているものを使用しています。(2023-08-08追記: Emacs 29.1にアップデートしました)

肝心のタグやコメントに関する機能をあまり使っていないので、今後はそれらを使ってみて効率よいワークフローが確立できるかを模索しようと思います。

2023-04-11 Emacs

dired-details-r.elの更新

次の点を変更しました。

image-diredのサムネイルやall-the-icons-diredのアイコンに対応
ファイル名が長いときの空白を調整
global-dired-details-r-modeを追加
find-dired系に一応対応
dired-after-readin-hookを使用するようにした

今回の一番の目的はimage-dired対応です。ファイル名の前に存在するオーバーレイの幅を計算に入れてレイアウトします。all-the-icons-diredのオーバーレイも一緒に考慮しなければならなかった(分離できなかった)のでそうしました。all-the-icons-diredは独自に色々手を入れているのでオリジナルでは未確認です。image-diredもサムネイルの幅が揃うように手元では独自に手を入れています。動作が遅くなったり不安定になる可能性が若干あるので無効化する変数も用意してあります。サムネイルのサイズは非同期生成や画像の編集操作で変化するのでその際はレイアウトが崩れます。gを押してください。

図1: image-diredのサムネイルとall-the-icons-diredを考慮して詳細情報の右側表示を行う

以下はついでに直した所です。

ファイル名が長すぎるときはバッファ全体のファイル名欄の幅を拡大せずにそのファイルだけレイアウトが崩れるようにしてありますが、その際ファイル名の右に余分な空白があれば削除するようにしました。ファイルサイズが右寄せされているために無駄に空白が空いていることがありました。

global-dired-details-r-modeは全体のON/OFFをしやすくするために追加しました。

find-dired系(find-name-diredやfind-grep-dired)での動作を改善しました。デフォルトでは見た目を変更しないようになっています。find-diredではファイル名にディレクトリが含まれるため長すぎてレイアウトが崩れがちだからです。 ( を押すとレイアウトを変更するようにはしてあります。私はfind-dired系をあまり使わないのでどうするのが一番良いのかよく分かりません。

dired-after-readin-hookを使用するようにしました。これまではadvice-addでdired-insert-set-propertiesとdired-revertに処理を挟んでいましたが、こちらのやり方の方が普通のようです。ただし、find-diredも含めいくつかdiredバッファを直接書き替えた後にdired-insert-set-propertiesを呼び出してdired-after-readin-hookを呼び出さないケースがあるようです。そういったものにもちゃんと対応するならこれまでのやり方も併用した方が良いのかもしれません。

misohena/dired-details-r: Show file details on the right side of the filename in Emacs Dired mode

(追記: 長すぎるファイル名を切り詰める機能も追加しました)

(追記2: ファイル名の最大幅をウィンドウ幅から決める機能を追加しました)

(追記3: ついに詳細を左にも両側にも表示できるようになってしまいました。dired-details-rなのにw)

2023-03-23 Emacs, org-mode

Emacs内で地図を見るosm.elを使う

osm.el というものがあることは少し前から知っていたのですが、別にEmacsの中で地図を見なくてもいいんじゃないかと思って試していませんでした。まぁEmacsの中で動く作図ソフトなんかを作ってるお前が言うのかという感じではあるのですが。

とは言え登山計画や登山記録の作成に何か活用できないかと考え、時間があったので少し試してみることにしました。

minad/osm: osm.el - OpenStreetMap viewer for Emacs

使ってみて驚いたのがとにかく速いということ。Emacs内のキー操作でシームレスに使えるというのもあるのですが、起動自体がブラウザでGoogle Mapsを開くよりも速いのです。もちろんタイルをキャッシュしているからというのはあるのですが、それは向こうだって同じ事。きっと余分な処理が少ないからなのでしょう。

キーボードだけで無くマウスでも普通に操作できますし、メニューもあるのでキー割り当てを覚えていなくても問題ありません。閉じる操作だけキーが必要でしょうか。qがquit-windowなので、バッファもkillしたいならC-u qすれば良いのでしょう。

私はC-f, C-b, C-p, C-nでも移動がしたかったので次のような設定を加えました。

(with-eval-after-load 'osm
  (define-key osm-mode-map [remap previous-line] #'osm-up-up)
  (define-key osm-mode-map [remap next-line] #'osm-down-down)
  (define-key osm-mode-map [remap forward-char] #'osm-right-right)
  (define-key osm-mode-map [remap backward-char] #'osm-left-left))

また、次の設定で国土地理院の地理院地図を表示するようにしました。

(with-eval-after-load 'osm
  (setq osm-server 'jgsi)
  (setf (alist-get 'jgsi osm-server-list)
        '(:name
          "地理院地図 標準地図"
          :max-zoom 18
          :description "地理院地図 標準地図"
          :url "https://cyberjapandata.gsi.go.jp/xyz/std/%z/%x/%y.png"
          :group "地理院地図"
          :copyright
          ("Map data © {国土地理院|https://www.gsi.go.jp/}"))))

後は自宅とか言語とか。

(setq osm-home '(35.XXXXXX 139.XXXXXX 14)
      osm-search-language "ja,en")

osm.elにはGPXファイルの軌跡データを表示する機能があります。GPXは登山の記録アプリでも広く使われている形式です。試しに表示させてみたところ次のようになりました。

大変面白いのですが、しかしこれだけだと単にEmacsの中で地図や軌跡が見られるというだけです。何かもう少し有意義な使い方が出来ないものでしょうか。最低限Emacsの中から任意の地点へリンクを張りたいですよね。

同梱されているosm-ol.elというのを使用すると次のような形式のorg-modeリンクが使えるようになります。

[[geo:36.399109,137.715168;z=15][燕山荘]]

……あれ、これ以前私も同じような仕組みを作りましたよね。

緯度経度リンクタイプをorg-modeに追加する

misohena/org-geolink: Adds geo location link type to org-mode.

私の方はリンクを各種地図サービス(Webブラウザ)で開いたり、エクスポート時に好きな形式に変換するためのものでした。

osm-ol.elの方は単にリンクをosm.elで開くだけのようです。エクスポートや外部サービスで開くことは考慮していないようです。

なのでosm-ol.elは使わず、私のorg-geolinkをosm.elと連携させることにしました。

org-geolinkがgeoリンクを開くときの方法としてosm.elを選べるようにしました。また、osm.elで見ている場所を各種地図サービスで開くコマンドを追加しました。

これによって

[[geo:～]] → osm.el(Emacs内) → 各種地図サービス(Webブラウザ内)

という流れで使うことができるようになりました。

つまり、まずは高速なosm.elで見て、必要に応じて(施設情報閲覧や経路検索がしたいなら)各種地図サービスを開く事が出来ます。

設定例:

(when (locate-library "org-geolink")
  (with-eval-after-load "org"
    (require 'org-geolink))

  (when (locate-library "osm")
    ;; [[geo:]]リンクをosm.elで開く
    (setq org-geolink-follow-function 'org-geolink-open-by-osm-el)

    ;; osmバッファ内において、Oで外部地図サービスを開く
    (with-eval-after-load 'osm
      (define-key osm-mode-map (kbd "O")
        #'org-geolink-open-osm-el-location-by-selected-web-service)))

  ;;地図サービスを追加
  (setq org-geolink-map-services-user
        ;; NAVITIME
        '((navitime
           (name . "NAVITIME")
           (url . "https://www.navitime.co.jp/maps/poi?lat={{{1}}}&lon={{{2}}}"))
          ;; ヤマケイオンライン
          (yamakei
           (name . "ヤマケイオンライン(ヤマタイム)")
           (url . "https://www.yamakei-online.com/yk_map/?latlon={{{1}}},{{{2}}}&zoom={{{z}}}"))
          ;; ヤマレコ
          (yamareco
           (name . "ヤマレコ(ヤマプラ)")
           (url . "https://www.yamareco.com/modules/yr_plan/step1_planner.php?lat={{{1}}}&lon={{{2}}}")))))

もっといろんな活用方法があるような気がするのですが、時間があったら色々やってみるかもしれません。

2022-12-30 Emacs

cl-defmethodやcl-defunで作成した関数に対するeldocを改善する

例えば次のようなコードを書いたとしましょう。

(require 'eieio)

(defclass myshape-rect () ;;Emacs Lispは何でもかんでも接頭辞必須なのが鬱陶しいですね。
  ((x-min :initarg :x-min :type number)
   (y-min :initarg :y-min :type number)
   (x-max :initarg :x-max :type number)
   (y-max :initarg :y-max :type number)))

(defclass myshape-ellipse ()
  ((cx :initarg :cx :type number)
   (cy :initarg :cy :type number)
   (rx :initarg :rx :type number)
   (ry :initarg :ry :type number)))

(cl-defmethod myshape-scale ((rect myshape-rect) sx &optional (sy sx) &key (ox 0) (oy 0))
  (with-slots (x-min y-min x-max y-max) rect
    (setf x-min (+ (* (- x-min ox) sx) ox)
          x-max (+ (* (- x-max ox) sx) ox)
          y-min (+ (* (- y-min oy) sy) oy)
          y-max (+ (* (- y-max oy) sy) oy)))
  rect)

(cl-defmethod myshape-scale ((ellipse myshape-ellipse) sx &optional (sy sx) &key (ox 0) (oy 0))
  (with-slots (cx cy rx ry) ellipse
    (setf cx (+ (* (- cx ox) sx) ox)
          cy (+ (* (- cy oy) sy) oy)
          rx (* rx sx)
          ry (* ry sy)))
  ellipse)

で、myshape-scaleメソッドを試してみますか。

(let ((rect (myshape-rect :x-min 100 :x-max 200 :y-min 1000 :y-max 1100)))
  (myshape-scale …

ん？

「ARG &rest ARGS」って何だよ。

こんなの見せられたって一つ以上の引数を取る関数としか分からないじゃないか。

いや、分かってるよ。cl-defgenericを書けって言いたいんでしょ？　うっせーバーカ！　それにしたって「ARG &rest ARGS」は無いでしょう。こんなの出すなら何も出さない方がマシ。それとも煽ってるの？

……まぁいいや、とりあえずお試しだからcl-defgenericを書くとして

(cl-defgeneric myshape-scale (shape sx &optional (sy sx) &key (ox 0) (oy 0)))

sxは2、syもとりあえず2でいいかな。原点は……

(let ((rect (myshape-rect :x-min 100 :x-max 200 :y-min 1000 :y-max 1100)))
  (myshape-scale rect 2 2

ん？　なんでsxの部分がハイライトされてるの？

キーワードも全然ダメじゃないか。

この部分ってアレでしょ？　cl-defunってやつと同じ。Common Lispの。そもそもあれよく知らないんだよね……(cl-defunのお勉強へ)

なるほどね。

cl-defunで定義した関数でも同様の問題が発生します。一つの引数が複数の要素を含むリストになっている場合は必ず問題が生じます。単純に空白で分割しているだけのようです。キーワードも対応するものをハイライトするなんてことにはなっていないようです。

ミニバッファに情報を表示しているのはeldoc。特に関数呼び出し時の表示は elisp-eldoc-funcall の仕事です。

というわけでこの辺りを修正すべく作成したのがこちら。

my-elisp-eldoc-funcall.el

まず関連するメソッドは全て表示します。出し惜しみせず知ってることは素直に全て出せば良いんです。

ちゃんとひとまとまりの部分をハイライトします。

キーワードも対応する場所をハイライトします。

cl-defunで定義した関数にも対応しました。通常の関数と区別が付かないのでちょっと心配ではあるのですが。

&keyと&restは同時にハイライトします。どちらにも入りますからね。

こういうこともできますが、本当はC++みたいに多重定義を静的に解決してくれたら最高なんですけどね。型推論とか入ってくれてもいいのよ？

はぁ、LSPでコードの解析が出来ると騒がしい昨今に何で自分でこんなことやってるんだろう。それも年末に。もう12月30日じゃないですか。

良いお年を。

2022-12-29 Emacs

cl-defunのお勉強

cl-defunは通常のdefunに加えて便利な機能が付け加えられていますが、正直使いませんしやりたいことに対して過剰に複雑な気がしたのでこれまで学ぶのを避けてきました。

しかし必要になったので諦めて嫌々勉強することにしました。

cl-defunのドキュメント

まずはドキュメントを確認しましょう。

cl-defun is an autoloaded Lisp macro in ‘cl-macs.el’.
# cl-defun は ‘cl-macs.el’ に自動ロードされる Lisp マクロです。

(cl-defun NAME ARGLIST [DOCSTRING] BODY...)

Define NAME as a function.
# NAME を関数として定義します。
Like normal ‘defun’, except ARGLIST allows full Common Lisp conventions,
and BODY is implicitly surrounded by (cl-block NAME ...).
# ARGLIST が完全な Common Lisp 規則を許可し、BODY が (cl-block NAME ...)
# で暗黙的に囲まれていることを除いて、通常の「defun」と同様です。

The full form of a Common Lisp function argument list is
# Common Lisp 関数の引数リストの完全な形式は

   (VAR...
    [&optional (VAR [INITFORM [SVAR]])...]
    [&rest|&body VAR]
    [&key (([KEYWORD] VAR) [INITFORM [SVAR]])... [&allow-other-keys]]
    [&aux (VAR [INITFORM])...])

VAR may be replaced recursively with an argument list for
destructuring, ‘&whole’ is supported within these sublists.  If
SVAR, INITFORM, and KEYWORD are all omitted, then ‘(VAR)’ may be
written simply ‘VAR’.  See the Info node ‘(cl)Argument Lists’ for
more details.
# VAR は、再帰的に分解用の引数リストに置き換えることができます。これらの
# サブリスト内では「&whole」がサポートされています。 SVAR、INITFORM、
# KEYWORD をすべて省略した場合、「(VAR)」は単に「VAR」と記述できます。詳
# 細については、Info ノード「(cl)Argument Lists」を参照してください。

Web上だとArgument Lists (Common Lisp Extensions)にマニュアルがあります。(ちなみにCommon Lispの場合はCLHS: Section 3.4.1)

通常のdefunと違うのは次の点です:

引数リストの形式を拡張
- 分割代入(再帰的な引数リストと&whole指定)
- &optionalの拡張(分割代入、初期値、指定有無変数)
- &restの拡張(分割代入)
- &bodyを追加(&restの別名)
- &keyを追加(名前付き引数(Named parameter - Wikipedia)を実現)
- &auxを追加(ローカル変数定義)
関数の内部をcl-blockで囲む

cl-blockについては今回の興味の対象外なので、引数について見て行きます。

順番

(VAR...
 [&optional (VAR [INITFORM [SVAR]])...]
 [&rest|&body VAR]
 [&key (([KEYWORD] VAR) [INITFORM [SVAR]])... [&allow-other-keys]]
 [&aux (VAR [INITFORM])...])

&optional、&rest(または&body)、&key、&auxはこの順番でなければならないようです。

違う順番で書くと定義時にエラーになりました。

(cl-defun test-clfun (a b &rest args &optional e f)
  (list a b c d e f)) ;;Malformed argument list ends with: (&optional e f)

(cl-defun test-clfun (a b &key c d &optional e f)
  (list a b c d e f)) ;;Malformed argument list ends with: (&optional e f)

(cl-defun test-clfun (a b &key c d &rest args)
  (list a b c d args)) ;;Malformed argument list ends with: (&rest args)

(cl-defun test-clfun (a b &aux (z (+ a b)) &optional c d)
  (list a b c d z)) ;;Malformed argument list ends with: (&optional c d)

(cl-defun test-clfun (a b &aux (z (+ a b)) &rest args)
  (list a b c d z)) ;;Malformed argument list ends with: (&rest args)

(cl-defun test-clfun (a b &aux (z (+ a b)) &key c d)
  (list a b c d z)) ;;Malformed argument list ends with: (&key c d)

技術的にはどんな順番でも良さそうな物ですが、処理の順番としては自然な気もします。

同じ物(&～)を複数書いた場合は対応が分かれます。(Emacs 28.2時点)

(cl-defun test-clfun (a b &optional c d &optional e f)
  (list a b c d e f)) ;;OK!
(test-clfun 1 2) ;;Invalid function

(cl-defun test-clfun (a b &optional (c 100) d &optional e f)
  (list a b c d e f)) ;;OK!
(test-clfun 1 2) ;;OK!

(cl-defun test-clfun (a b &rest rest1 &rest rest2)
  (list a b rest1 rest2)) ;;Malformed argument list ends with: (&rest rest2)

(cl-defun test-clfun (a b &rest rest &body body)
  (list a b rest body)) ;;Malformed argument list ends with: (&rest body)

(cl-defun test-clfun (a b &key c d &key e f)
  (list a b c d e f)) ;;OK!
(test-clfun 1 2) ;;OK!
(test-clfun 1 2 :c 3 :d 4 :e 5 :f 6) ;;OK!

(cl-defun test-clfun (a b &aux (c (+ a b)) &aux (d (* a b)))
  (list a b c d)) ;;OK!
(test-clfun 2 3) ;;OK! (2 3 5 6)

&restで指定出来る変数は必ず一つだけということでしょう。複数の要素が指定出来る物(&～)は(連続する場合に限り)同じ物(&～)を許容する方針のようです(cl–do-arglist内でwhenではなくわざわざwhileが使われています)。ただし&optionalはcl-defun的には良くても実行時にエラーが出る場合がありました。&optionalは元々Emacs Lispで対応しているというあたりが関係しているのかもしれません。元々対応していない初期値指定を入れたら通るようになりました。

&optionalや&key、&auxの後に何も無いのは受け入れられるようです。

(cl-defun test-clfun (a b &optional)
  (list a b)) ;;OK
(test-clfun 1 2) ;;OK

(cl-defun test-clfun (a b &key)
  (list a b)) ;;OK
(test-clfun 1 2) ;;OK

(cl-defun test-clfun (a b &optional &key &aux)
  (list a b)) ;;OK
(test-clfun 1 2) ;;OK

&restに関しては次の要素が強制的に格納先になる他、末尾での挙動が意図した物なのかは不明です。

(cl-defun test-clfun (&optional &rest &key &aux)
  (list &key)) ;;OK (&keyという変数になります)
(test-clfun 1 2 3) ;;OK

(cl-defun test-clfun (&optional &rest)
  (list "Hello")) ;;OK! (&rest _と同様の使い方を想定している？ たまたま？)
(test-clfun 1 2 3) ;;OK!

;;ちなみに↑は通常のdefunでは実行時エラーになります。

(defun test-fun (&optional &rest)
  (list "Hello"))
(test-fun 1 2 3) ;;Invalid function

VARに書けるもの(分割代入あるいは再帰的な引数リスト)

(VAR...
 [&optional (VAR [INITFORM [SVAR]])...]
 [&rest|&body VAR]
 [&key (([KEYWORD] VAR) [INITFORM [SVAR]])... [&allow-other-keys]]
 [&aux (VAR [INITFORM])...])

VARと書いてある部分には再帰的に引数リストが書けます。また、その引数リストの先頭には &whole 変数という指定ができます。

引数リストを書いた場合はその引数に指定した値が分割代入されます。

(cl-defun test-clfun (a b (c &optional d e))
  (list a b c d e))
(test-clfun 1 2 '(3 4))
;;=> (1 2 3 4 nil)

(cl-defun test-clfun (a b (c1 (c21 c22 &optional c23 c24) &rest c3s) d)
  (list a b c1 c21 c22 c23 c24 c3s d))
(test-clfun 1 2 '(31 (321 322 323) 33 34) 4)
;;=> (1 2 31 321 322 323 nil (33 34) 4)

引数リストの先頭に &whole 変数と書いてあると引数全体がその変数に格納されます。

(cl-defun test-clfun (a b (&whole all c d))
  (list a b c d all))
(test-clfun 1 2 '(3 4))
;;=> (1 2 3 4 (3 4))

ここで変数と書いているのはVARでは無いということです。ここでは分割代入はできません。

(cl-defun test-clfun (a b (&whole (all-c all-d) c d))
  (list a b c d all-c all-d))
(test-clfun 1 2 '(3 4));;Wrong type argument: symbolp, (all-c all-d)

&optional

[&optional (VAR [INITFORM [SVAR]])...]

&optionalは通常のdefunにもある機能ですが次の点が違います。

VARの分割代入
初期値指定 (INITFORM)
指定されたかを判別する変数 (SVAR)

INITFORM

INITFORMは&optionalや&keyword、&auxで変数の初期化に使う式です。

&optionalと&keyの所にあるINITFORMは指定されなかったときだけ評価されます。初期化されてから上書きされるわけではありません。

(let ((opt1-count 0)
      (kw1-count 0))
  (cl-defun test-clfun (&optional
                        (opt1 (cl-incf opt1-count))
                        &key
                        (kw1 (cl-incf kw1-count)))
    (list opt1 kw1))
  (test-clfun 100 :kw1 200)
  (message "%s %s" opt1-count kw1-count) ;;0 0
  (test-clfun)
  (message "%s %s" opt1-count kw1-count) ;;1 1
  (test-clfun 2)
  (message "%s %s" opt1-count kw1-count)) ;;1 2

INITFORMは関数内の最初の方で評価されます。呼び出す場所でマクロ展開・評価されるわけではありません。

(funcall
 (let ((a 2))
   (cl-defun test-clfun (b &optional (c (* a b)))
     (list a b c))
   #'test-clfun)
 3)
;;=>
;;レキシカルバインディング時: (2 3 6)
;;ダイナミックバインディング時: Symbol’s value as variable is void: a

(cl-defun test-clfun (b &optional (c (* a b)))
  (list a b c))

(let ((a 2))
  (test-clfun 3)))
;;=>
;;レキシカルバインディング時: Symbol’s value as variable is void: a
;;ダイナミックバインディング時: (2 3 6)

引数の左側は参照できて右側は参照できません。

(cl-defun test-clfun (a &optional (b (* a c)) &aux (c 100))
  (list a b c))
(test-clfun 2) ;;Symbol’s value as variable is void: c

SVAR

SVARには省略可能(&optionalまたは&key)な引数が指定されたかどうか(nilまたはt)を格納する変数を指定出来ます。

(cl-defun test-clfun (&optional
                      (opt1 100 opt1-supplied)
                      &key
                      (kw1 200 kw1-supplied))
  (list opt1 opt1-supplied kw1 kw1-supplied))
(test-clfun) ;;=> (100 nil 200 nil)
(test-clfun 1) => (1 t 200 nil)
(test-clfun nil :kw1 nil) ;;=> (nil t nil t)

引数の値がnilのときに省略されてnilになったのかnilを指定されたのかが区別できます。

ちなみにSVARは分割代入が可能ですが、nilかtしか渡されないのであまり意味は無いと思います。

(cl-defun test-clfun (&optional (opt1 100 (&whole opt1-sup-all &rest opt1-sup-args)))
  (list opt1 opt1-sup-all opt1-sup-args))
(test-clfun 1) ;;=> (1 t t)

&restまたは&body

[&rest|&body VAR]

&restまたは&bodyの後には一つのVARが続きます。

&restは通常のdefunにもある機能ですが、VARなので分割代入が出来ます。

(cl-defun test-clfun (a &rest (b c d &key e f))
  (list a b c d e f))
(test-clfun 1 2 3 4 :f 6) ;;=> (1 2 3 4 nil 6)

&bodyという表記には何か意味があるみたいですが詳しいことは知りません。

上でも書きましたが、末尾でVARを書かなくても受け入れられるケースがありますが意図的かは分かりません。

&key

[&key (([KEYWORD] VAR) [INITFORM [SVAR]])... [&allow-other-keys]]

&keyはいわゆる名前付き引数を実現するための機能です。

例えば次のような関数呼び出しを実現します。

(cl-defun test-clfun (&key a b c d)
  (list a b c d))
(test-clfun :d 345 :b 234 :a 123) ;;=> (123 234 nil 345)

;; より複雑な例 b:初期値, c:分割代入、初期値、指定の有無
(cl-defun test-clfun (&key a (b 222) ((:c (c1 c2)) '(301 302) c-supplied))
  (list a b c1 c2 c-supplied))
(test-clfun :c '(30001 30002) :a 1 :b 2) ;;=> (1 2 30001 30002 t)

キーワードの順番は自由です。

同じキーワードが指定された場合は最初のものが採用され後のものは無視(破棄)されます。

(cl-defun test-clfun (&key a b c d)
  (list a b c d))
(test-clfun :b 100 :b 101 :b 102) ;;=> (nil 100 nil nil)

INITFORMやSVARは&optionalの時と同じです。省略時はINITFORMの評価値か、INITFORMが無ければnilです。キーワードが指定されたかはSVARに指定した変数で判別可能です。

問題は肝心のキーワードと受け取る変数を指定する部分です。

(([KEYWORD] VAR) 略)

と書いてありますが、実際にはもう少し説明が必要でしょう。ここに書けるのは次の3パターンです。

シンボル: 次の (シンボル) と等価です。
(シンボル 略): キーワードと変数を同時に指定します。 シンボル の頭に:を付けたものがキーワードになります。もし シンボル の頭に_があるなら先に取り除いてからキーワードにします(未使用変数をマークできるようにするため)。引数の値は シンボル で指定した名前の変数に格納されます。
((シンボル VAR) 略): シンボル がそのままキーワードになります。引数の値はVARに格納されます。VARなので分割代入が可能です。

末尾に&allow-other-keysが指定されていると定義されていないキーワードでも受け入れます。これは&restと組み合わせて取得したり単に無視することもできます。

(cl-defun test-clfun (&key a b c d)
  (list a b c d))
(test-clfun :d 345 :b 234 :a 123 :z 999) ;;Keyword argument :z not one of (:a :b :c :d)

(cl-defun test-clfun (&key a b c d &allow-other-keys)
  (list a b c d))
(test-clfun :d 345 :b 234 :a 123 :z 999) ;;=> (123 234 nil 345)

または呼び出し側で許可させることも出来ます。

(cl-defun test-clfun (&key a b c d)
  (list a b c d))
(test-clfun :d 345 :b 234 :a 123 :z 999 :allow-other-keys t) ;;=> (123 234 nil 345)
(test-clfun :allow-other-keys t :d 345 :b 234 :a 123 :z 999) ;;=> (123 234 nil 345)
(test-clfun :allow-other-keys nil :d 345 :b 234 :a 123 :z 999) ;;Keyword argument :z not one of (:a :b :c :d)

&optionalと&keyを同時に指定した場合

&optionalと&keyの両方が引数リストにある場合は注意が必要です。

例えば次のような書き方は問題ありませんが……

(cl-defun test-clfun (a b &optional c d &key e f)
  (list a b c d e f))
(test-clfun 1 2 3 4 :e 5 :f 6) ;;=> (1 2 3 4 5 6)
(test-clfun 1 2 3 4) ;;=> (1 2 3 4 nil nil)
(test-clfun 1 2 nil nil :e 5 :f 6) ;;=> (1 2 nil nil 5 6)

&optionalを省略して&keyを指定することはできません。

(test-clfun 1 2 :e 5 :f 6) ;;=> (1 2 :e 5 nil 6)

そもそも最初から次のようなミスもあり得ます。

(test-clfun :e 5 :f 6) ;;=> (:e 5 :f 6 nil nil)

位置引数(positional parameter)と名前付き引数(named parameter)の食い合わせが悪いという言い方も出来るかもしれません。&optionalまでが位置で指定する引数であり、キーワードはその後からになります。

&restと&keyを同時に指定した場合

&restと&keyは並列に処理されます。

(cl-defun test-clfun (a b &rest args &key c d e)
  (list a b c d e args))
(test-clfun 111 222 :c 3 :d 4 :e 5) ;;=> (111 222 3 4 5 (:c 3 :d 4 :e 5))

&optional引数の最後より後は全て&restで指定されたVARに入るとともに、それらは同時にキーワード引数として処理されます。

&restの方にはあくまで指定されたものがそのまま入ります。

(cl-defun test-clfun (a b &rest args &key c d e)
  (list a b c d e args))
(test-clfun 111 222 :c 3 :e 5 :c 33 :c 333 999 :allow-other-keys t) ;;=> (111 222 3 nil 5 (:c 3 :e 5 :c 33 :c 333 999 :allow-other-keys t))

&aux

[&aux (VAR [INITFORM])...])

&auxは関数内部で使える変数を定義するためのものらしいです。

次の二つの関数は等価です。

(cl-defun test-clfun (a b &aux (z (+ a b)))
  ""
  ...)
(cl-defun test-clfun (a b)
  ""
  (let ((z (+ a b)))
    ...))

&auxの部分はドキュメント文字列にも載りません。

なぜこんなものがあるのかは次のページの議論が参考になりそうです。

what is &aux used for?

あながち互換性のためだけのものとは言えないかもしれません。letの字下げが鬱陶しいと思ったことは度々あるので、それが抑えられるのは案外嬉しいかもしれませんね。

もし&auxが引数リストのどこにでも書けてINITFORMから参照できたらもっと有用だったかもしれません。……と思いましたが、VARには分割代入で再帰的な引数リストが書けるのですから次のような使い方は出来ますね。

(cl-defun test-clfun ((&rest lst &aux (lst-len (length lst))) ;;lengthを1回で済ます！
                      &optional (mid (/ lst-len 2)) (upper lst-len))
  (list lst mid upper lst-len))
(test-clfun '(1 2 3 4 5 6 7 8)) ;;=> ((1 2 3 4 5 6 7 8) 4 8 8)

(追記)&optionalな引数は指定もINITFORMも無い場合でもnilが分割代入されるのでしょうか。

(cl-defun test-clfun (&optional ((&rest lst &aux (lst-len (length lst)))))
  (list lst lst-len))
(test-clfun) ;;=> (nil 0)

うん、ちゃんと&auxの評価されて0になりますね。

実態に即した文法

以上を踏まえて実態に即した文法を書くとだいたい次のような感じでしょうか？

LAMBDA-LIST :
  ([VAR]...
   [&optional [SYMBOL|(VAR [INITFORM [SVAR]])]...]...
   [&rest|&body VAR]
   [&key [SYMBOL|(SYMBOL|(SYMBOL VAR) [INITFORM [SVAR]])]... [&allow-other-keys]]...
   [&aux [(VAR [INITFORM])]...]...)

VAR :
  SYMBOL|
  ([VAR]...
   [&whole SYMBOL]
   [&optional [SYMBOL|(VAR [INITFORM [SVAR]])]...]...
   [&rest|&body VAR]
   [&key [SYMBOL|(SYMBOL|(SYMBOL VAR) [INITFORM [SVAR]])]... [&allow-other-keys]]...
   [&aux [(VAR [INITFORM])]...]...)

SVAR :
  VAR

まぁ、ほとんどは明文化されていない未定義状態なのである日突然変わって鼻から悪魔が出ても文句は言えないかもしれません。

続く

何でこんな重箱の隅をつつくようなことをしているかというと引数リストを解析する必要があったからなのですが、それはまた次のお話しということで。あー、やっぱり面倒くさかった。嫌だ嫌だ。

2022-12-26 Emacs

Windows上のEmacsで初期化を速くする即効性のある方法

Windows上のEmacsは起動もかなり遅く私もこれまでに色々試したのですが、今回はその中で最も効果的だったload-path解決の高速化をご紹介したいと思います。

何が遅いのか

Windows環境でプロファイルをするとすぐに見つかるのが locate-library が遅いということだと思います。つまり、 (locate-library "magit") などとしたときにこれに平気で数十ミリ秒も持って行かれたりします。

試しにやってみましょう。

(car (benchmark-run 1 (locate-library "magit")))

0.06533

65msかかりました。

今私の手元では (length load-path) は 218 を返してきます。つまり、load-pathに218のディレクトリが設定されているわけです(無駄なディレクトリ多すぎ)。

load-pathの中で最も最後にあるのが (Emacsのインストールディレクトリ)/share/emacs/28.2/lisp/obsolete ですが、その最後のファイルであるyow.elを探してみましょう。

(car (benchmark-run 1 (locate-library "yow")))

0.113833

なんと113.8msもかかりました。

一方で一番最初のディレクトリにあったのは all-the-icons-dired.el でした。

(car (benchmark-run 1 (locate-library "all-the-icons-dired")))

0.001121

こちらは1.1msで済んでいます。

load-path上の順番によって処理速度が大幅に変わっていることが分かります。

locate-library よりもやや気がつきにくいのですが、実は require も同じだけかかっています。 (require 'magit) とすれば初回は当然パスを解決するだけで65msかかってしまいます。trampを読み込むだけで1秒以上持って行かれるのには参りました。その中でも分かりやすかったのがring.el。見てみれば分かりますがとてもシンプルなelispですが、やはり60msくらいrequireで時間を消費していました。こんな他のファイルに依存していない小さなファイルの読み込みがそんなにかかるわけがありません。読み込み以前のパスの解決でそれだけかかっているのです。

なぜ遅いのか

知りません。なぜ遅いのかを知るにはC言語のコードに遡って処理を理解する必要がありますが面倒くさいので見ていません。

また、手元のVirtualBoxに入れたUbuntu(Emacs 27.1)で同様の試験をした結果……

(benchmark-run 1 (locate-library "yow"))

0.007467886

(length load-path) が165で、一番最後にあるyowのパスを特定するのに7msかかりました。文字通り桁が違います。

というわけでWindows版のEmacsに特有の現象である可能性が高そうです。Windowsのファイル処理が遅いのか、それともWin32APIからEmacs Lispまでの間に何かあるのか、調べてみなければ確かなことは分かりません。まぁ、おそらくその両方でしょう。それにしても100msはとんでもない時間だとは思いますが。Win32で同じ処理を直書きして比較してみたいものです。

詳しい原因は分かりませんが、load-path上の順番で処理時間が大幅に変わることから、毎回ディレクトリを検索している可能性が高そうです。

高速化の方法

であれば解決方法は全ファイルの位置をキャッシュしてしまうことでしょう。

もちろんload-pathとその下にあるファイルが変わらないという前提が必要です。幸い私が利用しているパッケージには少なくとも初期化中にload-pathを書き替えるものはありませんでした。新しくelispを生成する物も無し。強いて言えばpackage.elですが、package-enable-at-startupがtなのでinit.elの前にload-pathが設定されます。未インストールのパッケージを自動的にインストールするようにしているとそのタイミングでload-pathが変わることはあるでしょう。自分用にload-pathを追加しているところもあります。しかし、それ以降は変わることはありません。ある時点から初期化終了まではload-pathが変わらないので、少なくともその期間は問題なくキャッシュ出来るでしょう。

というわけで作成したのが次のコードです。

;;;; 高速ライブラリパス解決

(defvar my-locate-library-list nil
  "ファイルのベース名をシンボル化したもののリスト。
後でリセットするためのもの。")

(defvar my-locate-library-load-path nil
  "build時点でのload-path。変更を(簡易的に)検出するためのもの。")

(defconst my-locate-library-file-extensions
  (get-load-suffixes)
  "ロード対象の拡張子リスト")
(defconst my-locate-library-file-regexp
  (concat "\\`\\(.*\\)\\(" (mapconcat #'regexp-quote my-locate-library-file-extensions "\\|") "\\)\\'")
  "ロード対象のファイルにマッチし、ベース名と拡張子を取り出す正規表現。")

(defun my-locate-library-build ()
  "`my-locate-library'関数用のデータを構築する。

`load-path'が確定したら呼び出すこと。"
  ;; load-pathの変更を検出するために構築時のload-pathを保存する。
  ;; my-locate-libraryのたびに厳密な検査は時間がかかりすぎてやりたくないが
  ;; せめて先頭の比較くらいはしたい。
  ;; pushやpopしたくらいなら変更に気づけるので。
  ;; 厳密に判定したいなら、copy-sequenceしておいてequalで判定するくらいか？
  ;; もちろんそれでもファイルが増えたことには気づけない。
  (setq my-locate-library-load-path load-path)

  ;; load-path上の全てのディレクトリを走査する。
  ;; 先頭、つまり優先するものから走査する。
  (dolist (dir load-path)
    ;; 存在するディレクトリであること。
    (when (file-directory-p dir)
      (let (files) ;; filesは(ベース名 . 拡張子)のリスト。
        ;; dirの下にあるロード対象ファイルをリストアップする。
        ;; ファイルのベース名と最も優先する拡張子を求める。
        ;; 例: (foo.el foo.elc bar.el bar.txt aaa.txt) => (foo.elc bar.el)
        ;; directory-filesはソートされたリストを返すので、ベース名が一致
        ;; するファイルは隣接することを利用する。
        (dolist (file (directory-files dir))
          ;; 有効な拡張子を持つファイルであること。
          (when (string-match my-locate-library-file-regexp file)
            ;; ベース名と拡張子を取り出す。
            (let ((curr-base (match-string 1 file))
                  (curr-ext (match-string 2 file)))
              ;; 一つ前のベース名と比較する
              (if (equal (car (car files)) curr-base)
                  ;; 一つ前と同じベース名の場合 (e.g. foo.el and foo.elc)
                  ;; 拡張子の優先順位を比較する
                  ;;@todo .elcのタイムスタンプを考慮すべき？
                  (if (< (my-locate-library-ext-priority curr-ext)
                         (my-locate-library-ext-priority (cdr (car files))))
                      ;; 現在のを取る
                      (setcdr (car files) curr-ext)
                    ;; 一つ前のを取る
                    nil)
                ;; 違うベース名の場合
                (push (cons curr-base curr-ext) files)))))
        ;; シンボルを作りそのプロパティにパスを設定する。
        (dolist (base-ext files)
          (my-locate-library-set-path dir (car base-ext) (cdr base-ext)))))))

(defun my-locate-library-ext-priority (extension)
  "EXTENSIONの優先順位を示す整数値を返す。
例えば.elcの方が.elよりも小さな値を返す。"
  (seq-position my-locate-library-file-extensions extension))

(defun my-locate-library-set-path (dir base ext)
  "BASEをシンボル化し、それにファイルへのパス(DIR/BASE EXT)をプロパティとして設定する。"
  (let ((sym (intern base)))
    (unless (get sym 'my-locate-library-path) ;;上書きするとload-pathで後にある方が優先されてしまうので注意。
      (let ((path (file-name-concat dir (concat base ext))))
        ;;(message "library %s path=%s" sym path)
        (put sym 'my-locate-library-path path)
        (push sym my-locate-library-list)))))

(defun my-locate-library-clean ()
  (dolist (sym my-locate-library-list)
    (put sym 'my-locate-library-path nil))
  (setq my-locate-library-list nil))

(defun my-locate-library-rebuild ()
  (my-locate-library-clean)
  (my-locate-library-build))

(defun my-locate-library (file)
  "FILEで指定したファイルがあればそのパスを返す。

`locate-library'は非常に時間がかかるがこれは短時間でチェックできる。

FILEはシンボルでも良く、文字列を指定するよりも速い。"
  (unless (eq load-path my-locate-library-load-path)
    (warn "load-path change detected on (my-locate-library %s)" file)
    (my-locate-library-rebuild))
  ;; 私の手元ではlocate-libraryに拡張子が付いたファイル名や相対パスを指定するコードは無かったので以下は省略。
  ;;@todo 拡張子を考慮 例:(locate-library "tramp.el.gz")
  ;;@todo ディレクトリ名(相対パス指定)を考慮 例:(locate-library "net/tramp")
  ;; (when (stringp file)
  ;;   (when (file-name-directory file)
  ;;     (warn "directory specified on (my-locate-library %s)" file))
  ;;   (when (file-name-extension file)
  ;;     (warn "extension specified on (my-locate-library %s)" file)))
  (get (if (stringp file) (intern file) file) 'my-locate-library-path))

;; 以下、adviceでlocate-library、require、loadを書き替える。

(defun my-locate-library-advice (orig-fun
                                 library &optional
                                 nosuffix path interactive-call)
  (if (or (not (stringp library))
          (file-name-extension library) ;;2022-12-26:追加 動かないケースを除外する
          (file-name-directory library) ;;2022-12-26:追加 動かないケースを除外する
          nosuffix path interactive-call)
      ;; 想定していない使い方の場合はオリジナルを呼び出す。
      (funcall orig-fun library nosuffix path interactive-call)
    (my-locate-library (intern library))))

(defun my-locate-library-require-advice (orig-fun
                                         feature &optional filename noerror)
  (unless filename
    ;; ファイル名(パス)を補う。
    (setq filename (my-locate-library feature)))
  (funcall orig-fun feature filename noerror))

(defconst my-locate-library-load-suffixes-with-nil
  (cons nil (get-load-suffixes)))

(defun my-locate-library-load-advice (orig-fun
                                      file &optional
                                      noerror nomessage nosuffix must-suffix)
  (funcall orig-fun
           (or (and (stringp file)
                    (not nosuffix)
                    (not must-suffix)
                    (not (file-name-directory file))
                    (member (file-name-extension file)
                            my-locate-library-load-suffixes-with-nil)
                    (my-locate-library (file-name-base file)))
               file)
           noerror nomessage nosuffix must-suffix))

(defun my-locate-library-enable ()
  "`locate-library'や`require'、`load'のパス解決を高速化する。

あらかじめ`load-path'が確定した段階で`my-locate-library-build'を
実行しておくこと。

`my-locate-library-disable'で元に戻せる。"
  (advice-add #'locate-library :around #'my-locate-library-advice)
  (advice-add #'require :around #'my-locate-library-require-advice)
  (advice-add #'load :around #'my-locate-library-load-advice))

(defun my-locate-library-disable ()
  (advice-remove #'locate-library #'my-locate-library-advice)
  (advice-remove #'require #'my-locate-library-require-advice)
  (advice-remove #'load #'my-locate-library-load-advice))

locate-libraryには拡張子が付いたファイル名や相対パスも指定出来るようですが上のコードはそれらには対応していません。そのようなコードがある場合は自分で修正して下さい。

使い方は、load-pathが確定した段階で次のようにします。

(my-locate-library-build)
(my-locate-library-enable)

これでlocate-library、require、loadのよく使われる呼び出し形式が速くなります。ディレクトリを指定したり、ファイルの拡張子を指定したりする一部の呼び出し形式は速くなりません。速くならないどころか正しく動作しない場合もあるので注意して下さい(手抜きです)。

また、使用が終わったら次のようにします。

(my-locate-library-disable)

いつload-pathが変わるか分かりませんし、locate-libraryやrequire、loadに対して私が考慮していない引数を渡すコードがいつ実行されるかも分かりません。初期化が終わったら念のためdisableしておく方が良いでしょう。

効果の確認

(car (benchmark-run 1 (my-locate-library "yow")))

5e-06

桁が違うどころではありませんね(笑)

通常のlocate-libraryと違いシンボルも受け付けます。こちらの方がinternしなくて良いので若干早くなります。

(car (benchmark-run 1 (my-locate-library 'yow)))

3e-06

my-locate-library-enableしておけば通常のlocate-libraryも速くなります。

(my-locate-library-build)
(my-locate-library-enable)
(prog1 (car (benchmark-run 1 (locate-library "yow")))
  (my-locate-library-disable))

4e-06

requireも速くなります。例えば私のload-pathに218個のディレクトリが指定されている環境で、初期化の最初で動作を止めて (require 'tramp)を実行してみましょう。

(car (benchmark-run 1 (require 'tramp)))

1.269366

1.269秒(笑)

上のコードを評価しつつ有効化した後だと

(car (benchmark-run 1 (require 'tramp)))

0.197264

197msと大幅に短くなりました。(それでもかなり長いですが)

ちなみにemacs -Q環境だとload-pathの長さは24で (require 'tramp)は366msほどでした。load-pathに登録されているディレクトリが少なく検索する時間があまりかからないケースでは効果も薄くなります。

キャッシュの構築にかかる時間ですが

(car (benchmark-run 1 (my-locate-library-build)))

0.070408

実行毎にかなりバラツキがあるのですが、70msくらいのことが多いようです。平均的には90msくらい。元のlocate-libraryの1回分と大差ありません。Emacsで全ディレクトリを走査するとそのくらいかかるということなのでしょうね。

初期化プロセス全体だと大量のrequireが発生するのでこれだけで何秒も変わるほどのインパクトがあります。

Emacsの起動時間の短縮はelispの読み込みを遅延するのが王道ですが、Windowsでどうしてもある程度以上短くならないとお悩みの方は試してみてはいかがでしょうか。細かい注意点がいくつかあるので、よく読んだ上でご利用下さい。

まぁ、あとディレクトリも減らした方がいいですね。使っていないの多すぎ。整理しないと。

2022-12-21 Edraw, Emacs

Emacsの中で動く作図ツール最近の変更点

最近またEmacsの中で動く作図ツールをいじっています。

misohena/el-easydraw: Embedded drawing tool for Emacs

図1: 作成した図形をカスタムシェイプに登録して使用する様子(gifのため色数少ない)

(↑のgifアニメですが、C-u クリックで既存のアンカーポイントに接続しないでアンカーポイントを追加しています。つまり、一筆書きで描いています。2ストロークに分けた方が自然かもしれません)

phscrollの修正

org-modernと組み合わせたときにいくつか問題が目に付いたので修正しました。ついでに修正した点もいくつか。

misohena/phscroll: Enable partial horizontal scroll in Emacs

主な修正点:

phscroll-use-fringeをdefvarからdefcustomへ変更
左右スクロールコマンドでポイント位置を動かすオプションを追加
左右スクロールコマンドでスクロールする方向を反転するオプションを追加
Shift+マウスホイールでのスクロールに対応
orgテーブルの直後を余分にスクロール領域にしてしまうミスを修正
フィールドテキストがあるときに正しく動作しない問題を修正
org-phscroll使用時はmodification-hooksでは更新せずfontify時に更新するように変更
font-lockへの登録方法を修正
ピクセル単位で幅計算するオプションを追加(実験的)

左右スクロールコマンドが使いづらいという指摘があって私も同感で使っていないのですが、ポイントも一緒に動くようにしたりして少しはマシになりました。元々Emacs標準のscroll-left(C-x <)、scroll-right(C-x >)を真似た物でしたが、それ自体使いづらいですからね。

ついでにマウスのホイールに対応してみました。プラットフォームによってホイールのイベント名は変わるそうですね？　知りませんでした。mouse-wheel-up-eventやmouse-wheel-down-eventという変数にシンボルが格納されているのでそれを使うのだとか(Misc Events (GNU Emacs Lisp Reference Manual), mwheel.el)。

font-lockのキーワードまわりをあまりよく理解していなかったので必要な部分だけ少し勉強しました。font-lock処理(fontify? highlight?)(font-lock-fontify-keywords-regionを参照)はキーワードリストを上から順に処理していきますが、一つのキーワードで対象範囲の最初から最後までを処理してから次のキーワードをまた最初から処理する流れになっています。何となく複数のキーワードをまぜこぜに処理していくような気がしていたのですがそんなわけはありませんでした。一つの関数でマッチからハイライトまでをやってしまう場合、いくつか注意すべき点があります。基本的にmatcherの関数はre-search-forwardの代わりに呼ばれているので、tを返す場合はmatch-dataも有効でなければなりません。nilを返すのであればその限りにあらず。どちらにせよ一度に一箇所しか処理してはいけないという制約はありません。範囲内全てを一度に処理することは可能です。ただしmultilineや無限ループ回避のコードには注意が必要。

orgやorg-modernのfont-lock処理が終わってからでないと正しいテキスト幅が計算できないという問題に気がつきました。phscrollではテキストの幅を正しく計算することが求められます。これまではオーバーレイのmodification-hooksでテキストの変更を検出して更新処理を行っていましたが、それでは不十分でした。orgがリンクのパス部分を非表示にする(invisibleテキストプロパティにシンボルorg-linkを設定する)とテキストの変更無しに幅が縮まります。org-modernがテーブルの縦線を細くしてもテキストの(ピクセル)幅は縮まります。phscrollはその直後に水平スクロールに必要な幅の計算をしなければなりませんでした。

これまで幅の計算は文字数単位で行っていましたが、org-modernがテーブルの縦線を細くしてしまうと文字数は変わらないのに全体のピクセル数は小さくなってしまいます。すると縦線(テーブルの列)が沢山あるほど右側に無意味なスペースが空くことになっていました。これはピクセル単位で幅の計算をしなければ解決できません。

ピクセル単位での幅の計算は window-text-pixel-size 関数を使用しました。自分でテキストプロパティやオーバーレイを解析して計算しても良いのですが、なかなか完璧には出来ないので。

window-text-pixel-size 関数を使うにしても色々とやっかいな点があります。一番やっかいだったのは、折りたたまれて非表示になっているテキストに対してfont-lock処理が働く場合があることです。非表示になっているので window-text-pixel-size で計算しても幅は0になってしまいます。この問題に対しては、折りたたみ部分を隠すためのオーバーレイ(invisible=(outline . t)が設定されている)を一時的に表示状態(invisible=nil)にすることで解決しました。そんなことをして大丈夫なのか自信が無かったのですが、とりあえず動いています。最初は buffer-invisibility-specからoutlineを抜けば良いと思ったのですが、それだと他の非表示部分(リンクのパス部分など)が全て表示された状態で幅の計算をしてしまいます。テキストプロパティがどうであろうと、上に乗っかっているオーバーレイの非nilなinvisibleプロパティが優先されるようです。オーバーレイのinvisibleプロパティがoutlineである以上、その範囲内は全てinvisible=outlineであり、buffer-invisibility-specからoutlineを消した以上全て表示されてしまうのです。何はともあれ、この方法で解決して良かったです。ダメならそれこそ自分で幅の計算(というかもはや推測)をしなければいけないところでした。また、指定のピクセル幅を超えるテキスト位置を求める必要がありましたがそのような機能はどこにも無いため二分探索で何とかしました。

一応ピクセル単位での幅計算はオプションでデフォルト無効にしてあります。ちょっと重いような気もするので。

というわけでorg-modern下でもそれなりの見た目が実現出来ました。

私はこのプロジェクトがあまり良いものだとは思っていません。一応実用にはなるのですが、やり方はかなり強引ですし、同じ場所を幅の違う複数のウィンドウから見たら破綻するという根本的な問題も抱えています。理想的には、Emacsに折り返しを制御するような特殊なテキストプロパティを追加するのが良さそうに思えます。line-prefixやwrap-prefixと似たようなものです。いつかEmacsにそのような機能が追加されるのを夢見つつ、それまでのつなぎとして作っています。

2022-11-22 Emacs, org-mode

Emacs Lisp要素へのリンクをorg-modeに追加する

(2024-01-16追記: エクスポートに対応したのを書きました)

Emacs Lispの関数や変数、フェイスの定義へリンクを張ろうと思ったら次のような方法くらいしか無いらしい。

- [[elisp:(find-function 'org-mode)]]
- [[file:c:/app-install-dir/emacs-28.2/share/emacs/28.2/lisp/org/org.el::(define-derived-mode org-mode outline-mode "Org"]]

参考: Org-mode link to function definition - Emacs Stack Exchange

ファイル名はバージョンによってパスが変わってしまう。elispリンクタイプは評価するかの確認が必要。

ということで自分で定義した方が良さそう。

(org-link-set-parameters
 "elisp-function"
 :follow (lambda (str) (find-function (intern str))))

(org-link-set-parameters
 "elisp-variable"
 :follow (lambda (str) (find-variable (intern str))))

(org-link-set-parameters
 "elisp-face"
 :follow (lambda (str) (find-face-definition (intern str))))

[[elisp-function:org-version]]

[[elisp-variable:org-version]]

[[elisp-face:org-todo]]

2022-11-19 Emacs

diredに「戻る」機能を追加する

diredにディレクトリを「戻る」機能が無かったので追加してみました。

前提として、私はディレクトリを開くときに元のdiredバッファをkillするように改造して使っています。遙か昔Emacsを使い始めたときに真っ先に気になったことの一つがそれ。いつの間にかEmacsがdiredバッファだらけになっていてびっくりするわけです。他のEmacsユーザのことはほとんど知りませんが、多くの人が気になって直したのではないでしょうか。今日作業中に気がついたのですが、Emacs28からはdired-kill-when-opening-new-dired-bufferというカスタマイズ変数が追加されています。まさにそれを実現するための機能が長い時を経て追加されていました。

それでなぜ今になって戻る機能が欲しくなったかというと、新しいPCでシンボリックリンクを使ったからです。私は普段HOMEディレクトリをUSERPROFILE(C:/Users/名前/)とは別の場所に設定して使っています。C:/home/名前/のように。しかしそうするとUsersとhomeの使い分けが問題になってきます。私はUsersディレクトリはほとんど無視してhomeの中だけで過ごしてきました。そもそもWindows95系にはUsersなんてディレクトリは無かったはずです。古くからのユーザにはC:/の直下に好きなようにファイルを置いている人もまだいるかもしれません。それはともかく、私の使い方ではUsersとhomeが微妙に役割が被るケースがありました。その最たる物がdownloadsディレクトリです。私はこれまでUsersの下のディレクトリは使わずにC:/home/名前/downloadsというディレクトリを作って使っていました。しかし新しいPCをセットアップするたびにC:/Users/名前/Downloadsにファイルがダウンロードされてしまうわけです。ブラウザの設定をまだ変えていないので。ブラウザの設定を変えるのにも飽き飽きしてきましたし、エクスプローラで見たときにUsersの下のDownloadsディレクトリの方がアイコンが付いていて見た目が良く操作もしやすいという利点もあったので、 mklink /d C:\home\名前\downloads C:\Users\名前\Downloads でシンボリックリンクを張ってみたというわけです。個人的にはWindowsでシンボリックリングが欲しくなることというのはほとんど無いのでちょっと新鮮な気分でした。ちなみにシンボリックリンクを作るにはデフォルトでは管理者権限が必要みたいなのですが、Windowsを開発者モード(何だそりゃ)というのにすると管理者権限が無くても大丈夫になるようです。それでEmacsのdiredからC:/home/名前/downloadsディレクトリを開いてみると、C:/Users/名前/Downloadsが開きました。おおちゃんと対応しているじゃないかと気を良くして^を押して上のディレクトリに戻ろうとするとhome側では無くUsers側で上のディレクトリに移動してしまうわけです。原因の一端は find-file-visit-truename が t になっていることにありました。これがtだと開いた段階でシンボリックリンクの名前では無く、真のファイル名で開いてしまうわけです。nilにすればC:/home/名前/downloadsというパスでdiredが開くので、^を押したときにちゃんとC:/home/名前/に戻ります。しかし私は find-file-visit-truename を t に設定した覚えがありません。変数のドキュメントを見るとOriginal valueはnilだと書かれていますし実際files.elのdefcustomはnilです。探してみると、w32-fns.elの先頭付近でWindowsであればtに変更していました。8.3やlongnameを同一のバッファで開くというようなコメントがあります。今時8.3なんてお目にかかりませんしnilにしても問題ないような気がしましたが、念のためいじらないでおこうと思います。となるとシンボリックリンクの飛び先から戻るために最後に開いていたディレクトリに「戻る」機能が必要になるというわけです。ヤレヤレ！

HelpやInfoにも l で戻る機能がありますし、同じキーで戻れるようにしておけば直感的かもしれません。 l はdired-do-redisplayですが個人的には使っていません。 g を押してしまいますし。

既にあったコードも含めて次のようになりました。

(with-eval-after-load "dired"
  ;; 戻る機能を実現する
  
  (defvar-local my-dired-dir-history nil)

  (defmacro my-dired-dir-history-push (&rest body)
    (let ((new-hist (gensym))
          (result (gensym)))
      `(let ((,new-hist (cons (dired-current-directory) my-dired-dir-history))
             (,result (progn
                        ,@body))) ;;ここで新しいバッファを開く
         (setq-local my-dired-dir-history ,new-hist) ;;新しいバッファに履歴を持たせる
         ,result)))

  (defun my-dired-dir-history-back ()
    (interactive)
    ;; 存在しないディレクトリをスキップする。
    (while (and my-dired-dir-history
                (not (file-directory-p (car my-dired-dir-history))))
      (setq my-dired-dir-history (cdr my-dired-dir-history)))
    ;; 最近のディレクトリを開く。
    (when my-dired-dir-history
      (let ((last-dir (car my-dired-dir-history))
            (new-hist (cdr my-dired-dir-history)))
        (set-buffer-modified-p nil)
        (find-alternate-file last-dir)
        (setq-local my-dired-dir-history new-hist))))

  (define-key dired-mode-map "l" #'my-dired-dir-history-back) ;;dired-do-redisplayは個人的に使っていないのと(gを使ってしまう)、helpやinfoがlで戻るのでそれに合わせる。

  ;; aで開いたときに現在のディレクトリを履歴に記録する。

  (defun my-dired-find-alternate-file-for-record-dir-history (original-fun)
    (my-dired-dir-history-push
     (funcall original-fun)))
  (advice-add #'dired-find-alternate-file
              :around
              #'my-dired-find-alternate-file-for-record-dir-history)

  ;; ;; Emacs 28以降でdired-kill-when-opening-new-dired-bufferを使って
  ;; ;; e, f, ^でディレクトリを開いた場合に対応する。
  ;; (defun my-dired--find-file-for-record-dir-history (original-fun find-file-function file &rest args)
  ;;   (if (and (eq find-file-function #'find-alternate-file)
  ;;            (file-directory-p file))
  ;;       (my-dired-dir-history-push
  ;;        (apply original-fun find-file-function file args))
  ;;     (apply original-fun find-file-function file args)))
  ;; (when (and (fboundp 'dired--find-file)
  ;;            (boundp 'dired-kill-when-opening-new-dired-buffer)
  ;;            dired-kill-when-opening-new-dired-buffer)
  ;;   (advice-add #'dired--find-file
  ;;               :around
  ;;               #'my-dired--find-file-for-record-dir-history))
  ;; ↑動作未確認。
  ;; Emacs28以降であれば下の修正をせずに上の修正をしてdired-kill-when-opening-new-dired-bufferをtにすれば良い、はず。

  ;; 元々修正していたファイルを開く処理

  (defconst my-dired-open-desktop-extensions
    '(;;"pdf" <=use pdf-tools
      "xls" "xlsx" "docx" "vsd"
      "psd"
      "wav" "mp3" "aac" "au" "ogg" "flac"
      "mp4" "avi" "mpg" "mpeg"))
  (defun my-dired-w32-open ()
    (interactive)
    (w32-shell-execute "open" (dired-get-filename)))
  (defun my-dired-find-alternate-file ()
    (interactive)
    (cond
     ;; directoryはdired-find-alternate-file(aキー相当)で開く
     ((file-directory-p (dired-get-filename))
      (dired-find-alternate-file))
     ;; 一部の拡張子はw32-shell-executeで開く
     ((member (file-name-extension (dired-get-filename)) my-dired-open-desktop-extensions)
      (my-dired-w32-open))
     ;; emacsで開く
     (t
      (dired-find-file))))

  (define-key dired-mode-map "\C-m" 'my-dired-find-alternate-file) ;;C-mやRET

  ;; 元々修正していた上ディレクトリに移動する処理
  ;; (dired-up-directoryのコードをちょっと修正した物です)

  (defun my-dired-up-directory (&optional other-window)
    "Run dired on parent directory of current directory.
Find the parent directory either in this buffer or another buffer.
Creates a buffer if necessary."
    (interactive "P")
    (let* ((dir (dired-current-directory))
           (up (file-name-directory (directory-file-name dir))))
      (unless (equal dir up)
        (or (dired-goto-file (directory-file-name dir))
            ;; Only try dired-goto-subdir if buffer has more than one dir.
            (and (cdr dired-subdir-alist)
                 (dired-goto-subdir up))
            (progn
              (if other-window
                  (dired-other-window up)
                ;; ここから修正
                ;; 元は(dired up)
                ;; Emacs28からは(dired--find-possibly-alternative-file up)
                (my-dired-dir-history-push
                 (set-buffer-modified-p nil)
                 (find-alternate-file up))
                ;; ここまで修正
                )
              
              (dired-goto-file dir))))))

  (define-key dired-mode-map [delete] 'my-dired-up-directory) ;;Back Space
  (define-key dired-mode-map "^" 'my-dired-up-directory) ;;^

);;with-eval-after-load "dired"

dired-kill-when-opening-new-dired-bufferを使う方法に切り替えようかなとも思いましたが、たまにEmacs27以前をテストのために立ち上げることがあるのでしばらくは使わずにいようと思います。

HOMEをUSERPROFILEと同じにしてしまうという手も考えなくも無いんですけどね。C:/Users/名前/下の乱雑さを見ると気が引けてしまいます。整理していない(アプリが勝手にいじくるママにしている)からというのもあるのでしょうけど。

目次