A fast sequence matching macro

00-vector-case.lisp

(ql:quickload :alexandria)
(import '(alexandria:ensure-cons alexandria:once-only))

(defmacro vector-case (vec-and-options &body cases)
  (destructuring-bind (vec &key (start 0) end case-insensitive)
      (ensure-cons vec-and-options)
    (let ((otherwise (gensym "otherwise")))
      (labels ((case-candidates (el)
                 (if (and case-insensitive
                          (characterp el))
                     (cond
                       ((char<= #\a el #\z)
                        `(,el
                          ,(code-char
                            (- (char-code el)
                               #.(- (char-code #\a) (char-code #\A))))))
                       ((char<= #\A el #\Z)
                        `(,el
                          ,(code-char
                            (+ (char-code el)
                               #.(- (char-code #\a) (char-code #\A))))))
                       (t el))
                     el))
               (build-case (i cases vec end)
                 (when cases
                   (let ((map (make-hash-table)))
                     (map nil
                          (lambda (case)
                            (unless (vectorp (car case))
                              (error "The first element of cases must be a constant vector"))
                            (unless (<= (length (car case)) i)
                              (push case (gethash (aref (car case) i) map))))
                          cases)
                     (let (res-cases)
                       (maphash (lambda (el cases)
                                  (let ((next-case (build-case (1+ i) cases vec end)))
                                    (cond
                                      (next-case
                                       (push
                                        `(,(case-candidates el)
                                          (if (<= ,end ,(+ i 1 start))
                                              ,@(if (= (length (caar cases)) (1+ i))
                                                    (cdr (car cases))
                                                    '(nil))
                                              (case (aref ,vec ,(+ i 1 start))
                                                ,@next-case
                                                (otherwise (go ,otherwise)))))
                                        res-cases))
                                      (t
                                       (push `(,(case-candidates el)
                                               (when (= ,end ,(+ i 1 start))
                                                 ,@(cdr (car cases))))
                                             res-cases)))))
                                map)
                       res-cases)))))
        (let ((end-symb (gensym "END"))
              (otherwise-case nil))
          (when (eq (caar (last cases)) 'otherwise)
            (setq otherwise-case (car (last cases))
                  cases (butlast cases)))
          (once-only (vec)
            `(let ((,end-symb ,(or end `(length ,vec))))
               (unless (<= ,end-symb ,start)
                 (block nil
                   (tagbody
                      (return
                        (case (aref ,vec ,start)
                          ,@(build-case 0 cases vec end-symb)
                          (otherwise (go ,otherwise))))
                      ,otherwise
                      ,(when otherwise-case
                         `(return (progn ,@(cdr otherwise-case))))))))))))))

01-test.lisp

(ql:quickload :prove)
(use-package :prove)

(plan nil)

(is (vector-case "Sunday"
      ("Monday" :mon)
      ("Tuesday" :tue)
      ("Wednesday" :wed)
      ("Thursday" :thu)
      ("Fryday" :fry)
      ("Saturday" :sat)
      ("Sunday" :sun))
    :sun
    "normal case")

(is (vector-case "Sunday!"
      ("Sunday" :sun))
    nil
    "normal case")

(is (vector-case "Sunday!"
      ("Sunday" :sun)
      ("Sunday!" :sun+))
    :sun+
    "normal case")

(is (vector-case "Sunday!"
      ("Sunday!" :sun+)
      ("Sunday" :sun))
    :sun+
    "normal case")

(is (vector-case "Sunday"
      ("Sunday" :sun)
      ("Sunday" :sun2))
    :sun
    "duplicate cases")

(is (vector-case "Sunday"
      ("Monday" :mon)
      ("Tuesday" :tue)
      ("Wednesday" :wed)
      ("Thursday" :thu)
      ("Fryday" :fry)
      ("Saturday" :sat))
    nil
    "no match")

(is (vector-case "Sunday"
      ("Monday" :mon)
      ("Tuesday" :tue)
      ("Wednesday" :wed)
      ("Thursday" :thu)
      ("Fryday" :fry)
      ("Saturday" :sat)
      (otherwise :not-found))
    :not-found
    "otherwise")

(is (vector-case "Sunday"
      ("Monday" :mon)
      ("Tuesday" :tue)
      ("Wednesday" :wed)
      ("Thursday" :thu)
      ("Fryday" :fry)
      ("Saturday" :sat)
      ("Sunday2" :sun2))
    nil
    "no match")

(is (vector-case "Sunday")
    nil
    "empty cases")

(is (vector-case "empty"
      ("" :empty))
    nil
    "empty string case")


(is (vector-case ""
      ("Sunday" :sun))
    nil
    "empty target string")

(is (vector-case ("Sunday" :case-insensitive t)
      ("monday" :mon)
      ("tuesday" :tue)
      ("wednesday" :wed)
      ("thursday" :thu)
      ("fryday" :fry)
      ("saturday" :sat)
      ("sunday" :sun))
    :sun
    "case insensitive")

(is (vector-case ("Today is Sunday" :start 9 :case-insensitive t)
      ("monday" :mon)
      ("tuesday" :tue)
      ("wednesday" :wed)
      ("thursday" :thu)
      ("fryday" :fry)
      ("saturday" :sat)
      ("sunday" :sun))
    :sun
    "start")

(is (vector-case ("Today is Sunday!!" :start 9 :end nil :case-insensitive t)
      ("monday" :mon)
      ("tuesday" :tue)
      ("wednesday" :wed)
      ("thursday" :thu)
      ("fryday" :fry)
      ("saturday" :sat)
      ("sunday" :sun))
    nil
    "end")

(is (vector-case ("Today is Sunday!!" :start 9 :end 15 :case-insensitive t)
      ("monday" :mon)
      ("tuesday" :tue)
      ("wednesday" :wed)
      ("thursday" :thu)
      ("fryday" :fry)
      ("saturday" :sat)
      ("sunday" :sun))
    :sun
    "end")

(is (vector-case #(1 2 3)
      (#(1) :one)
      (#(1 2) :two)
      (#(1 2 3) :three))
    :three)

(finalize)

02-benchmark.lisp

(defvar *target* "Sunday")

(time
 (dotimes (i 1000000)
   (vector-case *target*
     ("Monday" :mon)
     ("Tuesday" :tue)
     ("Wednesday" :wed)
     ("Thursday" :thu)
     ("Fryday" :fry)
     ("Saturday" :sat)
     ("Sunday" :sun))))
;-> Evaluation took:
;     0.029 seconds of real time
;     0.028328 seconds of total run time (0.027308 user, 0.001020 system)
;     96.55% CPU
;     85,562,982 processor cycles
;     0 bytes consed

(time
 (dotimes (i 1000000)
   (cond
     ((string= *target* "Monday") :mon)
     ((string= *target* "Tuesday") :tue)
     ((string= *target* "Wednesday") :wed)
     ((string= *target* "Thursday") :thu)
     ((string= *target* "Fryday") :fry)
     ((string= *target* "Saturday") :sat)
     ((string= *target* "Sunday") :sun))))
;-> Evaluation took:
;     0.122 seconds of real time
;     0.122549 seconds of total run time (0.121346 user, 0.001203 system)
;     100.82% CPU
;     366,316,629 processor cycles
;     32,768 bytes consed