vectors-and-symbols.lisp

#!/usr/local/bin/sbcl --script

; example code described in this blog post:
; https://inconvergent.net/2023/vectors-as-symbols

; GENERIC UTILS

(defun mkstr (&rest args)
  (with-output-to-string (s)
    (dolist (a args) (princ a s))))

(defun symb (&rest args)
  (values (intern (apply #'mkstr args))))

(defun match-substr (sub s)
  (loop with lc = (length sub)
        for i from 0 repeat (1+ (- (length s) lc))
        if (string= sub s :start2 i :end2 (+ i lc))
        do (return-from match-substr i)))

(defmacro ~ (&rest rest)
  `(multiple-value-call #'values ,@rest))

(defmacro lst (&body body)
  `(multiple-value-call #'list (~ ,@body)))

(defun nsym (n name) (loop repeat n collect (gensym name)))

(defmacro vpr (&body body)
  (let ((res (gensym)))
    `(let ((,res (lst ,@body)))
       (format t "~&;> ~{~a~^ | ~}~&;; ~{~a~^ | ~}~&"
               ',body ,res)
       (apply #'values ,res))))

; SPECIFIC TO VV MACRO

(defun has-vv-trigger? (body trig)
  (and (listp body)
       (symbolp (car body))
       (match-substr trig (mkstr (car body)))))

(defun split-vv-trigger (sym trig)
  (let ((d (digit-char-p (char sym 0))))
    (unless d (warn "~a expects digit prefix. got ~a" trig sym))
    (values d (symb (subseq sym (+ (length trig)
                                   (match-substr trig sym)))))))

(defun vv-do-trigger (body)
  (multiple-value-bind (dim fx) (split-vv-trigger
                                  (mkstr (car body)) "!@")
      (let ((args (nsym (* 2 dim) (mkstr "VAR" fx))))
        `(multiple-value-bind ,args
           (~ ,@(vv-rec (cdr body)))
           (values
             ,@(loop for a in args
                     for b in (subseq args dim)
                     collect `(,fx ,a ,b)))))))

(defun vv-rec (body)
  (cond ((atom body) body)
        ((has-vv-trigger? body "!@")
           (vv-do-trigger body))
        (t `(,(vv-rec (car body))
             ,@(vv-rec (cdr body))))))

(defmacro vv (&body body)
  `(progn ,@(vv-rec body)))


; EXAMPLES

; (vpr
;   (vv (2!@+ (2!@* 1.0 2.0 3.0 4.0)
;             (2!@/ 5.0 6.0 7.0 8.0))))

; (print (macroexpand-1
;   '(vv (2!@+ (2!@* 1.0 2.0 3.0 4.0)
;             (2!@/ 5.0 6.0 7.0 8.0)))))
; (PROGN
;   (MULTIPLE-VALUE-BIND (#:VAR+93 #:VAR+94 #:VAR+95 #:VAR+96)
;     (~ (MULTIPLE-VALUE-BIND (#:VAR*97 #:VAR*98 #:VAR*99 #:VAR*100)
;          (~ 1.0 2.0 3.0 4.0)
;          (VALUES (* #:VAR*97 #:VAR*99)
;                  (* #:VAR*98 #:VAR*100)))
;        (MULTIPLE-VALUE-BIND (#:VAR/101 #:VAR/102 #:VAR/103 #:VAR/104)
;           (~ 5.0 6.0 7.0 8.0)
;           (VALUES (/ #:VAR/101 #:VAR/103)
;                   (/ #:VAR/102 #:VAR/104))))
;    (VALUES (+ #:VAR+93 #:VAR+95)
;            (+ #:VAR+94 #:VAR+96))))

; (print (vv-rec '(2!@+ 1 2 (2!@* 3 4 5 6))))
; (print (match-substr "!@" "asdf!@"))
; (vpr (~ 1 2) (~ 3 4))
; (vpr (split-vv-trigger "3!@fx" "!@"))
; (vv (print (lst (2!@+ 1 2 (2!@* 3 4 5 6)))))