mesh-expander.lisp

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