From: Wang Yin
Subject: A strange problem with CLX
Date:
Message-ID: <m3ptgc3zbw.fsf@wangyin.com>
Hi, I've written a grapher with CMU CL's CLX to draw simple geometric
figures for my computational geometry usage.
I put the objects to be drawn into a list in the record
graphics-device's obj-list. Later when exposure event comes, I invoke
a function named default-redrawer to redraw the objects according to
their types.
But there is a bug here. The last object in this list is drawn, and
then erased out immediately after that. A flash! I checked all the
places when clear-erea appear but I can't see why is the figure not
shown.
The main part of the code is here. For full working code, see the end
of this post.
(defun default-redrawer (gd x y width height)
(let* ((window (gd-window gd))
(display (gd-display gd))
(obj-list (gd-obj-list gd))
(gc (gd-gc gd))
(font (gd-font gd)))
(unless (eq (xlib:window-map-state window) :viewable)
(xlib:map-window window)
(xlib:display-force-output display))
;; clear the whole window
;; remove this would work around the bug,
;; but I need clear the window before redraw it.
(xlib:clear-area window :x 0 :y 0 :width (xlib:drawable-width window)
:height (xlib:drawable-height window))
(xlib:display-finish-output display)
;; draw objects
(dolist (obj obj-list)
(let ((drawer (gethash (car obj) *drawing-method-hash*)))
;(print obj) (print drawer)
(if drawer
(apply drawer gd (cdr obj))
(format t "I Don't know how to draw the type ~A" (car obj)))))
(xlib:display-finish-output display)))
It seems CLX's display-force-output and display-finish-output is
working misteriously. They don't really do things exactly like XFlush
and XSync. After I do a clear-area, I need do twice
display-finish-output to see the drawings disappear.
I don't know why. Anyone has some hint on this?
The following is the full list of the code. I use data directed
method for the redrawing process. The user can define his own
primitive types with the macro define-drawer. When the bug is fixed, I
hope this code is useful to someone who need simple canvas in CMU CL.
See the end of the code to see how to use it and how to reproduce the
bug.
(defvar *drawing-method-hash* (make-hash-table))
(defstruct (graphics-device (:constructor %make-gdev)
(:conc-name gd-))
display
screen
black
white
font
font-width
font-ascent
font-height
x-min
y-min
x-max
y-max
gc
event-mask
object-set
window
obj-list
redrawer
button-handler
)
(defun make-graphics-device (name width height)
(require :clx)
(let* ((display (ext:open-clx-display
(cdr (assoc :display ext:*environment-list*))))
(screen (first (xlib:display-roots display)))
(black (xlib:screen-black-pixel screen))
(white (xlib:screen-white-pixel screen))
(font (xlib:open-font display "8x13"))
(font-width (xlib:char-width font 0))
(font-ascent (xlib:font-ascent font))
(font-height (+ font-ascent (xlib:font-descent font)))
(gc (xlib:create-gcontext :drawable (xlib:screen-root screen)
:font font :exposures nil
:fill-style :solid :fill-rule :even-odd
:foreground black :background white))
(event-mask (xlib:make-event-mask :exposure
:button-press
))
(object-set
(system:make-object-set name #'ext:default-clx-event-handler))
(window (xlib:create-window :parent (xlib:screen-root screen)
:x 350 :y 200
:width width
:height height
:border-width 5
:event-mask event-mask
:background white))
(new-gd (%make-gdev
:display (ext:open-clx-display
(cdr (assoc :display ext:*environment-list*)))
:screen (first (xlib:display-roots display))
:black (xlib:screen-black-pixel screen)
:white (xlib:screen-white-pixel screen)
:font (xlib:open-font display "8x13")
:font-width (xlib:char-width font 0)
:font-ascent (xlib:font-ascent font)
:font-height (+ font-ascent (xlib:font-descent font))
:x-min 0
:y-min 0
:x-max 100
:y-max 100
:GC (xlib:create-gcontext
:drawable (xlib:screen-root screen)
:font font :exposures nil
:fill-style :solid :fill-rule :even-odd
:foreground black :background white)
:event-mask event-mask
:object-set object-set
:redrawer #'default-redrawer
:window window)))
(labels ((exposure-handler (obj event-key window x y width height count send)
(declare (ignore obj event-key window count send))
(funcall (gd-redrawer new-gd) new-gd x y width height))
(no-exposure-handler (obj event-key window major minor send)
(declare (ignore obj event-key window major minor send)) t)
(client-message-handler (obj event-key &rest lst)
(declare (ignore obj event-key))
(xlib:unmap-window window)
(xlib:display-force-output display))
(button-press-handler (obj event-key &rest lst)
(declare (ignore obj event-key))
(if (gd-button-handler new-gd)
(funcall (gd-button-handler new-gd)
new-gd
(nth 10 lst) ;number
(nth 4 lst) ;x
(nth 5 lst))))) ;y
(ext:serve-exposure object-set #'exposure-handler)
(ext:serve-no-exposure object-set #'no-exposure-handler)
(ext:serve-client-message object-set #'client-message-handler)
(ext:serve-button-press object-set #'button-press-handler)
(ext:enable-clx-event-handling display #'ext:object-set-event-handler)
(setf (xlib:wm-name window) name)
(xlib::set-wm-protocols window '(WM_DELETE_WINDOW))
(system:add-xwindow-object window window object-set))
(xlib:map-window window)
(xlib:display-force-output display)
new-gd))
(defun graphics-set-coordinate-limits (gd x-min y-min x-max y-max)
(cond ((or (<= x-max x-min) (<= y-max y-min))
(print "Upper bound should be larger than lower.") nil)
(t (setf (gd-x-min gd) x-min)
(setf (gd-y-min gd) y-min)
(setf (gd-x-max gd) x-max)
(setf (gd-y-max gd) y-max)
(graphics-redraw gd))))
(defun graphics-coordinate-limits (gd)
(values (gd-x-min gd)
(gd-y-min gd)
(gd-x-max gd)
(gd-y-max gd)))
(defun graphics-coord-map (gd)
(lambda (x y)
(values (funcall (graphics-coord-map-x gd) x)
(funcall (graphics-coord-map-y gd) y))))
(defun graphics-coord-map-x (gd)
(lambda (x)
(let* ((x-min (gd-x-min gd))
(x-max (gd-x-max gd))
(width (graphics-device-width gd)))
(floor (* width (- x x-min)) (- x-max x-min)))))
(defun graphics-coord-map-y (gd)
(lambda (y)
(let* ((y-min (gd-y-min gd))
(y-max (gd-y-max gd))
(height (graphics-device-height gd)))
(- height (floor (* height (- y y-min)) (- y-max y-min))))))
(defun graphics-length-map-x (gd)
(lambda (len)
(let* ((x-min (gd-x-min gd))
(x-max (gd-x-max gd))
(width (graphics-device-width gd)))
(floor (* width len) (- x-max x-min)))))
(defun graphics-length-map-y (gd)
(lambda (len)
(let* ((y-min (gd-y-min gd))
(y-max (gd-y-max gd))
(height (graphics-device-height gd)))
(floor (* height len) (- y-max y-min)))))
; (funcall (graphics-coord-map gd1) 30 30)
; (funcall (graphics-length-map-x gd1) 30)
(defun default-redrawer (gd x y width height)
(let* ((window (gd-window gd))
(display (gd-display gd))
(obj-list (gd-obj-list gd))
(gc (gd-gc gd))
(font (gd-font gd)))
(unless (eq (xlib:window-map-state window) :viewable)
(xlib:map-window window)
(xlib:display-force-output display))
;; clear the whole window
(xlib:clear-area window :x 0 :y 0 :width (xlib:drawable-width window)
:height (xlib:drawable-height window))
(xlib:display-finish-output display)
;; draw objects
(dolist (obj obj-list)
(let ((drawer (gethash (car obj) *drawing-method-hash*)))
;(print obj) (print drawer)
(if drawer
(apply drawer gd (cdr obj))
(format t "I Don't know how to draw the type ~A" (car obj)))))
(xlib:display-finish-output display)))
; (setf (gd-redrawer gd1) #'default-redrawer)
; (gd-obj-list gd1)
(defun register-drawer (type proc)
(setf (gethash type *drawing-method-hash*) proc))
(defmacro with-graphics-device (gd &body body)
`(let* ((window (gd-window ,gd))
(display (gd-display ,gd))
(obj-list (gd-obj-list ,gd))
(gc (gd-gc ,gd))
(font (gd-font ,gd))
(x-min (gd-x-min ,gd))
(y-min (gd-y-min ,gd))
(x-max (gd-x-max ,gd))
(y-max (gd-y-max ,gd))
(coord-map (graphics-coord-map ,gd))
(coord-map-x (graphics-coord-map-x ,gd))
(coord-map-y (graphics-coord-map-y ,gd))
(length-map-x (graphics-length-map-x ,gd))
(length-map-y (graphics-length-map-y ,gd))
(width (graphics-device-width ,gd))
(height (graphics-device-height ,gd)))
,@body))
(defun graphics-redraw (gd)
(with-graphics-device gd
(funcall (gd-redrawer gd) gd 0 0 width height)))
; (graphics-redraw gd1)
(defun graphics-flush (gd)
(xlib:display-force-output (gd-display gd)))
(defun graphics-clear (gd)
(with-graphics-device gd
(setf obj-list nil)
(xlib:clear-area window :x 0 :y 0 :width (xlib:drawable-width window)
:height (xlib:drawable-height window))
(xlib:display-finish-output display)))
(defmacro define-drawer (name args &body body)
(let ((type-tag (let ((type (cadr (memq '&type args))))
(if type (progn (setf args (remove-n '&type args 2))
type)
(gensym)))))
`(progn
(register-drawer ',type-tag #'(lambda ,args ,@body))
(defun ,name (gd ,@(cdr args))
(push (list ',type-tag ,@(cdr args)) (gd-obj-list gd))
(graphics-redraw gd)))))
(define-drawer graphics-draw-circle (gd x y radius &type :circle)
(with-graphics-device gd
(xlib:draw-arc window gc
(funcall coord-map-x (- x radius))
(funcall coord-map-y (+ y radius))
(funcall length-map-x (* 2 radius))
(funcall length-map-y (* 2 radius))
0 (* 2 3.14159))))
(define-drawer graphics-draw-line (gd x1 y1 x2 y2 &type :line)
(with-graphics-device gd
(xlib:draw-line window gc
(funcall coord-map-x x1)
(funcall coord-map-y y1)
(funcall coord-map-x x2)
(funcall coord-map-y y2))))
(define-drawer graphics-draw-rect (gd x y w h &type :rect)
(with-graphics-device gd
(xlib:draw-rectangle window gc
(funcall coord-map-x x)
(funcall coord-map-y y)
(funcall length-map-x w)
(funcall length-map-y h))))
(define-drawer graphics-draw-text (gd x y text &type :text)
(with-graphics-device gd
(xlib:draw-glyphs window gc (funcall coord-map-x x)
(funcall coord-map-y y) text)))
(defun graphics-device-width (gd)
(xlib:drawable-width (gd-window gd)))
(defun graphics-device-height (gd)
(xlib:drawable-height (gd-window gd)))
; (graphics-device-width gd1)
(defun close-graphics-device (g)
(xlib:unmap-window (gd-window g))
(xlib:display-finish-output (gd-display g))
(xlib:close-font (gd-font g))
(xlib:free-gcontext (gd-gc g))
(xlib:close-display (gd-display g)))
;; try the following to reproduce the bug:
(setf gd1 (make-graphics-device "hello" 300 300))
(graphics-set-coordinate-limits gd1 0 0 100 100)
(graphics-draw-text gd1 90 50 "hello") ; the "hello" won't be shown!
(graphics-draw-rect gd1 80 10 10 20)
(graphics-draw-line gd1 0 0 90 40)
(loop for x = 1 then (* 1.3 x)
until (> x 1000)
do (graphics-draw-circle gd1 0 0 x))
;; do this once won't clear the window, but the "hello is shown.
;; do this twice can clear the window.
(graphics-clear gd1)
--
Yin Wang,
EDA Lab,
Deparment of Computer Science and Technology,
Tsinghua University,
100084
Beijing China