cdo/ham
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Write define-transform macro for common transform logic

Browse Source
This commit is contained in:
Camden Dixie O'Brien 2025-05-29 01:14:30 +01:00
parent 5ce814867d
commit 8738229053
1 changed files with 37 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

74
drawing.lisp
View File

@ -22,44 +22,44 @@
(bottom-y (- centre-y (/ height 2)))) (bottom-y (- centre-y (/ height 2))))
(rectangle left-x bottom-y width height))) (rectangle left-x bottom-y width height)))
(defun translate (delta-x delta-y drawing) (defmacro define-transform (name (&rest params)
(defun translate-points (points) &key x-transform y-transform scalar-transform)
(let ((new-points (copy-seq points))) `(defun ,name (,@params drawing)
(do ((i 0 (+ i 2))) (labels ((transform-points (points)
((>= i (length points))) (let ((new-points (copy-seq points)))
(incf (aref new-points i) delta-x) (do ((i 0 (+ i 2)))
(incf (aref new-points (1+ i)) delta-y)) ((>= i (length points)))
new-points)) (let ((x (aref new-points i))
(defun translate-primitive (primitive) (y (aref new-points (1+ i))))
(typecase primitive (setf (aref new-points i) ,x-transform)
(line (make-line :points (translate-points (line-points primitive)))) (setf (aref new-points (1+ i)) ,y-transform)))
(circle new-points))
(make-circle (transform-primitive (primitive)
:radius (circle-radius primitive) (typecase primitive
:centre (translate-points (circle-centre primitive)))) (line
(polygon (make-line
(make-polygon :points (transform-points (line-points primitive))))
:points (translate-points (polygon-points primitive)))))) (circle
(mapcar #'translate-primitive drawing)) (make-circle
:radius ,(if scalar-transform
`(let ((s (circle-radius primitive)))
,scalar-transform)
'(circle-radius primitive))
:centre (transform-points (circle-centre primitive))))
(polygon
(make-polygon
:points (transform-points
(polygon-points primitive)))))))
(mapcar #'transform-primitive drawing))))
(defun scale (scale-factor drawing) (define-transform translate (delta-x delta-y)
(defun scale-points (points) :x-transform (+ delta-x x)
(let ((new-points (copy-seq points))) :y-transform (+ delta-y y))
(dotimes (i (length points))
(setf (aref new-points i) (define-transform scale (scale-factor)
(* scale-factor (aref new-points i)))) :x-transform (* scale-factor x)
new-points)) :y-transform (* scale-factor y)
(defun scale-primitive (primitive) :scalar-transform (* scale-factor s))
(typecase primitive
(line (make-line :points (scale-points (line-points primitive))))
(circle
(make-circle
:radius (* scale-factor (circle-radius primitive))
:centre (scale-points (circle-centre primitive))))
(polygon
(make-polygon
:points (scale-points (polygon-points primitive))))))
(mapcar #'scale-primitive drawing))
(defun overlay (&rest drawings) (defun overlay (&rest drawings)
(apply #'append drawings)) (apply #'append drawings))