OBJECT-ORIENTED CLX

[Warren Harris <harris%hplwhh@hplabs.hp.com>]

The following is a very rough outline of how CLX might look if it were
an object-oriented program.  We've been kicking this idea around in our lab
for a little while now and felt it was time to get some real feedback on
whether this was a good idea or not.  All comments are welcome.


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; AN OBJECT-ORIENTED CLX 
;;;;
;;;;    (A ROUGH DRAFT)
;;;;
;;;; Warren Harris, HP Labs
;;;;
#|

This document is an attempt to address some of the issues of combining CLX
with object-oriented programming.  It is the desire that this "low level"
interface to X11 will be sufficient to implement higher level extensions
such as those found in CLUE in a convenient and extensible way.

Throughout this document we make use of the CLOS meta-object protocol.  In
particular, a new meta-class is defined, X-CLASS, which makes convenient
the specification of objects allocated external to the Lisp process (in the
X server).  In this meta-class, a new slot-descriptor is defined,
X-SLOT-DESCRIPTOR, which allows an additional strategy of allocation,
namely :X-SERVER.  Specifying :X-SERVER allocation does not reserve space
in the actual CLOS object for the value, but instead defines reader and
writer methods which actually perform the X protocol requests.  (There may
be other slot-descriptor declarations necessary in the actual
implementation, such as which position the argument takes in the protocol
request, or how to convert between the Lisp representation and the protocol
representation.  For more difficult request functions, explicit DEFMETHOD
forms must be written.  However, it is still beneficial to think of these
attributes as "slots", allocated in the X server process.)

One difficulty with the old CLX model is that some objects are created in
the server process simultaneous with their creation in the Lisp process.
This includes WINDOWs, PIXMAPs, COLORMAPs and CURSORs.  Other objects are
created in the server process some time after their creation in the Lisp
process.  This includes DISPLAYs, and FONTs.  This object-oriented
version of CLX takes the uniform approach of delaying the creation of all
server allocated objects until the OPEN-OBJECT generic function is called.
This has some distinct advantages:

	1. It allows MAKE-INSTANCE and the standard CLOS initialization to
	be used to create all CLX objects. 

	2. It allows the objects' states to be remembered between Lisp
	sessions.  

This second point is a significant advantage since Lisp images can
typically be stored on disk via some SAVE-WORLD command.  Lisp images with
saved CLX objects can then be recreated numerous times.  (Note: the way
this works is that while a window is open, all :X-SERVER allocated instance
variable accesses go through the X server.  When the window is closed, the
values of these slots as they currently exist in the server are re-cached
in the lisp objects before the server object is actually destroyed.  That
way, the next time the window is opened the state is remembered.)

