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