tuple-expander.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;;;;;;;;;;;;;;;80
   2
   3
   4 #+cl-tuples-debug (declaim (optimize (speed 0) (safety 3) (debug 3)))
   5 #-cl-tuples-debug (declaim (optimize (speed 3) (safety 1) (debug 0)))
   6
   7 (in-package :cl-tuples)
   8
   9 (defun construct-tuple-array-reference (type-name tuple-array-name index)
  10   "Given a tuple type and an array index, return a form for returnign the array index"
  11   `(the ,(tuple-element-type type-name) (aref (the ,(tuple-typespec* type-name) ,tuple-array-name) ,index)))
  12
  13 (defun construct-tuple-value-type (type-name)
  14   "Given a tuple name construct the for of a  value typespec for it eg (values single-float single-float)"
  15   `(values ,@(loop for i from 0 below (tuple-size type-name) collect (tuple-element-type type-name))))
  16
  17 (defun construct-tuple-slots (type-name)
  18   "Given a tuple type return a list of slots sutable for the body of a defstruct body eg: ((A 0.0 :TYPE SINGLE-FLOAT) (B 0.0 :TYPE SINGLE-FLOAT))"
  19   (loop for e in (tuple-elements type-name)
  20          collect
  21            (list e (tuple-initial-element type-name) :type (tuple-element-type type-name))))
  22
  23 (defparameter *tuple-expander-keywords*
  24   '(:def-tuple-values :def-tuple-key-values
  25         :def-tuple-type :def-tuple-array-type
  26         :def-tuple-struct
  27         :def-tuple-getter
  28         :def-tuple-aref
  29         :def-tuple-aref*
  30         :def-nth-tuple
  31         :def-with-tuple :def-with-tuple* :def-with-tuple-aref
  32         :def-tuple-set :def-tuple-setter :def-tuple-aref-setter*
  33         :def-tuple-aref-setter
  34         :def-tuple-vector-push  :def-tuple-vector-push-extend
  35         :def-tuple-vector-push* :def-tuple-vector-push-extend*
  36         :def-new-tuple  :def-tuple-maker
  37         :def-tuple-maker*       :def-tuple-array-maker
  38         :def-tuple-array-dimensions
  39         :def-tuple-fill-pointer :def-tuple-setf-fill-pointer
  40         :def-tuple-setf* :def-tuple-array-setf*
  41         :def-tuple-array-setf
  42         :def-tuple-map
  43         :def-tuple-reduce))
  44
  45 (defgeneric tuple-symbol (type-name expansion))
  46
  47 (defgeneric tuple-expansion-fn (type-name expansion))
  48
  49 ;; eg. (vector3d-values* 1 2 3) => #{ 1 2 3 }
  50 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-values)))
  51   (make-adorned-symbol type-name :suffix "VALUES" :asterisk t ))
  52
  53 ;; eg (vector3d-values* 1.2 3.0 1.2) => #{ 1.2 3.0 1.2 }
  54 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-values)))
  55   "Expand to a macro that will create a values form representing our tuple type."
  56   `(defmacro ,(tuple-symbol type-name expansion) (&rest elements)
  57          `(the ,',(construct-tuple-value-type type-name)
  58                 (values  ,@elements))))
  59
  60 ;; eg. (vector3d-key-values z 1.0 x 2.0) => #{ 2.0 0.0 1.0 }
  61 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-key-values)))
  62   (make-adorned-symbol type-name :suffix "KEY-VALUES" :asterisk NIL))
  63
  64 ;; create freshly initialised multiple values e.g. (vector3d-key-values z 1.0 x 2.0) => #{ 2.0 0.0 1.0 }
  65 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-key-values)))
  66   `(defmacro ,(tuple-symbol type-name expansion)
  67        (&key
  68           (initial-element ,(tuple-initial-element type-name))
  69           ,@(mapcar (lambda (element)
  70                       `((,element ,element) initial-element))
  71                     (tuple-elements type-name)))
  72      `(,',(tuple-symbol type-name :def-tuple-values)
  73        ,,@(tuple-elements type-name))))
  74
  75 ;; deftype form for the multiple value equivalent of the struct
  76 ;; eg. (deftype vector3d* () `(values single-float single-float single-float))
  77 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-type)))
  78   (make-adorned-symbol type-name :asterisk t))
  79
  80 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-type)))
  81   "Expand the tuple multiple value deftype form."
  82   `(deftype ,(tuple-symbol type-name expansion) ()
  83          ,(construct-tuple-value-type type-name)))
  84
  85 ;; deftype form for the array equivalent of the struct
  86 ;; eg (deftype vector3d-array () (vector single-float *))
  87 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-array-type)))
  88   (make-adorned-symbol type-name :suffix "ARRAY"))
  89
  90 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-array-type)))
  91   "Expand the deftype form for an array of tuples"
  92   `(deftype ,(tuple-symbol type-name expansion) ()
  93          (vector ,(tuple-element-type type-name) *)))
  94
  95 ;; deftype form to generate the structure definition eg (defstruct vector3d ..)
  96 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-struct)))
  97   (make-adorned-symbol type-name))
  98
  99 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-struct)))
 100   "Defines a structure that will hold the tuple based on a vector."
 101   `(defstruct (,(tuple-symbol type-name expansion) (:type vector) (:constructor nil))
 102          ,@(construct-tuple-slots type-name)))
 103
 104 ;; -- generalised access --
 105
 106 ;; return macro that will convert an array to a values form (vector3d* v) => #{ x y z }
 107 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-getter)))
 108   (make-adorned-symbol type-name :asterisk t))
 109
 110 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-getter)))
 111   "Create a macro that will return the contents of a place representing our tuple as a value form"
 112   `(defmacro ,(tuple-symbol type-name :def-tuple-getter) (tuple-array-name)
 113          `(the ,(construct-tuple-value-type ',type-name)
 114                 (values
 115                  ,@(loop
 116                           for index from 0 below (tuple-size ',type-name)
 117                           collect
 118                                 (construct-tuple-array-reference ',type-name tuple-array-name index))))))
 119
 120
 121 ;; generate a setter for use with setf that takes values and places them into an array eg (vector3d-setter v #{ 1 2 3 })
 122 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-setter)))
 123   (make-adorned-symbol type-name :suffix "SETTER" :asterisk t))
 124
 125 (defun construct-tuple-set-aref (type-name tuple-place index varlist)
 126   `(setf (aref (the ,(tuple-typespec* type-name) ,tuple-place) ,index) ,(nth index varlist)))
 127
 128 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-setter)))
 129   "Create a macro that will set an tuple place form to the values of a tuple value form"
 130   `(defmacro ,(tuple-symbol type-name :def-tuple-setter) (tuple-place tuple-values)
 131          (let* ((varlist (make-gensym-list ,(tuple-size type-name))))
 132            `(multiple-value-bind
 133                           ,varlist
 134                         ,tuple-values
 135                   (declare (type ,',(tuple-element-type type-name) ,@varlist))
 136                   (values
 137                    ,@(loop
 138                                 for index from 0 below ,(tuple-size type-name)
 139                                 collect
 140                                   (construct-tuple-set-aref ',type-name tuple-place index varlist)))))))
 141
 142 ;; generate a setter for use with setf that takes values and places them into an array eg (vector3d-setter v #{ 1 2 3 })
 143 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-set)))
 144   (make-adorned-symbol type-name :prefix "SET"))
 145
 146 ;; to do -- this needs type declarations
 147 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-set)))
 148   `(defun ,(tuple-symbol type-name :def-tuple-set) (tuple-place ,@(tuple-elements type-name))
 149          ,@(loop
 150                   for index from 0 below (tuple-size type-name)
 151                   collect
 152                         `(setf (aref tuple-place ,index) ,(nth index (tuple-elements type-name))))))
 153
 154 ;; generalised reference to a tuple place
 155 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-setf*)))
 156  (make-adorned-symbol type-name :suffix "SETTER" :asterisk t))
 157
 158 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-setf*)))
 159   "Expand form that creates generalized reference to a tuple place"
 160   `(defsetf ,(tuple-symbol type-name :def-tuple-getter) ,(tuple-symbol type-name :def-tuple-setter)))
 161
 162 ;; -- arrays --
 163
 164 ;; to do -- possibly re-engineer as a macro
 165
 166 ;; create a flat array dimensioned to hold n tuples eg. (make-vector3d-array 3 :adjustable t)
 167 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-array-maker)))
 168   (make-adorned-symbol type-name :prefix "MAKE" :suffix "ARRAY" ))
 169
 170 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-array-maker)))
 171   "Create macro that creates a array of tuple array places."
 172   `(defun ,(tuple-symbol type-name :def-tuple-array-maker) (dimensions &key adjustable (initial-element ,(tuple-initial-element type-name))  (fill-pointer nil fill-pointer-p))
 173          (make-array (* ,(tuple-size type-name) dimensions)
 174                                  :adjustable adjustable
 175                                  :initial-element initial-element
 176                                  :fill-pointer (when fill-pointer-p (* ,(tuple-size type-name) fill-pointer))
 177                                  :element-type ',(tuple-element-type type-name))))
 178
 179
 180 ;; create an array accessor that will pick an individual tuple out of an array of tuples
 181 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-aref)))
 182   (make-adorned-symbol type-name :suffix "AREF"))
 183
 184 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-aref)))
 185   "Create a macro that will set an indexed array of tuple places to the values of a tuple struct form"
 186   `(defun  ,(tuple-symbol type-name :def-tuple-aref) (tuple-array tuple-index)
 187          (the ,(tuple-typespec* type-name)
 188                   (subseq (the ,(tuple-typespec** type-name) tuple-array)
 189                                   (* ,(tuple-size type-name) tuple-index)
 190                                   (* ,(tuple-size type-name) (1+ tuple-index))))))
 191
 192
 193 ;; create an array accessor that accesses an array of tuples and produces a value form eg (vector3d-aref* vecs 2) => #{ 2.3 4.3 2.4 }
 194 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-aref*)))
 195   (make-adorned-symbol type-name :suffix "AREF" :asterisk t))
 196
 197 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-aref*)))
 198   "Create a macro that will index an array that is considered to be an array of tuples and extract an individual tuple as a value form"
 199   (let ((tuple-size (tuple-size type-name)))
 200     `(defmacro ,(tuple-symbol type-name :def-tuple-aref*) (tuple-array array-index)
 201        (let ((array-index-sym (gensym)))
 202          `(let ((,array-index-sym (* ,',tuple-size ,array-index)))
 203             (the ,',(tuple-typespec type-name)
 204                  (values ,@(iterate
 205                              (for counter below ,tuple-size)
 206                              (collect `(aref (the ,',(tuple-typespec** type-name) ,tuple-array)
 207                                              (the fixnum (+ ,counter ,array-index-sym))))))))))))
 208
 209 ;; decided not to use this one..
 210 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-nth-tuple)))
 211   (make-adorned-symbol type-name :prefix "NTH"))
 212
 213 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-nth-tuple)))
 214   `(defun ,(tuple-symbol type-name :def-tuple-setter) (index tuple-place)
 215          (make-array ,(tuple-size type-name) :displaced-to tuple-place :displaced-index-offset (* ,(tuple-size type-name) index))))
 216
 217 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-aref-setter)))
 218   (make-adorned-symbol type-name :suffix "AREF-SETTER"))
 219
 220 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-aref-setter)))
 221   "Create a macro that will set an indexed array of tuple places to the values of a tuple struct form"
 222   `(defun ,(tuple-symbol type-name :def-tuple-aref-setter) (array-name tuple-index tuple)
 223          (setf (subseq array-name
 224                                    (* ,(tuple-size type-name) tuple-index)
 225                                    (* ,(tuple-size type-name) (1+ tuple-index)))
 226                    tuple)))
 227
 228 ;; create a setter macro (for generalised setf places) that will set a tuple value form into an indexed array
 229 ;; eg (vector3d-aref-setter vecs 2 #{ 2.3 2.3 4.2 })
 230 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-aref-setter*)))
 231   (make-adorned-symbol type-name :suffix "AREF-SETTER" :asterisk t))
 232
 233 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-aref-setter*)))
 234   "Create a macro that will set an indexed array of tuple places to the values of a tuple value form"
 235   `(defmacro ,(tuple-symbol type-name :def-tuple-aref-setter*) (array-name array-index tuple-values)
 236          (let* ((varlist (make-gensym-list ,(tuple-size type-name)))
 237                         (array-index-sym (gensym)))
 238            `(let ((,array-index-sym (* ,',(tuple-size type-name) ,array-index)))
 239                   (multiple-value-bind
 240                                 ,varlist
 241                           ,tuple-values
 242                         (declare (type ,',(tuple-element-type type-name) ,@varlist))
 243                         (values ,@(let ((counter 0))
 244                                                    (mapcar #'(lambda (x)
 245                                                                            (prog1
 246                                                                                    `(setf (aref (the ,',(tuple-typespec** type-name) ,array-name)
 247                                                                                                                 (the fixnum (+ (the fixnum ,counter) (the fixnum ,array-index-sym))))
 248                                                                                                   (the ,',(tuple-element-type type-name) ,x))
 249                                                                                  (incf counter)))
 250                                                                    varlist))))))))
 251
 252 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-array-setf)))
 253   (make-adorned-symbol type-name :suffix "AREF" ))
 254
 255 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-array-setf)))
 256   "Expand form that creates generalized reference to tuple-arrays"
 257   `(defsetf ,(tuple-symbol type-name :def-tuple-aref)
 258            ,(tuple-symbol type-name :def-tuple-aref-setter)))
 259
 260 ;; generalised reference to an array of tuples via value forms
 261 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-array-setf*)))
 262   (make-adorned-symbol type-name :suffix "AREF" :asterisk t))
 263
 264 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-array-setf*)))
 265   "Expand form that creates generalized reference to tuple-arrays"
 266   `(defsetf ,(tuple-symbol type-name :def-tuple-aref*)
 267            ,(tuple-symbol type-name :def-tuple-aref-setter*)))
 268
 269 ;; create a function that returns the dimensions of an array scaled down to tuple units
 270 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-array-dimensions)))
 271   (make-adorned-symbol type-name :suffix "ARRAY-DIMENSIONS"))
 272
 273 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-array-dimensions)))
 274   "Create macro that returns the number of tuples in an array of tuple places."
 275   `(defun ,(tuple-symbol  type-name :def-tuple-array-dimensions) (tuple-array)
 276          (the fixnum (/ (the fixnum (length tuple-array)) (the fixnum ,(tuple-size type-name))))))
 277
 278 ;; create a function that returns the fillpoiinter of an array scaled down to tuple units
 279 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-fill-pointer)))
 280   (make-adorned-symbol type-name :suffix "FILL-POINTER"))
 281
 282 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-fill-pointer)))
 283   "Create macro that returns the number of tuples in an array of tuple places."
 284   `(defun ,(tuple-symbol  type-name :def-tuple-fill-pointer) (tuple-array)
 285          (the fixnum (/ (the fixnum (fill-pointer tuple-array)) (the fixnum ,(tuple-size type-name))))))
 286
 287 ;; create a function that returns the fillpoiinter of an array scaled down to tuple units
 288 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-setf-fill-pointer)))
 289   (make-adorned-symbol type-name :suffix "FILL-POINTER"))
 290
 291 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-setf-fill-pointer)))
 292   "Create macro that returns the number of tuples in an array of tuple places."
 293   (with-gensyms (actual-fill-ptr)
 294         `(defun (setf ,(tuple-symbol  type-name :def-tuple-fill-pointer)) (value tuple-array)
 295            (declare (type fixnum value))
 296            (let ((,actual-fill-ptr
 297                           (the fixnum (* value (the fixnum ,(tuple-size type-name))))))
 298                  (setf (fill-pointer tuple-array) ,actual-fill-ptr)))))
 299
 300 ;; --- vectors --
 301
 302 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-vector-push)))
 303   (make-adorned-symbol type-name :suffix "VECTOR-PUSH"))
 304
 305 ;; tuple-vector-push
 306 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-vector-push)))
 307   "Create a macro that will push a tuple value form into an array of existing tuple places."
 308   `(defun ,(tuple-symbol type-name :def-tuple-vector-push) (tuple array-name)
 309          (declare (type ,(tuple-typespec* type-name) tuple) (type ,(tuple-typespec** type-name) array-name))
 310          (loop
 311                 for index from 0 below ,(tuple-size type-name)
 312                 do (vector-push (the ,(tuple-element-type type-name) (aref tuple index)) array-name))
 313          (the fixnum (/  (the fixnum (fill-pointer array-name)) (the fixnum ,(tuple-size type-name))))))
 314
 315 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-vector-push-extend)))
 316   (make-adorned-symbol type-name :suffix "VECTOR-PUSH-EXTEND"))
 317
 318 ;; tuple-vector-push
 319 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-vector-push-extend)))
 320   "Create a macro that will push a tuple value form into an array of existing tuple places."
 321   `(defun ,(tuple-symbol type-name :def-tuple-vector-push-extend) (tuple array-name)
 322          (declare (type ,(tuple-typespec* type-name) tuple) (type ,(tuple-typespec** type-name) array-name))
 323          (loop
 324                 for index from 0 below (the fixnum ,(tuple-size type-name))
 325                 do (vector-push-extend (aref tuple (the fixnum index)) array-name))
 326          (the fixnum (/  (the fixnum (fill-pointer array-name)) (the fixnum ,(tuple-size type-name))))))
 327
 328 ;; eg. (vector3d-push* vecs #{ 0.0 1.0 3.0 })
 329 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-vector-push*)))
 330   (make-adorned-symbol type-name :suffix "VECTOR-PUSH" :asterisk t))
 331
 332 ;; tuple-vector-push
 333 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-vector-push*)))
 334   "Create a macro that will push a tuple value form into an array of existing tuple places."
 335   `(defmacro ,(tuple-symbol type-name :def-tuple-vector-push*) (tuple-values array-name)
 336          (let* ((varlist (make-gensym-list ,(tuple-size type-name))))
 337            `(progn
 338                   (multiple-value-bind
 339                                 ,varlist
 340                           ,tuple-values
 341                         (declare (type ,',(tuple-element-type type-name) ,@varlist))
 342                         ,@(loop
 343                                  for index from 0 below ,(tuple-size type-name)
 344                                  collect
 345                                    `(vector-push (the fixnum,(nth index varlist)) (the ,',(tuple-typespec** type-name) ,array-name))))
 346                   (the fixnum (/  (the fixnum (fill-pointer ,array-name)) (the fixnum ,',(tuple-size type-name))))))))
 347
 348 ;; eg. (vector3d-push-extend* vecs #{ 0.0 1.0 3.0 })
 349 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-vector-push-extend*)))
 350   (make-adorned-symbol type-name :suffix "VECTOR-PUSH-EXTEND" :asterisk t))
 351
 352 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-vector-push-extend*)))
 353   "Create a macro that will push a tuple value form into an array of existing tuple places, extending if adjustable."
 354   `(defmacro ,(tuple-symbol type-name :def-tuple-vector-push-extend*) (tuple-values array-name)
 355          (let* ((varlist (make-gensym-list ,(tuple-size type-name))))
 356            `(progn
 357                   (multiple-value-bind
 358                           ,varlist
 359                         ,tuple-values
 360                   (declare (type ,',(tuple-element-type type-name) ,@varlist))
 361                   ,@(loop
 362                            for index from 0 below ,(tuple-size type-name)
 363                            collect
 364                                  `(vector-push-extend (the fixnum ,(nth index varlist)) (the ,',(tuple-typespec** type-name) ,array-name) ,',(tuple-size type-name))))
 365                   (the fixnum (/  (the fixnum (fill-pointer ,array-name)) (the fixnum ,',(tuple-size type-name))))))))
 366
 367 ;; -- bindings --
 368 ;; bind tuple vector to symbols during evaluation of the form eg (with-vector3d #( 1.0 2.0 3.0 ) (x y z) (fomat t "~A" (list x y z)))
 369 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-with-tuple)))
 370   (make-adorned-symbol type-name :prefix "WITH"))
 371
 372 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql  :def-with-tuple)))
 373   "Create a wrapper that will bind a tuple place  to symbols during evaluation of the body."
 374   `(defmacro ,(tuple-symbol type-name :def-with-tuple) (tuple-place element-syms &body forms)
 375          (assert (= (length element-syms) ,(tuple-size type-name)) nil "Incorrect length element-syms supplied to with-tuple*")
 376          ` (multiple-value-bind
 377                          ,element-syms
 378                    (values ,@(let ((counter 0))
 379                                                   (mapcar #'(lambda (x)
 380                                                                           (declare (ignore x))
 381                                                                           (prog1
 382                                                                                   `(aref (the ,',(tuple-typespec** type-name) ,tuple-place) ,counter)
 383                                                                                 (incf counter)))
 384                                                                   element-syms)))
 385                  (declare (ignorable ,@element-syms) (type ,',(tuple-element-type type-name) ,@element-syms))
 386                  (progn ,@forms))))
 387
 388 ;; bind tuple values to symbols during evaluation of the form eg (with-vector3d* #{ 1.0 2.0 3.0 } (x y z) (fomat t "~A" (list x y z)))
 389 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-with-tuple*)))
 390   (make-adorned-symbol type-name :prefix "WITH" :asterisk t))
 391
 392 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-with-tuple*)))
 393   "Create a wrapper that will bind a tuple value form to symbols during evaluation of the body."
 394   `(defmacro ,(tuple-symbol type-name :def-with-tuple*)  (tuple element-syms &body forms)
 395          (assert (= (length element-syms) ,(tuple-size type-name)) nil "Incorrect length element-syms supplied to with-tuple")
 396          `(multiple-value-bind
 397                         ,element-syms
 398                   ,tuple
 399                 (declare (ignorable ,@element-syms) (type ,',(tuple-element-type type-name) ,@element-syms))
 400                 (progn ,@forms))))
 401
 402
 403 ;; bind tuple array elements to symbols during evaluation of the form eg (with-vector3d-aref (vecs 2 (x y z)) (fomat t "~A" (list x y z)))
 404 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-with-tuple-aref)))
 405   (make-adorned-symbol type-name :prefix "WITH" :suffix "AREF" ))
 406
 407 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-with-tuple-aref)))
 408   "Create a wrapper macro that will bind an indexed tuple form in an array to symbols turing evaluation of the body."
 409   `(defmacro ,(tuple-symbol type-name :def-with-tuple-aref)  ((array-name index element-syms) &body forms)
 410          (assert (= (length element-syms) ,(tuple-size type-name)) nil "Incorrect length element-syms supplied to with-tuple-aref")
 411          (let* ((array-index-sym (gensym)))
 412            `(let ((,array-index-sym (* ,',(tuple-size type-name) ,index)))
 413                   (multiple-value-bind
 414                                 ,element-syms
 415                           ;; this is the bit we need to generate
 416                           (values ,@(let ((counter 0))
 417                                                          (mapcar #'(lambda (x)
 418                                                                                  (declare (ignore x))
 419                                                                                  (prog1
 420                                                                                          `(aref (the ,',(tuple-typespec** type-name) ,array-name) (+ ,counter ,array-index-sym))
 421                                                                                    (incf counter)))
 422                                                                          element-syms)))
 423                         (declare (ignorable ,@element-syms) (type ,',(tuple-element-type type-name)))
 424                         (progn ,@forms))))))
 425
 426 ;; -- constructors --
 427 (defun construct-tuple-array-maker (type-name)
 428   `(make-array  ,(tuple-size type-name) :initial-element ,(tuple-initial-element type-name) :element-type ',(tuple-element-type type-name)))
 429
 430 ;; create a new tuple, freshly initialised eg (new-vector3d) => #( 0.0 0.0 0.0 )
 431 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-new-tuple)))
 432   (make-adorned-symbol type-name :prefix "NEW" ))
 433
 434 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-new-tuple)))
 435   "Create a macro that creates a new tuple."
 436   `(defmacro ,(tuple-symbol type-name :def-new-tuple) ()
 437          `(the ,',(tuple-typespec* type-name)
 438                 ,(construct-tuple-array-maker ',type-name))))
 439
 440
 441 ;; create and initalise a tupe eg (make-vector3d 0.0 1.0 2.0) => #( 0.0 1.0 2.0 )
 442 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-maker)))
 443   (make-adorned-symbol type-name :prefix "MAKE"))
 444
 445 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-maker)))
 446   "Create a macro that creates new tuple place and initialize it from a list of elements"
 447   `(defmacro ,(tuple-symbol type-name :def-tuple-maker) (&rest elements)
 448          (assert (= (length elements) ,(tuple-size type-name)))
 449          (let ((tuple-sym (gensym)))
 450            `(let ((,tuple-sym
 451                            ,(construct-tuple-array-maker ',type-name)))
 452                   (declare (type ,',(tuple-typespec* type-name) ,tuple-sym))
 453                   (,',(tuple-symbol type-name :def-tuple-setter) ,tuple-sym (values  ,@elements))
 454                   ,tuple-sym))))
 455
 456
 457 ;; --- create and initialise from multiple values eg (make-vector3d* #{ 12.0 3.0 6.0 })
 458 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-maker*)))
 459   (make-adorned-symbol type-name :prefix "MAKE" :asterisk t))
 460
 461 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-maker*)))
 462   "Create a macro that creates new tuple place, form and initialize it with values"
 463   `(defmacro ,(tuple-symbol type-name :def-tuple-maker*) (tuple-values)
 464          (let ((varlist (make-gensym-list ,(tuple-size type-name)))
 465                    (tuple-sym (gensym))
 466                    (counter-sym 0))
 467            (declare (type fixnum counter-sym))
 468            `(let  ((,tuple-sym
 469                                 ,(construct-tuple-array-maker ',type-name)))
 470                   (declare (type ,',(tuple-typespec* type-name) ,tuple-sym))
 471                   (multiple-value-bind
 472                                 ,varlist
 473                           ,tuple-values
 474                         (declare (type ,',(tuple-element-type type-name) ,@varlist))
 475                         (progn ,@(mapcar #'(lambda (x)
 476                                                                  (prog1
 477                                                                          `(setf (aref ,tuple-sym (the fixnum ,counter-sym)) ,x)
 478                                                                    (incf counter-sym)))
 479                                                          varlist)
 480                                    ,tuple-sym))))))
 481
 482 ;; eg. (vector2d-map* (+) #{1.0 2.0} #{4.0 5.0}) => #{5.0 7.0}
 483 ;; or even (vector2d-map* (and) #{1.0 2.0} #{3.0 4.0}) => #{3.0 4.0}
 484 ;; and (vector2d-map* ((lambda (a b) (funcall #'+ a b))) #{1.0 2.0} #{4.0 5.0}) => #{5.0 7.0}
 485 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-map)))
 486   (make-adorned-symbol type-name :suffix "MAP*" :asterisk NIL))
 487
 488 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-map)))
 489   `(defmacro ,(tuple-symbol type-name expansion) (operator &rest args)
 490      (let* ((symbols
 491               (mapcar (lambda (arg)
 492                         (declare (ignore arg))
 493                         (make-gensym-list ,(tuple-size type-name)))
 494                       args))
 495             (values
 496               `(,',(tuple-symbol type-name :def-tuple-values)
 497                 ,@(iterate
 498                     (for index below ,(tuple-size type-name))
 499                     (collect `(,@operator ,@(mapcar (lambda (gensyms)
 500                                                       (nth index gensyms))
 501                                                     symbols)))))))
 502        (iterate
 503          (for arg in (reverse args))
 504          (for gensyms in (reverse symbols))
 505          (setf values `(,',(tuple-symbol type-name :def-with-tuple*)
 506                         ,arg ,gensyms
 507                         ,values)))
 508        values)))
 509
 510 ;; eg. (vector3d-reduce* '+ #{1.0 2.0 3.0}) => 6.0
 511 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-reduce)))
 512   (make-adorned-symbol type-name :suffix "REDUCE*" :asterisk NIL))
 513
 514 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-reduce)))
 515   `(defmacro ,(tuple-symbol type-name expansion) (operator tuple)
 516      (let ((symbols (make-gensym-list ,(tuple-size type-name))))
 517        `(,',(tuple-symbol type-name :def-with-tuple*)
 518          ,tuple ,symbols
 519          (,@operator ,@symbols)))))
 520
 521
 522 ;; -- def-tuple-op expanders begin here ------------------------------------
 523
 524 ;; (in-package :tuple-types)
 525
 526 ;; (defclass %tuple-fun ()
 527 ;;   ((name :intiarg :fun-name)
 528 ;;    (params :initarg :params)
 529 ;;    (types :initarg :types)
 530 ;;    (elements :initarg :elements)))
 531
 532 ;; (in-package :cl-tuples)
 533
 534 (defun symbol-macro-expander-fn (n names types elements gensyms body)
 535   "Wrap the body of def tuple op in symbol macros mapped to gensyms to prevent
 536    name capture."
 537   ;; if this is a tuple type with elements, we expand using with-tuple
 538   (if (tuple-typep (nth n types))
 539           (progn
 540                 (assert (= (length (nth n gensyms))
 541                                    (length (nth n elements)))
 542                                 nil "~A contains too few elements for a ~A" (nth n elements) (nth n types))
 543                 ``(symbol-macrolet
 544                           ,',(loop
 545                                         for gensym in (nth n gensyms)
 546                                         for element in (nth n elements) collect `(,element  ,gensym))
 547 ;;                      (declare (ignorable ,@',(nth n gensyms)))
 548                         (symbol-macrolet ((,',(nth n names) (,',(make-adorned-symbol (nth n types) :suffix "VALUES" :asterisk t)
 549                                                                                                         ,@',(loop
 550                                                                                                                    for gensym in (nth n gensyms)
 551                                                                                                                    collect gensym))))
 552                           ;; recurs down to the next parameter
 553                           ,,(if (< (1+ n) (length names))
 554                                         (symbol-macro-expander-fn (1+ n) names types elements gensyms body)
 555                                         ;; or bottom out
 556                                         ``(progn ,@',body)))))
 557           ;; if this is not a tuple type, and theres more to come, recurse down
 558           (if (< (1+ n) (length names))
 559                   (symbol-macro-expander-fn (1+ n) names types elements gensyms body)
 560                   ;; otherwise, bottom out
 561                   ``(progn ,@',body))))
 562
 563
 564 (defun arg-expander-fn-aux (n names types elements gensyms body)
 565   "Handle the expansion of the n-th parameter in a def-tuple-op call list. Names are the "
 566   (if (nth n types)
 567       ;; if it's a tuple type, bind to gensyms using the apropiate with-tuple macro
 568       (if (tuple-typep (nth n types))
 569           (if (< (1+ n) (length names))
 570               (arg-expander-fn-aux (1+ n) names types elements gensyms body)
 571               (symbol-macro-expander-fn 0 names types elements gensyms body))
 572           ;; otherwise just use a straight symbol
 573           ``(let ((,',(nth n names) (the ,',(nth n types) ,,(nth n names))))
 574               ,,(if (< (1+ n) (length names))
 575                     (arg-expander-fn-aux (1+ n) names types elements gensyms body)
 576                     (symbol-macro-expander-fn 0 names types elements gensyms body))))
 577       ;; if there are no associated parameters with this op, just expand the body
 578       (symbol-macro-expander-fn 0 nil nil nil nil body)))
 579
 580 (defun arg-expander-fn-aux-with (n names types elements gensyms body)
 581   "Handle the tuple type case, expanding into -WITH macros.  The rest is
 582 handled by ARG-EXPANDER-FN-AUX in a separate step."
 583   (if (nth n types)
 584       ;; if it's a tuple type, bind to gensyms using the apropiate with-tuple macro
 585       (if (tuple-typep (nth n types))
 586           ``(,',(make-adorned-symbol (nth n types) :prefix "WITH" :asterisk t)
 587              ,,(nth n  names) ,',(nth n  gensyms)
 588              ,,(if (< (1+ n) (length names))
 589                    (arg-expander-fn-aux-with (1+ n) names types elements gensyms body)
 590                    (arg-expander-fn-aux 0 names types elements gensyms body)))
 591           ;; otherwise just use a straight symbol
 592           (if (< (1+ n) (length names))
 593               (arg-expander-fn-aux-with (1+ n) names types elements gensyms body)
 594               (arg-expander-fn-aux 0 names types elements gensyms body)))
 595       ;; if there are no associated parameters with this op, just expand the body
 596       (symbol-macro-expander-fn 0 nil nil nil nil body)))
 597
 598 (defun body-expander-fn (names types elements gensyms body)
 599   "Expand the declarations and return type wrapper round a def-tuple-op. form"
 600   ;; have we specifed a return type?
 601   (if (eq (caar body) :return)
 602           (let ((ret-type
 603                          ;; is it a tuple type?
 604                          (if (tuple-typep (cadar body))
 605                                  ;; yes, expand into type spec
 606                                  (tuple-typespec (cadar body))
 607                                  ;; no, just use literal expansion
 608                                  (cadar body)))
 609                         ;; the rest of the body is the actual body
 610                         (real-body (cddar body)))
 611                 ;; when we have a parameter list, expand it
 612                 ``(the ,',ret-type
 613                         ,,(arg-expander-fn-aux-with 0 names types elements gensyms real-body)))
 614           ;;         ;; otherwise splice in the quoted body
 615           ;;         ``(the ,',ret-type
 616           ;;             (progn ,@',real-body)))
 617           ;; no we havent specified a return type, just fall in
 618           (arg-expander-fn-aux-with 0 names types elements gensyms body)))
 619
 620 (defun def-tuple-expander-fn (params types elements forms)
 621   "Helper function for def-tuple-op. Expands the arguments into a series of WITH-* forms so that
 622    symbols are bound to tuple elements in the body of the operator."
 623   (assert (= (length params) (length types) (length elements)) ()
 624                   "Malformed def-tuple-op argument list.")
 625   ;; if the first of the forms is a string then it's a docstring
 626   (let ((body (if (stringp (first forms)) (rest forms) forms)))
 627         ;; create a gensym for every tuple element - they are going to be symbol macros
 628         (let ((gensyms
 629                    (mapcar #'(lambda (element-list)
 630                                            (make-gensym-list (length element-list))) elements)))
 631           ;; epand the body
 632           (body-expander-fn params types elements gensyms body))))
 633
 634                                                                                 ; tester
 635 ;; (arg-expander-fn '(v q) '(vector3d quaternion) '((x y z) (qx qy qz qw)) '("Return the vector + real" (:return (values single-float single-float single-float single-float) (vertex3d-tuple x y z qw))))
 636 ;; (arg-expander-fn '(v q n) '(vector3d quaternion single-float) '((x y z) (qx qy qz qw) nil) '("Return the vector + real" (:return vertex3d (vertex3d-tuple x y z qw))))
 637