src http://haskell98.blogspot.ru/2014/08/blog-post_8.html

(defpackage #:pochta
  (:use :cl :iterate :metatilities)
  (:shadowing-import-from :metatilities minimize finish))

(in-package :pochta)

(defun process-stream (fsm stream)
  (iter (with acc = '())
        (for row from 0)
        (for line in-stream stream using #'read-line)
        (iter (for col from 0)
              (for char in-string line)
              (setf acc (funcall fsm char row col acc)))))

(defun process-file (fsm filename)
  (with-open-file (src filename) (process-stream fsm src)))

(defun make-fsm-queue (init-fsm)
  (lambda (char row col fsm-queue)
    (reduce (lambda (next-fsm-queue fsm)
              (funcall fsm char row col (lambda (next-state) (cons next-state next-fsm-queue)) (constantly next-fsm-queue)))
            (cons init-fsm fsm-queue)
            :initial-value '())))

(defmacro deffsm (name &rest patterns)
  (let ((fsm (iter main-loop
                   (with max-height = (reduce #'max patterns :key (compose #'length #'second)))
                   (with max-width = (reduce #'max patterns :key (compose (curry #'reduce #'max) (curry #'mapcar #'length) #'second)))
                   (with state-index = 0)
                   (with current-states = (list (cons state-index patterns)))
                   (for row from 0 below max-height)
                   (iter (for col from 0 below max-width)
                         (iter states-loop
                               (for (current-state-index . state-patterns) in current-states)
                               (iter (with ht = (make-hash-table))
                                     (for (target pattern) in state-patterns)
                                     (if (and (< row (length pattern))
                                              (< col (length (elt pattern row))))
                                         (push (list target
                                                     (and (= (1+ row) (length pattern)) (= (1+ col) (length (elt pattern row))))
                                                     pattern)
                                               (gethash (elt (elt pattern row) col) ht))
                                         (push (list target nil pattern)
                                               (gethash :default ht)))
                                     (finally
                                      (let ((trans (iter (for (key transition) in-hashtable ht)
                                                         (for next-state-index = (incf state-index))
                                                         (for (values stops next-patterns) =
                                                              (iter (for (target stop-p pattern) in transition)
                                                                    (if stop-p
                                                                        (collect target into stops)
                                                                        (collect (list target pattern) into next-patterns))
                                                                    (finally (return (values stops next-patterns)))))
                                                         (when next-patterns
                                                           (in states-loop (collect (cons next-state-index next-patterns) into next-states)))
                                                         (collect (cons key (cons (when next-patterns next-state-index) stops))))))
                                        (in main-loop (collect (cons (list current-state-index row col) trans))))))
                               (setf current-states next-states))))))
    (flet ((state-label (state) (form-symbol 'state- state)))
      `(defun ,name (char init-row init-col next reset)
         (declare (optimize (debug 3)))
         (labels ,(iter (for ((state row col) . transitions) in fsm)
                        (collect `(,(state-label state) (char row col next reset)
                                    (if (and (= row (+ init-row ,row)) (= col (+ init-col ,col)))
                                        (cond ,@(iter (for (key next-state . stop-set) in (remove-if (curry #'eq :default) transitions :key #'car))
                                                      (collect `((char= char ,key)
                                                                 ,@(iter (for stop in stop-set)
                                                                         (collect `(format t ,(format nil ";; found [ ~a ] @ (~~a, ~~a)~~%" stop)
                                                                                           init-col init-row)))
                                                                 ,(if next-state
                                                                      `(funcall next (function ,(state-label next-state)))
                                                                      `(funcall reset)))))
                                              (t ,(let ((default (find :default transitions :key #'car)))
                                                       (if (and default (second default))
                                                           `(funcall next (function ,(state-label (second default))))
                                                           `(funcall reset)))))
                                        (if (and (>= row (+ init-row ,row)) (> col (+ init-col ,col)))
                                            (funcall reset)
                                            (funcall next (function ,(state-label state))))))))
           (,(state-label 0) char init-row init-col next reset))))))

(deffsm mail-digits
  (0 ((#\1 #\1 #\1) (#\1 #\0 #\1) (#\1 #\0 #\1) (#\1 #\0 #\1) (#\1 #\1 #\1)))
  (1 ((#\1 #\1 #\0) (#\0 #\1 #\0) (#\0 #\1 #\0) (#\0 #\1 #\0) (#\1 #\1 #\1)))
  (2 ((#\1 #\1 #\1) (#\0 #\0 #\1) (#\1 #\1 #\1) (#\1 #\0 #\0) (#\1 #\1 #\1)))
  (3 ((#\1 #\1 #\1) (#\0 #\0 #\1) (#\1 #\1 #\1) (#\0 #\0 #\1) (#\1 #\1 #\1)))
  (4 ((#\1 #\0 #\1) (#\1 #\0 #\1) (#\1 #\1 #\1) (#\0 #\0 #\1) (#\0 #\0 #\1)))
  (5 ((#\1 #\1 #\1) (#\1 #\0 #\0) (#\1 #\1 #\1) (#\0 #\0 #\1) (#\1 #\1 #\1)))
  (6 ((#\1 #\1 #\1) (#\1 #\0 #\0) (#\1 #\1 #\1) (#\1 #\0 #\1) (#\1 #\1 #\1)))
  (7 ((#\1 #\1 #\1) (#\0 #\0 #\1) (#\0 #\1 #\1) (#\0 #\1 #\0) (#\0 #\1 #\0)))
  (8 ((#\1 #\1 #\1) (#\1 #\0 #\1) (#\1 #\1 #\1) (#\1 #\0 #\1) (#\1 #\1 #\1)))
  (9 ((#\1 #\1 #\1) (#\1 #\0 #\1) (#\1 #\1 #\1) (#\0 #\0 #\1) (#\1 #\1 #\1))))