protocol.lisp (6125B)
1 (in-package #:net.entf.graphics/draw/protocol) 2 3 (defparameter *printing-recursively?* nil) 4 5 (defun pixel-p (value) 6 (and (>= value 0) 7 (<= value 1))) 8 9 (deftype pixel () 10 '(satisfies pixel-p)) 11 12 (defclass color () 13 ((r 14 :initarg :r 15 :reader color-r) 16 (g 17 :initarg :g 18 :reader color-g) 19 (b 20 :initarg :b 21 :reader color-b) 22 (a 23 :initarg :a 24 :reader color-a))) 25 26 (defun make-color (r g b &optional (a 1)) 27 (check-type r pixel) 28 (check-type g pixel) 29 (check-type b pixel) 30 (check-type a pixel) 31 (make-instance 'color :r r :g g :b b :a a)) 32 33 (defmethod print-object ((object color) stream) 34 (with-slots (r g b a) 35 object 36 (print-unreadable-object (object stream :type t) 37 (format stream "~:[~*~;~2,'0X~]~2,'0X~2,'0X~2,'0X" (= a 1) 38 (round (* a 255)) 39 (round (* r 255)) 40 (round (* g 255)) 41 (round (* b 255)))))) 42 43 (defclass point () 44 ((x 45 :initarg :x 46 :reader point-x) 47 (y 48 :initarg :y 49 :reader point-y))) 50 51 (defun make-point (x y) 52 (make-instance 'point :x x :y y)) 53 54 (defmethod print-object ((object point) stream) 55 (with-slots (x y) 56 object 57 (if *printing-recursively?* 58 (format stream "~A/~A" x y) 59 (print-unreadable-object (object stream :type t) 60 (format stream "~A/~A" x y))))) 61 62 (defmethod point-x+ ((point point) value) 63 (make-point (+ (point-x point) value) 64 (point-y point))) 65 66 (defmethod point-x- ((point point) value) 67 (make-point (- (point-x point) value) 68 (point-y point))) 69 70 (defmethod point-y+ ((point point) value) 71 (make-point (point-x point) 72 (+ (point-y point) value))) 73 74 (defmethod point-y- ((point point) value) 75 (make-point (point-x point) 76 (- (point-y point) value))) 77 78 (defclass size () 79 ((width 80 :initarg :width 81 :reader size-width) 82 (height 83 :initarg :height 84 :reader size-height))) 85 86 (defun make-size (width height) 87 (make-instance 'size :width width :height height)) 88 89 (defmethod print-object ((object size) stream) 90 (with-slots (width height) 91 object 92 (if *printing-recursively?* 93 (format stream "~A/~A" width height) 94 (print-unreadable-object (object stream :type t) 95 (format stream "~A/~A" width height))))) 96 97 (defclass sheet () 98 ((size 99 :initarg size 100 :reader sheet-size))) 101 102 (defmethod sheet-width ((sheet sheet)) 103 (size-width (sheet-size sheet))) 104 105 (defmethod sheet-height ((sheet sheet)) 106 (size-height (sheet-size sheet))) 107 108 (defclass brush () 109 ()) 110 111 (defclass solid-color-brush (brush) 112 ((color 113 :initarg :color))) 114 115 (defun make-solid-color-brush (color) 116 (make-instance 'solid-color-brush :color color)) 117 118 (defclass path () 119 ((lines 120 :initarg :lines 121 :initform ()))) 122 123 (defun make-path (&optional lines) 124 (make-instance 'path :lines lines)) 125 126 (defmethod print-object ((object path) stream) 127 (print-unreadable-object (object stream :type t) 128 (with-slots (lines) 129 object 130 (let ((*printing-recursively?* t)) 131 (format stream "~{~A~^ ~}" lines))))) 132 133 (defclass line () 134 ((start 135 :initarg :start 136 :reader line-start) 137 (end 138 :initarg :end 139 :reader line-end))) 140 141 (defclass straight-line (line) 142 ()) 143 144 (defun make-straight-line (start end) 145 (make-instance 'straight-line :start start :end end)) 146 147 (defmethod print-object ((object straight-line) stream) 148 (with-slots (start end) 149 object 150 (if *printing-recursively?* 151 (format stream "~A⭢~A" start end) 152 (print-unreadable-object (object stream) 153 (format stream "~A⭢~A" start end))))) 154 155 (defclass arc (line) 156 ()) 157 158 (defun make-arc (start end) 159 (make-instance 'arc :start start :end end)) 160 161 (defmethod print-object ((object arc) stream) 162 (with-slots (start end) 163 object 164 (if *printing-recursively?* 165 (format stream "~A⤻~A" start end) 166 (print-unreadable-object (object stream) 167 (format stream "~A⤻~A" start end))))) 168 169 (defmacro with-path ((start) &body body) 170 (let ((path (gensym "PATH")) 171 (current (gensym "CURRENT")) 172 (lines (gensym "LINES"))) 173 `(let ((,path (make-path)) 174 (,current ,start)) 175 (symbol-macrolet ((,lines (slot-value ,path ','lines))) 176 (labels ((line-to (to) 177 (push (make-straight-line ,current to) ,lines) 178 (setf ,current to)) 179 (arc-to (to) 180 (push (make-arc ,current to) ,lines) 181 (setf ,current to))) 182 ,@body) 183 (setf ,lines (nreverse ,lines))) 184 ,path))) 185 186 (defgeneric fill-path (sheet brush path)) 187 188 (defgeneric fill-rect (sheet brush &key point size) 189 (:documentation "Fill area on SHEET denoted by POINT and SIZE with BRUSH. 190 191 When not given, POINT will refer to the top left of the SHEET. 192 When not given, SIZE will refer to the size of the SHEET.") 193 (:method ((sheet sheet) (brush brush) &key (point (make-point 0 0)) (size (sheet-size sheet))) 194 (declare (type point point) 195 (type size size)) 196 (fill-path sheet brush (let ((right-x (+ (point-x point) 197 (size-width size))) 198 (bottom-y (+ (point-y point) 199 (size-height size)))) 200 (with-path (point) 201 (line-to (make-point right-x (point-y point))) 202 (line-to (make-point right-x bottom-y)) 203 (line-to (make-point (point-x point) bottom-y))))))) 204 205 (defgeneric fill-circle (sheet brush point radius) 206 (:documentation "Full circle on SHEET with BRUSH, with it's center at POINT spanning the given RADIUS.") 207 (:method ((sheet sheet) (brush brush) point radius) 208 (fill-path sheet brush (with-path ((point-x- point radius)) 209 (arc-to (point-y- point radius)) 210 (arc-to (point-x+ point radius)) 211 (arc-to (point-y+ point radius)) 212 (arc-to (point-y- point radius))))))