Although this document describes vaporware at this point, it should be
pointed out that all these concepts have been verified in an X10 Lisp
interface developed by HP Labs called "Xenon".  (Xenon is not distributable
due to its heavy reliance on HP-CL's foreign function mechanism.)

This document has also left out all the actual CLX function and macros.
The intention is that most of the functions in the existing CLX document
will become generic.  They were not included here at the present time due
to lazyness.

|#
;;; X-OBJECT
;;;
;;; This class represents the root of the CLX object hierarchy.

(defclass x-object ()
  ()
  (:metaclass x-class))

;;; EXTERNAL-OBJECT
;;;
;;; These are objects which are allocated in the X server process.  They must
;;; be explicitly opened and closed by the Lisp process.

(defclass external-object (x-object)
  ((xid
    :type card32
    :allocation :instance)
   (display
    :type display
    :reader display
    :allocation :instance))
  (:metaclass x-class))

(defgeneric open-object (external-object))

(defgeneric close-object (external-object))

(defgeneric open-p (external-object))  

;;; X-PLIST-MIXIN
;;;
;;; These are objects with external X properties.  It is an error to
;;; instantiate this class directly.

(defclass x-plist-mixin (x-object)
  ((x-plist
    :type list
    :initform nil
    :initarg :x-plist
    :accessor x-plist
    :allocation :x-server))
  (:metaclass x-class))

(defgeneric get-x-prop (x-plist-object x-prop-name
			&key type (start 0) end delete-p (result-type 'list)
			     transform)
  (declare (type x-plist-mixin x-plist-object)
	   (type xatom property)
	   (type (or null xatom) type)
	   (type array-index start)
	   (type (or null array-index) end)
	   (type boolean delete-p)
	   (type type result-type)
	   (type (or null (function (integer) t)) transform)
	   (values data type format bytes-after)))

(defgeneric set-x-prop (x-plist-object x-prop-name x-prop-value
			type format
			&key (mode :replace) (start 0) end transform)
  (declare (type x-plist-mixin x-plist-object)
	   (type xatom x-prop-name type)
	   (type (member 8 16 32) format)
	   (type sequence x-prop-value)
	   (type (member :replace :prepend :append) mode)
	   (type array-index start)
	   (type (or null array-index) end)
	   (type (or null (function (t) integer)) transform)))

(defgeneric rem-x-prop (x-plist-object x-prop-name)
  (declare (type x-plist-mixin x-plist-object)
	   (type xatom x-prop-name)))

;;; DRAWABLE

(defclass drawable (x-plist-mixin
		    external-object)
  ((parent
    :type int16
    :initform 0
    :initarg :parent
    :reader parent
    :allocation :x-server)
   (outside-left
    :type int16
    :initform 0
    :initarg :outside-left
    :accessor outside-left
    :allocation :x-server)
   (outside-top
    :type int16
    :initform 0
    :initarg :outside-top
    :accessor outside-top
    :allocation :x-server)
   (inside-width
    :type card16
    :initform 1
    :initarg :inside-width
    :accessor inside-width
    :allocation :x-server)
   (inside-height
    :type card16
    :initform 1
    :initarg :inside-height
    :accessor inside-height
    :allocation :x-server)
   (border-width
    :type card16
    :initform 0
    :initarg :border-width
    :accessor border-width
    :allocation :x-server)
   (depth
    :type card16
    :initform 0
    :initarg :depth
    :accessor depth
    :allocation :x-server))
  (:metaclass x-class))

;;; WINDOW

(defclass window (drawable)
  ((i/o-class
    :type (member :copy :input-output :input-only)
    :initform :copy
    :initarg :i/o-class
    :reader i/o-class
    :allocation :x-server)
   (visual
    :type (or (member :copy) visual)
    :initform :copy
    :initarg :visual
    :reader visual
    :allocation :x-server)
   (background-color
    :type (or null (member :none :parent-relative) pixel pixmap)
    :initform nil
    :initarg :background-color
    :accessor background-color
    :allocation :x-server)
   (border-color
    :type (or null (member :copy) pixel pixmap)
    :initform nil
    :initarg :border-color
    :accessor border-color
    :allocation :x-server)
   (window-gravity
    :type (or null win-gravity)
    :initform nil
    :initarg :window-gravity
    :accessor window-gravity
    :allocation :x-server)
   (bit-gravity
    :type (or null bit-gravity)
    :initform nil
    :initarg :bit-gravity
    :accessor bit-gravity
    :allocation :x-server)
   (backing-store
    :type (or null (member :not-useful :when-mapped :always))
    :initform nil
    :initarg :backing-store
    :accessor backing-store
    :allocation :x-server)
   (backing-planes
    :type (or null pixel)
    :initform nil
    :initarg :backing-planes
    :accessor backing-planes
    :allocation :x-server)
   (backing-color
    :type (or null pixel)
    :initform nil
    :initarg :backing-color
    :accessor backing-color
    :allocation :x-server)
   (save-under
    :type (or null (member :on :off))
    :initform nil
    :initarg :save-under
    :accessor save-under
    :allocation :x-server)
   (event-mask
    :type (or null event-mask)
    :initform nil
    :initarg :event-mask
    :accessor event-mask
    :allocation :x-server)
   (do-not-propagate-mask
    :type (or null device-event-mask)
    :initform nil
    :initarg :do-not-propagate-mask
    :accessor do-not-propagate-mask
    :allocation :x-server)
   (override-redirect
    :type (or null (member :on :off))
    :initform nil
    :initarg :override-redirect
    :accessor override-redirect
    :allocation :x-server)
   (colormap
    :type (or null (member :copy) colormap)
    :initform nil
    :initarg :colormap
    :accessor colormap
    :allocation :x-server)
   (cursor
    :type (or null (member :none) cursor)
    :initform nil
    :initarg :cursor
    :accessor cursor
    :allocation :x-server)
   (colormap-installed-p
    :type boolean
    :reader colormap-installed-p
    :allocation :x-server)
   (all-event-masks
    :type mask32
    :reader all-event-masks
    :allocation :x-server)
   (map-state
    :type (member :unmapped :unviewable :viewable)
    :reader map-state
    :allocation :x-server))
  (:metaclass x-class))

(defgeneric (setf priority) (mode window &optional sibling))

;;; PIXMAP

(defclass pixmap (drawable)
  ()
  (:metaclass x-class))

;;; DISPLAY

(defclass display (x-plist-mixin
		   external-object)
  ((protocol-major-version
    :type card16
    :reader protocol-major-version
    :allocation :x-server)
   (protocol-minor-version
    :type card16
    :reader protocol-minor-version
    :allocation :x-server)
   (vendor-name
    :type string
    :reader vendor-name
    :allocation :x-server)
   (release-number
    :type card32
    :reader release-number
    :allocation :x-server)
   (image-lsb-first-p
    :type boolean
    :reader image-lsb-first-p
    :allocation :x-server)
   (bitmap-formap
    :type bitmap-format
    :reader bitmap-formap
    :allocation :x-server)
   (pixmap-formats
    :type (list pixmap-format)
    :reader pixmap-formats
    :allocation :x-server)
   (roots
    :type (list screen)
    :reader roots
    :allocation :x-server)
   (motion-buffer-size
    :type card32
    :reader motion-buffer-size
    :allocation :x-server)
   (max-request-length
    :type card16
    :reader max-request-length
    :allocation :x-server)
   (min-keycode
    :type card8
    :reader min-keycode
    :allocation :x-server)
   (max-keycode
    :type card8
    :reader max-keycode
    :allocation :x-server)
   (error-handler
    :type (or (sequence (function (&rest key-vals)))
	      (function (&rest key-vals)))
    :initform #'display-handle-error
    :initarg :error-handler
    :accessor error-handler
    :allocation :x-server)
   (flush-handler
    ;; this was called "display-after-function"
    :type (or null (function (display)))
    :initform nil
    :initarg :flush-handler
    :accessor flush-handler
    :allocation :x-server))
  (:metaclass x-class))

;;; SCREEN
;;;
;;; Screens need not be explicitly created and opened.  In some sense, they
;;; are substructures of display objects.

(defclass screen (x-object)
  ((root
    :type window
    :reader root
    :initarg :root
    :reader root
    :allocation :x-server)
   (width 
    :type card16
    :initarg :width
    :reader width
    :allocation :x-server)
   (height
    :type card16
    :initarg :height
    :reader height
    :allocation :x-server)
   (width-in-millimeters
    :type card16
    :initarg :width-in-millimeters
    :reader width-in-millimeters
    :allocation :x-server)
   (height-in-millimeters
    :type card16
    :initarg :height-in-millimeters
    :reader height-in-millimeters
    :allocation :x-server)
   (depths
    :type (alist (image-depth depth) ((list visual-info) visuals))
    :initarg :depths
    :reader depths
    :allocation :x-server)
   (root-depth
    :type image-depth
    :initarg :root-depth
    :reader root-depth
    :allocation :x-server)
   (root-visual
    :type card29
    :initarg :root-visual
    :reader root-visual
    :allocation :x-server)
   (default-colormap
     :type colormap
     :initarg :default-colormap
     :reader default-colormap
     :allocation :x-server)
   (white-pixel
    :type pixel
    :initarg :white-pixel
    :reader white-pixel
    :allocation :x-server)
   (black-pixel
    :type pixel
    :initarg :black-pixel
    :reader black-pixel
    :allocation :x-server)
   (min-installed-maps
    :type card16
    :initarg :min-installed-maps
    :reader min-installed-maps
    :allocation :x-server)
   (max-installed-maps
    :type card16
    :initarg :max-installed-maps
    :reader max-installed-maps
    :allocation :x-server)
   (backing-stores
    :type (member :never :when-mapped :always)
    :initarg :backing-stores
    :reader backing-stores
    :allocation :x-server)
   (save-unders-p
    :type boolean
    :initarg :save-unders-p
    :reader save-unders-p
    :allocation :x-server)
   (event-mask-at-open
    :type mask32
    :initarg :event-mask-at-open
    :reader event-mask-at-open
    :allocation :x-server))
  (:metaclass x-class))

;;; GCONTEXT

(defclass gcontext (external-object)
  ((drawable
    :type drawable
    :initform nil
    :initarg :drawable
    :accessor drawable
    :allocation :x-server)
   (boolean-function
    :type (or null boole-constant)
    :initform nil
    :initarg :boolean-function
    :accessor boolean-function
    :allocation :x-server)
   (plane-mask
    :type (or null pixel)
    :initform nil
    :initarg :plane-mask
    :accessor plane-mask
    :allocation :x-server)
   (foreground-color
    :type (or null pixel)
    :initform nil
    :initarg :foreground-color
    :accessor foreground-color
    :allocation :x-server)
   (background-color
    :type (or null pixel)
    :initform nil
    :initarg :background-color
    :accessor background-color
    :allocation :x-server)
   (line-width
    :type (or null card16)
    :initform nil
    :initarg :line-width
    :accessor line-width
    :allocation :x-server)
   (line-style
    :type (or null (member :solid :dash :double-dash))
    :initform nil
    :initarg :line-style
    :accessor line-style
    :allocation :x-server)
   (cap-style
    :type (or null (member :not-last :butt :round :projecting))
    :initform nil
    :initarg :cap-style
    :accessor cap-style
    :allocation :x-server)
   (join-style
    :type (or null (member :miter :round :bevel))
    :initform nil
    :initarg :join-style
    :accessor join-style
    :allocation :x-server)
   (fill-style 
    :type (or null (member :solid :tiled :opaque-stippled :stippled))
    :initform nil
    :initarg :fill-style 
    :accessor fill-style 
    :allocation :x-server)
   (fill-rule
    :type (or null (member :even-odd :winding))
    :initform nil
    :initarg :fill-rule
    :accessor fill-rule
    :allocation :x-server)
   (arc-mode
    :type (or null (member :chord :pie-slice))
    :initform nil
    :initarg :arc-mode
    :accessor arc-mode
    :allocation :x-server)
   (tile
    :type (or null pixmap)
    :initform nil
    :initarg :tile
    :accessor tile
    :allocation :x-server)
   (stipple
    :type (or null pixmap)
    :initform nil
    :initarg :stipple
    :accessor stipple
    :allocation :x-server)
   (ts-x
    :type (or null int16)
    :initform nil
    :initarg :ts-x
    :accessor ts-x
    :allocation :x-server)
   (ts-y
    :type (or null int16)
    :initform nil
    :initarg :ts-y
    :accessor ts-y
    :allocation :x-server)
   (font
    :type (or null fontable)
    :initform nil
    :initarg :font
    :accessor font
    :allocation :x-server)
   (subwindow-mode
    :type (or null (member :clip-by-children :include-inferiors))
    :initform nil
    :initarg :subwindow-mode
    :accessor subwindow-mode
    :allocation :x-server)
   (exposures
    :type (or null (member :on :off))
    :initform nil
    :initarg :exposures
    :accessor exposures
    :allocation :x-server)
   (clip-x
    :type (or null int16)
    :initform nil
    :initarg :clip-x
    :accessor clip-x
    :allocation :x-server)
   (clip-y
    :type (or null int16)
    :initform nil
    :initarg :clip-y
    :accessor clip-y
    :allocation :x-server)
   (clip-mask
    :type (or null (member :none) pixmap rect-seq)
    :initform nil
    :initarg :clip-mask
    :accessor clip-mask
    :allocation :x-server)
   (clip-ordering
    :type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded))
    :initform nil
    :initarg :clip-ordering
    :accessor clip-ordering
    :allocation :x-server)
   (dash-offset
    :type (or null card16)
    :initform nil
    :initarg :dash-offset
    :accessor dash-offset
    :allocation :x-server)
   (dashes
    :type (or null (or card8 (sequence card8)))
    :initform nil
    :initarg :dashes
    :accessor dashes
    :allocation :x-server)
   (cache-p
    :type boolean
    :initform t
    :initarg :cache-p
    :accessor cache-p
    :allocation :x-server))
  (:metaclass x-class))

