Plaster
New
List
Login
common-lisp
default
shinmera
2020.03.06 15:17:26
;;; Template mechanism (defmacro define-template (name &rest args)) (defun template-type (&rest template-args)) (defgeneric constructor (template-type)) (defgeneric place (template-type qualifier)) (define-template 2vec+ vec <s> <t> (a b) (let ((type (template-type 'vec <s> <t>))) `(declare (type ,type a b)) `(,(constructor type) ,@(loop for i from 0 below <s> collect `(+ (,(place type i) a) (,(place type i) b)))))) (define-2vec+ 2 single-float) ;; ===> (defun 2vec+/2/single-float (a b) (declare (type vec2 a b)) (vec2 (+ (vx2 a) (vx2 b)) (+ (vy2 a) (vy2 b)))) (define-template 2nvec+ <s> <t> (a b) (let ((type (template-type 'vec <s> <t>))) `(declare (type ,type a b)) (loop for i from 0 below <s> collect `(setf (,(place type i) a) (+ (,(place type i) a) (,(place type i) b)))) 'a)) (define-2nvec+ 3 ub32) ;; ===> (defun 2nvec+/3/ub32 (a b) (declare (type uvec3 a b)) (setf (uvx3 a) (+ (uvx3 a) (uvx3 b))) (setf (uvy3 a) (+ (uvy3 a) (uvy3 b))) a) (define-template* vsqrlen vec <s> <t> (a) `(declare (type ,type a)) `(+ ,@(loop for i from 0 below <s> collect `(expt (,(place type i) a) 2)))) (define-vsqrlen 4 double-float) ;; ==> (defun vsqrlen/4/double-float (a) (declare (type dvec4 a)) (+ (expt (dvx4 a) 2) (expt (dvy4 a) 2) (expt (dvz4 a) 2) (expt (dvw4 a) 2))) ;;; Dispatch mechanism (defmacro define-dispatch (name args &rest template-combinations)) (define-dispatch vsqrlen (a) (2 3 4) (single-float double-float ub32 sb32)) ;; ==> (defun vqsrlen (a) (etypecase a (vec2 (vsqrlen/2/single-float a)) (vec3 (vsqrlen/3/single-float a)) (vec4 (vsqrlen/4/single-float a)) (dvec2 (vsqrlen/2/double-float a)) (dvec3 (vsqrlen/3/double-float a)) (dvec4 (vsqrlen/4/double-float a)) (uvec2 (vsqrlen/2/ub32 a)) (uvec3 (vsqrlen/3/ub32 a)) (uvec4 (vsqrlen/4/ub32 a)) (ivec2 (vsqrlen/2/sb32 a)) (ivec3 (vsqrlen/3/sb32 a)) (ivec4 (vsqrlen/4/sb32 a)))) ;; + possible impl-specific type inference expanders
Raw
Annotate
Repaste
Annotations
common-lisp
default
shinmera
2020.03.06 16:36:16
;;; Utilities (defun compose-name (separator &rest parts) (intern (with-output-to-string (out) (flet ((s (a) (let ((s (typecase a (string a) (symbol (symbol-name a)) (T (princ-to-string a))))) (write-string s out)))) (s (first parts)) (loop for part in (rest parts) do (when separator (write-char separator out)) (s part)))))) (defun enumerate-combinations (&rest combinations) (if (cdr combinations) (loop for comb in (first combinations) nconc (loop for rest in (apply #'enumerate-combinations (rest combinations)) collect (list* comb rest))) (loop for comb in (first combinations) collect (list comb)))) ;;; Template type mechanism (defclass template-type () ()) (defgeneric template-type (base-type template-args)) (defgeneric constructor (template-type)) (defgeneric name (template-type)) (defgeneric place (template-type qualifier)) (defmethod template-type ((base symbol) template-args) (template-type (make-instance base) template-args)) (defun emit-template-type (parent name fields) (let ((class (compose-name #\- name 'type))) `(progn (defclass ,class (,parent) ()) (defmethod constructor ((_ ,class)) ',(compose-name NIL '% name)) (defmethod name ((_ ,class)) ',name) (defmethod place ((_ ,class) qualifier) (ecase qualifier ,@(loop for (name type alias) in fields collect `(,alias ',name)))) (defstruct (,name (:constructor ,(compose-name NIL '% name) ,(loop for (name type alias) in fields collect name)) (:copier ,(compose-name #\- name 'copy)) (:predicate ,(compose-name #\- name 'p)) (:conc-name NIL)) ,@(loop for (name type alias) in fields collect `(,name NIL :type ,type)))))) (defmacro define-template-type (name template-args name-constructor &body body) (let ((fields (gensym "FIELDS")) (targs (gensym "TEMPLATE-ARGS")) (class (compose-name #\- name 'type))) `(progn (defclass ,class (template-type) ()) (defmethod template-type ((_ (eql ',name)) ,targs) (template-type (make-instance ',class) ,targs)) (defmethod template-type ((_ ,class) ,targs) (destructuring-bind ,template-args ,targs (make-instance (compose-name #\- ,name-constructor 'type)))) (defmacro ,(compose-name #\- 'define name) ,template-args (let ((,fields ())) (labels ((field (name &key (type T) alias) (push (list name type alias) ,fields))) ,@body (emit-template-type ',class ,name-constructor (nreverse ,fields)))))))) ;;; Template mechanism (defmacro define-template (name &rest args) (destructuring-bind (base . template-args) (loop until (listp (car args)) collect (pop args)) (destructuring-bind (args . body) args `(defmacro ,(compose-name #\- 'define name) ,template-args (let* ((type (template-type ',base (list ,@template-args))) (constructor (constructor type)) (name (name type))) (flet ((place (qualifier) (place type qualifier))) `(defun ,(compose-name #\/ ',name ,@template-args) ,',args ,@(list ,@body)))))))) ;;; Dispatch mechanism ;; FIXME: + possible impl-specific type inference expanders ;; FIXME: handle args of different type combinations (defmacro define-dispatch (name args &rest template-combinations) (destructuring-bind (base-type . combinations) template-combinations `(defun ,name ,args (etypecase ,(first args) ,@(loop for template in (apply #'enumerate-combinations combinations) for type = (template-type base-type template) for op = (apply #'compose-name #\/ name template) collect `(,(name type) (,op ,@args))))))) ;;;; Usage (defun type-prefix (type) (ecase type (single-float '||) (double-float 'd) (ub32 'u) (sb32 'i))) (deftype ub32 () '(unsigned-byte 32)) (deftype sb32 () '(signed-byte 32)) (define-template-type vec (<s> <t>) (compose-name NIL (type-prefix <t>) 'vec <s>) (loop for i from 0 below <s> for f in '(x y z w) do (field (compose-name NIL (type-prefix <t>) 'v f <s>) :type <t> :alias (list i f)))) (define-vec 2 single-float) (define-vec 3 single-float) (define-vec 4 single-float) (define-vec 2 double-float) (define-vec 3 double-float) (define-vec 4 double-float) (define-vec 2 ub32) (define-vec 3 ub32) (define-vec 4 ub32) (define-vec 2 sb32) (define-vec 3 sb32) (define-vec 4 sb32) (define-template 2vec+ vec <s> <t> (a b) `(declare (type ,name a b)) `(,constructor ,@(loop for i from 0 below <s> collect `(+ (,(place i) a) (,(place i) b))))) (define-2vec+ 2 single-float) (define-template 2nvec+ vec <s> <t> (a b) `(declare (type ,name a b)) `(setf ,@(loop for i from 0 below <s> collect `(,(place i) a) collect `(+ (,(place i) a) (,(place i) b)))) 'a) (define-2nvec+ 3 ub32) (define-template vsqrlen vec <s> <t> (a) `(declare (type ,name a)) `(+ ,@(loop for i from 0 below <s> collect `(expt (,(place i) a) 2)))) (define-vsqrlen 2 single-float) (define-vsqrlen 3 single-float) (define-vsqrlen 4 single-float) (define-vsqrlen 2 double-float) (define-vsqrlen 3 double-float) (define-vsqrlen 4 double-float) (define-vsqrlen 2 sb32) (define-vsqrlen 3 sb32) (define-vsqrlen 4 sb32) (define-vsqrlen 2 ub32) (define-vsqrlen 3 ub32) (define-vsqrlen 4 ub32) (define-dispatch vsqrlen (a) vec (2 3 4) (single-float double-float ub32 sb32))
Raw
Repaste