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)))