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