;;; CURSOR

(defclass cursor (external-object)
  ((source
    :type pixmap
    :initarg :source
    :reader source
    :allocation :x-server)
   (mask
    :type (or null pixmap)
    :initform nil
    :initarg :mask
    :reader mask
    :allocation :x-server)
   (outside-left
    :type card16
    :initarg :outside-left
    :reader outside-left
    :allocation :x-server)
   (outside-top
    :type card16
    :initarg :outside-top
    :reader outside-top
    :allocation :x-server)
   (foreground-color
    :type color
    :initarg :foreground-color
    :accessor foreground-color
    :allocation :x-server)
   (background-color
    :type color
    :initarg :background-color
    :accessor background-color
    :allocation :x-server))
  (:metaclass x-class))

;;; GLIPH-CURSOR

(defclass gliph-cursor (cursor)
  ((source-font
    :type font
    :initarg :source-font
    :reader source-font
    :allocation :x-server)
   (source-char
    :type card16
    :initarg :source-char
    :reader source-char
    :allocation :x-server)
   (mask-font
    :type font
    :initarg :mask-font
    :reader mask-font
    :allocation :x-server)
   (mask-char
    :type card16
    :initarg :mask-char
    :reader mask-char
    :allocation :x-server))
  (:metaclass x-class))

