[cl-cairo2-cvs] r17 - tutorial
tpapp at common-lisp.net
tpapp at common-lisp.net
Sun Mar 23 22:58:25 UTC 2008
Author: tpapp
Date: Sun Mar 23 17:58:24 2008
New Revision: 17
Added:
tutorial/hearts.png (contents, props changed)
Modified:
cl-cairo2.asd
context.lisp
package.lisp
surface.lisp
tutorial/Makefile
xlib-context.lisp
xlib-image-context.lisp
xlib.lisp
Log:
Several small changes:
- dependence on trivial-garbage for finalizer code
- fixes in examples/Makefile
Modified: cl-cairo2.asd
==============================================================================
--- cl-cairo2.asd (original)
+++ cl-cairo2.asd Sun Mar 23 17:58:24 2008
@@ -3,7 +3,7 @@
(in-package :cl-cairo2-asd)
-(defsystem cl-cairo2
+(defsystem #:cl-cairo2
:description "Cairo 1.4 bindings"
:version "0.3"
:author "Tamas K Papp"
@@ -26,4 +26,4 @@
(:file "gtk-context" :depends-on ("context")
:in-order-to ((load-op (feature :unix))
(compile-op (feature :unix)))))
- :depends-on (:cffi :cl-colors :cl-utilities))
+ :depends-on (:cffi :cl-colors :cl-utilities :trivial-garbage))
Modified: context.lisp
==============================================================================
--- context.lisp (original)
+++ context.lisp Sun Mar 23 17:58:24 2008
@@ -25,19 +25,28 @@
(defclass context ()
((pointer :initform nil :initarg :pointer)
(width :initarg :width :reader get-width)
- (height :initarg :height :reader get-height)))
+ (height :initarg :height :reader get-height)
+ (pixel-based-p :initarg :pixel-based-p :reader pixel-based-p)))
+
+(defmethod print-object ((obj context) stream)
+ "Print a canvas object."
+ (print-unreadable-object (obj stream :type t)
+ (with-slots (pointer width height pixel-based-p) obj
+ (format stream "pointer: ~a, width: ~a, height: ~a, pixel-based-p: ~a"
+ pointer width height pixel-based-p))))
(defun create-context (surface)
(with-surface (surface pointer)
(let ((context (make-instance 'context
:pointer (cairo_create pointer)
:width (get-width surface)
- :height (get-height surface))))
+ :height (get-height surface)
+ :pixel-based-p (pixel-based-p surface))))
;; register finalizer
(let ((context-pointer (slot-value context 'pointer)))
- (finalize context
- #'(lambda ()
- (cairo_destroy context-pointer))))
+ (tg:finalize context
+ #'(lambda ()
+ (cairo_destroy context-pointer))))
;; return context
context)))
@@ -47,7 +56,7 @@
(cairo_destroy pointer)
(setf pointer nil)))
;; deregister finalizer
- (cancel-finalization object))
+ (tg:cancel-finalization object))
(defgeneric sync (object)
(:documentation "Synchronize contents of the object with the
@@ -82,6 +91,18 @@
(defvar *context* nil "default cairo context")
+(defmacro with-png-file ((filename format width height) &body body)
+ "Execute the body with context bound to a newly created png
+ file, and close it after executing body."
+ (let ((surface-name (gensym)))
+ `(let* ((,surface-name (create-image-surface ,format ,width ,height))
+ (*context* (create-context ,surface-name)))
+ (progn
+ , at body
+ (surface-write-to-png ,surface-name ,filename)
+ (destroy ,surface-name)
+ (destroy *context*)))))
+
(defmacro with-context ((context pointer) &body body)
"Execute body with pointer pointing to context, and check status."
(let ((status (gensym))
@@ -260,6 +281,19 @@
;;;; convenience functions for creating contexts directly
;;;;
+(defmacro define-create-context (type)
+ `(defun ,(prepend-intern "create-" type :replace-dash nil :suffix "-context")
+ (filename width height)
+ "Create a surface, then a context for a file, then
+destroy (dereference) the surface. The user only needs to
+destroy the context when done."
+ (let* ((surface (,(prepend-intern "create-"
+ type :replace-dash nil :suffix "-surface")
+ filename width height))
+ (context (create-context surface)))
+ (destroy surface)
+ context)))
+
(define-create-context ps)
(define-create-context pdf)
(define-create-context svg)
Modified: package.lisp
==============================================================================
--- package.lisp (original)
+++ package.lisp Sun Mar 23 17:58:24 2008
@@ -1,4 +1,6 @@
-(defpackage :cl-cairo2
+(in-package #:cl-cairo2-asd)
+
+(defpackage cl-cairo2
(:use :common-lisp :cffi :cl-colors :cl-utilities)
(:export
@@ -8,23 +10,24 @@
;; surface
- get-width get-height destroy create-ps-surface create-pdf-surface
- create-svg-surface create-image-surface image-surface-get-format
+ surface pointer width height get-width get-height pixel-based-p
+ destroy create-ps-surface create-pdf-surface create-svg-surface
+ create-image-surface image-surface-get-format
image-surface-get-width image-surface-get-height
- image-surface-create-from-png surface-write-to-png with-png-file
+ image-surface-create-from-png surface-write-to-png
;; context
- create-context sync sync-lock sync sync-unlock sync-reset
- with-sync-lock *context* save restore push-group pop-group
- pop-group-to-source set-source-rgb set-source-rgba clip
- clip-preserve reset-clip copy-page show-page fill-preserve paint
- paint-with-alpha stroke stroke-preserve set-source-color
- get-line-width set-line-width get-miter-limit set-miter-limit
- get-antialias set-antialias get-fill-rule set-fill-rule
- get-line-cap set-line-cap get-line-join set-line-join get-operator
- set-operator fill-path set-dash get-dash clip-extents fill-extents
- in-fill in-stoke create-ps-context create-pdf-context
+ context with-png-file create-context sync sync-lock sync
+ sync-unlock sync-reset with-sync-lock *context* save restore
+ push-group pop-group pop-group-to-source set-source-rgb
+ set-source-rgba clip clip-preserve reset-clip copy-page show-page
+ fill-preserve paint paint-with-alpha stroke stroke-preserve
+ set-source-color get-line-width set-line-width get-miter-limit
+ set-miter-limit get-antialias set-antialias get-fill-rule
+ set-fill-rule get-line-cap set-line-cap get-line-join set-line-join
+ get-operator set-operator fill-path set-dash get-dash clip-extents
+ fill-extents in-fill in-stoke create-ps-context create-pdf-context
create-svg-context get-target
;; path
Modified: surface.lisp
==============================================================================
--- surface.lisp (original)
+++ surface.lisp Sun Mar 23 17:58:24 2008
@@ -13,10 +13,20 @@
;;;; class surface
;;;;
+(defgeneric get-width (object)
+ (:documentation "return the width of an object"))
+
+(defgeneric get-height (object)
+ (:documentation "return the height of an object"))
+
+(defgeneric pixel-based-p (object)
+ (:documentation "return t iff the object uses a pixel-based backend"))
+
(defclass surface ()
((pointer :initarg :pointer :initform nil)
(width :initarg :width :reader get-width)
- (height :initarg :height :reader get-height)))
+ (height :initarg :height :reader get-height)
+ (pixel-based-p :initarg :pixel-based-p :reader pixel-based-p)))
(defmacro with-alive-surface ((surface pointer) &body body)
"Execute body with pointer pointing to cairo surface, if nil,
@@ -37,18 +47,19 @@
(warn "function returned with status ~a." ,status))))))
(defmacro with-surface ((surface pointer) &body body)
- "Execute body with pointer pointing to context, and check status."
+ "Execute body with pointer pointing to surface, and check status."
`(with-alive-surface (,surface ,pointer)
(check-surface-pointer-status ,pointer
, at body)))
-(defun new-surface-with-check (pointer width height)
+(defun new-surface-with-check (pointer width height &optional (pixel-based-p nil))
"Check if the creation of new surface was successful, if so, return new class."
- (let ((surface (make-instance 'surface :width width :height height)))
+ (let ((surface (make-instance 'surface :width width :height height
+ :pixel-based-p pixel-based-p)))
(check-surface-pointer-status pointer
(setf (slot-value surface 'pointer) pointer)
;; register finalizer
-;; (finalize surface #'(lambda () (cairo_surface_destroy pointer)))
+ (tg:finalize surface #'(lambda () (cairo_surface_destroy pointer)))
;; return surface
surface)))
@@ -57,7 +68,7 @@
(cairo_surface_destroy pointer)
(setf pointer nil))
;; deregister finalizer
- (cancel-finalization object))
+ (tg:cancel-finalization object))
;;;;
;;;; Macros to create surfaces (that are written into files) and
@@ -74,19 +85,6 @@
filename width height)
width height)))
-(defmacro define-create-context (type)
- `(defun ,(prepend-intern "create-" type :replace-dash nil :suffix "-context")
- (filename width height)
- "Create a surface, then a context for a file, then
-destroy (dereference) the surface. The user only needs to
-destroy the context when done."
- (let* ((surface (,(prepend-intern "create-"
- type :replace-dash nil :suffix "-surface")
- filename width height))
- (context (create-context surface)))
- (destroy surface)
- context)))
-
;;;;
;;;; PDF surface
;;;;
@@ -113,7 +111,7 @@
(new-surface-with-check
(cairo_image_surface_create (lookup-enum format table-format)
width height)
- width height))
+ width height t))
(defun image-surface-get-format (surface)
(with-surface (surface pointer)
@@ -144,14 +142,3 @@
(with-surface (surface pointer)
(cairo_surface_write_to_png pointer filename)))
-(defmacro with-png-file ((filename format width height) &body body)
- "Execute the body with context bound to a newly created png
- file, and close it after executing body."
- (let ((surface-name (gensym)))
- `(let* ((,surface-name (create-image-surface ,format ,width ,height))
- (*context* (create-context ,surface-name)))
- (progn
- , at body
- (surface-write-to-png ,surface-name ,filename)
- (destroy ,surface-name)
- (destroy *context*)))))
Modified: tutorial/Makefile
==============================================================================
--- tutorial/Makefile (original)
+++ tutorial/Makefile Sun Mar 23 17:58:24 2008
@@ -1,8 +1,15 @@
+EXAMPLEFILES=hearts.png lissajous.epsi text.epsi example.epsi
+RAWEXAMPLEFILES=hearts.png lissajous.ps text.ps example.ps
+LISP=sbcl
+
tutorial.pdf: tutorial.dvi
dvipdfm tutorial
-tutorial.dvi: tutorial.tex hearts.png lissajous.epsi text.epsi example.epsi
+tutorial.dvi: tutorial.tex $(EXAMPLEFILES)
latex tutorial.tex
+$(RAWEXAMPLEFILES): example.lisp
+ $(LISP) --eval '(progn (load "example.lisp") (quit))'
+
%.epsi: %.ps
ps2epsi $< $@
Added: tutorial/hearts.png
==============================================================================
Binary file. No diff available.
Modified: xlib-context.lisp
==============================================================================
--- xlib-context.lisp (original)
+++ xlib-context.lisp Sun Mar 23 17:58:24 2008
@@ -152,8 +152,8 @@
;; intern atom for window closing, set protocol on window
(setf wm-delete-window
(xinternatom display "WM_DELETE_WINDOW" 1))
- (with-foreign-object (prot 'atom)
- (setf (mem-aref prot 'atom) wm-delete-window)
+ (with-foreign-object (prot 'xatom)
+ (setf (mem-aref prot 'xatom) wm-delete-window)
(xsetwmprotocols display window prot 1))
;; store name
(xstorename display window window-name)
Modified: xlib-image-context.lisp
==============================================================================
--- xlib-image-context.lisp (original)
+++ xlib-image-context.lisp Sun Mar 23 17:58:24 2008
@@ -38,16 +38,60 @@
thread
(sync-counter :initform 0 :accessor sync-counter)))
+
+;; synchronization after drawing
+
+(defun send-message-to-signal-window (xlib-image-context message)
+ "Send the desired message to the context window."
+ (with-slots (pointer (display-pointer display) signal-window) xlib-image-context
+ (unless pointer
+ (warn "context is not active, can't send message to window")
+ (return-from send-message-to-signal-window))
+ (with-foreign-object (xev :long 24)
+ (with-foreign-slots
+ ((type display window message-type format data0)
+ xev xclientmessageevent)
+ (setf type 33) ; clientnotify
+ (setf display display-pointer)
+ (setf window signal-window)
+ (setf message-type 0)
+ (setf format 32)
+ (setf data0 message)
+ (xsendevent display-pointer signal-window 0 0 xev))
+ (xflush display-pointer))))
+
+(defmethod sync ((object xlib-image-context))
+ (when (zerop (sync-counter object))
+ (send-message-to-signal-window object +refresh-message+)))
+
+(defmethod sync-lock ((object xlib-image-context))
+ (incf (sync-counter object)))
+
+(defmethod sync-unlock ((object xlib-image-context))
+ (with-slots (sync-counter) object
+ (when (plusp sync-counter)
+ (decf sync-counter)))
+ (sync object))
+
+(defmethod sync-reset ((object xlib-image-context))
+ (setf (sync-counter object) 0)
+ (sync object))
+
(defun create-xlib-image-context (width height &key
(display-name nil)
- (window-name (next-xlib-image-context-name)))
+ (window-name (next-xlib-image-context-name))
+ (background-color +white+))
+ "Create a window mapped to an xlib-image-context, with given width,
+height (non-resizable) and window-name on display-name. If
+background-color is not nil, the window will be painted with it."
(let ((display (xopendisplay (if display-name display-name (null-pointer)))))
(when (null-pointer-p display)
(error "couldn't open display ~a" display-name))
(let ((xlib-image-context (make-instance 'xlib-image-context
:display display
:width width
- :height height)))
+ :height height
+ :pixel-based-p t)))
(labels (;; Repaint the xlib context with the image surface
;; (previously set as source during initialization.
(refresh ()
@@ -128,8 +172,8 @@
;; intern atom for window closing, set protocol on window
(setf wm-delete-window
(xinternatom display "WM_DELETE_WINDOW" 1))
- (with-foreign-object (prot 'atom)
- (setf (mem-aref prot 'atom) wm-delete-window)
+ (with-foreign-object (prot 'xatom)
+ (setf (mem-aref prot 'xatom) wm-delete-window)
(xsetwmprotocols display window prot 1))
;; store name
(xstorename display window window-name)
@@ -154,44 +198,15 @@
(start-thread
#'event-loop
(format nil "thread for display ~a" display-name))))))
+ ;; paint it if we are given a background color
+ (when background-color
+ (set-source-color background-color xlib-image-context)
+ (paint xlib-image-context)
+ (sync xlib-image-context))
;; return context
xlib-image-context)))
-(defun send-message-to-signal-window (xlib-image-context message)
- "Send the desired message to the context window."
- (with-slots (pointer (display-pointer display) signal-window) xlib-image-context
- (unless pointer
- (warn "context is not active, can't send message to window")
- (return-from send-message-to-signal-window))
- (with-foreign-object (xev :long 24)
- (with-foreign-slots
- ((type display window message-type format data0)
- xev xclientmessageevent)
- (setf type 33) ; clientnotify
- (setf display display-pointer)
- (setf window signal-window)
- (setf message-type 0)
- (setf format 32)
- (setf data0 message)
- (xsendevent display-pointer signal-window 0 0 xev))
- (xflush display-pointer))))
(defmethod destroy ((object xlib-image-context))
(send-message-to-signal-window object +destroy-message+))
-(defmethod sync ((object xlib-image-context))
- (when (zerop (sync-counter object))
- (send-message-to-signal-window object +refresh-message+)))
-
-(defmethod sync-lock ((object xlib-image-context))
- (incf (sync-counter object)))
-
-(defmethod sync-unlock ((object xlib-image-context))
- (with-slots (sync-counter) object
- (when (plusp sync-counter)
- (decf sync-counter)))
- (sync object))
-
-(defmethod sync-reset ((object xlib-image-context))
- (setf (sync-counter object) 0)
- (sync object))
Modified: xlib.lisp
==============================================================================
--- xlib.lisp (original)
+++ xlib.lisp Sun Mar 23 17:58:24 2008
@@ -17,7 +17,7 @@
(defctype colormap xid)
(defctype graphics-context xid)
(defctype visual :pointer)
-(defctype atom :unsigned-long)
+(defctype xatom :unsigned-long)
(defctype bool :int)
;; constants
@@ -255,7 +255,7 @@
;; atoms & protocols
-(defcfun ("XInternAtom" xinternatom) atom
+(defcfun ("XInternAtom" xinternatom) xatom
(display display)
(atom-name :string)
(only-if-exists :int))
@@ -304,7 +304,7 @@
(send-event bool)
(display display)
(window window)
- (message-type atom)
+ (message-type xatom)
(format :int)
;; we only use first field, union of message data is not included
(data0 :unsigned-long))
More information about the Cl-cairo2-cvs
mailing list