gistfile1.txt

;;; string-case.el --- Port of P. Khuong's string-case for Common Lisp  -*- lexical-binding: t; -*-

;; Copyright (C) 2026  Arthur Miller
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; a simple port of P. Khoung's string-case:
;; https://github.com/pkhuong/string-case

;; ported just for a little experiment for a blog post

;;; Code:

(require 'cl-lib)

(cl-defun split (list &key (test 'eql) (key 'identity))
  "Splits input list into sublists of elements
   whose elements are all such that (key element)
   are all test.
   It's assumed that test and key form an equality class.
   (This is similar to groupBy)"
  (when list
    (let* ((lists ())
           (cur-list (list (cl-first list)))
           (cur-key  (funcall key (cl-first list))))
      (dolist (elt (cl-rest list) (nreverse (cons (nreverse cur-list)
                                               lists)))
        (let ((new-key (funcall key elt)))
          (if (funcall test cur-key new-key)
              (push elt cur-list)
              (progn
                (push (nreverse cur-list) lists)
                (setf cur-list (list elt)
                      cur-key  new-key))))))))

(defun iota (n)
  (cl-loop for i below n collect i))

(cl-defun hash-table->list (table &key (keep-keys t) (keep-values t))
  "Saves the keys and/or values in table to a list.
   As with hash table iterating functions, there is no
   implicit ordering."
  (let ((list ()))
    (maphash (cond ((and keep-keys
                         keep-values)
                    (lambda (k v)
                      (push (cons k v) list)))
                   (keep-keys
                    (lambda (k _v)
                      (push k list)))
                   (keep-values
                    (lambda (_k v)
                      (push v list))))
             table)
    list))

(cl-defun all-equal (list &key (key 'identity) (test 'eql))
  (if (or (null list)
          (null (cl-rest list)))
      t
      (let ((first-key (funcall key (cl-first list))))
        (cl-every (lambda (element)
                 (funcall test first-key
                          (funcall key element)))
               (cl-rest list)))))

(defun split-at (list n)
  "Split list in k lists of n elements (or less for the last list)"
  (let ((lists    '())
        (cur-list '())
        (counter  0))
    (dolist (elt list (nreverse (if cur-list
                                    (cons (nreverse cur-list)
                                          lists)
                                    lists)))
      (push elt cur-list)
      (when (= (incf counter) n)
        (push (nreverse cur-list) lists)
        (setf cur-list '()
              counter   0)))))

 ;; elisp defconst has the exact same semantics as CL defparameter
(defmacro defparameter (&rest args)
  `(defconst ,@args))

(defparameter *input-string* nil
  "Symbol of the variable holding the input string")

(defparameter *no-match-form* nil
  "Form to insert when no match is found.")

(defun find-best-split (strings to-check)
  "Iterate over all the indices left to check to find
   which index (and which character) to test for equality
   with, keeping the ones which result in the most balanced
   split."
  (cl-flet ((evaluate-split (i char)
           "Just count all the matches and mismatches"
           (let ((=  0)
                 (/= 0))
             (dolist (string strings (min = /=))
               (if (eql (aref string i) char)
                   (cl-incf =)
                   (cl-incf /=)))))
         (uniquify-chars (chars)
           "Only keep one copy of each char in the list"
           (mapcar 'cl-first (split (cl-sort chars '<)))))
    (let ((best-split 0)            ; maximise size of smallest branch
          (best-posn  nil)
          (best-char  nil))
      (dolist (i to-check (cl-values best-posn best-char))
        (dolist (char (uniquify-chars (mapcar (lambda (string)
                                                (aref string i))
                                              strings)))
          (let ((Z (evaluate-split i char)))
            (when (> Z best-split)
              (setf best-split Z
                    best-posn  i
                    best-char  char))))))))

(defun numeric-char= (x y)
  (logxor x y))

(defun emit-common-checks (strings to-check)
  (cl-labels ((emit-char= (pairs)
                (mapcar (lambda (pair)
                          (cl-destructuring-bind (posn . char)
                              pair
                            `(numeric-char= ,char
                                            (aref ,*input-string* ,posn))))
                        pairs))
              (emit-checking-form (common-chars)
                (when common-chars
                  (let ((common-chars (cl-sort common-chars '< :key 'car)))
                    `(and ,@(mapcar
                             (lambda (chunk)
                               (if (null (cl-rest chunk))
                                   (cl-destructuring-bind ((posn . char))
                                       chunk
                                     `(eql ,char
                                           (aref ,*input-string* ,posn)))
                                 `(zerop
                                   (logior ,@(emit-char= chunk)))))
                             (split-at common-chars 4)))))))
    (let ((common-chars  ())
          (left-to-check ()))
      (dolist (posn to-check (cl-values (emit-checking-form common-chars)
                                        (nreverse           left-to-check)))
        (if (all-equal strings :key (lambda (string)
                                      (aref string posn)))
            (push (cons posn (aref (cl-first strings) posn))
                  common-chars)
          (push posn left-to-check))))))

(defun make-search-tree (strings bodies to-check)
  (cl-multiple-value-bind (guard to-check)
      (emit-common-checks strings to-check)
    (if (null (cl-rest strings))
        (progn
          (cl-assert (null to-check)) ; there shouldn't be anything left to check
          (if guard
              `(if ,guard
                   (progn ,@(cl-first bodies))
                   ,*no-match-form*)
              `(progn ,@(cl-first bodies))))
        (cl-multiple-value-bind (posn char)
            (find-best-split strings to-check)
          (cl-assert posn) ; this can only happen if all strings are equal
          (let ((=strings  ())
                (=bodies   ())
                (/=strings ())
                (/=bodies  ()))
            (cl-loop
               for string in strings
               for body   in bodies
               do (if (eql char (aref string posn))
                      (progn
                        (push string =strings)
                        (push body   =bodies))
                      (progn
                        (push string /=strings)
                        (push body   /=bodies))))
            (let ((tree `(if (eql ,char (aref ,*input-string* ,posn))
                             ,(make-search-tree  =strings   =bodies
                                                 (remove posn to-check))
                             ,(make-search-tree /=strings /=bodies
                                                to-check))))
              (if guard
                  `(if ,guard
                       ,tree
                       ,*no-match-form*)
                  tree)))))))

(defun emit-string-case (cases input-var no-match)
  (cl-flet ((case-string-length (x)
              (length (cl-first x))))
    (let ((*input-string*  input-var)
          (*no-match-form* no-match)
          (cases-lists     (split (cl-sort cases '<
                                           :key #'case-string-length)
                                  :key #'case-string-length)))
      `(progn
         (cl-case (length ,input-var)
           ,@(cl-loop for cases in cases-lists
                   for length = (case-string-length (cl-first cases))
                   collect `((,length)
                             ;; arrays with fill pointers expose the total length
                             ;; in their type, not the position of the fill-pointer.
                             ;; The type below only applies to simple-arrays.
                             (progn
                               ,(make-search-tree (mapcar 'cl-first cases)
                                                  (mapcar 'cl-rest  cases)
                                                  (iota length)))))
           (t ,no-match))))))

(defmacro string-case (string &optional default &rest cases)
  "(string-case (string &key default)
     case*)
   case ::= string form*
          | t      form*
   Where t is the default case."
  (declare (indent defun))
  (let* ((default (or default '(error "No match")))
         (cases-table (make-hash-table :test 'equal)))
    "Error checking cruft"
    (dolist (case cases)
      (let ((other-case (gethash (cl-first case) cases-table)))
        (if other-case
            (warn "Duplicate string-case cases: %S -> %S or %S\n"
                  (cl-first case)
                  (cl-rest other-case)
                  (cl-rest case))
            (setf (gethash (cl-first case) cases-table)
                  (cl-rest case)))))
    (let ((input-var    (gensym "INPUT"))
          (default-fn   (gensym "ON-ERROR"))
          (default-body (gethash t cases-table (list default))))
      `(let ((,input-var ,(car string)))
         (cl-flet ((,default-fn ()
                     ,@default-body))
           ,(emit-string-case (progn
                                (remhash t cases-table)
                                (hash-table->list cases-table))
                              input-var
                              `(,default-fn)))))))

;; (macroexpand-1 '(string-case ("foobar")
;;                  ("" 'empty)
;;                  ("foo" 'foo)
;;                  ("fob" 'fob)
;;                  ("foobar" 'hit)
;;                  (t     'default)))

;; (string-case ("foobar")
;;   ("" 'empty)
;;   ("foo" 'foo)
;;   ("fob" 'fob)
;;   ("foobar" 'hit)
;;   (t     'default))

;; (string-case ("blah")
;;   ("" 'empty)
;;   ("foo" 'foo)
;;   ("fob" 'fob)
;;   ("foobar" 'hit)
;;   (t     'default))

(provide 'string-case)
;;; string-case.el ends here