Emacs: Replace all words in buffer with random words of the same length

replace-words-randomly.el

;; This function replaces all words in a buffer with words of the same length, 
;; chosen at random from /usr/share/dict/words.  Words are replaced consistently, 
;; so e.g. "A" is always replaced with "Z".  The mapping changes when Emacs is 
;; restarted or when the cache buffer is killed.  If all unique words of a certain
;; length are exhausted, random strings are used.

(defun ap/replace-words-randomly (&optional buffer)
  "Replace all words in BUFFER or current buffer with randomly selected words from the dictionary.
Every time a new word is found, it is mapped to a replacement
word, so every instance of word A will be replaced with word Z."
  (interactive)
  (require 'ht)
  (with-current-buffer (or buffer (current-buffer))
    (let ((replacements (ht-create))
          (used-words (ht-create))
          (regexp (rx (or bow symbol-start) (1+ word) (or eow symbol-end)))
          (case-fold-search t)
          (orig-mode major-mode)
	  ;;  (window (get-buffer-window (current-buffer)))
          (buffer-size (buffer-size))
          current-word replacement-word)
      (fundamental-mode)
      (goto-char (point-min))
      (while (re-search-forward regexp nil 'noerror)
        (setq current-word (s-downcase (match-string 0)))
        (save-match-data  ; `ap/get-random-word-of-same-length' changes match data
          (unless (setq replacement-word (ht-get replacements current-word))
            ;; Find unique replacement word and add to hash-tables.
            ;; We use a second ht to store words that we've already
            ;; used, because looking them up as keys is much faster
            ;; than getting all the values in the replacements table.
            (while (ht-get used-words
                           (setq replacement-word (ap/get-random-word-of-same-length current-word used-words)))
              nil)
            (unless replacement-word
              ;; No word found; make random string (which may not be
              ;; unique, but we can't really guarantee uniqueness in the
              ;; case of very short words unless we go into non-word
              ;; characters, Unicode, etc)
              (setq replacement-word (ap/get-random-string (length current-word))))
            ;; TODO: Filter profanity?
            ;; Add to hash-tables
            (ht-set replacements current-word replacement-word)
            (ht-set used-words replacement-word t)))
        ;; Replace match
        (replace-match replacement-word nil 'literal)
        ;; Allow Emacs to be interrupted gracefully.  Also potentially
        ;; displays progress if you have the buffer visible, but I can't get
        ;; recentering to work.
        (sit-for 0)
        ;; Display progress (this takes a while on large buffers)
	(message "%s/%s" (point) buffer-size)
        ;; No idea why this doesn't work.  I have to save and restore
	;; point manually or it doesn't move past the matches and runs
	;; in an infinite loop, but then recenter does nothing at all
        ;; (when window
        ;;   (setq save-point (point))
        ;;   (with-selected-window window
        ;;     (recenter t))
        ;;   (goto-char save-point))
	)
      (funcall orig-mode))))

(cl-defmacro ap/with-random-word-cache (&rest body)
  ""
  (declare (indent defun)
           (debug (&rest form)))
  (let ((result (cl-gensym)))
    `(progn
       (unless (and (boundp 'ap/random-word-buffer)
                    (buffer-live-p ap/random-word-buffer))
         (with-current-buffer (setq ap/random-word-buffer (get-buffer-create " *RANDOM WORDS*"))
           (call-process-shell-command "cat /usr/share/dict/words | shuf" nil t))
         (setq ap/random-word-buffer-point 1))
       (with-current-buffer ap/random-word-buffer
         (let (,result)
           (goto-char ap/random-word-buffer-point)
           (setq ,result (progn ,@body))
           ;; This point-saving and restoring should NOT be necessary, I have no idea why this is.
           (setq ap/random-word-buffer-point (point))
           ,result)))))

(defun ap/get-random-word-of-same-length (word &optional exclude-ht)
  (let* ((length (length word))
         (regexp (rx-to-string `(seq bol (repeat ,length word) eow))))
    (ap/with-random-word-cache
      ;; Search from last point, wrap once
      (when (= (point) (point-max))
        (goto-char (point-min)))
      (cl-loop with starting-point = (point)
               with match
               with wrapped
               until (or match
                         (and wrapped
                              (>= (point) starting-point)))
               do (progn
                    (when (= (point) (point-max))
                      (goto-char (point-min))
                      (setq wrapped t))
                    (when (re-search-forward regexp nil 'goto-end)
                      (setq match (match-string 0))
                      (unless (and (not (string= match word))
                                   (or (not exclude-ht)
                                       (not (ht-get exclude-ht match))))
                        ;; Invalid match, clear var
                        (setq match nil))))
               finally return match))))

(defun ap/get-random-string (length)
  "Return random string of LENGTH."
  (unless (and (bound-and-true-p ap/random-chars)
               (bound-and-true-p ap/random-chars-length))
    (setq ap/random-chars (split-string "abcdefghijklmnopqrstuvwxyz" "" t))
    (setq ap/random-chars-length (length ap/random-chars)))
  (let* (s)
    (while (< (length s) length)
      (setq s (concat s (nth (random ap/random-chars-length) ap/random-chars))))
    s))