Paul.Birkel@K.GP.CS.CMU.EDU (11/12/87)
What with various sites porting TIs' implementation of CLX, a CLX version of the "hello worlds" example from David Rosenthal (at SUN) (thank you David!) would be useful: a) As a simple test case for a port. b) As an example of how to use CLX to generate a simple X11 application. c) As an interesting comparison on how much Common Lisp code with CLX it would take to replicate a given functionality in C code with Xlib. Any takers? Paul A. Birkel Dept. of Computer Science Carnegie-Mellon University Pittsburgh, PA 15213 pab@K.CS.CMU.EDU (412) 268-8893
Oren@home.csc.ti.COM (LaMott Oren) (11/13/87)
Any takers?
Here's one. I tried to duplicate the features of David Rosenthal's
program.
;;; -*- Mode:Lisp; Syntax: Common-lisp; Package:XLIB; Base:10 -*-
(defun hello-world (host &rest args &key (string "Hello World") (font "vrb-25"))
;; CLX demo, says STRING using FONT in its own window on HOST
(let* ((display (open-display host))
(screen (display-default-screen display))
(black (screen-black-pixel screen))
(white (screen-white-pixel screen))
(font (open-font display font))
(border 1) ; Minimum margin around the text
(width (+ (text-width font string) (* 2 border)))
(height (+ (max-char-ascent font) (max-char-descent font) (* 2 border)))
(x (truncate (- (screen-width screen) width) 2))
(y (truncate (- (screen-height screen) height) 2))
(window (create-window :parent (screen-root screen)
:x x :y y :width width :height height
:background black
:border white
:border-width 1
:colormap (screen-default-colormap screen)
:bit-gravity :center
:event-mask '(:exposure)))
(gcontext (create-gcontext :drawable window
:background black
:foreground white
:font font)))
;; Set window manager hints
(setf (wm-name window) string
(wm-icon-name window) string
(wm-command window) (list* 'hello-world host args)
(wm-normal-hints window) (make-wm-size-hints :x x :y y :width :width)
(wm-hints window) (make-wm-hints :input :off :initial-state :normal))
(map-window window)
;; Handle events
(unwind-protect
(loop
(event-case (display :force-output-p t)
(exposure ;; Come here on exposure events,
(window count) ;; binding WINDOW and COUNT from the event.
(when (zerop count) ;; Ignore all but the last exposure event.
(with-state (window)
(let ((x (truncate (- (drawable-width window) width) 2))
(y (truncate (- (+ (drawable-height window)
(max-char-ascent font))
(max-char-descent font))
2)))
;; Draw text centered in widnow
(clear-area window)
(draw-glyphs window gcontext x y string)))
;; Returning non-nil causes event-case to exit
t))))
;; Ensure display is closed when done
(close-display display))))
;; The following isn't part of CLX, put should be soon (see discussions
;; in the cl-windows@sail.stanford.edu mailing list).
;; I've included the accessor functions, even though only the defsetf's
;; are used by the hello-world function.
;;-----------------------------------------------------------------------------
;; Window manager property functions
(defun wm-name (window)
(declare (type window window)
(values string))
(get-property window :wm_name :type :string :result-type 'string :transform #'xlib:card8->char))
(defsetf wm-name (window) (name)
(declare (type window window)
(values string))
`(set-string-property ,window :wm_name ,name))
(defun set-string-property (window property string)
(declare (type window window)
(type keyword property)
(type stringable string))
(change-property window property (string string) :string 8 :transform #'xlib:char->card8)
string)
(defun wm-icon-name (window)
(declare (type window window)
(values string))
(get-property window :wm_icon_name :type :string
:result-type 'string :transform #'xlib:card8->char))
(defsetf wm-icon-name (window) (name)
`(set-string-property ,window :wm_icon_name ,name))
(defun wm-class (window)
(declare (type window window)
(values string))
(get-property window :wm_class :type :string
:result-type 'string :transform #'xlib:card8->char))
(defsetf wm-class (window) (name)
`(set-string-property ,window :wm_class ,name))
(defun wm-command (window)
;; Returns a list whose car is the command and
;; whose cdr is the list of arguments
(declare (type window window)
(values list))
(do* ((command-string (get-property window :wm_command :type :string
:result-type 'string :transform #'xlib:card8->char))
(command nil)
(start 0 (1+ end))
(end 0)
(len (length command-string)))
((>= start len) (nreverse command))
(setq end (position #.(int-char 0) command-string :start start))
(push (subseq command-string start end) command)))
(defsetf wm-command set-wm-command)
(defun set-wm-command (window command)
;; Uses PRIN1 to a string-stream with the following bindings:
;; (*print-length* nil) (*print-level* nil) (*print-radix* nil)
;; (*print-base* 10.) (*print-array* t) (*package* (find-package 'lisp))
;; each element of command is seperated with NULL characters.
;; This enables (mapcar #'read-from-string (wm-command window))
;; to recover a lisp command.
(declare (type window window)
(type list command))
(set-string-property window :wm_command
(with-output-to-string (stream)
(let ((*print-length* nil)
(*print-level* nil)
(*print-radix* nil)
(*print-base* 10.)
(*print-array* t)
(*package* (find-package 'lisp))
#+ti (ticl:*print-structure* t))
(dolist (c command)
(prin1 c stream)
(write-char #.(int-char 0) stream)))))
command)
;;-----------------------------------------------------------------------------
;; WM_HINTS
(defstruct wm-hints
(input nil :type (or null (member :off :on)))
(initial-state nil :type (or null (member :dont-care :normal :zoom :iconic :inactive)))
(icon-pixmap nil :type (or null pixmap))
(icon-window nil :type (or null window))
(icon-x nil :type (or null card16))
(icon-y nil :type (or null card16))
(icon-mask nil :type (or null pixmap))
(window-group nil :type (or null resource-id))
;; may be extended in the future
)
(defun wm-hints (window)
(declare (type window window)
(values wm-hints))
(let ((prop (get-property window :wm_hints :type :wm_hints :result-type 'vector)))
(when prop
(decode-wm-hints prop (window-display window)))))
(defsetf wm-hints set-wm-hints)
(defun set-wm-hints (window wm-hints)
(declare (type window window)
(type wm-hints wm-hints)
(values wm-hints))
(change-property window :wm_hints (encode-wm-hints wm-hints) :wm_hints 32)
wm-hints)
(defun decode-wm-hints (vector display)
(declare (type (simple-vector 9) vector)
(type display display)
(values wm-hints))
(let ((input-hint 0)
(state-hint 1)
(icon-pixmap-hint 2)
(icon-window-hint 3)
(icon-position-hint 4)
(icon-mask-hint 5)
(window-group-hint 6)
)
(let ((flags (aref vector 0))
(hints (make-wm-hints)))
(declare (type card16 flags)
(type wm-hints hints))
(compiler-let ((*buffer* 'display))
(when (logbitp input-hint flags)
(setf (wm-hints-input hints) (decode-type (member :off :on) (aref vector 1))))
(when (logbitp state-hint flags)
(setf (wm-hints-initial-state hints)
(decode-type (member :dont-care :normal :zoom :iconic :inactive)
(aref vector 2))))
(when (logbitp icon-pixmap-hint flags)
(setf (wm-hints-icon-pixmap hints) (decode-type pixmap (aref vector 3))))
(when (logbitp icon-window-hint flags)
(setf (wm-hints-icon-window hints) (decode-type window (aref vector 4))))
(when (logbitp icon-position-hint flags)
(setf (wm-hints-icon-x hints) (aref vector 5)
(wm-hints-icon-y hints) (aref vector 6)))
(when (logbitp icon-mask-hint flags)
(setf (wm-hints-icon-mask hints) (decode-type pixmap (aref vector 7))))
(when (logbitp window-group-hint flags)
(setf (wm-hints-window-group hints) (aref vector 8)))
hints))))
(defun encode-wm-hints (wm-hints)
(declare (type wm-hints wm-hints)
(values simple-vector))
(let ((input-hint #b1)
(state-hint #b10)
(icon-pixmap-hint #b100)
(icon-window-hint #b1000)
(icon-position-hint #b10000)
(icon-mask-hint #b100000)
(window-group-hint #b1000000)
)
(let ((vector (make-array 9 :initial-element 0))
(flags 0))
(declare (type (simple-vector 9) vector)
(type card16 flags))
(when (wm-hints-input wm-hints)
(setf flags input-hint
(aref vector 1) (encode-type (member :off :on) (wm-hints-input wm-hints))))
(when (wm-hints-initial-state wm-hints)
(setf flags (logior flags state-hint)
(aref vector 2) (encode-type (member :dont-care :normal :zoom :iconic :inactive)
(wm-hints-initial-state wm-hints))))
(when (wm-hints-icon-pixmap wm-hints)
(setf flags (logior flags icon-pixmap-hint)
(aref vector 3) (encode-type pixmap (wm-hints-icon-pixmap wm-hints))))
(when (wm-hints-icon-window wm-hints)
(setf flags (logior flags icon-window-hint)
(aref vector 4) (encode-type window (wm-hints-icon-window wm-hints))))
(when (and (wm-hints-icon-x wm-hints) (wm-hints-icon-y wm-hints))
(setf flags (logior flags icon-position-hint)
(aref vector 5) (encode-type card16 (wm-hints-icon-x wm-hints))
(aref vector 6) (encode-type card16 (wm-hints-icon-y wm-hints))))
(when (wm-hints-icon-mask wm-hints)
(setf flags (logior flags icon-mask-hint)
(aref vector 7) (encode-type pixmap (wm-hints-icon-mask wm-hints))))
(when (wm-hints-window-group wm-hints)
(setf flags (logior flags window-group-hint)
(aref vector 8) (wm-hints-window-group wm-hints)))
(setf (aref vector 0) flags)
vector)))
;;-----------------------------------------------------------------------------
;; WM_SIZE_HINTS
(defstruct wm-size-hints
;; Defaulted T to put the burden of remembering these on widget programmers.
(user-specified-position-p t :type boolean) ;; True when user specified x y
(user-specified-size-p t :type boolean) ;; True when user specified width height
(x nil :type (or null int16))
(y nil :type (or null int16))
(width nil :type (or null card16))
(height nil :type (or null card16))
(min-width nil :type (or null card16))
(min-height nil :type (or null card16))
(max-width nil :type (or null card16))
(max-height nil :type (or null card16))
(width-inc nil :type (or null card16))
(height-inc nil :type (or null card16))
(min-aspect nil :type (or null number))
(max-aspect nil :type (or null number)))
(defun wm-normal-hints (window)
(declare (type window window)
(values wm-size-hints))
(decode-wm-size-hints (get-property window :wm_normal_hints :type :wm_size_hints :result-type 'vector)))
(defsetf wm-normal-hints set-wm-normal-hints)
(defun set-wm-normal-hints (window hints)
(declare (type window window)
(type wm-size-hints hints)
(values wm-size-hints))
(change-property window :wm_normal_hints (encode-wm-size-hints hints) :wm_size_hints 32)
hints)
(defun wm-zoom-hints (window)
(declare (type window window)
(values wm-size-hints))
(decode-wm-size-hints (get-property window :wm_zoom_hints :type :wm_size_hints :result-type 'vector)))
(defsetf wm-zoom-hints set-wm-zoom-hints)
(defun set-wm-zoom-hints (window hints)
(declare (type window window)
(type wm-size-hints hints)
(values wm-size-hints))
(change-property window :wm_zoom_hints (encode-wm-size-hints hints) :wm_size_hints 32)
hints)
(defun decode-wm-size-hints (vector)
(declare (type (or null (simple-vector 15)) vector)
(values (or null wm-size-hints)))
(when vector
(let ((usposition 0) ;User Specified position
(ussize 1) ;User Specified size
(pposition 2) ;Program specified position
(psize 3) ;Program specified size
(pminsize 4) ;Program specified minimum size
(pmaxsize 5) ;Program specified maximum size
(presizeinc 6) ;Program specified resize increments
(paspect 7) ;Program specfied min and max aspect ratios
)
(let ((flags (aref vector 0))
(hints (make-wm-size-hints)))
(declare (type card16 flags)
(type wm-size-hints hints))
(when (or (logbitp usposition flags)
(logbitp pposition flags))
(setf (wm-size-hints-user-specified-position-p hints) (logbitp usposition flags)
(wm-size-hints-x hints) (aref vector 1)
(wm-size-hints-y hints) (aref vector 2)))
(when (or (logbitp ussize flags)
(logbitp psize flags))
(setf (wm-size-hints-user-specified-size-p hints) (logbitp usposition flags)
(wm-size-hints-width hints) (aref vector 3)
(wm-size-hints-height hints) (aref vector 4)))
(when (logbitp pminsize flags)
(setf (wm-size-hints-min-width hints) (aref vector 5)
(wm-size-hints-min-height hints) (aref vector 6)))
(when (logbitp pmaxsize flags)
(setf (wm-size-hints-max-width hints) (aref vector 7)
(wm-size-hints-max-height hints) (aref vector 8)))
(when (logbitp presizeinc flags)
(setf (wm-size-hints-width-inc hints) (aref vector 9)
(wm-size-hints-height-inc hints) (aref vector 10)))
(when (logbitp paspect flags)
(setf (wm-size-hints-min-aspect hints) (/ (aref vector 11) (aref vector 12))
(wm-size-hints-max-aspect hints) (/ (aref vector 13) (aref vector 14))))
hints))))
(defun encode-wm-size-hints (hints)
(declare (type wm-size-hints hints)
(values simple-vector))
(let ((usposition #b1) ;User Specified position
(ussize #b10) ;User Specified size
(pposition #b100) ;Program specified position
(psize #b1000) ;Program specified size
(pminsize #b10000) ;Program specified minimum size
(pmaxsize #b100000) ;Program specified maximum size
(presizeinc #b1000000) ;Program specified resize increments
(paspect #b10000000) ;Program specfied min and max aspect ratios
)
(let ((vector (make-array 15 :initial-element 0))
(flags 0))
(declare (type (simple-vector 15) vector)
(type card16 flags))
(when (and (wm-size-hints-x hints) (wm-size-hints-y hints))
(setq flags (if (wm-size-hints-user-specified-position-p hints) usposition pposition))
(setf (aref vector 1) (wm-size-hints-x hints)
(aref vector 2) (wm-size-hints-y hints)))
(when (and (wm-size-hints-width hints) (wm-size-hints-height hints))
(setf flags (logior flags (if (wm-size-hints-user-specified-position-p hints) ussize psize))
(aref vector 3) (wm-size-hints-width hints)
(aref vector 4) (wm-size-hints-height hints)))
(when (and (wm-size-hints-min-width hints) (wm-size-hints-min-height hints))
(setf flags (logior flags pminsize)
(aref vector 5) (wm-size-hints-min-width hints)
(aref vector 6) (wm-size-hints-min-height hints)))
(when (and (wm-size-hints-max-width hints) (wm-size-hints-max-height hints))
(setf flags (logior flags pmaxsize)
(aref vector 7) (wm-size-hints-max-width hints)
(aref vector 8) (wm-size-hints-max-height hints)))
(when (and (wm-size-hints-width-inc hints) (wm-size-hints-height-inc hints))
(setf flags (logior flags presizeinc)
(aref vector 9) (wm-size-hints-width-inc hints)
(aref vector 10) (wm-size-hints-height-inc hints)))
(let ((min-aspect (wm-size-hints-min-aspect hints))
(max-aspect (wm-size-hints-max-aspect hints)))
(when (and min-aspect max-aspect)
(setf flags (logior flags paspect)
min-aspect (rationalize min-aspect)
max-aspect (rationalize max-aspect)
(aref vector 11) (numerator min-aspect)
(aref vector 12) (denominator min-aspect)
(aref vector 13) (numerator max-aspect)
(aref vector 14) (denominator max-aspect))))
(setf (aref vector 0) flags)
vector)))