(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