;;; FONT

(defclass font (x-plist-mixin
		external-object)
  ((display
    :type display
    :initarg :display
    :reader display
    :allocation :x-server)
   (name
    :type stringable
    :initarg :name
    :reader name
    :allocation :x-server)
   (direction
    :type draw-direction
    :reader direction
    :allocation :x-server)
   (min-char
    :type card16
    :reader min-char
    :allocation :x-server)
   (max-char
    :type card16
    :reader max-char
    :allocation :x-server)
   (min-byte1
    :type card8
    :reader min-byte1
    :allocation :x-server)
   (max-byte1
    :type card8
    :reader max-byte1
    :allocation :x-server)
   (min-byte2
    :type card8
    :reader min-byte2
    :allocation :x-server)
   (max-byte2
    :type card8
    :reader max-byte2
    :allocation :x-server)
   (all-chars-exist-p
    :type boolean
    :reader all-chars-exist-p
    :allocation :x-server)
   (default-char
    :type card16
    :reader default-char
    :allocation :x-server)
   (ascent
    :type int16
    :reader ascent
    :allocation :x-server)
   (decent
    :type int16
    :reader decent
    :allocation :x-server))
  (:metaclass x-class))

;;; COLORMAP

(defclass colormap (external-object)
  ((visual
    :type card29
    :initarg :visual
    :reader visual
    :allocation :x-server)
   (window
    :type window
    :initarg :window
    :reader window
    :allocation :x-server)
   (alloc-p
    :type boolean
    :initarg :alloc-p
    :reader alloc-p
    :allocation :x-server))
  (:metaclass x-class))

