mesh-expander.lisp

   1
   2 (in-package :mixamesh)
   3
   4
   5 ;; -- keep track of every mesh instance ----------------------------------
   6
   7 (defparameter *meshes* (make-hash-table :test 'eql)
   8   "A table of meshes.")
   9
  10 (defparameter *compiled-meshes* (make-hash-table :test 'eql)
  11   "A table of compiled meshes")
  12
  13 (defparameter *bounding-boxes* (make-hash-table :test 'eql)
  14   "A table of mesh bounding boxes")
  15
  16
  17 ;; base mesh class type --------------------
  18
  19 (defclass base-mesh ()
  20   ((face-array :accessor faces-of :initform (make-triangle-array 0 :adjustable t :fill-pointer 0) :type (vector (unsigned-byte 16) *))
  21    (current-face-index :accessor current-face-index-of :initform 0 :type fixnum)
  22    (current-vertex-index :accessor current-vertex-index-of :initform 0 :type fixnum)
  23    (id :allocation :class :reader id-of :initform (get-universal-time)))
  24   (:metaclass closer-mop:funcallable-standard-class)
  25   (:documentation "Base class for all meshes"))
  26
  27 (defgeneric mesh-builder (mesh op &optional data)
  28   (:method      ((mesh base-mesh) op &optional data)
  29         (case op
  30           (:add-face (triangle-vector-push-extend data (faces-of mesh)) (triangle-array-dimensions (faces-of mesh)))
  31           (:set-face (setf (triangle-aref (faces-of mesh)  (the fixnum (current-face-index-of mesh))) data))
  32           (:clear-face (setf (faces-of mesh) (make-triangle-array data :adjustable t :fill-pointer 0))))))
  33
  34 ;; mesh - building protocol --------------------
  35
  36
  37 ;; constructor
  38 (defmethod initialize-instance :after ((self base-mesh) &rest args)
  39   (declare (ignore args))
  40   ;; treat the object as a function
  41   (setf (gethash (id-of self) *meshes*) self)
  42   (closer-mop:set-funcallable-instance-function
  43    self
  44    #'(lambda (op &optional data) (mesh-builder self op data))))
  45
  46 (defun make-mesh (mesh-type)
  47   "Create a mesh instance and return the handle to it"
  48   (let* ((mesh
  49                   (make-instance mesh-type))
  50                  (result
  51                   (id-of mesh)))
  52         (incf (slot-value mesh 'id))
  53         result))
  54
  55
  56 ;; expanders for individual aspects of a mesh --------------------
  57
  58 (defun expand-mesh-class-attributes (attributes)
  59   "Expand the class slot defintion of the mesh attribute"
  60   (loop
  61          for (array-name accessor-name type-name) in attributes
  62          collect
  63            `(,(cl-tuples::make-adorned-symbol array-name :suffix "ARRAY")
  64                   :accessor ,accessor-name
  65                   :initform (,(cl-tuples::tuple-symbol type-name :def-tuple-array-maker) 0 :adjustable t :fill-pointer 0))))
  66
  67 (defun make-accessor-symbol (sym)
  68   "Given a symbol, suffix it with -OF so as to make an accessor name"
  69   (cl-tuples::make-adorned-symbol sym :suffix "OF"))
  70
  71
  72 (defun expand-mesh-setters (name attributes)
  73   "Expands the clauses used to set an attribute indexed by the current vertex index."
  74   (declare (ignorable name))
  75   (loop
  76          for (array-name accessor-name type-name) in attributes
  77          collect
  78            `(,(cl-tuples::make-adorned-symbol array-name :prefix "SET" :package :keyword)
  79                   (setf (,(cl-tuples::tuple-symbol type-name :def-tuple-aref)
  80                                   (,accessor-name mesh)
  81                                   (the fixnum (current-vertex-index-of mesh)))
  82                                 data))))
  83
  84
  85 (defun expand-mesh-clearers (name attributes)
  86   "Expands the clauses use to clear attribute arrays in a mesh"
  87   (declare (ignorable name))
  88   (loop
  89          for (array-name accessor-name type-name) in attributes
  90          collect
  91            `(,(cl-tuples::make-adorned-symbol array-name :prefix "CLEAR" :package :keyword)
  92                   (setf (,accessor-name mesh)
  93                                 (,(cl-tuples::tuple-symbol type-name :def-tuple-array-maker) (list data) :adjustable t :fill-pointer 0)))))
  94
  95 (defun expand-mesh-adders (name attributes)
  96   "Expands the clauses used to add attribute values to a mesh."
  97   (declare (ignorable name))
  98   (loop
  99          for (array-name accessor-name type-name) in attributes
 100          collect
 101            `(,(cl-tuples::make-adorned-symbol array-name :prefix "ADD" :package :keyword)
 102                   (,(cl-tuples::tuple-symbol type-name  :def-tuple-vector-push-extend)
 103                          data
 104                         (,accessor-name mesh)))))
 105
 106 (defun expand-mesh-builder-function (name attributes)
 107   "Expands the form used to deefine the function used to build the mesh"
 108   `(defmethod mesh-builder ((mesh ,name) op &optional data)
 109          (case op
 110            ,@(expand-mesh-setters name attributes)
 111            ,@(expand-mesh-clearers name attributes)
 112            ,@(expand-mesh-adders name attributes)
 113            (:face-index (current-face-index-of mesh))
 114            (:vertex-index (current-vertex-index-of mesh))
 115            (:set-face-index (setf (current-face-index-of mesh) data))
 116            (:set-vertex-index (setf (current-vertex-index-of mesh) data))
 117            (otherwise (call-next-method)))))
 118
 119
 120 (defun expand-attributes-list (attributes)
 121   (loop
 122          for (array-name accessor-name type-name) in attributes
 123          collect `(quote ,array-name)))
 124
 125 (defun expand-mesh-class  (name base slots attributes)
 126   "Expands the form used to declare a custom mesh class"
 127   `(defclass ,name (,@base)
 128          (,@slots
 129           ,@(expand-mesh-class-attributes attributes)
 130           (attributes :initform (list 'vertices 'faces ,@(expand-attributes-list attributes))    :reader attributes-of :allocation :class))
 131          (:metaclass closer-mop:funcallable-standard-class)
 132          (:documentation "Custom mesh type")))
 133
 134 ;; main mesh expansion macro --------------------
 135
 136 (defmacro def-mesh-type (name base &rest spec)
 137   (destructuring-bind (attributes &key (slots nil))
 138           spec
 139         `(progn ,(expand-mesh-class name base slots attributes)
 140                         ,(expand-mesh-builder-function name attributes))))
 141