;;;
;;;              Copyright 1990 by Digital Equipment AB, Sweden
;;;
;;;                                  and
;;;
;;;                       Hakan Huss and Johan Ihren
;;;
;;;                           All Rights Reserved
;;;
;;;    Permission to use, copy, modify, and distribute this software and
;;;    its documentation for any purpose and without fee is hereby
;;;    granted, provided that the above copyright notice appear in all
;;;    copies and that both that copyright notice and this permis-
;;;    sion notice appear in supporting documentation, and that the
;;;    names of the copyright holders not be used in advertising in
;;;    publicity pertaining to distribution of the software without
;;;    specific, written prior permission. The copyright holders make no
;;;    representations about the suitability of this software for any
;;;    purpose. It is provided "as is" without express or implied warranty.
;;;
;;;    THE COPYRIGHT HOLDERS DISCLAIM ALL WARRANTIES WITH REGARD TO
;;;    THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANT-
;;;    ABILITY AND FITNESS, IN NO EVENT SHALL THE COPYRIGHT HOLDERS
;;;    BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
;;;    ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
;;;    PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER
;;;    TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE
;;;    OR PERFORMANCE OF THIS SOFTWARE.
;;;
;;;    Authors: Hakan Huss, KTH and Johan Ihren, KTH
;;;

