markov-algorithm/markov-algorithm.lisp

;;;; markov-algorithm.lisp

(defpackage #:markov-algorithm
  (:use #:cl)
  (:export #:make-formula
           #:lhs
           #:rhs
           #:formulap
           #:compile-markov-algorithm
           #:formulap
           #:schemep))

(in-package #:markov-algorithm)

(defun make-formula (lhs rhs finalp)
  (list lhs
        (if finalp
            :->.
            :->)
        rhs))

(defun formulap (obj)
  (and (listp obj)
       (stringp (first obj))
       (member (second obj) '(:-> :->.))
       (stringp (third obj))))

(defun lhs (formula)
  (first formula))

(defun rhs (formula)
  (third formula))

(defun finalp (formula)
  (eql (second formula) :->.))

(defun schemep (obj)
  (and (listp obj)
       (every #'formulap obj)))

(defun matching-formula (word scheme)
  (find-if (lambda (formula)
             (search (lhs formula) word))
           scheme))

(defun split-word (word formula)
  (let ((len (length (lhs formula)))
        (pos (search (lhs formula) word)))
    (values (subseq word 0 pos)
            (subseq word pos (+ pos len))
            (subseq word (+ pos len)))))

(defun word-substitution (word formula)
  (multiple-value-bind (prefix stem suffix) (split-word word formula)
    (declare (ignore stem))
    (concatenate 'string prefix (rhs formula) suffix)))

#|
First value: the next iteration or the same word if no formula matches.
Second value: true if there are no more iterations, nil otherwise.
Third value: true if no formula matches, nil otherwise.
|#
(defun next-word (word scheme)
  (let ((formula (matching-formula word scheme)))
    (cond ((null formula) (values word t t))
          ((finalp formula) (values (word-substitution word formula) t nil))
          (t (values (word-substitution word formula) nil nil))))) 

(defun compile-markov-algorithm (scheme &optional (max-iterations 100))
  "Given a Markov scheme, return a function applying it to strings and
   performing at most MAX-ITERATIONS.  The function returns either the
   resulting string or NIL if the iteration limit has been reached."
  (check-type scheme (satisfies schemep))
  (check-type max-iterations (integer 0 *))
  (lambda (word)
    (check-type word string)
    (loop repeat max-iterations
          with end? = nil
          do (setf (values word end?) (next-word word scheme))
          when end? do (return word)
          finally (return nil))))