/[cl-cairo2]/surface.lisp
ViewVC logotype

Contents of /surface.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 20 - (show annotations)
Wed May 28 01:34:00 2008 UTC (5 years, 10 months ago) by tpapp
File size: 4972 byte(s)
added image-surface-get-data and minor fixes by Johann Korndoerfer
1 (in-package :cl-cairo2)
2 ;;;;
3 ;;;; Notes
4 ;;;;
5 ;;;; image-surface-get-stride is not implemented, as I don't see how
6 ;;;; it would be used (ask if you need it).
7 ;;;;
8 ;;;; functions that write to/read from streams are not implemented
9
10
11
12 ;;;;
13 ;;;; class surface
14 ;;;;
15
16 (defgeneric get-width (object)
17 (:documentation "return the width of an object"))
18
19 (defgeneric get-height (object)
20 (:documentation "return the height of an object"))
21
22 (defgeneric pixel-based-p (object)
23 (:documentation "return t iff the object uses a pixel-based backend"))
24
25 (defclass surface ()
26 ((pointer :initarg :pointer :initform nil)
27 (width :initarg :width :reader get-width)
28 (height :initarg :height :reader get-height)
29 (pixel-based-p :initarg :pixel-based-p :reader pixel-based-p)))
30
31 (defmacro with-alive-surface ((surface pointer) &body body)
32 "Execute body with pointer pointing to cairo surface, if nil,
33 signal error."
34 (let ((pointer-name pointer))
35 `(with-slots ((,pointer-name pointer)) ,surface
36 (if ,pointer-name
37 (progn ,@body)
38 (warn "surface is not alive")))))
39
40 (defmacro check-surface-pointer-status (pointer &body body)
41 "Check status of surface after executing body."
42 (let ((status (gensym)))
43 `(multiple-value-prog1 (progn ,@body)
44 (let ((,status
45 (lookup-cairo-enum (cairo_surface_status ,pointer) table-status)))
46 (unless (eq ,status 'status-success)
47 (warn "function returned with status ~a." ,status))))))
48
49 (defmacro with-surface ((surface pointer) &body body)
50 "Execute body with pointer pointing to surface, and check status."
51 `(with-alive-surface (,surface ,pointer)
52 (check-surface-pointer-status ,pointer
53 ,@body)))
54
55 (defun new-surface-with-check (pointer width height &optional (pixel-based-p nil))
56 "Check if the creation of new surface was successful, if so, return new class."
57 (let ((surface (make-instance 'surface :width width :height height
58 :pixel-based-p pixel-based-p)))
59 (check-surface-pointer-status pointer
60 (setf (slot-value surface 'pointer) pointer)
61 ;; register finalizer
62 (tg:finalize surface #'(lambda () (cairo_surface_destroy pointer)))
63 ;; return surface
64 surface)))
65
66 (defmethod destroy ((object surface))
67 (with-alive-surface (object pointer)
68 (cairo_surface_destroy pointer)
69 (setf pointer nil))
70 ;; deregister finalizer
71 (tg:cancel-finalization object))
72
73 ;;;;
74 ;;;; Macros to create surfaces (that are written into files) and
75 ;;;; direct creation of contexts for these surfaces.
76 ;;;;
77
78 (defmacro define-create-surface (type)
79 "Define the function create-<type>-surface."
80 `(defun ,(prepend-intern "create-" type :replace-dash nil :suffix "-surface")
81 (filename width height)
82 (new-surface-with-check
83 (,(prepend-intern "cairo_" type :replace-dash nil
84 :suffix "_surface_create")
85 filename width height)
86 width height)))
87
88 ;;;;
89 ;;;; PDF surface
90 ;;;;
91
92 (define-create-surface pdf)
93
94 ;;;;
95 ;;;; PostScript surface
96 ;;;;
97
98 (define-create-surface ps)
99
100 ;;;;
101 ;;;; SVG surface
102 ;;;;
103
104 (define-create-surface svg)
105
106 ;;;;
107 ;;;; image surface
108 ;;;;
109
110 (defun create-image-surface (format width height)
111 (new-surface-with-check
112 (cairo_image_surface_create (lookup-enum format table-format)
113 width height)
114 width height t))
115
116 (defun get-bytes-per-pixel (format)
117 (case format
118 (format-argb32 4)
119 (format-rgb24 3)
120 (format-a8 1)
121 (otherwise (error (format nil "unknown format: ~a" format))))) ;todo: how does format-a1 fit in here?
122
123 (defun image-surface-get-data (surface)
124 (with-surface (surface pointer)
125 (let* ((width (image-surface-get-width surface))
126 (height (image-surface-get-height surface))
127 (bytes-per-pixel (get-bytes-per-pixel (image-surface-get-format surface)))
128 (buffer (make-array (* width height bytes-per-pixel) :element-type '(unsigned-byte 8) :fill-pointer 0))
129 (data (cairo_image_surface_get_data pointer)))
130 (loop for i from 0 below (* width height bytes-per-pixel) do
131 (vector-push-extend (cffi:mem-ref data :uint8 i) buffer))
132 buffer)))
133
134
135 (defun image-surface-get-format (surface)
136 (with-surface (surface pointer)
137 (lookup-cairo-enum (cairo_image_surface_get_format pointer) table-format)))
138
139 (defun image-surface-get-width (surface)
140 (with-surface (surface pointer)
141 (cairo_image_surface_get_width pointer)))
142
143 (defun image-surface-get-height (surface)
144 (with-surface (surface pointer)
145 (cairo_image_surface_get_height pointer)))
146
147 ;;;;
148 ;;;; PNG surfaces
149 ;;;;
150
151 (defun image-surface-create-from-png (filename)
152 (let ((surface
153 (new-surface-with-check (cairo_image_surface_create_from_png filename)
154 0 0)))
155 (with-slots (width height) surface
156 (setf width (image-surface-get-width surface)
157 height (image-surface-get-height surface))
158 surface)))
159
160 (defun surface-write-to-png (surface filename)
161 (with-surface (surface pointer)
162 (cairo_surface_write_to_png pointer filename)))
163

  ViewVC Help
Powered by ViewVC 1.1.5