> I used to draw white points in a black background using a gcontext
> defined in B/W and the draw-point function. I would like to be able
> to write pixels of different color, but I can't figure a
> straightforward way to make it.
Basically you use ALLOC-COLOR.
If you want some complete examples, check the contrib directory in the
CMUCL source tree. There are two directories containing CLX code that
uses color: the demos directory and the games/feebs directory. The
feebs program in particular uses specific named colors.
Here's a test example that I did some time ago that you may also be
able to get some help from:
----------------------------------------
(defpackage "TEST-XLIB-REENTRANCY"
(:nicknames "TXR")
(:use :common-lisp :xlib))
(in-package "TEST-XLIB-REENTRANCY")
(defvar *display*)
(defvar *screen*)
(defvar *root*)
(defvar *colormap*)
(defvar *root-w*)
(defvar *root-h*)
(defvar *parent-bg*)
(defvar *child-bg*)
(defvar *parent-fg*)
(defvar *child-fg*)
(defvar *black-pixel*)
(defvar *white-pixel*)
(defvar *parent-window*)
(defvar *parent-gcontext*)
(defvar *child-window*)
(defvar *child-gcontext1*)
(defvar *child-gcontext2*)
(defvar *event-loop-process*)
(defun full-window-state (w)
(with-state (w)
(values (drawable-width w)
(drawable-height w)
(drawable-x w)
(drawable-y w)
(window-map-state w))))
(defun wait-for-mapping (display win)
(display-finish-output display)
(multiple-value-bind (width height x y mapped) (full-window-state win)
(declare (ignore width height x y))
(if (eq mapped :viewable)
t
(wait-for-mapping display win))))
(defun child-refresh ()
(clear-area *parent-window*)
(clear-area *child-window*))
(defun child-fill (gc)
(draw-rectangle *child-window* gc
0 0
(drawable-width *child-window*) (drawable-height *child-window*)
t))
(defun child-normal ()
(child-fill *child-gcontext1*))
(defun child-reverse ()
(child-fill *child-gcontext2*))
(defun do-button-release (event-window)
(when (eql event-window *child-window*)
(child-reverse)
(ext:flush-display-events *display*)
;; (discard-pending-events)
(throw 'done-waiting nil)))
(defun discard-pending-events (&optional (timeout 1))
(discard-current-event *display*)
(event-case (*display* :discard-p t :timeout timeout)
(:destroy-notify () NIL) ; get rid of warnings
(otherwise () t)))
(defun do-button-press (event-window)
(flip-and-wait)
)
(defun flip-and-wait ()
(child-normal)
(catch 'done-waiting
(loop
(handle-events))))
(defun handle-events ()
(EVENT-CASE ((DRAWABLE-DISPLAY *parent-window*) :discard-p t :timeout 1)
(:exposure (count)
(when (zerop count) (child-refresh))
t)
(:button-release (event-window)
(do-button-release event-window)
t)
(:button-press (event-window)
(do-button-press event-window)
t)
(:enter-notify (window)
(child-reverse)
t)
(:leave-notify (window)
(child-normal)
t)
(otherwise ()
t)))
(defun make-test (&key (x 150) (y 150) (width 200) (height 200))
(multiple-value-setq (*display* *screen*) (ext:open-clx-display))
(setf *root* (screen-root *screen*)
*colormap* (screen-default-colormap *screen*)
*root-w* (drawable-width *root*)
*root-h* (drawable-height *root*)
*black-pixel* (screen-black-pixel *screen*)
*white-pixel* (screen-white-pixel *screen*)
*parent-bg* (alloc-color *colormap* "green")
*parent-fg* (alloc-color *colormap* "red")
*child-bg* (alloc-color *colormap* "orange")
*child-fg* (alloc-color *colormap* "blue")
*parent-window* (create-window
:parent *root*
:x (if (minusp x) (- (+ *root-w* x) width) x)
:y (if (minusp y) (- (+ *root-h* y) height) y)
:event-mask nil
:width width :height height
:background *parent-bg*
:border-width 0
;;:override-redirect :on
)
*parent-gcontext* (create-gcontext :drawable *parent-window*
:background *parent-bg*
:foreground *parent-fg*))
(map-window *parent-window*)
(wait-for-mapping *display* *parent-window*)
(setf *child-gcontext1* (create-gcontext :drawable *parent-window*
:foreground *child-fg*
:background *child-bg*)
*child-gcontext2* (create-gcontext :drawable *parent-window*
:foreground *child-bg*
:background *child-fg*)
*child-window* (create-window
:parent *parent-window*
;; :class :input-output
:x 20 ;temporary value
:y 20 ;temporary value
:width 75 ;temporary value
:height 75 ;temporary value
:border-width 2
:border *black-pixel*
:background *child-fg*
:save-under :on
;; :override-redirect :on ;override window mgr when
positioning
:event-mask (MAKE-EVENT-MASK :enter-window :leave-window
:button-press
:button-release)))
(map-subwindows *parent-window*)
(clear-area *child-window*)
(wait-for-mapping *display* *child-window*))
#+mp
(defun start-up ()
(make-test)
(setf *event-loop-process*
(mp:make-process
#'(lambda ()
(loop (handle-events)))
:name "Test event handler"))
(setf mp::*idle-process* mp::*initial-process*)
;; Lower the timeout for serve-event to give good process response.
(setf lisp::*max-event-to-usec* 50000)
(setf lisp::*max-event-to-sec* 0))
#-mp
(defun start-up ()
(make-test)
(loop (handle-events)))
----------------------------------------
--
Fred Gilham [EMAIL PROTECTED]
If you want to be largely ignored by women, playing jazz guitar is
pretty good strategy... --- Bob Russell
