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

Contents of /surface.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 20 - (hide 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 tpapp 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 tpapp 17 (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 tpapp 13 (defclass surface ()
26     ((pointer :initarg :pointer :initform nil)
27     (width :initarg :width :reader get-width)
28 tpapp 17 (height :initarg :height :reader get-height)
29     (pixel-based-p :initarg :pixel-based-p :reader pixel-based-p)))
30 tpapp 1
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 tpapp 8 (unless (eq ,status 'status-success)
47 tpapp 1 (warn "function returned with status ~a." ,status))))))
48    
49     (defmacro with-surface ((surface pointer) &body body)
50 tpapp 17 "Execute body with pointer pointing to surface, and check status."
51 tpapp 1 `(with-alive-surface (,surface ,pointer)
52     (check-surface-pointer-status ,pointer
53     ,@body)))
54    
55 tpapp 17 (defun new-surface-with-check (pointer width height &optional (pixel-based-p nil))
56 tpapp 1 "Check if the creation of new surface was successful, if so, return new class."
57 tpapp 17 (let ((surface (make-instance 'surface :width width :height height
58     :pixel-based-p pixel-based-p)))
59 tpapp 1 (check-surface-pointer-status pointer
60     (setf (slot-value surface 'pointer) pointer)
61 tpapp 7 ;; register finalizer
62 tpapp 17 (tg:finalize surface #'(lambda () (cairo_surface_destroy pointer)))
63 tpapp 7 ;; return surface
64 tpapp 1 surface)))
65    
66     (defmethod destroy ((object surface))
67     (with-alive-surface (object pointer)
68     (cairo_surface_destroy pointer)
69 tpapp 7 (setf pointer nil))
70     ;; deregister finalizer
71 tpapp 17 (tg:cancel-finalization object))
72 tpapp 1
73     ;;;;
74 tpapp 6 ;;;; Macros to create surfaces (that are written into files) and
75     ;;;; direct creation of contexts for these surfaces.
76 tpapp 1 ;;;;
77    
78 tpapp 6 (defmacro define-create-surface (type)
79 tpapp 13 "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 tpapp 1
88     ;;;;
89 tpapp 6 ;;;; PDF surface
90     ;;;;
91    
92     (define-create-surface pdf)
93    
94     ;;;;
95 tpapp 1 ;;;; PostScript surface
96     ;;;;
97    
98 tpapp 6 (define-create-surface ps)
99 tpapp 1
100 tpapp 6 ;;;;
101     ;;;; SVG surface
102     ;;;;
103 tpapp 1
104 tpapp 6 (define-create-surface svg)
105    
106 tpapp 1 ;;;;
107     ;;;; image surface
108     ;;;;
109    
110 tpapp 13 (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 tpapp 17 width height t))
115 tpapp 1
116 tpapp 20 (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 tpapp 13 (defun image-surface-get-format (surface)
136     (with-surface (surface pointer)
137     (lookup-cairo-enum (cairo_image_surface_get_format pointer) table-format)))
138 tpapp 1
139 tpapp 13 (defun image-surface-get-width (surface)
140     (with-surface (surface pointer)
141     (cairo_image_surface_get_width pointer)))
142 tpapp 1
143 tpapp 13 (defun image-surface-get-height (surface)
144     (with-surface (surface pointer)
145     (cairo_image_surface_get_height pointer)))
146 tpapp 1
147     ;;;;
148     ;;;; PNG surfaces
149     ;;;;
150    
151 tpapp 13 (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 tpapp 1
160 tpapp 13 (defun surface-write-to-png (surface filename)
161     (with-surface (surface pointer)
162     (cairo_surface_write_to_png pointer filename)))
163 tpapp 1

  ViewVC Help
Powered by ViewVC 1.1.5