hall@polya.Stanford.EDU (Keith A. Hall) (08/30/89)
Does anyone have a short example program of stippling and/or tiling using CLX? My goal is to simulate grayscale on a monochrome server. Thank you for any tips. Keith Hall hall@eclipse.stanford.edu
rao@PARC.xerox.com (Ramana Rao) (08/31/89)
Here's a short example of how you might simulate grayscale on a monochrome
server. Of course, I yanked this code from a larger system that I'm working
on, so it may look odd, and of course, it could be better, but at least, ...
(in-package 'xlib)
(defun shade-test (&key (host-name "localhost"))
(let* ((display (open-display host-name))
(screen (first (display-roots display)))
(root (screen-root screen))
(black (screen-black-pixel screen))
(white (screen-white-pixel screen))
(window (create-window :parent root
:background white
:x 10 :y 10 :width 300 :height 300))
(gc (create-gcontext :drawable window
:foreground black
:fill-style :solid)))
(map-window window)
(display-finish-output display)
(sleep 1)
(dolist (shade '(0 7.25 12.5 25 37.5 50 62.5 75 87.5 92.75 100))
(setf-shade root gc 100 white black)
(draw-rectangle window gc 10 10 280 280 t)
(setf-shade root gc shade white black)
(draw-rectangle window gc 20 20 260 260 t)
(display-finish-output display)
(sleep 1))
(close-display display)))
(defun setf-shade (root gcontext shade white black)
(case shade
(0
(setf (xlib:gcontext-fill-style gcontext) :solid
(xlib:gcontext-foreground gcontext) white))
(100
(setf (xlib:gcontext-fill-style gcontext) :solid
(xlib:gcontext-foreground gcontext) black))
(otherwise
(setf (xlib:gcontext-fill-style gcontext) :opaque-stippled
(xlib:gcontext-foreground gcontext) black
(xlib:gcontext-background gcontext) white
(xlib:gcontext-stipple gcontext)
(convert-shade root gcontext shade)))))
(defun convert-shade (root gc shade)
;; Much of this code originally comes from Stan Lanning.
(multiple-value-bind (width height) (xlib:query-best-stipple 8 8 root)
(let* ((width (cond ((< width 4) 4)
((evenp width) width)
(t (+ 1 width))))
(height (cond ((< height 4) 4)
((evenp height) height)
(t (+ 1 height))))
(stipple (xlib:create-pixmap :width width :height height :depth 1
:drawable root))
;; To draw on the stipple, we get an "image" the size of the
;; stipple, draw on it, and then paint that image back on the
;; stipple.
(image (xlib:get-image stipple :x 0 :y 0
:width width :height height))
(image-data (xlib::image-x-data image)))
;; The image-data is a vector that can be treated as a two-d array of
;; bytes, where each row of the pixmap is contained in a row of the array.
;; For whatever reasons, X might pad the rows with extra bytes, so the
;; number of columns that contain "real" data is likely smaller than the
;; number of columns in the array. So... we make a two-d array displaced
;; to this image-data, and then treat it as if it contained just the
;; number of bytes that contain "real" info.
(let ((nrows (xlib:image-height image))
(ncolumns (/ (xlib:image-width image) 8))
(array (make-array (list (/ (array-total-size image-data)
(xlib::image-x-bytes-per-line image))
(xlib::image-x-bytes-per-line image))
:element-type (array-element-type image-data)
:displaced-to image-data)))
;; Some special cases that we handle, to ensure a pleasing appearence.
;; We only deal with shades <= 50%; darker shades are computed as the
;; complement shade.
(case (if (> shade 50)
(- 100 shade)
shade)
(50 (dotimes (row nrows)
(let ((byte (ecase (rem row 2)
(0 #b10101010)
(1 #b01010101))))
(dotimes (column ncolumns)
(setf (aref array row column) byte)))))
(37.5 (dotimes (row nrows)
(let ((byte (ecase (rem row 8)
(0 #b10101011)
(1 #b01011101)
(2 #b11101010)
(3 #b01010111)
(4 #b10111010)
(5 #b11010101)
(6 #b10101110)
(7 #b01110101))))
(dotimes (column ncolumns)
(setf (aref array row column) byte)))))
(25 (dotimes (row nrows)
(let ((byte (ecase (rem row 4)
(0 #b01000100)
(1 #b00100010)
(2 #b10001000)
(3 #b00010001))))
(dotimes (column ncolumns)
(setf (aref array row column) byte)))))
(12.5 (dotimes (row nrows)
(let ((byte (ecase (rem row 8)
(0 #b00000001)
(1 #b00001000)
(2 #b01000000)
(3 #b00000010)
(4 #b00010000)
(5 #b10000000)
(6 #b00000100)
(7 #b00100000))))
(dotimes (column ncolumns)
(setf (aref array row column) byte)))))
(7.25 (dotimes (row nrows)
(let ((byte (ecase (rem row 8)
(0 #b00000001)
(1 #b00000000)
(2 #b00010000)
(3 #b00000000)
(4 #b01000000)
(5 #b00000000)
(6 #b00000100)
(7 #b00000000))))
(dotimes (column ncolumns)
(setf (aref array row column) byte)))))
(0 (dotimes (row nrows)
(dotimes (column ncolumns)
(setf (aref array row column) #b00000000))))
(t (error "~%Can't yet handle arbitrary shades")))
;; If the shade is > 50%, it is the inverse of the complement shade,
;; so...
(when (> shade 50)
(dotimes (row nrows)
(dotimes (column ncolumns)
(setf (aref array row column)
(mask-field (byte 8 0)
(lognot (aref array row column)))))))
(xlib:put-image stipple gc image :x 0 :y 0)
stipple))))
--
Ramana Rao (Internet: Rao@arisia.xerox.com)
Xerox Palo Alto Research Center (PARC)
3333 Coyote Hill Road; Palo Alto, CA, USA 94304
TEL: 415-494-4716; FAX: 415-494-4334