   [word]
   (-> (clojure.string/lower-case word)
       (clean)))
+
+(defn- drop-suffix
+  "Drop the longest suffix we can find in the given [word]."
+  [word]
+  (if-let [[match condition] (some #(when (re-test? (first %) word) %) (partition 2 endings))]
+    (let [stem (clojure.string/replace word match "")]
+      (if (and ((conditions condition) stem)
+               (> (count stem) 1))
+        stem
+        word))
+    word))
+
+(defn apply-transformations
+  "Apply the algorithm's transformations to the given [stem]."
+  [stem]
+  (if-let [[match replacement] (some #(when (re-test? (first %) stem) %) (partition 2 transformations))]
+    (clojure.string/replace stem match replacement)
+    stem))
+
+(defn stem
+  "Stem the given [word] according to the algorithm"
+  [word]
+  (-> (prep-word word)
+      (drop-suffix)
+      (dedouble)
+      (apply-transformations)))

   :Y (fn [stem] (re-test? #"in$" stem))
   :Z (fn [stem] (not (re-test? #"f$" stem)))
   :AA (fn [stem] (re-test? #"([dflt]|ph|th|er|or|es)$" stem))
   :BB (fn [stem] (and (conditions :B stem) (not (re-test? #"(met|ryst)" stem))))
   :CC (fn [stem] (re-test? #"l$" stem))})

;; Transformations
(defn- dedouble
  "Drop double occurences of certain letters in the given [stem]."
  [stem]
  (clojure.string/replace stem #"([bdglmnprst])[bdglmnprst]" "$1"))

(def ^:private transformations
  '(#"ief$" "iev"
    #"uct$" "uc"
    #"umpt$" "um"
    #"rpt$" "rb"

    #"ity$" :A         #"ium$" :A         #"ive$" :A         #"ize$" :F
    #"oid$" :A         #"one$" :R         #"ous$" :A

    #"ae$" :A          #"al$" :BB         #"ar$" :X          #"as$" :B
    #"ed$" :E          #"en$" :F          #"es$" :E          #"ia$" :A
    #"ic$" :A          #"is$" :A          #"ly$" :B          #"on$" :S
    #"or$" :T          #"um$" :U          #"us$" :V          #"yl$" :R
    #"s'"  :A          #"'s$" :A

    #"a$" :A           #"e$" :A           #"i$" :A           #"o$" :A
    #"s$" :W           #"y$" :B))
