Selecting fonts using binary search

A few days ago I found a website that lets you find your preferred font. It does this by presenting two different choices next to one another where you have to select whatever you like better.

One disadvantage is that I don’t have all the fonts installed on my system, and they might not look the same in the web browser as they do in my editor (Emacs).

Speaking of Emacs, why not re-implement the game right in Emacs? I sat down to do so yesterday evening and smoothed out the remaining bugs this evening, and this is what I got:

(defun binary-font-search ()
  "Compare two monospaced fonts until only one is left."
  (interactive)
  (let ((line (line-number-at-pos)) queue)
    ;; Extract fixed-width font names
    (dolist (fam (x-family-fonts))
      (when (aref fam 5)
        (push (symbol-name (aref fam 0)) queue)))
    ;; Check if there are enough fonts
    (when (<= (length queue) 1)
      (user-error "Not enough fixed-width fonts for binary Search"))
    ;; Shuffle font list (should use Fischer-Yates)
    (setq queue (sort (delete-dups queue) (lambda (_ _) (= (random 2) 0))))
    ;; Start binary search
    (save-window-excursion
      (while (< 1 (length queue))
        (let ((buf-a (clone-indirect-buffer "font-a" nil))
              (buf-b (clone-indirect-buffer "font-b" nil))
              (font-a (pop queue))
              (font-b (pop queue)))
          (delete-other-windows)
          (unwind-protect
              (let* ((win-a (selected-window))
                     (win-b (split-window-right)))
                (set-window-buffer win-a buf-a)
                (with-selected-window win-a
                  (face-remap-add-relative 'default :family font-a)
                  (setq mode-line-format " Font A")
                  (goto-char (point-min))
                  (forward-char line))
                (set-window-buffer win-b buf-b)
                (with-selected-window win-b
                  (face-remap-add-relative 'default :family font-b)
                  (setq mode-line-format " Font B")
                  (goto-char (point-min))
                  (forward-char line))
                (let ((pref (let (c r)
                              (while (not r)
                                (setq c (read-char  "Prefer font A or font B?"))
                                (cond
                                 ((memq c '(?a ?A))
                                  (setq r font-a))
                                 ((memq c '(?b ?b))
                                  (setq r font-b))
                                 ((message "Invalid choice"))))
                              r)))
                  (setq queue (nconc queue (list pref)))))
            (kill-buffer buf-a)
            (kill-buffer buf-b)))))
    (message "You appear to prefer the font %S." (car queue))))

After evaluating the command, you start it using M-x binary-font-search. The current buffer is used as a reference, the frame is split into two windows and you choose whichever you like better. This goes on until only one font is available.

To prevent favouritism you aren’t told the names of the fonts you are comparing. Only after the last decision was made are you told the name of the font.

Of course this is just a rough sketch. Various improvements could be made to the selection UI, detecting and preventing the usage of broken fonts among other things. Maybe a listing of second place, third/forth place, etc. would also be interesting.