palindromes.lisp

(defpackage #:snippets/palindromes
  (:use #:cl)
  (:export
   #:list-palindrome-units
   #:palindrome?))

(in-package #:snippets/palindromes)

(defvar *palindrome-units* '()
  "A list of supported palindrome units.")

(defun list-palindrome-units ()
  "Return a list of supported palindrome units."
  (copy-list *palindrome-units*))

(defgeneric split (unit object)
  (:documentation "Split object into a vector of components according
to unit."))

(defmacro define-splitter (unit ((object typespec)) &body forms)
  "Define a splitter for the supplied UNIT."
  `(progn
     (pushnew ',unit *palindrome-units*)
     (defmethod split ((unit (eql ',unit)) ,object)
       (when (typep ,object ',typespec)
         ,@forms))
     ',unit))

(defun palindrome? (object &key (test #'equalp) (units *palindrome-units*))
  "If OBJECT is a palindrome in the sense of one of the UNITS
supplied, return the unit; return false otherwise.

By default UNITS is the list of all supported units.  Also see
LIST-PALINDROME-UNITS."
  (some (lambda (unit)
          (palindrome-of-unit? unit object test))
        units))

(defun palindrome-of-unit? (unit object test)
  "If OBJECT is a palindrome of UNIT components, return UNIT, and
false otherwise.

If OBJECT cannot be split into at least one component of UNIT, it is
not considered a palindrome in that sense.

The components are compared using a predicate TEST."
  (let ((tokens (split unit object)))
    (case (length tokens)
      (0 nil)
      (1 unit)
      (t (do ((i 0 (1+ i))
              (j (1- (length tokens)) (1- j)))
             ((>= i j) unit)
           (unless (funcall test
                            (aref tokens i)
                            (aref tokens j))
             (return nil)))))))

(defun splitter (function string)
  "Split STRING into a vector of string components.

FUNCTION should take each character in the string and return two
values:

 - the character to add, or NIL if none;

 - whether to start a new string component."
  (let ((tokens (make-array (length string) :fill-pointer 0))
        (word (make-string-output-stream)))
    (flet ((add-char (x)
             (write-char x word))
           (add-word (x)
             (when (plusp (length x))
               (vector-push x tokens))))
      (map nil (lambda (char)
                 (multiple-value-bind (char-to-add new-component)
                     (funcall function char)
                   (when new-component
                     (add-word (get-output-stream-string word)))
                   (when char-to-add
                     (add-char char-to-add))))
           string)
      (add-word (get-output-stream-string word)))
    tokens))

(defun single-char (predicate)
  "Used with splitter to make each token a single character."
  (lambda (x)
    (if (funcall predicate x)
        (values x t)
        (values nil t))))

(defun grouped-chars (predicate)
  "Used with splitter to make each token a group of characters."
  (lambda (x)
    (if (funcall predicate x)
        (values x nil)
        (values nil t))))

(defun letter? (x)
  "Return true if X is a letter from the English alphabet, and false
otherwise."
  (find x "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"))

(define-splitter :letter ((string string))
  (splitter (single-char #'letter?) string))

(define-splitter :word ((string string))
  (splitter (grouped-chars #'letter?) string))

(define-splitter :decimal-digit ((n integer))
  (splitter (single-char #'digit-char-p)
            (princ-to-string n)))

;; Example

(defparameter *cases*
  '("Egad, a base life defiles a bad age"
    "Doom an evil deed, liven a mood"
    "Harass Sensuousness, Sarah"
    "Golf; No, sir, prefer prison-flog"
    "Ban campus motto, \"Bottoms up, MacNab\""
    "Men wanted warning before police approached; squealer approached police before warning wanted men."

    "Yreka Bakery"
    "A man, a plan, a canal, Panama"
    12321

    "A nonpalindrome"
    123))

(defun test ()
  (flet ((tag (object) (list (palindrome? object) object)))
    (mapcar #'tag *cases*)))

(defun exp-palindrome? (n k)
  "Are both N and N^K palindromes?"
  (and (palindrome? n)
       (palindrome? (expt n k))
       t))

(defun reverse-digits (n)
  "Return the number represented as the reverse decimal digits of
another number, e.g. 123 => 321."
  (values (parse-integer (reverse (princ-to-string n)))))

(defun palindromat (n &optional (upper-bound (expt 10 20)))
  "Attempt to make a palindrome out of number N.

If the process arrives at a number that is equal to or greater than
the upper bound, return NIL and that number.

If NIL is passed for the upper bound, the upper bound is unspecified.

Passing 196 will likely reach an upper bound, if there is one."
  (cond ((and upper-bound (>= n upper-bound))
         (values nil n))
        ((palindrome? n :units '(:decimal-digit)) n)
        (t (palindromat (+ n (reverse-digits n))))))