aesthetic.computer
Monorepo for Aesthetic.Computer
aesthetic.computer
1;;; Graphics primitives — wipe, ink, plot, line, box, circle
2
3(in-package :ac-native.graph)
4
5(defstruct graph
6 "Immediate-mode 2D graphics context."
7 (fb nil) ; ac-native.framebuffer:framebuffer
8 (screen nil) ; ac-native.framebuffer:framebuffer
9 (ink-color (make-color :r 255 :g 255 :b 255 :a 255)))
10
11(defun graph-wipe (g color)
12 "Clear the screen with COLOR."
13 (fb-clear (graph-fb g) (color-pack-argb32 color)))
14
15(defun graph-ink (g color)
16 "Set the current drawing color."
17 (setf (graph-ink-color g) color))
18
19(defun graph-plot (g x y)
20 "Plot a single pixel at (X, Y) using the current ink."
21 (let ((c (graph-ink-color g)))
22 (if (= (color-a c) 255)
23 (fb-put-pixel (graph-fb g) x y (color-pack-argb32 c))
24 (fb-blend-pixel (graph-fb g) x y c))))
25
26(defun graph-line (g x0 y0 x1 y1)
27 "Draw a line from (X0,Y0) to (X1,Y1) using Bresenham's algorithm."
28 (declare (optimize (speed 3) (safety 1))
29 (type fixnum x0 y0 x1 y1))
30 (let ((dx (abs (- x1 x0)))
31 (dy (- (abs (- y1 y0))))
32 (sx (if (< x0 x1) 1 -1))
33 (sy (if (< y0 y1) 1 -1)))
34 (let ((err (+ dx dy))
35 (x x0) (y y0))
36 (declare (type fixnum err x y))
37 (loop
38 (graph-plot g x y)
39 (when (and (= x x1) (= y y1)) (return))
40 (let ((e2 (* 2 err)))
41 (when (>= e2 dy)
42 (incf err dy)
43 (incf x sx))
44 (when (<= e2 dx)
45 (incf err dx)
46 (incf y sy)))))))
47
48(defun graph-box (g x y w h &optional (filled t))
49 "Draw a rectangle. If FILLED, fill it; otherwise draw outline."
50 (declare (optimize (speed 3) (safety 1))
51 (type fixnum x y w h))
52 (let ((c (graph-ink-color g))
53 (fb (graph-fb g)))
54 (if filled
55 ;; Filled box — hot path, optimize
56 (let ((c32 (color-pack-argb32 c))
57 (opaque (= (color-a c) 255)))
58 (dotimes (row h)
59 (let ((py (+ y row)))
60 (when (and (>= py 0) (< py (fb-height fb)))
61 (dotimes (col w)
62 (let ((px (+ x col)))
63 (when (and (>= px 0) (< px (fb-width fb)))
64 (if opaque
65 (fb-put-pixel fb px py c32)
66 (fb-blend-pixel fb px py c)))))))))
67 ;; Outline
68 (progn
69 (graph-line g x y (+ x w -1) y)
70 (graph-line g x (+ y h -1) (+ x w -1) (+ y h -1))
71 (graph-line g x y x (+ y h -1))
72 (graph-line g (+ x w -1) y (+ x w -1) (+ y h -1))))))
73
74(defun graph-circle (g cx cy r &optional (filled t))
75 "Draw a circle using the midpoint algorithm."
76 (declare (optimize (speed 3) (safety 1))
77 (type fixnum cx cy r))
78 (if filled
79 ;; Filled circle — draw horizontal spans
80 (let ((x 0) (y r) (d (- 1 r)))
81 (declare (type fixnum x y d))
82 (loop while (<= x y) do
83 (graph-line g (- cx x) (+ cy y) (+ cx x) (+ cy y))
84 (graph-line g (- cx x) (- cy y) (+ cx x) (- cy y))
85 (graph-line g (- cx y) (+ cy x) (+ cx y) (+ cy x))
86 (graph-line g (- cx y) (- cy x) (+ cx y) (- cy x))
87 (incf x)
88 (if (< d 0)
89 (incf d (+ (* 2 x) 1))
90 (progn (decf y) (incf d (+ (* 2 (- x y)) 1))))))
91 ;; Outline circle
92 (let ((x 0) (y r) (d (- 1 r)))
93 (declare (type fixnum x y d))
94 (loop while (<= x y) do
95 (graph-plot g (+ cx x) (+ cy y))
96 (graph-plot g (- cx x) (+ cy y))
97 (graph-plot g (+ cx x) (- cy y))
98 (graph-plot g (- cx x) (- cy y))
99 (graph-plot g (+ cx y) (+ cy x))
100 (graph-plot g (- cx y) (+ cy x))
101 (graph-plot g (+ cx y) (- cy x))
102 (graph-plot g (- cx y) (- cy x))
103 (incf x)
104 (if (< d 0)
105 (incf d (+ (* 2 x) 1))
106 (progn (decf y) (incf d (+ (* 2 (- x y)) 1))))))))