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

Contents of /surface.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 6 - (hide 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 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 6 (defclass surface () ((pointer :initarg :pointer :initform nil)))
17 tpapp 1
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 tpapp 6 ;;;; Macros to create surfaces (that are written into files) and
56     ;;;; direct creation of contexts for these surfaces.
57 tpapp 1 ;;;;
58    
59 tpapp 6 (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 tpapp 1
68 tpapp 6 (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 tpapp 1
82 tpapp 6
83 tpapp 1 ;;;;
84 tpapp 6 ;;;; PDF surface
85     ;;;;
86    
87     (define-create-surface pdf)
88     (define-create-context pdf)
89    
90     ;;;;
91 tpapp 1 ;;;; PostScript surface
92     ;;;;
93    
94 tpapp 6 (define-create-surface ps)
95     (define-create-context ps)
96 tpapp 1
97 tpapp 6 ;;;;
98     ;;;; SVG surface
99     ;;;;
100 tpapp 1
101 tpapp 6 (define-create-surface svg)
102     (define-create-context svg)
103    
104 tpapp 1 ;;;;
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