[cl-cairo2-cvs] r15 - tutorial
tpapp at common-lisp.net
tpapp at common-lisp.net
Thu Dec 20 13:05:09 UTC 2007
Author: tpapp
Date: Thu Dec 20 08:05:07 2007
New Revision: 15
Modified:
cl-cairo2.asd
context.lisp
package.lisp
tutorial/example.lisp
xlib-context.lisp
xlib.lisp
Log:
reorganization, bugfixes
Modified: cl-cairo2.asd
==============================================================================
--- cl-cairo2.asd (original)
+++ cl-cairo2.asd Thu Dec 20 08:05:07 2007
@@ -13,9 +13,9 @@
(:file "text" :depends-on ("context"))
(:file "transformations" :depends-on ("context"))
(:file "xlib" :depends-on ("context")
- :in-order-to ((load-op (feature :unix))
- (compile-op (feature :unix))))
- (:file "xlib-context" :depends-on ("xlib")
- :in-order-to ((load-op (feature :unix))
- (compile-op (feature :unix)))))
+ :in-order-to ((load-op (feature :unix))
+ (compile-op (feature :unix))))
+ (:file "xlib-image-context" :depends-on ("xlib")
+ :in-order-to ((load-op (feature :unix))
+ (compile-op (feature :unix)))))
:depends-on (:cffi :cl-colors :cl-utilities))
Modified: context.lisp
==============================================================================
--- context.lisp (original)
+++ context.lisp Thu Dec 20 08:05:07 2007
@@ -172,6 +172,14 @@
(define-with-default-context-sync stroke)
(define-with-default-context-sync stroke-preserve)
+;;;; get-target
+
+(defun get-target (context)
+ "Obtain the target surface of a given context. Width and height
+will be nil, as cairo can't provide that in general."
+ (new-surface-with-check (cairo_get_target (slot-value context 'pointer))
+ nil nil))
+
;;;;
;;;; set colors using the cl-colors library
;;;;
@@ -184,7 +192,7 @@
(defmethod set-source-color ((color rgba) &optional (context *context*))
(with-slots (red green blue alpha) color
- (set-source-rgb red green blue alpha context)))
+ (set-source-rgba red green blue alpha context)))
(defmethod set-source-color ((color hsv) &optional (context *context*))
(with-slots (red green blue) (hsv->rgb color)
Modified: package.lisp
==============================================================================
--- package.lisp (original)
+++ package.lisp Thu Dec 20 08:05:07 2007
@@ -8,10 +8,10 @@
;; surface
- get-width get-height destroy 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
+ get-width get-height 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
;; context
@@ -25,7 +25,7 @@
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
+ create-svg-context get-target
;; path
@@ -49,6 +49,6 @@
trans-matrix-rotate trans-matrix-invert trans-matrix-multiply
trans-matrix-distance transform-point
- ;; xlib-context
+ ;; xlib-image-context
- xlib-context xlib-display open-xlib-display create-xlib-context))
+ xlib-image-context create-xlib-image-context))
Modified: tutorial/example.lisp
==============================================================================
--- tutorial/example.lisp (original)
+++ tutorial/example.lisp Thu Dec 20 08:05:07 2007
@@ -14,9 +14,8 @@
(setf *context* (create-context *surface*))
(destroy *surface*)
;; clear the whole canvas with blue
-(rectangle 0 0 200 100)
(set-source-rgb 0.2 0.2 1)
-(fill-path)
+(paint)
;; draw a white diagonal line
(move-to 200 0)
(line-to 0 100)
@@ -49,11 +48,7 @@
(defun mark-at (x y d red green blue)
"Make a rectangle of size 2d around x y with the given colors,
50% alpha. Used for marking points."
- (move-to (+ x d) (+ y d))
- (line-to (- x d) (+ y d))
- (line-to (- x d) (- y d))
- (line-to (+ x d) (- y d))
- (close-path)
+ (rectangle (- x d) (- y d) (* 2 d) (* 2 d))
(set-source-rgba red green blue 0.5)
(fill-path))
@@ -71,9 +66,8 @@
(defparameter y 50)
(setf *context* (create-ps-context "text.ps" width height))
;; white background
-(rectangle 0 0 width height)
(set-source-rgb 1 1 1)
-(fill-path)
+(paint)
;; setup font
(select-font-face "Arial" 'font-slant-normal 'font-weight-normal)
(set-font-size size)
Modified: xlib-context.lisp
==============================================================================
--- xlib-context.lisp (original)
+++ xlib-context.lisp Thu Dec 20 08:05:07 2007
@@ -51,31 +51,6 @@
0 0 width height 0 0)
(xsync display 1)))
-(defun create-window (display parent width height class visual background-pixel
- event-mask &optional (backing-store t))
- "Create an x11 window, placed at 0 0, with the given attributes.
-For internal use in the cl-cairo2 package."
- ;; call xcreatewindow with attributes
- (with-foreign-object (attributes 'xsetwindowattributes)
- (setf (foreign-slot-value attributes 'xsetwindowattributes 'event-mask)
- event-mask
- (foreign-slot-value attributes 'xsetwindowattributes 'background-pixel)
- background-pixel
- (foreign-slot-value attributes 'xsetwindowattributes 'backing-store)
- (if backing-store 1 0))
- (xcreatewindow display parent 0 0 width height
- 0 ; zero border width
- 0 ; depth - copy from parent
- (ecase class
- (copyfromparent 0)
- (inputoutput 1)
- (inputonly 2)) ; class
- visual
- (if (eq class 'inputonly)
- cweventmask
- (logior cwbackpixel cwbackingstore cweventmask))
- attributes)))
-
(defun create-xlib-context (width height &key
(display-name nil)
(window-name (next-xlib-context-name)))
@@ -101,7 +76,7 @@
(with-foreign-slots ((type window serial) xev xanyevent)
;; action based on event type
(cond
- ;; expose and configurenotify events
+ ;; expose events
((and (= type 12) (= window this-window))
(refresh-xlib-context xlib-context))
;; clientnotify event
@@ -121,14 +96,16 @@
;; close down everything
(with-slots (display pixmap window signal-window pointer)
xlib-context
+ (xsynchronize display 1)
(let ((saved-pointer pointer))
(setf pointer nil) ; invalidate first so it can't be used
- (cairo_destroy saved-pointer))
+;; (cairo_destroy saved-pointer)
+ )
(xfreepixmap display pixmap)
(xdestroywindow display window)
- (xdestroywindow display signal-window)
- (xclosedisplay display))))
- ;; initialize
+ (xdestroywindow display signal-window)
+ (xclosedisplay display))))
+ ;; initialize
(xsynchronize display 1)
(let* ((screen (xdefaultscreen display))
(root (xdefaultrootwindow display))
@@ -201,7 +178,10 @@
(defun send-message-to-signal-window (xlib-context message)
"Send the desired message to the context window."
- (with-slots ((display-pointer display) signal-window) xlib-context
+ (with-slots (pointer (display-pointer display) signal-window) xlib-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)
@@ -213,8 +193,7 @@
(setf format 32)
(setf data0 message)
(xsendevent display-pointer signal-window 0 0 xev))
- (xflush display-pointer))))
-
+ (xsync display-pointer 1))))
(defmethod destroy ((object xlib-context))
(send-message-to-signal-window object +destroy-message+))
Modified: xlib.lisp
==============================================================================
--- xlib.lisp (original)
+++ xlib.lisp Thu Dec 20 08:05:07 2007
@@ -387,7 +387,102 @@
(first-event :int)
(first-error :int))
+;; image manipulation
+
+(cffi:defcstruct XImage
+ (width :int)
+ (height :int)
+ (xoffset :int)
+ (format :int)
+ (data :pointer)
+ (byte-order :int)
+ (bitmap-unit :int)
+ (bitmap-bit-order :int)
+ (bitmap-pad :int)
+ (depth :int)
+ (bytes-per-line :int)
+ (bits-per-pixel :int)
+ (red-mask :unsigned-long)
+ (green-mask :unsigned-long)
+ (blue-mask :unsigned-long)
+ (obdata :pointer)
+ ;; funcs
+ (create-image :pointer)
+ (destroy-image :pointer)
+ (get-pixel :pointer)
+ (put-pixel :pointer)
+ (sub-image :pointer)
+ (add-pixel :pointer))
+
+(defcfun ("XInitImage" xinitimage) :int
+ (ximage :pointer))
+
+(defcfun ("XPutImage" xputimage) :int
+ (display display)
+ (drawable drawable)
+ (graphics-context graphics-context)
+ (ximage :pointer)
+ (src-x :int)
+ (src-y :int)
+ (dest-x :int)
+ (dest-y :int)
+ (width :unsigned-int)
+ (height :unsigned-int))
;; call xinitthreads
(xinitthreads)
+
+
+;; various higher level functions
+
+(defun set-window-size-hints (display window
+ min-window-width max-window-width
+ min-window-height max-window-height)
+ ;; set size hints on window (most window managers will respect this)
+ (let ((hints (xallocsizehints)))
+ (with-foreign-slots ((flags x y min-width min-height
+ max-width max-height)
+ hints
+ xsizehints)
+ ;; we only set the first four values because old WM's might
+ ;; get confused if we don't, they should be ignored
+ (setf flags (logior pminsize pmaxsize)
+ x 0
+ y 0
+ ;; we don't need to set the following, but some WMs go
+ ;; crazy if we don't
+ (foreign-slot-value hints 'xsizehints 'width) max-window-width
+ (foreign-slot-value hints 'xsizehints 'height) max-window-height
+ ;; set desired min/max width/height
+ min-width min-window-width
+ max-width max-window-width
+ min-height min-window-height
+ max-height max-window-height)
+ (xsetwmnormalhints display window hints)
+ (xfree hints))))
+
+(defun create-window (display parent width height class visual background-pixel
+ event-mask &optional (backing-store t))
+ "Create an x11 window, placed at 0 0, with the given attributes.
+For internal use in the cl-cairo2 package."
+ ;; call xcreatewindow with attributes
+ (with-foreign-object (attributes 'xsetwindowattributes)
+ (setf (foreign-slot-value attributes 'xsetwindowattributes 'event-mask)
+ event-mask
+ (foreign-slot-value attributes 'xsetwindowattributes 'background-pixel)
+ background-pixel
+ (foreign-slot-value attributes 'xsetwindowattributes 'backing-store)
+ (if backing-store 1 0))
+ (xcreatewindow display parent 0 0 width height
+ 0 ; zero border width
+ 0 ; depth - copy from parent
+ (ecase class
+ (copyfromparent 0)
+ (inputoutput 1)
+ (inputonly 2)) ; class
+ visual
+ (if (eq class 'inputonly)
+ cweventmask
+ (logior cwbackpixel cwbackingstore cweventmask))
+ attributes)))
More information about the Cl-cairo2-cvs
mailing list