Skip to content

Instantly share code, notes, and snippets.

@inconvergent
Last active November 22, 2023 18:54
Show Gist options
  • Save inconvergent/b414f10ee06bdeaf616b7de0fe9dd407 to your computer and use it in GitHub Desktop.
Save inconvergent/b414f10ee06bdeaf616b7de0fe9dd407 to your computer and use it in GitHub Desktop.
#!/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)))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment