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 + ,@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 ,@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 - ,@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))