|
Revision 3656, 1.5 kB
(checked in by ksprotte, 4 months ago)
|
whitespace cleanup
|
| Line | |
|---|
| 1 |
(in-package :bos.web) |
|---|
| 2 |
|
|---|
| 3 |
(enable-interpol-syntax) |
|---|
| 4 |
|
|---|
| 5 |
(defclass contract-image-handler (object-handler) |
|---|
| 6 |
() |
|---|
| 7 |
(:default-initargs :class 'contract)) |
|---|
| 8 |
|
|---|
| 9 |
(defmethod handle-object ((handler contract-image-handler) contract) |
|---|
| 10 |
"Create and return a GD image of the contract. The returned |
|---|
| 11 |
rectangular image will have the size of the contracts' bounding box. |
|---|
| 12 |
All square meters will have yellow color, the background will be transparent." |
|---|
| 13 |
(destructuring-bind (left top width height) (contract-bounding-box contract) |
|---|
| 14 |
(cl-gd:with-image* (width height) |
|---|
| 15 |
(setf (cl-gd:transparent-color) (cl-gd:allocate-color 0 0 0)) |
|---|
| 16 |
;; We manipulate pixels in a temporary array which is copied to the GD image as |
|---|
| 17 |
;; a whole for performance reasons. The FFI is way too slow to manipulate individual pixels. |
|---|
| 18 |
(let ((work-array (make-array (list width height) :element-type 'fixnum :initial-element 0)) |
|---|
| 19 |
(color (parse-color (or (second (decoded-handler-path handler)) "ffff00")))) |
|---|
| 20 |
(flet ((set-pixel (x y) |
|---|
| 21 |
(decf x left) |
|---|
| 22 |
(decf y top) |
|---|
| 23 |
(setf (aref work-array x y) color))) |
|---|
| 24 |
(dolist (m2 (contract-m2s contract)) |
|---|
| 25 |
(set-pixel (m2-x m2) (m2-y m2)))) |
|---|
| 26 |
(cl-gd:do-rows (y) |
|---|
| 27 |
(cl-gd:do-pixels-in-row (x) |
|---|
| 28 |
(setf (cl-gd:raw-pixel) (aref work-array x y))))) |
|---|
| 29 |
(emit-image-to-browser cl-gd:*default-image* :png :cache-sticky t)))) |
|---|
| 30 |
|
|---|
| 31 |
(defmethod handle-object ((handler contract-image-handler) (contract null)) |
|---|
| 32 |
(error "no contract found")) |
|---|
