From 24df86fa44331d79051d215dc9340c846fecba6b Mon Sep 17 00:00:00 2001
From: Camden Dixie O'Brien <cdo@wip.sh>
Date: Thu, 29 May 2025 01:14:30 +0100
Subject: [PATCH] Create simple, purely functional drawing API

---
 drawing.lisp | 65 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 65 insertions(+)
 create mode 100644 drawing.lisp

diff --git a/drawing.lisp b/drawing.lisp
new file mode 100644
index 0000000..a1515e8
--- /dev/null
+++ b/drawing.lisp
@@ -0,0 +1,65 @@
+(defstruct line points)
+(defstruct circle radius centre)
+(defstruct polygon points)
+
+(defun line (start-x start-y end-x end-y)
+  (list (make-line :points (vector start-x start-y end-x end-y))))
+
+(defun circle (radius centre-x centre-y)
+  (list (make-circle :radius radius :centre (vector centre-x centre-y))))
+
+(defun rectangle (left-x bottom-y width height)
+  (let ((right-x (+ left-x width))
+		(top-y (+ bottom-y height)))
+	(list (make-polygon
+           :points (vector left-x bottom-y
+						   left-x top-y
+						   right-x top-y
+						   right-x bottom-y)))))
+
+(defun centre-rectangle (centre-x centre-y width height)
+  (let ((left-x (- centre-x (/ width 2)))
+        (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))
+
+(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))
+
+(defun overlay (&rest drawings)
+  (apply #'append drawings))