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