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

Contents of /surface.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 6 - (show annotations)
Thu Jun 21 09:07:42 2007 UTC (6 years, 10 months ago) by tpapp
File size: 4366 byte(s)
added svg and xlib support
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 (defclass surface () ((pointer :initarg :pointer :initform nil)))
17
18 (defmacro with-alive-surface ((surface pointer) &body body)
19 "Execute body with pointer pointing to cairo surface, if nil,
20 signal error."
21 (let ((pointer-name pointer))
22 `(with-slots ((,pointer-name pointer)) ,surface
23 (if ,pointer-name
24 (progn ,@body)
25 (warn "surface is not alive")))))
26
27 (defmacro check-surface-pointer-status (pointer &body body)
28 "Check status of surface after executing body."
29 (let ((status (gensym)))
30 `(multiple-value-prog1 (progn ,@body)
31 (let ((,status
32 (lookup-cairo-enum (cairo_surface_status ,pointer) table-status)))
33 (unless (eq ,status 'success)
34 (warn "function returned with status ~a." ,status))))))
35
36 (defmacro with-surface ((surface pointer) &body body)
37 "Execute body with pointer pointing to context, and check status."
38 `(with-alive-surface (,surface ,pointer)
39 (check-surface-pointer-status ,pointer
40 ,@body)))
41
42 (defun new-surface-with-check (pointer)
43 "Check if the creation of new surface was successful, if so, return new class."
44 (let ((surface (make-instance 'surface)))
45 (check-surface-pointer-status pointer
46 (setf (slot-value surface 'pointer) pointer)
47 surface)))
48
49 (defmethod destroy ((object surface))
50 (with-alive-surface (object pointer)
51 (cairo_surface_destroy pointer)
52 (setf pointer nil)))
53
54 ;;;;
55 ;;;; Macros to create surfaces (that are written into files) and
56 ;;;; direct creation of contexts for these surfaces.
57 ;;;;
58
59 (defmacro define-create-surface (type)
60 `(export
61 (defun ,(prepend-intern "create-" type :replace-dash nil :suffix "-surface")
62 (filename width-in-points height-in-points)
63 (new-surface-with-check
64 (,(prepend-intern "cairo_" type :replace-dash nil
65 :suffix "_surface_create")
66 filename width-in-points height-in-points)))))
67
68 (defmacro define-create-context (type)
69 `(export
70 (defun ,(prepend-intern "create-" type :replace-dash nil :suffix "-context")
71 (filename width-in-points height-in-points)
72 "Create a surface, then a context for a file, then
73 destroy (dereference) the surface. The user only needs to
74 destroy the context when done."
75 (let* ((surface (,(prepend-intern "create-"
76 type :replace-dash nil :suffix "-surface")
77 filename width-in-points height-in-points))
78 (context (create-context surface)))
79 (destroy surface)
80 context))))
81
82
83 ;;;;
84 ;;;; PDF surface
85 ;;;;
86
87 (define-create-surface pdf)
88 (define-create-context pdf)
89
90 ;;;;
91 ;;;; PostScript surface
92 ;;;;
93
94 (define-create-surface ps)
95 (define-create-context ps)
96
97 ;;;;
98 ;;;; SVG surface
99 ;;;;
100
101 (define-create-surface svg)
102 (define-create-context svg)
103
104 ;;;;
105 ;;;; image surface
106 ;;;;
107
108 (export
109 (defun create-image-surface (format width height)
110 (new-surface-with-check
111 (cairo_image_surface_create (lookup-enum format table-format)
112 width height))))
113
114 (export
115 (defun image-surface-get-format (surface)
116 (with-surface (surface pointer)
117 (lookup-cairo-enum (cairo_image_surface_get_format pointer) table-format))))
118
119 (export
120 (defun image-surface-get-width (surface)
121 (with-surface (surface pointer)
122 (cairo_image_surface_get_width pointer))))
123
124 (export
125 (defun image-surface-get-height (surface)
126 (with-surface (surface pointer)
127 (cairo_image_surface_get_height pointer))))
128
129 ;;;;
130 ;;;; PNG surfaces
131 ;;;;
132
133 (export
134 (defun image-surface-create-from-png (filename)
135 (new-surface-with-check (cairo_image_surface_create_from_png filename))))
136
137 (export
138 (defun surface-write-to-png (surface filename)
139 (with-surface (surface pointer)
140 (cairo_surface_write_to_png pointer filename))))
141
142 (export
143 (defmacro with-png-file ((filename format width height) &body body)
144 "Execute the body with context bound to a newly created png
145 file, and close it after executing body."
146 (let ((surface-name (gensym)))
147 `(let* ((,surface-name (create-image-surface ,format ,width ,height))
148 (*context* (create-context ,surface-name)))
149 (progn
150 ,@body
151 (surface-write-to-png ,surface-name ,filename)
152 (destroy ,surface-name)
153 (destroy *context*))))))

  ViewVC Help
Powered by ViewVC 1.1.5