;;; COLOR

(defclass color (external-object)
  ((red
    :type rgb-val
    :initform 0.0
    :initarg :red
    :accessor red
    :allocation :x-server)
   (green
    :type rgb-val
    :initform 0.0
    :initarg :green
    :accessor green
    :allocation :x-server)
   (blue
    :type rgb-val
    :initform 0.0
    :initarg :blue
    :accessor blue
    :allocation :x-server))   
  (:metaclass x-class))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#|

	HANDLING X EVENTS

Events are handled by this system in one of two ways, by the EVENT-CASE
macro and by the PROCESS-EVENT function.  EVENT-CASE gives the user
localized control over how X events are handled within the lexical scope of
a program.  Since I am proposing little or no change to the existing CLX
EVENT-CASE macro, I will leave it out of this discussion.

PROCESS-EVENT invokes the default event handlers for a given class of
window.  This is different from the current CLX in that handlers are
associated with window classes instead of just display objects.  For each X
event type there is a corresponding handler method.  This method is invoked
by dispatching off of the type of the event-window and the type of the
event.  These methods would not be called by the user explicitly, but would
be called from within the PROCESS-EVENT function.

There are three alternatives to how to organize this multimethod dispatch:

1.  By defining one event handler method for each type of event.  Each of
these methods would do a single dispatch off of the type of window.  (This
was the approach taken by Xenon.)  The dispatch which invokes the method
corresponding to the event type is handled by magic inside PROCESS-EVENT.
Here are some examples:

