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

Contents of /surface.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5