mesh-expander.lisp

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