mesh-expander.lisp

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