;; make #{ .. } notation become a short hand for (values ...)
(defun |#{-reader| (stream char arg)
(declare (ignore char arg))
`(values ,@(read-delimited-list #\} stream t)))
(set-dispatch-macro-character #\# #\{ #'|#{-reader|)
(set-macro-character #\} (get-macro-character #\) nil))
(defmacro make-tuple-struct (&key type-name tuple-type tuple-default-value elements)
"Create a structure in the form needed for tuple / packing
unpacking. All fields should have the same type and default value."
`(defstruct ,type-name
,@(loop
for element in elements
collect (list element tuple-default-value :type tuple-type))))
;; test code
(make-tuple-struct :type-name vector2d :tuple-type single-float :tuple-default-value 0.0 :elements (x y))
(make-tuple-struct :type-name vector3d :tuple-type single-float :tuple-default-value 0.0 :elements (x y z))
(make-tuple-struct :type-name vector4d :tuple-type single-float :tuple-default-value 0.0 :elements (x y z w))
(make-tuple-struct :type-name quaternion :tuple-type single-float :tuple-default-value 0.0 :elements (x y z w))
(make-tuple-struct :type-name color :tuple-type single-float :tuple-default-value 0.0 :elements (r g b a))
(defmacro with-gensyms (syms &body body)
`(let ,(mapcar #'(lambda (s) `(,s (gensym)))
syms)
,@body))
(defmacro make-tuple-unpacker (&key type-name elements)
"Create an unpacker function such as (vector? vector4d) that takes an instance
of a struct and unpacks it to tuples (aka multiple values)"
(labels
((make-macro-name (type-name)
(intern (concatenate 'string
(symbol-name type-name)
"?")))
(make-element-names (elements)
(mapcar #'(lambda (x)
(find-symbol
(concatenate 'string
(symbol-name type-name) "-"
(symbol-name x))))
elements)))
`(defmacro ,(make-macro-name type-name) (packed-tuple)
(let ((packed-tuple-sym (gensym)))
`(let
((,packed-tuple-sym ,packed-tuple))
(values ,@(loop
for element-name in (quote ,(make-element-names elements))
collect (list element-name packed-tuple-sym))))))))
(make-tuple-unpacker :type-name vector2d :elements (x y))
(make-tuple-unpacker :type-name vector3d :elements (x y z))
(make-tuple-unpacker :type-name vector4d :elements (x y z w))
(make-tuple-unpacker :type-name quaternion :elements (x y z w))
(make-tuple-unpacker :type-name color :elements (r g b a))
;; to do - not entirely sure if this is wise/neeed
;; is anything evaluated more than once? I lost track
(defmacro make-with-tuple (&key type-name)
"Create a macro that can be used to bind members of the tuples struct to symbols
to symbols e-g (with-vector thing-vec (x y z w) &body forms)"
(labels
((make-unpacker-name (type-name)
(intern (concatenate 'string
(symbol-name type-name)
"?")))
(make-macro-name (type-name)
(intern (concatenate 'string
"WITH-"
(symbol-name type-name)))))
`(defmacro ,(make-macro-name type-name) (tuple element-syms &body forms)
`(multiple-value-bind
,(loop
for element-sym in element-syms
collect element-sym)
(,',(make-unpacker-name type-name) ,tuple)
,@forms))))
(make-with-tuple :type-name vector2d)
(make-with-tuple :type-name vector3d)
(make-with-tuple :type-name vector4d)
(make-with-tuple :type-name quarternion)
(make-with-tuple :type-name color)
(defmacro make-tuple-packer (&key type-name elements)
"Create a tuple-name! macro for packing multiple values into
a tuple struct. eg (vector! up #{ 0.0 1.0 0.0 })"
(labels
((make-packer-name (type-name)
(intern (concatenate 'string
(symbol-name type-name)
"!")))
(make-element-names (elements)
(mapcar #'(lambda (x)
(find-symbol
(concatenate 'string
(symbol-name type-name) "-"
(symbol-name x))))
elements)))
`(defmacro ,(make-packer-name type-name) (target-sym tuple-values)
(let* ((element-name-list ',(make-element-names elements))
(varlist (mapcar #'(lambda (x) (gensym (symbol-name x))) element-name-list)))
`(multiple-value-bind
,(mapcar #'(lambda (x) x) varlist)
,tuple-values
(progn ,@(mapcar #'(lambda (p v) `(setf (,p ,target-sym) ,v)) element-name-list varlist)))))))
(make-tuple-packer :type-name vector2d :elements (x y))
(make-tuple-packer :type-name vector3d :elements (x y z))
(make-tuple-packer :type-name vector4d :elements (x y z w))
(make-tuple-packer :type-name quaternion :elements (x y z w))
(make-tuple-packer :type-name color :elements (r g b a))
(defparameter *blue* (make-color :b 1.0))
(defparameter *transparent-blue* (make-color :b 1.0 :a 0.5))
(defparameter *red* (make-color :r 1.0))
(defparameter *yellow* (make-color :r 1.0 :g 1.0))
(with-color *yellow* (yr yg yb ya) (format t "Yellow ~A ~A ~A ~A " yr yg yb ya))
;; change yellow to white
(color! *yellow* #{ 1.0 1.0 1.0 0.0 })
(with-color *yellow* (yr yg yb ya) (format t "Yellow ~A ~A ~A ~A " yr yg yb ya))
;; confirm change
(color? *yellow*)
(defmacro make-tuple-type (tuple-name &key tuple-element-type tuple-default-value elements)
"Create a tuple type in one swoosh with all the support macros for it"
`(progn
(make-tuple-struct :type-name ,tuple-name
:tuple-type ,tuple-element-type
:tuple-default-value ,tuple-default-value
:elements ,elements )
(make-tuple-unpacker :type-name ,tuple-name :elements ,elements)
(make-with-tuple :type-name ,tuple-name)
(make-tuple-packer :type-name ,tuple-name :elements ,elements)))
(make-tuple-type pixel :tuple-element-type (unsigned-byte 8) :tuple-default-value 0 :elements (b r g a))
make-tuple-type is a macro that invokes a set of macros that invoke macros. I hope to be able to build on this to get together a decent 3d-game/spatial-math collection of lisp code. Now I have to think about how exactly I want transforms to work. I'm tempted to code them as scale-rotate-translate rather than a straight matrix.
No comments:
Post a Comment