1 files changed, 197 insertions, 0 deletions

@@ -0,0 +1,197 @@
+;;; titlecase.el --- title-case phrases -*- lexical-binding: t; -*-
+
+;;; Commentary:
+
+;; adapted from https://hungyi.net/posts/programmers-way-to-title-case/
+
+;;; Code:
+
+(require 'seq)
+
+(defgroup titlecase nil
+  "Customizations for titlecasing phrases."
+  :prefix "titlecase-"
+  :group 'text)
+
+;;; Lists of words /never/ to capitalize
+
+(defvar titlecase-prepositions
+  '("'thout" "'tween" "aboard" "about" "above"
+    "abreast" "absent" "abt."  "across" "after" "against" "ago" "aloft" "along"
+    "alongside" "amid" "amidst" "among" "amongst" "anti" "apart" "apropos"
+    "around" "as" "aside" "aslant" "astride" "at" "atop" "away" "before"
+    "behind" "below" "beneath" "beside" "besides" "between" "beyond" "but" "by"
+    "c." "ca." "circa" "come" "concerning" "contra" "counting" "cum" "despite"
+    "down" "during" "effective" "ere" "except" "excepting" "excluding" "failing"
+    "following" "for" "from" "hence" "in" "including" "inside" "into" "less"
+    "like" "mid" "midst" "minus" "mod" "modulo" "near" "nearer" "nearest"
+    "neath" "next" "notwithstanding" "o'" "o'er" "of" "off" "offshore" "on"
+    "onto" "ontop" "opposite" "out" "outside" "over" "pace" "past" "pending"
+    "per" "plus" "post" "pre" "pro" "qua" "re" "regarding" "respecting" "round"
+    "sans" "save" "saving" "short" "since" "sub" "t'" "than" "through"
+    "throughout" "thru" "thruout" "till" "times" "to" "toward" "towards" "under"
+    "underneath" "unlike" "until" "unto" "up" "upon" "v." "versus" "via"
+    "vis-à-vis" "vs." "w."  "w/" "w/i" "w/o" "wanting" "with" "within"
+    "without")
+  "List of prepositions in English.
+This list is, by necessity, incomplete, even though prepositions
+are a closed lexical group in the English language.  This list
+was pulled and culled from
+https://en.wikipedia.org/wiki/List_of_English_prepositions.")
+
+(defvar titlecase-articles '("a" "an" "the")
+  "List of articles in English.")
+
+(defvar titlecase-coordinating-conjunctions '("for" "and" "nor" "but" "or"
+                                              "yet" "so")
+  "List of coordinating conjunctions in English.")
+
+(defvar titlecase-lowercase-chicago (append titlecase-articles
+                                            titlecase-prepositions
+                                            titlecase-coordinating-conjunctions)
+  "Words to lowercase in Chicago Style.
+Include: articles, coordinating conjunctions, prepositions, and
+\"to\" in an infinitive (though that's caught as a preposition).")
+
+(defvar titlecase-lowercase-apa (append titlecase-articles
+                                        (seq-filter (lambda (p)
+                                                      (< (length p) 4))
+                                                    titlecase-prepositions))
+  "Words to lowercase in APA Style.")
+
+(defvar titlecase-lowercase-mla (append titlecase-articles
+                                        titlecase-prepositions
+                                        titlecase-coordinating-conjunctions)
+  "Words to lowercase in MLA Style.")
+
+(defvar titlecase-lowercase-ap (append titlecase-articles
+                                       (seq-filter (lambda (p)
+                                                     (< (length p) 4))
+                                                   titlecase-prepositions)
+                                       (seq-filter
+                                        (lambda (p)
+                                          (< (length p) 4))
+                                        titlecase-coordinating-conjunctions))
+  "Words to lowercase in AP Style.")
+
+(defvar titlecase-lowercase-bluebook (append titlecase-articles
+                                             titlecase-coordinating-conjunctions
+                                             (seq-filter
+                                              (lambda (p)
+                                                (< (length p) 4))
+                                              titlecase-prepositions))
+  "Words to lowercase in Bluebook Style.")
+
+(defvar titlecase-lowercase-ama (append titlecase-articles
+                                        titlecase-coordinating-conjunctions
+                                        (seq-filter (lambda (p)
+                                                      (< (length p) 4))
+                                                    titlecase-prepositions))
+  "Words to lowercase in AMA Style.")
+
+(defvar titlecase-lowercase-nyt (append titlecase-articles
+                                        titlecase-prepositions
+                                        titlecase-coordinating-conjunctions)
+  "Words to lowercase in New York Times Style.")
+
+(defvar titlecase-lowercase-wikipedia
+  (append titlecase-articles
+          (seq-filter (lambda (p) (< (length p) 5)) titlecase-prepositions)
+          titlecase-coordinating-conjunctions)
+  "Words to lowercase in Wikipedia Style.")
+
+(defcustom titlecase-style 'chicago
+  "Which style to use when titlecasing."
+  :type '(choice (const :tag "Chicago Style" chicago)
+                 (const :tag "APA Style" apa)
+                 (const :tag "MLA Style" mla)
+                 (const :tag "AP Style" ap)
+                 (const :tag "Bluebook Style" bluebook)
+                 (const :tag "AMA Style" ama)
+                 (const :tag "New York Times Style" nyt)
+                 (const :tag "Wikipedia Style" wikipedia)))
+
+(defun titlecase--normalize (begin end)
+  "Normalize region from BEGIN to END."
+  (goto-char begin)
+  (unless (re-search-forward "[a-z]" end :noerror)
+    (downcase-region begin end)))
+
+(defun titlecase--capitalize-first-word (begin end)
+  "Capitalize the first word of region from BEGIN to END."
+  (goto-char begin)
+  (capitalize-word 1))
+
+(defun titlecase--capitalize-last-word (begin end)
+  "Capitalize the last word of region from BEGIN to END."
+  (goto-char end)
+  (backward-word 1)
+  (when (and (>= (point) begin))
+    (capitalize-word 1)))
+
+
+
+
+(defun titlecase-region-with-style (begin end style)
+  "Titlecase the region of English text from BEGIN to END, using STYLE."
+  (interactive "*r")
+  (save-excursion
+    (goto-char begin)
+    ;; If the region is in ALL-CAPS, normalize it first
+    (unless (re-search-forward "[a-z]" end :noerror)
+      (downcase-region begin end))
+    (goto-char begin)                   ; gotta go back to the beginning
+    (let (;; Constants during this function's runtime
+          (case-fold-search nil)
+          (downcase-word-list (symbol-value
+                               (intern (format "titlecase-lowercase-%s"
+                                               style))))
+          ;; State variables
+          (this-word (current-word))
+          (force-capitalize t))
+      ;; And loop over the rest
+      (while (< (point) end)
+        (setq this-word (current-word))
+        (cond
+         ;; Skip ALL-CAPS words
+         ((string-match "^[A-Z]+$" this-word) (forward-word 1))
+         ;; Force capitalization if `force-capitalize' is t
+         (force-capitalize (progn (capitalize-word 1)
+                                  (setq force-capitalize nil)))
+         ;; Special rules for different styles
+         ((and (memq style '(ap))
+               (> (length this-word) 3))
+          (capitalize-word 1))
+         ;; Downcase words that should be
+         ((member (downcase this-word) downcase-word-list)
+          (downcase-word 1))
+         ;; Otherwise, capitalize the word
+         (t (capitalize-word 1)))
+        ;; If the word ends with a :, ., ?, newline, or carriage-return, force
+        ;; the next word to be capitalized.
+        (when (looking-at "[:.?;\n\r]")
+          (setq force-capitalize t))
+        (skip-syntax-forward "^w" end))
+      ;; Capitalize the last word, only in some styles
+      (when (memq style '(chicago ap bluebook ama nyt wikipedia))
+        (backward-word 1)
+        (when (and (>= (point) begin))
+          (capitalize-word 1))))))
+
+;;;###autoload
+(defun titlecase-region (begin end)
+  "Titlecase the region of English text from BEGIN to END.
+Uses the style provided in `titlecase-style'."
+  (interactive "*r")
+  (titlecase-region-with-style begin end titlecase-style))
+
+;;;###autoload
+(defun titlecase-dwim ()
+  "Titlecase either the region, if active, or the current line."
+  (interactive)
+  (if (region-active-p)
+      (titlecase-region (region-beginning) (region-end))
+    (titlecase-region (point-at-bol) (point-at-eol))))
+
+(provide 'titlecase)
+;;; titlecase.el ends here