meta-meta-programming

Strictly for laughs, and partly for performance: a bit of meta-meta-programming.

;; 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.