;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XLIB; -*- ;;; --------------------------------------------------------------------------- ;;; Title: X11 Shape extension ;;; Created: 1999-05-14 11:31 ;;; Author: Gilbert Baumann <unk6@rz.uni-karlsruhe.de> ;;; --------------------------------------------------------------------------- ;;; (c) copyright 1999 by Gilbert Baumann ;;; ;;; Permission is granted to any individual or institution to use, ;;; copy, modify, and distribute this software, provided that this ;;; complete copyright and permission notice is maintained, intact, in ;;; all copies and supporting documentation. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. ;;; ;;; Use xc/doc/hardcopy/Xext/shape.PS.gz obtainable from e.g. ;; ftp://ftp.xfree86.org/pub/XFree86/current/untarred/xc/hardcopy/Xext/shape.PS.gz (in-package :xlib) (export '(shape-query-version shape-rectangles shape-mask shape-combine shape-offset shape-query-extents shape-select-input shape-input-selected-p shape-get-rectangles) :xlib) (define-extension "SHAPE" :events (:shape-notify)) (declare-event :shape-notify ((data (member8 :bounding :clip)) kind) ;shape kind (card16 sequence) (window (window event-window)) ;affected window (int16 x) ;extents (int16 y) (card16 width) (card16 height) ((or null card32) time) ;timestamp (boolean shaped-p)) (defun encode-shape-kind (kind) (ecase kind (:bounding 0) (:clip 1))) (defun encode-shape-operation (operation) (ecase operation (:set 0) (:union 1) (:interset 2) (:subtract 3) (:invert 4))) (defun encode-shape-rectangle-ordering (ordering) (ecase ordering ((:unsorted :un-sorted nil) 0) ((:y-sorted) 1) ((:yx-sorted) 2) ((:yx-banded) 3))) (defun shape-query-version (display) (with-buffer-request-and-reply (display (extension-opcode display "SHAPE") nil :sizes 16) ((data 0)) (values (card16-get 8) (card16-get 10)))) (defun shape-rectangles (window rectangles &key (kind :bounding) (x-offset 0) (y-offset 0) (operation :set) (ordering :unsorted)) (let* ((display (xlib:window-display window))) (with-buffer-request (display (extension-opcode display "SHAPE")) (data 1) (card8 (encode-shape-operation operation)) (card8 (encode-shape-kind kind)) (card8 (encode-shape-rectangle-ordering ordering)) (card8 0) ;unused (window window) (int16 x-offset) (int16 y-offset) ((sequence :format int16) rectangles)))) (defun shape-mask (window pixmap &key (kind :bounding) (x-offset 0) (y-offset 0) (operation :set)) (let* ((display (xlib:window-display window))) (with-buffer-request (display (extension-opcode display "SHAPE")) (data 2) (card8 (encode-shape-operation operation)) (card8 (encode-shape-kind kind)) (card16 0) ;unused (window window) (int16 x-offset) (int16 y-offset) ((or pixmap (member :none)) pixmap)))) (defun shape-combine (window source-window &key (kind :bounding) (source-kind :bounding) (x-offset 0) (y-offset 0) (operation :set)) (let* ((display (xlib:window-display window))) (with-buffer-request (display (extension-opcode display "SHAPE")) (data 3) (card8 (encode-shape-operation operation)) (card8 (encode-shape-kind kind)) (card8 (encode-shape-kind source-kind)) (card8 0) ;unused (window window) (int16 x-offset) (int16 y-offset) (window source-window)))) (defun shape-offset (window &key (kind :bounding) (x-offset 0) (y-offset 0)) (let* ((display (xlib:window-display window))) (with-buffer-request (display (extension-opcode display "SHAPE")) (data 4) (card8 (encode-shape-kind kind)) (card8 0) (card8 0) (card8 0) ;unused (window window) (int16 x-offset) (int16 y-offset)))) (defun shape-query-extents (window) (let* ((display (xlib:window-display window))) (with-buffer-request-and-reply (display (extension-opcode display "SHAPE") nil :sizes (8 16 32)) ((data 5) (window window)) (values (boolean-get 8) ;bounding shaped (boolean-get 9) ;clip shaped (int16-get 12) ;bounding shape extents x (int16-get 14) ;bounding shape extents y (card16-get 16) ;bounding shape extents width (card16-get 18) ;bounding shape extents height (int16-get 20) ;clip shape extents x (int16-get 22) ;clip shape extents y (card16-get 24) ;clip shape extents width (card16-get 26))))) ;clip shape extents height (defun shape-select-input (window selected-p) (let* ((display (window-display window))) (with-buffer-request (display (extension-opcode display "SHAPE")) (data 6) (window window) (boolean selected-p)) )) (defun shape-input-selected-p (window) (let* ((display (window-display window))) (with-buffer-request-and-reply (display (extension-opcode display "SHAPE") nil :sizes (8)) ((data 7) ;also wrong in documentation (window window)) (boolean-get 1)))) (defun shape-get-rectangles (window &optional (kind :bounding) (result-type 'list)) (let* ((display (window-display window))) (with-buffer-request-and-reply (display (extension-opcode display "SHAPE") nil :sizes (8 16 32)) ((data 8) ;this was wrong in the specification (window window) (card8 (ecase kind (:bounding 0) (:clip 1)))) (values (sequence-get :length (print (* 4 (card32-get 8))) :result-type result-type :format int16 :index *replysize*) (ecase (card8-get 1) (0 :unsorted) (1 :y-sorted) (2 :yx-sorted) (3 :yx-banded) )))))