(defun compile-dispatcher (nums)
  (let ((x (make-symbol "X")))
    (labels ((compile-single (nums)
               `(when (= ,x ,(caar nums)) ,(cdar nums)))
             (compile-multiple (nums)
               (let* ((pivot 0)
                      (l (loop repeat (ceiling (length nums) 2)
                               collect (setf pivot (pop nums))))
                      (r nums))
                 `(if (<= ,x ,(car pivot))
                      ,(compile-branch l)
                      ,(compile-branch r))))
             (compile-branch (nums)
               (if (cdr nums)
                   (compile-multiple nums)
                   (compile-single nums))))
      `(lambda (,x)
         ,(compile-branch nums)))))

(defun batch (strings i)
  (loop with prev = strings
        with char = (aref (caar strings) i)
        with cons = strings
        while cons
        if (or (null (cdr cons)) (char/= char (aref (caadr cons) i)))
        collect (prog1 (cons (char-code char) prev)
                  (shiftf cons (cdr cons) NIL)
                  (setf prev cons)
                  (when cons
                    (setf char (aref (caar cons) i))))
        else
        do (setf cons (cdr cons))))

(defun compile-string-dispatcher (strings)
  (let* ((x (make-symbol "X"))
         (strings (sort (copy-list strings) #'string<= :key #'car))
         (length (length (caar strings))))
    (labels ((compile-single (strings)
               `(funcall ,(compile-dispatcher strings)
                         (char-code (read-char ,x))))
             (compile-multiple (i strings)
               (if (< i (1- length))
                   (compile-single (loop for (code . sub) in (batch strings i)
                                         collect (cons code (compile-multiple (1+ i) sub))))
                   (compile-single (loop for (string . value) in strings
                                         collect (cons (char-code (aref string i)) value))))))
      `(lambda (,x)
         (declare (type stream ,x))
         (declare (optimize speed (debug 0) (safety 0)))
         ,(compile-multiple 0 strings)))))

;;; (compile-string-dispatcher '(("aaa" . 1) ("abb" . 2) ("abc" . 3) ("bbb" . 4) ("cde" . 5) ("dee" . 6)))
;;; ; => (LAMBDA (#:X) ...)
;;; (compile NIL *)
;;; ; => #<FUNCTION (LAMBDA (#:X)) {5357A79B}>
;;; (funcall * (make-string-input-stream "abc    "))
;;; ; => 3