;;; $Header: /deneb/src0/johani/scix-0.96/src/RCS/masks.sc,v 1.3 90/04/01 13:50:34 johani Exp $
;;;
;;; masks.sc -- Formats of the various bit- and value-masks of X. Calls are of
;;;             the form
;;;                (make-<name>-mask 'id ...)
;;;             for bitmasks, and
;;;                (make-<name>-value-mask '(id . val) ...)
;;;             for value-masks.

(module masks (top-level make-event-mask make-pointerevent-mask
			 make-deviceevent-mask make-keybutmask-mask
			 make-keymask-mask make-window-value-mask
			 make-configure-value-mask make-gc-value-mask
			 make-color-mask make-keyboard-value-mask))

(include "../include/types.sch")
(include "../include/util.sch")
(include "../include/lowlevel.sch")

(include "../macros/extend-syntax.sc")
(include "../macros/mask-object.sc")

(define *mask-constants*
   '((None . 0)
     (ParentRelative . 1)
     (CopyFromParent . 0)
     (NotUseful . 0)
     (WhenMapped . 1)
     (Always . 2)
     (Above . 0)
     (Below . 1)
     (TopIf . 2)
     (BottomIf . 3)
     (Opposite . 4)
     (Clear . 0)
     (And . 1)
     (AndReverse . 2)
     (Copy . 3)
     (AndInverted . 4)
     (NoOp . 5)
     (Xor . 6)
     (Or . 7)
     (Nor . 8)
     (Equiv . 9)
     (Invert . 10)
     (OrReverse . 11)
     (CopyInverted . 12)
     (OrInverted . 13)
     (Nand . 14)
     (Set . 15)
     (Solid . 0)
     (OnOffDash . 1)
     (DoubleDash . 2)
     (NotLast . 0)
     (Butt . 1)
     (RoundCap . 2)	; RoundCap and RoundJoin should both be named Round,
     (Projecting . 3)
     (Miter . 0)
     (RoundJoin . 1)	; but since they aren't mapped onto the same value...
     (Bevel . 2)
     (Tiled . 1)
     (Stippled . 2)
     (OpaqueStippled . 3)
     (EvenOdd . 0)
     (Winding . 1)
     (ClipByChildren . 0)
     (IncludeInferiors . 1)
     (Chord . 0)
     (PieSlice . 1)
     (Off . 0)
     (On . 1)
     (Default . 2) ))

(define (make-event-mask . initial-settings)
  (let ((the-mask (make-mask (KeyPress
			      KeyRelease
			      ButtonPress
			      ButtonRelease
			      EnterWindow
			      LeaveWindow
			      PointerMotion
			      PointerMotionHint
			      Button1Motion
			      Button2Motion
			      Button3Motion
			      Button4Motion
			      Button5Motion
			      ButtonMotion
			      KeyMapState
			      Exposure
			      VisibilityChange
			      StructureNotify
			      ResizeRedirect
			      SubstructureNotify
			      SubstructureRedirect
			      FocusChange
			      PropertyChange
			      ColormapChange
			      OwnerGrabButton))))
    (for-each (lambda (bit)
		(the-mask 'set! bit) )
	      initial-settings)
    the-mask))

(define (make-pointerevent-mask . initial-settings)
  (let ((the-mask (make-mask (unused
			      unused
			      ButtonPress
			      ButtonRelease
			      EnterWindow
			      LeaveWindow
			      PointerMotion
			      PointerMotionHint
			      Button1Motion
			      Button2Motion
			      Button3Motion
			      Button4Motion
			      Button5Motion
			      ButtonMotion
			      KeyMapState))))
    (for-each (lambda (bit)
		(the-mask 'set! bit) )
	      initial-settings)
    the-mask))

(define (make-deviceevent-mask . initial-settings)
  (let ((the-mask (make-mask (KeyPress
			      KeyRelease
			      ButtonPress
			      ButtonRelease
			      unused
			      unused
			      PointerMotion
			      unused
			      Button1Motion
			      Button2Motion
			      Button3Motion
			      Button4Motion
			      Button5Motion
			      ButtonMotion))))
    (for-each (lambda (bit)
		(the-mask 'set! bit) )
	      initial-settings)
    the-mask))

(define (make-keybutmask-mask . initial-settings)
  (let ((the-mask (make-mask (Shift
			      Lock
			      Control
			      Mod1
			      Mod2
			      Mod3
			      Mod4
			      Mod5
			      Button1
			      Button2
			      Button3
			      Button4
			      Button5))))
    (for-each (lambda (bit)
		(the-mask 'set! bit) )
	      initial-settings)
    the-mask))

(define (make-keymask-mask . initial-settings)
  (let ((the-mask (make-mask (Shift
			      Lock
			      Control
			      Mod1
			      Mod2
			      Mod3
			      Mod4
			      Mod5))))
    (for-each (lambda (bit)
		(the-mask 'set! bit) )
	      initial-settings)
    the-mask))

(define (make-window-value-mask . initial-settings)
  (let ((the-mask (make-mask ((background-pixmap     a-pixmap)
			      (background-pixel      a-color)
			      (border-pixmap         a-pixmap)
			      (border-pixel          a-color)
			      (bit-gravity           a-card8)
			      (win-gravity           a-card8)
			      (backing-store         a-card8)
			      (backing-planes        a-card32)
			      (backing-pixel         a-color)
			      (override-redirect     a-bool)
			      (save-under            a-bool)
			      (event-mask            (lambda (m buf)
						       (a-setofevent
							(if (procedure? m)
							    (m 'mask)
							    m)
							buf)))
			      (do-not-propagate-mask (lambda (m buf)
						       (a-setofdeviceevent
							(if (procedure? m)
							    (m 'mask)
							    m)
							buf)))
			      (colormap              a-colormap)
			      (cursor                a-cursor) ))))
    (for-each (lambda (ls)
		(the-mask 'set! ls) )
	      initial-settings)
    the-mask))

(define (make-configure-value-mask . initial-settings)
  (let ((the-mask (make-mask ((x            a-int16)
			      (y            a-int16)
			      (width        a-card16)
			      (height       a-card16)
			      (border-width a-card16)
			      (sibling      a-window)
			      (stack-mode   a-card8) ))))
    (for-each (lambda (ls)
		(the-mask 'set! ls) )
	      initial-settings)
    the-mask))

(define (make-GC-value-mask . initial-settings)
  (let ((the-mask (make-mask ((function              a-card8)
			      (plane-mask            a-card32)
			      (foreground            a-color)
			      (background            a-color)
			      (line-width            a-card16)
			      (line-style            a-card8)
			      (cap-style             a-card8)
			      (join-style            a-card8)
			      (fill-style            a-card8)
			      (fill-rule             a-card8)
			      (tile                  a-pixmap)
			      (stipple               a-pixmap)
			      (tile-stipple-x-origin a-int16)
			      (tile-stipple-y-origin a-int16)
			      (font                  a-font)
			      (subwindow-mode        a-card8)
			      (graphics-exposures    a-bool)
			      (clip-x-origin         a-int16)
			      (clip-y-origin         a-int16)
			      (clip-mask             a-pixmap)
			      (dash-offset           a-card16)
			      (dashes                a-card8)
			      (arc-mode              a-card8) ))))
    (for-each (lambda (ls)
		(the-mask 'set! ls) )
	      initial-settings)
    the-mask))

(define (make-keyboard-value-mask . initial-settings)
  (let ((the-mask (make-mask ((key-click-percent a-int8)
			      (bell-percent      a-int8)
			      (bell-pitch        a-int16)
			      (bell-duration     a-int16)
			      (led               a-card8)
			      (led-mode          a-card8)
			      (key               a-keycode)
			      (auto-repeat-mode  a-card8) ))))
    (for-each (lambda (ls)
		(the-mask 'set! ls) )
	      initial-settings)
    the-mask))