commit b4d74d2ebcfef43c0d2fcb25b342f121791e5c06
parent 25e295bcb3df3888109fa1dae32b464bec6c9db1
Author: Lukas Henkel <lh@entf.net>
Date: Sat, 16 Dec 2023 14:03:19 +0100
Basic drawing API
Diffstat:
5 files changed, 309 insertions(+), 1 deletion(-)
diff --git a/draw/api.lisp b/draw/api.lisp
@@ -0,0 +1,46 @@
+(uiop:define-package #:net.entf.graphics/draw
+ (:use #:cl)
+ (:local-nicknames (#:p #:net.entf.graphics/draw/protocol))
+ (:export
+ #:*sheet*
+ #:with-sheet
+ #:*brush*
+ #:with-brush
+ #:fill-path
+ #:fill-rect
+ #:fill-circle))
+(in-package #:net.entf.graphics/draw)
+
+(eval-when (:load-toplevel)
+ (loop with proto-package = (find-package '#:net.entf.graphics/draw/protocol)
+ for symbol being the external-symbols of proto-package
+ for mine = (nth-value 1 (find-symbol (symbol-name symbol) *package*))
+ unless (eq mine :external)
+ do (import symbol)
+ and do (export symbol)))
+
+(defparameter *sheet* nil)
+
+(defmacro with-sheet ((sheet) &body body)
+ `(let ((*sheet* ,sheet))
+ ,@body))
+
+(defparameter *brush* nil)
+
+(defmacro with-brush ((brush) &body body)
+ `(let ((*brush* ,brush))
+ ,@body))
+
+(defun fill-path (path &key (sheet *sheet*) (brush *brush*))
+ (p:fill-path sheet brush path))
+
+(defun fill-rect (&key
+ (sheet *sheet*)
+ (brush *brush*)
+ (point (p:make-point 0 0))
+ (size (p:sheet-size sheet)))
+ (p:fill-rect sheet brush :size size :point point))
+
+(defun fill-circle (point radius
+ &key (sheet *sheet*) (brush *brush*))
+ (p:fill-circle sheet brush point radius))
diff --git a/draw/operations.lisp b/draw/operations.lisp
@@ -0,0 +1 @@
+(in-package #:net.entf.graphics/draw/protocol)
diff --git a/draw/package.lisp b/draw/package.lisp
@@ -0,0 +1,35 @@
+(defpackage #:net.entf.graphics/draw/protocol
+ (:use #:cl)
+ (:export
+ #:pixel-p
+ #:pixel
+ #:color
+ #:make-color
+ #:point
+ #:point-width
+ #:point-height
+ #:make-point
+ #:point-x+
+ #:point-x-
+ #:point-y+
+ #:point-y-
+ #:size
+ #:size-width
+ #:size-height
+ #:sheet
+ #:sheet-size
+ #:sheet-width
+ #:sheet-height
+ #:brush
+ #:solid-color-brush
+ #:make-solid-color-brush
+ #:path
+ #:make-path
+ #:straight-line
+ #:make-straight-line
+ #:arc
+ #:make-arc
+ #:with-path
+ #:fill-path
+ #:fill-rect
+ #:fill-circle))
diff --git a/draw/protocol.lisp b/draw/protocol.lisp
@@ -0,0 +1,212 @@
+(in-package #:net.entf.graphics/draw/protocol)
+
+(defparameter *printing-recursively?* nil)
+
+(defun pixel-p (value)
+ (and (>= value 0)
+ (<= value 1)))
+
+(deftype pixel ()
+ '(satisfies pixel-p))
+
+(defclass color ()
+ ((r
+ :initarg :r
+ :reader color-r)
+ (g
+ :initarg :g
+ :reader color-g)
+ (b
+ :initarg :b
+ :reader color-b)
+ (a
+ :initarg :a
+ :reader color-a)))
+
+(defun make-color (r g b &optional (a 1))
+ (check-type r pixel)
+ (check-type g pixel)
+ (check-type b pixel)
+ (check-type a pixel)
+ (make-instance 'color :r r :g g :b b :a a))
+
+(defmethod print-object ((object color) stream)
+ (with-slots (r g b a)
+ object
+ (print-unreadable-object (object stream :type t)
+ (format stream "~:[~*~;~2,'0X~]~2,'0X~2,'0X~2,'0X" (= a 1)
+ (round (* a 255))
+ (round (* r 255))
+ (round (* g 255))
+ (round (* b 255))))))
+
+(defclass point ()
+ ((x
+ :initarg :x
+ :reader point-x)
+ (y
+ :initarg :y
+ :reader point-y)))
+
+(defun make-point (x y)
+ (make-instance 'point :x x :y y))
+
+(defmethod print-object ((object point) stream)
+ (with-slots (x y)
+ object
+ (if *printing-recursively?*
+ (format stream "~A/~A" x y)
+ (print-unreadable-object (object stream :type t)
+ (format stream "~A/~A" x y)))))
+
+(defmethod point-x+ ((point point) value)
+ (make-point (+ (point-x point) value)
+ (point-y point)))
+
+(defmethod point-x- ((point point) value)
+ (make-point (- (point-x point) value)
+ (point-y point)))
+
+(defmethod point-y+ ((point point) value)
+ (make-point (point-x point)
+ (+ (point-y point) value)))
+
+(defmethod point-y- ((point point) value)
+ (make-point (point-x point)
+ (- (point-y point) value)))
+
+(defclass size ()
+ ((width
+ :initarg :width
+ :reader size-width)
+ (height
+ :initarg :height
+ :reader size-height)))
+
+(defun make-size (width height)
+ (make-instance 'size :width width :height height))
+
+(defmethod print-object ((object size) stream)
+ (with-slots (width height)
+ object
+ (if *printing-recursively?*
+ (format stream "~A/~A" width height)
+ (print-unreadable-object (object stream :type t)
+ (format stream "~A/~A" width height)))))
+
+(defclass sheet ()
+ ((size
+ :initarg size
+ :reader sheet-size)))
+
+(defmethod sheet-width ((sheet sheet))
+ (size-width (sheet-size sheet)))
+
+(defmethod sheet-height ((sheet sheet))
+ (size-height (sheet-size sheet)))
+
+(defclass brush ()
+ ())
+
+(defclass solid-color-brush (brush)
+ ((color
+ :initarg :color)))
+
+(defun make-solid-color-brush (color)
+ (make-instance 'solid-color-brush :color color))
+
+(defclass path ()
+ ((lines
+ :initarg :lines
+ :initform ())))
+
+(defun make-path (&optional lines)
+ (make-instance 'path :lines lines))
+
+(defmethod print-object ((object path) stream)
+ (print-unreadable-object (object stream :type t)
+ (with-slots (lines)
+ object
+ (let ((*printing-recursively?* t))
+ (format stream "~{~A~^ ~}" lines)))))
+
+(defclass line ()
+ ((start
+ :initarg :start
+ :reader line-start)
+ (end
+ :initarg :end
+ :reader line-end)))
+
+(defclass straight-line (line)
+ ())
+
+(defun make-straight-line (start end)
+ (make-instance 'straight-line :start start :end end))
+
+(defmethod print-object ((object straight-line) stream)
+ (with-slots (start end)
+ object
+ (if *printing-recursively?*
+ (format stream "~A⭢~A" start end)
+ (print-unreadable-object (object stream)
+ (format stream "~A⭢~A" start end)))))
+
+(defclass arc (line)
+ ())
+
+(defun make-arc (start end)
+ (make-instance 'arc :start start :end end))
+
+(defmethod print-object ((object arc) stream)
+ (with-slots (start end)
+ object
+ (if *printing-recursively?*
+ (format stream "~A⤻~A" start end)
+ (print-unreadable-object (object stream)
+ (format stream "~A⤻~A" start end)))))
+
+(defmacro with-path ((start) &body body)
+ (let ((path (gensym "PATH"))
+ (current (gensym "CURRENT"))
+ (lines (gensym "LINES")))
+ `(let ((,path (make-path))
+ (,current ,start))
+ (symbol-macrolet ((,lines (slot-value ,path ','lines)))
+ (labels ((line-to (to)
+ (push (make-straight-line ,current to) ,lines)
+ (setf ,current to))
+ (arc-to (to)
+ (push (make-arc ,current to) ,lines)
+ (setf ,current to)))
+ ,@body)
+ (setf ,lines (nreverse ,lines)))
+ ,path)))
+
+(defgeneric fill-path (sheet brush path))
+
+(defgeneric fill-rect (sheet brush &key point size)
+ (:documentation "Fill area on SHEET denoted by POINT and SIZE with BRUSH.
+
+ When not given, POINT will refer to the top left of the SHEET.
+ When not given, SIZE will refer to the size of the SHEET.")
+ (:method ((sheet sheet) (brush brush) &key (point (make-point 0 0)) (size (sheet-size sheet)))
+ (declare (type point point)
+ (type size size))
+ (fill-path sheet brush (let ((right-x (+ (point-x point)
+ (size-width size)))
+ (bottom-y (+ (point-y point)
+ (size-height size))))
+ (with-path (point)
+ (line-to (make-point right-x (point-y point)))
+ (line-to (make-point right-x bottom-y))
+ (line-to (make-point (point-x point) bottom-y)))))))
+
+(defgeneric fill-circle (sheet brush point radius)
+ (:documentation "Full circle on SHEET with BRUSH, with it's center at POINT spanning the given RADIUS.")
+ (:method ((sheet sheet) (brush brush) point radius)
+ (fill-path sheet brush (with-path ((point-x- point radius))
+ (arc-to (point-y- point radius))
+ (arc-to (point-x+ point radius))
+ (arc-to (point-y+ point radius))
+ (arc-to (point-y- point radius))))))
diff --git a/net.entf.graphics.asd b/net.entf.graphics.asd
@@ -1,5 +1,6 @@
(defsystem "net.entf.graphics"
- :depends-on ("net.entf.graphics/window"))
+ :depends-on ("net.entf.graphics/window"
+ "net.entf.graphics/draw"))
(defsystem "net.entf.graphics/window"
:pathname #P"window/"
@@ -24,3 +25,16 @@
:depends-on ("package" "protocols"))
(:module "wayland-protocols"
:components ((:static-file "xdg-decoration-unstable-v1.xml")))))
+
+(defsystem "net.entf.graphics/draw"
+ :pathname #P"draw/"
+ :depends-on ("net.entf.graphics/draw/protocol")
+ :components ((:file "api")))
+
+(defsystem "net.entf.graphics/draw/protocol"
+ :pathname #P"draw/"
+ :components ((:file "package")
+ (:file "operations"
+ :depends-on ("package"))
+ (:file "protocol"
+ :depends-on ("package"))))