(defmethod handle-key-press-event ((w window)
				   child
				   same-screen-p
				   x y root-x root-y
				   state
				   time
				   code)
  ...)

(defmethod handle-unmap-notify-event ((w window) configure-p)
  ...)

One advantage of this approach is that the user can write event handler
methods which dispatch off of other arguments as well.  Here is an example
of how to use this type of handler:

(defclass active-border-window (window)
  ((event-mask
    :initform '(:enter-notify :leave-notify))
   (active-color
    :type color
    :accessor active-color)
   (inactive-color
    :type color
    :accessor inactive-color)))

(defmethod handle-enter-notify-event ((w active-border-window) ...)
  (with-slots (active-color) w
    (setf (border-color w) active-color)))

(defmethod handle-leave-notify-event ((w active-border-window) ...)
  (with-slots (inactive-color) w
    (setf (border-color w) inactive-color)))

These methods, in some sense, become part of the class definition.

2. By using a single CLOS multimethod which does two dispatches:  one off
of the type of window, and an EQL dispatch off of the event keyword.  The
advantage of this approach is that the keywords correspond to the keywords
in the EVENT-CASE macro.  Here are some examples of these methods:

(defmethod handle-event ((w window)
			 (event-keyword (eql :key-press))
			 &rest args)
  ...)

(defmethod handle-event ((w window)
			 (event-keyword (eql :key-release))
			 &rest args)
  ...)

The disadvantage of this is the &REST argument.  This is necessary because
not all event handlers are called with the same arguments.  It would be up
to the user to decipher the position of an argument in the ARGS list.  An
alternative to this might be to use keyword arguments with &ALLOW-OTHER-KEYS.


3. The final approach would be to define actual event classes and dispatch
off the window instance and the event instance.  (I believe XCL took this
approach.)  Here's an example:

(defclass enter-notify-event (x-event)
  ((window
    :type window
    :accessor window)
   (child
    :type (or null window)
    :accessor child)
   ...))

(defmethod handle-event ((w window) (e enter-notify-event))
  ...)

The advantage of this approach is that it makes the implicit hierarchy of X
event types explicit.  Making this hierarchy explicit allows us to do some
interesting method lookup defaulting.  One could imagine exploiting
multiple inheritance to provide increased flexibility:

(defclass key-press-event (key-event press-event)
  ...)

These new abstract event classes could be used by very general methods:

(defmethod handle-event ((w foo-window) (e press-event))
  (format t "Something was pressed.~%"))

One question with this approach is how to map out this event hierarchy in
lisp.  The X11 server doesn't really make any use of the hierarchy, and the
user may be fooled into thinking that subclassing an existing event class
would magically begin being utilized by CLX.

Another disadvantage to this is that generating CLOS objects for each X
event can be very expensive.  Although using resource caches is possible
this still seems to be more trouble than its worth.

I recommend alternative 1.

|#

Respectfully submitted,

Warren Harris